diff --git a/package.yaml b/package.yaml index db4a8e355a..1a49d897c6 100644 --- a/package.yaml +++ b/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 diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index e0bba2a633..dd7d4e12a8 100644 --- a/src/Stack/Build/Target.hs +++ b/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 diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 111deed64b..98beda7cfd 100644 --- a/src/Stack/Hoogle.hs +++ b/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 diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 2287c6cdc9..ce996ce1a9 100644 --- a/src/Stack/Setup.hs +++ b/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 diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index b606ad834a..28c3fc58ec 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/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) = diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs new file mode 100644 index 0000000000..7156afdc8e --- /dev/null +++ b/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 +-} diff --git a/src/main/Main.hs b/src/main/Main.hs index 20689796c3..3e4992bcdd 100644 --- a/src/main/Main.hs +++ b/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 diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 8a6689e9a5..fbc4791cc6 100644 --- a/subs/pantry/src/Pantry.hs +++ b/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 diff --git a/subs/pantry/src/Pantry/Fetch.hs b/subs/pantry/src/Pantry/Fetch.hs index 6b49bdf852..948c459552 100644 --- a/subs/pantry/src/Pantry/Fetch.hs +++ b/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 -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