Add command-line options --hash and --no-hash

src/Hpack.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
 module Hpack (
 -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into
@@ -32,10 +33,12 @@ module Hpack (
 , Verbose(..)
 , Options(..)
 , Force(..)
+, GenerateHashStrategy(..)
 
 #ifdef TEST
 , hpackResultWithVersion
 , header
+, renderCabalFile
 #endif
 ) where
 
@@ -47,6 +50,7 @@ import           System.Environment
 import           System.Exit
 import           System.IO (stderr)
 import           Data.Aeson (Value)
+import           Data.Maybe
 
 import           Paths_hpack (version)
 import           Hpack.Options
@@ -56,41 +60,48 @@ import           Hpack.Util
 import           Hpack.Utf8 as Utf8
 import           Hpack.CabalFile
 
-programVersion :: Version -> String
-programVersion v = "hpack version " ++ Version.showVersion v
+programVersion :: Maybe Version -> String
+programVersion Nothing = "hpack"
+programVersion (Just v) = "hpack version " ++ Version.showVersion v
 
-header :: FilePath -> Version -> Hash -> String
-header p v hash = unlines [
+header :: FilePath -> Maybe Version -> (Maybe Hash) -> [String]
+header p v hash = [
     "-- This file has been generated from " ++ takeFileName p ++ " by " ++ programVersion v ++ "."
   , "--"
   , "-- see: https://github.com/sol/hpack"
-  , "--"
-  , "-- hash: " ++ hash
-  , ""
-  ]
+  ] ++ case hash of
+    Just h -> ["--" , "-- hash: " ++ h, ""]
+    Nothing -> [""]
 
 data Options = Options {
   optionsDecodeOptions :: DecodeOptions
 , optionsForce :: Force
+, optionsGenerateHashStrategy :: GenerateHashStrategy
 , optionsToStdout :: Bool
 }
 
+data GenerateHashStrategy = ForceHash | ForceNoHash | PreferHash | PreferNoHash
+  deriving (Eq, Show)
+
 getOptions :: FilePath -> [String] -> IO (Maybe (Verbose, Options))
 getOptions defaultPackageConfig args = do
   result <- parseOptions defaultPackageConfig args
   case result of
     PrintVersion -> do
-      putStrLn (programVersion version)
+      putStrLn (programVersion $ Just version)
       return Nothing
     PrintNumericVersion -> do
       putStrLn (Version.showVersion version)
       return Nothing
     Help -> do
       printHelp
       return Nothing
-    Run options -> case options of
-      ParseOptions verbose force toStdout file -> do
-        return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force toStdout)
+    Run (ParseOptions verbose force hash toStdout file) -> do
+      let generateHash = case hash of
+            Just True -> ForceHash
+            Just False -> ForceNoHash
+            Nothing -> PreferNoHash
+      return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force generateHash toStdout)
     ParseError -> do
       printHelp
       exitFailure
@@ -99,7 +110,7 @@ printHelp :: IO ()
 printHelp = do
   name <- getProgName
   Utf8.hPutStrLn stderr $ unlines [
-      "Usage: " ++ name ++ " [ --silent ] [ --force | -f ] [ PATH ] [ - ]"
+      "Usage: " ++ name ++ " [ --silent ] [ --force | -f ] [ --[no-]hash ] [ PATH ] [ - ]"
     , "       " ++ name ++ " --version"
     , "       " ++ name ++ " --numeric-version"
     , "       " ++ name ++ " --help"
@@ -109,7 +120,7 @@ hpack :: Verbose -> Options -> IO ()
 hpack verbose options = hpackResult options >>= printResult verbose
 
 defaultOptions :: Options
-defaultOptions = Options defaultDecodeOptions NoForce False
+defaultOptions = Options defaultDecodeOptions NoForce PreferNoHash False
 
 setTarget :: FilePath -> Options -> Options
 setTarget target options@Options{..} =
@@ -154,41 +165,76 @@ printResult verbose r = do
 printWarnings :: [String] -> IO ()
 printWarnings = mapM_ $ Utf8.hPutStrLn stderr . ("WARNING: " ++)
 
-mkStatus :: [String] -> Version -> CabalFile -> Status
-mkStatus new v (CabalFile mOldVersion mHash old) = case (mOldVersion, mHash) of
-  (_, _) | old == new -> OutputUnchanged
-  (Nothing, _) -> ExistingCabalFileWasModifiedManually
-  (Just oldVersion, _) | oldVersion < makeVersion [0, 20, 0] -> Generated
-  (_, Nothing) -> ExistingCabalFileWasModifiedManually
-  (Just oldVersion, Just hash)
-    | v < oldVersion -> AlreadyGeneratedByNewerHpack
-    | sha256 (unlines old) /= hash -> ExistingCabalFileWasModifiedManually
-    | otherwise -> Generated
+mkStatus :: CabalFile -> CabalFile -> Status
+mkStatus new@(CabalFile _ mNewVersion mNewHash _) existing@(CabalFile _ mExistingVersion _ _)
+  | new `hasSameContent` existing = OutputUnchanged
+  | otherwise = case mExistingVersion of
+      Nothing -> ExistingCabalFileWasModifiedManually
+      Just _
+        | mNewVersion < mExistingVersion -> AlreadyGeneratedByNewerHpack
+        | isJust mNewHash && hashMismatch existing -> ExistingCabalFileWasModifiedManually
+        | otherwise -> Generated
+
+hasSameContent :: CabalFile -> CabalFile -> Bool
+hasSameContent (CabalFile cabalVersionA _ _ a) (CabalFile cabalVersionB _ _ b) = cabalVersionA == cabalVersionB && a == b
+
+hashMismatch :: CabalFile -> Bool
+hashMismatch cabalFile = case cabalFileHash cabalFile of
+  Nothing -> False
+  Just hash -> hash /= calculateHash cabalFile
+
+calculateHash :: CabalFile -> Hash
+calculateHash (CabalFile cabalVersion _ _ body) = sha256 (unlines $ cabalVersion ++ body)
 
 hpackResult :: Options -> IO Result
 hpackResult = hpackResultWithVersion version
 
 hpackResultWithVersion :: Version -> Options -> IO Result
-hpackResultWithVersion v (Options options force toStdout) = do
-  DecodeResult pkg cabalVersion cabalFile warnings <- readPackageConfig options >>= either die return
-  oldCabalFile <- readCabalFile cabalFile
-  let
-    body = renderPackage (maybe [] cabalFileContents oldCabalFile) pkg
-    withoutHeader = cabalVersion ++ body
+hpackResultWithVersion v (Options options force generateHashStrategy toStdout) = do
+  DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings <- readPackageConfig options >>= either die return
+  mExistingCabalFile <- readCabalFile cabalFileName
   let
+    newCabalFile = makeCabalFile generateHashStrategy mExistingCabalFile cabalVersion v pkg
+
     status = case force of
       Force -> Generated
-      NoForce -> maybe Generated (mkStatus (lines withoutHeader) v) oldCabalFile
+      NoForce -> maybe Generated (mkStatus newCabalFile) mExistingCabalFile
+
   case status of
-    Generated -> do
-      let hash = sha256 withoutHeader
-          out  = cabalVersion ++ header (decodeOptionsTarget options) v hash ++ body
-      if toStdout
-        then Utf8.putStr out
-        else Utf8.writeFile cabalFile out
+    Generated -> writeCabalFile options toStdout cabalFileName newCabalFile
     _ -> return ()
+
   return Result {
-      resultWarnings = warnings
-    , resultCabalFile = cabalFile
-    , resultStatus = status
-    }
+    resultWarnings = warnings
+  , resultCabalFile = cabalFileName
+  , resultStatus = status
+  }
+
+writeCabalFile :: DecodeOptions -> Bool -> FilePath -> CabalFile -> IO ()
+writeCabalFile options toStdout name cabalFile = do
+  write . unlines $ renderCabalFile (decodeOptionsTarget options) cabalFile
+  where
+    write = if toStdout then Utf8.putStr else Utf8.writeFile name
+
+makeCabalFile :: GenerateHashStrategy -> Maybe CabalFile -> [String] -> Version -> Package -> CabalFile
+makeCabalFile strategy mExistingCabalFile cabalVersion v pkg = cabalFile
+  where
+    cabalFile = CabalFile cabalVersion (Just v) hash body
+
+    hash
+      | shouldGenerateHash mExistingCabalFile strategy = Just $ calculateHash cabalFile
+      | otherwise = Nothing
+
+    body = lines $ renderPackage (maybe [] cabalFileContents mExistingCabalFile) pkg
+
+shouldGenerateHash :: Maybe CabalFile -> GenerateHashStrategy -> Bool
+shouldGenerateHash mExistingCabalFile strategy = case (strategy, mExistingCabalFile) of
+  (ForceHash, _) -> True
+  (ForceNoHash, _) -> False
+  (PreferHash, Nothing) -> True
+  (PreferNoHash, Nothing) -> False
+  (_, Just CabalFile {cabalFileHash = Nothing}) -> False
+  (_, Just CabalFile {cabalFileHash = Just _}) -> True
+
+renderCabalFile :: FilePath -> CabalFile -> [String]
+renderCabalFile file (CabalFile cabalVersion hpackVersion hash body) = cabalVersion ++ header file hpackVersion hash ++ body

src/Hpack/CabalFile.hs

@@ -16,7 +16,8 @@ makeVersion :: [Int] -> Version
 makeVersion v = Version v []
 
 data CabalFile = CabalFile {
-  cabalFileHpackVersion :: Maybe Version
+  cabalFileCabalVersion :: [String]
+, cabalFileHpackVersion :: Maybe Version
 , cabalFileHash :: Maybe Hash
 , cabalFileContents :: [String]
 } deriving (Eq, Show)
@@ -25,13 +26,13 @@ readCabalFile :: FilePath -> IO (Maybe CabalFile)
 readCabalFile cabalFile = fmap parse <$> tryReadFile cabalFile
   where
     parse :: String -> CabalFile
-    parse (splitHeader -> (h, c)) = CabalFile (extractVersion h) (extractHash h) c
+    parse (splitHeader -> (cabalVersion, h, c)) = CabalFile cabalVersion (extractVersion h) (extractHash h) c
 
-    splitHeader :: String -> ([String], [String])
+    splitHeader :: String -> ([String], [String], [String])
     splitHeader (removeGitConflictMarkers . lines -> c) =
       case span (not . isComment) c of
         (cabalVersion, xs) -> case span isComment xs of
-          (header, body) -> (header, cabalVersion ++ dropWhile null body)
+          (header, body) -> (cabalVersion, header, dropWhile null body)
 
     isComment = ("--" `isPrefixOf`)
 

src/Hpack/Options.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE LambdaCase #-}
 module Hpack.Options where
 
+import           Control.Applicative
+import           Control.Monad
+import           Data.Maybe
 import           System.FilePath
 import           System.Directory
 
@@ -16,6 +19,7 @@ data Force = Force | NoForce
 data ParseOptions = ParseOptions {
   parseOptionsVerbose :: Verbose
 , parseOptionsForce :: Force
+, parseOptionsHash :: Maybe Bool
 , parseOptionsToStdout :: Bool
 , parseOptionsTarget :: FilePath
 } deriving (Eq, Show)
@@ -30,18 +34,30 @@ parseOptions defaultTarget = \ case
       file <- expandTarget defaultTarget target
       let
         options
-          | toStdout = ParseOptions NoVerbose Force toStdout file
-          | otherwise = ParseOptions verbose force toStdout file
+          | toStdout = ParseOptions NoVerbose Force hash toStdout file
+          | otherwise = ParseOptions verbose force hash toStdout file
       return (Run options)
     Left err -> return err
     where
       silentFlag = "--silent"
       forceFlags = ["--force", "-f"]
+      hashFlag = "--hash"
+      noHashFlag = "--no-hash"
 
-      flags = silentFlag : forceFlags
+      flags = hashFlag : noHashFlag : silentFlag : forceFlags
 
+      verbose :: Verbose
       verbose = if silentFlag `elem` args then NoVerbose else Verbose
+
+      force :: Force
       force = if any (`elem` args) forceFlags then Force else NoForce
+
+      hash :: Maybe Bool
+      hash = listToMaybe . reverse $ mapMaybe parse args
+        where
+          parse :: String -> Maybe Bool
+          parse t = True <$ guard (t == hashFlag) <|> False <$ guard (t == noHashFlag)
+
       ys = filter (`notElem` flags) args
 
       targets :: Either ParseResult (Maybe FilePath, Bool)

test/Hpack/CabalFileSpec.hs

@@ -9,9 +9,15 @@ import           Data.String.Interpolate.Util
 
 import           Paths_hpack (version)
 
+import           Hpack.Util (Hash)
+import           Data.Version (Version)
 import           Hpack (header)
+
 import           Hpack.CabalFile
 
+mkHeader :: FilePath -> Version -> Hash -> String
+mkHeader p v hash = unlines $ header p (Just v) (Just hash)
+
 spec :: Spec
 spec = do
   describe "readCabalFile" $ do
@@ -21,13 +27,13 @@ spec = do
 
     it "includes hash" $ do
       inTempDirectory $ do
-        writeFile file $ header "package.yaml" version hash
-        readCabalFile file `shouldReturn` Just (CabalFile (Just version) (Just hash) [])
+        writeFile file $ mkHeader "package.yaml" version hash
+        readCabalFile file `shouldReturn` Just (CabalFile [] (Just version) (Just hash) [])
 
     it "accepts cabal-version at the beginning of the file" $ do
       inTempDirectory $ do
-        writeFile file $ ("cabal-version: 2.2\n" ++ header "package.yaml" version hash)
-        readCabalFile file `shouldReturn` Just (CabalFile (Just version) (Just hash) ["cabal-version: 2.2"])
+        writeFile file $ ("cabal-version: 2.2\n" ++ mkHeader "package.yaml" version hash)
+        readCabalFile file `shouldReturn` Just (CabalFile ["cabal-version: 2.2"] (Just version) (Just hash) [])
 
   describe "extractVersion" $ do
     it "extracts Hpack version from a cabal file" $ do

test/Hpack/OptionsSpec.hs

@@ -18,30 +18,42 @@ spec = do
 
     context "by default" $ do
       it "returns Run" $ do
-        parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce False defaultTarget)
+        parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False defaultTarget)
 
       it "includes target" $ do
-        parseOptions defaultTarget ["foo.yaml"] `shouldReturn` Run (ParseOptions Verbose NoForce False "foo.yaml")
+        parseOptions defaultTarget ["foo.yaml"] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False "foo.yaml")
 
       context "with superfluous arguments" $ do
         it "returns ParseError" $ do
           parseOptions defaultTarget ["foo", "bar"] `shouldReturn` ParseError
 
       context "with --silent" $ do
         it "sets optionsVerbose to NoVerbose" $ do
-          parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce False defaultTarget)
+          parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce Nothing False defaultTarget)
 
       context "with --force" $ do
         it "sets optionsForce to Force" $ do
-          parseOptions defaultTarget ["--force"] `shouldReturn` Run (ParseOptions Verbose Force False defaultTarget)
+          parseOptions defaultTarget ["--force"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget)
 
       context "with -f" $ do
         it "sets optionsForce to Force" $ do
-          parseOptions defaultTarget ["-f"] `shouldReturn` Run (ParseOptions Verbose Force False defaultTarget)
+          parseOptions defaultTarget ["-f"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget)
+
+      context "when determining parseOptionsHash" $ do
+
+        it "assumes True on --hash" $ do
+          parseOptions defaultTarget ["--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget)
+
+        it "assumes False on --no-hash" $ do
+          parseOptions defaultTarget ["--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget)
+
+        it "gives last occurrence precedence" $ do
+          parseOptions defaultTarget ["--no-hash", "--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget)
+          parseOptions defaultTarget ["--hash", "--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget)
 
       context "with -" $ do
         it "sets optionsToStdout to True, implies Force and NoVerbose" $ do
-          parseOptions defaultTarget ["-"] `shouldReturn` Run (ParseOptions NoVerbose Force True defaultTarget)
+          parseOptions defaultTarget ["-"] `shouldReturn` Run (ParseOptions NoVerbose Force Nothing True defaultTarget)
 
         it "rejects - for target" $ do
           parseOptions defaultTarget ["-", "-"] `shouldReturn` ParseError