IOV2ProtocolTests.hs (8901B)
1 module IOV2ProtocolTests (ioV2ProtocolTests) where 2 3 import qualified IOV2.Driver as V 4 import qualified IOV2.Protocol as P 5 import qualified IOV2.Resources as R 6 import Runtime (T(..), ofNumber, ofString, ofList) 7 import Test.Tasty 8 import Test.Tasty.HUnit 9 10 request :: String -> Integer -> String -> T -> T 11 request g v op args = Fork (ofNumber 10) (Fork (ofString g) (Fork (ofNumber v) (Fork (ofString op) args))) 12 ok, err :: T -> T 13 ok x = Fork (Stem Leaf) (Fork x Leaf) 14 err x = Fork Leaf (Fork x Leaf) 15 problem category operation detail = ofList (map ofString [category,operation,detail,"none"]) 16 completed action expected = V.runDetailed action >>= \outcome -> case outcome of 17 V.Completed value -> value @?= expected 18 _ -> assertFailure "expected completion" 19 20 ioV2ProtocolTests :: TestTree 21 ioV2ProtocolTests = testGroup "IO v2 protocol" 22 [ testCase "capability schema reports exact implemented groups and limits" $ do 23 let strings = ofList . map ofString 24 row key value = ofList [ofString key,value] 25 groups = [("runtime",["capabilities","inspect"]),("standard",["input","output","error"]),("file",["open-reader","open-writer","open-appender","open-update","seek","position","size","resize","sync"]), 26 ("path",["stat","lstat","remove-file","rename"]),("directory",["create","remove","open","next","sync"]),("tcp",["listen","connect","accept","local-address","peer-address","shutdown-write"]),("resolver",["resolve"]),("indexed-tree",["read","hash","write","verify"]),("utf8",["encode","decode"]),("stream",["read","write","snapshot","transfer"]),("resource",["close"]),("stage",["open","seal","publish"]), 27 ("digest",["open","update","finish"]),("clock",["monotonic","sleep"]),("scheduler",["yield"]),("process",["spawn","working-directory","environment-variable"])] 28 expected = ofList [row "schema" (ofNumber 1), row "io-version" (ofNumber 2), 29 row "backend" (ofString "haskell-native"), row "authority" (ofString "os-process"), 30 row "core" (strings ["pure","bind","fail","scope","current-scope","spawn","join","discard","cancel","cancelled"]), 31 row "groups" (ofList [ofList [ofString g,ofNumber 1,strings ops] | (g,ops) <- groups]), 32 row "limits" (ofList [row "chunk-bytes" (ofNumber 4096), row "transfer-handles" (ofNumber 256), row "file-offset-max" (ofNumber 9223372036854775807), row "directory-name-scalars" (ofNumber 4096), row "tcp-backlog" (ofNumber 4096), row "resolver-host-characters" (ofNumber 253), row "resolver-addresses" (ofNumber 64), row "indexed-sections" (ofNumber 64), row "indexed-manifest-bytes" (ofNumber 65536), row "utf8-encode-scalars" (ofNumber 1024), row "sleep-milliseconds-max" (ofNumber 9223372036854775807), row "process-arguments" (ofNumber 256), row "process-environment-entries" (ofNumber 256), row "process-text-scalars" (ofNumber 4096), row "process-total-scalars" (ofNumber 65536), row "process-grace-milliseconds-max" (ofNumber 9223372036854775807)]), 33 row "tcp-address-families" (strings ["ipv4","ipv6"]), 34 row "digest-algorithms" (strings ["sha256"]), 35 row "restrictions" (strings ["action-boundary-cancellation","no-hard-deadlines","stage-same-filesystem","stage-no-copy-fallback", 36 "stage-private-namespace","publish-new-requires-hard-links","no-crash-recovery","borrowed-standard-streams","standard-stream-leases-per-run","file-single-cursor-lease","append-no-position-or-resize","file-host-handle-locking","directory-unsorted-non-snapshot","filesystem-host-encoding","directory-failure-poisons-cursor","tcp-numeric-addresses","tcp-ipv6-only-listeners","tcp-direction-leases","tcp-failure-poisons-direction","resolver-host-order-and-buffering","resolver-may-delay-cancellation","indexed-authenticated-snapshot","indexed-caller-frame-and-disk-limit","indexed-dag-resident","indexed-writer-preflight","indexed-budget-not-heap-quota","sync-host-filesystem-guarantees","utf8-strict-scalars","clock-host-monotonic-word64","sleep-may-run-late","yield-no-ordering-guarantee", "process-direct-child-only", "process-normal-exit-joins", "process-explicit-pipe-draining"])] 37 completed (request "runtime" 1 "capabilities" Leaf) (ok expected) 38 R.chunkLimit @?= 4096 39 P.transferLimit @?= 256 40 , testCase "unsupported requests do not inspect arguments and remain ordinary errors" $ 41 mapM_ (\(g,v,op) -> completed (request g v op (error "unsupported arguments demanded")) 42 (err (problem "unsupported" (g++"/"++op) ("group revision "++show v)))) 43 [("future-tcp",1,"connect"),("digest",2,"open"),("file",1,"absent"),("clock",2,"sleep"),("clock",1,"deadline"),("scheduler",1,"absent"),("process",2,"spawn"),("process",1,"shell")] 44 , testCase "recognized operation arguments fail ordinarily" $ 45 mapM_ (\(g,op) -> V.runDetailed (request g 1 op (if g == "utf8" && op == "encode" then Stem Leaf else Leaf)) >>= \outcome -> case outcome of 46 V.Completed (Fork Leaf (Fork (Fork _ (Fork operation _)) Leaf)) -> operation @?= ofString (g++"/"++op) 47 _ -> assertFailure (g++"/"++op)) 48 [("file","open-reader"),("file","open-writer"),("file","open-appender"),("file","open-update"),("file","seek"),("file","position"),("file","size"),("file","resize"),("file","sync"),("stream","read"),("stream","write"),("stream","snapshot"),("stream","transfer"), 49 ("path","stat"),("path","lstat"),("path","remove-file"),("path","rename"),("directory","create"),("directory","remove"),("directory","open"),("directory","next"),("directory","sync"),("tcp","listen"),("tcp","connect"),("tcp","accept"),("tcp","local-address"),("tcp","peer-address"),("tcp","shutdown-write"),("resolver","resolve"),("indexed-tree","read"),("indexed-tree","hash"),("indexed-tree","write"),("indexed-tree","verify"),("utf8","encode"),("utf8","decode"),("resource","close"),("stage","open"),("stage","seal"),("stage","publish"), 50 ("digest","open"),("digest","update"),("digest","finish"),("runtime","inspect")] 51 , testCase "inspection does not demand core payloads or callbacks" $ 52 mapM_ (\(tag,label) -> completed (request "runtime" 1 "inspect" (Fork (ofNumber tag) (error "payload demanded"))) 53 (ok (ofList [ofString "core",ofString label]))) 54 (zip [0..9] ["pure","bind","fail","scope","current-scope","spawn","join","discard","cancel","cancelled"]) 55 , testCase "inspection classifies headers without executing or validating arguments" $ do 56 completed (request "runtime" 1 "inspect" (request "file" 1 "open-writer" (error "writer executed"))) 57 (ok (ofList [ofString "facility",ofString "file",ofNumber 1,ofString "open-writer",ofString "available"])) 58 completed (request "runtime" 1 "inspect" (request "file" 2 "open-writer" (error "unsupported arguments demanded"))) 59 (ok (ofList [ofString "facility",ofString "file",ofNumber 2,ofString "open-writer",ofString "unsupported"])) 60 , testCase "retired numeric facility tags cannot accidentally execute" $ 61 mapM_ (\tag -> V.runDetailed (Fork (ofNumber tag) (error "retired payload demanded")) >>= \outcome -> case outcome of 62 V.Failed diagnostic [] -> diagnostic @?= problem "protocol-error" "core/decode" "unknown computation constructor" 63 _ -> assertFailure "retired tag accepted") [20,21,22,23,24,25,26,27,30,31,32,40,41,42,50,51,52,53,54,55,56,60,61,62,63,64,65,66,67,68,80,81,82,83,84,85,86,87,88,89,95,96,97,100,101,255] 64 , testCase "malformed headers are protocol failures rather than unsupported" $ do 65 let header g v op = Fork (ofNumber 10) (Fork g (Fork v (Fork op (error "malformed args demanded")))) 66 oversized = foldr Fork (Fork (error "excess name head demanded") (error "excess name tail demanded")) 67 (replicate 64 (ofNumber 97)) 68 inputs = [header (ofString "") (ofNumber 1) (ofString "read"), 69 header (ofString "File") (ofNumber 1) (ofString "read"), 70 header (ofString "file") Leaf (ofString "read"), 71 header (ofString "file") (Fork Leaf Leaf) (ofString "read"), 72 header oversized (ofNumber 1) (ofString "read"), 73 Fork (Fork Leaf Leaf) (error "noncanonical core payload demanded")] 74 mapM_ (\input -> V.runDetailed input >>= \outcome -> case outcome of 75 V.Failed _ [] -> pure () 76 _ -> assertFailure "malformed header accepted") inputs 77 , testCase "standard stream lookup validates unit without demanding its child" $ 78 mapM_ (\op -> completed (request "standard" 1 op (Stem (error "payload forced"))) 79 (err (problem "invalid-argument" ("standard/"++op) ""))) ["input","output","error"] 80 , testCase "runtime capability request validates unit without traversing payload" $ 81 completed (request "runtime" 1 "capabilities" (Stem (error "ignored child demanded"))) 82 (err (problem "invalid-argument" "runtime/capabilities" "")) 83 ]