pantry-0.9.3: test/Pantry/TypesSpec.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Pantry.TypesSpec
( spec
) where
import Data.Aeson.WarningParser ( WithJSONWarnings (..) )
import qualified Data.ByteString.Char8 as S8
import qualified Data.Yaml as Yaml
import Distribution.Types.PackageName ( mkPackageName )
import Distribution.Types.Version ( mkVersion )
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Pantry
import qualified Pantry.SHA256 as SHA256
import Pantry.Types
( Tree (..), TreeEntry (..), parseTree, renderTree )
import RIO
import qualified RIO.Text as T
import RIO.Time ( Day (..) )
import Test.Hspec
import Text.RawString.QQ
hh :: HasCallStack => String -> Property -> Spec
hh name p = it name $ do
result <- check p
unless result $ throwString "Hedgehog property failed" :: IO ()
genBlobKey :: Gen BlobKey
genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> Gen.word (Range.linear 1 10000))
genSha256 :: Gen SHA256
genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500)
samplePLIRepo :: ByteString
samplePLIRepo =
[r|
subdir: wai
cabal-file:
# This is ignored, only included to make sure we get no warnings
size: 1765
sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410
name: wai
version: 3.2.1.2
git: https://github.com/yesodweb/wai.git
pantry-tree:
size: 714
sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2
commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0
|]
samplePLIRepo2 :: ByteString
samplePLIRepo2 =
[r|
name: merkle-log
version: 0.1.0.0
git: https://github.com/kadena-io/merkle-log.git
pantry-tree:
size: 615
sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d
commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376
|]
spec :: Spec
spec = do
describe "WantedCompiler" $ do
hh "parse/render works" $ property $ do
wc <- forAll $
let ghc = WCGhc <$> genVersion
ghcjs = WCGhcjs <$> genVersion <*> genVersion
genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100))
in Gen.choice [ghc, ghcjs]
let text = utf8BuilderToText $ display wc
case parseWantedCompiler text of
Left e -> throwIO e
Right actual -> liftIO $ actual `shouldBe` wc
describe "Tree" $ do
hh "parse/render works" $ property $ do
tree <- forAll $
let sfp = do
pieces <- Gen.list (Range.linear 1 10) sfpComponent
let combined = T.intercalate "/" pieces
case mkSafeFilePath combined of
Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces
Just sfp' -> pure sfp'
sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum
entry = TreeEntry
<$> genBlobKey
<*> Gen.choice (map pure [minBound..maxBound])
in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry)
let bs = renderTree tree
liftIO $ parseTree bs `shouldBe` Just tree
describe "(Raw)SnapshotLayer" $ do
let parseSl :: String -> IO RawSnapshotLayer
parseSl str = case Yaml.decodeThrow . S8.pack $ str of
(Just (WithJSONWarnings x _)) -> resolvePaths Nothing x
Nothing -> fail "Can't parse RawSnapshotLayer"
it "parses snapshot using 'resolver'" $ do
RawSnapshotLayer{..} <- parseSl $
"name: 'test'\n" ++
"resolver: lts-2.10\n"
rslParent `shouldBe` RSLSynonym (LTS 2 10)
it "parses snapshot using 'snapshot'" $ do
RawSnapshotLayer{..} <- parseSl $
"name: 'test'\n" ++
"snapshot: lts-2.10\n"
rslParent `shouldBe` RSLSynonym (LTS 2 10)
it "throws if both 'resolver' and 'snapshot' are present" $ do
let go = parseSl $
"name: 'test'\n" ++
"resolver: lts-2.10\n" ++
"snapshot: lts-2.10\n"
go `shouldThrow` anyException
it "throws if both 'snapshot' and 'compiler' are not present" $ do
let go = parseSl "name: 'test'\n"
go `shouldThrow` anyException
it "works if no 'snapshot' specified" $ do
RawSnapshotLayer{..} <- parseSl $
"name: 'test'\n" ++
"compiler: ghc-8.0.1\n"
rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1]))
hh "rendering 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 (RSLSynonym $ LTS major minor) `shouldBe`
Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor])
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 (RSLSynonym $ Nightly day) `shouldBe`
Yaml.String (T.pack $ "nightly-" ++ show day)
it "FromJSON instance for PLIRepo" $ do
WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo
warnings `shouldBe` []
pli <- resolvePaths Nothing unresolvedPli
let repoValue =
Repo
{ repoSubdir = "wai"
, repoType = RepoGit
, repoCommit =
"d11d63f1a6a92db8c637a8d33e7953ce6194a3e0"
, repoUrl = "https://github.com/yesodweb/wai.git"
}
pantrySha =
SHA256.fromHexBytes
"ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2"
psha <- case pantrySha of
Right psha -> pure psha
_ -> fail "Failed decoding sha256"
let pkgValue =
PackageMetadata
{ pmIdent =
PackageIdentifier
(mkPackageName "wai")
(mkVersion [3, 2, 1, 2])
, pmTreeKey = TreeKey (BlobKey psha (FileSize 714))
}
pli `shouldBe` PLIRepo repoValue pkgValue
WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli
warnings2 `shouldBe` []
reparsed' <- resolvePaths Nothing reparsed
reparsed' `shouldBe` pli
it "parseHackageText parses" $ do
let txt =
"persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058"
hsha =
SHA256.fromHexBytes
"df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1"
sha <- case hsha of
Right sha' -> pure sha'
_ -> fail "parseHackagetext: failed decoding the sha256"
let Right (pkgIdentifier, blobKey) = parseHackageText txt
blobKey `shouldBe` BlobKey sha (FileSize 5058)
pkgIdentifier `shouldBe`
PackageIdentifier
(mkPackageName "persistent")
(mkVersion [2, 8, 2])
it "roundtripping a PLIRepo" $ do
WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2
warnings `shouldBe` []
pli <- resolvePaths Nothing unresolvedPli
WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli
warnings2 `shouldBe` []
pli2 <- resolvePaths Nothing unresolvedPli2
pli2 `shouldBe` (pli :: PackageLocationImmutable)
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"