Protocol.hs (5946B)
1 -- Shared native request catalogue and shallow, non-executing inspection. 2 -- Dispatch numbers below are PRIVATE implementation selectors. 3 module IO.Protocol 4 ( Action(..), decodeAction, canonicalNat, resolve, capabilities, inspectAction 5 , problemTree, transferLimit 6 ) where 7 8 import Runtime (T(..), ofList, ofString, ofNumber) 9 import qualified IO.Resources as R 10 import qualified IO.Filesystem as FS 11 import qualified IO.Network as TCP 12 import qualified IO.Codec as Codec 13 import qualified IO.UTF8 as UTF8 14 import qualified IO.Resolver as Resolver 15 import qualified IO.Clock as Clock 16 import Data.List (find) 17 import IO.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")])