InteractionInspectionTests.hs (11326B)
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 3) 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 "v2 named headers, opaque arguments and bind continuations" $ do 111 let req = action 10 (Fork (ofString "file") (Fork (ofNumber 1) (Fork (ofString "open-writer") (action 26 (ofString "DO-NOT-DELETE"))))) 112 envelope = Fork (ofString "tricuIO") . Fork (ofNumber 2) 113 os = occurrences (inspect defaultLimits [("main",envelope (action 1 (Fork req req)))]) 114 map occurrenceSummary (take 3 os) @?= ["tricuIO v2","Bind","Facility file@1/open-writer"] 115 map occurrenceStatus (drop 3 os) @?= ["opaque","opaque"] 116 assertBool "no payload preview" (not (any (Text.isInfixOf "DO-NOT-DELETE" . occurrenceSummary) os)) 117 , testCase "v2 does not inherit permissive v1 tag decoding or numeric facilities" $ do 118 let envelope = Fork (ofString "tricuIO") . Fork (ofNumber 2) 119 status t = occurrenceStatus (occurrences (inspect defaultLimits [("main",envelope t)]) !! 1) 120 status (Fork (Fork Leaf Leaf) Leaf) @?= "invalid" 121 status (action 20 Leaf) @?= "unknown" 122 status (action 10 (Fork (ofString "file") (Fork Leaf (Fork (ofString "read") Leaf)))) @?= "invalid" 123 , testCase "v2 callbacks and huge shared arguments remain opaque" $ do 124 let huge = iterate (\t -> Fork t t) Leaf !! 120 125 req = action 10 (Fork (ofString "future") (Fork (ofNumber 7) (Fork (ofString "work") huge))) 126 envelope = Fork (ofString "tricuIO") . Fork (ofNumber 2) 127 bundle <- W.buildBundleShared [("main",envelope req)] 128 case inspectBundle defaultLimits "main" bundle of 129 Left e -> assertFailure e 130 Right r -> do 131 length (occurrences r) @?= 3 132 occurrenceStatus (last (occurrences r)) @?= "opaque" 133 let os = occurrences (inspect defaultLimits [("main",envelope (action 3 (action 20 Leaf)))]) 134 occurrenceSummary (last os) @?= "scope callback (not applied)" 135 , testCase "JSON schema and safe terminal quoting" $ do 136 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")))] 137 output = renderOutline r 138 json = reportJSON "fingerprint" r 139 assertBool "no terminal escapes" (not (Text.any (== '\ESC') output)) 140 assertBool "no bidi" (not (Text.any (== '\x202e') output)) 141 (eitherDecode (encode json) :: Either String Value) @?= Right json 142 assertBool "schema" ("tricu.interaction-inspection.v2" `Text.isInfixOf` Text.pack (BL.unpack (encode json))) 143 ] 144 where 145 checkPrimitive (tag,label,fields) = do 146 let payload = case fields of 147 [] -> Leaf 148 _ -> foldr1 Fork (map snd fields) 149 os = rows (action tag payload) 150 occurrenceSummary (os !! 1) @?= label 151 map occurrenceRole (drop 2 os) @?= if null fields then ["payload"] else map fst fields 152 assertBool ("valid payloads for " ++ show tag) (all ((/= "invalid") . occurrenceStatus) os) 153 str = ofString "x" 154 n = ofNumber 3 155 p = ("path",str) 156 dg = ("digest",str) 157 bytes = ("bytes",ofList [ofNumber 0,ofNumber 255]) 158 sock = ("socket",Leaf) 159 address = [("address",str),("port",n)] 160 primitives = 161 [ (0,"Pure",[("value",Leaf)]), (10,"PutStr",[("text",str)]), (11,"GetLine",[]) 162 , (12,"PutBytes",[bytes]), (20,"ReadFile",[p]), (21,"WriteFile",[p,("contents",str)]) 163 , (22,"WriteBytes",[p,bytes]), (23,"ListDirectory",[p]), (24,"RenameFile",[("oldPath",str),("newPath",str)]) 164 , (25,"CreateDirectory",[p]), (26,"DeleteFile",[p]), (27,"FileExists",[p]) 165 , (28,"Sha256Hex",[bytes]), (29,"CurrentTime",[]), (30,"Ask",[]) 166 , (32,"WriteBytesIfAbsent",[p,bytes]), (33,"AtomicWriteBytes",[p,bytes]) 167 , (34,"ReadTreeTerm",[p,dg]), (35,"HashTreeTerm",[("tree",Leaf)]) 168 , (36,"WriteTreeTermIfAbsent",[p,dg,("tree",Leaf)]), (37,"ReadSourceFile",[p]) 169 , (38,"EncodeSourceText",[("text",str)]), (40,"Get",[]), (41,"Put",[("state",Leaf)]) 170 , (50,"ReadIndexedTree",[p,dg]), (51,"HashIndexedTree",[("tree",Leaf)]) 171 , (52,"WriteIndexedTreeIfAbsent",[p,dg,("tree",Leaf)]), (61,"Await",[("handle",Leaf)]) 172 , (62,"Yield",[]), (63,"Sleep",[("milliseconds",n)]), (70,"Socket",[]) 173 , (71,"CloseSocket",[sock]), (72,"BindSocket",sock:address), (73,"Listen",[sock,("backlog",n)]) 174 , (74,"Accept",[sock]), (75,"Connect",sock:address), (76,"Recv",[sock,("maxBytes",n)]) 175 , (77,"Send",[sock,bytes]), (78,"GetSocketName",[sock]) 176 , (90,"UploadBegin",[("directory",str),("expected",n)]) 177 , (91,"UploadAppend",[("handle",Leaf),("chunk",ofList [ofNumber 0,ofNumber 255])]) 178 , (92,"UploadSeal",[("handle",Leaf)]) 179 , (93,"UploadCommit",[("handle",Leaf),("destination",str)]) 180 , (94,"UploadAbort",[("handle",Leaf)]) 181 ]