pantry 0.2.0.0 → 0.3.0.0

raw patch · 15 files changed

+642/−138 lines, 15 filesdep +casa-clientdep +casa-typesdep −arraydep −base-orphansdep −base64-bytestringdep ~Cabaldep ~aesondep ~hackage-securityPVP ok

version bump matches the API change (PVP)

Dependencies added: casa-client, casa-types

Dependencies removed: array, base-orphans, base64-bytestring, contravariant, deepseq, directory, filepath, ghc-prim, hashable, integer-gmp, mono-traversable, network, safe, syb, template-haskell, th-lift, th-lift-instances, th-orphans, th-reify-many, th-utilities

Dependency ranges changed: Cabal, aeson, hackage-security, persistent, persistent-template

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• README.md +1/−1
• pantry.cabal +11/−47
• src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +4/−2
• src/Pantry.hs +267/−26
• src/Pantry/Archive.hs +1/−0
• src/Pantry/Casa.hs +77/−0
• src/Pantry/Hackage.hs +38/−1
• src/Pantry/Internal.hs +1/−0
• src/Pantry/Internal/Stackage.hs +1/−9
• src/Pantry/SQLite.hs +1/−0
• src/Pantry/Storage.hs +59/−0
• src/Pantry/Tree.hs +1/−1
• src/Pantry/Types.hs +81/−51
• test/Pantry/CasaSpec.hs +95/−0

@@ -1,5 +1,9 @@ # Changelog for pantry +## v0.3.0.0++* Upgrade to Cabal 3.0+ ## v0.2.0.0  Bug fixes:

@@ -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.

@@ -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 <https://github.com/commercialhaskell/pantry#readme> 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

@@ -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]

@@ -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")

@@ -9,6 +9,7 @@   , getArchiveKey   , fetchArchivesRaw   , fetchArchives+  , findCabalOrHpackFile   ) where  import RIO

@@ -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

@@ -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

@@ -5,6 +5,7 @@   , renderTree   , Tree (..)   , TreeEntry (..)+  , FileType(..)   , mkSafeFilePath   , pcHpackExecutable   , normalizeParents

@@ -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   )

@@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-} module Pantry.SQLite   ( Storage (..)   , initStorage

@@ -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

@@ -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)

@@ -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

@@ -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+        }