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