1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE QuasiQuotes #-}
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
8
9module Pantry.TypesSpec
10    ( spec
11    ) where
12
13import Pantry.Internal.AesonExtended
14import qualified Data.ByteString.Char8 as S8
15import qualified Data.Yaml as Yaml
16import Distribution.Types.PackageName (mkPackageName)
17import Distribution.Types.Version (mkVersion)
18import Hedgehog
19import qualified Hedgehog.Gen as Gen
20import qualified Hedgehog.Range as Range
21import Pantry
22import Pantry.Internal
23    ( Tree(..)
24    , TreeEntry(..)
25    , mkSafeFilePath
26    , parseTree
27    , renderTree
28    )
29import qualified Pantry.SHA256 as SHA256
30import RIO
31import qualified RIO.Text as T
32import Test.Hspec
33import Text.RawString.QQ
34import RIO.Time (Day (..))
35
36hh :: HasCallStack => String -> Property -> Spec
37hh name p = it name $ do
38  result <- check p
39  unless result $ throwString "Hedgehog property failed" :: IO ()
40
41genBlobKey :: Gen BlobKey
42genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000)))
43
44genSha256 :: Gen SHA256
45genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500)
46
47samplePLIRepo :: ByteString
48samplePLIRepo =
49    [r|
50subdir: wai
51cabal-file:
52  # This is ignored, only included to make sure we get no warnings
53  size: 1765
54  sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410
55name: wai
56version: 3.2.1.2
57git: https://github.com/yesodweb/wai.git
58pantry-tree:
59  size: 714
60  sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2
61commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0
62|]
63
64samplePLIRepo2 :: ByteString
65samplePLIRepo2 =
66    [r|
67name: merkle-log
68version: 0.1.0.0
69git: https://github.com/kadena-io/merkle-log.git
70pantry-tree:
71  size: 615
72  sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d
73commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376
74|]
75
76spec :: Spec
77spec = do
78  describe "WantedCompiler" $ do
79    hh "parse/render works" $ property $ do
80      wc <- forAll $
81        let ghc = WCGhc <$> genVersion
82            ghcjs = WCGhcjs <$> genVersion <*> genVersion
83            genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100))
84         in Gen.choice [ghc, ghcjs]
85      let text = utf8BuilderToText $ display wc
86      case parseWantedCompiler text of
87        Left e -> throwIO e
88        Right actual -> liftIO $ actual `shouldBe` wc
89
90  describe "Tree" $ do
91    hh "parse/render works" $ property $ do
92      tree <- forAll $
93        let sfp = do
94              pieces <- Gen.list (Range.linear 1 10) sfpComponent
95              let combined = T.intercalate "/" pieces
96              case mkSafeFilePath combined of
97                Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces
98                Just sfp' -> pure sfp'
99            sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum
100            entry = TreeEntry
101              <$> genBlobKey
102              <*> Gen.choice (map pure [minBound..maxBound])
103         in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry)
104      let bs = renderTree tree
105      liftIO $ parseTree bs `shouldBe` Just tree
106
107  describe "(Raw)SnapshotLayer" $ do
108    let parseSl :: String -> IO RawSnapshotLayer
109        parseSl str = case Yaml.decodeThrow . S8.pack $ str of
110          (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x
111          Nothing -> fail "Can't parse RawSnapshotLayer"
112
113    it "parses snapshot using 'resolver'" $ do
114      RawSnapshotLayer{..} <- parseSl $
115        "name: 'test'\n" ++
116        "resolver: lts-2.10\n"
117      rslParent `shouldBe` (RSLSynonym $ LTS 2 10)
118
119    it "parses snapshot using 'snapshot'" $ do
120      RawSnapshotLayer{..} <- parseSl $
121        "name: 'test'\n" ++
122        "snapshot: lts-2.10\n"
123      rslParent `shouldBe` (RSLSynonym $ LTS 2 10)
124
125    it "throws if both 'resolver' and 'snapshot' are present" $ do
126      let go = parseSl $
127                "name: 'test'\n" ++
128                "resolver: lts-2.10\n" ++
129                "snapshot: lts-2.10\n"
130      go `shouldThrow` anyException
131
132    it "throws if both 'snapshot' and 'compiler' are not present" $ do
133      let go = parseSl "name: 'test'\n"
134      go `shouldThrow` anyException
135
136    it "works if no 'snapshot' specified" $ do
137      RawSnapshotLayer{..} <- parseSl $
138        "name: 'test'\n" ++
139        "compiler: ghc-8.0.1\n"
140      rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1]))
141
142    hh "rendering the name of an LTS to JSON" $ property $ do
143      (major, minor) <- forAll $ (,)
144        <$> Gen.integral (Range.linear 1 10000)
145        <*> Gen.integral (Range.linear 1 10000)
146      liftIO $
147        Yaml.toJSON (RSLSynonym $ LTS major minor) `shouldBe`
148        Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor])
149
150    hh "rendering the name of a nightly to JSON" $ property $ do
151      days <- forAll $ Gen.integral $ Range.linear 1 10000000
152      let day = ModifiedJulianDay days
153      liftIO $
154        Yaml.toJSON (RSLSynonym $ Nightly day) `shouldBe`
155        Yaml.String (T.pack $ "nightly-" ++ show day)
156    it "FromJSON instance for PLIRepo" $ do
157      WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo
158      warnings `shouldBe` []
159      pli <- resolvePaths Nothing unresolvedPli
160      let repoValue =
161              Repo
162                  { repoSubdir = "wai"
163                  , repoType = RepoGit
164                  , repoCommit =
165                        "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0"
166                  , repoUrl = "https://github.com/yesodweb/wai.git"
167                  }
168          pantrySha =
169              SHA256.fromHexBytes
170                  "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2"
171      psha <- case pantrySha of
172        Right psha -> pure psha
173        _ -> fail "Failed decoding sha256"
174      let pkgValue =
175              PackageMetadata
176                  { pmIdent =
177                        PackageIdentifier
178                            (mkPackageName "wai")
179                            (mkVersion [3, 2, 1, 2])
180                  , pmTreeKey = TreeKey (BlobKey psha (FileSize 714))
181                  }
182      pli `shouldBe` PLIRepo repoValue pkgValue
183
184      WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli
185      warnings2 `shouldBe` []
186      reparsed' <- resolvePaths Nothing reparsed
187      reparsed' `shouldBe` pli
188    it "parseHackageText parses" $ do
189      let txt =
190              "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058"
191          hsha =
192              SHA256.fromHexBytes
193                  "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1"
194      sha <- case hsha of
195        Right sha' -> pure sha'
196        _ -> fail "parseHackagetext: failed decoding the sha256"
197      let Right (pkgIdentifier, blobKey) = parseHackageText txt
198      blobKey `shouldBe` (BlobKey sha (FileSize 5058))
199      pkgIdentifier `shouldBe`
200          PackageIdentifier
201              (mkPackageName "persistent")
202              (mkVersion [2, 8, 2])
203    it "roundtripping a PLIRepo" $ do
204      WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2
205      warnings `shouldBe` []
206      pli <- resolvePaths Nothing unresolvedPli
207      WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli
208      warnings2 `shouldBe` []
209      pli2 <- resolvePaths Nothing unresolvedPli2
210      pli2 `shouldBe` (pli :: PackageLocationImmutable)
211
212  describe "completeSnapshotLocation" $ do
213    let sameUrl (SLUrl txt _) (RSLUrl txt' _) txt'' =
214          do
215          txt `shouldBe` txt'
216          txt `shouldBe` txt''
217        sameUrl _ _ _ = liftIO $ error "Snapshot synonym did not complete as expected"
218
219    it "default location for nightly-2020-01-01" $ do
220      let sn = Nightly $ ModifiedJulianDay 58849
221      loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn
222      sameUrl loc (defaultSnapshotLocation sn)
223        "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/1/1.yaml"
224
225    it "default location for lts-15.1" $ do
226      let sn = LTS 15 1
227      loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn
228      sameUrl loc (defaultSnapshotLocation sn)
229        "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml"
230