pantry 0.4.0.2 → 0.5.0.0

raw patch · 7 files changed

+148/−82 lines, 7 filesdep ~aesondep ~persistentdep ~persistent-templatePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, persistent, persistent-template

API changes (from Hackage documentation)

Files

• ChangeLog.md +2/−2
• pantry.cabal +3/−2
• src/Pantry.hs +18/−5
• src/Pantry/Internal/Stackage.hs +4/−0
• src/Pantry/Types.hs +86/−67
• test/Pantry/TypesSpec.hs +25/−6
• test/PantrySpec.hs +10/−0

@@ -1,8 +1,8 @@ # Changelog for pantry -## v0.4.0.2+## v0.5.0.0 -* Allow building with Cabal-3.2.*+* Make the location of LTS/Nightly snapshots configurable  ## v0.4.0.1 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: cb17eb4ba27f5fad8ef492276362b6be7533e390279b5e6a857fa89a753da4a1+-- hash: 39397f3a78104fe1a4f1ef80cbd0e8af1fbaf10a9b5b4e18303bf7a3eafabc09  name:           pantry-version:        0.4.0.2+version:        0.5.0.0 synopsis:       Content addressable Haskell package management description:    Please see the README on Github at <https://github.com/commercialhaskell/pantry#readme> category:       Development@@ -128,6 +128,7 @@       Pantry.InternalSpec       Pantry.TreeSpec       Pantry.TypesSpec+      PantrySpec       Paths_pantry   hs-source-dirs:       test

@@ -14,6 +14,7 @@   , defaultHackageSecurityConfig   , defaultCasaRepoPrefix   , defaultCasaMaxPerRequest+  , defaultSnapshotLocation   , HasPantryConfig (..)   , withPantryConfig   , HpackExecutable (..)@@ -87,6 +88,8 @@   , SnapshotLayer (..)   , toRawSnapshotLayer   , WantedCompiler (..)+  , SnapName (..)+  , snapshotLocation      -- * Loading values   , resolvePaths@@ -111,6 +114,7 @@      -- * Parsers   , parseWantedCompiler+  , parseSnapName   , parseRawSnapshotLocation   , parsePackageIdentifierRevision   , parseHackageText@@ -123,10 +127,6 @@   , parseVersion   , parseVersionThrowing -    -- * Stackage snapshots-  , ltsSnapshotLocation-  , nightlySnapshotLocation-     -- * Cabal helpers   , packageIdentifierString   , packageNameString@@ -239,10 +239,12 @@   -- ^ The casa pull URL e.g. https://casa.fpcomplete.com/v1/pull.   -> Int   -- ^ Max casa keys to pull per request.+  -> (SnapName -> RawSnapshotLocation)+  -- ^ The location of snapshot synonyms   -> (PantryConfig -> RIO env a)   -- ^ What to do with the config   -> RIO env a-withPantryConfig root hsc he count pullURL maxPerRequest inner = do+withPantryConfig root hsc he count pullURL maxPerRequest snapLoc inner = do   env <- ask   pantryRelFile <- parseRelFile "pantry.sqlite3"   -- Silence persistent's logging output, which is really noisy@@ -261,6 +263,7 @@       , pcParsedCabalFilesMutable = ref2       , pcCasaRepoPrefix = pullURL       , pcCasaMaxPerRequest = maxPerRequest+      , pcSnapshotLocation = snapLoc       }  -- | Default pull URL for Casa.@@ -1036,6 +1039,8 @@ completeSnapshotLocation (RSLUrl url Nothing) = do   bs <- loadFromURL url Nothing   pure $ SLUrl url (bsToBlobKey bs)+completeSnapshotLocation (RSLSynonym syn) =+  completeSnapshotLocation =<< snapshotLocation syn  traverseConcurrently_   :: (Foldable f, HasPantryConfig env)@@ -1424,6 +1429,12 @@     value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp     snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp     pure $ Right (snapshot, CompletedSL rsl (SLFilePath fp))+loadRawSnapshotLayer rsl@(RSLSynonym syn) = do+  loc <- snapshotLocation syn+  comp <- loadRawSnapshotLayer loc+  pure $ case comp of+    Left wc -> Left wc+    Right (l, CompletedSL _ n) -> Right (l, CompletedSL rsl n)  -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. --@@ -1665,6 +1676,7 @@     maxConnCount     casaRepoPrefix     casaMaxPerRequest+    defaultSnapshotLocation     $ \pc ->       runRIO         PantryApp@@ -1691,6 +1703,7 @@     8     defaultCasaRepoPrefix     defaultCasaMaxPerRequest+    defaultSnapshotLocation     $ \pc ->       runRIO         PantryApp

@@ -31,6 +31,10 @@   , storeBlob   , migrateAll   , Key(unBlobKey)+  , allHackageCabalCount+  , allBlobsSource+  , allBlobsCount+  , allHackageCabalRawPackageLocations   ) import Pantry.Types as X   ( ModuleNameP(..)

@@ -86,8 +86,10 @@   , HpackExecutable (..)   , WantedCompiler (..)   --, resolveSnapshotLocation-  , ltsSnapshotLocation-  , nightlySnapshotLocation+  , snapshotLocation+  , defaultSnapshotLocation+  , SnapName (..)+  , parseSnapName   , RawSnapshotLocation (..)   , SnapshotLocation (..)   , toRawSL@@ -117,7 +119,7 @@ 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 RIO.Time (toGregorian, Day, UTCTime) import qualified RIO.Map as Map import qualified RIO.HashMap as HM import qualified Data.Map.Strict as Map (mapKeysMonotonic)@@ -250,8 +252,18 @@   -- ^ The pull URL e.g. @https://casa.fpcomplete.com/v1/pull@   , pcCasaMaxPerRequest :: !Int   -- ^ Maximum blobs sent per pull request.+  , pcSnapshotLocation :: SnapName -> RawSnapshotLocation+  -- ^ The location of snapshot synonyms   } +-- | Get the location of a snapshot synonym from the 'PantryConfig'.+--+-- @since 0.5.0.0+snapshotLocation :: HasPantryConfig env => SnapName -> RIO env RawSnapshotLocation+snapshotLocation name = do+  loc <- view $ pantryConfigL.to pcSnapshotLocation+  pure $ loc name+ -- | Should we print warnings when loading a cabal file? -- -- @since 0.1.0.0@@ -842,6 +854,7 @@   | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])]   | MigrationFailure !Text !(Path Abs File) !SomeException   | InvalidTreeFromCasa !BlobKey !ByteString+  | ParseSnapNameException !Text    deriving Typeable instance Exception PantryException where@@ -1026,6 +1039,7 @@     "\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."+  display (ParseSnapNameException t) = "Invalid snapshot name: " <> display t  data FuzzyResults   = FRNameNotFound ![PackageName]@@ -1845,9 +1859,7 @@  instance Display SnapshotLocation where   display (SLCompiler compiler) = display compiler-  display (SLUrl url blob) =-    fromMaybe (display url) (specialRawSnapshotLocation url) <>-    " (" <> display blob <> ")"+  display (SLUrl url blob) = display url <> " (" <> display blob <> ")"   display (SLFilePath resolved) = display (resolvedRelative resolved)  -- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'.@@ -1856,22 +1868,10 @@ parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $   (either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0)) <|>-  parseLts <|>-  parseNightly <|>+  (pure <$> RSLSynonym <$> parseSnapName t0) <|>   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@@ -1909,29 +1909,75 @@ defRepo :: Text defRepo = "stackage-snapshots" --- | Location of an LTS snapshot+-- | Default location of snapshot synonyms+-- , i.e. commercialhaskell's GitHub repository. ----- @since 0.1.0.0-ltsSnapshotLocation-  :: Int -- ^ major version-  -> Int -- ^ minor version+-- @since 0.5.0.0+defaultSnapshotLocation+  :: SnapName   -> RawSnapshotLocation-ltsSnapshotLocation x y =+defaultSnapshotLocation (LTS 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 =+defaultSnapshotLocation (Nightly date) =   githubSnapshotLocation defUser defRepo $   utf8BuilderToText $   "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml"   where     (year, month, day) = toGregorian date +-- | A snapshot synonym.+-- It is expanded according to the field 'snapshotLocation'+-- of a 'PantryConfig'.+--+-- @ since 0.5.0.0+data SnapName+    -- | LTS Haskell snapshot,+    -- displayed as @"lts-maj.min"@.+    --+    -- @since 0.5.0.0+    = LTS+        !Int -- ^ Major version +        !Int -- ^ Minor version+    -- | Stackage Nightly snapshot,+    -- displayed as @"nighly-YYYY-MM-DD"@.+    --+    -- @since 0.5.0.0+    | Nightly !Day+    deriving (Eq, Ord, Generic)++instance NFData SnapName++instance Display SnapName where+  display (LTS x y) = "lts-" <> display x <> "." <> display y+  display (Nightly date) = "nightly-" <> displayShow date++instance Show SnapName where+  show = T.unpack . utf8BuilderToText . display++instance ToJSON SnapName where+  toJSON syn = String $ utf8BuilderToText $ display syn++-- | Parse the short representation of a 'SnapName'.+--+-- @since 0.5.0.0+parseSnapName :: MonadThrow m => Text -> m SnapName+parseSnapName t0 =+    case lts <|> nightly of+        Nothing -> throwM $ ParseSnapNameException t0+        Just sn -> return sn+  where+    lts = do+        t1 <- T.stripPrefix "lts-" t0+        Right (x, t2) <- Just $ decimal t1+        t3 <- T.stripPrefix "." t2+        Right (y, "") <- Just $ decimal t3+        return $ LTS x y+    nightly = do+        t1 <- T.stripPrefix "nightly-" t0+        Nightly <$> readMaybe (T.unpack t1)+ -- | Where to load a snapshot from in raw form -- (RSUrl could have a missing BlobKey) --@@ -1951,56 +1997,29 @@     -- ^ Snapshot at a local file path.     --     -- @since 0.1.0.0+  | RSLSynonym !SnapName+    -- ^ Snapshot synonym (LTS/Nightly).+    --+    -- @since 0.5.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 (RSLUrl url Nothing) = display url+  display (RSLUrl url (Just blob)) = display 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+  display (RSLSynonym syn) = display syn+    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]+  toJSON (RSLSynonym syn) = toJSON syn  -- | Where to load a snapshot from. --

@@ -114,13 +114,13 @@       RawSnapshotLayer{..} <- parseSl $         "name: 'test'\n" ++         "resolver: lts-2.10\n"-      rslParent `shouldBe` ltsSnapshotLocation 2 10+      rslParent `shouldBe` (RSLSynonym $ LTS 2 10)      it "parses snapshot using 'snapshot'" $ do       RawSnapshotLayer{..} <- parseSl $         "name: 'test'\n" ++         "snapshot: lts-2.10\n"-      rslParent `shouldBe` ltsSnapshotLocation 2 10+      rslParent `shouldBe` (RSLSynonym $ LTS 2 10)      it "throws if both 'resolver' and 'snapshot' are present" $ do       let go = parseSl $@@ -139,19 +139,19 @@         "compiler: ghc-8.0.1\n"       rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1])) -    hh "rendering an LTS gives a nice name" $ property $ do+    hh "rendering the name of an LTS to JSON" $ 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.toJSON (RSLSynonym $ LTS major minor) `shouldBe`         Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor]) -    hh "rendering a nightly gives a nice name" $ property $ do+    hh "rendering the name of a nightly to JSON" $ property $ do       days <- forAll $ Gen.integral $ Range.linear 1 10000000       let day = ModifiedJulianDay days       liftIO $-        Yaml.toJSON (nightlySnapshotLocation day) `shouldBe`+        Yaml.toJSON (RSLSynonym $ Nightly day) `shouldBe`         Yaml.String (T.pack $ "nightly-" ++ show day)     it "FromJSON instance for PLIRepo" $ do       WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo@@ -208,3 +208,22 @@       warnings2 `shouldBe` []       pli2 <- resolvePaths Nothing unresolvedPli2       pli2 `shouldBe` (pli :: PackageLocationImmutable)++  describe "completeSnapshotLocation" $ do+    let sameUrl (SLUrl txt _) (RSLUrl txt' _) txt'' =+          do+          txt `shouldBe` txt'+          txt `shouldBe` txt''+        sameUrl _ _ _ = liftIO $ error "Snapshot synonym did not complete as expected"++    it "default location for nightly-2020-01-01" $ do+      let sn = Nightly $ ModifiedJulianDay 58849+      loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn+      sameUrl loc (defaultSnapshotLocation sn)+        "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/1/1.yaml"++    it "default location for lts-15.1" $ do+      let sn = LTS 15 1+      loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn+      sameUrl loc (defaultSnapshotLocation sn)+        "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml"

@@ -0,0 +1,10 @@+{-# LANGUAGE NoImplicitPrelude #-}+module PantrySpec (spec) where++import Test.Hspec+import Pantry+import RIO++spec :: Spec+spec = do+  it "vacuums" $ runPantryAppClean pantryVacuum