Merge pull request #4220 from qrilka/pantry

[WIP] `stack freeze` command

ChangeLog.md

@@ -33,6 +33,9 @@ Major changes:
       changes, existing cache files will in general be invalidated,
       resulting in Stack needing to rebuild many previously cached
       builds in the new version. Sorry :(.
+    * A new command, `stack freeze` has been added which outputs
+      project and snapshot definitions with dependencies pinned to
+      their exact versions.
 
 Behavior changes:
 

doc/setting_up_dependencies.md

@@ -0,0 +1,38 @@
+# Dependency freezing
+
+To make builds reproducible it makes sense to pin project dependencies to some
+exact versions and this is what is stack's `freeze` command is about.
+
+## Project freezing
+
+The default mode of its invocation:
+
+```
+$ stack freeze
+```
+freezes the following fields from the project's `stack.yaml`
+
+* packages in `extra-deps` which do not include sha256 of their cabal files and
+  which do not specify pantry tree pointer of the package archive
+* `resolver` if it references a remote snapshot and if it does not specify
+  pantry tree pointer of its contents
+
+The command outputs to standard output new project's `stack.yaml` with these
+changes included.
+
+If a project is specified precisely enough stack tells about it and exits.
+
+## Snapshot freezing
+
+When a project uses some custom snapshot freezing dependencies defined in
+the project is not enough as a snapshot could also contain not precisely
+specified package references. To prevent this from happening `--snapshot` flag
+(or `-s` in its short form) of the `freeze` command could be used:
+
+```
+$ stack freeze --snapshot
+```
+
+In this mode `freeze` command works almost like in the default mode, the main
+differenc is that it works with the projects snapshot definition and thus it
+pins packages from its `packages` field and not from the project's `extra-deps`.

package.yaml

@@ -179,6 +179,7 @@ library:
   - Stack.Docker.GlobalDB
   - Stack.Dot
   - Stack.FileWatch
+  - Stack.Freeze
   - Stack.GhcPkg
   - Stack.Ghci
   - Stack.Ghci.Script
@@ -198,6 +199,7 @@ library:
   - Stack.Options.DockerParser
   - Stack.Options.DotParser
   - Stack.Options.ExecParser
+  - Stack.Options.FreezeParser
   - Stack.Options.GhcBuildParser
   - Stack.Options.GhciParser
   - Stack.Options.GhcVariantParser

src/Stack/Freeze.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Stack.Freeze
+    ( freeze
+    , FreezeOpts (..)
+    , FreezeMode (..)
+    ) where
+
+import qualified Data.Yaml as Yaml
+import qualified RIO.ByteString as B
+import           Stack.Prelude
+import           Stack.Types.BuildPlan
+import           Stack.Types.Config
+
+data FreezeMode = FreezeProject | FreezeSnapshot
+
+data FreezeOpts = FreezeOpts
+    { freezeMode :: FreezeMode
+    }
+
+freeze :: HasEnvConfig env => FreezeOpts -> RIO env ()
+freeze (FreezeOpts FreezeProject) = do
+  mproject <- view $ configL.to configMaybeProject
+  case mproject of
+    Just (p, _) -> do
+      let deps = projectDependencies p
+          resolver = projectResolver p
+          completePackageLocation' pl =
+            case pl of
+              PLImmutable pli -> PLImmutable <$> completePackageLocation pli
+              plm@(PLMutable _) -> pure plm
+      resolver' <- completeSnapshotLocation resolver
+      deps' <- mapM completePackageLocation' deps
+      if deps' == deps && resolver' == resolver
+      then
+        logInfo "No freezing is required for this project"
+      else
+        liftIO $ B.putStr $ Yaml.encode p{ projectDependencies = deps'
+                                         , projectResolver = resolver'
+                                         }
+    Nothing -> logWarn "No project was found: nothing to freeze"
+
+freeze (FreezeOpts FreezeSnapshot) = do
+  msnapshot <- view $ buildConfigL.to bcSnapshotDef.to sdSnapshot
+  case msnapshot of
+    Just (snap, _) -> do
+      snap' <- completeSnapshot snap
+      if snap' == snap
+      then
+        logInfo "No freezing is required for the snapshot of this project"
+      else
+        liftIO $ B.putStr $ Yaml.encode snap'
+    Nothing ->
+      logWarn "No snapshot was found: nothing to freeze"

src/Stack/Options/FreezeParser.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Stack.Options.FreezeParser where
+
+import           Data.Semigroup ((<>))
+import           Options.Applicative
+import           Stack.Freeze
+
+
+-- | Parser for arguments to `stack freeze`
+freezeOptsParser :: Parser FreezeOpts
+freezeOptsParser =
+  FreezeOpts <$> flag FreezeProject FreezeSnapshot
+                 ( long "snapshot"
+                   <> short 's'
+                   <> help "Freeze snapshot definition instead of project's stack.yaml" )

src/main/Main.hs

@@ -63,6 +63,7 @@ import           Stack.Dot
 import           Stack.GhcPkg (findGhcPkgField)
 import qualified Stack.Nix as Nix
 import           Stack.FileWatch
+import           Stack.Freeze
 import           Stack.Ghci
 import           Stack.Hoogle
 import           Stack.Ls
@@ -77,6 +78,7 @@ import           Stack.Options.DotParser
 import           Stack.Options.ExecParser
 import           Stack.Options.GhciParser
 import           Stack.Options.GlobalParser
+import           Stack.Options.FreezeParser
 
 import           Stack.Options.HpcReportParser
 import           Stack.Options.NewParser
@@ -388,6 +390,10 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions
                   "Run a Stack Script"
                   scriptCmd
                   scriptOptsParser
+      addCommand' "freeze"
+                  "Show project or snapshot with pinned dependencies if there are any such"
+                  freezeCmd
+                  freezeOptsParser
 
       unless isInterpreter (do
         addCommand' "eval"
@@ -1004,6 +1010,10 @@ queryCmd selectors go = withBuildConfig go $ queryBuildInfo $ map T.pack selecto
 hpcReportCmd :: HpcReportOpts -> GlobalOpts -> IO ()
 hpcReportCmd hropts go = withBuildConfig go $ generateHpcReportForTargets hropts
 
+freezeCmd :: FreezeOpts -> GlobalOpts -> IO ()
+freezeCmd freezeOpts go =
+  withBuildConfig go $ freeze freezeOpts
+
 data MainException = InvalidReExecVersion String String
                    | UpgradeCabalUnusable
                    | InvalidPathForExec FilePath

test/integration/tests/4220-freeze-command/Main.hs

@@ -0,0 +1,25 @@
+import Control.Monad (unless)
+import StackTest
+
+main :: IO ()
+main = do
+  stackCheckStdout ["freeze"] $ \stdOut -> do
+    let expected = unlines
+          [ "packages:"
+          , "- ."
+          , "extra-deps:"
+          , "- hackage: a50-0.5@sha256:b8dfcc13dcbb12e444128bb0e17527a2a7a9bd74ca9450d6f6862c4b394ac054,1491"
+          , "  pantry-tree:"
+          , "    size: 409"
+          , "    sha256: a7c6151a18b04afe1f13637627cad4deff91af51d336c4f33e95fc98c64c40d3"
+          , "resolver:"
+          , "  size: 527165"
+          , "  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/19.yaml"
+          , "  sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4"
+          ]
+    unless (stdOut == expected) $
+      error $ concat [ "Expected: "
+                   , show expected
+                   , "\nActual: "
+                   , show stdOut
+                   ]

test/integration/tests/4220-freeze-command/files/freeze-command.cabal

@@ -0,0 +1,12 @@
+name:           freeze-command
+version:        0.1.0.0
+build-type:     Simple
+cabal-version:  >= 2.0
+
+library
+  exposed-modules: Src
+  hs-source-dirs: src
+  build-depends: base
+               , rio
+               , vector
+  default-language: Haskell2010

test/integration/tests/4220-freeze-command/files/src/Src.hs

@@ -0,0 +1,5 @@
+module Src where
+
+-- | A function of the main library
+funMainLib :: Int -> Int
+funMainLib = succ

test/integration/tests/4220-freeze-command/files/stack.yaml

@@ -0,0 +1,5 @@
+resolver: lts-11.19
+packages:
+- .
+extra-deps:
+- a50-0.5@rev:0