1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
{-# 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 (..), fromGregorian )
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-22.9\n"
rslParent `shouldBe` RSLSynonym (LTS 22 9)
it "parses snapshot using 'snapshot'" $ do
RawSnapshotLayer{..} <- parseSl $
"name: 'test'\n" ++
"snapshot: lts-22.9\n"
rslParent `shouldBe` RSLSynonym (LTS 22 9)
it "throws if both 'resolver' and 'snapshot' are present" $ do
let go = parseSl $
"name: 'test'\n" ++
"resolver: lts-22.9\n" ++
"snapshot: lts-22.9\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-9.6.4\n"
rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [9, 6, 4]))
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-2024-02-04" $ do
let sn = Nightly $ fromGregorian 2024 2 4
loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn
sameUrl loc (defaultSnapshotLocation sn)
"https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2024/2/4.yaml"
it "default location for lts-22.9" $ do
let sn = LTS 22 9
loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn
sameUrl loc (defaultSnapshotLocation sn)
"https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/9.yaml"
|
