diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/pantry.cabal b/pantry.cabal --- a/pantry.cabal +++ b/pantry.cabal @@ -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 category: Development @@ -128,6 +128,7 @@ Pantry.InternalSpec Pantry.TreeSpec Pantry.TypesSpec + PantrySpec Paths_pantry hs-source-dirs: test diff --git a/src/Pantry.hs b/src/Pantry.hs --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -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 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 @@ -31,6 +31,10 @@ , storeBlob , migrateAll , Key(unBlobKey) + , allHackageCabalCount + , allBlobsSource + , allBlobsCount + , allHackageCabalRawPackageLocations ) import Pantry.Types as X ( ModuleNameP(..) diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs --- a/src/Pantry/Types.hs +++ b/src/Pantry/Types.hs @@ -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. -- diff --git a/test/Pantry/TypesSpec.hs b/test/Pantry/TypesSpec.hs --- a/test/Pantry/TypesSpec.hs +++ b/test/Pantry/TypesSpec.hs @@ -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" diff --git a/test/PantrySpec.hs b/test/PantrySpec.hs new file mode 100644 --- /dev/null +++ b/test/PantrySpec.hs @@ -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