PackageTests.hs (7746B)
1 module PackageTests (packageTests) where 2 3 import qualified Package as P 4 import qualified Project as J 5 import qualified Module.Inspection as I 6 import qualified Module.Manifest as MM 7 import qualified Data.Map.Strict as Map 8 import ContentStore.Object (StorePath(..)) 9 import ContentStore.Filesystem (putObject) 10 import ContentStore.Bundle (indexedTreeDomain) 11 import ContentStore.Alias (ObjectRef(..)) 12 import qualified Wire as W 13 import qualified Data.Sequence as Seq 14 import qualified Data.ByteString as BS 15 import qualified Data.Text as T 16 import Wire (buildBundleShared, encodeBundle) 17 import Runtime (T(..), ofNumber) 18 import System.IO.Temp (withSystemTempDirectory) 19 import System.FilePath ((</>)) 20 import System.Directory (doesFileExist) 21 import Control.Exception (try, IOException) 22 import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) 23 import Control.Monad (forM, forM_) 24 import Test.Tasty 25 import Test.Tasty.HUnit 26 27 packageTests :: TestTree 28 packageTests = testGroup "Exact package releases" 29 [ testCase "canonical release and lock codecs" $ do 30 let r = P.Release "collections" "0.1.0" (T.replicate 64 "a") (T.replicate 64 "b") 31 l = P.PackageLock "home" "https://example.com" r 32 P.decodeRelease (P.encodeRelease r) @?= Right r 33 P.decodeLock (P.encodeLock l) @?= Right l 34 forM_ [BS.init (P.encodeRelease r), P.encodeRelease r <> "\n", "arboricx.package-release.v2\n"] $ \bytes -> 35 assertBool "reject noncanonical release" (isLeft (P.decodeRelease bytes)) 36 assertBool "reject noncanonical lock" (isLeft (P.decodeLock (P.encodeLock l <> "\n"))) 37 , testCase "path components and explicit origins" $ do 38 forM_ ["", ".", "..", "../x", "x/y", "x:y", "x%2fy", "a\tb", T.replicate 129 "a", "é"] $ \s -> 39 assertBool (show s) (not (P.validComponent s)) 40 forM_ ["a", "0.1.0", "a-b_c.d"] $ \s -> assertBool (show s) (P.validComponent s) 41 forM_ ["http://example.com", "https://example.com/", "https://user@example.com", "https://example.com?q=x", "file:///tmp/x", "https://example.com#x"] $ \u -> 42 assertBool (show u) (isLeft (P.validateRegistryURL u)) 43 forM_ ["https://example.com", "http://127.0.0.1:9050", "http://[::1]:9050"] $ \u -> P.validateRegistryURL u @?= Right () 44 , testCase "immutable publication including racing publishers" $ withSystemTempDirectory "package-tests" $ \tmp -> do 45 bytes <- encodeBundle <$> buildBundleShared [("value", ofNumber 42)] 46 let file = tmp </> "library.arboricx" 47 root = tmp </> "registry" 48 BS.writeFile file bytes 49 r <- P.publishRelease root "library" "1.0" file 50 P.publishRelease root "library" "1.0" file >>= (@?= r) 51 vars <- forM [1..4 :: Int] $ \_ -> do 52 var <- newEmptyMVar 53 _ <- forkIO $ (try (P.publishRelease root "library" "2.0" file) :: IO (Either IOException P.Release)) >>= putMVar var 54 pure var 55 results <- mapM takeMVar vars 56 forM_ results $ \result -> case result of 57 Left e -> assertFailure (show e) 58 Right actual -> P.releaseManifest actual @?= P.releaseManifest r 59 changed <- encodeBundle <$> buildBundleShared [("value", ofNumber 43)] 60 BS.writeFile file changed 61 failed <- try (P.publishRelease root "library" "1.0" file) :: IO (Either IOException P.Release) 62 assertBool "reject replacement" (isLeft failed) 63 BS.readFile (root </> "packages/library/1.0") >>= (@?= P.encodeRelease r) 64 exists <- doesFileExist (root </> "objects" </> T.unpack (T.take 3 (P.releaseBundle r)) </> T.unpack (P.releaseBundle r) ++ ".arboricx") 65 assertBool "bundle published before index" exists 66 , testCase "reject malformed bundle before index publication" $ withSystemTempDirectory "package-tests" $ \tmp -> do 67 BS.writeFile (tmp </> "bad") "not a bundle" 68 failed <- try (P.publishRelease tmp "bad" "1" (tmp </> "bad")) :: IO (Either IOException P.Release) 69 assertBool "invalid bundle fails" (isLeft failed) 70 exists <- doesFileExist (tmp </> "packages/bad/1") 71 assertBool "no release advertised" (not exists) 72 , testCase "project codecs and portable flat binding names" $ do 73 let ds = [J.Dependency "foundation" "home" "base" "1.0"] 74 r = P.Release "base" "1.0" (T.replicate 64 "a") (T.replicate 64 "b") 75 ls = [("foundation", P.PackageLock "home" "https://example.com" r)] 76 J.decodeProject (J.encodeProject ds) @?= Right ds 77 J.decodeProjectLock (J.encodeProjectLock ls) @?= Right ls 78 J.decodeProject "arboricx.project.v1\n" @?= Right [] 79 forM_ ["", "..", "a/b", "a.b", "9abc", "a\tb", "é", T.replicate 64 "a", T.replicate 129 "x"] $ \a -> 80 assertBool (show a) (not (J.validBinding a)) 81 forM_ ["a", "_foo", "foo-bar", "With42"] $ \a -> assertBool (show a) (J.validBinding a) 82 forM_ [BS.init (J.encodeProject ds), J.encodeProject ds <> "\n", 83 "arboricx.project.v2\n", "arboricx.project.v1\nfoo\thome\tbase\t*\n", 84 "arboricx.project.v1\nfoo\thome\tbase\t1\nFoo\thome\tbase\t1\n", 85 J.encodeProject [J.Dependency ("d" <> T.pack (show n)) "home" "base" "1" | n <- [1..129 :: Int]]] $ \bytes -> 86 assertBool "reject malformed declaration" (isLeft (J.decodeProject bytes)) 87 let l = snd (head ls) 88 forM_ [J.encodeProjectLock ls <> "\n", J.encodeProjectLock [("a",l),("A",l)], 89 J.encodeProjectLock [("a",l),("b",l {P.lockRelease = r {P.releaseBundle = T.replicate 64 "c"}})], 90 J.encodeProjectLock [("a",l {P.lockURL = "http://remote.example"})]] $ \bytes -> 91 assertBool "reject malformed/conflicting lock" (isLeft (J.decodeProjectLock bytes)) 92 , testCase "DAG structural comparison agrees with small independent tree equality" $ do 93 let trees = [Leaf, Stem Leaf, Fork Leaf Leaf, Stem (Stem Leaf), 94 Fork (Stem Leaf) Leaf, Fork Leaf (Stem Leaf)] 95 forM_ trees $ \a -> forM_ trees $ \b -> 96 I.compareGraphs (W.buildBundle [("root",a)]) (W.buildBundle [("root",b)]) @?= Right (a == b) 97 , testCase "DAG comparison ignores physical ordering but preserves child order" $ do 98 let left = W.buildBundle [("root", Fork (Stem Leaf) (Fork Leaf Leaf))] 99 right = left {W.bundleNodes = Seq.fromList [W.BNLeaf,W.BNFork 0 0,W.BNStem 0,W.BNFork 2 1]} 100 different = right {W.bundleNodes = Seq.fromList [W.BNLeaf,W.BNFork 0 0,W.BNStem 0,W.BNFork 1 2]} 101 W.bundleRoots left @?= [3] 102 I.compareGraphs left right @?= Right True 103 I.compareGraphs left different @?= Right False 104 assertBool "reject cycles before structural indexing" (isLeft (I.compareGraphs left (right {W.bundleNodes = Seq.singleton (W.BNStem 0)}))) 105 106 , testCase "inspection byte budget counts distinct retained objects" $ withSystemTempDirectory "inspection-budget" $ \tmp -> do 107 let store = StorePath tmp 108 first = W.encodeBundle (W.buildBundle [("root", Leaf)]) 109 a <- putObject store indexedTreeDomain first 110 b <- putObject store indexedTreeDomain (W.encodeBundle (W.buildBundle [("root", Stem Leaf)])) 111 let ex n pin = MM.ModuleExport n (ObjectRef "arboricx.indexed-tree.v1" pin) "arboricx.abi.tree.v1" 112 pin <- MM.putManifest store (MM.ModuleManifest [] [ex "first" a,ex "same" a,ex "next" b]) 113 evidence <- I.inspectModuleWithBudget (BS.length first) store pin 114 let status name = case Map.lookup name (I.inspectedExports evidence) of 115 Just (Right _) -> "verified" 116 Just (Left err) -> err 117 Nothing -> "absent" 118 status "first" @?= "verified" 119 status "same" @?= "verified" 120 assertBool "next object unavailable rather than unbounded allocation" ("unavailable:" `T.isPrefixOf` status "next") 121 122 ] 123 where 124 isLeft (Left _) = True 125 isLeft _ = False