pantry-0.4.0.2/attic/0000755000000000000000000000000013712324626012470 5ustar0000000000000000pantry-0.4.0.2/src/0000755000000000000000000000000013712324626012153 5ustar0000000000000000pantry-0.4.0.2/src/Hackage/0000755000000000000000000000000013712324605013473 5ustar0000000000000000pantry-0.4.0.2/src/Hackage/Security/0000755000000000000000000000000013712324605015302 5ustar0000000000000000pantry-0.4.0.2/src/Hackage/Security/Client/0000755000000000000000000000000013712324605016520 5ustar0000000000000000pantry-0.4.0.2/src/Hackage/Security/Client/Repository/0000755000000000000000000000000013712324605020677 5ustar0000000000000000pantry-0.4.0.2/src/Hackage/Security/Client/Repository/HttpLib/0000755000000000000000000000000013712324605022245 5ustar0000000000000000pantry-0.4.0.2/src/Pantry/0000755000000000000000000000000013712326407013427 5ustar0000000000000000pantry-0.4.0.2/src/Pantry/Internal/0000755000000000000000000000000013712324626015204 5ustar0000000000000000pantry-0.4.0.2/src/unix/0000755000000000000000000000000013712324605013133 5ustar0000000000000000pantry-0.4.0.2/src/unix/System/0000755000000000000000000000000013712324605014417 5ustar0000000000000000pantry-0.4.0.2/src/windows/0000755000000000000000000000000013712324605013642 5ustar0000000000000000pantry-0.4.0.2/src/windows/System/0000755000000000000000000000000013712324605015126 5ustar0000000000000000pantry-0.4.0.2/test/0000755000000000000000000000000013712324605012340 5ustar0000000000000000pantry-0.4.0.2/test/Pantry/0000755000000000000000000000000013712324626013620 5ustar0000000000000000pantry-0.4.0.2/test/Pantry/Internal/0000755000000000000000000000000013712324605015371 5ustar0000000000000000pantry-0.4.0.2/src/Pantry.hs0000644000000000000000000017670713712324626014006 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Content addressable Haskell package management, providing for -- secure, reproducible acquisition of Haskell package contents and -- metadata. -- -- @since 0.1.0.0 module Pantry ( -- * Running PantryConfig , HackageSecurityConfig (..) , defaultHackageSecurityConfig , defaultCasaRepoPrefix , defaultCasaMaxPerRequest , HasPantryConfig (..) , withPantryConfig , HpackExecutable (..) -- ** Convenience , PantryApp , runPantryApp , runPantryAppClean , runPantryAppWith , hpackExecutableL -- * Types -- ** Exceptions , PantryException (..) -- ** Cabal types , PackageName , Version , FlagName , PackageIdentifier (..) -- ** Files , FileSize (..) , RelFilePath (..) , ResolvedPath (..) , Unresolved -- ** Cryptography , SHA256 , TreeKey (..) , BlobKey (..) -- ** Packages , RawPackageMetadata (..) , PackageMetadata (..) , Package (..) -- ** Hackage , CabalFileInfo (..) , Revision (..) , PackageIdentifierRevision (..) , UsePreferredVersions (..) -- ** Archives , RawArchive (..) , Archive (..) , ArchiveLocation (..) -- ** Repos , Repo (..) , RepoType (..) , withRepo -- ** Package location , RawPackageLocation (..) , PackageLocation (..) , toRawPL , RawPackageLocationImmutable (..) , PackageLocationImmutable (..) -- ** Snapshots , RawSnapshotLocation (..) , SnapshotLocation (..) , toRawSL , RawSnapshot (..) , Snapshot (..) , RawSnapshotPackage (..) , SnapshotPackage (..) , RawSnapshotLayer (..) , SnapshotLayer (..) , toRawSnapshotLayer , WantedCompiler (..) -- * Loading values , resolvePaths , loadPackageRaw , tryLoadPackageRawViaCasa , loadPackage , loadRawSnapshotLayer , loadSnapshotLayer , loadSnapshot , loadAndCompleteSnapshot , loadAndCompleteSnapshotRaw , CompletedSL (..) , CompletedPLI (..) , addPackagesToSnapshot , AddPackagesConfig (..) -- * Completion functions , CompletePackageLocation (..) , completePackageLocation , completeSnapshotLocation , warnMissingCabalFile -- * Parsers , parseWantedCompiler , parseRawSnapshotLocation , parsePackageIdentifierRevision , parseHackageText -- ** Cabal values , parsePackageIdentifier , parsePackageName , parsePackageNameThrowing , parseFlagName , parseVersion , parseVersionThrowing -- * Stackage snapshots , ltsSnapshotLocation , nightlySnapshotLocation -- * Cabal helpers , packageIdentifierString , packageNameString , flagNameString , versionString , moduleNameString , CabalString (..) , toCabalStringMap , unCabalStringMap , gpdPackageIdentifier , gpdPackageName , gpdVersion -- * Package location , fetchPackages , unpackPackageLocationRaw , unpackPackageLocation , getPackageLocationName , getRawPackageLocationIdent , packageLocationIdent , packageLocationVersion , getRawPackageLocationTreeKey , getPackageLocationTreeKey -- * Cabal files , loadCabalFileRaw , loadCabalFile , loadCabalFileRawImmutable , loadCabalFileImmutable , loadCabalFilePath , findOrGenerateCabalFile , PrintWarnings (..) -- * Hackage index , updateHackageIndex , DidUpdateOccur (..) , RequireHackageIndex (..) , hackageIndexTarballL , getHackagePackageVersions , getLatestHackageVersion , getLatestHackageLocation , getLatestHackageRevision , getHackageTypoCorrections , loadGlobalHints , partitionReplacedDependencies -- * Snapshot cache , SnapshotCacheHash (..) , withSnapshotCache ) where import Database.Persist (entityKey) import RIO import Conduit import Control.Arrow (right) import Control.Monad.State.Strict (State, execState, get, modify') import qualified RIO.Map as Map import qualified RIO.Set as Set import qualified RIO.ByteString as B import qualified RIO.Text as T import qualified RIO.List as List import qualified RIO.FilePath as FilePath import Pantry.Archive import Pantry.Casa import Casa.Client (thParserCasaRepo, CasaRepoPrefix) import Pantry.Repo import qualified Pantry.SHA256 as SHA256 import Pantry.Storage hiding (TreeEntry, PackageName, Version) import Pantry.Tree import Pantry.Types as P import Pantry.Hackage import Path (Path, Abs, File, toFilePath, Dir, (), filename, parseAbsDir, parent, parseRelFile) import Path.IO (doesFileExist, resolveDir', listDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Distribution.PackageDescription as D import Distribution.Parsec (PWarning (..), showPos) import qualified Hpack import qualified Hpack.Config as Hpack import Network.HTTP.Download import RIO.PrettyPrint import RIO.PrettyPrint.StylesUpdate import RIO.Process import RIO.Directory (getAppUserDataDirectory) import qualified Data.Yaml as Yaml import Pantry.Internal.AesonExtended (WithJSONWarnings (..), Value) import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP import Data.Char (isHexDigit) import Data.Time (getCurrentTime, diffUTCTime) -- | Create a new 'PantryConfig' with the given settings. -- -- For something easier to use in simple cases, see 'runPantryApp'. -- -- @since 0.1.0.0 withPantryConfig :: HasLogFunc env => Path Abs Dir -- ^ pantry root directory, where the SQLite database and Hackage -- downloads are kept. -> HackageSecurityConfig -- ^ Hackage configuration. You probably want -- 'defaultHackageSecurityConfig'. -> HpackExecutable -- ^ When converting an hpack @package.yaml@ file to a cabal file, -- what version of hpack should we use? -> Int -- ^ Maximum connection count -> CasaRepoPrefix -- ^ The casa pull URL e.g. https://casa.fpcomplete.com/v1/pull. -> Int -- ^ Max casa keys to pull per request. -> (PantryConfig -> RIO env a) -- ^ What to do with the config -> RIO env a withPantryConfig root hsc he count pullURL maxPerRequest inner = do env <- ask pantryRelFile <- parseRelFile "pantry.sqlite3" -- Silence persistent's logging output, which is really noisy runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do ur <- newMVar True ref1 <- newIORef mempty ref2 <- newIORef mempty inner PantryConfig { pcHackageSecurity = hsc , pcHpackExecutable = he , pcRootDir = root , pcStorage = storage , pcUpdateRef = ur , pcConnectionCount = count , pcParsedCabalFilesRawImmutable = ref1 , pcParsedCabalFilesMutable = ref2 , pcCasaRepoPrefix = pullURL , pcCasaMaxPerRequest = maxPerRequest } -- | Default pull URL for Casa. -- -- @since 0.1.1.1 defaultCasaRepoPrefix :: CasaRepoPrefix defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.fpcomplete.com") -- | Default max keys to pull per request. -- -- @since 0.1.1.1 defaultCasaMaxPerRequest :: Int defaultCasaMaxPerRequest = 1280 -- | Default 'HackageSecurityConfig' value using the official Hackage server. -- -- @since 0.1.0.0 defaultHackageSecurityConfig :: HackageSecurityConfig defaultHackageSecurityConfig = HackageSecurityConfig { hscKeyIds = [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" , "280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833" , "2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201" , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" , "772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d" , "aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9" , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" ] , hscKeyThreshold = 3 , hscDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/" , hscIgnoreExpiry = False } -- | Returns the latest version of the given package available from -- Hackage. -- -- @since 0.1.0.0 getLatestHackageVersion :: (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> PackageName -- ^ package name -> UsePreferredVersions -> RIO env (Maybe PackageIdentifierRevision) getLatestHackageVersion req name preferred = ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions req preferred name where go (version, m) = do (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m pure $ PackageIdentifierRevision name version $ CFIHash sha $ Just size -- | Returns location of the latest version of the given package available from -- Hackage. -- -- @since 0.1.0.0 getLatestHackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RequireHackageIndex -> PackageName -- ^ package name -> UsePreferredVersions -> RIO env (Maybe PackageLocationImmutable) getLatestHackageLocation req name preferred = do mversion <- fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions req preferred name let mVerCfKey = do (version, revisions) <- mversion (_rev, cfKey) <- fst <$> Map.maxViewWithKey revisions pure (version, cfKey) forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do let pir = PackageIdentifierRevision name version (CFIHash sha (Just size)) treeKey' <- getHackageTarballKey pir pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' -- | Returns the latest revision of the given package version available from -- Hackage. -- -- @since 0.1.0.0 getLatestHackageRevision :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RequireHackageIndex -> PackageName -- ^ package name -> Version -> RIO env (Maybe (Revision, BlobKey, TreeKey)) getLatestHackageRevision req name version = do revisions <- getHackagePackageVersionRevisions req name version case fmap fst $ Map.maxViewWithKey revisions of Nothing -> pure Nothing Just (revision, cfKey@(BlobKey sha size)) -> do let cfi = CFIHash sha (Just size) treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) return $ Just (revision, cfKey, treeKey') -- | Fetch keys and blobs and insert into the database where possible. fetchTreeKeys :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [RawPackageLocationImmutable] -> RIO env () fetchTreeKeys treeKeys = do pure () -- Find all tree keys that are missing from the database. packageLocationsMissing :: [RawPackageLocationImmutable] <- withStorage (filterM (fmap isNothing . maybe (pure Nothing) getTreeForKey . getRawTreeKey) treeKeys) pullTreeStart <- liftIO getCurrentTime -- Pull down those tree keys from Casa, automatically inserting into -- our local database. treeKeyBlobs :: Map TreeKey P.Tree <- fmap Map.fromList (withStorage (runConduitRes (casaBlobSource (fmap unTreeKey (mapMaybe getRawTreeKey packageLocationsMissing)) .| mapMC parseTreeM .| sinkList))) pullTreeEnd <- liftIO getCurrentTime let pulledPackages = mapMaybe (\treeKey' -> List.find ((== Just treeKey') . getRawTreeKey) packageLocationsMissing) (Map.keys treeKeyBlobs) -- Pull down all unique file blobs. let uniqueFileBlobKeys :: Set BlobKey uniqueFileBlobKeys = foldMap (\(P.TreeMap files) -> Set.fromList (map teBlob (toList files))) treeKeyBlobs pullBlobStart <- liftIO getCurrentTime pulledBlobKeys :: Int <- withStorage (runConduitRes (casaBlobSource uniqueFileBlobKeys .| mapC (const 1) .| sumC)) pullBlobEnd <- liftIO getCurrentTime logDebug ("Pulled from Casa: " <> mconcat (List.intersperse ", " (map display pulledPackages)) <> " (" <> display (T.pack (show (diffUTCTime pullTreeEnd pullTreeStart))) <> "), " <> plural pulledBlobKeys "file" <> " (" <> display (T.pack (show (diffUTCTime pullBlobEnd pullBlobStart))) <> ")") -- Store the tree for each missing package. for_ packageLocationsMissing (\rawPackageLocationImmutable -> let mkey = getRawTreeKey rawPackageLocationImmutable in case mkey of Nothing -> logDebug ("Ignoring package with no tree key " <> display rawPackageLocationImmutable <> ", can't look in Casa for it.") Just key -> case Map.lookup key treeKeyBlobs of Nothing -> logDebug ("Package key " <> display key <> " (" <> display rawPackageLocationImmutable <> ") not returned from Casa.") Just tree -> do identifier <- getRawPackageLocationIdent rawPackageLocationImmutable case findCabalOrHpackFile rawPackageLocationImmutable tree of Just buildFile -> void (withStorage (storeTree rawPackageLocationImmutable identifier tree buildFile)) Nothing -> logWarn ("Unable to find build file for package: " <> display rawPackageLocationImmutable)) where unTreeKey :: TreeKey -> BlobKey unTreeKey (P.TreeKey blobKey) = blobKey -- | Download all of the packages provided into the local cache -- without performing any unpacking. Can be useful for build tools -- wanting to prefetch or provide an offline mode. -- -- @since 0.1.0.0 fetchPackages :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) => f PackageLocationImmutable -> RIO env () fetchPackages pls = do fetchTreeKeys (fmap toRawPLI (toList pls)) traverseConcurrently_ (void . uncurry getHackageTarball) hackages -- TODO in the future, be concurrent in these as well fetchArchives archives fetchRepos repos where s x = Endo (x:) run (Endo f) = f [] (hackagesE, archivesE, reposE) = foldMap go pls hackages = run hackagesE archives = run archivesE repos = run reposE go (PLIHackage ident cfHash tree) = (s (toPir ident cfHash, Just tree), mempty, mempty) go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) toPir (PackageIdentifier name ver) (BlobKey sha size) = PackageIdentifierRevision name ver (CFIHash sha (Just size)) -- | Unpack a given 'RawPackageLocationImmutable' into the given -- directory. Does not generate any extra subdirectories. -- -- @since 0.1.0.0 unpackPackageLocationRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ unpack directory -> RawPackageLocationImmutable -> RIO env () unpackPackageLocationRaw fp loc = loadPackageRaw loc >>= unpackTree loc fp . packageTree -- | Unpack a given 'PackageLocationImmutable' into the given -- directory. Does not generate any extra subdirectories. -- -- @since 0.1.0.0 unpackPackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ unpack directory -> PackageLocationImmutable -> RIO env () unpackPackageLocation fp loc = loadPackage loc >>= unpackTree (toRawPLI loc) fp . packageTree -- | Load the cabal file for the given 'PackageLocationImmutable'. -- -- This function ignores all warnings. -- -- @since 0.1.0.0 loadCabalFileImmutable :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env GenericPackageDescription loadCabalFileImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFileBytes loc (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs let pm = case loc of PLIHackage (PackageIdentifier name version) _cfHash mtree -> PackageMetadata { pmIdent = PackageIdentifier name version , pmTreeKey = mtree } PLIArchive _ pm' -> pm' PLIRepo _ pm' -> pm' let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing (gpdPackageIdentifier gpd) PackageIdentifier name ver = pmIdent pm maybe (throwIO exc) pure $ do guard $ name == gpdPackageName gpd guard $ ver == gpdVersion gpd pure gpd where withCache inner = do let rawLoc = toRawPLI loc ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable m0 <- readIORef ref case Map.lookup rawLoc m0 of Just x -> pure x Nothing -> do x <- inner atomicModifyIORef' ref $ \m -> (Map.insert rawLoc x m, x) -- | Load the cabal file for the given 'RawPackageLocationImmutable'. -- -- This function ignores all warnings. -- -- Note that, for now, this will not allow support for hpack files in -- these package locations. Instead, all @PackageLocationImmutable@s -- will require a .cabal file. This may be relaxed in the future. -- -- @since 0.1.0.0 loadCabalFileRawImmutable :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env GenericPackageDescription loadCabalFileRawImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadRawCabalFileBytes loc (_warnings, gpd) <- rawParseGPD (Left loc) bs let rpm = case loc of RPLIHackage (PackageIdentifierRevision name version _cfi) mtree -> RawPackageMetadata { rpmName = Just name , rpmVersion = Just version , rpmTreeKey = mtree } RPLIArchive _ rpm' -> rpm' RPLIRepo _ rpm' -> rpm' let exc = MismatchedPackageMetadata loc rpm Nothing (gpdPackageIdentifier gpd) maybe (throwIO exc) pure $ do guard $ maybe True (== gpdPackageName gpd) (rpmName rpm) guard $ maybe True (== gpdVersion gpd) (rpmVersion rpm) pure gpd where withCache inner = do ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable m0 <- readIORef ref case Map.lookup loc m0 of Just x -> pure x Nothing -> do x <- inner atomicModifyIORef' ref $ \m -> (Map.insert loc x m, x) -- | Same as 'loadCabalFileRawImmutable', but takes a -- 'RawPackageLocation'. Never prints warnings, see 'loadCabalFilePath' -- for that. -- -- @since 0.1.0.0 loadCabalFileRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocation -> RIO env GenericPackageDescription loadCabalFileRaw (RPLImmutable loc) = loadCabalFileRawImmutable loc loadCabalFileRaw (RPLMutable rfp) = do (gpdio, _, _) <- loadCabalFilePath (resolvedAbsolute rfp) liftIO $ gpdio NoPrintWarnings -- | Same as 'loadCabalFileImmutable', but takes a -- 'PackageLocation'. Never prints warnings, see 'loadCabalFilePath' -- for that. -- -- @since 0.1.0.0 loadCabalFile :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocation -> RIO env GenericPackageDescription loadCabalFile (PLImmutable loc) = loadCabalFileImmutable loc loadCabalFile (PLMutable rfp) = do (gpdio, _, _) <- loadCabalFilePath (resolvedAbsolute rfp) liftIO $ gpdio NoPrintWarnings -- | Parse the cabal file for the package inside the given -- directory. Performs various sanity checks, such as the file name -- being correct and having only a single cabal file. -- -- @since 0.1.0.0 loadCabalFilePath :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ project directory, with a cabal file or hpack file -> RIO env ( PrintWarnings -> IO GenericPackageDescription , PackageName , Path Abs File ) loadCabalFilePath dir = do ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable mcached <- Map.lookup dir <$> readIORef ref case mcached of Just triple -> pure triple Nothing -> do (name, cabalfp) <- findOrGenerateCabalFile dir gpdRef <- newIORef Nothing run <- askRunInIO let gpdio = run . getGPD cabalfp gpdRef triple = (gpdio, name, cabalfp) atomicModifyIORef' ref $ \m -> (Map.insert dir triple m, triple) where getGPD cabalfp gpdRef printWarnings = do mpair <- readIORef gpdRef (warnings0, gpd) <- case mpair of Just pair -> pure pair Nothing -> do bs <- liftIO $ B.readFile $ toFilePath cabalfp (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs checkCabalFileName (gpdPackageName gpd) cabalfp pure (warnings0, gpd) warnings <- case printWarnings of YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> [] NoPrintWarnings -> pure warnings0 writeIORef gpdRef $ Just (warnings, gpd) pure gpd toPretty :: Path Abs File -> PWarning -> Utf8Builder toPretty src (PWarning _type pos msg) = "Cabal file warning in" <> fromString (toFilePath src) <> "@" <> fromString (showPos pos) <> ": " <> fromString msg -- | Check if the given name in the @Package@ matches the name of the .cabal file checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () checkCabalFileName name cabalfp = do -- Previously, we just use parsePackageNameFromFilePath. However, that can -- lead to confusing error messages. See: -- https://github.com/commercialhaskell/stack/issues/895 let expected = T.unpack $ unSafeFilePath $ cabalFileName name when (expected /= toFilePath (filename cabalfp)) $ throwM $ MismatchedCabalName cabalfp name -- | Get the filename for the cabal file in the given directory. -- -- If no .cabal file is present, or more than one is present, an exception is -- thrown via 'throwM'. -- -- If the directory contains a file named package.yaml, hpack is used to -- generate a .cabal file from it. -- -- @since 0.1.0.0 findOrGenerateCabalFile :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ package directory -> RIO env (PackageName, Path Abs File) findOrGenerateCabalFile pkgDir = do hpack pkgDir files <- filter (flip hasExtension "cabal" . toFilePath) . snd <$> listDir pkgDir -- If there are multiple files, ignore files that start with -- ".". On unixlike environments these are hidden, and this -- character is not valid in package names. The main goal is -- to ignore emacs lock files - see -- https://github.com/commercialhaskell/stack/issues/1897. let isHidden ('.':_) = True isHidden _ = False case filter (not . isHidden . toFilePath . filename) files of [] -> throwIO $ NoCabalFileFound pkgDir [x] -> maybe (throwIO $ InvalidCabalFilePath x) (\pn -> pure $ (pn, x)) $ List.stripSuffix ".cabal" (toFilePath (filename x)) >>= parsePackageName _:_ -> throwIO $ MultipleCabalFilesFound pkgDir files where hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Generate .cabal file from package.yaml, if necessary. hpack :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -> RIO env () hpack pkgDir = do packageConfigRelFile <- parseRelFile Hpack.packageConfig let hpackFile = pkgDir packageConfigRelFile exists <- liftIO $ doesFileExist hpackFile when exists $ do logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) he <- view $ pantryConfigL.to pcHpackExecutable case he of HpackBundled -> do r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions forM_ (Hpack.resultWarnings r) (logWarn . fromString) let cabalFile = fromString . Hpack.resultCabalFile $ r case Hpack.resultStatus r of Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ cabalFile <> " was generated with a newer version of hpack,\n" <> "please upgrade and try again." Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ cabalFile <> " was modified manually. Ignoring " <> fromString (toFilePath hpackFile) <> " in favor of the cabal file.\nIf you want to use the " <> fromString (toFilePath (filename hpackFile)) <> " file instead of the cabal file,\n" <> "then please delete the cabal file." HpackCommand command -> withWorkingDir (toFilePath pkgDir) $ proc command [] runProcess_ -- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'. -- -- @since 0.1.0.0 gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier gpdPackageIdentifier = D.package . D.packageDescription -- | Get the 'PackageName' from a 'GenericPackageDescription'. -- -- @since 0.1.0.0 gpdPackageName :: GenericPackageDescription -> PackageName gpdPackageName = pkgName . gpdPackageIdentifier -- | Get the 'Version' from a 'GenericPackageDescription'. -- -- @since 0.1.0.0 gpdVersion :: GenericPackageDescription -> Version gpdVersion = pkgVersion . gpdPackageIdentifier loadCabalFileBytes :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env ByteString -- Just ignore the mtree for this. Safe assumption: someone who filled -- in the TreeKey also filled in the cabal file hash, and that's a -- more efficient lookup mechanism. loadCabalFileBytes (PLIHackage pident cfHash _mtree) = getHackageCabalFile (pirForHash pident cfHash) loadCabalFileBytes pl = do package <- loadPackage pl let sfp = cabalFileName $ pkgName $ packageIdent package cabalBlobKey <- case (packageCabalEntry package) of PCHpack pcHpack -> pure $ teBlob . phGenerated $ pcHpack PCCabalFile (TreeEntry blobKey _) -> pure blobKey mbs <- withStorage $ loadBlob cabalBlobKey case mbs of Nothing -> do throwIO $ TreeReferencesMissingBlob (toRawPLI pl) sfp cabalBlobKey Just bs -> pure bs -- FIXME: to be removed loadRawCabalFileBytes :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env ByteString -- Just ignore the mtree for this. Safe assumption: someone who filled -- in the TreeKey also filled in the cabal file hash, and that's a -- more efficient lookup mechanism. loadRawCabalFileBytes (RPLIHackage pir _mtree) = getHackageCabalFile pir loadRawCabalFileBytes pl = do package <- loadPackageRaw pl let sfp = cabalFileName $ pkgName $ packageIdent package TreeEntry cabalBlobKey _ft = case packageCabalEntry package of PCCabalFile cabalTE -> cabalTE PCHpack hpackCE -> phGenerated hpackCE mbs <- withStorage $ loadBlob cabalBlobKey case mbs of Nothing -> do throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey Just bs -> pure bs -- | Load a 'Package' from a 'PackageLocationImmutable'. -- -- @since 0.1.0.0 loadPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env Package loadPackage = loadPackageRaw . toRawPLI -- | Load a 'Package' from a 'RawPackageLocationImmutable'. -- -- Load the package either from the local DB, Casa, or as a last -- resort, the third party (hackage, archive or repo). -- -- @since 0.1.0.0 loadPackageRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env Package loadPackageRaw rpli = do case getRawTreeKey rpli of Just treeKey' -> do mpackage <- tryLoadPackageRawViaDbOrCasa rpli treeKey' case mpackage of Nothing -> loadPackageRawViaThirdParty Just package -> pure package Nothing -> loadPackageRawViaThirdParty where loadPackageRawViaThirdParty = do logDebug ("Loading package from third-party: " <> display rpli) case rpli of RPLIHackage pir mtree -> htrPackage <$> getHackageTarball pir mtree RPLIArchive archive pm -> getArchivePackage rpli archive pm RPLIRepo repo rpm -> getRepo repo rpm -- | Try to load a package via the database or Casa. tryLoadPackageRawViaDbOrCasa :: (HasLogFunc env, HasPantryConfig env, HasProcessContext env) => RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package) tryLoadPackageRawViaDbOrCasa rpli treeKey' = do mviaDb <- tryLoadPackageRawViaLocalDb rpli treeKey' case mviaDb of Just package -> do logDebug ("Loaded package from Pantry: " <> display rpli) pure (Just package) Nothing -> do mviaCasa <- tryLoadPackageRawViaCasa rpli treeKey' case mviaCasa of Just package -> do logDebug ("Loaded package from Casa: " <> display rpli) pure (Just package) Nothing -> pure Nothing -- | Maybe load the package from Casa. tryLoadPackageRawViaCasa :: (HasLogFunc env, HasPantryConfig env, HasProcessContext env) => RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package) tryLoadPackageRawViaCasa rlpi treeKey' = do mtreePair <- casaLookupTree treeKey' case mtreePair of Nothing -> pure Nothing Just (treeKey'', _tree) -> do fetchTreeKeys [rlpi] mdb <- tryLoadPackageRawViaLocalDb rlpi treeKey'' case mdb of Nothing -> do logWarn ("Did not find tree key in DB after pulling it from Casa: " <> display treeKey'' <> " (for " <> display rlpi <> ")") pure Nothing Just package -> pure (Just package) -- | Maybe load the package from the local database. tryLoadPackageRawViaLocalDb :: (HasLogFunc env, HasPantryConfig env, HasProcessContext env) => RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package) tryLoadPackageRawViaLocalDb rlpi treeKey' = do mtreeEntity <- withStorage (getTreeForKey treeKey') case mtreeEntity of Nothing -> pure Nothing Just treeId -> fmap Just (withStorage (loadPackageById rlpi (entityKey treeId))) -- | Complete package location, plus whether the package has a cabal file. This -- is relevant to reproducibility, see -- -- -- @since 0.4.0.0 data CompletePackageLocation = CompletePackageLocation { cplComplete :: !PackageLocationImmutable , cplHasCabalFile :: !Bool } -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. -- -- @since 0.1.0.0 completePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env CompletePackageLocation completePackageLocation (RPLIHackage (PackageIdentifierRevision n v (CFIHash sha (Just size))) (Just tk)) = pure CompletePackageLocation { cplComplete = PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk , cplHasCabalFile = True } completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name version cfi0) _) = do logDebug $ "Completing package location information from " <> display pir0 (pir, cfKey) <- case cfi0 of CFIHash sha (Just size) -> pure (pir0, BlobKey sha size) _ -> do bs <- getHackageCabalFile pir0 let size = FileSize (fromIntegral (B.length bs)) sha = SHA256.hashBytes bs cfi = CFIHash sha (Just size) pir = PackageIdentifierRevision name version cfi logDebug $ "Added in cabal file hash: " <> display pir pure (pir, BlobKey sha size) treeKey' <- getHackageTarballKey pir pure CompletePackageLocation { cplComplete = PLIHackage (PackageIdentifier name version) cfKey treeKey' , cplHasCabalFile = True } completePackageLocation pl@(RPLIArchive archive rpm) = do mpackage <- case rpmTreeKey rpm of Just treeKey' -> tryLoadPackageRawViaDbOrCasa pl treeKey' Nothing -> pure Nothing case (,,) <$> raHash archive <*> raSize archive <*> mpackage of Just (sha256, fileSize, package) -> do let RawArchive loc _ _ subdir = archive pure CompletePackageLocation { cplComplete = PLIArchive (Archive loc sha256 fileSize subdir) (packagePM package) , cplHasCabalFile = case packageCabalEntry package of PCCabalFile{} -> True PCHpack{} -> False } Nothing -> byThirdParty (isJust mpackage) where byThirdParty warnAboutMissingSizeSha = do (sha, size, package) <- getArchive pl archive rpm when warnAboutMissingSizeSha (warnWith sha size) -- (getArchive checks archive and package metadata) let RawArchive loc _ _ subdir = archive logDebug $ fromString $ show (pl, sha, size, package) pure CompletePackageLocation { cplComplete = PLIArchive (Archive loc sha size subdir) (packagePM package) , cplHasCabalFile = case packageCabalEntry package of PCCabalFile{} -> True PCHpack{} -> False } warnWith sha size = logWarn (mconcat [ "The package " , display pl , " is available from the local content-addressable storage database, \n" , "but we can't use it unless you specify the size and hash for this package.\n" , "Add the following to your package description:\n" , "\nsize: " <> display size , "\nsha256: " <> display sha ]) completePackageLocation pl@(RPLIRepo repo rpm) = do unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo completePM repo pl rpm where isSHA1 t = T.length t == 40 && T.all isHexDigit t completePM :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageLocationImmutable -> RawPackageMetadata -> RIO env CompletePackageLocation completePM repo plOrig rpm@(RawPackageMetadata mn mv mtk) | Just n <- mn, Just v <- mv, Just tk <- mtk = do let pm = PackageMetadata (PackageIdentifier n v) tk pure CompletePackageLocation { cplComplete = PLIRepo repo pm -- This next bit is a hack: we don't know for certain that this is the case. -- However, for the use case where complete package metadata has been supplied, -- we'll assume there's a cabal file for purposes of generating a deprecation warning. , cplHasCabalFile = True } | otherwise = do package <- loadPackageRaw plOrig let pm = packagePM package let isSame x (Just y) = x == y isSame _ _ = True allSame = isSame (pkgName $ pmIdent pm) (rpmName rpm) && isSame (pkgVersion $ pmIdent pm) (rpmVersion rpm) && isSame (pmTreeKey pm) (rpmTreeKey rpm) if allSame then pure CompletePackageLocation { cplComplete = PLIRepo repo pm , cplHasCabalFile = case packageCabalEntry package of PCCabalFile{} -> True PCHpack{} -> False } else throwIO $ CompletePackageMetadataMismatch plOrig pm packagePM :: Package -> PackageMetadata packagePM package = PackageMetadata { pmIdent = packageIdent package , pmTreeKey = packageTreeKey package } -- | Add in hashes to make a 'SnapshotLocation' reproducible. -- -- @since 0.1.0.0 completeSnapshotLocation :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation -> RIO env SnapshotLocation completeSnapshotLocation (RSLCompiler c) = pure $ SLCompiler c completeSnapshotLocation (RSLFilePath f) = pure $ SLFilePath f completeSnapshotLocation (RSLUrl url (Just blobKey)) = pure $ SLUrl url blobKey completeSnapshotLocation (RSLUrl url Nothing) = do bs <- loadFromURL url Nothing pure $ SLUrl url (bsToBlobKey bs) traverseConcurrently_ :: (Foldable f, HasPantryConfig env) => (a -> RIO env ()) -- ^ action to perform -> f a -- ^ input values -> RIO env () traverseConcurrently_ f t0 = do cnt <- view $ pantryConfigL.to pcConnectionCount traverseConcurrentlyWith_ cnt f t0 traverseConcurrentlyWith_ :: (MonadUnliftIO m, Foldable f) => Int -- ^ concurrent workers -> (a -> m ()) -- ^ action to perform -> f a -- ^ input values -> m () traverseConcurrentlyWith_ count f t0 = do queue <- newTVarIO $ toList t0 replicateConcurrently_ count $ fix $ \loop -> join $ atomically $ do toProcess <- readTVar queue case toProcess of [] -> pure (pure ()) (x:rest) -> do writeTVar queue rest pure $ do f x loop -- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'. -- -- @since 0.1.0.0 loadSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation -> RIO env RawSnapshot loadSnapshotRaw loc = do eres <- loadRawSnapshotLayer loc case eres of Left wc -> pure RawSnapshot { rsCompiler = wc , rsPackages = mempty , rsDrop = mempty } Right (rsl, _) -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot (display loc) (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl , apcFlags = rslFlags rsl , apcHiddens = rslHidden rsl , apcGhcOptions = rslGhcOptions rsl } (rsPackages snap0) warnUnusedAddPackagesConfig (display loc) unused pure RawSnapshot { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) , rsPackages = packages , rsDrop = apcDrop unused } -- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'. -- -- @since 0.1.0.0 loadSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation -> RIO env RawSnapshot loadSnapshot loc = do eres <- loadSnapshotLayer loc case eres of Left wc -> pure RawSnapshot { rsCompiler = wc , rsPackages = mempty , rsDrop = mempty } Right rsl -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot (display loc) (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl , apcFlags = rslFlags rsl , apcHiddens = rslHidden rsl , apcGhcOptions = rslGhcOptions rsl } (rsPackages snap0) warnUnusedAddPackagesConfig (display loc) unused pure RawSnapshot { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) , rsPackages = packages , rsDrop = apcDrop unused } -- | A completed package location, including the original raw and completed information. -- -- @since 0.1.0.0 data CompletedPLI = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable -- | A completed snapshot location, including the original raw and completed information. -- -- @since 0.1.0.0 data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting -- any incomplete package locations -- -- @since 0.1.0.0 loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) loadAndCompleteSnapshot loc cachedSL cachedPL = loadAndCompleteSnapshotRaw (toRawSL loc) cachedSL cachedPL -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations -- -- @since 0.1.0.0 loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) loadAndCompleteSnapshotRaw rawLoc cacheSL cachePL = do eres <- case Map.lookup rawLoc cacheSL of Just loc -> right (\rsl -> (rsl, (CompletedSL rawLoc loc))) <$> loadSnapshotLayer loc Nothing -> loadRawSnapshotLayer rawLoc case eres of Left wc -> let snapshot = Snapshot { snapshotCompiler = wc , snapshotPackages = mempty , snapshotDrop = mempty } in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], []) Right (rsl, sloc) -> do (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cacheSL cachePL logDebug $ fromString $ show rsl (packages, completed, unused) <- addAndCompletePackagesToSnapshot rawLoc cachePL (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl , apcFlags = rslFlags rsl , apcHiddens = rslHidden rsl , apcGhcOptions = rslGhcOptions rsl } (snapshotPackages snap0) warnUnusedAddPackagesConfig (display rawLoc) unused let snapshot = Snapshot { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl) , snapshotPackages = packages , snapshotDrop = apcDrop unused } return (snapshot, sloc : slocs,completed0 ++ completed) data SingleOrNot a = Single !a | Multiple !a !a !([a] -> [a]) instance Semigroup (SingleOrNot a) where Single a <> Single b = Multiple a b id Single a <> Multiple b c d = Multiple a b ((c:) . d) Multiple a b c <> Single d = Multiple a b (c . (d:)) Multiple a b c <> Multiple d e f = Multiple a b (c . (d:) . (e:) . f) sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a]) sonToEither (k, Single a) = Left (k, a) sonToEither (k, Multiple a b c) = Right (k, (a : b : c [])) -- | Package settings to be passed to 'addPackagesToSnapshot'. -- -- @since 0.1.0.0 data AddPackagesConfig = AddPackagesConfig { apcDrop :: !(Set PackageName) , apcFlags :: !(Map PackageName (Map FlagName Bool)) , apcHiddens :: !(Map PackageName Bool) , apcGhcOptions :: !(Map PackageName [Text]) } -- | Does not warn about drops, those are allowed in order to ignore global -- packages. warnUnusedAddPackagesConfig :: HasLogFunc env => Utf8Builder -- ^ source -> AddPackagesConfig -> RIO env () warnUnusedAddPackagesConfig source (AddPackagesConfig _drops flags hiddens options) = do unless (null ls) $ do logWarn $ "Some warnings discovered when adding packages to snapshot (" <> source <> ")" traverse_ logWarn ls where ls = concat [flags', hiddens', options'] flags' = map (\pn -> "Setting flags for non-existent package: " <> fromString (packageNameString pn)) (Map.keys flags) hiddens' = map (\pn -> "Hiding non-existent package: " <> fromString (packageNameString pn)) (Map.keys hiddens) options' = map (\pn -> "Setting options for non-existent package: " <> fromString (packageNameString pn)) (Map.keys options) -- | Add more packages to a snapshot -- -- Note that any settings on a parent flag which is being replaced will be -- ignored. For example, if package @foo@ is in the parent and has flag @bar@ -- set, and @foo@ also appears in new packages, then @bar@ will no longer be -- set. -- -- Returns any of the 'AddPackagesConfig' values not used. -- -- @since 0.1.0.0 addPackagesToSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Utf8Builder -- ^ Text description of where these new packages are coming from, for error -- messages only -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig -> Map PackageName RawSnapshotPackage -- ^ packages from parent -> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig) addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do new' <- for newPackages $ \loc -> do name <- getPackageLocationName loc pure (name, RawSnapshotPackage { rspLocation = loc , rspFlags = Map.findWithDefault mempty name flags , rspHidden = Map.findWithDefault False name hiddens , rspGhcOptions = Map.findWithDefault [] name options }) let (newSingles, newMultiples) = partitionEithers $ map sonToEither $ Map.toList $ Map.fromListWith (<>) $ map (second Single) new' unless (null $ newMultiples) $ throwIO $ DuplicatePackageNames source $ map (second (map rspLocation)) newMultiples let new = Map.fromList newSingles allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) allPackages = flip Map.mapWithKey allPackages0 $ \name rsp -> rsp { rspFlags = Map.findWithDefault (rspFlags rsp) name flags , rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens , rspGhcOptions = Map.findWithDefault (rspGhcOptions rsp) name options } unused = AddPackagesConfig (drops `Set.difference` Map.keysSet old) (flags `Map.difference` allPackages) (hiddens `Map.difference` allPackages) (options `Map.difference` allPackages) pure (allPackages, unused) cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Map RawPackageLocationImmutable PackageLocationImmutable -> RawPackageLocationImmutable -> RIO env (Maybe PackageLocationImmutable) cachedSnapshotCompletePackageLocation cachePackages rpli = do let xs = Map.lookup rpli cachePackages case xs of Nothing -> do cpl <- completePackageLocation rpli pure $ if cplHasCabalFile cpl then Just (cplComplete cpl) else Nothing Just x -> pure $ Just x -- | Add more packages to a snapshot completing their locations if needed -- -- Note that any settings on a parent flag which is being replaced will be -- ignored. For example, if package @foo@ is in the parent and has flag @bar@ -- set, and @foo@ also appears in new packages, then @bar@ will no longer be -- set. -- -- Returns any of the 'AddPackagesConfig' values not used and also all -- non-trivial package location completions. -- -- @since 0.1.0.0 addAndCompletePackagesToSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation -- ^ Text description of where these new packages are coming from, for error -- messages only -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig -> Map PackageName SnapshotPackage -- ^ packages from parent -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do let source = display loc addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => ([(PackageName, SnapshotPackage)],[CompletedPLI]) -> RawPackageLocationImmutable -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) addPackage (ps, completed) rawLoc = do mcomplLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc case mcomplLoc of Nothing -> do warnMissingCabalFile rawLoc pure (ps, completed) Just complLoc -> do let PackageIdentifier name _ = packageLocationIdent complLoc p = (name, SnapshotPackage { spLocation = complLoc , spFlags = Map.findWithDefault mempty name flags , spHidden = Map.findWithDefault False name hiddens , spGhcOptions = Map.findWithDefault [] name options }) completed' = if toRawPLI complLoc == rawLoc then completed else CompletedPLI rawLoc complLoc:completed pure (p:ps, completed') (revNew, revCompleted) <- foldM addPackage ([], []) newPackages let (newSingles, newMultiples) = partitionEithers $ map sonToEither $ Map.toList $ Map.fromListWith (<>) $ map (second Single) (reverse revNew) unless (null $ newMultiples) $ throwIO $ DuplicatePackageNames source $ map (second (map (toRawPLI . spLocation))) newMultiples let new = Map.fromList newSingles allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) allPackages = flip Map.mapWithKey allPackages0 $ \name sp -> sp { spFlags = Map.findWithDefault (spFlags sp) name flags , spHidden = Map.findWithDefault (spHidden sp) name hiddens , spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options } unused = AddPackagesConfig (drops `Set.difference` Map.keysSet old) (flags `Map.difference` allPackages) (hiddens `Map.difference` allPackages) (options `Map.difference` allPackages) pure (allPackages, reverse revCompleted, unused) -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- -- Returns a 'Left' value if provided an 'SLCompiler' -- constructor. Otherwise, returns a 'Right' value providing both the -- 'Snapshot' and a hash of the input configuration file. -- -- @since 0.1.0.0 loadRawSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler loadRawSnapshotLayer rsl@(RSLUrl url blob) = handleAny (throwIO . InvalidSnapshot rsl) $ do bs <- loadFromURL url blob value <- Yaml.decodeThrow bs snapshot <- warningsParserHelperRaw rsl value Nothing pure $ Right (snapshot, (CompletedSL rsl (SLUrl url (bsToBlobKey bs)))) loadRawSnapshotLayer rsl@(RSLFilePath fp) = handleAny (throwIO . InvalidSnapshot rsl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp pure $ Right (snapshot, CompletedSL rsl (SLFilePath fp)) -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- -- Returns a 'Left' value if provided an 'SLCompiler' -- constructor. Otherwise, returns a 'Right' value providing both the -- 'Snapshot' and a hash of the input configuration file. -- -- @since 0.1.0.0 loadSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation -> RIO env (Either WantedCompiler RawSnapshotLayer) loadSnapshotLayer (SLCompiler compiler) = pure $ Left compiler loadSnapshotLayer sl@(SLUrl url blob) = handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do bs <- loadFromURL url (Just blob) value <- Yaml.decodeThrow bs snapshot <- warningsParserHelper sl value Nothing pure $ Right snapshot loadSnapshotLayer sl@(SLFilePath fp) = handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp pure $ Right snapshot loadFromURL :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ url -> Maybe BlobKey -> RIO env ByteString loadFromURL url Nothing = do mcached <- withStorage $ loadURLBlob url case mcached of Just bs -> return bs Nothing -> loadWithCheck url Nothing loadFromURL url (Just bkey) = do mcached <- withStorage $ loadBlob bkey case mcached of Just bs -> do logDebug "Loaded snapshot from Pantry database." return bs Nothing -> loadUrlViaCasaOrWithCheck url bkey loadUrlViaCasaOrWithCheck :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ url -> BlobKey -> RIO env ByteString loadUrlViaCasaOrWithCheck url blobKey = do mblobFromCasa <- casaLookupKey blobKey case mblobFromCasa of Just blob -> do logDebug ("Loaded snapshot from Casa (" <> display blobKey <> ") for URL: " <> display url) pure blob Nothing -> loadWithCheck url (Just blobKey) loadWithCheck :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ url -> Maybe BlobKey -> RIO env ByteString loadWithCheck url mblobkey = do let (msha, msize) = case mblobkey of Nothing -> (Nothing, Nothing) Just (BlobKey sha size) -> (Just sha, Just size) (_, _, bss) <- httpSinkChecked url msha msize sinkList let bs = B.concat bss withStorage $ storeURLBlob url bs logDebug ("Loaded snapshot from third party: " <> display url) return bs warningsParserHelperRaw :: HasLogFunc env => RawSnapshotLocation -> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer warningsParserHelperRaw rsl val mdir = case parseEither Yaml.parseJSON val of Left e -> throwIO $ Couldn'tParseSnapshot rsl e Right (WithJSONWarnings x ws) -> do unless (null ws) $ do logWarn $ "Warnings when parsing snapshot " <> display rsl for_ ws $ logWarn . display resolvePaths mdir x warningsParserHelper :: HasLogFunc env => SnapshotLocation -> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer warningsParserHelper sl val mdir = case parseEither Yaml.parseJSON val of Left e -> throwIO $ Couldn'tParseSnapshot (toRawSL sl) e Right (WithJSONWarnings x ws) -> do unless (null ws) $ do logWarn $ "Warnings when parsing snapshot " <> display sl for_ ws $ logWarn . display resolvePaths mdir x -- | Get the 'PackageName' of the package at the given location. -- -- @since 0.1.0.0 getPackageLocationName :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env PackageName getPackageLocationName = fmap pkgName . getRawPackageLocationIdent -- | Get the 'PackageIdentifier' of the package at the given location. -- -- @since 0.1.0.0 packageLocationIdent :: PackageLocationImmutable -> PackageIdentifier packageLocationIdent (PLIHackage ident _ _) = ident packageLocationIdent (PLIRepo _ pm) = pmIdent pm packageLocationIdent (PLIArchive _ pm) = pmIdent pm -- | Get version of the package at the given location. -- -- @since 0.1.0.0 packageLocationVersion :: PackageLocationImmutable -> Version packageLocationVersion (PLIHackage pident _ _) = pkgVersion pident packageLocationVersion (PLIRepo _ pm) = pkgVersion (pmIdent pm) packageLocationVersion (PLIArchive _ pm) = pkgVersion (pmIdent pm) -- | Get the 'PackageIdentifier' of the package at the given location. -- -- @since 0.1.0.0 getRawPackageLocationIdent :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env PackageIdentifier getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version getRawPackageLocationIdent (RPLIRepo _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version getRawPackageLocationIdent (RPLIArchive _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version getRawPackageLocationIdent rpli = packageIdent <$> loadPackageRaw rpli -- | Get the 'TreeKey' of the package at the given location. -- -- @since 0.1.0.0 getRawPackageLocationTreeKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env TreeKey getRawPackageLocationTreeKey pl = case getRawTreeKey pl of Just treeKey' -> pure treeKey' Nothing -> case pl of RPLIHackage pir _ -> getHackageTarballKey pir RPLIArchive archive pm -> getArchiveKey pl archive pm RPLIRepo repo pm -> getRepoKey repo pm -- | Get the 'TreeKey' of the package at the given location. -- -- @since 0.1.0.0 getPackageLocationTreeKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env TreeKey getPackageLocationTreeKey pl = pure $ getTreeKey pl getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey getRawTreeKey (RPLIHackage _ mtree) = mtree getRawTreeKey (RPLIArchive _ rpm) = rpmTreeKey rpm getRawTreeKey (RPLIRepo _ rpm) = rpmTreeKey rpm getTreeKey :: PackageLocationImmutable -> TreeKey getTreeKey (PLIHackage _ _ tree) = tree getTreeKey (PLIArchive _ pm) = pmTreeKey pm getTreeKey (PLIRepo _ pm) = pmTreeKey pm -- | Convenient data type that allows you to work with pantry more -- easily than using 'withPantryConfig' directly. Uses basically sane -- settings, like sharing a pantry directory with Stack. -- -- You can use 'runPantryApp' to use this. -- -- @since 0.1.0.0 data PantryApp = PantryApp { paSimpleApp :: !SimpleApp , paPantryConfig :: !PantryConfig , paUseColor :: !Bool , paTermWidth :: !Int , paStylesUpdate :: !StylesUpdate } simpleAppL :: Lens' PantryApp SimpleApp simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y }) -- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig' -- -- @since 0.1.0.0 hpackExecutableL :: Lens' PantryConfig HpackExecutable hpackExecutableL k pconfig = fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig)) instance HasLogFunc PantryApp where logFuncL = simpleAppL.logFuncL instance HasPantryConfig PantryApp where pantryConfigL = lens paPantryConfig (\x y -> x { paPantryConfig = y }) instance HasProcessContext PantryApp where processContextL = simpleAppL.processContextL instance HasStylesUpdate PantryApp where stylesUpdateL = lens paStylesUpdate (\x y -> x { paStylesUpdate = y }) instance HasTerm PantryApp where useColorL = lens paUseColor (\x y -> x { paUseColor = y }) termWidthL = lens paTermWidth (\x y -> x { paTermWidth = y }) -- | Run some code against pantry using basic sane settings. -- -- For testing, see 'runPantryAppClean'. -- -- @since 0.1.0.0 runPantryApp :: MonadIO m => RIO PantryApp a -> m a runPantryApp = runPantryAppWith 8 defaultCasaRepoPrefix defaultCasaMaxPerRequest -- | Run some code against pantry using basic sane settings. -- -- For testing, see 'runPantryAppClean'. -- -- @since 0.1.1.1 runPantryAppWith :: MonadIO m => Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp $ do sa <- ask stack <- getAppUserDataDirectory "stack" root <- parseAbsDir $ stack FilePath. "pantry" withPantryConfig root defaultHackageSecurityConfig HpackBundled maxConnCount casaRepoPrefix casaMaxPerRequest $ \pc -> runRIO PantryApp { paSimpleApp = sa , paPantryConfig = pc , paTermWidth = 100 , paUseColor = True , paStylesUpdate = mempty } f -- | Like 'runPantryApp', but uses an empty pantry directory instead -- of sharing with Stack. Useful for testing. -- -- @since 0.1.0.0 runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> runSimpleApp $ do sa <- ask root <- resolveDir' dir withPantryConfig root defaultHackageSecurityConfig HpackBundled 8 defaultCasaRepoPrefix defaultCasaMaxPerRequest $ \pc -> runRIO PantryApp { paSimpleApp = sa , paPantryConfig = pc , paTermWidth = 100 , paUseColor = True , paStylesUpdate = mempty } f -- | Load the global hints from Github. -- -- @since 0.1.0.0 loadGlobalHints :: (HasTerm env, HasPantryConfig env) => WantedCompiler -> RIO env (Maybe (Map PackageName Version)) loadGlobalHints wc = inner False where inner alreadyDownloaded = do dest <- getGlobalHintsFile req <- parseRequest "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/global-hints.yaml" downloaded <- download req dest eres <- tryAny (inner2 dest) mres <- case eres of Left e -> Nothing <$ logError ("Error when parsing global hints: " <> displayShow e) Right x -> pure x case mres of Nothing | not alreadyDownloaded && not downloaded -> do logInfo $ "Could not find local global hints for " <> RIO.display wc <> ", forcing a redownload" x <- redownload req dest if x then inner True else do logInfo "Redownload didn't happen" pure Nothing _ -> pure mres inner2 dest = liftIO $ Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) <$> Yaml.decodeFileThrow (toFilePath dest) -- | Partition a map of global packages with its versions into a Set of -- replaced packages and its dependencies and a map of remaining (untouched) packages. -- -- @since 0.1.0.0 partitionReplacedDependencies :: Ord id => Map PackageName a -- ^ global packages -> (a -> PackageName) -- ^ package name getter -> (a -> id) -- ^ returns unique package id used for dependency pruning -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies -> Set PackageName -- ^ overrides which global dependencies should get pruned -> (Map PackageName [PackageName], Map PackageName a) partitionReplacedDependencies globals getName getId getDeps overrides = flip execState (replaced, mempty) $ for (Map.toList globals) $ prunePackageWithDeps globals' getName getDeps where globals' = Map.fromList $ map (getId &&& id) (Map.elems globals) replaced = Map.map (const []) $ Map.restrictKeys globals overrides prunePackageWithDeps :: Ord id => Map id a -> (a -> PackageName) -> (a -> [id]) -> (PackageName, a) -> State (Map PackageName [PackageName], Map PackageName a) Bool prunePackageWithDeps pkgs getName getDeps (pname, a) = do (pruned, kept) <- get if Map.member pname pruned then return True else if Map.member pname kept then return False else do let deps = Map.elems $ Map.restrictKeys pkgs (Set.fromList $ getDeps a) prunedDeps <- forMaybeM deps $ \dep -> do let depName = getName dep isPruned <- prunePackageWithDeps pkgs getName getDeps (depName, dep) pure $ if isPruned then Just depName else Nothing if null prunedDeps then do modify' $ second (Map.insert pname a) else do modify' $ first (Map.insert pname prunedDeps) return $ not (null prunedDeps) -- | Use a snapshot cache, which caches which modules are in which -- packages in a given snapshot. This is mostly intended for usage by -- Stack. -- -- @since 0.1.0.0 withSnapshotCache :: (HasPantryConfig env, HasLogFunc env) => SnapshotCacheHash -> RIO env (Map PackageName (Set ModuleName)) -> ((ModuleName -> RIO env [PackageName]) -> RIO env a) -> RIO env a withSnapshotCache hash getModuleMapping f = do mres <- withStorage $ getSnapshotCacheByHash hash cacheId <- case mres of Nothing -> do logWarn "Populating snapshot module name cache" packageModules <- getModuleMapping withStorage $ do scId <- getSnapshotCacheId hash storeSnapshotModuleCache scId packageModules return scId Just scId -> pure scId f $ withStorage . loadExposedModulePackages cacheId -- | Add an s to the builder if n!=1. plural :: Int -> Utf8Builder -> Utf8Builder plural n text = display n <> " " <> text <> (if n == 1 then "" else "s") pantry-0.4.0.2/src/Pantry/SHA256.hs0000644000000000000000000001233713712324605014637 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | Provides a data type ('SHA256') for efficient memory -- representation of a sha-256 hash value, together with helper -- functions for converting to and from that value. This module is -- intended to be imported qualified as @SHA256@. -- -- Some nomenclature: -- -- * Hashing calculates a new hash value from some input. @from@ takes a value that representats an existing hash. -- -- * Raw means a raw binary representation of the hash value, without any hex encoding. -- -- * Text always uses lower case hex encoding -- -- @since 0.1.0.0 module Pantry.SHA256 ( -- * Types SHA256 , SHA256Exception (..) -- * Hashing , hashFile , hashBytes , hashLazyBytes , sinkHash -- * Convert from a hash representation , fromHexText , fromHexBytes , fromDigest , fromRaw -- * Convert to a hash representation , toHexText , toHexBytes , toRaw ) where import RIO import Data.Aeson import Database.Persist.Sql import Pantry.Internal.StaticBytes import Conduit import qualified RIO.Text as T import qualified Crypto.Hash.Conduit as Hash (hashFile, sinkHash) import qualified Crypto.Hash as Hash (hash, hashlazy, Digest, SHA256) import qualified Data.ByteArray import qualified Data.ByteArray.Encoding as Mem -- | A SHA256 hash, stored in a static size for more efficient -- memory representation. -- -- @since 0.1.0.0 newtype SHA256 = SHA256 Bytes32 deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable) -- | Exceptions which can occur in this module -- -- @since 0.1.0.0 data SHA256Exception = InvalidByteCount !ByteString !StaticBytesException | InvalidHexBytes !ByteString !Text deriving (Typeable) -- | Generate a 'SHA256' value by hashing the contents of a file. -- -- @since 0.1.0.0 hashFile :: MonadIO m => FilePath -> m SHA256 hashFile fp = fromDigest <$> Hash.hashFile fp -- | Generate a 'SHA256' value by hashing a @ByteString@. -- -- @since 0.1.0.0 hashBytes :: ByteString -> SHA256 hashBytes = fromDigest . Hash.hash -- | Generate a 'SHA256' value by hashing a lazy @ByteString@. -- -- @since 0.1.0.0 hashLazyBytes :: LByteString -> SHA256 hashLazyBytes = fromDigest . Hash.hashlazy -- | Generate a 'SHA256' value by hashing the contents of a stream. -- -- @since 0.1.0.0 sinkHash :: Monad m => ConduitT ByteString o m SHA256 sinkHash = fromDigest <$> Hash.sinkHash -- | Convert a base16-encoded 'Text' value containing a hash into a 'SHA256'. -- -- @since 0.1.0.0 fromHexText :: Text -> Either SHA256Exception SHA256 fromHexText = fromHexBytes . encodeUtf8 -- | Convert a base16-encoded 'ByteString' value containing a hash into a 'SHA256'. -- -- @since 0.1.0.0 fromHexBytes :: ByteString -> Either SHA256Exception SHA256 fromHexBytes hexBS = do mapLeft (InvalidHexBytes hexBS . T.pack) (Mem.convertFromBase Mem.Base16 hexBS) >>= fromRaw -- | Convert a 'Hash.Digest' into a 'SHA256' -- -- @since 0.1.0.0 fromDigest :: Hash.Digest Hash.SHA256 -> SHA256 fromDigest digest = case toStaticExact (Data.ByteArray.convert digest :: ByteString) of Left e -> error $ "Impossible failure in fromDigest: " ++ show (digest, e) Right x -> SHA256 x -- | Convert a raw representation of a hash into a 'SHA256'. -- -- @since 0.1.0.0 fromRaw :: ByteString -> Either SHA256Exception SHA256 fromRaw bs = either (Left . InvalidByteCount bs) (Right . SHA256) (toStaticExact bs) -- | Convert a 'SHA256' into a base16-encoded SHA256 hash. -- -- @since 0.1.0.0 toHexText :: SHA256 -> Text toHexText ss = case decodeUtf8' $ toHexBytes ss of Left e -> error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) Right t -> t -- | Convert a 'SHA256' into a base16-encoded SHA256 hash. -- -- @since 0.1.0.0 toHexBytes :: SHA256 -> ByteString toHexBytes (SHA256 x) = Mem.convertToBase Mem.Base16 x -- | Convert a 'SHA256' into a raw binary representation. -- -- @since 0.1.0.0 toRaw :: SHA256 -> ByteString toRaw (SHA256 x) = Data.ByteArray.convert x -- Instances instance Show SHA256 where show s = "SHA256 " ++ show (toHexText s) instance PersistField SHA256 where toPersistValue = PersistByteString . toRaw fromPersistValue (PersistByteString bs) = case toStaticExact bs of Left e -> Left $ tshow e Right ss -> pure $ SHA256 ss fromPersistValue x = Left $ "Unexpected value: " <> tshow x instance PersistFieldSql SHA256 where sqlType _ = SqlBlob instance Display SHA256 where display = displayBytesUtf8 . toHexBytes instance ToJSON SHA256 where toJSON = toJSON . toHexText instance FromJSON SHA256 where parseJSON = withText "SHA256" $ \t -> case fromHexText t of Right x -> pure x Left e -> fail $ concat [ "Invalid SHA256 " , show t , ": " , show e ] instance Exception SHA256Exception instance Show SHA256Exception where show = T.unpack . utf8BuilderToText . display instance Display SHA256Exception where display (InvalidByteCount bs sbe) = "Invalid byte count creating a SHA256 from " <> displayShow bs <> ": " <> displayShow sbe display (InvalidHexBytes bs t) = "Invalid hex bytes creating a SHA256: " <> displayShow bs <> ": " <> display t pantry-0.4.0.2/src/Pantry/Internal.hs0000644000000000000000000000431413712324626015542 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Exposed for testing, do not use! module Pantry.Internal ( parseTree , renderTree , Tree (..) , TreeEntry (..) , FileType(..) , mkSafeFilePath , pcHpackExecutable , normalizeParents , makeTarRelative , getGlobalHintsFile , hpackVersion , Storage , initStorage , withStorage_ ) where import Control.Exception (assert) import Pantry.Types import Pantry.SQLite (initStorage) import Pantry.HPack (hpackVersion) import qualified Data.Text as T import Data.Maybe (fromMaybe) -- | Like @System.FilePath.normalise@, however: -- -- * Only works on relative paths, absolute paths fail -- -- * Strips trailing slashes -- -- * Only works on forward slashes, even on Windows -- -- * Normalizes parent dirs @foo/../@ get stripped -- -- * Cannot begin with a parent directory (@../@) -- -- * Spelled like an American, sorry normalizeParents :: FilePath -> Either String FilePath normalizeParents "" = Left "empty file path" normalizeParents ('/':_) = Left "absolute path" normalizeParents ('.':'.':'/':_) = Left "absolute path" normalizeParents fp = do -- Strip a single trailing, but not multiple let t0 = T.pack fp t = fromMaybe t0 $ T.stripSuffix "/" t0 case T.unsnoc t of Just (_, '/') -> Left "multiple trailing slashes" _ -> Right () let c1 = T.split (== '/') t case reverse c1 of ".":_ -> Left "last component is a single dot" _ -> Right () let c2 = filter (\x -> not (T.null x || x == ".")) c1 let loop [] = [] loop (_:"..":rest) = loop rest loop (x:xs) = x : loop xs case loop c2 of [] -> Left "no non-empty components" c' -> Right $ T.unpack $ T.intercalate "/" c' -- | Following tar file rules (Unix file paths only), make the second -- file relative to the first file. makeTarRelative :: FilePath -- ^ base file -> FilePath -- ^ relative part -> Either String FilePath makeTarRelative _ ('/':_) = Left "absolute path found" makeTarRelative base rel = case reverse base of [] -> Left "cannot have empty base" '/':_ -> Left "base cannot be a directory" _:rest -> Right $ case dropWhile (/= '/') rest of '/':rest' -> reverse rest' ++ '/' : rel rest' -> assert (null rest') rel pantry-0.4.0.2/src/Pantry/Internal/StaticBytes.hs0000644000000000000000000001700413712324605017775 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} -- | This is an unstable API, exposed only for testing. Relying on -- this may break your code! Caveat emptor. -- -- This module can (and perhaps should) be separate into its own -- package, it's generally useful. module Pantry.Internal.StaticBytes ( Bytes8 , Bytes16 , Bytes32 , Bytes64 , Bytes128 , DynamicBytes , StaticBytes , StaticBytesException (..) , toStaticExact , toStaticPad , toStaticTruncate , toStaticPadTruncate , fromStatic ) where import RIO hiding (words) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Unboxed.Base as VU import qualified Data.Vector.Storable as VS import System.IO.Unsafe (unsafePerformIO) import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Storable import Data.Bits import qualified Data.Primitive.ByteArray as BA import Data.ByteArray newtype Bytes8 = Bytes8 Word64 deriving (Eq, Ord, Generic, NFData, Hashable, Data) instance Show Bytes8 where show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString) data Bytes16 = Bytes16 !Bytes8 !Bytes8 deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) data Bytes32 = Bytes32 !Bytes16 !Bytes16 deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) data Bytes64 = Bytes64 !Bytes32 !Bytes32 deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) data Bytes128 = Bytes128 !Bytes64 !Bytes64 deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) data StaticBytesException = NotEnoughBytes | TooManyBytes deriving (Show, Eq, Typeable) instance Exception StaticBytesException -- All lengths below are given in bytes class DynamicBytes dbytes where lengthD :: dbytes -> Int -- | Yeah, it looks terrible to use a list here, but fusion should -- kick in withPeekD :: dbytes -> ((Int -> IO Word64) -> IO a) -> IO a -- | May throw a runtime exception if invariants are violated! fromWordsD :: Int -> [Word64] -> dbytes fromWordsForeign :: (ForeignPtr a -> Int -> b) -> Int -> [Word64] -> b fromWordsForeign wrapper len words0 = unsafePerformIO $ do fptr <- B.mallocByteString len withForeignPtr fptr $ \ptr -> do let loop _ [] = return () loop off (w:ws) = do pokeElemOff (castPtr ptr) off w loop (off + 1) ws loop 0 words0 return $ wrapper fptr len withPeekForeign :: (ForeignPtr a, Int, Int) -> ((Int -> IO Word64) -> IO b) -> IO b withPeekForeign (fptr, off, len) inner = withForeignPtr fptr $ \ptr -> do let f off' | off' >= len = return 0 | off' + 8 > len = do let loop w64 i | off' + i >= len = return w64 | otherwise = do w8 :: Word8 <- peekByteOff ptr (off + off' + i) let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 loop w64' (i + 1) loop 0 0 | otherwise = peekByteOff ptr (off + off') inner f instance DynamicBytes B.ByteString where lengthD = B.length fromWordsD = fromWordsForeign (\fptr len -> B.fromForeignPtr fptr 0 len) withPeekD = withPeekForeign . B.toForeignPtr instance word8 ~ Word8 => DynamicBytes (VS.Vector word8) where lengthD = VS.length fromWordsD = fromWordsForeign VS.unsafeFromForeignPtr0 withPeekD = withPeekForeign . VS.unsafeToForeignPtr instance word8 ~ Word8 => DynamicBytes (VP.Vector word8) where lengthD = VP.length fromWordsD len words0 = unsafePerformIO $ do ba <- BA.newByteArray len let loop _ [] = VP.Vector 0 len <$> BA.unsafeFreezeByteArray ba loop i (w:ws) = do BA.writeByteArray ba i w loop (i + 1) ws loop 0 words0 withPeekD (VP.Vector off len ba) inner = do let f off' | off' >= len = return 0 | off' + 8 > len = do let loop w64 i | off' + i >= len = return w64 | otherwise = do let w8 :: Word8 = BA.indexByteArray ba (off + off' + i) let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 loop w64' (i + 1) loop 0 0 | otherwise = return $ BA.indexByteArray ba (off + (off' `div` 8)) inner f instance word8 ~ Word8 => DynamicBytes (VU.Vector word8) where lengthD = VU.length fromWordsD len words = VU.V_Word8 (fromWordsD len words) withPeekD (VU.V_Word8 v) = withPeekD v class StaticBytes sbytes where lengthS :: proxy sbytes -> Int -- use type level literals instead? -- difference list toWordsS :: sbytes -> [Word64] -> [Word64] usePeekS :: Int -> (Int -> IO Word64) -> IO sbytes instance StaticBytes Bytes8 where lengthS _ = 8 toWordsS (Bytes8 w) = (w:) usePeekS off f = Bytes8 <$> f off instance StaticBytes Bytes16 where lengthS _ = 16 toWordsS (Bytes16 b1 b2) = toWordsS b1 . toWordsS b2 usePeekS off f = Bytes16 <$> usePeekS off f <*> usePeekS (off + 8) f instance StaticBytes Bytes32 where lengthS _ = 32 toWordsS (Bytes32 b1 b2) = toWordsS b1 . toWordsS b2 usePeekS off f = Bytes32 <$> usePeekS off f <*> usePeekS (off + 16) f instance StaticBytes Bytes64 where lengthS _ = 64 toWordsS (Bytes64 b1 b2) = toWordsS b1 . toWordsS b2 usePeekS off f = Bytes64 <$> usePeekS off f <*> usePeekS (off + 32) f instance StaticBytes Bytes128 where lengthS _ = 128 toWordsS (Bytes128 b1 b2) = toWordsS b1 . toWordsS b2 usePeekS off f = Bytes128 <$> usePeekS off f <*> usePeekS (off + 64) f instance ByteArrayAccess Bytes8 where length _ = 8 withByteArray = withByteArrayS instance ByteArrayAccess Bytes16 where length _ = 16 withByteArray = withByteArrayS instance ByteArrayAccess Bytes32 where length _ = 32 withByteArray = withByteArrayS instance ByteArrayAccess Bytes64 where length _ = 64 withByteArray = withByteArrayS instance ByteArrayAccess Bytes128 where length _ = 128 withByteArray = withByteArrayS withByteArrayS :: StaticBytes sbytes => sbytes -> (Ptr p -> IO a) -> IO a withByteArrayS sbytes = withByteArray (fromStatic sbytes :: ByteString) toStaticExact :: forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes) => dbytes -> Either StaticBytesException sbytes toStaticExact dbytes = case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of LT -> Left NotEnoughBytes GT -> Left TooManyBytes EQ -> Right (toStaticPadTruncate dbytes) toStaticPad :: forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes) => dbytes -> Either StaticBytesException sbytes toStaticPad dbytes = case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of GT -> Left TooManyBytes _ -> Right (toStaticPadTruncate dbytes) toStaticTruncate :: forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes) => dbytes -> Either StaticBytesException sbytes toStaticTruncate dbytes = case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of LT -> Left NotEnoughBytes _ -> Right (toStaticPadTruncate dbytes) toStaticPadTruncate :: (DynamicBytes dbytes, StaticBytes sbytes) => dbytes -> sbytes toStaticPadTruncate dbytes = unsafePerformIO (withPeekD dbytes (usePeekS 0)) fromStatic :: forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes) => sbytes -> dbytes fromStatic = fromWordsD (lengthS (Nothing :: Maybe sbytes)) . ($ []) . toWordsS pantry-0.4.0.2/src/Pantry/Internal/Stackage.hs0000644000000000000000000000156413712324626017270 0ustar0000000000000000-- | All types and functions exported from this module are for advanced usage -- only. They are needed for stackage-server integration with pantry. module Pantry.Internal.Stackage ( module X ) where import Pantry.Hackage as X ( forceUpdateHackageIndex , getHackageTarball , HackageTarballResult(..) ) import Pantry.Storage as X ( BlobId , EntityField(..) , HackageCabalId , ModuleNameId , PackageName , PackageNameId , Tree(..) , TreeEntryId , TreeId , Unique(..) , Version , VersionId , getBlobKey , getPackageNameById , getPackageNameId , getTreeForKey , getVersionId , loadBlobById , storeBlob , migrateAll , Key(unBlobKey) ) import Pantry.Types as X ( ModuleNameP(..) , PackageNameP(..) , PantryConfig(..) , SafeFilePath , Storage(..) , VersionP(..) , mkSafeFilePath , packageTreeKey , unSafeFilePath ) pantry-0.4.0.2/src/Pantry/Internal/Companion.hs0000644000000000000000000000564513712324605017472 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE NoImplicitPrelude #-} -- | Companion threads, such as for printing messages saying we're -- still busy. Ultimately this could be put into its own package. This -- is a non-standard API for use by Pantry and Stack, please /DO NOT -- DEPEND ON IT/. module Pantry.Internal.Companion ( withCompanion , onCompanionDone , Companion , Delay , StopCompanion ) where import RIO -- | A companion thread which can perform arbitrary actions as well as delay type Companion m = Delay -> m () -- | Delay the given number of microseconds. If 'StopCompanion' is -- triggered before the timer completes, a 'CompanionDone' exception -- will be thrown (which is caught internally by 'withCompanion'). type Delay = forall mio. MonadIO mio => Int -> mio () -- | Tell the 'Companion' to stop. The next time 'Delay' is -- called, or if a 'Delay' is currently blocking, the 'Companion' thread -- will exit with a 'CompanionDone' exception. type StopCompanion m = m () -- | When a delay was interrupted because we're told to stop, perform -- this action. onCompanionDone :: MonadUnliftIO m => m () -- ^ the delay -> m () -- ^ action to perform -> m () onCompanionDone theDelay theAction = theDelay `withException` \CompanionDone -> theAction -- | Internal exception used by 'withCompanion' to allow short-circuiting -- of the 'Companion'. Should not be used outside of this module. data CompanionDone = CompanionDone deriving (Show, Typeable) instance Exception CompanionDone -- | Keep running the 'Companion' action until either the inner action -- completes or calls the 'StopCompanion' action. This can be used to -- give the user status information while running a long running -- operations. withCompanion :: forall m a. MonadUnliftIO m => Companion m -> (StopCompanion m -> m a) -> m a withCompanion companion inner = do -- Variable to indicate 'Delay'ing should result in a 'CompanionDone' -- exception. shouldStopVar <- newTVarIO False let -- Relatively simple: set shouldStopVar to True stopCompanion = atomically $ writeTVar shouldStopVar True delay :: Delay delay usec = do -- Register a delay with the runtime system delayDoneVar <- registerDelay usec join $ atomically $ -- Delay has triggered, keep going (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|> -- Time to stop the companion, throw a 'CompanionDone' exception immediately (throwIO CompanionDone <$ (readTVar shouldStopVar >>= checkSTM)) -- Run the 'Companion' and inner action together runConcurrently $ -- Ignore a 'CompanionDone' exception from the companion, that's expected behavior Concurrently (companion delay `catch` \CompanionDone -> pure ()) *> -- Run the inner action, giving it the 'StopCompanion' action, and -- ensuring it is called regardless of exceptions. Concurrently (inner stopCompanion `finally` stopCompanion) pantry-0.4.0.2/src/Pantry/Internal/AesonExtended.hs0000644000000000000000000001706113712324605020270 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -- | Extensions to Aeson parsing of objects. This module is intended -- for internal use by Pantry and Stack only. The intention is to -- fully remove this module in the future. /DO NOT RELY ON IT/. module Pantry.Internal.AesonExtended ( module Export -- * Extended failure messages , (.:) , (.:?) -- * JSON Parser that emits warnings , JSONWarning (..) , WarningParser , WithJSONWarnings (..) , withObjectWarnings , jsonSubWarnings , jsonSubWarningsT , jsonSubWarningsTT , logJSONWarnings , noJSONWarnings , tellJSONField , unWarningParser , (..:) , (...:) , (..:?) , (...:?) , (..!=) ) where import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell) import Data.Aeson as Export hiding ((.:), (.:?)) import qualified Data.Aeson as A import Data.Aeson.Types hiding ((.:), (.:?)) import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set import Data.Text (unpack) import qualified Data.Text as T import Generics.Deriving.Monoid (mappenddefault, memptydefault) import RIO import RIO.PrettyPrint.StylesUpdate (StylesUpdate) -- | Extends @.:@ warning to include field name. (.:) :: FromJSON a => Object -> Text -> Parser a (.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p) {-# INLINE (.:) #-} -- | Extends @.:?@ warning to include field name. (.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a) (.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p) {-# INLINE (.:?) #-} -- | 'WarningParser' version of @.:@. (..:) :: FromJSON a => Object -> Text -> WarningParser a o ..: k = tellJSONField k >> lift (o .: k) -- | 'WarningParser' version of @.:?@. (..:?) :: FromJSON a => Object -> Text -> WarningParser (Maybe a) o ..:? k = tellJSONField k >> lift (o .:? k) -- | 'WarningParser' version of @.!=@. (..!=) :: WarningParser (Maybe a) -> a -> WarningParser a wp ..!= d = flip mapWriterT wp $ \p -> do a <- fmap snd p fmap (, a) (fmap fst p .!= d) presentCount :: Object -> [Text] -> Int presentCount o ss = length . filter (\x -> HashMap.member x o) $ ss -- | Synonym version of @..:@. (...:) :: FromJSON a => Object -> [Text] -> WarningParser a _ ...: [] = fail "failed to find an empty key" o ...: ss@(key:_) = apply where pc = presentCount o ss apply | pc == 0 = fail $ "failed to parse field " ++ show key ++ ": " ++ "keys " ++ show ss ++ " not present" | pc > 1 = fail $ "failed to parse field " ++ show key ++ ": " ++ "two or more synonym keys " ++ show ss ++ " present" | otherwise = asum $ map (o..:) ss -- | Synonym version of @..:?@. (...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a) _ ...:? [] = fail "failed to find an empty key" o ...:? ss@(key:_) = apply where pc = presentCount o ss apply | pc == 0 = return Nothing | pc > 1 = fail $ "failed to parse field " ++ show key ++ ": " ++ "two or more synonym keys " ++ show ss ++ " present" | otherwise = asum $ map (o..:) ss -- | Tell warning parser about an expected field, so it doesn't warn about it. tellJSONField :: Text -> WarningParser () tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key}) -- | 'WarningParser' version of 'withObject'. withObjectWarnings :: String -> (Object -> WarningParser a) -> Value -> Parser (WithJSONWarnings a) withObjectWarnings expected f = withObject expected $ \obj -> do (a,w) <- runWriterT (f obj) let unrecognizedFields = Set.toList (Set.difference (Set.fromList (HashMap.keys obj)) (wpmExpectedFields w)) return (WithJSONWarnings a (wpmWarnings w ++ case unrecognizedFields of [] -> [] _ -> [JSONUnrecognizedFields expected unrecognizedFields])) -- | Convert a 'WarningParser' to a 'Parser'. unWarningParser :: WarningParser a -> Parser a unWarningParser wp = do (a,_) <- runWriterT wp return a -- | Log JSON warnings. logJSONWarnings :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) => FilePath -> [JSONWarning] -> m () logJSONWarnings fp = mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w)) -- | Handle warnings in a sub-object. jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a jsonSubWarnings f = do WithJSONWarnings result warnings <- f tell (mempty { wpmWarnings = warnings }) return result -- | Handle warnings in a @Traversable@ of sub-objects. jsonSubWarningsT :: Traversable t => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a) jsonSubWarningsT f = mapM (jsonSubWarnings . return) =<< f -- | Handle warnings in a @Maybe Traversable@ of sub-objects. jsonSubWarningsTT :: (Traversable t, Traversable u) => WarningParser (u (t (WithJSONWarnings a))) -> WarningParser (u (t a)) jsonSubWarningsTT f = mapM (jsonSubWarningsT . return) =<< f -- Parsed JSON value without any warnings noJSONWarnings :: a -> WithJSONWarnings a noJSONWarnings v = WithJSONWarnings v [] -- | JSON parser that warns about unexpected fields in objects. type WarningParser a = WriterT WarningParserMonoid Parser a -- | Monoid used by 'WarningParser' to track expected fields and warnings. data WarningParserMonoid = WarningParserMonoid { wpmExpectedFields :: !(Set Text) , wpmWarnings :: [JSONWarning] } deriving Generic instance Semigroup WarningParserMonoid where (<>) = mappenddefault instance Monoid WarningParserMonoid where mempty = memptydefault mappend = (<>) instance IsString WarningParserMonoid where fromString s = mempty { wpmWarnings = [fromString s] } -- Parsed JSON value with its warnings data WithJSONWarnings a = WithJSONWarnings a [JSONWarning] deriving (Eq, Generic, Show) instance Functor WithJSONWarnings where fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w instance Monoid a => Semigroup (WithJSONWarnings a) where (<>) = mappenddefault instance Monoid a => Monoid (WithJSONWarnings a) where mempty = memptydefault mappend = (<>) -- | Warning output from 'WarningParser'. data JSONWarning = JSONUnrecognizedFields String [Text] | JSONGeneralWarning !Text deriving Eq instance Show JSONWarning where show = T.unpack . utf8BuilderToText . display instance Display JSONWarning where display (JSONUnrecognizedFields obj [field]) = "Unrecognized field in " <> fromString obj <> ": " <> display field display (JSONUnrecognizedFields obj fields) = "Unrecognized fields in " <> fromString obj <> ": " <> display (T.intercalate ", " fields) display (JSONGeneralWarning t) = display t instance IsString JSONWarning where fromString = JSONGeneralWarning . T.pack instance FromJSON (WithJSONWarnings StylesUpdate) where parseJSON v = noJSONWarnings <$> parseJSON v pantry-0.4.0.2/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs0000644000000000000000000001334113712324605024661 0ustar0000000000000000-- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -- Taken from -- https://github.com/well-typed/hackage-security/tree/master/hackage-security-http-client -- to avoid extra dependencies module Hackage.Security.Client.Repository.HttpLib.HttpClient ( httpLib ) where import Control.Exception import Control.Monad (void) import Data.ByteString (ByteString) import Network.URI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.C8 import qualified Pantry.HTTP as HTTP import Hackage.Security.Client hiding (Header) import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked {------------------------------------------------------------------------------- Top-level API -------------------------------------------------------------------------------} -- | An 'HttpLib' value using the default global manager httpLib :: HttpLib httpLib = HttpLib { httpGet = get , httpGetRange = getRange } {------------------------------------------------------------------------------- Individual methods -------------------------------------------------------------------------------} get :: Throws SomeRemoteError => [HttpRequestHeader] -> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a get reqHeaders uri callback = wrapCustomEx $ do -- TODO: setUri fails under certain circumstances; in particular, when -- the URI contains URL auth. Not sure if this is a concern. request' <- HTTP.setUri HTTP.defaultRequest uri let request = setRequestHeaders reqHeaders request' checkHttpException $ HTTP.withResponse request $ \response -> do let br = wrapCustomEx $ HTTP.getResponseBody response callback (getResponseHeaders response) br getRange :: Throws SomeRemoteError => [HttpRequestHeader] -> URI -> (Int, Int) -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a getRange reqHeaders uri (from, to) callback = wrapCustomEx $ do request' <- HTTP.setUri HTTP.defaultRequest uri let request = setRange from to $ setRequestHeaders reqHeaders request' checkHttpException $ HTTP.withResponse request $ \response -> do let br = wrapCustomEx $ HTTP.getResponseBody response case () of () | HTTP.getResponseStatus response == HTTP.partialContent206 -> callback HttpStatus206PartialContent (getResponseHeaders response) br () | HTTP.getResponseStatus response == HTTP.ok200 -> callback HttpStatus200OK (getResponseHeaders response) br _otherwise -> throwChecked $ HTTP.HttpExceptionRequest request $ HTTP.StatusCodeException (void response) "" -- | Wrap custom exceptions -- -- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ -- but it is currently disabled wrapCustomEx :: (Throws HTTP.HttpException => IO a) -> (Throws SomeRemoteError => IO a) wrapCustomEx act = handleChecked (\(ex :: HTTP.HttpException) -> go ex) act where go ex = throwChecked (SomeRemoteError ex) checkHttpException :: Throws HTTP.HttpException => IO a -> IO a checkHttpException = handle $ \(ex :: HTTP.HttpException) -> throwChecked ex {------------------------------------------------------------------------------- http-client auxiliary -------------------------------------------------------------------------------} hAcceptRanges :: HTTP.HeaderName hAcceptRanges = "Accept-Ranges" hAcceptEncoding :: HTTP.HeaderName hAcceptEncoding = "Accept-Encoding" setRange :: Int -> Int -> HTTP.Request -> HTTP.Request setRange from to = HTTP.addRequestHeader HTTP.hRange rangeHeader where -- Content-Range header uses inclusive rather than exclusive bounds -- See rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) -- | Set request headers setRequestHeaders :: [HttpRequestHeader] -> HTTP.Request -> HTTP.Request setRequestHeaders opts = HTTP.setRequestHeaders (trOpt disallowCompressionByDefault opts) where trOpt :: [(HTTP.HeaderName, [ByteString])] -> [HttpRequestHeader] -> [HTTP.Header] trOpt acc [] = concatMap finalizeHeader acc trOpt acc (HttpRequestMaxAge0:os) = trOpt (insert HTTP.hCacheControl ["max-age=0"] acc) os trOpt acc (HttpRequestNoTransform:os) = trOpt (insert HTTP.hCacheControl ["no-transform"] acc) os -- disable content compression (potential security issue) disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])] disallowCompressionByDefault = [(hAcceptEncoding, [])] -- Some headers are comma-separated, others need multiple headers for -- multiple options. -- -- TODO: Right we we just comma-separate all of them. finalizeHeader :: (HTTP.HeaderName, [ByteString]) -> [HTTP.Header] finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))] insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] insert _ _ [] = [] insert x y ((k, v):pairs) | x == k = (k, v ++ y) : insert x y pairs | otherwise = (k, v) : insert x y pairs -- | Extract the response headers getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader] getResponseHeaders response = concat [ [ HttpResponseAcceptRangesBytes | (hAcceptRanges, "bytes") `elem` headers ] ] where headers = HTTP.getResponseHeaders response pantry-0.4.0.2/src/Pantry/Archive.hs0000644000000000000000000005000513712324605015342 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Logic for loading up trees from HTTPS archives. module Pantry.Archive ( getArchivePackage , getArchive , getArchiveKey , fetchArchivesRaw , fetchArchives , findCabalOrHpackFile ) where import RIO import qualified Pantry.SHA256 as SHA256 import Pantry.Storage hiding (Tree, TreeEntry) import Pantry.Tree import Pantry.Types import RIO.Process import Pantry.Internal (normalizeParents, makeTarRelative) import qualified RIO.Text as T import qualified RIO.Text.Partial as T import qualified RIO.List as List import qualified RIO.ByteString.Lazy as BL import qualified RIO.Map as Map import qualified RIO.Set as Set import qualified Hpack.Config as Hpack import Pantry.HPack (hpackVersion) import Data.Bits ((.&.), shiftR) import Path (toFilePath) import qualified Codec.Archive.Zip as Zip import qualified Data.Digest.CRC32 as CRC32 import Distribution.PackageDescription (packageDescription, package) import Conduit import Data.Conduit.Zlib (ungzip) import qualified Data.Conduit.Tar as Tar import Pantry.HTTP fetchArchivesRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(RawArchive, RawPackageMetadata)] -> RIO env () fetchArchivesRaw pairs = for_ pairs $ \(ra, rpm) -> getArchive (RPLIArchive ra rpm) ra rpm fetchArchives :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Archive, PackageMetadata)] -> RIO env () fetchArchives pairs = -- TODO be more efficient, group together shared archives fetchArchivesRaw [(toRawArchive a, toRawPM pm) | (a, pm) <- pairs] getArchiveKey :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata -> RIO env TreeKey getArchiveKey rpli archive rpm = packageTreeKey <$> getArchivePackage rpli archive rpm -- potential optimization thd3 :: (a, b, c) -> c thd3 (_, _, z) = z getArchivePackage :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata -> RIO env Package getArchivePackage rpli archive rpm = thd3 <$> getArchive rpli archive rpm getArchive :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata -> RIO env (SHA256, FileSize, Package) getArchive rpli archive rpm = do -- Check if the value is in the archive, and use it if possible mcached <- loadCache rpli archive cached@(_, _, pa) <- case mcached of Just stored -> pure stored -- Not in the archive. Load the archive. Completely ignore the -- PackageMetadata for now, we'll check that the Package -- info matches next. Nothing -> withArchiveLoc archive $ \fp sha size -> do pa <- parseArchive rpli archive fp -- Storing in the cache exclusively uses information we have -- about the archive itself, not metadata from the user. storeCache archive sha size pa pure (sha, size, pa) either throwIO (\_ -> pure cached) $ checkPackageMetadata rpli rpm pa storeCache :: forall env. (HasPantryConfig env, HasLogFunc env) => RawArchive -> SHA256 -> FileSize -> Package -> RIO env () storeCache archive sha size pa = case raLocation archive of ALUrl url -> withStorage $ storeArchiveCache url (raSubdir archive) sha size (packageTreeKey pa) ALFilePath _ -> pure () -- TODO cache local as well loadCache :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package)) loadCache rpli archive = case loc of ALFilePath _ -> pure Nothing -- TODO can we do something intelligent here? ALUrl url -> withStorage (loadArchiveCache url (raSubdir archive)) >>= loop where loc = raLocation archive msha = raHash archive msize = raSize archive loadFromCache :: TreeId -> RIO env (Maybe Package) loadFromCache tid = fmap Just $ withStorage $ loadPackageById rpli tid loop [] = pure Nothing loop ((sha, size, tid):rest) = case msha of Nothing -> do case msize of Just size' | size /= size' -> loop rest _ -> do case loc of ALUrl url -> do -- Only debug level, let lock files solve this logDebug $ "Using archive from " <> display url <> " without a specified cryptographic hash" logDebug $ "Cached hash is " <> display sha <> ", file size " <> display size ALFilePath _ -> pure () fmap (sha, size,) <$> loadFromCache tid Just sha' | sha == sha' -> case msize of Nothing -> do case loc of -- Only debug level, let lock files solve this ALUrl url -> logDebug $ "Archive from " <> display url <> " does not specify a size" ALFilePath _ -> pure () fmap (sha, size,) <$> loadFromCache tid Just size' | size == size' -> fmap (sha, size,) <$> loadFromCache tid | otherwise -> do -- This is an actual warning, since we have a concrete mismatch logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" logWarn "Please verify that your configuration provides the correct size" loop rest | otherwise -> loop rest -- ensure name, version, etc are correct checkPackageMetadata :: RawPackageLocationImmutable -> RawPackageMetadata -> Package -> Either PantryException Package checkPackageMetadata pl pm pa = do let err = MismatchedPackageMetadata pl pm (Just (packageTreeKey pa)) (packageIdent pa) test :: Eq a => Maybe a -> a -> Bool test (Just x) y = x == y test Nothing _ = True tests = [ test (rpmTreeKey pm) (packageTreeKey pa) , test (rpmName pm) (pkgName $ packageIdent pa) , test (rpmVersion pm) (pkgVersion $ packageIdent pa) ] in if and tests then Right pa else Left err -- | Provide a local file with the contents of the archive, regardless -- of where it comes from. Perform SHA256 and file size validation if -- downloading. withArchiveLoc :: HasLogFunc env => RawArchive -> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a withArchiveLoc (RawArchive (ALFilePath resolved) msha msize _subdir) f = do let abs' = resolvedAbsolute resolved fp = toFilePath abs' (sha, size) <- withBinaryFile fp ReadMode $ \h -> do size <- FileSize . fromIntegral <$> hFileSize h for_ msize $ \size' -> when (size /= size') $ throwIO $ LocalInvalidSize abs' Mismatch { mismatchExpected = size' , mismatchActual = size } sha <- runConduit (sourceHandle h .| SHA256.sinkHash) for_ msha $ \sha' -> when (sha /= sha') $ throwIO $ LocalInvalidSHA256 abs' Mismatch { mismatchExpected = sha' , mismatchActual = sha } pure (sha, size) f fp sha size withArchiveLoc (RawArchive (ALUrl url) msha msize _subdir) f = withSystemTempFile "archive" $ \fp hout -> do logDebug $ "Downloading archive from " <> display url (sha, size, ()) <- httpSinkChecked url msha msize (sinkHandle hout) hClose hout f fp sha size data ArchiveType = ATTarGz | ATTar | ATZip deriving (Enum, Bounded) instance Display ArchiveType where display ATTarGz = "GZIP-ed tar file" display ATTar = "Uncompressed tar file" display ATZip = "Zip file" data METype = METNormal | METExecutable | METLink !FilePath deriving Show data MetaEntry = MetaEntry { mePath :: !FilePath , meType :: !METype } deriving Show foldArchive :: (HasPantryConfig env, HasLogFunc env) => ArchiveLocation -- ^ for error reporting -> FilePath -> ArchiveType -> a -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a) -> RIO env a foldArchive loc fp ATTarGz accum f = withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar loc accum f foldArchive loc fp ATTar accum f = withSourceFile fp $ \src -> runConduit $ src .| foldTar loc accum f foldArchive loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do let go accum entry = do let me = MetaEntry (Zip.eRelativePath entry) met met = fromMaybe METNormal $ do let modes = shiftR (Zip.eExternalFileAttributes entry) 16 guard $ Zip.eVersionMadeBy entry .&. 0xFF00 == 0x0300 guard $ modes /= 0 Just $ if (modes .&. 0o100) == 0 then METNormal else METExecutable lbs = Zip.fromEntry entry let crcExpected = Zip.eCRC32 entry crcActual = CRC32.crc32 lbs when (crcExpected /= crcActual) $ throwIO $ CRC32Mismatch loc (Zip.eRelativePath entry) Mismatch { mismatchExpected = crcExpected , mismatchActual = crcActual } runConduit $ sourceLazy lbs .| f accum me isDir entry = case reverse $ Zip.eRelativePath entry of '/':_ -> True _ -> False -- We're entering lazy I/O land thanks to zip-archive. lbs <- BL.hGetContents h foldM go accum0 (filter (not . isDir) $ Zip.zEntries $ Zip.toArchive lbs) foldTar :: (HasPantryConfig env, HasLogFunc env) => ArchiveLocation -- ^ for exceptions -> a -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a) -> ConduitT ByteString o (RIO env) a foldTar loc accum0 f = do ref <- newIORef accum0 Tar.untar $ \fi -> toME fi >>= traverse_ (\me -> do accum <- readIORef ref accum' <- f accum me writeIORef ref $! accum') readIORef ref where toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry) toME fi = do let exc = InvalidTarFileType loc (Tar.getFileInfoPath fi) (Tar.fileType fi) mmet <- case Tar.fileType fi of Tar.FTSymbolicLink bs -> case decodeUtf8' bs of Left _ -> throwIO exc Right text -> pure $ Just $ METLink $ T.unpack text Tar.FTNormal -> pure $ Just $ if Tar.fileMode fi .&. 0o100 /= 0 then METExecutable else METNormal Tar.FTDirectory -> pure Nothing _ -> throwIO exc pure $ (\met -> MetaEntry { mePath = Tar.getFileInfoPath fi , meType = met }) <$> mmet data SimpleEntry = SimpleEntry { seSource :: !FilePath , seType :: !FileType } deriving Show -- | Attempt to parse the contents of the given archive in the given -- subdir into a 'Tree'. This will not consult any caches. It will -- ensure that: -- -- * The cabal file exists -- -- * The cabal file can be parsed -- -- * The name inside the cabal file matches the name of the cabal file itself parseArchive :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RawArchive -> FilePath -- ^ file holding the archive -> RIO env Package parseArchive rpli archive fp = do let loc = raLocation archive getFiles [] = throwIO $ UnknownArchiveType loc getFiles (at:ats) = do eres <- tryAny $ foldArchive loc fp at id $ \m me -> pure $ m . (me:) case eres of Left e -> do logDebug $ "parseArchive of " <> display at <> ": " <> displayShow e getFiles ats Right files -> pure (at, Map.fromList $ map (mePath &&& id) $ files []) (at :: ArchiveType, files :: Map FilePath MetaEntry) <- getFiles [minBound..maxBound] let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry) toSimple key me = case meType me of METNormal -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTNormal METExecutable -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTExecutable METLink relDest -> do case relDest of '/':_ -> Left $ concat [ "File located at " , show $ mePath me , " is a symbolic link to absolute path " , relDest ] _ -> Right () dest0 <- case makeTarRelative (mePath me) relDest of Left e -> Left $ concat [ "Error resolving relative path " , relDest , " from symlink at " , mePath me , ": " , e ] Right x -> Right x dest <- case normalizeParents dest0 of Left e -> Left $ concat [ "Invalid symbolic link from " , mePath me , " to " , relDest , ", tried parsing " , dest0 , ": " , e ] Right x -> Right x -- Check if it's a symlink to a file case Map.lookup dest files of Nothing -> -- Check if it's a symlink to a directory case findWithPrefix dest files of [] -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest ++ ".\n" ++ "This may indicate that the source is a git archive which uses git-annex.\n" ++ "See https://github.com/commercialhaskell/stack/issues/4579 for further information." pairs -> fmap fold $ for pairs $ \(suffix, me') -> toSimple (key ++ '/' : suffix) me' Just me' -> case meType me' of METNormal -> Right $ Map.singleton key $ SimpleEntry dest FTNormal METExecutable -> Right $ Map.singleton key $ SimpleEntry dest FTExecutable METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest case fold <$> Map.traverseWithKey toSimple files of Left e -> throwIO $ UnsupportedTarball loc $ T.pack e Right files1 -> do let files2 = stripCommonPrefix $ Map.toList files1 files3 = takeSubdir (raSubdir archive) files2 toSafe (fp', a) = case mkSafeFilePath fp' of Nothing -> Left $ "Not a safe file path: " ++ show fp' Just sfp -> Right (sfp, a) case traverse toSafe files3 of Left e -> throwIO $ UnsupportedTarball loc $ T.pack e Right safeFiles -> do let toSave = Set.fromList $ map (seSource . snd) safeFiles (blobs :: Map FilePath BlobKey) <- foldArchive loc fp at mempty $ \m me -> if mePath me `Set.member` toSave then do bs <- mconcat <$> sinkList (_, blobKey) <- lift $ withStorage $ storeBlob bs pure $ Map.insert (mePath me) blobKey m else pure m tree <- fmap (TreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) -> case Map.lookup (seSource se) blobs of Nothing -> error $ "Impossible: blob not found for: " ++ seSource se Just blobKey -> pure (sfp, TreeEntry blobKey (seType se)) -- parse the cabal file and ensure it has the right name buildFile <- findCabalOrHpackFile rpli tree (buildFilePath, buildFileBlobKey, buildFileEntry) <- case buildFile of BFCabal fpath te@(TreeEntry key _) -> pure (fpath, key, te) BFHpack te@(TreeEntry key _) -> pure (hpackSafeFilePath, key, te) mbs <- withStorage $ loadBlob buildFileBlobKey bs <- case mbs of Nothing -> throwIO $ TreeReferencesMissingBlob rpli buildFilePath buildFileBlobKey Just bs -> pure bs cabalBs <- case buildFile of BFCabal _ _ -> pure bs BFHpack _ -> snd <$> hpackToCabal rpli tree (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBs let ident@(PackageIdentifier name _) = package $ packageDescription gpd case buildFile of BFCabal _ _ -> when (buildFilePath /= cabalFileName name) $ throwIO $ WrongCabalFileName rpli buildFilePath name _ -> return () -- It's good! Store the tree, let's bounce (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile packageCabal <- case buildFile of BFCabal _ _ -> pure $ PCCabalFile buildFileEntry BFHpack _ -> do cabalKey <- withStorage $ do hpackId <- storeHPack rpli tid loadCabalBlobKey hpackId hpackSoftwareVersion <- hpackVersion let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) pure $ PCHpack $ PHpack { phOriginal = buildFileEntry, phGenerated = cabalTreeEntry, phVersion = hpackSoftwareVersion} pure Package { packageTreeKey = treeKey' , packageTree = tree , packageCabalEntry = packageCabal , packageIdent = ident } -- | Find all of the files in the Map with the given directory as a -- prefix. Directory is given without trailing slash. Returns the -- suffix after stripping the given prefix. findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)] findWithPrefix dir = mapMaybe go . Map.toList where prefix = dir ++ "/" go (x, y) = (, y) <$> List.stripPrefix prefix x findCabalOrHpackFile :: MonadThrow m => RawPackageLocationImmutable -- ^ for exceptions -> Tree -> m BuildFile findCabalOrHpackFile loc (TreeMap m) = do let isCabalFile (sfp, _) = let txt = unSafeFilePath sfp in not ("/" `T.isInfixOf` txt) && (".cabal" `T.isSuffixOf` txt) isHpackFile (sfp, _) = let txt = unSafeFilePath sfp in T.pack (Hpack.packageConfig) == txt isBFCabal (BFCabal _ _) = True isBFCabal _ = False sfpBuildFile (BFCabal sfp _) = sfp sfpBuildFile (BFHpack _) = hpackSafeFilePath toBuildFile xs@(sfp, te) = let cbFile = if (isCabalFile xs) then Just $ BFCabal sfp te else Nothing hpFile = if (isHpackFile xs) then Just $ BFHpack te else Nothing in cbFile <|> hpFile case mapMaybe toBuildFile $ Map.toList m of [] -> throwM $ TreeWithoutCabalFile loc [bfile] -> pure bfile xs -> case (filter isBFCabal xs) of [] -> throwM $ TreeWithoutCabalFile loc [bfile] -> pure bfile xs' -> throwM $ TreeWithMultipleCabalFiles loc $ map sfpBuildFile xs' -- | If all files have a shared prefix, strip it off stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] stripCommonPrefix [] = [] stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do let firstDir = takeWhile (/= '/') firstFP guard $ not $ null firstDir let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp stripCommonPrefix <$> traverse strip pairs -- | Take us down to the specified subdirectory takeSubdir :: Text -- ^ subdir -> [(FilePath, a)] -- ^ files after stripping common prefix -> [(Text, a)] takeSubdir subdir = mapMaybe $ \(fp, a) -> do stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp Just (T.intercalate "/" stripped, a) where splitDirs = List.dropWhile (== ".") . filter (/= "") . T.splitOn "/" subdirs = splitDirs subdir pantry-0.4.0.2/src/Pantry/HTTP.hs0000644000000000000000000000776013712324605014552 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.HTTP ( module Export , withResponse , httpSink , httpSinkChecked ) where import Conduit import Network.HTTP.Client as Export (parseRequest) import Network.HTTP.Client as Export (parseUrlThrow) import Network.HTTP.Client as Export (BodyReader, HttpExceptionContent (StatusCodeException)) import qualified Network.HTTP.Client as HTTP (withResponse) import Network.HTTP.Client.Internal as Export (setUri) import Network.HTTP.Client.TLS (getGlobalManager) import Network.HTTP.Simple as Export (HttpException (..), Request, Response, addRequestHeader, defaultRequest, getResponseBody, getResponseHeaders, getResponseStatus, setRequestHeader, setRequestHeaders) import qualified Network.HTTP.Simple as HTTP hiding (withResponse) import Network.HTTP.Types as Export (Header, HeaderName, Status, hCacheControl, hRange, ok200, partialContent206, statusCode) import qualified Pantry.SHA256 as SHA256 import Pantry.Types import RIO import qualified RIO.ByteString as B import qualified RIO.Text as T setUserAgent :: Request -> Request setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"] withResponse :: MonadUnliftIO m => HTTP.Request -> (Response BodyReader -> m a) -> m a withResponse req inner = withRunInIO $ \run -> do manager <- getGlobalManager HTTP.withResponse (setUserAgent req) manager (run . inner) httpSink :: MonadUnliftIO m => Request -> (Response () -> ConduitT ByteString Void m a) -> m a httpSink req inner = HTTP.httpSink (setUserAgent req) inner httpSinkChecked :: MonadUnliftIO m => Text -> Maybe SHA256 -> Maybe FileSize -> ConduitT ByteString Void m a -> m (SHA256, FileSize, a) httpSinkChecked url msha msize sink = do req <- liftIO $ parseUrlThrow $ T.unpack url httpSink req $ const $ getZipSink $ (,,) <$> ZipSink (checkSha msha) <*> ZipSink (checkSize msize) <*> ZipSink sink where checkSha mexpected = do actual <- SHA256.sinkHash for_ mexpected $ \expected -> unless (actual == expected) $ throwIO $ DownloadInvalidSHA256 url Mismatch { mismatchExpected = expected , mismatchActual = actual } pure actual checkSize mexpected = loop 0 where loop accum = do mbs <- await case mbs of Nothing -> case mexpected of Just (FileSize expected) | expected /= accum -> throwIO $ DownloadInvalidSize url Mismatch { mismatchExpected = FileSize expected , mismatchActual = FileSize accum } _ -> pure (FileSize accum) Just bs -> do let accum' = accum + fromIntegral (B.length bs) case mexpected of Just (FileSize expected) | accum' > expected -> throwIO $ DownloadTooLarge url Mismatch { mismatchExpected = FileSize expected , mismatchActual = FileSize accum' } _ -> loop accum' pantry-0.4.0.2/src/Pantry/HPack.hs0000644000000000000000000000577713712324605014767 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Pantry.HPack ( hpack , hpackVersion ) where import RIO import RIO.Process import Pantry.Types import qualified Data.ByteString.Lazy.Char8 as BL import qualified Hpack import qualified Hpack.Config as Hpack import Data.Char (isSpace, isDigit) import Path (Path, Abs, toFilePath, Dir, (), filename, parseRelFile) import Path.IO (doesFileExist) hpackVersion :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RIO env Version hpackVersion = do he <- view $ pantryConfigL.to pcHpackExecutable case he of HpackBundled -> do let bundledHpackVersion :: String = VERSION_hpack parseVersionThrowing bundledHpackVersion HpackCommand command -> do version <- BL.unpack <$> proc command ["--version"] readProcessStdout_ let version' = dropWhile (not . isDigit) version version'' = filter (not . isSpace) version' parseVersionThrowing version'' -- | Generate .cabal file from package.yaml, if necessary. hpack :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -> RIO env () hpack pkgDir = do packageConfigRelFile <- parseRelFile Hpack.packageConfig let hpackFile = pkgDir Path. packageConfigRelFile whenM (doesFileExist hpackFile) $ do logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) he <- view $ pantryConfigL.to pcHpackExecutable case he of HpackBundled -> do r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions forM_ (Hpack.resultWarnings r) (logWarn . fromString) let cabalFile = fromString . Hpack.resultCabalFile $ r case Hpack.resultStatus r of Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ cabalFile <> " was generated with a newer version of hpack,\n" <> "please upgrade and try again." Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ cabalFile <> " was modified manually. Ignoring " <> fromString (toFilePath hpackFile) <> " in favor of the cabal file.\nIf you want to use the " <> fromString (toFilePath (filename hpackFile)) <> " file instead of the cabal file,\n" <> "then please delete the cabal file." HpackCommand command -> withWorkingDir (toFilePath pkgDir) $ proc command [] runProcess_ pantry-0.4.0.2/src/Pantry/Hackage.hs0000644000000000000000000006172513712324605015317 0ustar0000000000000000{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Pantry.Hackage ( updateHackageIndex , forceUpdateHackageIndex , DidUpdateOccur (..) , RequireHackageIndex (..) , hackageIndexTarballL , getHackageTarball , getHackageTarballKey , getHackageCabalFile , getHackagePackageVersions , getHackagePackageVersionRevisions , getHackageTypoCorrections , UsePreferredVersions (..) , HackageTarballResult(..) ) where import RIO import RIO.Process import Pantry.Casa import Data.Aeson import Conduit import Data.Conduit.Tar import qualified RIO.Text as T import qualified RIO.Map as Map import Data.Text.Unsafe (unsafeTail) import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import Pantry.Archive import Pantry.Types hiding (FileType (..)) import Pantry.Storage hiding (TreeEntry, PackageName, Version) import Pantry.Tree import qualified Pantry.SHA256 as SHA256 import Network.URI (parseURI) import Data.Time (getCurrentTime) import Path ((), Path, Abs, Rel, Dir, File, toFilePath, parseRelDir, parseRelFile) import qualified Distribution.Text import qualified Distribution.PackageDescription as Cabal import System.IO (SeekMode (..)) import qualified Data.List.NonEmpty as NE import Data.Text.Metrics (damerauLevenshtein) import Distribution.PackageDescription (GenericPackageDescription) import Distribution.Types.Version (versionNumbers) import Distribution.Types.VersionRange (withinRange) import qualified Hackage.Security.Client as HS import qualified Hackage.Security.Client.Repository.Cache as HS import qualified Hackage.Security.Client.Repository.Remote as HS import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS import qualified Hackage.Security.Util.Path as HS import qualified Hackage.Security.Util.Pretty as HS hackageRelDir :: Path Rel Dir hackageRelDir = either impureThrow id $ parseRelDir "hackage" hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) hackageDirL = pantryConfigL.to (( hackageRelDir) . pcRootDir) indexRelFile :: Path Rel File indexRelFile = either impureThrow id $ parseRelFile "00-index.tar" -- | Where does pantry download its 01-index.tar file from Hackage? -- -- @since 0.1.0.0 hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) hackageIndexTarballL = hackageDirL.to ( indexRelFile) -- | Did an update occur when running 'updateHackageIndex'? -- -- @since 0.1.0.0 data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred -- | Information returned by `getHackageTarball` -- -- @since 0.1.0.0 data HackageTarballResult = HackageTarballResult { htrPackage :: !Package -- ^ Package that was loaded from Hackage tarball , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) -- ^ This information is only available whenever package was just loaded into pantry. } -- | Download the most recent 01-index.tar file from Hackage and -- update the database tables. -- -- This function will only perform an update once per 'PantryConfig' -- for user sanity. See the return value to find out if it happened. -- -- @since 0.1.0.0 updateHackageIndex :: (HasPantryConfig env, HasLogFunc env) => Maybe Utf8Builder -- ^ reason for updating, if any -> RIO env DidUpdateOccur updateHackageIndex = updateHackageIndexInternal False -- | Same as `updateHackageIndex`, but force the database update even if hackage -- security tells that there is no change. This can be useful in order to make -- sure the database is in sync with the locally downloaded tarball -- -- @since 0.1.0.0 forceUpdateHackageIndex :: (HasPantryConfig env, HasLogFunc env) => Maybe Utf8Builder -> RIO env DidUpdateOccur forceUpdateHackageIndex = updateHackageIndexInternal True updateHackageIndexInternal :: (HasPantryConfig env, HasLogFunc env) => Bool -- ^ Force the database update. -> Maybe Utf8Builder -- ^ reason for updating, if any -> RIO env DidUpdateOccur updateHackageIndexInternal forceUpdate mreason = do storage <- view $ pantryConfigL.to pcStorage gateUpdate $ withWriteLock_ storage $ do for_ mreason logInfo pc <- view pantryConfigL let HackageSecurityConfig keyIds threshold url ignoreExpiry = pcHackageSecurity pc root <- view hackageDirL tarball <- view hackageIndexTarballL baseURI <- case parseURI $ T.unpack url of Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url Just x -> return x run <- askRunInIO let logTUF = run . logInfo . fromString . HS.pretty withRepo = HS.withRepository HS.httpLib [baseURI] HS.defaultRepoOpts HS.Cache { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root , HS.cacheLayout = HS.cabalCacheLayout } HS.hackageRepoLayout HS.hackageIndexLayout logTUF didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do needBootstrap <- HS.requiresBootstrap repo when needBootstrap $ do HS.bootstrap repo (map (HS.KeyId . T.unpack) keyIds) (HS.KeyThreshold $ fromIntegral threshold) maybeNow <- if ignoreExpiry then pure Nothing else Just <$> getCurrentTime HS.checkForUpdates repo maybeNow case didUpdate of _ | forceUpdate -> do logInfo "Forced package update is initialized" updateCache tarball HS.NoUpdates -> do x <- needsCacheUpdate tarball if x then do logInfo "No package index update available, but didn't update cache last time, running now" updateCache tarball else logInfo "No package index update available and cache up to date" HS.HasUpdates -> do logInfo "Updated package index downloaded" updateCache tarball logStickyDone "Package index cache populated" where -- The size of the new index tarball, ignoring the required -- (by the tar spec) 1024 null bytes at the end, which will be -- mutated in the future by other updates. getTarballSize :: MonadIO m => Handle -> m Word getTarballSize h = (fromIntegral . max 0 . subtract 1024) <$> hFileSize h -- Check if the size of the tarball on the disk matches the value -- in CacheUpdate. If not, we need to perform a cache update, even -- if we didn't download any new information. This can be caused -- by canceling an updateCache call. needsCacheUpdate tarball = do mres <- withStorage loadLatestCacheUpdate case mres of Nothing -> pure True Just (FileSize cachedSize, _sha256) -> do actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize pure $ cachedSize /= actualSize -- This is the one action in the Pantry codebase known to hold a -- write lock on the database for an extended period of time. To -- avoid failures due to SQLite locks failing, we take our own -- lock outside of SQLite for this action. -- -- See https://github.com/commercialhaskell/stack/issues/4471 updateCache tarball = withStorage $ do -- Alright, here's the story. In theory, we only ever append to -- a tarball. Therefore, we can store the last place we -- populated our cache from, and fast forward to that point. But -- there are two issues with that: -- -- 1. Hackage may rebase, in which case we need to recalculate -- everything from the beginning. Unfortunately, -- hackage-security doesn't let us know when that happens. -- -- 2. Some paranoia about files on the filesystem getting -- modified out from under us. -- -- Therefore, we store both the last read-to index, _and_ the -- SHA256 of all of the contents until that point. When updating -- the cache, we calculate the new SHA256 of the whole file, and -- the SHA256 of the previous read-to point. If the old hashes -- match, we can do an efficient fast forward. Otherwise, we -- clear the old cache and repopulate. minfo <- loadLatestCacheUpdate (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" newSize <- getTarballSize h let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash case minfo of Nothing -> do logInfo "No old cache found, populating cache from scratch" newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize pure (0, newHash, newSize) Just (FileSize oldSize, oldHash) -> do -- oldSize and oldHash come from the database, and tell -- us what we cached already. Compare against -- oldHashCheck, which assuming the tarball has not been -- rebased will be the same as oldHash. At the same -- time, calculate newHash, which is the hash of the new -- content as well. (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) <$> ZipSink (sinkSHA256 oldSize) <*> ZipSink (sinkSHA256 newSize) ) offset <- if oldHash == oldHashCheck then oldSize <$ logInfo "Updating preexisting cache, should be quick" else 0 <$ do logWarn $ mconcat [ "Package index change detected, that's pretty unusual: " , "\n Old size: " <> display oldSize , "\n Old hash (orig) : " <> display oldHash , "\n New hash (check): " <> display oldHashCheck , "\n Forcing a recache" ] pure (offset, newHash, newSize) lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash when (offset == 0) clearHackageRevisions populateCache tarball (fromIntegral offset) `onException` lift (logStickyDone "Failed populating package index cache") storeCacheUpdate (FileSize newSize) newHash gateUpdate inner = do pc <- view pantryConfigL join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ if toUpdate then (False, UpdateOccurred <$ inner) else (False, pure NoUpdateOccurred) -- | Populate the SQLite tables with Hackage index information. populateCache :: (HasPantryConfig env, HasLogFunc env) => Path Abs File -- ^ tarball -> Integer -- ^ where to start processing from -> ReaderT SqlBackend (RIO env) () populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do lift $ logInfo "Populating package index cache ..." counter <- newIORef (0 :: Int) hSeek h AbsoluteSeek offset runConduit $ sourceHandle h .| untar (perFile counter) where perFile counter fi | FTNormal <- fileType fi , Right path <- decodeUtf8' $ filePath fi , Just (name, version, filename) <- parseNameVersionSuffix path = if | filename == "package.json" -> sinkLazy >>= lift . addJSON name version | filename == unSafeFilePath (cabalFileName name) -> do (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version count <- readIORef counter let count' = count + 1 writeIORef counter count' when (count' `mod` 400 == 0) $ lift $ lift $ logSticky $ "Processed " <> display count' <> " cabal files" | otherwise -> pure () | FTNormal <- fileType fi , Right path <- decodeUtf8' $ filePath fi , (nameT, "/preferred-versions") <- T.break (== '/') path , Just name <- parsePackageName $ T.unpack nameT = do lbs <- sinkLazy case decodeUtf8' $ BL.toStrict lbs of Left _ -> pure () -- maybe warning Right p -> lift $ storePreferredVersion name p | otherwise = pure () addJSON name version lbs = case eitherDecode' lbs of Left e -> lift $ logError $ "Error processing Hackage security metadata for " <> fromString (Distribution.Text.display name) <> "-" <> fromString (Distribution.Text.display version) <> ": " <> fromString e Right (PackageDownload sha size) -> storeHackageTarballInfo name version sha $ FileSize size addCabal name version bs = do (blobTableId, _blobKey) <- storeBlob bs storeHackageRevision name version blobTableId breakSlash x | T.null z = Nothing | otherwise = Just (y, unsafeTail z) where (y, z) = T.break (== '/') x parseNameVersionSuffix t1 = do (name, t2) <- breakSlash t1 (version, filename) <- breakSlash t2 name' <- Distribution.Text.simpleParse $ T.unpack name version' <- Distribution.Text.simpleParse $ T.unpack version Just (name', version', filename) -- | Package download info from Hackage data PackageDownload = PackageDownload !SHA256 !Word instance FromJSON PackageDownload where parseJSON = withObject "PackageDownload" $ \o1 -> do o2 <- o1 .: "signed" Object o3 <- o2 .: "targets" Object o4:_ <- return $ toList o3 len <- o4 .: "length" hashes <- o4 .: "hashes" sha256' <- hashes .: "sha256" sha256 <- case SHA256.fromHexText sha256' of Left e -> fail $ "Invalid sha256: " ++ show e Right x -> return x return $ PackageDownload sha256 len getHackageCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> RIO env ByteString getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do bid <- resolveCabalFileInfo pir bs <- withStorage $ loadBlobById bid case cfi of CFIHash sha msize -> do let sizeMismatch = case msize of Nothing -> False Just size -> FileSize (fromIntegral (B.length bs)) /= size shaMismatch = sha /= SHA256.hashBytes bs when (sizeMismatch || shaMismatch) $ error $ "getHackageCabalFile: size or SHA mismatch for " ++ show (pir, bs) _ -> pure () pure bs resolveCabalFileInfo :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> RIO env BlobId resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do mres <- inner case mres of Just res -> pure res Nothing -> do updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" mres' <- case updated of UpdateOccurred -> inner NoUpdateOccurred -> pure Nothing case mres' of Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir Just res -> pure res where inner = case cfi of CFIHash sha msize -> loadOrDownloadBlobBySHA pir sha msize CFIRevision rev -> (fmap fst . Map.lookup rev) <$> withStorage (loadHackagePackageVersion name ver) CFILatest -> (fmap (fst . fst) . Map.maxView) <$> withStorage (loadHackagePackageVersion name ver) -- | Load or download a blob by its SHA. loadOrDownloadBlobBySHA :: (Display a, HasPantryConfig env, HasLogFunc env) => a -> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId) loadOrDownloadBlobBySHA label sha256 msize = do mresult <- byDB case mresult of Nothing -> do case msize of Nothing -> do pure Nothing Just size -> do mblob <- casaLookupKey (BlobKey sha256 size) case mblob of Nothing -> do pure Nothing Just {} -> do result <- byDB case result of Just blobId -> do logDebug ("Pulled blob from Casa for " <> display label) pure (Just blobId) Nothing -> do logWarn ("Bug? Blob pulled from Casa not in database for " <> display label) pure Nothing Just blobId -> do logDebug ("Got blob from Pantry database for " <> display label) pure (Just blobId) where byDB = withStorage $ loadBlobBySHA sha256 -- | Given package identifier and package caches, return list of packages -- with the same name and the same two first version number components found -- in the caches. fuzzyLookupCandidates :: (HasPantryConfig env, HasLogFunc env) => PackageName -> Version -> RIO env FuzzyResults fuzzyLookupCandidates name ver0 = do m <- getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions name if Map.null m then FRNameNotFound <$> getHackageTypoCorrections name else case Map.lookup ver0 m of Nothing -> do let withVers vers = pure $ FRVersionNotFound $ flip NE.map vers $ \(ver, revs) -> case Map.maxView revs of Nothing -> error "fuzzyLookupCandidates: no revisions" Just (BlobKey sha size, _) -> PackageIdentifierRevision name ver (CFIHash sha (Just size)) case NE.nonEmpty $ filter (sameMajor . fst) $ Map.toList m of Just vers -> withVers vers Nothing -> case NE.nonEmpty $ Map.toList m of Nothing -> error "fuzzyLookupCandidates: no versions" Just vers -> withVers vers Just revisions -> let pirs = map (\(BlobKey sha size) -> PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) (Map.elems revisions) in case NE.nonEmpty pirs of Nothing -> error "fuzzyLookupCandidates: no revisions" Just pirs' -> pure $ FRRevisionNotFound pirs' where sameMajor v = toMajorVersion v == toMajorVersion ver0 toMajorVersion :: Version -> [Int] toMajorVersion v = case versionNumbers v of [] -> [0, 0] [a] -> [a, 0] a:b:_ -> [a, b] -- | Try to come up with typo corrections for given package identifier -- using Hackage package names. This can provide more user-friendly -- information in error messages. -- -- @since 0.1.0.0 getHackageTypoCorrections :: (HasPantryConfig env, HasLogFunc env) => PackageName -> RIO env [PackageName] getHackageTypoCorrections name1 = withStorage $ sinkHackagePackageNames (\name2 -> name1 `distance` name2 < 4) (takeC 10 .| sinkList) where distance = damerauLevenshtein `on` (T.pack . packageNameString) -- | Should we pay attention to Hackage's preferred versions? -- -- @since 0.1.0.0 data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions deriving Show -- | Require that the Hackage index is populated. -- -- @since 0.1.0.0 data RequireHackageIndex = YesRequireHackageIndex -- ^ If there is nothing in the Hackage index, then perform an update | NoRequireHackageIndex -- ^ Do not perform an update deriving Show initializeIndex :: (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> RIO env () initializeIndex NoRequireHackageIndex = pure () initializeIndex YesRequireHackageIndex = do cabalCount <- withStorage countHackageCabals when (cabalCount == 0) $ void $ updateHackageIndex $ Just $ "No information from Hackage index, updating" -- | Returns the versions of the package available on Hackage. -- -- @since 0.1.0.0 getHackagePackageVersions :: (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> UsePreferredVersions -> PackageName -- ^ package name -> RIO env (Map Version (Map Revision BlobKey)) getHackagePackageVersions req usePreferred name = do initializeIndex req withStorage $ do mpreferred <- case usePreferred of UsePreferredVersions -> loadPreferredVersion name IgnorePreferredVersions -> pure Nothing let predicate :: Version -> Map Revision BlobKey -> Bool predicate = fromMaybe (\_ _ -> True) $ do preferredT1 <- mpreferred preferredT2 <- T.stripPrefix (T.pack $ packageNameString name) preferredT1 vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 Just $ \v _ -> withinRange v vr Map.filterWithKey predicate <$> loadHackagePackageVersions name -- | Returns the versions of the package available on Hackage. -- -- @since 0.1.0.0 getHackagePackageVersionRevisions :: (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> PackageName -- ^ package name -> Version -- ^ package version -> RIO env (Map Revision BlobKey) getHackagePackageVersionRevisions req name version = do initializeIndex req withStorage $ Map.map snd <$> loadHackagePackageVersion name version withCachedTree :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> PackageName -> Version -> BlobId -- ^ cabal file contents -> RIO env HackageTarballResult -> RIO env HackageTarballResult withCachedTree rpli name ver bid inner = do mres <- withStorage $ loadHackageTree rpli name ver bid case mres of Just package -> pure $ HackageTarballResult package Nothing Nothing -> do htr <- inner withStorage $ storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr pure htr getHackageTarballKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageIdentifierRevision -> RIO env TreeKey getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do mres <- withStorage $ loadHackageTreeKey name ver sha case mres of Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing Just key -> pure key getHackageTarballKey pir = packageTreeKey . htrPackage <$> getHackageTarball pir Nothing getHackageTarball :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageIdentifierRevision -> Maybe TreeKey -> RIO env HackageTarballResult getHackageTarball pir mtreeKey = do let PackageIdentifierRevision name ver _cfi = pir cabalFile <- resolveCabalFileInfo pir let rpli = RPLIHackage pir mtreeKey withCachedTree rpli name ver cabalFile $ do cabalFileKey <- withStorage $ getBlobKey cabalFile mpair <- withStorage $ loadHackageTarballInfo name ver (sha, size) <- case mpair of Just pair -> pure pair Nothing -> do let exc = NoHackageCryptographicHash $ PackageIdentifier name ver updated <- updateHackageIndex $ Just $ display exc <> ", updating" mpair2 <- case updated of UpdateOccurred -> withStorage $ loadHackageTarballInfo name ver NoUpdateOccurred -> pure Nothing case mpair2 of Nothing -> throwIO exc Just pair2 -> pure pair2 pc <- view pantryConfigL let urlPrefix = hscDownloadPrefix $ pcHackageSecurity pc url = mconcat [ urlPrefix , "package/" , T.pack $ Distribution.Text.display name , "-" , T.pack $ Distribution.Text.display ver , ".tar.gz" ] package <- getArchivePackage rpli RawArchive { raLocation = ALUrl url , raHash = Just sha , raSize = Just size , raSubdir = T.empty -- no subdirs on Hackage } RawPackageMetadata { rpmName = Just name , rpmVersion = Just ver , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree } case packageTree package of TreeMap m -> do let ft = case packageCabalEntry package of PCCabalFile (TreeEntry _ ft') -> ft' _ -> error "Impossible: Hackage does not support hpack" cabalEntry = TreeEntry cabalFileKey ft tree' = TreeMap $ Map.insert (cabalFileName name) cabalEntry m ident = PackageIdentifier name ver cabalBS <- withStorage $ do let BlobKey sha' _ = cabalFileKey mcabalBS <- loadBlobBySHA sha' case mcabalBS of Nothing -> error $ "Invariant violated, cabal file key: " ++ show cabalFileKey Just bid -> loadBlobById bid (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS let gpdIdent = Cabal.package $ Cabal.packageDescription gpd when (ident /= gpdIdent) $ throwIO $ MismatchedCabalFileForHackage pir Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent} (tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) pure HackageTarballResult { htrPackage = Package { packageTreeKey = treeKey' , packageTree = tree' , packageIdent = ident , packageCabalEntry = PCCabalFile cabalEntry } , htrFreshPackageInfo = Just (gpd, tid) } pantry-0.4.0.2/src/Pantry/Repo.hs0000644000000000000000000002002613712324605014666 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Pantry.Repo ( fetchReposRaw , fetchRepos , getRepo , getRepoKey , createRepoArchive , withRepoArchive , withRepo ) where import Pantry.Types import Pantry.Archive import Pantry.Storage import RIO import Path.IO (resolveFile') import RIO.FilePath (()) import RIO.Directory (doesDirectoryExist) import RIO.ByteString (isInfixOf) import RIO.ByteString.Lazy (toStrict) import qualified RIO.Map as Map import RIO.Process import Database.Persist (Entity (..)) import qualified RIO.Text as T import System.Console.ANSI (hSupportsANSIWithoutEmulation) import System.IsWindows (osIsWindows) data TarType = Gnu | Bsd getTarType :: (HasProcessContext env, HasLogFunc env) => RIO env TarType getTarType = do (stdoutBS, _) <- proc "tar" ["--version"] readProcess_ let bs = toStrict stdoutBS if "GNU" `isInfixOf` bs then pure Gnu else if "bsdtar" `isInfixOf` bs then pure Bsd else do logError $ "Either GNU Tar or BSD tar is required on the PATH." throwString "Proper tar executable not found in the environment" fetchReposRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Repo, RawPackageMetadata)] -> RIO env () fetchReposRaw pairs = for_ pairs $ uncurry getRepo fetchRepos :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Repo, PackageMetadata)] -> RIO env () fetchRepos pairs = do -- TODO be more efficient, group together shared archives fetchReposRaw $ map (second toRawPM) pairs getRepoKey :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageMetadata -> RIO env TreeKey getRepoKey repo rpm = packageTreeKey <$> getRepo repo rpm -- potential optimization getRepo :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageMetadata -> RIO env Package getRepo repo pm = withCache $ getRepo' repo pm where withCache :: RIO env Package -> RIO env Package withCache inner = do mtid <- withStorage (loadRepoCache repo (repoSubdir repo)) case mtid of Just tid -> withStorage $ loadPackageById (RPLIRepo repo pm) tid Nothing -> do package <- inner withStorage $ do ment <- getTreeForKey $ packageTreeKey package case ment of Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid pure package getRepo' :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageMetadata -> RIO env Package getRepo' repo rpm = do withRepoArchive repo $ \tarball -> do abs' <- resolveFile' tarball getArchivePackage (RPLIRepo repo rpm) RawArchive { raLocation = ALFilePath $ ResolvedPath { resolvedRelative = RelFilePath $ T.pack tarball , resolvedAbsolute = abs' } , raHash = Nothing , raSize = Nothing , raSubdir = repoSubdir repo } rpm -- | Fetch a repository and create a (temporary) tar archive from it. Pass the -- path of the generated tarball to the given action. withRepoArchive :: forall env a. (HasLogFunc env, HasProcessContext env) => Repo -> (FilePath -> RIO env a) -> RIO env a withRepoArchive repo action = withSystemTempDirectory "with-repo-archive" $ \tmpdir -> do let tarball = tmpdir "foo.tar" createRepoArchive repo tarball action tarball -- | Run a git command, setting appropriate environment variable settings. See -- . runGitCommand :: (HasLogFunc env, HasProcessContext env) => [String] -- ^ args -> RIO env () runGitCommand args = withModifyEnvVars go $ void $ proc "git" args readProcess_ where go = Map.delete "GIT_DIR" . Map.delete "GIT_CEILING_DIRECTORIES" . Map.delete "GIT_WORK_TREE" . Map.delete "GIT_INDEX_FILE" . Map.delete "GIT_OBJECT_DIRECTORY" -- possible optimization: set this to something Pantry controls . Map.delete "GIT_ALTERNATE_OBJECT_DIRECTORIES" -- Include submodules files into the archive: use `git submodule -- foreach` to execute `git archive` in each submodule and generate -- tar archive. With bsd tar, the generated archive is extracted to a -- temporary folder and the files in them are added to the tarball -- referenced by the variable tarball in the haskell code. This is -- done in GNU tar with -A option. archiveSubmodules :: (HasLogFunc env, HasProcessContext env) => FilePath -> RIO env () archiveSubmodules tarball = do tarType <- getTarType let forceLocal = if osIsWindows then " --force-local " else mempty case tarType of Gnu -> runGitCommand [ "submodule", "foreach", "--recursive" , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " <> "tar" <> forceLocal <> " -Af " <> tarball <> " bar.tar" ] Bsd -> runGitCommand [ "submodule" , "foreach" , "--recursive" , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD;" <> " rm -rf temp; mkdir temp; mv bar.tar temp/; tar " <> " -C temp -xf temp/bar.tar; " <> "rm temp/bar.tar; tar " <> " -C temp -rf " <> tarball <> " . ;" ] -- | Run an hg command runHgCommand :: (HasLogFunc env, HasProcessContext env) => [String] -- ^ args -> RIO env () runHgCommand args = void $ proc "hg" args readProcess_ -- | Create a tarball containing files from a repository createRepoArchive :: forall env. (HasLogFunc env, HasProcessContext env) => Repo -> FilePath -- ^ Output tar archive filename -> RIO env () createRepoArchive repo tarball = do withRepo repo $ case repoType repo of RepoGit -> do runGitCommand ["-c", "core.autocrlf=false", "archive", "-o", tarball, "HEAD"] archiveSubmodules tarball RepoHg -> runHgCommand ["archive", tarball, "-X", ".hg_archival.txt"] -- | Clone the repository and execute the action with the working -- directory set to the repository root. -- -- @since 0.1.0.0 withRepo :: forall env a. (HasLogFunc env, HasProcessContext env) => Repo -> RIO env a -> RIO env a withRepo repo@(Repo url commit repoType' _subdir) action = withSystemTempDirectory "with-repo" $ \tmpDir -> do -- Note we do not immediately change directories into the new temporary directory, -- but instead wait until we have finished cloning the repo. This is because the -- repo URL may be a relative path on the local filesystem, and we should interpret -- it as relative to the current directory, not the temporary directory. let dir = tmpDir "cloned" (runCommand, resetArgs, submoduleArgs) = case repoType' of RepoGit -> ( runGitCommand , ["reset", "--hard", T.unpack commit] , Just ["submodule", "update", "--init", "--recursive"] ) RepoHg -> ( runHgCommand , ["update", "-C", T.unpack commit] , Nothing ) fixANSIForWindows = -- On Windows 10, an upstream issue with the `git clone` command means that -- command clears, but does not then restore, the -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The -- folowing hack re-enables the lost ANSI-capability. when osIsWindows $ void $ liftIO $ hSupportsANSIWithoutEmulation stdout logInfo $ "Cloning " <> display commit <> " from " <> display url runCommand ["clone", T.unpack url, dir] fixANSIForWindows created <- doesDirectoryExist dir unless created $ throwIO $ FailedToCloneRepo repo withWorkingDir dir $ do runCommand resetArgs traverse_ runCommand submoduleArgs fixANSIForWindows action pantry-0.4.0.2/src/Pantry/SQLite.hs0000644000000000000000000001015413712324605015123 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} module Pantry.SQLite ( Storage (..) , initStorage ) where import RIO hiding (FilePath) import Database.Persist.Sqlite import RIO.Orphans () import Path (Path, Abs, File, toFilePath, parent) import Path.IO (ensureDir) import Pantry.Types (PantryException (MigrationFailure), Storage (..)) import System.FileLock (withFileLock, withTryFileLock, SharedExclusive (..)) import Pantry.Internal.Companion initStorage :: HasLogFunc env => Text -> Migration -> Path Abs File -- ^ storage file -> (Storage -> RIO env a) -> RIO env a initStorage description migration fp inner = do ensureDir $ parent fp migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $ withSqliteConnInfo (sqinfo True) $ runSqlConn $ runMigrationSilent migration forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig -- Make a single connection to the SQLite database and wrap it in an MVar for -- the entire execution context. Previously we used a resource pool of size -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird -- interaction with Docker on OS X where when resource-pool's reaper would -- trigger, it would somehow cause the Stack process inside the container to -- die with a SIGBUS. Definitely an interesting thing worth following up -- on... withSqliteConnInfo (sqinfo False) $ \conn0 -> do connVar <- newMVar conn0 inner $ Storage -- NOTE: Currently, we take a write lock on every action. This is -- a bit heavyweight, but it avoids the SQLITE_BUSY errors -- reported in -- -- completely. We can investigate more elegant solutions in the -- future, such as separate read and write actions or introducing -- smarter retry logic. { withStorage_ = \action -> withMVar connVar $ \conn -> withWriteLock (display description) fp $ runSqlConn action conn , withWriteLock_ = id } where wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) sqinfo isMigration = set extraPragmas ["PRAGMA busy_timeout=2000;"] $ set walEnabled False -- When doing a migration, we want to disable foreign key -- checking, since the order in which tables are created by -- the migration scripts may not respect foreign keys. The -- rest of the time: enforce those foreign keys. $ set fkEnabled (not isMigration) $ mkSqliteConnectionInfo (fromString $ toFilePath fp) -- | Ensure that only one process is trying to write to the database -- at a time. See -- https://github.com/commercialhaskell/stack/issues/4471 and comments -- above. withWriteLock :: HasLogFunc env => Utf8Builder -- ^ database description, for lock messages -> Path Abs File -- ^ SQLite database file -> RIO env a -> RIO env a withWriteLock desc dbFile inner = do let lockFile = toFilePath dbFile ++ ".pantry-write-lock" withRunInIO $ \run -> do mres <- withTryFileLock lockFile Exclusive $ const $ run inner case mres of Just res -> pure res Nothing -> do let complainer :: Companion IO complainer delay = run $ do -- Wait five seconds before giving the first message to -- avoid spamming the user for uninteresting file locks delay $ 5 * 1000 * 1000 -- 5 seconds logInfo $ "Unable to get a write lock on the " <> desc <> " database, waiting..." -- Now loop printing a message every 1 minute forever $ do delay (60 * 1000 * 1000) -- 1 minute `onCompanionDone` logInfo ("Acquired the " <> desc <> " database write lock") logWarn ("Still waiting on the " <> desc <> " database write lock...") withCompanion complainer $ \stopComplaining -> withFileLock lockFile Exclusive $ const $ do stopComplaining run inner pantry-0.4.0.2/src/Pantry/Storage.hs0000644000000000000000000011362113712324605015371 0ustar0000000000000000{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-} module Pantry.Storage ( SqlBackend , initStorage , withStorage , migrateAll , storeBlob , loadBlob , loadBlobById , loadBlobBySHA , allBlobsSource , allHackageCabalRawPackageLocations , allBlobsCount , allHackageCabalCount , getBlobKey , loadURLBlob , storeURLBlob , clearHackageRevisions , storeHackageRevision , loadHackagePackageVersions , loadHackagePackageVersion , loadLatestCacheUpdate , storeCacheUpdate , storeHackageTarballInfo , loadHackageTarballInfo , getHPackBlobKeyById , storeTree , loadTree , storeHPack , loadPackageById , getPackageNameById , getPackageNameId , getVersionId , getTreeForKey , storeHackageTree , loadHackageTree , loadHackageTreeKey , storeArchiveCache , loadArchiveCache , storeRepoCache , loadRepoCache , storePreferredVersion , loadPreferredVersion , sinkHackagePackageNames , loadCabalBlobKey , hpackToCabal , countHackageCabals , getSnapshotCacheByHash , getSnapshotCacheId , storeSnapshotModuleCache , loadExposedModulePackages , PackageNameId , PackageName , VersionId , ModuleNameId , Version , Unique(..) , EntityField(..) -- avoid warnings , BlobId , Key(unBlobKey) , HackageCabalId , HackageCabal(..) , HackageTarballId , CacheUpdateId , FilePathId , Tree(..) , TreeId , TreeEntry(..) , TreeEntryId , ArchiveCacheId , RepoCacheId , PreferredVersionsId , UrlBlobId , SnapshotCacheId , PackageExposedModuleId ) where import RIO hiding (FilePath) import RIO.Process import qualified RIO.ByteString as B import qualified Pantry.Types as P import qualified RIO.List as List import qualified RIO.FilePath as FilePath import RIO.FilePath ((), takeDirectory) import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) import Database.Persist import Database.Persist.Sqlite import Database.Persist.TH import RIO.Orphans (HasResourceMap) import qualified Pantry.SHA256 as SHA256 import qualified RIO.Map as Map import qualified RIO.Text as T import RIO.Time (UTCTime, getCurrentTime) import Path (Path, Abs, File, Dir, toFilePath, filename, parseAbsDir, fromAbsFile, fromRelFile) import Path.IO (listDir, createTempDir, getTempDir, removeDirRecur) import Pantry.HPack (hpackVersion, hpack) import Conduit import Data.Acquire (with) import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..), SnapshotCacheHash (..)) import qualified Pantry.SQLite as SQLite share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- Raw blobs Blob sha SHA256 size FileSize contents ByteString UniqueBlobSha sha -- Previously downloaded blobs from given URLs. -- May change over time, so we keep a time column too. UrlBlob sql=url_blob url Text blob BlobId time UTCTime UniqueUrlTime url time -- For normalization, and avoiding storing strings in a bunch of -- tables. PackageName name P.PackageNameP UniquePackageName name Version version P.VersionP UniqueVersion version FilePath path P.SafeFilePath UniqueSfp path -- Secure download information for a package on Hackage. This does not -- contain revision information, since sdist tarballs are (blessedly) -- unmodified on Hackage. HackageTarball name PackageNameId version VersionId sha SHA256 size FileSize UniqueHackageTarball name version -- An individual cabal file from Hackage, representing a specific -- revision. HackageCabal name PackageNameId version VersionId revision P.Revision cabal BlobId -- If available: the full tree containing the HackageTarball -- contents with the cabal file modified. tree TreeId Maybe UniqueHackage name version revision -- Any preferred-version information from Hackage PreferredVersions name PackageNameId preferred Text UniquePreferred name -- Last time we downloaded a 01-index.tar file from Hackage and -- updated the three previous tables. CacheUpdate -- When did we do the update? time UTCTime -- How big was the file when we updated, ignoring the last two -- all-null 512-byte blocks. size FileSize -- SHA256 of the first 'size' bytes of the file sha SHA256 -- A tree containing a Haskell package. See associated TreeEntry -- table. Tree key BlobId -- If the treeCabal field is Nothing, it means the Haskell package -- doesn't have a corresponding cabal file for it. This may be the case -- for haskell package referenced by git repository with only a hpack file. cabal BlobId Maybe cabalType FileType name PackageNameId version VersionId UniqueTree key HPack tree TreeId -- hpack version used for generating this cabal file version VersionId -- Generated cabal file for the given tree and hpack version cabalBlob BlobId cabalPath FilePathId UniqueHPack tree version -- An individual file within a Tree. TreeEntry tree TreeId path FilePathId blob BlobId type FileType -- Like UrlBlob, but stores the contents as a Tree. ArchiveCache time UTCTime url Text subdir Text sha SHA256 size FileSize tree TreeId -- Like ArchiveCache, but for a Repo. RepoCache time UTCTime url Text type P.RepoType commit Text subdir Text tree TreeId -- Identified by sha of all immutable packages contained in a snapshot -- and GHC version used SnapshotCache sha SHA256 UniqueSnapshotCache sha PackageExposedModule snapshotCache SnapshotCacheId module ModuleNameId package PackageNameId ModuleName name P.ModuleNameP UniqueModule name |] initStorage :: HasLogFunc env => Path Abs File -- ^ storage file -> (P.Storage -> RIO env a) -> RIO env a initStorage = SQLite.initStorage "Pantry" migrateAll withStorage :: (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) a -> RIO env a withStorage action = flip SQLite.withStorage_ action =<< view (P.pantryConfigL.to P.pcStorage) -- | This is a helper type to distinguish db queries between different rdbms backends. The important -- part is that the affects described in this data type should be semantically equivalent between -- the supported engines. data RdbmsActions env a = RdbmsActions { raSqlite :: !(ReaderT SqlBackend (RIO env) a) -- ^ A query that is specific to SQLite , raPostgres :: !(ReaderT SqlBackend (RIO env) a) -- ^ A query that is specific to PostgreSQL } -- | This function provides a way to create queries supported by multiple sql backends. rdbmsAwareQuery :: RdbmsActions env a -> ReaderT SqlBackend (RIO env) a rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do rdbms <- connRDBMS <$> ask case rdbms of "postgresql" -> raPostgres "sqlite" -> raSqlite _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" getPackageNameById :: PackageNameId -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName) getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get getPackageNameId :: P.PackageName -> ReaderT SqlBackend (RIO env) PackageNameId getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP getVersionId :: P.Version -> ReaderT SqlBackend (RIO env) VersionId getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP storeBlob :: ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) storeBlob bs = do let sha = SHA256.hashBytes bs size = FileSize $ fromIntegral $ B.length bs keys <- selectKeysList [BlobSha ==. sha] [] key <- case keys of [] -> rdbmsAwareQuery RdbmsActions { raSqlite = insert Blob {blobSha = sha, blobSize = size, blobContents = bs} , raPostgres = do rawExecute "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" [ toPersistValue sha , toPersistValue size , toPersistValue bs ] rawSql "SELECT blob.id FROM blob WHERE blob.sha = ?" [toPersistValue sha] >>= \case [Single key] -> pure key _ -> error "soreBlob: there was a critical problem storing a blob." } key:rest -> assert (null rest) (pure key) pure (key, P.BlobKey sha size) loadBlob :: HasLogFunc env => BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString) loadBlob (P.BlobKey sha size) = do ment <- getBy $ UniqueBlobSha sha case ment of Nothing -> pure Nothing Just (Entity _ bt) | blobSize bt == size -> pure $ Just $ blobContents bt | otherwise -> Nothing <$ lift (logWarn $ "Mismatched blob size detected for SHA " <> display sha <> ". Expected size: " <> display size <> ". Actual size: " <> display (blobSize bt)) loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId) loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString loadBlobById bid = do mbt <- get bid case mbt of Nothing -> error "loadBlobById: ID doesn't exist in database" Just bt -> pure $ blobContents bt allBlobsSource :: HasResourceMap env => Maybe BlobId -- ^ For some x, yield blob whose id>x. -> ConduitT () (BlobId, ByteString) (ReaderT SqlBackend (RIO env)) () allBlobsSource mblobId = selectSource [BlobId >. blobId | Just blobId <- [mblobId]] [Asc BlobId] .| mapC ((entityKey &&& blobContents . entityVal)) -- | Pull all hackage cabal entries from the database as -- 'RawPackageLocationImmutable'. We do a manual join rather than -- dropping to raw SQL, and Esqueleto would add more deps. allHackageCabalRawPackageLocations :: HasResourceMap env => Maybe HackageCabalId -- ^ For some x, yield cabals whose id>x. -> ReaderT SqlBackend (RIO env) (Map.Map HackageCabalId P.RawPackageLocationImmutable) allHackageCabalRawPackageLocations mhackageId = do hackageCabals :: Map HackageCabalId HackageCabal <- selectTuples [HackageCabalId >. hackageId | Just hackageId <- [mhackageId]] [] packageNames :: Map PackageNameId PackageName <- selectTuples [] [] versions :: Map VersionId Version <- selectTuples [] [] for hackageCabals (\hackageCabal -> case Map.lookup (hackageCabalName hackageCabal) packageNames of Nothing -> error "no such package name" Just packageName -> let P.PackageNameP packageName' = packageNameName packageName in case Map.lookup (hackageCabalVersion hackageCabal) versions of Nothing -> error "no such version" Just version -> let P.VersionP version' = versionVersion version in do mtree <- case hackageCabalTree hackageCabal of Just key -> selectFirst [TreeId ==. key] [] Nothing -> pure Nothing mblobKey <- maybe (pure Nothing) (fmap Just . getBlobKey) (fmap (treeKey . entityVal) mtree) pure (P.RPLIHackage (P.PackageIdentifierRevision packageName' version' (P.CFIRevision (hackageCabalRevision hackageCabal))) (fmap P.TreeKey mblobKey))) where selectTuples pred sort = fmap (Map.fromList . map tuple) (selectList pred sort) tuple (Entity k v) = (k, v) allBlobsCount :: Maybe BlobId -> ReaderT SqlBackend (RIO env) Int allBlobsCount mblobId = count [BlobId >. blobId | Just blobId <- [mblobId]] allHackageCabalCount :: Maybe HackageCabalId -> ReaderT SqlBackend (RIO env) Int allHackageCabalCount mhackageCabalId = count [ HackageCabalId >. hackageCabalId | Just hackageCabalId <- [mhackageCabalId] ] getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey getBlobKey bid = do res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] case res of [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid [(Single sha, Single size)] -> pure $ P.BlobKey sha size _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId) getBlobId (P.BlobKey sha size) = do res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" [toPersistValue sha, toPersistValue size] pure $ listToMaybe $ map unSingle res loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString) loadURLBlob url = do ment <- rawSql "SELECT blob.contents\n\ \FROM blob, url_blob\n\ \WHERE url=?\ \ AND url_blob.blob=blob.id\n\ \ ORDER BY url_blob.time DESC" [toPersistValue url] case ment of [] -> pure Nothing (Single bs) : _ -> pure $ Just bs storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) () storeURLBlob url blob = do (blobId, _) <- storeBlob blob now <- getCurrentTime insert_ UrlBlob { urlBlobUrl = url , urlBlobBlob = blobId , urlBlobTime = now } clearHackageRevisions :: ReaderT SqlBackend (RIO env) () clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) storeHackageRevision :: P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) () storeHackageRevision name version key = do nameid <- getPackageNameId name versionid <- getVersionId version rev <- count [ HackageCabalName ==. nameid , HackageCabalVersion ==. versionid ] insert_ HackageCabal { hackageCabalName = nameid , hackageCabalVersion = versionid , hackageCabalRevision = Revision (fromIntegral rev) , hackageCabalCabal = key , hackageCabalTree = Nothing } loadHackagePackageVersions :: P.PackageName -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) loadHackagePackageVersions name = do nameid <- getPackageNameId name -- would be better with esequeleto (Map.fromListWith Map.union . map go) <$> rawSql "SELECT hackage.revision, version.version, blob.sha, blob.size\n\ \FROM hackage_cabal as hackage, version, blob\n\ \WHERE hackage.name=?\n\ \AND hackage.version=version.id\n\ \AND hackage.cabal=blob.id" [toPersistValue nameid] where go (Single revision, Single (P.VersionP version), Single key, Single size) = (version, Map.singleton revision (P.BlobKey key size)) loadHackagePackageVersion :: P.PackageName -> P.Version -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) loadHackagePackageVersion name version = do nameid <- getPackageNameId name versionid <- getVersionId version -- would be better with esequeleto (Map.fromList . map go) <$> rawSql "SELECT hackage.revision, blob.sha, blob.size, blob.id\n\ \FROM hackage_cabal as hackage, version, blob\n\ \WHERE hackage.name=?\n\ \AND hackage.version=?\n\ \AND hackage.cabal=blob.id" [toPersistValue nameid, toPersistValue versionid] where go (Single revision, Single sha, Single size, Single bid) = (revision, (bid, P.BlobKey sha size)) loadLatestCacheUpdate :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] where go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () storeCacheUpdate size sha = do now <- getCurrentTime insert_ CacheUpdate { cacheUpdateTime = now , cacheUpdateSize = size , cacheUpdateSha = sha } storeHackageTarballInfo :: P.PackageName -> P.Version -> SHA256 -> FileSize -> ReaderT SqlBackend (RIO env) () storeHackageTarballInfo name version sha size = do nameid <- getPackageNameId name versionid <- getVersionId version void $ insertBy HackageTarball { hackageTarballName = nameid , hackageTarballVersion = versionid , hackageTarballSha = sha , hackageTarballSize = size } loadHackageTarballInfo :: P.PackageName -> P.Version -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) loadHackageTarballInfo name version = do nameid <- getPackageNameId name versionid <- getVersionId version fmap go <$> getBy (UniqueHackageTarball nameid versionid) where go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) storeCabalFile :: ByteString -> P.PackageName -> ReaderT SqlBackend (RIO env) BlobId storeCabalFile cabalBS pkgName = do (bid, _) <- storeBlob cabalBS let cabalFile = P.cabalFileName pkgName _ <- insertBy FilePath {filePathPath = cabalFile} return bid loadFilePath :: SafeFilePath -> ReaderT SqlBackend (RIO env) (Entity FilePath) loadFilePath path = do fp <- getBy $ UniqueSfp path case fp of Nothing -> error $ "loadFilePath: No row found for " <> (T.unpack $ P.unSafeFilePath path) Just record -> return record loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) loadHPackTreeEntity tid = do filepath <- loadFilePath P.hpackSafeFilePath let filePathId :: FilePathId = entityKey filepath hpackTreeEntry <- selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] case hpackTreeEntry of Nothing -> error $ "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ show tid Just record -> return record storeHPack :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -> TreeId -> ReaderT SqlBackend (RIO env) (Key HPack) storeHPack rpli tid = do vid <- hpackVersionId hpackRecord <- getBy (UniqueHPack tid vid) case hpackRecord of Nothing -> generateHPack rpli tid vid Just record -> return $ entityKey record loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey loadCabalBlobKey hpackId = do hpackRecord <- getJust hpackId getBlobKey $ hPackCabalBlob hpackRecord generateHPack :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> TreeId -> VersionId -> ReaderT SqlBackend (RIO env) (Key HPack) generateHPack rpli tid vid = do tree <- getTree tid (pkgName, cabalBS) <- hpackToCabalS rpli tree bid <- storeCabalFile cabalBS pkgName let cabalFile = P.cabalFileName pkgName fid <- insertBy FilePath {filePathPath = cabalFile} let hpackRecord = HPack { hPackTree = tid , hPackVersion = vid , hPackCabalBlob = bid , hPackCabalPath = either entityKey id fid } either entityKey id <$> insertBy hpackRecord hpackVersionId :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => ReaderT SqlBackend (RIO env) VersionId hpackVersionId = do hpackSoftwareVersion <- lift hpackVersion fmap (either entityKey id) $ insertBy $ Version {versionVersion = P.VersionP hpackSoftwareVersion} getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId getFilePathId sfp = selectKeysList [FilePathPath ==. sfp] [] >>= \case [fpId] -> pure fpId [] -> rdbmsAwareQuery RdbmsActions { raSqlite = insert $ FilePath sfp , raPostgres = do rawExecute "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" [toPersistValue sfp] rawSql "SELECT id FROM file_path WHERE path = ?" [toPersistValue sfp] >>= \case [Single key] -> pure key _ -> error "getFilePathId: there was a critical problem storing a blob." } _ -> error $ "getFilePathId: FilePath unique constraint key is violated for: " ++ fp where fp = T.unpack (P.unSafeFilePath sfp) storeTree :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.PackageIdentifier -> P.Tree -> P.BuildFile -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey) storeTree rpli (P.PackageIdentifier name version) tree@(P.TreeMap m) buildFile = do (bid, blobKey) <- storeBlob $ P.renderTree tree (cabalid, ftype) <- case buildFile of P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype) P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do buildTypeid <- loadBlobBySHA btypeSha buildid <- case buildTypeid of Just buildId -> pure buildId Nothing -> error $ "storeTree: " ++ (show buildFile) ++ " BlobKey not found: " ++ show (tree, btypeSha) return (Just buildid, ftype) nameid <- getPackageNameId name versionid <- getVersionId version etid <- insertBy Tree { treeKey = bid , treeCabal = cabalid , treeCabalType = ftype , treeName = nameid , treeVersion = versionid } (tid, pTreeKey) <- case etid of Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches Right tid -> do for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey' ft) -> do sfpid <- getFilePathId sfp mbid <- getBlobId blobKey' bid' <- case mbid of Nothing -> error $ "Cannot store tree, contains unknown blob: " ++ show blobKey' Just bid' -> pure bid' insert_ TreeEntry { treeEntryTree = tid , treeEntryPath = sfpid , treeEntryBlob = bid' , treeEntryType = ft } pure (tid, P.TreeKey blobKey) case buildFile of P.BFHpack _ -> storeHPack rpli tid >> return () P.BFCabal _ _ -> return () return (tid, pTreeKey) getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree getTree tid = do (mts :: Maybe Tree) <- get tid ts <- case mts of Nothing -> error $ "getTree: invalid foreign key " ++ show tid Just ts -> pure ts loadTreeByEnt $ Entity tid ts loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) loadTree key = do ment <- getTreeForKey key case ment of Nothing -> pure Nothing Just ent -> Just <$> loadTreeByEnt ent getTreeForKey :: TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) getTreeForKey (P.TreeKey key) = do mbid <- getBlobId key case mbid of Nothing -> pure Nothing Just bid -> getBy $ UniqueTree bid loadPackageById :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> TreeId -> ReaderT SqlBackend (RIO env) Package loadPackageById rpli tid = do (mts :: Maybe Tree) <- get tid ts <- case mts of Nothing -> error $ "loadPackageById: invalid foreign key " ++ show tid Just ts -> pure ts (tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts (blobKey :: BlobKey) <- getBlobKey $ treeKey ts (mname :: Maybe PackageName) <- get $ treeName ts name <- case mname of Nothing -> error $ "loadPackageByid: invalid foreign key " ++ show (treeName ts) Just (PackageName (P.PackageNameP name)) -> pure name mversion <- get $ treeVersion ts version <- case mversion of Nothing -> error $ "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) Just (Version (P.VersionP version)) -> pure version let ident = P.PackageIdentifier name version (packageEntry, mtree) <- case treeCabal ts of Just keyBlob -> do cabalKey <- getBlobKey keyBlob return ( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts) , tree) Nothing -> do hpackVid <- hpackVersionId hpackEntity <- getBy (UniqueHPack tid hpackVid) let (P.TreeMap tmap) = tree cabalFile = P.cabalFileName name case hpackEntity of Nothing -- This case will happen when you either -- update stack with a new hpack version or -- use different hpack version via -- --with-hpack option. -> do (hpackId :: HPackId) <- storeHPack rpli tid hpackRecord <- getJust hpackId getHPackCabalFile hpackRecord ts tmap cabalFile Just (Entity _ item) -> getHPackCabalFile item ts tmap cabalFile pure Package { packageTreeKey = P.TreeKey blobKey , packageTree = mtree , packageCabalEntry = packageEntry , packageIdent = ident } getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey getHPackBlobKey hpackRecord = do let treeId = hPackTree hpackRecord hpackEntity <- loadHPackTreeEntity treeId getBlobKey (treeEntryBlob $ entityVal hpackEntity) getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey getHPackBlobKeyById hpackId = do hpackRecord <- getJust hpackId getHPackBlobKey hpackRecord getHPackCabalFile :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => HPack -> Tree -> Map SafeFilePath P.TreeEntry -> SafeFilePath -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree) getHPackCabalFile hpackRecord ts tmap cabalFile = do cabalKey <- getBlobKey (hPackCabalBlob hpackRecord) hpackKey <- getHPackBlobKey hpackRecord hpackSoftwareVersion <- lift hpackVersion let fileType = treeCabalType ts cbTreeEntry = P.TreeEntry cabalKey fileType hpackTreeEntry = P.TreeEntry hpackKey fileType tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap return ( P.PCHpack $ P.PHpack { P.phOriginal = hpackTreeEntry , P.phGenerated = cbTreeEntry , P.phVersion = hpackSoftwareVersion } , tree) loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree loadTreeByEnt (Entity tid _t) = do entries <- rawSql "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ \FROM tree_entry, blob, file_path\n\ \WHERE tree_entry.tree=?\n\ \AND tree_entry.blob=blob.id\n\ \AND tree_entry.path=file_path.id" [toPersistValue tid] pure $ P.TreeMap $ Map.fromList $ map (\(Single sfp, Single sha, Single size, Single ft) -> (sfp, P.TreeEntry (P.BlobKey sha size) ft)) entries storeHackageTree :: P.PackageName -> P.Version -> BlobId -> P.TreeKey -> ReaderT SqlBackend (RIO env) () storeHackageTree name version cabal treeKey' = do nameid <- getPackageNameId name versionid <- getVersionId version ment <- getTreeForKey treeKey' for_ ment $ \ent -> updateWhere [ HackageCabalName ==. nameid , HackageCabalVersion ==. versionid , HackageCabalCabal ==. cabal ] [HackageCabalTree =. Just (entityKey ent)] loadHackageTreeKey :: P.PackageName -> P.Version -> SHA256 -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) loadHackageTreeKey name ver sha = do res <- rawSql "SELECT treeblob.sha, treeblob.size\n\ \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\ \WHERE package_name.name=?\n\ \AND version.version=?\n\ \AND cabalblob.sha=?\n\ \AND hackage_cabal.name=package_name.id\n\ \AND hackage_cabal.version=version.id\n\ \AND hackage_cabal.cabal=cabalblob.id\n\ \AND hackage_cabal.tree=tree.id\n\ \AND tree.key=treeblob.id" [ toPersistValue $ P.PackageNameP name , toPersistValue $ P.VersionP ver , toPersistValue sha ] case res of [] -> pure Nothing (Single treesha, Single size):_ -> pure $ Just $ P.TreeKey $ P.BlobKey treesha size loadHackageTree :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) (Maybe Package) loadHackageTree rpli name ver bid = do nameid <- getPackageNameId name versionid <- getVersionId ver ment <- selectFirst [ HackageCabalName ==. nameid , HackageCabalVersion ==. versionid , HackageCabalCabal ==. bid , HackageCabalTree !=. Nothing ] [] case ment of Nothing -> pure Nothing Just (Entity _ hc) -> case hackageCabalTree hc of Nothing -> assert False $ pure Nothing Just tid -> Just <$> loadPackageById rpli tid storeArchiveCache :: Text -- ^ URL -> Text -- ^ subdir -> SHA256 -> FileSize -> P.TreeKey -> ReaderT SqlBackend (RIO env) () storeArchiveCache url subdir sha size treeKey' = do now <- getCurrentTime ment <- getTreeForKey treeKey' for_ ment $ \ent -> insert_ ArchiveCache { archiveCacheTime = now , archiveCacheUrl = url , archiveCacheSubdir = subdir , archiveCacheSha = sha , archiveCacheSize = size , archiveCacheTree = entityKey ent } loadArchiveCache :: Text -- ^ URL -> Text -- ^ subdir -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] loadArchiveCache url subdir = map go <$> selectList [ ArchiveCacheUrl ==. url , ArchiveCacheSubdir ==. subdir ] [Desc ArchiveCacheTime] where go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) storeRepoCache :: Repo -> Text -- ^ subdir -> TreeId -> ReaderT SqlBackend (RIO env) () storeRepoCache repo subdir tid = do now <- getCurrentTime insert_ RepoCache { repoCacheTime = now , repoCacheUrl = repoUrl repo , repoCacheType = repoType repo , repoCacheCommit = repoCommit repo , repoCacheSubdir = subdir , repoCacheTree = tid } loadRepoCache :: Repo -> Text -- ^ subdir -> ReaderT SqlBackend (RIO env) (Maybe TreeId) loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst [ RepoCacheUrl ==. repoUrl repo , RepoCacheType ==. repoType repo , RepoCacheCommit ==. repoCommit repo , RepoCacheSubdir ==. subdir ] [Desc RepoCacheTime] storePreferredVersion :: P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () storePreferredVersion name p = do nameid <- getPackageNameId name ment <- getBy $ UniquePreferred nameid case ment of Nothing -> insert_ PreferredVersions { preferredVersionsName = nameid , preferredVersionsPreferred = p } Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] loadPreferredVersion :: P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) loadPreferredVersion name = do nameid <- getPackageNameId name fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) sinkHackagePackageNames :: (P.PackageName -> Bool) -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a -> ReaderT SqlBackend (RIO env) a sinkHackagePackageNames predicate sink = do acqSrc <- selectSourceRes [] [] with acqSrc $ \src -> runConduit $ src .| concatMapMC go .| sink where go (Entity nameid (PackageName (PackageNameP name))) | predicate name = do -- Make sure it's actually on Hackage. Would be much more -- efficient with some raw SQL and an inner join, but we -- don't have a Conduit version of rawSql. onHackage <- checkOnHackage nameid pure $ if onHackage then Just name else Nothing | otherwise = pure Nothing checkOnHackage nameid = do cnt <- count [HackageCabalName ==. nameid] pure $ cnt > 0 -- | Get the filename for the cabal file in the given directory. -- -- If no .cabal file is present, or more than one is present, an exception is -- thrown via 'throwM'. -- -- If the directory contains a file named package.yaml, hpack is used to -- generate a .cabal file from it. findOrGenerateCabalFile :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ package directory -> RIO env (P.PackageName, Path Abs File) findOrGenerateCabalFile pkgDir = do hpack pkgDir files <- filter (flip hasExtension "cabal" . toFilePath) . snd <$> listDir pkgDir -- If there are multiple files, ignore files that start with -- ".". On unixlike environments these are hidden, and this -- character is not valid in package names. The main goal is -- to ignore emacs lock files - see -- https://github.com/commercialhaskell/stack/issues/1897. let isHidden ('.':_) = True isHidden _ = False case filter (not . isHidden . fromRelFile . filename) files of [] -> throwIO $ P.NoCabalFileFound pkgDir [x] -> maybe (throwIO $ P.InvalidCabalFilePath x) (\pn -> pure $ (pn, x)) $ List.stripSuffix ".cabal" (toFilePath (filename x)) >>= P.parsePackageName _:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files where hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Similar to 'hpackToCabal' but doesn't require a new connection to database. hpackToCabalS :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.Tree -> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString) hpackToCabalS rpli tree = do tmpDir <- lift $ do tdir <- getTempDir createTempDir tdir "hpack-pkg-dir" unpackTreeToDir rpli tmpDir tree (packageName, cfile) <- lift $ findOrGenerateCabalFile tmpDir !bs <- lift $ B.readFile (fromAbsFile cfile) lift $ removeDirRecur tmpDir return $ (packageName, bs) hpackToCabal :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.Tree -> RIO env (P.PackageName, ByteString) hpackToCabal rpli tree = withSystemTempDirectory "hpack-pkg-dir" $ \tmpdir -> do tdir <- parseAbsDir tmpdir withStorage $ unpackTreeToDir rpli tdir tree (packageName, cfile) <- findOrGenerateCabalFile tdir bs <- B.readFile (fromAbsFile cfile) return (packageName, bs) unpackTreeToDir :: (HasPantryConfig env, HasLogFunc env) => P.RawPackageLocationImmutable -- ^ for exceptions -> Path Abs Dir -- ^ dest dir, will be created if necessary -> P.Tree -> ReaderT SqlBackend (RIO env) () unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey ft) -> do let dest = dir T.unpack (P.unSafeFilePath sfp) createDirectoryIfMissing True $ takeDirectory dest mbs <- loadBlob blobKey case mbs of Nothing -> do -- TODO when we have pantry wire stuff, try downloading throwIO $ P.TreeReferencesMissingBlob rpli sfp blobKey Just bs -> do B.writeFile dest bs case ft of FTNormal -> pure () FTExecutable -> liftIO $ do perms <- getPermissions dest setPermissions dest $ setOwnerExecutable True perms countHackageCabals :: ReaderT SqlBackend (RIO env) Int countHackageCabals = do res <- rawSql "SELECT COUNT(*)\n\ \FROM hackage_cabal" [] case res of [] -> pure 0 (Single n):_ -> pure n getSnapshotCacheByHash :: SnapshotCacheHash -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId) getSnapshotCacheByHash = fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash getSnapshotCacheId :: SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId getSnapshotCacheId = fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash getModuleNameId :: P.ModuleName -> ReaderT SqlBackend (RIO env) ModuleNameId getModuleNameId = fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP storeSnapshotModuleCache :: SnapshotCacheId -> Map P.PackageName (Set P.ModuleName) -> ReaderT SqlBackend (RIO env) () storeSnapshotModuleCache cache packageModules = forM_ (Map.toList packageModules) $ \(pn, modules) -> do package <- getPackageNameId pn forM_ modules $ \m -> do moduleName <- getModuleNameId m insert_ PackageExposedModule { packageExposedModuleSnapshotCache = cache , packageExposedModulePackage = package , packageExposedModuleModule = moduleName } loadExposedModulePackages :: SnapshotCacheId -> P.ModuleName -> ReaderT SqlBackend (RIO env) [P.PackageName] loadExposedModulePackages cacheId mName = map go <$> rawSql "SELECT package_name.name\n\ \FROM package_name, package_exposed_module, module_name\n\ \WHERE module_name.name=?\n\ \AND package_exposed_module.snapshot_cache=?\n\ \AND module_name.id=package_exposed_module.module\n\ \AND package_name.id=package_exposed_module.package" [ toPersistValue (P.ModuleNameP mName) , toPersistValue cacheId ] where go (Single (P.PackageNameP m)) = m pantry-0.4.0.2/src/Pantry/Casa.hs0000644000000000000000000000527113712324626014640 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DisambiguateRecordFields #-} -- | Integration with the Casa server. module Pantry.Casa where import qualified Casa.Client as Casa import qualified Casa.Types as Casa import Conduit import qualified Data.HashMap.Strict as HM import qualified Pantry.SHA256 as SHA256 import Pantry.Storage import Pantry.Types as P import RIO import qualified RIO.ByteString as B -- | Lookup a tree. casaLookupTree :: (HasPantryConfig env, HasLogFunc env) => TreeKey -> RIO env (Maybe (TreeKey, P.Tree)) casaLookupTree (P.TreeKey key) = withStorage (runConduitRes (casaBlobSource (Identity key) .| mapMC parseTreeM .| await)) -- | Lookup a single blob. If possible, prefer 'casaBlobSource', and -- query a group of keys at once, rather than one at a time. This will -- have better network performance. casaLookupKey :: (HasPantryConfig env, HasLogFunc env) => BlobKey -> RIO env (Maybe ByteString) casaLookupKey key = fmap (fmap snd) (withStorage (runConduitRes (casaBlobSource (Identity key) .| await))) -- | A source of blobs given a set of keys. All blobs are -- automatically stored in the local pantry database. casaBlobSource :: (Foldable f, HasPantryConfig env, HasLogFunc env) => f BlobKey -> ConduitT i (BlobKey, ByteString) (ResourceT (ReaderT SqlBackend (RIO env))) () casaBlobSource keys = source .| convert .| store where source = do pullUrl <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaRepoPrefix maxPerRequest <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaMaxPerRequest Casa.blobsSource (Casa.SourceConfig { sourceConfigUrl = pullUrl , sourceConfigBlobs = toBlobKeyMap keys , sourceConfigMaxBlobsPerRequest = maxPerRequest }) where toBlobKeyMap :: Foldable f => f BlobKey -> HashMap Casa.BlobKey Int toBlobKeyMap = HM.fromList . map unpackBlobKey . toList unpackBlobKey (P.BlobKey sha256 (FileSize fileSize)) = (Casa.BlobKey (SHA256.toRaw sha256), fromIntegral fileSize) convert = mapMC toBlobKeyAndBlob where toBlobKeyAndBlob :: MonadThrow m => (Casa.BlobKey, ByteString) -> m (BlobKey, ByteString) toBlobKeyAndBlob (Casa.BlobKey keyBytes, blob) = do sha256 <- case SHA256.fromRaw keyBytes of Left e -> throwM e Right sha -> pure sha pure (BlobKey sha256 (FileSize (fromIntegral (B.length blob))), blob) store = mapMC insertBlob where insertBlob original@(_key, binary) = do _ <- lift (storeBlob binary) pure original pantry-0.4.0.2/src/Pantry/Tree.hs0000644000000000000000000000377213712326407014673 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Pantry.Tree ( unpackTree , rawParseGPD ) where import RIO import qualified RIO.Map as Map import qualified RIO.Text as T import qualified RIO.ByteString as B import Pantry.Storage hiding (Tree, TreeEntry) import Pantry.Types import RIO.FilePath ((), takeDirectory) import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) import Path (Path, Abs, Dir, toFilePath) import Distribution.Parsec (PWarning (..)) import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Parsec import Path (File) unpackTree :: (HasPantryConfig env, HasLogFunc env) => RawPackageLocationImmutable -- for exceptions -> Path Abs Dir -- ^ dest dir, will be created if necessary -> Tree -> RIO env () unpackTree rpli (toFilePath -> dir) (TreeMap m) = do withStorage $ for_ (Map.toList m) $ \(sfp, TreeEntry blobKey ft) -> do let dest = dir T.unpack (unSafeFilePath sfp) createDirectoryIfMissing True $ takeDirectory dest mbs <- loadBlob blobKey case mbs of Nothing -> do -- TODO when we have pantry wire stuff, try downloading throwIO $ TreeReferencesMissingBlob rpli sfp blobKey Just bs -> do B.writeFile dest bs case ft of FTNormal -> pure () FTExecutable -> liftIO $ do perms <- getPermissions dest setPermissions dest $ setOwnerExecutable True perms -- | A helper function that performs the basic character encoding -- necessary. rawParseGPD :: MonadThrow m => Either RawPackageLocationImmutable (Path Abs File) -> ByteString -> m ([PWarning], GenericPackageDescription) rawParseGPD loc bs = case eres of Left (mversion, errs) -> throwM $ InvalidCabalFile loc mversion (toList errs) warnings Right gpkg -> return (warnings, gpkg) where (warnings, eres) = runParseResult $ parseGenericPackageDescription bs pantry-0.4.0.2/src/Pantry/Types.hs0000644000000000000000000024265613712326343015105 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiWayIf #-} module Pantry.Types ( PantryConfig (..) , HackageSecurityConfig (..) , Storage (..) , HasPantryConfig (..) , BlobKey (..) , PackageName , Version , PackageIdentifier (..) , Revision (..) , ModuleName , CabalFileInfo (..) , PrintWarnings (..) , PackageNameP (..) , VersionP (..) , ModuleNameP (..) , PackageIdentifierRevision (..) , pirForHash , FileType (..) , BuildFile (..) , FileSize (..) , TreeEntry (..) , SafeFilePath , unSafeFilePath , mkSafeFilePath , safeFilePathtoPath , hpackSafeFilePath , TreeKey (..) , Tree (..) , renderTree , parseTree , parseTreeM , SHA256 , Unresolved , resolvePaths , Package (..) , PackageCabal (..) , PHpack (..) -- , PackageTarball (..) , RawPackageLocation (..) , PackageLocation (..) , toRawPL , RawPackageLocationImmutable (..) , PackageLocationImmutable (..) , toRawPLI , RawArchive (..) , Archive (..) , toRawArchive , Repo (..) , RepoType (..) , parsePackageIdentifier , parsePackageName , parsePackageNameThrowing , parseFlagName , parseVersion , parseVersionThrowing , packageIdentifierString , packageNameString , flagNameString , versionString , moduleNameString , OptionalSubdirs (..) , ArchiveLocation (..) , RelFilePath (..) , CabalString (..) , toCabalStringMap , unCabalStringMap , parsePackageIdentifierRevision , Mismatch (..) , PantryException (..) , FuzzyResults (..) , ResolvedPath (..) , HpackExecutable (..) , WantedCompiler (..) --, resolveSnapshotLocation , ltsSnapshotLocation , nightlySnapshotLocation , RawSnapshotLocation (..) , SnapshotLocation (..) , toRawSL , parseHackageText , parseRawSnapshotLocation , RawSnapshotLayer (..) , SnapshotLayer (..) , toRawSnapshotLayer , RawSnapshot (..) , Snapshot (..) , RawSnapshotPackage (..) , SnapshotPackage (..) , parseWantedCompiler , RawPackageMetadata (..) , PackageMetadata (..) , toRawPM , cabalFileName , SnapshotCacheHash (..) , getGlobalHintsFile , bsToBlobKey , warnMissingCabalFile ) where import RIO import qualified Data.Conduit.Tar as Tar import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import RIO.List (intersperse) import RIO.Time (toGregorian, Day, fromGregorianValid, UTCTime) import qualified RIO.Map as Map import qualified RIO.HashMap as HM import qualified Data.Map.Strict as Map (mapKeysMonotonic) import qualified RIO.Set as Set import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText, Parser) import Pantry.Internal.AesonExtended import Data.Aeson.Encoding.Internal (unsafeToEncoding) import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) import Database.Persist import Database.Persist.Sql import Pantry.SHA256 (SHA256) import qualified Pantry.SHA256 as SHA256 import qualified Distribution.Compat.CharParsing as Parse import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Parsec (PError (..), PWarning (..), showPos, parsec, explicitEitherParsec, ParsecParser) import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName) import Distribution.Types.VersionRange (VersionRange) import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription) import Distribution.Types.PackageId (PackageIdentifier (..)) import qualified Distribution.Pretty import qualified Distribution.Text import qualified Hpack.Config as Hpack import Distribution.ModuleName (ModuleName) import Distribution.Types.Version (Version, mkVersion, nullVersion) import Network.HTTP.Client (parseRequest) import Network.HTTP.Types (Status, statusCode) import Data.Text.Read (decimal) import Path (Path, Abs, Dir, File, toFilePath, filename, (), parseRelFile) import Path.IO (resolveFile, resolveDir) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Casa.Client (CasaRepoPrefix) -- | Parsed tree with more information on the Haskell package it contains. -- -- @since 0.1.0.0 data Package = Package { packageTreeKey :: !TreeKey -- ^ The 'TreeKey' containing this package. -- -- This is a hash of the binary representation of 'packageTree'. -- -- @since 0.1.0.0 , packageTree :: !Tree -- ^ The 'Tree' containing this package. -- -- @since 0.1.0.0 , packageCabalEntry :: !PackageCabal -- ^ Information on the cabal file inside this package. -- -- @since 0.1.0.0 , packageIdent :: !PackageIdentifier -- ^ The package name and version in this package. -- -- @since 0.1.0.0 } deriving (Show, Eq) data PHpack = PHpack { phOriginal :: !TreeEntry, -- ^ Original hpack file phGenerated :: !TreeEntry, -- ^ Generated Cabal file phVersion :: !Version -- ^ Version of Hpack used } deriving (Show, Eq) data PackageCabal = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file | PCHpack !PHpack deriving (Show, Eq) cabalFileName :: PackageName -> SafeFilePath cabalFileName name = case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of Nothing -> error $ "cabalFileName: failed for " ++ show name Just sfp -> sfp -- | The revision number of a package from Hackage, counting upwards -- from 0 (the original cabal file). -- -- See caveats on 'CFIRevision'. -- -- @since 0.1.0.0 newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql) -- | Represents a SQL database connection. This used to be a newtype -- wrapper around a connection pool. However, when investigating -- , it -- appeared that holding a pool resulted in overly long write locks -- being held on the database. As a result, we now abstract away -- whether a pool is used, and the default implementation in -- "Pantry.Storage" does not use a pool. data Storage = Storage { withStorage_ :: forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a } -- | Configuration value used by the entire pantry package. Create one -- using @withPantryConfig@. See also @PantryApp@ for a convenience -- approach to using pantry. -- -- @since 0.1.0.0 data PantryConfig = PantryConfig { pcHackageSecurity :: !HackageSecurityConfig , pcHpackExecutable :: !HpackExecutable , pcRootDir :: !(Path Abs Dir) , pcStorage :: !Storage , pcUpdateRef :: !(MVar Bool) -- ^ Want to try updating the index once during a single run for missing -- package identifiers. We also want to ensure we only update once at a -- time. Start at @True@. , pcParsedCabalFilesRawImmutable :: !(IORef (Map RawPackageLocationImmutable GenericPackageDescription)) -- ^ Cache of previously parsed cabal files, to save on slow parsing time. , pcParsedCabalFilesMutable :: !(IORef (Map (Path Abs Dir) (PrintWarnings -> IO GenericPackageDescription, PackageName, Path Abs File) ) ) -- ^ Cache for mutable packages. We want to allow for an optimization: -- deferring parsing of the 'GenericPackageDescription' until its actually -- needed. Therefore, we keep the filepath and the 'PackageName' derived from -- that filepath. When the @IO GenericPackageDescription@ is run, it will -- ensure that the @PackageName@ matches the value inside the cabal file, and -- print out any warnings that still need to be printed. , pcConnectionCount :: !Int -- ^ concurrently open downloads , pcCasaRepoPrefix :: !CasaRepoPrefix -- ^ The pull URL e.g. @https://casa.fpcomplete.com/v1/pull@ , pcCasaMaxPerRequest :: !Int -- ^ Maximum blobs sent per pull request. } -- | Should we print warnings when loading a cabal file? -- -- @since 0.1.0.0 data PrintWarnings = YesPrintWarnings | NoPrintWarnings -- | Wraps a value which potentially contains relative paths. Needs to -- be provided with a base directory to resolve these paths. -- -- Unwrap this using 'resolvePaths'. -- -- @since 0.1.0.0 newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) deriving Functor instance Applicative Unresolved where pure = Unresolved . const . pure Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir -- | Resolve all of the file paths in an 'Unresolved' relative to the -- given directory. -- -- @since 0.1.0.0 resolvePaths :: MonadIO m => Maybe (Path Abs Dir) -- ^ directory to use for relative paths -> Unresolved a -> m a resolvePaths mdir (Unresolved f) = liftIO (f mdir) -- | A combination of the relative path provided in a config file, -- together with the resolved absolute path. -- -- @since 0.1.0.0 data ResolvedPath t = ResolvedPath { resolvedRelative :: !RelFilePath -- ^ Original value parsed from a config file. , resolvedAbsolute :: !(Path Abs t) -- ^ Absolute path resolved against base directory loaded from. } deriving (Show, Eq, Generic, Ord) instance NFData (ResolvedPath t) -- | Location to load a package from. Can either be immutable (see -- 'PackageLocationImmutable') or a local directory which is expected -- to change over time. Raw version doesn't include exact package -- version (e.g. could refer to the latest revision on Hackage) -- -- @since 0.1.0.0 data RawPackageLocation = RPLImmutable !RawPackageLocationImmutable | RPLMutable !(ResolvedPath Dir) deriving (Show, Eq, Generic) instance NFData RawPackageLocation -- | Location to load a package from. Can either be immutable (see -- 'PackageLocationImmutable') or a local directory which is expected -- to change over time. -- -- @since 0.1.0.0 data PackageLocation = PLImmutable !PackageLocationImmutable | PLMutable !(ResolvedPath Dir) deriving (Show, Eq, Generic) instance NFData PackageLocation instance Display PackageLocation where display (PLImmutable loc) = display loc display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp -- | Convert `PackageLocation` to its "raw" equivalent -- -- @since 0.1.0.0 toRawPL :: PackageLocation -> RawPackageLocation toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im) toRawPL (PLMutable m) = RPLMutable m -- | Location for remote packages or archives assumed to be immutable. -- as user specifies it i.e. not an exact location -- -- @since 0.1.0.0 data RawPackageLocationImmutable = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) | RPLIArchive !RawArchive !RawPackageMetadata | RPLIRepo !Repo !RawPackageMetadata deriving (Show, Eq, Ord, Generic) instance NFData RawPackageLocationImmutable instance Display RawPackageLocationImmutable where display (RPLIHackage pir _tree) = display pir <> " (from Hackage)" display (RPLIArchive archive _pm) = "Archive from " <> display (raLocation archive) <> (if T.null $ raSubdir archive then mempty else " in subdir " <> display (raSubdir archive)) display (RPLIRepo repo _pm) = "Repo from " <> display (repoUrl repo) <> ", commit " <> display (repoCommit repo) <> (if T.null $ repoSubdir repo then mempty else " in subdir " <> display (repoSubdir repo)) -- | Location for remote packages or archives assumed to be immutable. -- -- @since 0.1.0.0 data PackageLocationImmutable = PLIHackage !PackageIdentifier !BlobKey !TreeKey | PLIArchive !Archive !PackageMetadata | PLIRepo !Repo !PackageMetadata deriving (Generic, Show, Eq, Ord, Typeable) instance NFData PackageLocationImmutable instance Display PackageLocationImmutable where display (PLIHackage ident _cabalHash _tree) = fromString (packageNameString $ pkgName ident) <> " (from Hackage)" display (PLIArchive archive _pm) = "Archive from " <> display (archiveLocation archive) <> (if T.null $ archiveSubdir archive then mempty else " in subdir " <> display (archiveSubdir archive)) display (PLIRepo repo _pm) = "Repo from " <> display (repoUrl repo) <> ", commit " <> display (repoCommit repo) <> (if T.null $ repoSubdir repo then mempty else " in subdir " <> display (repoSubdir repo)) instance ToJSON PackageLocationImmutable where toJSON = toJSON . toRawPLI -- | Package identifier and revision with a specified cabal file hash -- -- @since 0.1.0.0 pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision pirForHash (PackageIdentifier name ver) (BlobKey sha size') = let cfi = CFIHash sha (Just size') in PackageIdentifierRevision name ver cfi -- | Convert `PackageLocationImmutable` to its "raw" equivalent -- -- @since 0.1.0.0 toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable toRawPLI (PLIHackage ident cfKey treeKey) = RPLIHackage (pirForHash ident cfKey) (Just treeKey) toRawPLI (PLIArchive archive pm) = RPLIArchive (toRawArchive archive) (toRawPM pm) toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm) -- | A raw package archive, specified by a user, could have no -- hash and file size information. -- -- @since 0.1.0.0 data RawArchive = RawArchive { raLocation :: !ArchiveLocation -- ^ Location of the archive -- -- @since 0.1.0.0 , raHash :: !(Maybe SHA256) -- ^ Cryptographic hash of the archive file -- -- @since 0.1.0.0 , raSize :: !(Maybe FileSize) -- ^ Size of the archive file -- -- @since 0.1.0.0 , raSubdir :: !Text -- ^ Subdirectory within the archive to get the package from. -- -- @since 0.1.0.0 } deriving (Generic, Show, Eq, Ord, Typeable) instance NFData RawArchive -- | A package archive, could be from a URL or a local file -- path. Local file path archives are assumed to be unchanging -- over time, and so are allowed in custom snapshots. -- -- @since 0.1.0.0 data Archive = Archive { archiveLocation :: !ArchiveLocation -- ^ Location of the archive -- -- @since 0.1.0.0 , archiveHash :: !SHA256 -- ^ Cryptographic hash of the archive file -- -- @since 0.1.0.0 , archiveSize :: !FileSize -- ^ Size of the archive file -- -- @since 0.1.0.0 , archiveSubdir :: !Text -- ^ Subdirectory within the archive to get the package from. -- -- @since 0.1.0.0 } deriving (Generic, Show, Eq, Ord, Typeable) instance NFData Archive -- | Convert archive to its "raw" equivalent. -- -- @since 0.1.0.0 toRawArchive :: Archive -> RawArchive toRawArchive archive = RawArchive (archiveLocation archive) (Just $ archiveHash archive) (Just $ archiveSize archive) (archiveSubdir archive) -- | The type of a source control repository. -- -- @since 0.1.0.0 data RepoType = RepoGit | RepoHg deriving (Generic, Show, Eq, Ord, Typeable) instance NFData RepoType instance PersistField RepoType where toPersistValue RepoGit = toPersistValue (1 :: Int32) toPersistValue RepoHg = toPersistValue (2 :: Int32) fromPersistValue v = do i <- fromPersistValue v case i :: Int32 of 1 -> pure RepoGit 2 -> pure RepoHg _ -> Left $ fromString $ "Invalid RepoType: " ++ show i instance PersistFieldSql RepoType where sqlType _ = SqlInt32 -- | Information on packages stored in a source control repository. -- -- @since 0.1.0.0 data Repo = Repo { repoUrl :: !Text -- ^ Location of the repo -- -- @since 0.1.0.0 , repoCommit :: !Text -- ^ Commit to use from the repo. It's strongly recommended to use -- a hash instead of a tag or branch name. -- -- @since 0.1.0.0 , repoType :: !RepoType -- ^ The type of the repo -- -- @since 0.1.0.0 , repoSubdir :: !Text -- ^ Subdirectory within the archive to get the package from. -- -- @since 0.1.0.0 } deriving (Generic, Eq, Ord, Typeable) instance NFData Repo instance Show Repo where show = T.unpack . utf8BuilderToText . display instance Display Repo where display (Repo url commit typ subdir) = (case typ of RepoGit -> "Git" RepoHg -> "Mercurial") <> " repo at " <> display url <> ", commit " <> display commit <> (if T.null subdir then mempty else " in subdirectory " <> display subdir) -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains -- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". newtype GitHubRepo = GitHubRepo Text instance FromJSON GitHubRepo where parseJSON = withText "GitHubRepo" $ \s -> do case T.split (== '/') s of [x, y] | not (T.null x || T.null y) -> return (GitHubRepo s) _ -> fail "expecting \"user/repo\"" -- | Configuration for Hackage Security to securely download package -- metadata and contents from Hackage. For most purposes, you'll want -- to use the default Hackage settings via -- @defaultHackageSecurityConfig@. -- -- /NOTE/ It's highly recommended to only use the official Hackage -- server or a mirror. See -- . -- -- @since 0.1.0.0 data HackageSecurityConfig = HackageSecurityConfig { hscKeyIds :: ![Text] , hscKeyThreshold :: !Int , hscDownloadPrefix :: !Text , hscIgnoreExpiry :: !Bool } deriving Show instance FromJSON (WithJSONWarnings HackageSecurityConfig) where parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o' -> do hscDownloadPrefix <- o' ..: "download-prefix" Object o <- o' ..: "hackage-security" hscKeyIds <- o ..: "keyids" hscKeyThreshold <- o ..: "key-threshold" hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True pure HackageSecurityConfig {..} -- | An environment which contains a 'PantryConfig'. -- -- @since 0.1.0.0 class HasPantryConfig env where -- | Lens to get or set the 'PantryConfig' -- -- @since 0.1.0.0 pantryConfigL :: Lens' env PantryConfig -- | File size in bytes -- -- @since 0.1.0.0 newtype FileSize = FileSize Word deriving (Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData, PersistField, PersistFieldSql, ToJSON, FromJSON) -- | A key for looking up a blob, which combines the SHA256 hash of -- the contents and the file size. -- -- The file size may seem redundant with the hash. However, it is -- necessary for safely downloading blobs from an untrusted -- source. See -- . -- -- @since 0.1.0.0 data BlobKey = BlobKey !SHA256 !FileSize deriving (Eq, Ord, Typeable, Generic) instance NFData BlobKey instance Show BlobKey where show = T.unpack . utf8BuilderToText . display instance Display BlobKey where display (BlobKey sha size') = display sha <> "," <> display size' blobKeyPairs :: BlobKey -> [(Text, Value)] blobKeyPairs (BlobKey sha size') = [ "sha256" .= sha , "size" .= size' ] instance ToJSON BlobKey where toJSON = object . blobKeyPairs instance FromJSON BlobKey where parseJSON = withObject "BlobKey" $ \o -> BlobKey <$> o .: "sha256" <*> o .: "size" newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } deriving (Eq, Ord, Show, Read, NFData) instance Display PackageNameP where display = fromString . packageNameString . unPackageNameP instance PersistField PackageNameP where toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn fromPersistValue v = do str <- fromPersistValue v case parsePackageName str of Nothing -> Left $ "Invalid package name: " <> T.pack str Just pn -> Right $ PackageNameP pn instance PersistFieldSql PackageNameP where sqlType _ = SqlString instance ToJSON PackageNameP where toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn instance FromJSON PackageNameP where parseJSON = withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack instance ToJSONKey PackageNameP where toJSONKey = ToJSONKeyText (T.pack . packageNameString . unPackageNameP) (unsafeToEncoding . getUtf8Builder . display) instance FromJSONKey PackageNameP where fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack newtype VersionP = VersionP { unVersionP :: Version } deriving (Eq, Ord, Show, Read, NFData) instance PersistField VersionP where toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v fromPersistValue v = do str <- fromPersistValue v case parseVersion str of Nothing -> Left $ "Invalid version number: " <> T.pack str Just ver -> Right $ VersionP ver instance PersistFieldSql VersionP where sqlType _ = SqlString instance Display VersionP where display (VersionP v) = fromString $ versionString v instance ToJSON VersionP where toJSON (VersionP v) = String $ T.pack $ versionString v instance FromJSON VersionP where parseJSON = withText "VersionP" $ either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack newtype ModuleNameP = ModuleNameP { unModuleNameP :: ModuleName } deriving (Eq, Ord, Show, NFData) instance Display ModuleNameP where display = fromString . moduleNameString . unModuleNameP instance PersistField ModuleNameP where toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn fromPersistValue v = do str <- fromPersistValue v case parseModuleName str of Nothing -> Left $ "Invalid module name: " <> T.pack str Just pn -> Right $ ModuleNameP pn instance PersistFieldSql ModuleNameP where sqlType _ = SqlString -- | How to choose a cabal file for a package from Hackage. This is to -- work with Hackage cabal file revisions, which makes -- @PackageIdentifier@ insufficient for specifying a package from -- Hackage. -- -- @since 0.1.0.0 data CabalFileInfo = CFILatest -- ^ Take the latest revision of the cabal file available. This -- isn't reproducible at all, but the running assumption (not -- necessarily true) is that cabal file revisions do not change -- semantics of the build. -- -- @since 0.1.0.0 | CFIHash !SHA256 !(Maybe FileSize) -- ^ Identify by contents of the cabal file itself. Only reason for -- @Maybe@ on @FileSize@ is for compatibility with input that -- doesn't include the file size. -- -- @since 0.1.0.0 | CFIRevision !Revision -- ^ Identify by revision number, with 0 being the original and -- counting upward. This relies on Hackage providing consistent -- versioning. @CFIHash@ should be preferred wherever possible for -- reproducibility. -- -- @since 0.1.0.0 deriving (Generic, Show, Eq, Ord, Typeable) instance NFData CabalFileInfo instance Hashable CabalFileInfo instance Display CabalFileInfo where display CFILatest = mempty display (CFIHash hash' msize) = "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize display (CFIRevision rev) = "@rev:" <> display rev -- | A full specification for a package from Hackage, including the -- package name, version, and how to load up the correct cabal file -- revision. -- -- @since 0.1.0.0 data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo deriving (Generic, Eq, Ord, Typeable) instance NFData PackageIdentifierRevision instance Show PackageIdentifierRevision where show = T.unpack . utf8BuilderToText . display instance Display PackageIdentifierRevision where display (PackageIdentifierRevision name version cfi) = fromString (packageNameString name) <> "-" <> fromString (versionString version) <> display cfi instance ToJSON PackageIdentifierRevision where toJSON = toJSON . utf8BuilderToText . display instance FromJSON PackageIdentifierRevision where parseJSON = withText "PackageIdentifierRevision" $ \t -> case parsePackageIdentifierRevision t of Left e -> fail $ show e Right pir -> pure pir -- | Parse a hackage text. -- -- @since 0.1.0.0 parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) parseHackageText t = either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $ explicitEitherParsec (hackageTextParsec <* Parse.eof) $ T.unpack t hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey) hackageTextParsec = do ident <- packageIdentifierParsec _ <- Parse.string "@sha256:" shaT <- Parse.munch (/= ',') sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT _ <- Parse.char ',' size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't pure (ident, BlobKey sha (FileSize size')) splitColon :: Text -> Maybe (Text, Text) splitColon t' = let (x, y) = T.break (== ':') t' in (x, ) <$> T.stripPrefix ":" y -- | Parse a 'PackageIdentifierRevision' -- -- @since 0.1.0.0 parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision parsePackageIdentifierRevision t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do let (identT, cfiT) = T.break (== '@') t PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT cfi <- case splitColon cfiT of Just ("@sha256", shaSizeT) -> do let (shaT, sizeT) = T.break (== ',') shaSizeT sha <- either (const Nothing) Just $ SHA256.fromHexText shaT msize <- case T.stripPrefix "," sizeT of Nothing -> Just Nothing Just sizeT' -> case decimal sizeT' of Right (size', "") -> Just $ Just $ FileSize size' _ -> Nothing pure $ CFIHash sha msize Just ("@rev", revT) -> case decimal revT of Right (rev, "") -> pure $ CFIRevision $ Revision rev _ -> Nothing Nothing -> pure CFILatest _ -> Nothing pure $ PackageIdentifierRevision name version cfi data Mismatch a = Mismatch { mismatchExpected :: !a , mismatchActual :: !a } -- | Things that can go wrong in pantry. Note two things: -- -- * Many other exception types may be thrown from underlying -- libraries. Pantry does not attempt to wrap these underlying -- exceptions. -- -- * We may add more constructors to this data type in minor version -- bumps of pantry. This technically breaks the PVP. You should not -- be writing pattern matches against this type that expect total -- matching. -- -- @since 0.1.0.0 data PantryException = PackageIdentifierRevisionParseFail !Text | InvalidCabalFile !(Either RawPackageLocationImmutable (Path Abs File)) !(Maybe Version) ![PError] ![PWarning] | TreeWithoutCabalFile !RawPackageLocationImmutable | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath] | MismatchedCabalName !(Path Abs File) !PackageName | NoCabalFileFound !(Path Abs Dir) | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] | InvalidWantedCompiler !Text | InvalidSnapshotLocation !(Path Abs Dir) !Text | InvalidOverrideCompiler !WantedCompiler !WantedCompiler | InvalidFilePathSnapshot !Text | InvalidSnapshot !RawSnapshotLocation !SomeException | MismatchedPackageMetadata !RawPackageLocationImmutable !RawPackageMetadata !(Maybe TreeKey) !PackageIdentifier | Non200ResponseStatus !Status | InvalidBlobKey !(Mismatch BlobKey) | Couldn'tParseSnapshot !RawSnapshotLocation !String | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName | DownloadInvalidSHA256 !Text !(Mismatch SHA256) | DownloadInvalidSize !Text !(Mismatch FileSize) | DownloadTooLarge !Text !(Mismatch FileSize) -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is -- a lower bound on the size from the server. | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) | UnknownArchiveType !ArchiveLocation | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType | UnsupportedTarball !ArchiveLocation !Text | NoHackageCryptographicHash !PackageIdentifier | FailedToCloneRepo !Repo | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults | CannotCompleteRepoNonSHA1 !Repo | MutablePackageLocationFromUrl !Text | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) | PackageNameParseFail !Text | PackageVersionParseFail !Text | InvalidCabalFilePath !(Path Abs File) | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])] | MigrationFailure !Text !(Path Abs File) !SomeException | InvalidTreeFromCasa !BlobKey !ByteString deriving Typeable instance Exception PantryException where instance Show PantryException where show = T.unpack . utf8BuilderToText . display instance Display PantryException where display (InvalidTreeFromCasa blobKey _bs) = "Invalid tree from casa: " <> display blobKey display (PackageIdentifierRevisionParseFail text) = "Invalid package identifier (with optional revision): " <> display text display (InvalidCabalFile loc mversion errs warnings) = "Unable to parse cabal file from package " <> either display (fromString . toFilePath) loc <> "\n\n" <> foldMap (\(PError pos msg) -> "- " <> fromString (showPos pos) <> ": " <> fromString msg <> "\n") errs <> foldMap (\(PWarning _ pos msg) -> "- " <> fromString (showPos pos) <> ": " <> fromString msg <> "\n") warnings <> (case mversion of Just version | version > cabalSpecLatestVersion -> "\n\nThe cabal file uses the cabal specification version " <> fromString (versionString version) <> ", but we only support up to version " <> fromString (versionString cabalSpecLatestVersion) <> ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)." _ -> mempty) display (TreeWithoutCabalFile pl) = "No cabal file found for " <> display pl display (TreeWithMultipleCabalFiles pl sfps) = "Multiple cabal files found for " <> display pl <> ": " <> fold (intersperse ", " (map display sfps)) display (MismatchedCabalName fp name) = "cabal file path " <> fromString (toFilePath fp) <> " does not match the package name it defines.\n" <> "Please rename the file to: " <> fromString (packageNameString name) <> ".cabal\n" <> "For more information, see: https://github.com/commercialhaskell/stack/issues/317" display (NoCabalFileFound dir) = "Stack looks for packages in the directories configured in\n" <> "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" <> "The current entry points to " <> fromString (toFilePath dir) <> ",\nbut no .cabal or package.yaml file could be found there." display (MultipleCabalFilesFound dir files) = "Multiple .cabal files found in directory " <> fromString (toFilePath dir) <> ":\n" <> fold (intersperse "\n" (map (\x -> "- " <> fromString (toFilePath (filename x))) files)) display (InvalidWantedCompiler t) = "Invalid wanted compiler: " <> display t display (InvalidSnapshotLocation dir t) = "Invalid snapshot location " <> displayShow t <> " relative to directory " <> displayShow (toFilePath dir) display (InvalidOverrideCompiler x y) = "Specified compiler for a resolver (" <> display x <> "), but also specified an override compiler (" <> display y <> ")" display (InvalidFilePathSnapshot t) = "Specified snapshot as file path with " <> displayShow t <> ", but not reading from a local file" display (InvalidSnapshot loc e) = "Exception while reading snapshot from " <> display loc <> ":\n" <> displayShow e display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = "Mismatched package metadata for " <> display loc <> "\nFound: " <> fromString (packageIdentifierString foundIdent) <> (case mtreeKey of Nothing -> mempty Just treeKey -> " with tree " <> display treeKey) <> "\nExpected: " <> display pm display (Non200ResponseStatus status) = "Unexpected non-200 HTTP status code: " <> displayShow (statusCode status) display (InvalidBlobKey Mismatch{..}) = "Invalid blob key found, expected: " <> display mismatchExpected <> ", actual: " <> display mismatchActual display (Couldn'tParseSnapshot sl e) = "Couldn't parse snapshot from " <> display sl <> ": " <> fromString e display (WrongCabalFileName pl sfp name) = "Wrong cabal file name for package " <> display pl <> "\nCabal file is named " <> display sfp <> ", but package name is " <> fromString (packageNameString name) <> "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" display (DownloadInvalidSHA256 url Mismatch {..}) = "Mismatched SHA256 hash from " <> display url <> "\nExpected: " <> display mismatchExpected <> "\nActual: " <> display mismatchActual display (DownloadInvalidSize url Mismatch {..}) = "Mismatched download size from " <> display url <> "\nExpected: " <> display mismatchExpected <> "\nActual: " <> display mismatchActual display (DownloadTooLarge url Mismatch {..}) = "Download from " <> display url <> " was too large.\n" <> "Expected: " <> display mismatchExpected <> ", stopped after receiving: " <> display mismatchActual display (LocalInvalidSHA256 path Mismatch {..}) = "Mismatched SHA256 hash from " <> fromString (toFilePath path) <> "\nExpected: " <> display mismatchExpected <> "\nActual: " <> display mismatchActual display (LocalInvalidSize path Mismatch {..}) = "Mismatched file size from " <> fromString (toFilePath path) <> "\nExpected: " <> display mismatchExpected <> "\nActual: " <> display mismatchActual display (UnknownArchiveType loc) = "Unable to determine archive type of: " <> display loc display (InvalidTarFileType loc fp x) = "Unsupported tar filetype in archive " <> display loc <> " at file " <> fromString fp <> ": " <> displayShow x display (UnsupportedTarball loc e) = "Unsupported tarball from " <> display loc <> ": " <> display e display (NoHackageCryptographicHash ident) = "Not cryptographic hash found for Hackage package " <> fromString (packageIdentifierString ident) display (FailedToCloneRepo repo) = "Failed to clone repo " <> display repo display (TreeReferencesMissingBlob loc sfp key) = "The package " <> display loc <> " needs blob " <> display key <> " for file path " <> display sfp <> ", but the blob is not available" display (CompletePackageMetadataMismatch loc pm) = "When completing package metadata for " <> display loc <> ", some values changed in the new package metadata: " <> display pm display (CRC32Mismatch loc fp Mismatch {..}) = "CRC32 mismatch in ZIP file from " <> display loc <> " on internal file " <> fromString fp <> "\n.Expected: " <> display mismatchExpected <> "\n.Actual: " <> display mismatchActual display (UnknownHackagePackage pir fuzzy) = "Could not find " <> display pir <> " on Hackage" <> displayFuzzy fuzzy display (CannotCompleteRepoNonSHA1 repo) = "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " <> display repo display (MutablePackageLocationFromUrl t) = "Cannot refer to a mutable package location from a URL: " <> display t display (MismatchedCabalFileForHackage pir Mismatch{..}) = "When processing cabal file for Hackage package " <> display pir <> ":\nMismatched package identifier." <> "\nExpected: " <> fromString (packageIdentifierString mismatchExpected) <> "\nActual: " <> fromString (packageIdentifierString mismatchActual) display (PackageNameParseFail t) = "Invalid package name: " <> display t display (PackageVersionParseFail t) = "Invalid version: " <> display t display (InvalidCabalFilePath fp) = "File path contains a name which is not a valid package name: " <> fromString (toFilePath fp) display (DuplicatePackageNames source pairs') = "Duplicate package names (" <> source <> "):\n" <> foldMap (\(name, locs) -> fromString (packageNameString name) <> ":\n" <> foldMap (\loc -> "- " <> display loc <> "\n") locs ) pairs' display (MigrationFailure desc fp ex) = "Encountered error while migrating " <> display desc <> " database:" <> "\n " <> displayShow ex <> "\nPlease report this on https://github.com/commercialhaskell/stack/issues" <> "\nAs a workaround you may delete " <> display desc <> " database in " <> fromString (toFilePath fp) <> " triggering its recreation." data FuzzyResults = FRNameNotFound ![PackageName] | FRVersionNotFound !(NonEmpty PackageIdentifierRevision) | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) displayFuzzy :: FuzzyResults -> Utf8Builder displayFuzzy (FRNameNotFound names) = case NE.nonEmpty names of Nothing -> "" Just names' -> "\nPerhaps you meant " <> orSeparated (NE.map (fromString . packageNameString) names') <> "?" displayFuzzy (FRVersionNotFound pirs) = "\nPossible candidates: " <> commaSeparated (NE.map display pirs) <> "." displayFuzzy (FRRevisionNotFound pirs) = "\nThe specified revision was not found.\nPossible candidates: " <> commaSeparated (NE.map display pirs) <> "." orSeparated :: NonEmpty Utf8Builder -> Utf8Builder orSeparated xs | NE.length xs == 1 = NE.head xs | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder commaSeparated = fold . NE.intersperse ", " -- You'd really think there'd be a better way to do this in Cabal. cabalSpecLatestVersion :: Version cabalSpecLatestVersion = case cabalSpecLatest of CabalSpecV1_0 -> error "this cannot happen" CabalSpecV1_2 -> error "this cannot happen" CabalSpecV1_4 -> error "this cannot happen" CabalSpecV1_6 -> error "this cannot happen" CabalSpecV1_8 -> error "this cannot happen" CabalSpecV1_10 -> error "this cannot happen" CabalSpecV1_12 -> error "this cannot happen" CabalSpecV1_18 -> error "this cannot happen" CabalSpecV1_20 -> error "this cannot happen" CabalSpecV1_22 -> error "this cannot happen" CabalSpecV1_24 -> error "this cannot happen" CabalSpecV2_0 -> error "this cannot happen" CabalSpecV2_2 -> error "this cannot happen" CabalSpecV2_4 -> error "this cannot happen" CabalSpecV3_0 -> mkVersion [3, 0] data BuildFile = BFCabal !SafeFilePath !TreeEntry | BFHpack !TreeEntry -- We don't need SafeFilePath for Hpack since it has to be package.yaml file deriving (Show, Eq) data FileType = FTNormal | FTExecutable deriving (Show, Eq, Enum, Bounded) instance PersistField FileType where toPersistValue FTNormal = PersistInt64 1 toPersistValue FTExecutable = PersistInt64 2 fromPersistValue v = do i <- fromPersistValue v case i :: Int64 of 1 -> Right FTNormal 2 -> Right FTExecutable _ -> Left $ "Invalid FileType: " <> tshow i instance PersistFieldSql FileType where sqlType _ = SqlInt32 data TreeEntry = TreeEntry { teBlob :: !BlobKey , teType :: !FileType } deriving (Show, Eq) newtype SafeFilePath = SafeFilePath Text deriving (Show, Eq, Ord, Display) instance PersistField SafeFilePath where toPersistValue = toPersistValue . unSafeFilePath fromPersistValue v = do t <- fromPersistValue v maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t instance PersistFieldSql SafeFilePath where sqlType _ = SqlString unSafeFilePath :: SafeFilePath -> Text unSafeFilePath (SafeFilePath t) = t safeFilePathtoPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File) safeFilePathtoPath dir (SafeFilePath path) = do fpath <- parseRelFile (T.unpack path) return $ dir fpath mkSafeFilePath :: Text -> Maybe SafeFilePath mkSafeFilePath t = do guard $ not $ "\\" `T.isInfixOf` t guard $ not $ "//" `T.isInfixOf` t guard $ not $ "\n" `T.isInfixOf` t guard $ not $ "\0" `T.isInfixOf` t (c, _) <- T.uncons t guard $ c /= '/' guard $ all (not . T.all (== '.')) $ T.split (== '/') t Just $ SafeFilePath t -- | SafeFilePath for `package.yaml` file. hpackSafeFilePath :: SafeFilePath hpackSafeFilePath = let fpath = mkSafeFilePath (T.pack Hpack.packageConfig) in case fpath of Nothing -> error $ "hpackSafeFilePath: Not able to encode " <> (Hpack.packageConfig) Just sfp -> sfp -- | The hash of the binary representation of a 'Tree'. -- -- @since 0.1.0.0 newtype TreeKey = TreeKey BlobKey deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display) -- | Represents the contents of a tree, which is a mapping from -- relative file paths to 'TreeEntry's. -- -- @since 0.1.0.0 newtype Tree = TreeMap (Map SafeFilePath TreeEntry) -- In the future, consider allowing more lax parsing -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys -- TreeTarball !PackageTarball deriving (Show, Eq) renderTree :: Tree -> ByteString renderTree = BL.toStrict . toLazyByteString . go where go :: Tree -> Builder go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = netstring (unSafeFilePath sfp) <> byteString (SHA256.toRaw sha) <> netword size' <> (case ft of FTNormal -> "N" FTExecutable -> "X") netstring :: Text -> Builder netstring t = let bs = encodeUtf8 t in netword (fromIntegral (B.length bs)) <> byteString bs netword :: Word -> Builder netword w = wordDec w <> ":" parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree) parseTreeM (blobKey, blob) = case parseTree blob of Nothing -> throwM (InvalidTreeFromCasa blobKey blob) Just tree -> pure (TreeKey blobKey, tree) parseTree :: ByteString -> Maybe Tree parseTree bs1 = do tree <- parseTree' bs1 let bs2 = renderTree tree guard $ bs1 == bs2 Just tree parseTree' :: ByteString -> Maybe Tree parseTree' bs0 = do entriesBS <- B.stripPrefix "map:" bs0 TreeMap <$> loop Map.empty entriesBS where loop !m bs1 | B.null bs1 = pure m | otherwise = do (sfpBS, bs2) <- takeNetstring bs1 sfp <- case decodeUtf8' sfpBS of Left _ -> Nothing Right sfpT -> mkSafeFilePath sfpT (sha, bs3) <- takeSha bs2 (size', bs4) <- takeNetword bs3 (typeW, bs5) <- B.uncons bs4 ft <- case typeW of 78 -> Just FTNormal -- 'N' 88 -> Just FTExecutable -- 'X' _ -> Nothing let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft loop (Map.insert sfp entry m) bs5 takeNetstring bs1 = do (size', bs2) <- takeNetword bs1 guard $ B.length bs2 >= size' Just $ B.splitAt size' bs2 takeSha bs = do let (x, y) = B.splitAt 32 bs x' <- either (const Nothing) Just (SHA256.fromRaw x) Just (x', y) takeNetword = go 0 where go !accum bs = do (next, rest) <- B.uncons bs if | next == 58 -> pure (accum, rest) -- ':' | next >= 48 && next <= 57 -> go (accum * 10 + fromIntegral (next - 48)) rest | otherwise -> Nothing {- data PackageTarball = PackageTarball { ptBlob :: !BlobKey -- ^ Contains the tarball itself , ptCabal :: !BlobKey -- ^ Contains the cabal file contents , ptSubdir :: !FilePath -- ^ Subdir containing the files we want for this package. -- -- There must be precisely one file with a @.cabal@ file extension -- located there. Thanks to Hackage revisions, its contents will be -- overwritten by the value of @ptCabal@. } deriving Show -} -- | This is almost a copy of Cabal's parser for package identifiers, -- the main difference is in the fact that Stack requires version to be -- present while Cabal uses "null version" as a default value -- -- @since 0.1.0.0 parsePackageIdentifier :: String -> Maybe PackageIdentifier parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof) packageIdentifierParsec :: ParsecParser PackageIdentifier packageIdentifierParsec = do ident@(PackageIdentifier _ v) <- parsec -- version is a required component of a package identifier for Stack guard (v /= nullVersion) pure ident -- | Parse a package name from a 'String'. -- -- @since 0.1.0.0 parsePackageName :: String -> Maybe PackageName parsePackageName = Distribution.Text.simpleParse -- | Parse a package name from a 'String' throwing on failure -- -- @since 0.1.0.0 parsePackageNameThrowing :: MonadThrow m => String -> m PackageName parsePackageNameThrowing str = case parsePackageName str of Nothing -> throwM $ PackageNameParseFail $ T.pack str Just pn -> pure pn -- | Parse a version from a 'String'. -- -- @since 0.1.0.0 parseVersion :: String -> Maybe Version parseVersion = Distribution.Text.simpleParse -- | Parse a package version from a 'String' throwing on failure -- -- @since 0.1.0.0 parseVersionThrowing :: MonadThrow m => String -> m Version parseVersionThrowing str = case parseVersion str of Nothing -> throwM $ PackageVersionParseFail $ T.pack str Just v -> pure v -- | Parse a version range from a 'String'. -- -- @since 0.1.0.0 parseVersionRange :: String -> Maybe VersionRange parseVersionRange = Distribution.Text.simpleParse -- | Parse a module name from a 'String'. -- -- @since 0.1.0.0 parseModuleName :: String -> Maybe ModuleName parseModuleName = Distribution.Text.simpleParse -- | Parse a flag name from a 'String'. -- -- @since 0.1.0.0 parseFlagName :: String -> Maybe FlagName parseFlagName = Distribution.Text.simpleParse -- | Render a package name as a 'String'. -- -- @since 0.1.0.0 packageNameString :: PackageName -> String packageNameString = unPackageName -- | Render a package identifier as a 'String'. -- -- @since 0.1.0.0 packageIdentifierString :: PackageIdentifier -> String packageIdentifierString = Distribution.Text.display -- | Render a version as a 'String'. -- -- @since 0.1.0.0 versionString :: Version -> String versionString = Distribution.Text.display -- | Render a flag name as a 'String'. -- -- @since 0.1.0.0 flagNameString :: FlagName -> String flagNameString = unFlagName -- | Render a module name as a 'String'. -- -- @since 0.1.0.0 moduleNameString :: ModuleName -> String moduleNameString = Distribution.Text.display data OptionalSubdirs = OSSubdirs !(NonEmpty Text) | OSPackageMetadata !Text !RawPackageMetadata -- ^ subdirectory and package metadata deriving (Show, Eq, Generic) instance NFData OptionalSubdirs -- | Metadata provided by a config file for archives and repos. This -- information can be used for optimized lookups of information like -- package identifiers, or for validating that the user configuration -- has the expected information. -- -- @since 0.1.0.0 data RawPackageMetadata = RawPackageMetadata { rpmName :: !(Maybe PackageName) -- ^ Package name in the cabal file -- -- @since 0.1.0.0 , rpmVersion :: !(Maybe Version) -- ^ Package version in the cabal file -- -- @since 0.1.0.0 , rpmTreeKey :: !(Maybe TreeKey) -- ^ Tree key of the loaded up package -- -- @since 0.1.0.0 } deriving (Show, Eq, Ord, Generic, Typeable) instance NFData RawPackageMetadata instance Display RawPackageMetadata where display rpm = fold $ intersperse ", " $ catMaybes [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm ] -- | Exact metadata specifying concrete package -- -- @since 0.1.0.0 data PackageMetadata = PackageMetadata { pmIdent :: !PackageIdentifier -- ^ Package identifier in the cabal file -- -- @since 0.1.0.0 , pmTreeKey :: !TreeKey -- ^ Tree key of the loaded up package -- -- @since 0.1.0.0 } deriving (Show, Eq, Ord, Generic, Typeable) -- i PackageMetadata instance NFData PackageMetadata instance Display PackageMetadata where display pm = fold $ intersperse ", " $ [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) , "tree == " <> display (pmTreeKey pm) ] parsePackageMetadata :: Object -> WarningParser PackageMetadata parsePackageMetadata o = do _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file" pantryTree :: BlobKey <- o ..: "pantry-tree" CabalString pkgName <- o ..: "name" CabalString pkgVersion <- o ..: "version" let pmTreeKey = TreeKey pantryTree pmIdent = PackageIdentifier {..} pure PackageMetadata {..} -- | Conver package metadata to its "raw" equivalent. -- -- @since 0.1.0.0 toRawPM :: PackageMetadata -> RawPackageMetadata toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) where PackageIdentifier name version = pmIdent pm -- | File path relative to the configuration file it was parsed from -- -- @since 0.1.0.0 newtype RelFilePath = RelFilePath Text deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display) -- | Location that an archive is stored at -- -- @since 0.1.0.0 data ArchiveLocation = ALUrl !Text -- ^ Archive stored at an HTTP(S) URL -- -- @since 0.1.0.0 | ALFilePath !(ResolvedPath File) -- ^ Archive stored at a local file path -- -- @since 0.1.0.0 deriving (Show, Eq, Ord, Generic, Typeable) instance NFData ArchiveLocation instance Display ArchiveLocation where display (ALUrl url) = display url display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation) parseArchiveLocationObject o = ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl) <|> ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath) <|> ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText) <|> ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText) parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation) parseArchiveLocationText t = case validateUrl t of Left e1 -> case validateFilePath t of Left e2 -> Left $ T.unlines [ "Invalid archive location, neither a URL nor a file path" , " URL error: " <> e1 , " File path error: " <> e2 ] Right x -> Right x Right x -> Right x validateUrl :: Text -> Either Text (Unresolved ArchiveLocation) validateUrl t = case parseRequest $ T.unpack t of Left _ -> Left $ "Could not parse URL: " <> t Right _ -> pure $ pure $ ALUrl t validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation) validateFilePath t = if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") then pure $ Unresolved $ \mdir -> case mdir of Nothing -> throwIO $ InvalidFilePathSnapshot t Just dir -> do abs' <- resolveFile dir $ T.unpack t pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' else Left $ "Does not have an archive file extension: " <> t instance ToJSON RawPackageLocation where toJSON (RPLImmutable rpli) = toJSON rpli toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where parseJSON v = ((fmap.fmap.fmap.fmap) RPLImmutable (parseJSON v)) <|> ((noJSONWarnings . mkMutable) <$> parseJSON v) where mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation) mkMutable t = Unresolved $ \mdir -> do case mdir of Nothing -> throwIO $ MutablePackageLocationFromUrl t Just dir -> do abs' <- resolveDir dir $ T.unpack t pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' instance ToJSON RawPackageLocationImmutable where toJSON (RPLIHackage pir mtree) = object $ concat [ ["hackage" .= pir] , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree ] toJSON (RPLIArchive (RawArchive loc msha msize subdir) rpm) = object $ concat [ case loc of ALUrl url -> ["url" .= url] ALFilePath resolved -> ["filepath" .= resolvedRelative resolved] , maybe [] (\sha -> ["sha256" .= sha]) msha , maybe [] (\size' -> ["size" .= size']) msize , if T.null subdir then [] else ["subdir" .= subdir] , rpmToPairs rpm ] toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat [ [ urlKey .= url , "commit" .= commit ] , if T.null subdir then [] else ["subdir" .= subdir] , rpmToPairs rpm ] where urlKey = case typ of RepoGit -> "git" RepoHg -> "hg" rpmToPairs :: RawPackageMetadata -> [(Text, Value)] rpmToPairs (RawPackageMetadata mname mversion mtree) = concat [ maybe [] (\name -> ["name" .= CabalString name]) mname , maybe [] (\version -> ["version" .= CabalString version]) mversion , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree ] instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do pm <- parsePackageMetadata o repoSubdir <- o ..:? "subdir" ..!= "" repoCommit <- o ..: "commit" (repoType, repoUrl) <- (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> (o ..: "hg" >>= \url -> pure (RepoHg, url)) pure $ pure $ PLIRepo Repo {..} pm archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do pm <- parsePackageMetadata o Unresolved mkArchiveLocation <- parseArchiveLocationObject o archiveHash <- o ..: "sha256" archiveSize <- o ..: "size" archiveSubdir <- o ..:? "subdir" ..!= "" pure $ Unresolved $ \mdir -> do archiveLocation <- mkArchiveLocation mdir pure $ PLIArchive Archive {..} pm hackageObject = withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do treeKey <- o ..: "pantry-tree" htxt <- o ..: "hackage" case parseHackageText htxt of Left e -> fail $ show e Right (pkgIdentifier, blobKey) -> pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) github value = withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do pm <- parsePackageMetadata o GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" let archiveLocation = ALUrl $ T.concat [ "https://github.com/" , ghRepo , "/archive/" , commit , ".tar.gz" ] archiveHash <- o ..: "sha256" archiveSize <- o ..: "size" archiveSubdir <- o ..:? "subdir" ..!= "" pure $ pure $ PLIArchive Archive {..} pm) value instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where parseJSON v = http v <|> hackageText v <|> hackageObject v <|> repo v <|> archiveObject v <|> github v <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) where http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> case parseArchiveLocationText t of Left _ -> fail $ "Invalid archive location: " ++ T.unpack t Right (Unresolved mkArchiveLocation) -> pure $ noJSONWarnings $ Unresolved $ \mdir -> do raLocation <- mkArchiveLocation mdir let raHash = Nothing raSize = Nothing raSubdir = T.empty pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> case parsePackageIdentifierRevision t of Left e -> fail $ show e Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> (pure.pure) <$> (RPLIHackage <$> o ..: "hackage" <*> o ..:? "pantry-tree") optionalSubdirs :: Object -> WarningParser OptionalSubdirs optionalSubdirs o = -- if subdirs exists, it needs to be valid case HM.lookup "subdirs" o of Just v' -> do tellJSONField "subdirs" subdirs <- lift $ parseJSON v' case NE.nonEmpty subdirs of Nothing -> fail "Invalid empty subdirs" Just x -> pure $ OSSubdirs x Nothing -> OSPackageMetadata <$> o ..:? "subdir" ..!= T.empty <*> (rawPackageMetadataHelper <$> (fmap unCabalString <$> (o ..:? "name")) <*> (fmap unCabalString <$> (o ..:? "version")) <*> o ..:? "pantry-tree" <*> o ..:? "cabal-file") rawPackageMetadataHelper :: Maybe PackageName -> Maybe Version -> Maybe TreeKey -> Maybe BlobKey -> RawPackageMetadata rawPackageMetadataHelper name version pantryTree _ignoredCabalFile = RawPackageMetadata name version pantryTree repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do (repoType, repoUrl) <- ((RepoGit, ) <$> o ..: "git") <|> ((RepoHg, ) <$> o ..: "hg") repoCommit <- o ..: "commit" os <- optionalSubdirs o pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do Unresolved mkArchiveLocation <- parseArchiveLocationObject o raHash <- o ..:? "sha256" raSize <- o ..:? "size" os <- optionalSubdirs o pure $ Unresolved $ \mdir -> do raLocation <- mkArchiveLocation mdir pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" let raLocation = ALUrl $ T.concat [ "https://github.com/" , ghRepo , "/archive/" , commit , ".tar.gz" ] raHash <- o ..:? "sha256" raSize <- o ..:? "size" os <- optionalSubdirs o pure $ pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) -- | Returns pairs of subdirectory and 'PackageMetadata'. osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata) osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) rpmEmpty :: RawPackageMetadata rpmEmpty = RawPackageMetadata Nothing Nothing Nothing -- | Newtype wrapper for easier JSON integration with Cabal types. -- -- @since 0.1.0.0 newtype CabalString a = CabalString { unCabalString :: a } deriving (Show, Eq, Ord, Typeable) -- I'd like to use coerce here, but can't due to roles. unsafeCoerce -- could work, but let's avoid unsafe code. -- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' -- instance. -- -- @since 0.1.0.0 toCabalStringMap :: Map a v -> Map (CabalString a) v toCabalStringMap = Map.mapKeysMonotonic CabalString -- | Unwrap the 'CabalString' from the keys in a 'Map' to use a -- 'FromJSON' instance. -- -- @since 0.1.0.0 unCabalStringMap :: Map (CabalString a) v -> Map a v unCabalStringMap = Map.mapKeysMonotonic unCabalString instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where toJSON = toJSON . Distribution.Text.display . unCabalString instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString instance forall a. IsCabalString a => FromJSON (CabalString a) where parseJSON = withText name $ \t -> case cabalStringParser $ T.unpack t of Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t Just x -> pure $ CabalString x where name = cabalStringName (Nothing :: Maybe a) instance forall a. IsCabalString a => FromJSONKey (CabalString a) where fromJSONKey = FromJSONKeyTextParser $ \t -> case cabalStringParser $ T.unpack t of Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t Just x -> pure $ CabalString x where name = cabalStringName (Nothing :: Maybe a) class IsCabalString a where cabalStringName :: proxy a -> String cabalStringParser :: String -> Maybe a instance IsCabalString PackageName where cabalStringName _ = "package name" cabalStringParser = parsePackageName instance IsCabalString Version where cabalStringName _ = "version" cabalStringParser = parseVersion instance IsCabalString VersionRange where cabalStringName _ = "version range" cabalStringParser = parseVersionRange instance IsCabalString PackageIdentifier where cabalStringName _ = "package identifier" cabalStringParser = parsePackageIdentifier instance IsCabalString FlagName where cabalStringName _ = "flag name" cabalStringParser = parseFlagName -- | What to use for running hpack -- -- @since 0.1.0.0 data HpackExecutable = HpackBundled -- ^ Compiled in library | HpackCommand !FilePath -- ^ Executable at the provided path deriving (Show, Read, Eq, Ord) -- | Which compiler a snapshot wants to use. The build tool may elect -- to do some fuzzy matching of versions (e.g., allowing different -- patch versions). -- -- @since 0.1.0.0 data WantedCompiler = WCGhc !Version | WCGhcGit !Text !Text | WCGhcjs !Version !Version -- ^ GHCJS version followed by GHC version deriving (Show, Eq, Ord, Generic) instance NFData WantedCompiler instance Display WantedCompiler where display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) display (WCGhcjs vghcjs vghc) = "ghcjs-" <> fromString (versionString vghcjs) <> "_ghc-" <> fromString (versionString vghc) display (WCGhcGit commit flavour) = "ghc-git-" <> display commit <> "-" <> display flavour instance ToJSON WantedCompiler where toJSON = toJSON . utf8BuilderToText . display instance FromJSON WantedCompiler where parseJSON = withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler instance FromJSONKey WantedCompiler where fromJSONKey = FromJSONKeyTextParser $ \t -> case parseWantedCompiler t of Left e -> fail $ "Invalid WantedComiler " ++ show t ++ ": " ++ show e Right x -> pure x -- | Parse a 'Text' into a 'WantedCompiler' value. -- -- @since 0.1.0.0 parseWantedCompiler :: Text -> Either PantryException WantedCompiler parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ case T.stripPrefix "ghcjs-" t0 of Just t1 -> parseGhcjs t1 Nothing -> case T.stripPrefix "ghc-git-" t0 of Just t1 -> parseGhcGit t1 Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc where parseGhcjs t1 = do let (ghcjsVT, t2) = T.break (== '_') t1 ghcjsV <- parseVersion $ T.unpack ghcjsVT ghcVT <- T.stripPrefix "_ghc-" t2 ghcV <- parseVersion $ T.unpack ghcVT pure $ WCGhcjs ghcjsV ghcV parseGhcGit t1 = do let (commit, flavour) = T.break (== '-') t1 pure $ WCGhcGit commit (T.drop 1 flavour) parseGhc = fmap WCGhc . parseVersion . T.unpack instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where parseJSON v = text v <|> obj v where text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) text = withText "UnresolvedSnapshotLocation (Text)" $ pure . noJSONWarnings . parseRawSnapshotLocation obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> ((pure . RSLCompiler) <$> o ..: "compiler") <|> ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|> (parseRawSnapshotLocationPath <$> o ..: "filepath") blobKey o = do msha <- o ..:? "sha256" msize <- o ..:? "size" case (msha, msize) of (Nothing, Nothing) -> pure Nothing (Just sha, Just size') -> pure $ Just $ BlobKey sha size' (Just _sha, Nothing) -> fail "You must also specify the file size" (Nothing, Just _) -> fail "You must also specify the file's SHA256" instance Display SnapshotLocation where display (SLCompiler compiler) = display compiler display (SLUrl url blob) = fromMaybe (display url) (specialRawSnapshotLocation url) <> " (" <> display blob <> ")" display (SLFilePath resolved) = display (resolvedRelative resolved) -- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. -- -- @since 0.1.0.0 parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ (either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0)) <|> parseLts <|> parseNightly <|> parseGithub <|> parseUrl where parseLts = do t1 <- T.stripPrefix "lts-" t0 Right (x, t2) <- Just $ decimal t1 t3 <- T.stripPrefix "." t2 Right (y, "") <- Just $ decimal t3 Just $ pure $ ltsSnapshotLocation x y parseNightly = do t1 <- T.stripPrefix "nightly-" t0 date <- readMaybe (T.unpack t1) Just $ pure $ nightlySnapshotLocation date parseGithub = do t1 <- T.stripPrefix "github:" t0 let (user, t2) = T.break (== '/') t1 t3 <- T.stripPrefix "/" t2 let (repo, t4) = T.break (== ':') t3 path <- T.stripPrefix ":" t4 Just $ pure $ githubSnapshotLocation user repo path parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation parseRawSnapshotLocationPath t = Unresolved $ \mdir -> case mdir of Nothing -> throwIO $ InvalidFilePathSnapshot t Just dir -> do abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation githubSnapshotLocation user repo path = let url = T.concat [ "https://raw.githubusercontent.com/" , user , "/" , repo , "/master/" , path ] in RSLUrl url Nothing defUser :: Text defUser = "commercialhaskell" defRepo :: Text defRepo = "stackage-snapshots" -- | Location of an LTS snapshot -- -- @since 0.1.0.0 ltsSnapshotLocation :: Int -- ^ major version -> Int -- ^ minor version -> RawSnapshotLocation ltsSnapshotLocation x y = githubSnapshotLocation defUser defRepo $ utf8BuilderToText $ "lts/" <> display x <> "/" <> display y <> ".yaml" -- | Location of a Stackage Nightly snapshot -- -- @since 0.1.0.0 nightlySnapshotLocation :: Day -> RawSnapshotLocation nightlySnapshotLocation date = githubSnapshotLocation defUser defRepo $ utf8BuilderToText $ "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml" where (year, month, day) = toGregorian date -- | Where to load a snapshot from in raw form -- (RSUrl could have a missing BlobKey) -- -- @since 0.1.0.0 data RawSnapshotLocation = RSLCompiler !WantedCompiler -- ^ Don't use an actual snapshot, just a version of the compiler -- with its shipped packages. -- -- @since 0.1.0.0 | RSLUrl !Text !(Maybe BlobKey) -- ^ Download the snapshot from the given URL. The optional -- 'BlobKey' is used for reproducibility. -- -- @since 0.1.0.0 | RSLFilePath !(ResolvedPath File) -- ^ Snapshot at a local file path. -- -- @since 0.1.0.0 deriving (Show, Eq, Ord, Generic) instance NFData RawSnapshotLocation instance Display RawSnapshotLocation where display (RSLCompiler compiler) = display compiler display (RSLUrl url Nothing) = fromMaybe (display url) $ specialRawSnapshotLocation url display (RSLUrl url (Just blob)) = fromMaybe (display url) (specialRawSnapshotLocation url) <> " (" <> display blob <> ")" display (RSLFilePath resolved) = display (resolvedRelative resolved) -- | For nicer display purposes: present a 'RawSnapshotLocation' as a -- short form like lts-13.13 if possible. specialRawSnapshotLocation :: Text -> Maybe Utf8Builder specialRawSnapshotLocation url = do t1 <- T.stripPrefix "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" url parseLTS t1 <|> parseNightly t1 where popInt :: Text -> Maybe (Int, Text) popInt t0 = -- Would be nice if this function did overflow checking for us case decimal t0 of Left _ -> Nothing Right (x, rest) -> (, rest) <$> do if (x :: Integer) > fromIntegral (maxBound :: Int) then Nothing else Just (fromIntegral x) parseLTS t1 = do t2 <- T.stripPrefix "lts/" t1 (major, t3) <- popInt t2 (minor, ".yaml") <- T.stripPrefix "/" t3 >>= popInt Just $ "lts-" <> display major <> "." <> display minor parseNightly t1 = do t2 <- T.stripPrefix "nightly/" t1 (year, t3) <- popInt t2 (month, t4) <- T.stripPrefix "/" t3 >>= popInt (day, ".yaml") <- T.stripPrefix "/" t4 >>= popInt date <- fromGregorianValid (fromIntegral year) month day Just $ "nightly-" <> displayShow date instance ToJSON RawSnapshotLocation where toJSON (RSLCompiler compiler) = object ["compiler" .= compiler] toJSON (RSLUrl url Nothing) | Just x <- specialRawSnapshotLocation url = String $ utf8BuilderToText x toJSON (RSLUrl url mblob) = object $ "url" .= url : maybe [] blobKeyPairs mblob toJSON (RSLFilePath resolved) = object ["filepath" .= resolvedRelative resolved] -- | Where to load a snapshot from. -- -- @since 0.1.0.0 data SnapshotLocation = SLCompiler !WantedCompiler -- ^ Don't use an actual snapshot, just a version of the compiler -- with its shipped packages. -- -- @since 0.1.0.0 | SLUrl !Text !BlobKey -- ^ Download the snapshot from the given URL. The optional -- 'BlobKey' is used for reproducibility. -- -- @since 0.1.0.0 | SLFilePath !(ResolvedPath File) -- ^ Snapshot at a local file path. -- -- @since 0.1.0.0 deriving (Show, Eq, Ord, Generic) instance NFData SnapshotLocation instance ToJSON SnapshotLocation where toJSON sl = toJSON (toRawSL sl) instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where parseJSON v = file v <|> url v <|> compiler v where file = withObjectWarnings "SLFilepath" $ \o -> do ufp <- o ..: "filepath" pure $ Unresolved $ \mdir -> case mdir of Nothing -> throwIO $ InvalidFilePathSnapshot ufp Just dir -> do absolute <- resolveFile dir (T.unpack ufp) let fp = ResolvedPath (RelFilePath ufp) absolute pure $ SLFilePath fp url = withObjectWarnings "SLUrl" $ \o -> do url' <- o ..: "url" sha <- o ..: "sha256" size <- o ..: "size" pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size) compiler = withObjectWarnings "SLCompiler" $ \o -> do c <- o ..: "compiler" pure $ Unresolved $ \_ -> pure $ SLCompiler c -- | Convert snapshot location to its "raw" equivalent. -- -- @since 0.1.0.0 toRawSL :: SnapshotLocation -> RawSnapshotLocation toRawSL (SLCompiler c) = RSLCompiler c toRawSL (SLUrl url blob) = RSLUrl url (Just blob) toRawSL (SLFilePath fp) = RSLFilePath fp -- | A flattened representation of all the layers in a snapshot. -- -- @since 0.1.0.0 data RawSnapshot = RawSnapshot { rsCompiler :: !WantedCompiler -- ^ The compiler wanted for this snapshot. , rsPackages :: !(Map PackageName RawSnapshotPackage) -- ^ Packages available in this snapshot for installation. This will be -- applied on top of any globally available packages. , rsDrop :: !(Set PackageName) -- ^ Global packages that should be dropped/ignored. } -- | A flattened representation of all the layers in a snapshot. -- -- @since 0.1.0.0 data Snapshot = Snapshot { snapshotCompiler :: !WantedCompiler -- ^ The compiler wanted for this snapshot. , snapshotPackages :: !(Map PackageName SnapshotPackage) -- ^ Packages available in this snapshot for installation. This will be -- applied on top of any globally available packages. , snapshotDrop :: !(Set PackageName) -- ^ Global packages that should be dropped/ignored. } -- | Settings for a package found in a snapshot. -- -- @since 0.1.0.0 data RawSnapshotPackage = RawSnapshotPackage { rspLocation :: !RawPackageLocationImmutable -- ^ Where to get the package from , rspFlags :: !(Map FlagName Bool) -- ^ Same as 'slFlags' , rspHidden :: !Bool -- ^ Same as 'slHidden' , rspGhcOptions :: ![Text] -- ^ Same as 'slGhcOptions' } -- | Settings for a package found in a snapshot. -- -- @since 0.1.0.0 data SnapshotPackage = SnapshotPackage { spLocation :: !PackageLocationImmutable -- ^ Where to get the package from , spFlags :: !(Map FlagName Bool) -- ^ Same as 'slFlags' , spHidden :: !Bool -- ^ Same as 'slHidden' , spGhcOptions :: ![Text] -- ^ Same as 'slGhcOptions' } deriving Show -- | A single layer of a snapshot, i.e. a specific YAML configuration file. -- -- @since 0.1.0.0 data RawSnapshotLayer = RawSnapshotLayer { rslParent :: !RawSnapshotLocation -- ^ The sl to extend from. This is either a specific -- compiler, or a @SnapshotLocation@ which gives us more information -- (like packages). Ultimately, we'll end up with a -- @CompilerVersion@. -- -- @since 0.1.0.0 , rslCompiler :: !(Maybe WantedCompiler) -- ^ Override the compiler specified in 'slParent'. Must be -- 'Nothing' if using 'SLCompiler'. -- -- @since 0.1.0.0 , rslLocations :: ![RawPackageLocationImmutable] -- ^ Where to grab all of the packages from. -- -- @since 0.1.0.0 , rslDropPackages :: !(Set PackageName) -- ^ Packages present in the parent which should not be included -- here. -- -- @since 0.1.0.0 , rslFlags :: !(Map PackageName (Map FlagName Bool)) -- ^ Flag values to override from the defaults -- -- @since 0.1.0.0 , rslHidden :: !(Map PackageName Bool) -- ^ Packages which should be hidden when registering. This will -- affect, for example, the import parser in the script -- command. We use a 'Map' instead of just a 'Set' to allow -- overriding the hidden settings in a parent sl. -- -- @since 0.1.0.0 , rslGhcOptions :: !(Map PackageName [Text]) -- ^ GHC options per package -- -- @since 0.1.0.0 , rslPublishTime :: !(Maybe UTCTime) -- ^ See 'slPublishTime' -- -- @since 0.1.0.0 } deriving (Show, Eq, Generic) instance NFData RawSnapshotLayer instance ToJSON RawSnapshotLayer where toJSON rsnap = object $ concat [ ["resolver" .= rslParent rsnap] , maybe [] (\compiler -> ["compiler" .= compiler]) (rslCompiler rsnap) , ["packages" .= rslLocations rsnap] , if Set.null (rslDropPackages rsnap) then [] else ["drop-packages" .= Set.map CabalString (rslDropPackages rsnap)] , if Map.null (rslFlags rsnap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap))] , if Map.null (rslHidden rsnap) then [] else ["hidden" .= toCabalStringMap (rslHidden rsnap)] , if Map.null (rslGhcOptions rsnap) then [] else ["ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)] , maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap) ] instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where parseJSON = withObjectWarnings "Snapshot" $ \o -> do _ :: Maybe Text <- o ..:? "name" -- avoid warnings for old snapshot format mcompiler <- o ..:? "compiler" mresolver <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"] unresolvedSnapshotParent <- case (mcompiler, mresolver) of (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler, Nothing) (_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do sl <- usl mdir case (sl, mcompiler) of (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 _ -> pure (sl, mcompiler) unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) rslDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) rslFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) rslPublishTime <- o ..:? "publish-time" pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..}) <$> ((concat . map NE.toList) <$> sequenceA unresolvedLocs) <*> unresolvedSnapshotParent -- | A single layer of a snapshot, i.e. a specific YAML configuration file. -- -- @since 0.1.0.0 data SnapshotLayer = SnapshotLayer { slParent :: !SnapshotLocation -- ^ The sl to extend from. This is either a specific -- compiler, or a @SnapshotLocation@ which gives us more information -- (like packages). Ultimately, we'll end up with a -- @CompilerVersion@. -- -- @since 0.1.0.0 , slCompiler :: !(Maybe WantedCompiler) -- ^ Override the compiler specified in 'slParent'. Must be -- 'Nothing' if using 'SLCompiler'. -- -- @since 0.1.0.0 , slLocations :: ![PackageLocationImmutable] -- ^ Where to grab all of the packages from. -- -- @since 0.1.0.0 , slDropPackages :: !(Set PackageName) -- ^ Packages present in the parent which should not be included -- here. -- -- @since 0.1.0.0 , slFlags :: !(Map PackageName (Map FlagName Bool)) -- ^ Flag values to override from the defaults -- -- @since 0.1.0.0 , slHidden :: !(Map PackageName Bool) -- ^ Packages which should be hidden when registering. This will -- affect, for example, the import parser in the script -- command. We use a 'Map' instead of just a 'Set' to allow -- overriding the hidden settings in a parent sl. -- -- @since 0.1.0.0 , slGhcOptions :: !(Map PackageName [Text]) -- ^ GHC options per package -- -- @since 0.1.0.0 , slPublishTime :: !(Maybe UTCTime) -- ^ Publication timestamp for this snapshot. This field is optional, and -- is for informational purposes only. -- -- @since 0.1.0.0 } deriving (Show, Eq, Generic) instance ToJSON SnapshotLayer where toJSON snap = object $ concat [ ["resolver" .= slParent snap] , maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap) , ["packages" .= slLocations snap] , if Set.null (slDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (slDropPackages snap)] , if Map.null (slFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))] , if Map.null (slHidden snap) then [] else ["hidden" .= toCabalStringMap (slHidden snap)] , if Map.null (slGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (slGhcOptions snap)] , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) ] -- | Convert snapshot layer into its "raw" equivalent. -- -- @since 0.1.0.0 toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer toRawSnapshotLayer sl = RawSnapshotLayer { rslParent = toRawSL (slParent sl) , rslCompiler = slCompiler sl , rslLocations = map toRawPLI (slLocations sl) , rslDropPackages = slDropPackages sl , rslFlags = slFlags sl , rslHidden = slHidden sl , rslGhcOptions = slGhcOptions sl , rslPublishTime = slPublishTime sl } -- | An arbitrary hash for a snapshot, used for finding module names -- in a snapshot. Mostly intended for Stack's usage. -- -- @since 0.1.0.0 newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} deriving (Show) -- | Get the path to the global hints cache file getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) getGlobalHintsFile = do root <- view $ pantryConfigL.to pcRootDir globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" pure $ root globalHintsRelFile -- | Creates BlobKey for an input ByteString -- -- @since 0.1.0.0 bsToBlobKey :: ByteString -> BlobKey bsToBlobKey bs = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) -- | Warn if the package uses 'PCHpack'. -- -- @since 0.4.0.0 warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env () warnMissingCabalFile loc = logWarn $ "DEPRECATED: The package at " <> display loc <> " does not include a cabal file.\n" <> "Instead, it includes an hpack package.yaml file for generating a cabal file.\n" <> "This usage is deprecated; please see https://github.com/commercialhaskell/stack/issues/5210.\n" <> "Support for this workflow will be removed in the future.\n" pantry-0.4.0.2/src/windows/System/IsWindows.hs0000644000000000000000000000026413712324605017412 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} module System.IsWindows ( osIsWindows ) where import RIO (Bool (..)) -- | True if using Windows OS. osIsWindows :: Bool osIsWindows = True pantry-0.4.0.2/src/unix/System/IsWindows.hs0000644000000000000000000000027213712324605016702 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} module System.IsWindows ( osIsWindows ) where import RIO (Bool (..)) -- | False if not using Windows OS. osIsWindows :: Bool osIsWindows = False pantry-0.4.0.2/test/Spec.hs0000644000000000000000000000005413712324605013565 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} pantry-0.4.0.2/test/Pantry/ArchiveSpec.hs0000644000000000000000000000672413712324605016356 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Pantry.ArchiveSpec (spec) where import Test.Hspec import Data.Maybe (fromJust) import RIO import RIO.Text as T import Pantry import Path.IO (resolveFile') data TestLocation = TLFilePath String | TLUrl Text data TestArchive = TestArchive { testLocation :: !TestLocation , testSubdir :: !Text } getRawPackageLocationIdent' :: TestArchive -> IO PackageIdentifier getRawPackageLocationIdent' TestArchive{..} = do testLocation' <- case testLocation of TLFilePath relPath -> do absPath <- resolveFile' relPath return $ ALFilePath $ ResolvedPath { resolvedRelative = RelFilePath $ fromString relPath , resolvedAbsolute = absPath } TLUrl url -> return $ ALUrl url let archive = RawArchive { raLocation = testLocation' , raHash = Nothing , raSize = Nothing , raSubdir = testSubdir } runPantryApp $ getRawPackageLocationIdent $ RPLIArchive archive metadata where metadata = RawPackageMetadata { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing } parsePackageIdentifier' :: String -> PackageIdentifier parsePackageIdentifier' = fromJust . parsePackageIdentifier urlToStackCommit :: Text -> TestLocation urlToStackCommit commit = TLUrl $ T.concat [ "https://github.com/commercialhaskell/stack/archive/" , commit , ".tar.gz" ] treeWithoutCabalFile :: Selector PantryException treeWithoutCabalFile (TreeWithoutCabalFile _) = True treeWithoutCabalFile _ = False spec :: Spec spec = do it "finds cabal file from tarball" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" , testSubdir = "" } ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" it "finds cabal file from tarball with subdir '.'" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" , testSubdir = "." } ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" it "finds cabal file from tarball with a package.yaml" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" , testSubdir = "" } ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" it "finds cabal file from tarball with subdir '.' with a package.yaml" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" , testSubdir = "." } ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" it "finds cabal file from tarball with subdir 'subs/pantry/'" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" , testSubdir = "subs/pantry/" } ident `shouldBe` parsePackageIdentifier' "pantry-0.1.0.0" it "matches whole directory name" $ getRawPackageLocationIdent' TestArchive { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" , testSubdir = "subs/pant" } `shouldThrow` treeWithoutCabalFile it "follows symlinks to directories" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/symlink-to-dir.tar.gz" , testSubdir = "symlink" } ident `shouldBe` parsePackageIdentifier' "foo-1.2.3" pantry-0.4.0.2/test/Pantry/BuildPlanSpec.hs0000644000000000000000000001017413712324605016641 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.BuildPlanSpec where import Pantry.Internal.AesonExtended (WithJSONWarnings(..)) import RIO import qualified Data.ByteString.Char8 as S8 import Data.Yaml (decodeThrow) import Pantry import Test.Hspec import Control.Monad.Catch (MonadThrow) import Data.List.NonEmpty (NonEmpty) spec :: Spec spec = describe "PackageLocation" $ do describe "Archive" $ do describe "github" $ do let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) decode' = decodeThrow decode'' :: HasCallStack => ByteString -> IO (NonEmpty RawPackageLocationImmutable) decode'' bs = do WithJSONWarnings unresolved warnings <- decode' bs unless (null warnings) $ error $ show warnings resolvePaths Nothing unresolved it "'github' and 'commit' keys" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink/town" , "commit: abc123" ]) let expected :: RawPackageLocationImmutable expected = RPLIArchive RawArchive { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" , raHash = Nothing , raSize = Nothing , raSubdir = "" } RawPackageMetadata { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing } actual <- decode'' contents actual `shouldBe` pure expected it "'github', 'commit', and 'subdirs' keys" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink/town" , "commit: abc123" , "subdirs:" , " - foo" ]) let expected :: RawPackageLocationImmutable expected = RPLIArchive RawArchive { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" , raHash = Nothing , raSize = Nothing , raSubdir = "foo" } RawPackageMetadata { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing } actual <- decode'' contents actual `shouldBe` pure expected it "does not parse GitHub repo with no slash" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink" , "commit: abc123" ]) void (decode' contents) `shouldBe` Nothing it "does not parse GitHub repo with leading slash" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: /oink" , "commit: abc123" ]) void (decode' contents) `shouldBe` Nothing it "does not parse GitHub repo with trailing slash" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink/" , "commit: abc123" ]) void (decode' contents) `shouldBe` Nothing it "does not parse GitHub repo with more than one slash" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink/town/here" , "commit: abc123" ]) void (decode' contents) `shouldBe` Nothing pantry-0.4.0.2/test/Pantry/CabalSpec.hs0000644000000000000000000000707613712324605016000 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.CabalSpec (spec) where import Test.Hspec import Pantry import qualified Pantry.SHA256 as SHA256 import RIO import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) spec :: Spec spec = describe "wrong cabal file" $ do let test :: HasCallStack => String -> RIO PantryApp () -> Spec test name action = it name (runPantryApp action :: IO ()) shouldThrow' x y = withRunInIO $ \run -> run x `shouldThrow` y test "Hackage" $ do sha <- either throwIO pure $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" let rpli = RPLIHackage (PackageIdentifierRevision name version3 (CFIHash sha (Just size))) Nothing go = loadCabalFileRawImmutable rpli name = mkPackageName "acme-missiles" version2 = mkVersion [0, 2] version3 = mkVersion [0, 3] size = FileSize 597 go `shouldThrow'` \e -> case e of MismatchedPackageMetadata rpli' rpm _tree ident -> rpli == rpli' && rpm == RawPackageMetadata { rpmName = Just name , rpmVersion = Just version3 , rpmTreeKey = Nothing } && ident == PackageIdentifier name version2 _ -> False test "tarball with wrong ident" $ do archiveHash' <- either throwIO pure $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" let rpli = RPLIArchive archive rpm archive = RawArchive { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" , raHash = Just archiveHash' , raSize = Just $ FileSize 309199 , raSubdir = "yesod-auth" } rpm = RawPackageMetadata { rpmName = Just acmeMissiles , rpmVersion = Just version2 , rpmTreeKey = Nothing } go = loadCabalFileRawImmutable rpli acmeMissiles = mkPackageName "acme-missiles" version2 = mkVersion [0, 2] go `shouldThrow'` \e -> case e of MismatchedPackageMetadata rpli' rpm' _treeKey ident -> rpli == rpli' && rpm == rpm' && ident == PackageIdentifier (mkPackageName "yesod-auth") (mkVersion [1, 6, 4, 1]) _ -> False test "tarball with wrong cabal file" $ do let rpli = RPLIArchive archive rpm archive = RawArchive { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" , raHash = either impureThrow Just $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" , raSize = Just $ FileSize 309199 , raSubdir = "yesod-auth" } rpm = RawPackageMetadata { rpmName = Just yesodAuth , rpmVersion = Just badVersion , rpmTreeKey = Nothing } go = loadCabalFileRawImmutable rpli yesodAuth = mkPackageName "yesod-auth" version = mkVersion [1, 6, 4, 1] badVersion = mkVersion [1, 6, 4, 0] go `shouldThrow'` \e -> case e of MismatchedPackageMetadata rpli' rpm' _treeKey ident -> rpli == rpli' && rpm == rpm' && ident == PackageIdentifier yesodAuth version _ -> False pantry-0.4.0.2/test/Pantry/CasaSpec.hs0000644000000000000000000000514413712324605015637 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Pantry.CasaSpec (spec) where import Distribution.Types.Version (mkVersion) import Pantry import Pantry.SHA256 import Test.Hspec spec :: Spec spec = do loadHackagePackageSpec completeSpec completeSpec :: Spec completeSpec = it "completePackageLocation: unliftio_0_2_12" (shouldReturn (runPantryAppClean (cplComplete <$> completePackageLocation (argsRlpi unliftio_0_2_12))) ( PLIHackage (PackageIdentifier { pkgName = "unliftio" , pkgVersion = mkVersion [0, 2, 12] }) (argsCabalKey unliftio_0_2_12) (argsTreeKey unliftio_0_2_12))) loadHackagePackageSpec :: Spec loadHackagePackageSpec = do it "loadPackageRaw Exact hackage lookup" (shouldReturn (fmap packageTreeKey (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) (argsTreeKey unliftio_0_2_12)) it "loadHackagePackageRaw Exact hackage lookup" (shouldReturn (fmap packageTreeKey (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) (argsTreeKey unliftio_0_2_12)) it "loadHackagePackageRawViaCasa Exact hackage lookup" (shouldReturn (fmap (fmap packageTreeKey) (runPantryAppClean (tryLoadPackageRawViaCasa (argsRlpi unliftio_0_2_12) (argsTreeKey unliftio_0_2_12)))) (Just (argsTreeKey unliftio_0_2_12))) data Args = Args { argsRlpi :: !RawPackageLocationImmutable , argsTreeKey :: !TreeKey , argsRevision :: !PackageIdentifierRevision , argsCabalKey :: !BlobKey } unliftio_0_2_12 :: Args unliftio_0_2_12 = let cabalHash = (either (error . show) id (fromHexText "b089fbc2ff2628a963c2c4b12143f2020874e3e5144ffd6c62b25639a0ca1483")) cabalLen = FileSize 3325 cabalFileHash = CFIHash cabalHash (Just cabalLen) casaTreeKey = TreeKey (BlobKey (either (error . show) id (fromHexText "4971b43f3d473eff868eb1a0c359729b49f1779e78c462ba45ef0d1eda677699")) (FileSize 2229)) pir = PackageIdentifierRevision "unliftio" (mkVersion [0, 2, 12]) cabalFileHash in Args { argsRevision = pir , argsRlpi = RPLIHackage pir (Just casaTreeKey) , argsTreeKey = casaTreeKey , argsCabalKey = BlobKey cabalHash cabalLen } pantry-0.4.0.2/test/Pantry/FileSpec.hs0000644000000000000000000000073113712324605015644 0ustar0000000000000000module Pantry.FileSpec (spec) where import Test.Hspec import Pantry import Path import Path.IO import Control.Monad (void) spec :: Spec spec = describe "loadCabalFilePath" $ do it "sanity" $ do abs' <- resolveDir' "." (f, name, cabalfp) <- runPantryApp $ loadCabalFilePath abs' suffix <- parseRelFile "pantry.cabal" cabalfp `shouldBe` abs' suffix name' <- parsePackageNameThrowing "pantry" name `shouldBe` name' void $ f NoPrintWarnings pantry-0.4.0.2/test/Pantry/GlobalHintsSpec.hs0000644000000000000000000000342213712324605017173 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.GlobalHintsSpec (spec) where import Distribution.Types.PackageName (mkPackageName) import Distribution.Version (mkVersion) import RIO import Pantry (loadGlobalHints, WantedCompiler (..), runPantryAppClean) import Pantry.Internal import Test.Hspec import qualified RIO.Map as Map import Path (toFilePath) spec :: Spec spec = do let it' name inner = it name $ example $ runPantryAppClean $ do file <- getGlobalHintsFile writeFileBinary (toFilePath file) "this should be ignored" inner it' "unknown compiler" $ do mmap <- loadGlobalHints $ WCGhc (mkVersion [0, 0, 0, 0, 0, 0, 0]) liftIO $ mmap `shouldBe` Nothing it' "known compiler" $ do mmap <- loadGlobalHints $ WCGhc (mkVersion [8, 4, 3]) case mmap of Nothing -> error "not found" Just m -> liftIO $ do Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [8, 4, 3]) Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 11, 1, 0]) Map.lookup (mkPackageName "bytestring") m `shouldBe` Just (mkVersion [0, 10, 8, 2]) Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing it' "older known compiler" $ do mmap <- loadGlobalHints $ WCGhc (mkVersion [7, 8, 4]) case mmap of Nothing -> error "not found" Just m -> liftIO $ do Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [7, 8, 4]) Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 7, 0, 2]) Map.lookup (mkPackageName "Cabal") m `shouldBe` Just (mkVersion [1, 18, 1, 5]) Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing pantry-0.4.0.2/test/Pantry/HackageSpec.hs0000644000000000000000000000147313712324605016314 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.HackageSpec (spec) where import Test.Hspec import Pantry import RIO import Distribution.Types.Version (mkVersion) spec :: Spec spec = do it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing it "fuzzy lookup kicks in" $ do let pir = PackageIdentifierRevision "thisisnot-tobe-foundon-hackage-please" (mkVersion [1..3]) CFILatest runPantryApp (loadPackageRaw (RPLIHackage pir Nothing)) `shouldThrow` \e -> case e of UnknownHackagePackage pir' _ -> pir == pir' _ -> False -- Flaky test, can be broken by new packages on Hackage. it "finds acme-missiles" $ do x <- runPantryApp (getHackageTypoCorrections "acme-missile") x `shouldSatisfy` ("acme-missiles" `elem`) pantry-0.4.0.2/test/Pantry/Internal/StaticBytesSpec.hs0000644000000000000000000000613213712324605021000 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} module Pantry.Internal.StaticBytesSpec (spec) where import RIO import Pantry.Internal.StaticBytes import Control.Monad (replicateM) import qualified Data.ByteString as B import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import qualified Data.Text as T import qualified Data.Text.Encoding as TE spec :: Spec spec = do describe "ByteString" $ tests B.pack describe "Storable Vector" $ tests VS.fromList describe "Unboxed Vector" $ tests VU.fromList describe "Primitive Vector" $ tests VP.fromList tests :: (Eq dbytes, Show dbytes, DynamicBytes dbytes) => ([Word8] -> dbytes) -> Spec tests pack = do it "disallows 4 bytes" $ property $ \(w1,w2,w3,w4) -> toStaticExact (pack [w1,w2,w3,w4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8) it "toStaticExact matches ByteString" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do let octets = [w1,w2,w3,w4,w5,w6,w7,w8] (expected :: Bytes8) = either impureThrow id $ toStaticExact (B.pack octets) actual = either impureThrow id $ toStaticExact (pack octets) actual `shouldBe` expected it "fromStatic round trips" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do let octets = [w1,w2,w3,w4,w5,w6,w7,w8] v1 = pack octets (b8 :: Bytes8) = either impureThrow id $ toStaticExact v1 v2 = fromStatic b8 v2 `shouldBe` v1 it "allows 8 bytes" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do let bs = pack [w1,w2,w3,w4,w5,w6,w7,w8] case toStaticExact bs of Left e -> throwIO e Right b8 -> fromStatic (b8 :: Bytes8) `shouldBe` bs toStaticExact bs `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes16) it "padding is the same as trailing nulls" $ property $ \(w1,w2,w3,w4) -> do let ws = [w1,w2,w3,w4] bs1 = pack $ ws ++ replicate 4 0 bs2 = pack ws Right (toStaticPadTruncate bs2 :: Bytes8) `shouldBe` toStaticExact bs1 prop "handles bytes16" $ \octets -> do let bs = pack $ take 16 octets (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs fromStatic b16 `shouldBe` pack (take 16 (octets ++ replicate 16 0)) it "spot check bytes16" $ forAll (replicateM 16 arbitrary) $ \ws -> do let bs = pack ws (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs fromStatic b16 `shouldBe` pack ws prop "handles bytes32" $ \octets -> do let bs = pack $ take 32 octets (b32 :: Bytes32) = either impureThrow id $ toStaticPad bs fromStatic b32 `shouldBe` pack (take 32 (take 32 octets ++ replicate 32 0)) prop "fuzz with encodeUtf8" $ \chars -> do let t = T.pack $ filter (/= '\0') chars bs = TE.encodeUtf8 t bs128 = pack $ B.unpack $ B.take 128 $ bs `B.append` B.replicate 128 0 b128 = toStaticPadTruncate (pack $ B.unpack bs) :: Bytes128 fromStatic b128 `shouldBe` bs128 pantry-0.4.0.2/test/Pantry/InternalSpec.hs0000644000000000000000000000452513712324626016551 0ustar0000000000000000module Pantry.InternalSpec (spec) where import Test.Hspec import Pantry (runPantryApp) import Pantry.Internal (normalizeParents, makeTarRelative, hpackVersion) spec :: Spec spec = do describe "normalizeParents" $ do let (!) :: HasCallStack => String -> Maybe String -> Spec input ! output = it input $ let x = normalizeParents input y = either (const Nothing) Just x in y `shouldBe` output "/file/\\test" ! Nothing "file/\\test" ! Just "file/\\test" "/file/////\\test" ! Nothing "file/////\\test" ! Just "file/\\test" "file/test/" ! Just "file/test" "/file/\\test////" ! Nothing "/file/./test" ! Nothing "file/./test" ! Just "file/test" "/test/file/../bob/fred/" ! Nothing "/test/file/../bob/fred" ! Nothing "test/file/../bob/fred/" ! Just "test/bob/fred" "test/file/../bob/fred" ! Just "test/bob/fred" "../bob/fred" ! Nothing "../bob/fred/" ! Nothing "./bob/fred/" ! Just "bob/fred" "./bob/fred" ! Just "bob/fred" "./" ! Nothing "./." ! Nothing "/./" ! Nothing "/" ! Nothing "bob/fred/." ! Nothing "//home" ! Nothing "foobarbaz\\bin" ! Just "foobarbaz\\bin" describe "makeTarRelative" $ do let test :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Spec test base rel expected = it (show (base, rel)) $ either (const Nothing) Just (makeTarRelative base rel) `shouldBe` expected test "foo/bar" "baz" $ Just "foo/baz" test "foo" "bar" $ Just "bar" test "foo" "/bar" Nothing test "foo/" "bar" Nothing -- MSS 2018-08-23: Arguable whether this should be Nothing -- instead, since we don't want any absolute paths. However, -- that's really a concern for normalizeParents. Point being: if -- you refactor in the future, and this turns into Nothing, that's -- fine. test "/foo" "bar" $ Just "/bar" describe "Parse HPack version" $ do {- let isVersion :: Version -> Bool isVersion _ = True -} it "Shipped hpack version" $ example $ do _version <- runPantryApp hpackVersion -- version `shouldSatisfy` isVersion pure () -- it "External hpack version" $ do -- version <- runPantryApp $ customHpack "/home/sibi/.local/bin/hpack" hpackVersion -- version `shouldSatisfy` isVersion pantry-0.4.0.2/test/Pantry/TreeSpec.hs0000644000000000000000000000546013712324605015670 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.TreeSpec (spec) where import Test.Hspec import RIO import Pantry import qualified Pantry.SHA256 as SHA256 import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) spec :: Spec spec = do let tarURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.tar.gz" zipURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.zip" emptyPM = RawPackageMetadata { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing } mkArchive url = RPLIArchive RawArchive { raLocation = ALUrl url , raHash = Nothing , raSize = Nothing , raSubdir = "" } emptyPM tarPL = mkArchive tarURL zipPL = mkArchive zipURL gitPL = RPLIRepo Repo { repoUrl = "https://github.com/snoyberg/file-embed.git" , repoCommit = "47b499c3c58ca465c56ee0295d0a76782a66751d" , repoType = RepoGit , repoSubdir = "" } emptyPM hgPL = RPLIRepo Repo { repoUrl = "https://bitbucket.org/snoyberg/file-embed" , repoCommit = "6d8126e7a4821788a0275fa7c2c4a0083e14d690" , repoType = RepoHg , repoSubdir = "" } emptyPM it "zip and tar.gz archives match" $ asIO $ runPantryAppClean $ do pair1 <- loadPackageRaw tarPL pair2 <- loadPackageRaw zipPL liftIO $ pair2 `shouldBe` pair1 it "archive and Git repo match" $ asIO $ runPantryAppClean $ do pair1 <- loadPackageRaw tarPL pair2 <- loadPackageRaw gitPL liftIO $ pair2 `shouldBe` pair1 it "archive and Hg repo match" $ asIO $ runPantryAppClean $ do pair1 <- loadPackageRaw tarPL pair2 <- loadPackageRaw hgPL liftIO $ pair2 `shouldBe` pair1 it "5045 no cabal file" $ asIO $ runPantryAppClean $ do let rpli = RPLIArchive archive rpm packageName = mkPackageName "yaml" version = mkVersion [0, 11, 1, 2] archive = RawArchive { raLocation = ALUrl "https://github.com/snoyberg/yaml/archive/yaml-0.11.1.2.tar.gz" , raHash = either impureThrow Just $ SHA256.fromHexBytes "b8564e99c555e670ee487bbf92d03800d955f0e6e16333610ef46534548e0a3d" , raSize = Just $ FileSize 94198 , raSubdir = "yaml" } rpm = RawPackageMetadata { rpmName = Just packageName , rpmVersion = Just version , rpmTreeKey = Nothing } void $ loadCabalFileRawImmutable rpli pantry-0.4.0.2/test/Pantry/TypesSpec.hs0000644000000000000000000001666113712324626016105 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Pantry.TypesSpec ( spec ) where import Pantry.Internal.AesonExtended import qualified Data.ByteString.Char8 as S8 import qualified Data.Yaml as Yaml import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Pantry import Pantry.Internal ( Tree(..) , TreeEntry(..) , mkSafeFilePath , parseTree , renderTree ) import qualified Pantry.SHA256 as SHA256 import RIO import qualified RIO.Text as T import Test.Hspec import Text.RawString.QQ import RIO.Time (Day (..)) hh :: HasCallStack => String -> Property -> Spec hh name p = it name $ do result <- check p unless result $ throwString "Hedgehog property failed" :: IO () genBlobKey :: Gen BlobKey genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) genSha256 :: Gen SHA256 genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) samplePLIRepo :: ByteString samplePLIRepo = [r| subdir: wai cabal-file: # This is ignored, only included to make sure we get no warnings size: 1765 sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 name: wai version: 3.2.1.2 git: https://github.com/yesodweb/wai.git pantry-tree: size: 714 sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 |] samplePLIRepo2 :: ByteString samplePLIRepo2 = [r| name: merkle-log version: 0.1.0.0 git: https://github.com/kadena-io/merkle-log.git pantry-tree: size: 615 sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376 |] spec :: Spec spec = do describe "WantedCompiler" $ do hh "parse/render works" $ property $ do wc <- forAll $ let ghc = WCGhc <$> genVersion ghcjs = WCGhcjs <$> genVersion <*> genVersion genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100)) in Gen.choice [ghc, ghcjs] let text = utf8BuilderToText $ display wc case parseWantedCompiler text of Left e -> throwIO e Right actual -> liftIO $ actual `shouldBe` wc describe "Tree" $ do hh "parse/render works" $ property $ do tree <- forAll $ let sfp = do pieces <- Gen.list (Range.linear 1 10) sfpComponent let combined = T.intercalate "/" pieces case mkSafeFilePath combined of Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces Just sfp' -> pure sfp' sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum entry = TreeEntry <$> genBlobKey <*> Gen.choice (map pure [minBound..maxBound]) in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry) let bs = renderTree tree liftIO $ parseTree bs `shouldBe` Just tree describe "(Raw)SnapshotLayer" $ do let parseSl :: String -> IO RawSnapshotLayer parseSl str = case Yaml.decodeThrow . S8.pack $ str of (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x Nothing -> fail "Can't parse RawSnapshotLayer" it "parses snapshot using 'resolver'" $ do RawSnapshotLayer{..} <- parseSl $ "name: 'test'\n" ++ "resolver: lts-2.10\n" rslParent `shouldBe` ltsSnapshotLocation 2 10 it "parses snapshot using 'snapshot'" $ do RawSnapshotLayer{..} <- parseSl $ "name: 'test'\n" ++ "snapshot: lts-2.10\n" rslParent `shouldBe` ltsSnapshotLocation 2 10 it "throws if both 'resolver' and 'snapshot' are present" $ do let go = parseSl $ "name: 'test'\n" ++ "resolver: lts-2.10\n" ++ "snapshot: lts-2.10\n" go `shouldThrow` anyException it "throws if both 'snapshot' and 'compiler' are not present" $ do let go = parseSl "name: 'test'\n" go `shouldThrow` anyException it "works if no 'snapshot' specified" $ do RawSnapshotLayer{..} <- parseSl $ "name: 'test'\n" ++ "compiler: ghc-8.0.1\n" rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1])) hh "rendering an LTS gives a nice name" $ property $ do (major, minor) <- forAll $ (,) <$> Gen.integral (Range.linear 1 10000) <*> Gen.integral (Range.linear 1 10000) liftIO $ Yaml.toJSON (ltsSnapshotLocation major minor) `shouldBe` Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor]) hh "rendering a nightly gives a nice name" $ property $ do days <- forAll $ Gen.integral $ Range.linear 1 10000000 let day = ModifiedJulianDay days liftIO $ Yaml.toJSON (nightlySnapshotLocation day) `shouldBe` Yaml.String (T.pack $ "nightly-" ++ show day) it "FromJSON instance for PLIRepo" $ do WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo warnings `shouldBe` [] pli <- resolvePaths Nothing unresolvedPli let repoValue = Repo { repoSubdir = "wai" , repoType = RepoGit , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" , repoUrl = "https://github.com/yesodweb/wai.git" } pantrySha = SHA256.fromHexBytes "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2" psha <- case pantrySha of Right psha -> pure psha _ -> fail "Failed decoding sha256" let pkgValue = PackageMetadata { pmIdent = PackageIdentifier (mkPackageName "wai") (mkVersion [3, 2, 1, 2]) , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) } pli `shouldBe` PLIRepo repoValue pkgValue WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli warnings2 `shouldBe` [] reparsed' <- resolvePaths Nothing reparsed reparsed' `shouldBe` pli it "parseHackageText parses" $ do let txt = "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" hsha = SHA256.fromHexBytes "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" sha <- case hsha of Right sha' -> pure sha' _ -> fail "parseHackagetext: failed decoding the sha256" let Right (pkgIdentifier, blobKey) = parseHackageText txt blobKey `shouldBe` (BlobKey sha (FileSize 5058)) pkgIdentifier `shouldBe` PackageIdentifier (mkPackageName "persistent") (mkVersion [2, 8, 2]) it "roundtripping a PLIRepo" $ do WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2 warnings `shouldBe` [] pli <- resolvePaths Nothing unresolvedPli WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli warnings2 `shouldBe` [] pli2 <- resolvePaths Nothing unresolvedPli2 pli2 `shouldBe` (pli :: PackageLocationImmutable) pantry-0.4.0.2/LICENSE0000644000000000000000000000273113712324777012403 0ustar0000000000000000Copyright (c) 2015-2019, Stack contributors All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Stack nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. pantry-0.4.0.2/pantry.cabal0000644000000000000000000000763013712326614013672 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- -- hash: cb17eb4ba27f5fad8ef492276362b6be7533e390279b5e6a857fa89a753da4a1 name: pantry version: 0.4.0.2 synopsis: Content addressable Haskell package management description: Please see the README on Github at category: Development homepage: https://github.com/commercialhaskell/pantry#readme bug-reports: https://github.com/commercialhaskell/pantry/issues author: Michael Snoyman maintainer: michael@snoyman.com copyright: 2018-2019 FP Complete license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: README.md ChangeLog.md attic/hpack-0.1.2.3.tar.gz attic/package-0.1.2.3.tar.gz attic/symlink-to-dir.tar.gz source-repository head type: git location: https://github.com/commercialhaskell/pantry library exposed-modules: Pantry Pantry.SHA256 Pantry.Internal Pantry.Internal.StaticBytes Pantry.Internal.Stackage Pantry.Internal.Companion Pantry.Internal.AesonExtended other-modules: Hackage.Security.Client.Repository.HttpLib.HttpClient Pantry.Archive Pantry.HTTP Pantry.HPack Pantry.Hackage Pantry.Repo Pantry.SQLite Pantry.Storage Pantry.Casa Pantry.Tree Pantry.Types hs-source-dirs: src/ ghc-options: -Wall build-depends: Cabal >=3 && <3.3 , aeson , ansi-terminal , base >=4.10 && <5 , bytestring , casa-client , casa-types , conduit , conduit-extra , containers , cryptonite , cryptonite-conduit , digest , filelock , generic-deriving , hackage-security , hpack >=0.31.2 , http-client , http-client-tls , http-conduit , http-download , http-types , memory , mtl , network-uri , path , path-io , persistent , persistent-sqlite >=2.9.3 , persistent-template , primitive , resourcet , rio , rio-orphans , rio-prettyprint , tar-conduit , text , text-metrics , time , transformers , unix-compat , unliftio , unordered-containers , vector , yaml , zip-archive if os(windows) other-modules: System.IsWindows hs-source-dirs: src/windows/ else other-modules: System.IsWindows hs-source-dirs: src/unix/ default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Pantry.ArchiveSpec Pantry.BuildPlanSpec Pantry.CabalSpec Pantry.CasaSpec Pantry.FileSpec Pantry.GlobalHintsSpec Pantry.HackageSpec Pantry.Internal.StaticBytesSpec Pantry.InternalSpec Pantry.TreeSpec Pantry.TypesSpec Paths_pantry hs-source-dirs: test ghc-options: -Wall build-depends: Cabal >=3 && <3.3 , QuickCheck , aeson , ansi-terminal , base >=4.10 && <5 , bytestring , casa-client , casa-types , conduit , conduit-extra , containers , cryptonite , cryptonite-conduit , digest , exceptions , filelock , generic-deriving , hackage-security , hedgehog , hpack >=0.31.2 , hspec , http-client , http-client-tls , http-conduit , http-download , http-types , memory , mtl , network-uri , pantry , path , path-io , persistent , persistent-sqlite >=2.9.3 , persistent-template , primitive , raw-strings-qq , resourcet , rio , rio-orphans , rio-prettyprint , tar-conduit , text , text-metrics , time , transformers , unix-compat , unliftio , unordered-containers , vector , yaml , zip-archive default-language: Haskell2010 pantry-0.4.0.2/README.md0000644000000000000000000002237013712324777012656 0ustar0000000000000000# pantry [![Build Status](https://dev.azure.com/commercialhaskell/pantry/_apis/build/status/commercialhaskell.pantry?branchName=master)](https://dev.azure.com/commercialhaskell/pantry/_build/latest?definitionId=6&branchName=master) Content addressable Haskell package management, providing for secure, reproducible acquisition of Haskell package contents and metadata. ## What is Pantry * A Haskell library, command line executable, storage specification, and network protocol * Intended for content-addressable storage of Haskell packages * Allows non-centralized package storage * Primarily for use by Stackage and Stack, hopefully other tools as well ## Goals * Efficient, distributed package storage for Haskell * Superset of existing storage mechanisms * Security via content addressable storage * Allow more Stackage-style snapshots to exist * Allow authors to bypass Hackage for uploads * Allow Stackage to create forks of packages on Hackage __TODO__ Content below needs to be updated. * Support for hpack in PackageLocationImmutable? ## Package definition Pantry defines the following concepts: * __Blob__: a raw byte sequence, identified by its key (SHA256 of the contents) * __Tree entry__: contents of a single file (identified by blob key) and whether or not it is executable. * NOTE: existing package formats like tarballs support more sophisticated options. We explicitly do not support those. If such functionality is needed, fallback to those mechanism is required. * __Tree__: mapping from relative path to a tree entry. Some basic sanity rules apply to the paths: no `.` or `..` directory components, no newlines in filepaths, does not begin with `/`, no `\\` (we normalize to POSIX-style paths). A tree is identified by a tree key (SHA256 of the tree's serialized format). * __Package__: a tree key for the package contents, package name, version number, and cabal file blob key. Requirements: there must be a single file with a `.cabal` file extension at the root of the tree, and it must match the cabal file blob key. The cabal file must be located at `pkgname.cabal`. Each tree can be in at most one package, and therefore tree keys work as package keys too. Note that with the above, a tree key is all the information necessary to uniquely identify a package. However, including additional information (package name, version, cabal key) in config files may be useful for optimizations or user friendliness. If such extra information is ever included, it must be validated to concur with the package contents itself. ### Package location Packages will optionally be sourced from some location: * __Hackage__ requires the package name, version number, and revision number. Each revision of a package will end up with a different tree key. * __Archive__ takes a URL pointing to a tarball (gzipped or not) or a ZIP file. An implicit assumption is that archives remain immutable over time. Use tree keys to verify this assumption. (Same applies to Hackage for that matter.) * __Repository__ takes a repo type (Git or Mercurial), URL, and commit. Assuming the veracity of the cryptographic hashes on the repos, this should guarantee a unique set of files. In order to deal with _megarepos_ (repos and archives containing more than one package), there is also a subdirectory for the archive and repository cases. An empty subdir `""` would be the case for a standard repo/archive. In order to meet the rules of a package listed above, the following logic is applied to all three types above: * Find all of the files in the raw location, and represent as `Map FilePath TreeEntry` (or equivalent). * Remove a wrapper directory. If _all_ filepaths in that `Map` are contained within the same directory, strip it from all of the paths. For example, if the paths are `foo/bar` and `foo/baz`, the paths will be reduced to `bar` and `baz`. * After this wrapper is removed, then subdirectory logic is applied, essentially applying `stripPrefix` to the filepaths. If the subdir is `yesod-bin` and files exist called `yesod-core/yesod-core.cabal` and `yesod-bin/yesod-bin.cabal`, the only file remaining after subdir stripping would be `yesod-bin.cabal`. Note that trailing slashes must be handled appropriately, and that an empty subdir string results in this step being a noop. The result of all of this is that, given one of the three package locations above, we can receive a tree key which will provide an installable package. That tree key will remain immutable. ### How tooling refers to packages We'll get to the caching mechanism for Pantry below. However, the recommended approach for tooling is to support some kind of composite of the Pantry keys, parsed info, and raw package location. This allows for more efficient lookups when available, with a fallback when mirrors don't have the needed information. An example: ```yaml extra-deps: - name: foobar version: 1.2.3.4 pantry: deadbeef # tree key cabal-file: 12345678 # blob key archive: https://example.com/foobar-1.2.3.4.tar.gz ``` It is also recommended that tooling provide an easy way to generate such complete information from, e.g., just the URL of the tarball, and that upon reading information, hashes, package names, and version numbers are all checked for correctness. ## Pantry caching One simplistic option for Pantry would be that, every time a piece of data is needed, Pantry downloads the necessary tarball/Git repo/etc. However, this would in practice be highly wasteful, since downloading Git repos and archives just to get a single cabal file (for plan construction purposes) is overkill. Instead, here's the basic idea for how caching works: * All data for Pantry can be stored in a SQL database. Local tools like Stack will use an SQLite database. Servers will use PostgreSQL. * We'll define a network protocol (initially just HTTP, maybe extending to something more efficient if desired) for querying blobs and trees. * When a blob or tree is needed, it is first checked for in the local SQLite cache. If it's not available there, a request to the Pantry mirrors (configurable) will be made for the data. Since everything is content addressable, it is safe to use untrusted mirrors. * If the data is not available in a mirror, and a location is provided, the location will be downloaded and cached locally. We may also allow these Pantry mirrors to provide some kind of query interface to find out, e.g., the latest version of a package on Hackage. That's still TBD. ## Example: resolving a package location To work through a full example, the following three stanzas are intended to have equivalent behavior: ```yaml - archive: https://example.com/foobar-1.2.3.4.tar.gz - name: foobar version: 1.2.3.4 pantry: deadbeef # tree key cabal-file: 12345678 # blob key archive: https://example.com/foobar-1.2.3.4.tar.gz - pantry: deadbeef ``` The question is: how does the first one (presumably what a user would want to enter) be resolved into the second and third? Pantry would follow this set of steps: * Download the tarball from the given URL * Place each file in the tarball into its store as a blob, getting a blob key for each. The tarball is now represented as `Map FilePath BlobKey` * Perform the root directory stripping step, removing a shared path * Since there's no subdirectory: no subdirectory stripping would be performed * Serialize the `Map FilePath BlobKey` to a binary format and take its hash to get a tree key * Store the tree in the store referenced by its tree key. In our example: the tree key is `deadbeef`. * Ensure that the tree is a valid package by checking for a single cabal file at the root. In our example, that's found in `foobar.cabal` with blob key `12345678`. * Parse the cabal file and ensure that it is a valid cabal file, and that its package name is `foobar`. Grab the version number (1.2.3.4). * We now know that tree key `deadbeef` is a valid package, and can refer to it by tree key exclusively. However, including the other information allows us to verify our assumptions, provide user-friendly readable data, and provide a fallback if the package isn't in the Pantry cache. ## More advanced content discovery There are three more advanced cases to consider: * Providing fall-back locations for content, such as out of concern for a single URL being removed in the future * Closed corporate setups, where access to the general internet may either be impossible or undesirable * Automatic discovery of missing content by hash The following extensions are possible to address these cases: * Instead of a single package location, provide a list of package locations with fallback semantics. * Corporate environments will be encouraged to run a local Pantry mirror, and configure clients like Stack to speak to these mirrors instead of the default ones (or in addition to). * Provide some kind of federation protocol for Pantry where servers can registry with each other and requests for content can be pinged to each other. Providing override at the client level for Pantry mirror locations is a __MUST__. Making it easy to run in a corporate environment is a __SHOULD__. Providing the fallback package locations seems easy enough that we should include it initially, but falls under a __SHOULD__. The federated protocol should be added on-demand. pantry-0.4.0.2/ChangeLog.md0000644000000000000000000000311513712326560013534 0ustar0000000000000000# Changelog for pantry ## v0.4.0.2 * Allow building with Cabal-3.2.* ## v0.4.0.1 * Removed errant log message ## v0.4.0.0 * Add a deprecation warning when using a repo/archive without a cabal file, see [Stack #5210](https://github.com/commercialhaskell/stack/issues/5210) * Do not include repo/archive dependencies which do not include cabal files in lock files * Remove some no longer used functions ## v0.3.0.0 * Upgrade to Cabal 3.0 ## v0.2.0.0 Bug fixes: * Don't compare the hashes of cabal files. Addresses bugs such as [Stack #5045](https://github.com/commercialhaskell/stack/issues/5045). Data type changes: removed the `pmCabal` and `rpmCabal` fields. ## v0.1.1.2 Bug fixes: * Module mapping insertions into the database are now atomic. Previously, if you SIGTERMed at the wrong time while running a script, you could end up with an inconsistent database state. ## v0.1.1.1 Other changes: * Support building with persistent-template-2.7 ## v0.1.1.0 **Changes since 0.1.0.0** Bug fixes: * Fix to allow dependencies on specific versions of local git repositories. See [#4862](https://github.com/commercialhaskell/stack/pull/4862) Behavior changes: * By default, do not perform expiry checks in Hackage Security. See [#4928](https://github.com/commercialhaskell/stack/issues/4928). Other changes: * Rename `pantry-tmp` package back to `pantry`, now that we have gained maintainership (which had been used by someone else for a candidate-only test that made it look like the name was free but prevented uploading a real package). ## 0.1.0.0 * Initial release pantry-0.4.0.2/attic/hpack-0.1.2.3.tar.gz0000644000000000000000000000026613712324605015503 0ustar0000000000000000\\ 0]{;sBoBRJ O Fع`|8vf%~S:I|I*usjZ{GC6y| n?SoS[e(:TR[-RKl$ѷu#D S(pantry-0.4.0.2/attic/package-0.1.2.3.tar.gz0000644000000000000000000000031513712324605016003 0ustar0000000000000000w#Z @a}yq;f(-:AoPWݬ g:K&'"=Ÿ{vTn/ɽX%y (?jIr:>҄ űbywGBzm|?K]y،xs۲I;QxoCST}zն)ѹ6ڦ^/\@H(pantry-0.4.0.2/attic/symlink-to-dir.tar.gz0000644000000000000000000000040413712324626016477 0ustar0000000000000000\\ۊ0`}$f&зIk }pSZ(%lAf7MJmNLҰ%Y!&k3AZ| oﮋ}qD5a:1_$#6AF_7seB&]緢ۇP.