Implement the unpack command

package.yaml

@@ -261,6 +261,7 @@ library:
   - Stack.Types.TemplateName
   - Stack.Types.Version
   - Stack.Types.VersionIntervals
+  - Stack.Unpack
   - Stack.Upgrade
   - Stack.Upload
   - Text.PrettyPrint.Leijen.Extended

src/Stack/Build/Target.hs

@@ -318,8 +318,8 @@ resolveRawTarget globals snap deps locals (ri, rt) =
           , rrPackageType = Dependency
           }
       | otherwise = do
-          mversion <- getLatestVersion $ toCabalPackageName name
-          return $ case fromCabalVersion <$> mversion of
+          mversion <- getLatestHackageVersion $ toCabalPackageName name
+          return $ case first fromCabalVersion <$> mversion of
             -- This is actually an error case. We _could_ return a
             -- Left value here, but it turns out to be better to defer
             -- this until the ConstructPlan phase, and let it complain
@@ -333,16 +333,13 @@ resolveRawTarget globals snap deps locals (ri, rt) =
               , rrAddedDep = Nothing
               , rrPackageType = Dependency
               }
-            Just version -> Right ResolveResult
+            Just (version, _cabalHash) -> Right ResolveResult
               { rrName = name
               , rrRaw = ri
               , rrComponent = Nothing
               , rrAddedDep = Just version
               , rrPackageType = Dependency
               }
-      where
-        getLatestVersion pn =
-            fmap fst . Set.maxView . Map.keysSet <$> getPackageVersions pn
 
     go (RTPackageIdentifier ident@(PackageIdentifier name version))
       | Map.member name locals = return $ Left $ T.concat

src/Stack/Hoogle.hs

@@ -11,8 +11,6 @@ module Stack.Hoogle
 import           Stack.Prelude
 import qualified Data.ByteString.Lazy.Char8 as BL8
 import           Data.Char (isSpace)
-import qualified Data.Set as Set
-import qualified RIO.Map as Map
 import qualified Data.Text as T
 import           Path (parseAbsFile)
 import           Path.IO hiding (findExecutable)
@@ -85,17 +83,19 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do
     installHoogle :: RIO EnvConfig ()
     installHoogle = do
         hooglePackageIdentifier <- do
-          versions <- getPackageVersions $ toCabalPackageName hooglePackageName
+          mversion <- getLatestHackageVersion $ toCabalPackageName hooglePackageName
 
           -- FIXME For a while, we've been following the logic of
           -- taking the latest Hoogle version available. However, we
           -- may want to instead grab the version of Hoogle present in
           -- the snapshot current being used instead.
           pure $ fromMaybe (Left hoogleMinIdent) $ do
-            (verC, _) <- Set.maxView $ Map.keysSet versions
+            (verC, cabalHash) <- mversion
             let ver = fromCabalVersion verC
             guard $ ver >= hoogleMinVersion
-            Just $ Right $ PackageIdentifier hooglePackageName ver
+            Just $ Right $ PackageIdentifierRevision
+              (PackageIdentifier hooglePackageName ver)
+              (CFIHash Nothing cabalHash) -- FIXME populate this Nothing
 
         case hooglePackageIdentifier of
             Left{} -> logInfo $
@@ -119,11 +119,12 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do
                                 (const (return ()))
                                 lk
                                 defaultBuildOptsCLI
-                                { boptsCLITargets = [ packageIdentifierText
-                                                          (either
-                                                               id
-                                                               id
-                                                               hooglePackageIdentifier)]
+                                { boptsCLITargets =
+                                    pure $
+                                    either
+                                     packageIdentifierText
+                                     (fromString . packageIdentifierRevisionString)
+                                     hooglePackageIdentifier
                                 }))
                  (\(e :: ExitCode) ->
                        case e of

src/Stack/Setup.hs

@@ -698,10 +698,10 @@ upgradeCabal wc upgradeTo = do
                   RIO.display installed <>
                   " is already installed"
         Latest -> do
-          versions <- getPackageVersions $ toCabalPackageName name
-          case fmap (fromCabalVersion . fst) $ Set.maxView $ Map.keysSet versions of
+          mversion <- getLatestHackageVersion $ toCabalPackageName name
+          case mversion of
             Nothing -> throwString "No Cabal library found in index, cannot upgrade"
-            Just latestVersion -> do
+            Just (fromCabalVersion -> latestVersion, _cabalHash) -> do
                 if installed < latestVersion then
                     doCabalInstall wc installed latestVersion
                 else

src/Stack/Types/PackageIdentifier.hs

@@ -183,6 +183,9 @@ parsePackageIdentifierRevision x = go x
 packageIdentifierString :: PackageIdentifier -> String
 packageIdentifierString (PackageIdentifier n v) = show n ++ "-" ++ show v
 
+instance Display PackageIdentifierRevision where
+  display = fromString . packageIdentifierRevisionString
+
 -- | Get a string representation of the package identifier with revision; name-ver[@hashtype:hash[,size]].
 packageIdentifierRevisionString :: PackageIdentifierRevision -> String
 packageIdentifierRevisionString (PackageIdentifierRevision ident cfi) =

src/Stack/Unpack.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Stack.Unpack
+  ( unpackPackages
+  ) where
+
+import Stack.Prelude
+import Stack.Types.BuildPlan
+import Stack.Types.PackageName
+import Stack.Types.PackageIdentifier
+import Stack.Types.Version
+import qualified RIO.Text as T
+import qualified RIO.Map as Map
+import qualified RIO.Set as Set
+import Pantry
+import RIO.Directory (doesDirectoryExist)
+import RIO.List (intercalate)
+import RIO.FilePath ((</>))
+
+data UnpackException
+  = UnpackDirectoryAlreadyExists (Set FilePath)
+  | CouldNotParsePackageSelectors [String]
+    deriving Typeable
+instance Exception UnpackException
+instance Show UnpackException where
+    show (UnpackDirectoryAlreadyExists dirs) = unlines
+        $ "Unable to unpack due to already present directories:"
+        : map ("    " ++) (Set.toList dirs)
+    show (CouldNotParsePackageSelectors strs) =
+        "The following package selectors are not valid package names or identifiers: " ++
+        intercalate ", " strs
+
+-- | Intended to work for the command line command.
+unpackPackages
+  :: (HasPantryConfig env, HasLogFunc env)
+  => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan
+  -> FilePath -- ^ destination
+  -> [String] -- ^ names or identifiers
+  -> RIO env ()
+unpackPackages mSnapshotDef dest input = do
+    let (errs1, (names, pirs1)) =
+          fmap partitionEithers $ partitionEithers $ map parse input
+    (errs2, pirs2) <- fmap partitionEithers $ traverse toPIR names
+    case errs1 ++ errs2 of
+      [] -> pure ()
+      errs -> throwM $ CouldNotParsePackageSelectors errs
+    let pirs = Map.fromList $ map
+          (\pir@(PackageIdentifierRevision ident _) ->
+               ( pir
+               , dest </> packageIdentifierString ident
+               )
+          )
+          (pirs1 ++ pirs2)
+
+    alreadyUnpacked <- filterM doesDirectoryExist $ Map.elems pirs
+
+    unless (null alreadyUnpacked) $
+        throwM $ UnpackDirectoryAlreadyExists $ Set.fromList alreadyUnpacked
+
+    forM_ (Map.toList pirs) $ \(pir, dest') -> do
+      let PackageIdentifierRevision (PackageIdentifier name ver) cfi = pir
+      unpackPackageIdent
+        dest'
+        (toCabalPackageName name)
+        (toCabalVersion ver)
+        cfi
+      logInfo $
+        "Unpacked " <>
+        display pir <>
+        " to " <>
+        fromString dest'
+  where
+    toPIR = maybe toPIRNoSnapshot toPIRSnapshot mSnapshotDef
+
+    toPIRNoSnapshot name = do
+      mver <- getLatestHackageVersion $ toCabalPackageName name
+      pure $
+        case mver of
+          -- consider updating the index
+          Nothing -> Left $ "Could not find package " ++ packageNameString name
+          Just (ver, cabalHash) -> Right $ PackageIdentifierRevision
+            (PackageIdentifier name (fromCabalVersion ver))
+            (CFIHash Nothing cabalHash) -- FIXME get the actual size
+
+    toPIRSnapshot sd name =
+        pure $
+          case mapMaybe go $ sdLocations sd of
+            [] -> Left $ "Package does not appear in snapshot: " ++ packageNameString name
+            pir:_ -> Right pir
+      where
+        -- FIXME should work for things besides PLIndex
+        go (PLIndex pir@(PackageIdentifierRevision (PackageIdentifier name' _) _))
+          | name == name' = Just pir
+        go _ = Nothing
+
+    -- Possible future enhancement: parse names as name + version range
+    parse s =
+        case parsePackageName t of
+            Right x -> Right $ Left x
+            Left _ ->
+                case parsePackageIdentifierRevision t of
+                    Right x -> Right $ Right x
+                    Left _ -> Left s
+      where
+        t = T.pack s
+
+{- FIXME
+-- | Resolve a set of package names and identifiers into @FetchPackage@ values.
+resolvePackages :: HasCabalLoader env
+                => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan
+                -> [PackageIdentifierRevision]
+                -> Set PackageName
+                -> RIO env [ResolvedPackage]
+resolvePackages mSnapshotDef idents0 names0 = do
+    eres <- go
+    case eres of
+        Left _ -> do
+            updateAllIndices
+            go >>= either throwM return
+        Right x -> return x
+  where
+    go = r <$> getUses00Index <*> resolvePackagesAllowMissing mSnapshotDef idents0 names0
+    r uses00Index (missingNames, missingIdents, idents)
+      | not $ Set.null missingNames  = Left $ UnknownPackageNames       missingNames
+      | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" uses00Index
+      | otherwise                    = Right idents
+-}

src/main/Main.hs

@@ -100,6 +100,7 @@ import           Stack.Types.Config
 import           Stack.Types.Compiler
 import           Stack.Types.NamedComponent
 import           Stack.Types.Nix
+import           Stack.Unpack
 import           Stack.Upgrade
 import qualified Stack.Upload as Upload
 import qualified System.Directory as D

subs/pantry/src/Pantry.hs

@@ -18,13 +18,13 @@ module Pantry
     -- * Hackage index
   , updateHackageIndex
   , hackageIndexTarballL
+  , getLatestHackageVersion
 
     -- * FIXME legacy from Stack, to be updated
   , loadFromIndex
   , getPackageVersions
   , fetchPackages
   , unpackPackageIdent
-  , unpackPackages
   ) where
 
 import RIO
@@ -190,6 +190,15 @@ getPackageVersions
   -> RIO env (Map Version CabalHash)
 getPackageVersions = withStorage . loadHackagePackageVersions
 
+-- | Returns the latest version of the given package available from
+-- Hackage.
+getLatestHackageVersion
+  :: (HasPantryConfig env, HasLogFunc env)
+  => PackageName -- ^ package name
+  -> RIO env (Maybe (Version, CabalHash))
+getLatestHackageVersion =
+  fmap (fmap fst . Map.maxViewWithKey) . getPackageVersions
+
 fetchPackages :: a
 fetchPackages = undefined
 
@@ -199,8 +208,5 @@ unpackPackageIdent
   -> PackageName
   -> Version
   -> CabalFileInfo
-  -> RIO env FilePath
+  -> RIO env FilePath -- FIXME remove this FilePath return, make it flat
 unpackPackageIdent = undefined
-
-unpackPackages :: a
-unpackPackages = undefined

subs/pantry/src/Pantry/Fetch.hs

@@ -23,8 +23,6 @@ module Stack.Fetch
     , unpackPackageIdents
     , fetchPackages
     , untar
-    , resolvePackages
-    , resolvePackagesAllowMissing
     , ResolvedPackage (..)
     ) where
 
@@ -64,8 +62,6 @@ import              System.PosixCompat (setFileMode)
 data FetchException
     = Couldn'tReadIndexTarball FilePath Tar.FormatError
     | Couldn'tReadPackageTarball FilePath SomeException
-    | UnpackDirectoryAlreadyExists (Set FilePath)
-    | CouldNotParsePackageSelectors [String]
     | UnknownPackageNames (Set PackageName)
     | UnknownPackageIdentifiers (HashSet PackageIdentifierRevision) String
         Bool -- Do we use any 00-index.tar.gz indices? Just used for more informative error messages
@@ -85,12 +81,6 @@ instance Show FetchException where
         , ": "
         , show err
         ]
-    show (UnpackDirectoryAlreadyExists dirs) = unlines
-        $ "Unable to unpack due to already present directories:"
-        : map ("    " ++) (Set.toList dirs)
-    show (CouldNotParsePackageSelectors strs) =
-        "The following package selectors are not valid package names or identifiers: " ++
-        intercalate ", " strs
     show (UnknownPackageNames names) =
         "The following packages were not found in your indices: " ++
         intercalate ", " (map packageNameString $ Set.toList names)
@@ -113,39 +103,6 @@ fetchPackages idents' = do
     -- always provide a CFILatest cabal file info
     idents = map (flip PackageIdentifierRevision CFILatest) $ Set.toList idents'
 
--- | Intended to work for the command line command.
-unpackPackages :: HasCabalLoader env
-               => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan
-               -> FilePath -- ^ destination
-               -> [String] -- ^ names or identifiers
-               -> RIO env ()
-unpackPackages mSnapshotDef dest input = do
-    dest' <- resolveDir' dest
-    (names, idents) <- case partitionEithers $ map parse input of
-        ([], x) -> return $ partitionEithers x
-        (errs, _) -> throwM $ CouldNotParsePackageSelectors errs
-    resolved <- resolvePackages mSnapshotDef idents (Set.fromList names)
-    ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved
-    unless (Map.null alreadyUnpacked) $
-        throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked
-    unpacked <- fetchPackages' Nothing toFetch
-    F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> logInfo $
-        "Unpacked " <>
-        fromString (packageIdentifierString ident) <>
-        " to " <>
-        fromString (toFilePath dest'')
-  where
-    -- Possible future enhancement: parse names as name + version range
-    parse s =
-        case parsePackageName t of
-            Right x -> Right $ Left x
-            Left _ ->
-                case parsePackageIdentifierRevision t of
-                    Right x -> Right $ Right x
-                    Left _ -> Left s
-      where
-        t = T.pack s
-
 -- | Same as 'unpackPackageIdents', but for a single package.
 unpackPackageIdent
     :: HasCabalLoader env
@@ -185,35 +142,6 @@ data ResolvedPackage = ResolvedPackage
     }
     deriving Show
 
--- | Resolve a set of package names and identifiers into @FetchPackage@ values.
-resolvePackages :: HasCabalLoader env
-                => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan
-                -> [PackageIdentifierRevision]
-                -> Set PackageName
-                -> RIO env [ResolvedPackage]
-resolvePackages mSnapshotDef idents0 names0 = do
-    eres <- go
-    case eres of
-        Left _ -> do
-            updateAllIndices
-            go >>= either throwM return
-        Right x -> return x
-  where
-    go = r <$> getUses00Index <*> resolvePackagesAllowMissing mSnapshotDef idents0 names0
-    r uses00Index (missingNames, missingIdents, idents)
-      | not $ Set.null missingNames  = Left $ UnknownPackageNames       missingNames
-      | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" uses00Index
-      | otherwise                    = Right idents
-
--- | Does the configuration use a 00-index.tar.gz file for indices?
--- See <https://github.com/commercialhaskell/stack/issues/3520>
-getUses00Index :: HasCabalLoader env => RIO env Bool
-getUses00Index =
-    any is00 <$> view (cabalLoaderL.to clIndices)
-  where
-    is00 :: PackageIndex -> Bool
-    is00 index = "00-index.tar.gz" `T.isInfixOf` indexLocation index
-
 -- | Turn package identifiers and package names into a list of
 -- @ResolvedPackage@s. Returns any unresolved names and
 -- identifier. These are considered unresolved even if the only