Protocol.hs (5967B)
1 -- Shared native v2 request catalogue and shallow, non-executing inspection. 2 -- Dispatch numbers below are PRIVATE implementation selectors. 3 module IOV2.Protocol 4 ( Action(..), decodeAction, canonicalNat, resolve, capabilities, inspectAction 5 , problemTree, transferLimit 6 ) where 7 8 import Runtime (T(..), ofList, ofString, ofNumber) 9 import qualified IOV2.Resources as R 10 import qualified IOV2.Filesystem as FS 11 import qualified IOV2.Network as TCP 12 import qualified IOV2.Codec as Codec 13 import qualified IOV2.UTF8 as UTF8 14 import qualified IOV2.Resolver as Resolver 15 import qualified IOV2.Clock as Clock 16 import Data.List (find) 17 import IOV2.Wire (Action(..), canonicalNat, decodeAction) 18 19 -- Only implemented revisions/operations are advertised. Unsupported names are 20 -- not promises about a future group's argument schema or API. 21 catalogue :: [(String, [(String, Integer)])] 22 catalogue = 23 [ ("runtime", [("capabilities",100), ("inspect",101)]) 24 , ("standard", [("input",25), ("output",26), ("error",27)]) 25 , ("file", [("open-reader",20), ("open-writer",21), ("open-appender",50), ("open-update",51), ("seek",52), ("position",53), ("size",54), ("resize",55), ("sync",56)]) 26 , ("path", [("stat",60), ("lstat",61), ("remove-file",64), ("rename",65)]) 27 , ("directory", [("create",62), ("remove",63), ("open",66), ("next",67), ("sync",68)]) 28 , ("tcp", [("listen",80), ("connect",81), ("accept",82), ("local-address",83), ("peer-address",84), ("shutdown-write",85)]) 29 , ("resolver", [("resolve",86)]) 30 , ("indexed-tree", [("read",87), ("hash",88), ("write",89), ("verify",95)]) 31 , ("utf8", [("encode",96), ("decode",97)]) 32 , ("stream", [("read",22), ("write",23), ("snapshot",108), ("transfer",109)]) 33 , ("resource", [("close",24)]) 34 , ("stage", [("open",30), ("seal",31), ("publish",32)]) 35 , ("digest", [("open",40), ("update",41), ("finish",42)]) 36 , ("clock", [("monotonic",102), ("sleep",103)]) 37 , ("scheduler", [("yield",104)]) 38 , ("process", [("spawn",105), ("working-directory",106), ("environment-variable",107)]) 39 ] 40 41 resolve :: String -> Integer -> String -> Maybe Integer 42 resolve group 1 operation = lookup group catalogue >>= lookup operation 43 resolve _ _ _ = Nothing 44 45 core :: [(Integer, String)] 46 core = zip [0..9] ["pure", "bind", "fail", "scope", "current-scope", "spawn", "join", "discard", "cancel", "cancelled"] 47 48 transferLimit :: Int 49 transferLimit = 256 50 51 problemTree :: R.Problem -> T 52 problemTree p = ofList (map ofString [R.category p, R.operation p, R.detail p, R.progress p]) 53 54 -- Association rows keep metadata extensible without making it authority. 55 capabilities :: T 56 capabilities = ofList 57 [ row "schema" (ofNumber 1) 58 , row "io-version" (ofNumber 2) 59 , row "backend" (ofString "haskell-native") 60 , row "authority" (ofString "os-process") 61 , row "core" (strings (map snd core)) 62 , row "groups" (ofList [ofList [ofString g, ofNumber 1, strings (map fst ops)] | (g,ops) <- catalogue]) 63 , row "limits" (ofList [row "chunk-bytes" (ofNumber (toInteger R.chunkLimit)), row "transfer-handles" (ofNumber (toInteger transferLimit)), row "file-offset-max" (ofNumber R.positionLimit), row "directory-name-scalars" (ofNumber (toInteger FS.nameLimit)), row "tcp-backlog" (ofNumber (toInteger TCP.backlogLimit)), row "resolver-host-characters" (ofNumber (toInteger Resolver.hostLimit)), row "resolver-addresses" (ofNumber (toInteger Resolver.addressLimit)), row "indexed-sections" (ofNumber (toInteger Codec.sectionLimit)), row "indexed-manifest-bytes" (ofNumber (toInteger Codec.manifestLimit)), row "utf8-encode-scalars" (ofNumber (toInteger UTF8.scalarLimit)), row "sleep-milliseconds-max" (ofNumber Clock.sleepLimit), 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)]) 64 , row "tcp-address-families" (strings ["ipv4","ipv6"]) 65 , row "digest-algorithms" (strings ["sha256"]) 66 , row "restrictions" (strings ["action-boundary-cancellation", "no-hard-deadlines", "stage-same-filesystem", "stage-no-copy-fallback", "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"]) 67 ] 68 where row key value = ofList [ofString key, value] 69 strings = ofList . map ofString 70 71 -- This is classification of ONE header, not executable validation, recursive 72 -- traversal, argument validation, handle lookup, or prediction of success. 73 -- Payloads, callbacks and continuations are never included in the result. 74 inspectAction :: T -> Either R.Problem T 75 inspectAction value = case decodeAction value of 76 Left detail -> Left (R.Problem "invalid-argument" "inspect" detail "none") 77 Right (Core code _) -> case find ((== code) . fst) core of 78 Just (_,label) -> Right (ofList [ofString "core", ofString label]) 79 Nothing -> error "decodeAction returned unknown core" 80 Right (Request group revision operation _) -> Right (ofList 81 [ofString "facility", ofString group, ofNumber revision, ofString operation, 82 ofString (case resolve group revision operation of Just _ -> "available"; _ -> "unsupported")])