stack freeze command

ChangeLog.md

@@ -15,6 +15,8 @@ Major changes:
       must be specified in `extra-deps`.
     * The `extra-dep` key in `packages` is no longer supported; please
       move any such specifications to `extra-deps`.
+* A new command, `stack freeze` has been added which outputs project
+  and snapshot definitions with dependencies pinned to their exact versions.
 
 Behavior changes:
 

package.yaml

@@ -183,6 +183,7 @@ library:
   - Stack.Docker.GlobalDB
   - Stack.Dot
   - Stack.FileWatch
+  - Stack.Freeze
   - Stack.GhcPkg
   - Stack.Ghci
   - Stack.Ghci.Script
@@ -202,6 +203,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,49 @@
+{-# 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
+      when (deps' /= deps || resolver' /= resolver) $
+        liftIO $ B.putStr $ Yaml.encode p{ projectDependencies = deps'
+                                         , projectResolver = resolver'
+                                         }
+    Nothing -> pure ()
+
+freeze (FreezeOpts FreezeSnapshot) = do
+  msnapshot <- view $ buildConfigL.to bcSnapshotDef.to sdSnapshot
+  case msnapshot of
+    Just (snap, _) -> do
+      snap' <- completeSnapshot snap
+      when (snap' /= snap) $
+        liftIO $ B.putStr $ Yaml.encode snap'
+    Nothing ->
+      return ()

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

@@ -64,6 +64,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
@@ -78,6 +79,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
@@ -389,6 +391,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"
@@ -1005,6 +1011,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

subs/pantry/src/Pantry/Types.hs

@@ -1214,30 +1214,17 @@ instance Store Snapshot
 instance NFData Snapshot
 instance ToJSON Snapshot where
   toJSON snap = object $ concat
-    [ case snapshotParent snap of
-        SLCompiler compiler -> ["compiler" .= compiler]
-        SLUrl url mblob mcompiler -> concat
-          [ pure $ "resolver" .= concat
-              [ ["url" .= url]
-              , maybe [] blobKeyPairs mblob
-              ]
-          , case mcompiler of
-              Nothing -> []
-              Just compiler -> ["compiler" .= compiler]
-          ]
-        SLFilePath resolved mcompiler -> concat
-          [ pure $ "resolver" .= object ["filepath" .= resolvedRelative resolved]
-          , case mcompiler of
-              Nothing -> []
-              Just compiler -> ["compiler" .= compiler]
-          ]
+    [ maybe [] (\cv -> ["compiler" .= cv]) compiler
+    , ["resolver" .= usl]
     , ["name" .= snapshotName snap]
     , ["packages" .= map mkUnresolvedPackageLocationImmutable (snapshotLocations snap)]
     , if Set.null (snapshotDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (snapshotDropPackages snap)]
     , if Map.null (snapshotFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (snapshotFlags snap))]
     , if Map.null (snapshotHidden snap) then [] else ["hidden" .= toCabalStringMap (snapshotHidden snap)]
     , if Map.null (snapshotGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (snapshotGhcOptions snap)]
     ]
+    where
+      (usl, compiler) = unresolveSnapshotLocation $ snapshotParent snap
 
 parseSnapshot :: Maybe (Path Abs Dir) -> Value -> Parser (WithJSONWarnings (IO Snapshot))
 parseSnapshot mdir = withObjectWarnings "Snapshot" $ \o -> do

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

@@ -0,0 +1,26 @@
+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:"
+          , "  blob:"
+          , "    size: 527165"
+          , "    sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4"
+          , "  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/19.yaml"
+          ]
+    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