diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for pantry +## v0.3.0.0 + +* Upgrade to Cabal 3.0 + ## v0.2.0.0 Bug fixes: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # pantry -TODO: Add Travis and AppVeyor badges +[![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. diff --git a/pantry.cabal b/pantry.cabal --- a/pantry.cabal +++ b/pantry.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.32.0. -- -- see: https://github.com/sol/hpack -- --- hash: abfcc422864de256ba0ef8b533df725b381cffd7791dca94f17303a16e69a2a3 +-- hash: 66b17dc690d946f2a8ece380f0bd2b576e16f19d1f63e5a163eb2d6c7c81f1fa name: pantry -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Content addressable Haskell package management description: Please see the README on Github at category: Development @@ -48,47 +48,37 @@ Pantry.Repo Pantry.SQLite Pantry.Storage + Pantry.Casa Pantry.Tree Pantry.Types hs-source-dirs: src/ - default-extensions: MonadFailDesugaring ghc-options: -Wall build-depends: - Cabal + Cabal >=3 && <3.1 , aeson , ansi-terminal - , array , base >=4.10 && <5 - , base-orphans - , base64-bytestring , bytestring + , casa-client + , casa-types , conduit , conduit-extra , containers - , contravariant , cryptonite , cryptonite-conduit - , deepseq , digest - , directory , filelock - , filepath , generic-deriving - , ghc-prim , hackage-security - , hashable , hpack >=0.31.2 , http-client , http-client-tls , http-conduit , http-download , http-types - , integer-gmp , memory - , mono-traversable , mtl - , network , network-uri , path , path-io @@ -100,17 +90,9 @@ , rio , rio-orphans , rio-prettyprint - , safe - , syb , tar-conduit - , template-haskell , text , text-metrics - , th-lift - , th-lift-instances - , th-orphans - , th-reify-many - , th-utilities , time , transformers , unix-compat @@ -138,6 +120,7 @@ Pantry.ArchiveSpec Pantry.BuildPlanSpec Pantry.CabalSpec + Pantry.CasaSpec Pantry.FileSpec Pantry.GlobalHintsSpec Pantry.HackageSpec @@ -148,34 +131,26 @@ Paths_pantry hs-source-dirs: test - default-extensions: MonadFailDesugaring ghc-options: -Wall build-depends: - Cabal + Cabal >=3 && <3.1 , QuickCheck , aeson , ansi-terminal - , array , base >=4.10 && <5 - , base-orphans - , base64-bytestring , bytestring + , casa-client + , casa-types , conduit , conduit-extra , containers - , contravariant , cryptonite , cryptonite-conduit - , deepseq , digest - , directory , exceptions , filelock - , filepath , generic-deriving - , ghc-prim , hackage-security - , hashable , hedgehog , hpack >=0.31.2 , hspec @@ -184,11 +159,8 @@ , http-conduit , http-download , http-types - , integer-gmp , memory - , mono-traversable , mtl - , network , network-uri , pantry , path @@ -202,17 +174,9 @@ , rio , rio-orphans , rio-prettyprint - , safe - , syb , tar-conduit - , template-haskell , text , text-metrics - , th-lift - , th-lift-instances - , th-orphans - , th-reify-many - , th-utilities , time , transformers , unix-compat diff --git a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs --- a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +++ b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs @@ -22,7 +22,6 @@ import Hackage.Security.Client hiding (Header) import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked -import qualified Hackage.Security.Util.Lens as Lens {------------------------------------------------------------------------------- Top-level API @@ -133,7 +132,10 @@ finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))] insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] - insert x y = Lens.modify (Lens.lookupM x) (++ y) + 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] diff --git a/src/Pantry.hs b/src/Pantry.hs --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Content addressable Haskell package management, providing for @@ -11,6 +12,8 @@ PantryConfig , HackageSecurityConfig (..) , defaultHackageSecurityConfig + , defaultCasaRepoPrefix + , defaultCasaMaxPerRequest , HasPantryConfig (..) , withPantryConfig , HpackExecutable (..) @@ -19,6 +22,7 @@ , PantryApp , runPantryApp , runPantryAppClean + , runPantryAppWith , hpackExecutableL -- * Types @@ -87,6 +91,7 @@ -- * Loading values , resolvePaths , loadPackageRaw + , tryLoadPackageRawViaCasa , loadPackage , loadRawSnapshotLayer , loadSnapshotLayer @@ -171,6 +176,7 @@ , withSnapshotCache ) where +import Database.Persist (entityKey) import RIO import Conduit import Control.Arrow (right) @@ -182,17 +188,19 @@ 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 +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.Common (PWarning (..), showPos) +import Distribution.Parsec (PWarning (..), showPos) import qualified Hpack import qualified Hpack.Config as Hpack import Network.HTTP.Download @@ -206,6 +214,7 @@ import Data.Monoid (Endo (..)) import Pantry.HTTP import Data.Char (isHexDigit) +import Data.Time (getCurrentTime, diffUTCTime) -- | Create a new 'PantryConfig' with the given settings. -- @@ -225,10 +234,14 @@ -- 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 inner = do +withPantryConfig root hsc he count pullURL maxPerRequest inner = do env <- ask pantryRelFile <- parseRelFile "pantry.sqlite3" -- Silence persistent's logging output, which is really noisy @@ -245,8 +258,22 @@ , 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 @@ -327,12 +354,98 @@ treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) return $ Just (revision, cfKey, treeKey') -fetchTreeKeys - :: (HasPantryConfig env, HasLogFunc env, Foldable f) - => f TreeKey +-- | Fetch keys and blobs and insert into the database where possible. +fetchTreeKeys :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [RawPackageLocationImmutable] -> RIO env () -fetchTreeKeys _ = - logWarn "Network caching not yet implemented!" -- TODO pantry wire +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 @@ -344,7 +457,7 @@ => f PackageLocationImmutable -> RIO env () fetchPackages pls = do - fetchTreeKeys $ map getTreeKey $ toList pls + fetchTreeKeys (fmap toRawPLI (toList pls)) traverseConcurrently_ (void . uncurry getHackageTarball) hackages -- TODO in the future, be concurrent in these as well fetchArchives archives @@ -662,7 +775,6 @@ mbs <- withStorage $ loadBlob cabalBlobKey case mbs of Nothing -> do - -- TODO when we have pantry wire, try downloading throwIO $ TreeReferencesMissingBlob (toRawPLI pl) sfp cabalBlobKey Just bs -> pure bs @@ -686,7 +798,6 @@ mbs <- withStorage $ loadBlob cabalBlobKey case mbs of Nothing -> do - -- TODO when we have pantry wire, try downloading throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey Just bs -> pure bs @@ -697,22 +808,91 @@ :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env Package -loadPackage (PLIHackage ident cfHash tree) = - htrPackage <$> getHackageTarball (pirForHash ident cfHash) (Just tree) -loadPackage pli@(PLIArchive archive pm) = getArchivePackage (toRawPLI pli) (toRawArchive archive) (toRawPM pm) -loadPackage (PLIRepo repo pm) = getRepo repo (toRawPM pm) +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 (RPLIHackage pir mtree) = htrPackage <$> getHackageTarball pir mtree -loadPackageRaw rpli@(RPLIArchive archive pm) = getArchivePackage rpli archive pm -loadPackageRaw (RPLIRepo repo rpm) = getRepo repo rpm +loadPackageRaw rpli = + 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))) + -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. -- -- @since 0.1.0.0 @@ -738,10 +918,33 @@ treeKey' <- getHackageTarballKey pir pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' completePackageLocation pl@(RPLIArchive archive rpm) = do - -- getArchive checks archive and package metadata - (sha, size, package) <- getArchive pl archive rpm - let RawArchive loc _ _ subdir = archive - pure $ PLIArchive (Archive loc sha size subdir) (packagePM package) + 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 $ PLIArchive (Archive loc sha256 fileSize subdir) (packagePM package) + 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 + pure $ PLIArchive (Archive loc sha size subdir) (packagePM package) + 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 PLIRepo repo <$> completePM pl rpm @@ -1268,9 +1471,26 @@ loadFromURL url (Just bkey) = do mcached <- withStorage $ loadBlob bkey case mcached of - Just bs -> return bs - Nothing -> loadWithCheck url (Just bkey) + 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 @@ -1284,6 +1504,7 @@ (_, _, 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 @@ -1434,7 +1655,15 @@ -- -- @since 0.1.0.0 runPantryApp :: MonadIO m => RIO PantryApp a -> m a -runPantryApp f = runSimpleApp $ do +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" @@ -1442,7 +1671,9 @@ root defaultHackageSecurityConfig HpackBundled - 8 + maxConnCount + casaRepoPrefix + casaMaxPerRequest $ \pc -> runRIO PantryApp @@ -1467,6 +1698,8 @@ defaultHackageSecurityConfig HpackBundled 8 + defaultCasaRepoPrefix + defaultCasaMaxPerRequest $ \pc -> runRIO PantryApp @@ -1584,3 +1817,11 @@ 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") diff --git a/src/Pantry/Archive.hs b/src/Pantry/Archive.hs --- a/src/Pantry/Archive.hs +++ b/src/Pantry/Archive.hs @@ -9,6 +9,7 @@ , getArchiveKey , fetchArchivesRaw , fetchArchives + , findCabalOrHpackFile ) where import RIO diff --git a/src/Pantry/Casa.hs b/src/Pantry/Casa.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Casa.hs @@ -0,0 +1,77 @@ +{-# 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 diff --git a/src/Pantry/Hackage.hs b/src/Pantry/Hackage.hs --- a/src/Pantry/Hackage.hs +++ b/src/Pantry/Hackage.hs @@ -20,6 +20,7 @@ import RIO import RIO.Process +import Pantry.Casa import Data.Aeson import Conduit import Data.Conduit.Tar @@ -382,9 +383,45 @@ where inner = case cfi of - CFIHash sha _msize -> withStorage $ loadBlobBySHA sha + 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 diff --git a/src/Pantry/Internal.hs b/src/Pantry/Internal.hs --- a/src/Pantry/Internal.hs +++ b/src/Pantry/Internal.hs @@ -5,6 +5,7 @@ , renderTree , Tree (..) , TreeEntry (..) + , FileType(..) , mkSafeFilePath , pcHpackExecutable , normalizeParents diff --git a/src/Pantry/Internal/Stackage.hs b/src/Pantry/Internal/Stackage.hs --- a/src/Pantry/Internal/Stackage.hs +++ b/src/Pantry/Internal/Stackage.hs @@ -17,7 +17,6 @@ , PackageName , PackageNameId , Tree(..) - , TreeEntry(..) , TreeEntryId , TreeId , Unique(..) @@ -29,10 +28,8 @@ , getTreeForKey , getVersionId , loadBlobById - , allBlobsSource - , allBlobsCount + , storeBlob , migrateAll - , treeCabal , Key(unBlobKey) ) import Pantry.Types as X @@ -43,11 +40,6 @@ , Storage(..) , VersionP(..) , mkSafeFilePath - , packageNameString , packageTreeKey - , parsePackageName - , parseVersion - , parseVersionThrowing , unSafeFilePath - , versionString ) diff --git a/src/Pantry/SQLite.hs b/src/Pantry/SQLite.hs --- a/src/Pantry/SQLite.hs +++ b/src/Pantry/SQLite.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} module Pantry.SQLite ( Storage (..) , initStorage diff --git a/src/Pantry/Storage.hs b/src/Pantry/Storage.hs --- a/src/Pantry/Storage.hs +++ b/src/Pantry/Storage.hs @@ -13,6 +13,8 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} module Pantry.Storage ( SqlBackend , initStorage @@ -23,7 +25,9 @@ , loadBlobById , loadBlobBySHA , allBlobsSource + , allHackageCabalRawPackageLocations , allBlobsCount + , allHackageCabalCount , getBlobKey , loadURLBlob , storeURLBlob @@ -368,8 +372,63 @@ 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 diff --git a/src/Pantry/Tree.hs b/src/Pantry/Tree.hs --- a/src/Pantry/Tree.hs +++ b/src/Pantry/Tree.hs @@ -15,7 +15,7 @@ import RIO.FilePath ((), takeDirectory) import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) import Path (Path, Abs, Dir, toFilePath) -import Distribution.Parsec.Common (PWarning (..)) +import Distribution.Parsec (PWarning (..)) import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Parsec import Path (File) diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs --- a/src/Pantry/Types.hs +++ b/src/Pantry/Types.hs @@ -42,6 +42,7 @@ , Tree (..) , renderTree , parseTree + , parseTreeM , SHA256 , Unresolved , resolvePaths @@ -114,7 +115,6 @@ import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL -import RIO.Char (isSpace) import RIO.List (intersperse) import RIO.Time (toGregorian, Day, fromGregorianValid, UTCTime) import qualified RIO.Map as Map @@ -130,17 +130,18 @@ import Database.Persist.Sql import Pantry.SHA256 (SHA256) import qualified Pantry.SHA256 as SHA256 -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.CharParsing as Parse import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) -import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) +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) +import Distribution.Types.Version (Version, mkVersion, nullVersion) import Network.HTTP.Client (parseRequest) import Network.HTTP.Types (Status, statusCode) import Data.Text.Read (decimal) @@ -148,6 +149,7 @@ 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. -- @@ -243,6 +245,10 @@ -- 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? @@ -464,7 +470,7 @@ case i :: Int32 of 1 -> pure RepoGit 2 -> pure RepoHg - _ -> fail $ "Invalid RepoType: " ++ show i + _ -> Left $ fromString $ "Invalid RepoType: " ++ show i instance PersistFieldSql RepoType where sqlType _ = SqlInt32 @@ -717,25 +723,23 @@ -- -- @since 0.1.0.0 parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) -parseHackageText t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do - let (identT, cfiT) = T.break (== '@') t - PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT - (csha, csize) <- - 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 -> Nothing - Just sizeT' -> - case decimal sizeT' of - Right (size', "") -> Just $ (sha, FileSize size') - _ -> Nothing - pure msize - _ -> Nothing - pure $ (PackageIdentifier name version, BlobKey csha csize) +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' @@ -836,12 +840,14 @@ | 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 @@ -1055,12 +1061,21 @@ cabalSpecLatestVersion :: Version cabalSpecLatestVersion = case cabalSpecLatest of - CabalSpecOld -> error "this cannot happen" + 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 -> mkVersion [2, 4] + 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 @@ -1167,6 +1182,12 @@ 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 @@ -1239,21 +1260,21 @@ -- | 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 defaul value +-- present while Cabal uses "null version" as a default value -- -- @since 0.1.0.0 parsePackageIdentifier :: String -> Maybe PackageIdentifier -parsePackageIdentifier str = - case [p | (p, s) <- Parse.readP_to_S parser str, all isSpace s] of - [] -> Nothing - (p:_) -> Just p - where - parser = do - n <- Distribution.Text.parse - -- version is a required component of a package identifier for Stack - v <- Parse.char '-' >> Distribution.Text.parse - return (PackageIdentifier n v) +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 @@ -1438,22 +1459,31 @@ parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation) parseArchiveLocationObject o = - ((o ..: "url") >>= validateUrl) <|> - ((o ..: "filepath") >>= validateFilePath) <|> - ((o ..: "archive") >>= parseArchiveLocationText) <|> - ((o ..: "location") >>= parseArchiveLocationText) + ((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) --- Forgive me my father, for I have sinned (bad fail, bad!) -parseArchiveLocationText :: (Monad m, Alternative m) => Text -> m (Unresolved ArchiveLocation) -parseArchiveLocationText t = validateUrl t <|> validateFilePath t +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 :: Monad m => Text -> m (Unresolved ArchiveLocation) +validateUrl :: Text -> Either Text (Unresolved ArchiveLocation) validateUrl t = case parseRequest $ T.unpack t of - Left _ -> fail $ "Could not parse URL: " ++ T.unpack t + Left _ -> Left $ "Could not parse URL: " <> t Right _ -> pure $ pure $ ALUrl t -validateFilePath :: Monad m => Text -> m (Unresolved ArchiveLocation) +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 -> @@ -1462,7 +1492,7 @@ Just dir -> do abs' <- resolveFile dir $ T.unpack t pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' - else fail $ "Does not have an archive file extension: " ++ T.unpack t + else Left $ "Does not have an archive file extension: " <> t instance ToJSON RawPackageLocation where toJSON (RPLImmutable rpli) = toJSON rpli @@ -1578,8 +1608,8 @@ http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> case parseArchiveLocationText t of - Nothing -> fail $ "Invalid archive location: " ++ T.unpack t - Just (Unresolved mkArchiveLocation) -> + Left _ -> fail $ "Invalid archive location: " ++ T.unpack t + Right (Unresolved mkArchiveLocation) -> pure $ noJSONWarnings $ Unresolved $ \mdir -> do raLocation <- mkArchiveLocation mdir let raHash = Nothing @@ -1686,9 +1716,9 @@ unCabalStringMap :: Map (CabalString a) v -> Map a v unCabalStringMap = Map.mapKeysMonotonic unCabalString -instance Distribution.Text.Text a => ToJSON (CabalString a) where +instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where toJSON = toJSON . Distribution.Text.display . unCabalString -instance Distribution.Text.Text a => ToJSONKey (CabalString a) where +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 diff --git a/test/Pantry/CasaSpec.hs b/test/Pantry/CasaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/CasaSpec.hs @@ -0,0 +1,95 @@ +{-# 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 + (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 + }