InteractionInspectionTests.hs (9167B)
1 module InteractionInspectionTests (interactionInspectionTests) where 2 3 import InteractionInspection 4 import Runtime (T(..), ofNumber, ofString, ofList) 5 import qualified Wire as W 6 import qualified Data.Sequence as S 7 import qualified Data.Text as Text 8 import qualified Data.ByteString.Lazy.Char8 as BL 9 import Data.Aeson (encode, eitherDecode, Value) 10 import Test.Tasty 11 import Test.Tasty.HUnit 12 13 -- Independent literal tags/layouts: do not derive expected values from the 14 -- inspector's operation table. No source compiler/evaluator is involved. 15 io :: T -> T 16 io = Fork (ofString "tricuIO") . Fork (ofNumber 1) 17 action :: Integer -> T -> T 18 action = Fork . ofNumber 19 20 inspect :: Limits -> [(Text.Text,T)] -> Report 21 inspect limits exports = either error id $ inspectBundle limits "main" (W.buildBundle exports) 22 23 rows :: T -> [Occurrence] 24 rows t = occurrences (inspect defaultLimits [("main",io t)]) 25 26 interactionInspectionTests :: TestTree 27 interactionInspectionTests = testGroup "Interaction inspection" 28 [ testCase "bind outline, exact continuation aliases and paths" $ do 29 let k = Stem (Fork Leaf Leaf) 30 r = inspect defaultLimits [("main",io (action 1 (Fork (action 20 (ofString "settings.txt")) k))), ("afterRead",k), ("alsoAfterRead",k)] 31 os = occurrences r 32 map occurrencePath os @?= ["root","root.action","root.action.action","root.action.action.path","root.action.resume"] 33 map occurrenceSummary os @?= ["tricuIO v1","Bind","ReadFile","\"settings.txt\"","continuation (not applied)"] 34 occurrenceAliases (last os) @?= ["afterRead","alsoAfterRead"] 35 occurrenceStatus (last os) @?= "opaque" 36 , testCase "continuations remain opaque even when shaped as actions" $ do 37 let os = rows (action 1 (Fork (action 11 Leaf) (action 26 (ofString "DO-NOT-DELETE")))) 38 assertBool "no interpreted continuation" (not (any ((== "DeleteFile") . occurrenceSummary) os)) 39 occurrenceSummary (last os) @?= "continuation (not applied)" 40 , testCase "explicit Fork and Local child actions only" $ do 41 let os = rows (action 60 (action 31 (Fork (action 10 (ofString "not run")) (action 63 (ofNumber 25))))) 42 map occurrenceSummary os @?= ["tricuIO v1","Fork","Local","environment function (not applied)","Sleep","25"] 43 , testCase "all primitive tags and field roles" $ mapM_ checkPrimitive primitives 44 , testCase "tag 2 is terminal Abort, not a pure-layer exception" $ 45 map occurrenceSummary (rows (action 2 (ofString "stop"))) @?= ["tricuIO v1","Abort","tree value"] 46 , testCase "bad envelope, unsupported version, unknown and malformed actions" $ do 47 let bad = inspect defaultLimits [("main",Leaf)] 48 occurrenceStatus (head (occurrences bad)) @?= "invalid" 49 let version = inspect defaultLimits [("main",Fork (ofString "tricuIO") (Fork (ofNumber 2) Leaf))] 50 occurrenceStatus (head (occurrences version)) @?= "unknown" 51 occurrenceStatus (rows (action 999 Leaf) !! 1) @?= "unknown" 52 let cutUnknown = inspect (Limits 1 100 80) [("main",io (action 999 Leaf))] 53 occurrenceStatus (last (occurrences cutUnknown)) @?= "unknown" 54 occurrenceStatus (rows (action 1 Leaf) !! 1) @?= "invalid" 55 occurrenceStatus (rows (action 72 (Fork Leaf Leaf)) !! 1) @?= "invalid" 56 occurrenceStatus (last (rows (action 20 (Stem Leaf)))) @?= "invalid" 57 occurrenceStatus (last (rows (action 12 (ofList [ofNumber 256])))) @?= "invalid" 58 occurrenceStatus (last (rows (action 10 (ofList [ofNumber 0xd800])))) @?= "invalid" 59 , testCase "ignored payload is not wrongly required to be Leaf" $ 60 occurrenceStatus (last (rows (action 11 (Stem Leaf)))) @?= "opaque" 61 , testCase "noncanonical binary numbers follow host acceptance" $ do 62 let noncanonical = Fork Leaf Leaf 63 r = inspect defaultLimits [("main",io (Fork noncanonical Leaf))] 64 occurrenceSummary (occurrences r !! 1) @?= "Pure" 65 , testCase "bounded previews distinguish exact end, bad tail and unvisited suffix" $ do 66 let preview t = last $ occurrences $ inspect (Limits 24 500 2) [("main",io (action 10 t))] 67 occurrenceStatus (preview (ofString "ab")) @?= "decoded" 68 occurrenceStatus (preview (ofString "abc")) @?= "truncated" 69 occurrenceStatus (preview (Fork (ofNumber 97) (Stem Leaf))) @?= "invalid" 70 occurrenceStatus (preview (Fork (ofNumber 97) (Fork (ofNumber 98) (Fork (Stem Leaf) Leaf)))) @?= "truncated" 71 , testCase "depth, occurrence and alias limits are deterministic" $ do 72 let bundle = [("main",io (action 60 (action 60 (action 0 Leaf)))), ("alias",Leaf),("alias2",Leaf)] 73 deep = inspect (Limits 1 100 80) bundle 74 length (occurrences deep) @?= 2 75 occurrenceStatus (last (occurrences deep)) @?= "truncated" 76 let narrow = inspect (Limits 24 2 80) bundle 77 length (occurrences narrow) @?= 2 78 occurrenceLimitReached narrow @?= True 79 let aliases = inspect (Limits 24 100 1) bundle 80 aliasesOmitted (last (occurrences aliases)) @?= 1 81 inspect (Limits 24 2 80) bundle @?= narrow 82 , testCase "64-bit number inspection cap" $ do 83 let os = rows (action 63 (ofNumber (2^(65::Int)))) 84 occurrenceStatus (last os) @?= "truncated" 85 , testCase "same tree can occupy distinct semantic roles" $ do 86 let a = action 11 Leaf 87 os = rows (action 1 (Fork a a)) 88 act = os !! 2 89 resume = last os 90 occurrenceNode act @?= occurrenceNode resume 91 assertBool "distinct occurrences" (occurrencePath act /= occurrencePath resume) 92 occurrenceStatus act @?= "decoded" 93 occurrenceStatus resume @?= "opaque" 94 , testCase "large shared opaque DAG is never unfolded" $ do 95 let huge = iterate (\t -> Fork t t) Leaf !! 120 96 bundle <- W.buildBundleShared [("main",io (action 0 huge))] 97 case inspectBundle defaultLimits "main" bundle of 98 Left e -> assertFailure e 99 Right r -> do 100 length (occurrences r) @?= 3 101 assertBool "compact stored representation" (storedNodes r < 200) 102 , testCase "validate unused nodes and reject missing exports / bad limits" $ do 103 let b = W.buildBundle [("main",io (action 0 Leaf))] 104 malformed = b { W.bundleNodes = W.bundleNodes b S.|> W.BNStem 99999 } 105 isLeft (Left _) = True; isLeft _ = False 106 assertBool "unused invalid edge" (isLeft (inspectBundle defaultLimits "main" malformed)) 107 assertBool "absent export" (isLeft (inspectBundle defaultLimits "missing" b)) 108 assertBool "negative limit" (isLeft (inspectBundle (Limits (-1) 1 1) "main" b)) 109 assertBool "zero limit" (isLeft (inspectBundle (Limits 1 0 1) "main" b)) 110 , testCase "JSON schema and safe terminal quoting" $ do 111 let r = inspect defaultLimits [("main",io (action 10 (ofString "x\n\ESC[2J\x202e"))), ("unsafe\n\ESC",io (action 10 (ofString "x\n\ESC[2J\x202e")))] 112 output = renderOutline r 113 json = reportJSON "fingerprint" r 114 assertBool "no terminal escapes" (not (Text.any (== '\ESC') output)) 115 assertBool "no bidi" (not (Text.any (== '\x202e') output)) 116 (eitherDecode (encode json) :: Either String Value) @?= Right json 117 assertBool "schema" ("tricu.interaction-inspection.v1" `Text.isInfixOf` Text.pack (BL.unpack (encode json))) 118 ] 119 where 120 checkPrimitive (tag,label,fields) = do 121 let payload = case fields of 122 [] -> Leaf 123 _ -> foldr1 Fork (map snd fields) 124 os = rows (action tag payload) 125 occurrenceSummary (os !! 1) @?= label 126 map occurrenceRole (drop 2 os) @?= if null fields then ["payload"] else map fst fields 127 assertBool ("valid payloads for " ++ show tag) (all ((/= "invalid") . occurrenceStatus) os) 128 str = ofString "x" 129 n = ofNumber 3 130 p = ("path",str) 131 dg = ("digest",str) 132 bytes = ("bytes",ofList [ofNumber 0,ofNumber 255]) 133 sock = ("socket",Leaf) 134 address = [("address",str),("port",n)] 135 primitives = 136 [ (0,"Pure",[("value",Leaf)]), (10,"PutStr",[("text",str)]), (11,"GetLine",[]) 137 , (12,"PutBytes",[bytes]), (20,"ReadFile",[p]), (21,"WriteFile",[p,("contents",str)]) 138 , (22,"WriteBytes",[p,bytes]), (23,"ListDirectory",[p]), (24,"RenameFile",[("oldPath",str),("newPath",str)]) 139 , (25,"CreateDirectory",[p]), (26,"DeleteFile",[p]), (27,"FileExists",[p]) 140 , (28,"Sha256Hex",[bytes]), (29,"CurrentTime",[]), (30,"Ask",[]) 141 , (32,"WriteBytesIfAbsent",[p,bytes]), (33,"AtomicWriteBytes",[p,bytes]) 142 , (34,"ReadTreeTerm",[p,dg]), (35,"HashTreeTerm",[("tree",Leaf)]) 143 , (36,"WriteTreeTermIfAbsent",[p,dg,("tree",Leaf)]), (37,"ReadSourceFile",[p]) 144 , (38,"EncodeSourceText",[("text",str)]), (40,"Get",[]), (41,"Put",[("state",Leaf)]) 145 , (50,"ReadIndexedTree",[p,dg]), (51,"HashIndexedTree",[("tree",Leaf)]) 146 , (52,"WriteIndexedTreeIfAbsent",[p,dg,("tree",Leaf)]), (61,"Await",[("handle",Leaf)]) 147 , (62,"Yield",[]), (63,"Sleep",[("milliseconds",n)]), (70,"Socket",[]) 148 , (71,"CloseSocket",[sock]), (72,"BindSocket",sock:address), (73,"Listen",[sock,("backlog",n)]) 149 , (74,"Accept",[sock]), (75,"Connect",sock:address), (76,"Recv",[sock,("maxBytes",n)]) 150 , (77,"Send",[sock,bytes]), (78,"GetSocketName",[sock]) 151 ]