pantry-0.5.7: test/Pantry/TypesSpec.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Pantry.TypesSpec
( spec
) where
import Pantry.Internal.AesonExtended
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 Pantry.Internal
( Tree(..)
, TreeEntry(..)
, mkSafeFilePath
, parseTree
, renderTree
)
import qualified Pantry.SHA256 as SHA256
import RIO
import qualified RIO.Text as T
import Test.Hspec
import Text.RawString.QQ
import RIO.Time (Day (..))
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"