Driver.hs - tricu - An interpreted language for exploring Tree Calculus

Driver.hs (24395B)
      1 {-# LANGUAGE ScopedTypeVariables #-}
      2 -- Native v2 structured tasks, resource ownership and scoped operations.
      3 module IOV2.Driver (Outcome(..), run, runDetailed, runInRuntime, canonicalNat, decodeChunk) where
      4 
      5 import Runtime (T(..), apply, ofNumber, ofString, ofList, ofBytes, toString)
      6 import qualified IOV2.Resources as R
      7 import qualified IOV2.Protocol as P
      8 import IOV2.Protocol (canonicalNat, problemTree)
      9 import qualified IOV2.Tasks as S
     10 import qualified IOV2.Staging as Stage
     11 import qualified IOV2.Digest as Digest
     12 import qualified IOV2.Filesystem as FS
     13 import qualified IOV2.Network as TCP
     14 import qualified IOV2.Codec as Codec
     15 import qualified IOV2.ByteStream as ByteStream
     16 import qualified IOV2.UTF8 as UTF8
     17 import qualified IOV2.Resolver as Resolver
     18 import qualified IOV2.Clock as Clock
     19 import qualified IOV2.Process as Process
     20 import qualified IOV2.Context as Context
     21 import qualified Control.Concurrent as Concurrent
     22 import IOV2.Tasks (Outcome(..))
     23 import qualified Data.ByteString as BS
     24 
     25 
     26 decodeChunk :: T -> Either String BS.ByteString
     27 decodeChunk = fmap BS.pack . walk R.chunkLimit
     28   where
     29     walk _ Leaf = Right []
     30     walk 0 _ = Left "chunk exceeds bound"
     31     walk n (Fork value rest) = case canonicalNat 8 value of
     32       Just byte -> (fromIntegral byte :) <$> walk (n-1) rest
     33       _ -> Left "noncanonical octet"
     34     walk _ _ = Left "improper chunk"
     35 
     36 ok, err :: T -> T
     37 ok value = Fork (Stem Leaf) (Fork value Leaf)
     38 err value = Fork Leaf (Fork value Leaf)
     39 reply :: (a -> T) -> Either R.Problem a -> T
     40 reply encode = either (err . problemTree) (ok . encode)
     41 bad :: String -> T
     42 bad op = err (problemTree (R.Problem "invalid-argument" op "" "none"))
     43 -- Only host-generated operation Results pass here. Successful payloads and
     44 -- arbitrary user failure diagnostics remain opaque; no error is inferred from
     45 -- a pure computation's value. Keep category/detail/progress exactly intact.
     46 qualifyError :: String -> T -> T
     47 qualifyError operation result = case result of
     48   Fork Leaf (Fork (Fork category (Fork _ rest)) Leaf) ->
     49     err (Fork category (Fork (ofString operation) rest))
     50   _ -> result
     51 
     52 protocol :: Outcome
     53 protocol = protocolFailure "invalid v2 computation"
     54 protocolFailure :: String -> Outcome
     55 protocolFailure detail = Failed (problemTree (R.Problem "protocol-error" "core/decode" detail "none")) []
     56 
     57 tokenTree :: R.Token -> T
     58 tokenTree (R.Token identity key) = ofList [ofString "io.v2.resource", ofNumber identity, ofNumber key]
     59 decodeToken :: T -> Maybe R.Token
     60 decodeToken (Fork tag (Fork runId (Fork key Leaf)))
     61   | tag == ofString "io.v2.resource" = R.Token <$> canonicalNat 64 runId <*> canonicalNat 64 key
     62 decodeToken _ = Nothing
     63 
     64 -- Scope references also carry a run identity, supplied by a private root token.
     65 -- Use a separate marker so a resource cannot be passed as a scope.
     66 scopeTree :: R.Token -> R.Scope -> T
     67 scopeTree (R.Token identity _) scope = ofList [ofString "io.v2.scope", ofNumber identity, ofNumber scope]
     68 decodeScope :: R.Token -> T -> Maybe R.Scope
     69 decodeScope (R.Token identity _) (Fork tag (Fork runId (Fork key Leaf)))
     70   | tag == ofString "io.v2.scope", Just identity == canonicalNat 64 runId = canonicalNat 64 key
     71 decodeScope _ _ = Nothing
     72 
     73 runDetailed :: T -> IO Outcome
     74 runDetailed action = R.newRuntime >>= \runtime -> runInRuntime runtime action
     75 
     76 -- One execution owns this runtime's root and always closes it. Exposed for
     77 -- embedding/backend tests; a closed runtime cannot be reused for acquisitions.
     78 runInRuntime :: R.Runtime -> T -> IO Outcome
     79 runInRuntime runtime action = do
     80   identity <- R.runtimeIdentity runtime
     81   scheduler <- S.newScheduler runtime
     82   group <- S.rootGroup scheduler
     83   S.runGroup group (loop runtime (R.Token identity 0) group action [])
     84 
     85 run :: T -> IO (Either String T)
     86 run action = do
     87   outcome <- runDetailed action
     88   pure $ case outcome of
     89     Completed value -> Right value
     90     Cancelled _ cleanup -> Left ("IO v2 task cancelled (reason not forced; " ++ show (length cleanup) ++ " cleanup diagnostics)")
     91     Failed _ cleanup -> Left ("IO v2 task failed (diagnostic payload not forced; " ++ show (length cleanup) ++ " cleanup diagnostics)")
     92 
     93 loop :: R.Runtime -> R.Token -> S.Group -> T -> [T] -> IO Outcome
     94 loop runtime marker group action frames = S.checkpoint group >> step
     95   where
     96     scope = S.scopeOf group
     97     step = case P.decodeAction action of
     98       Left detail -> pure (protocolFailure detail)
     99       Right (P.Core code payload) -> dispatch code payload $ case lookup code
    100         [(5,"spawn"),(6,"join"),(7,"discard"),(8,"cancel")] of
    101           Just name -> done . qualifyError ("core/" ++ name)
    102           Nothing -> done
    103       Right (P.Request facility revision operation arguments) ->
    104         case P.resolve facility revision operation of
    105           Just code -> dispatch code arguments (done . qualifyError (facility ++ "/" ++ operation))
    106           Nothing -> done (reply id (Left (R.Problem "unsupported"
    107             (facility ++ "/" ++ operation) ("group revision " ++ show revision) "none")))
    108     dispatch code payload finish = case code of
    109         0 -> finish payload
    110         1 -> case payload of
    111           Fork first next -> loop runtime marker group first (next:frames)
    112           _ -> pure protocol
    113         2 -> pure (Failed payload [])
    114         3 -> do
    115           result <- S.nested group (\child -> loop runtime marker child
    116             (apply payload (scopeTree marker (S.scopeOf child))) [])
    117           case result of Completed value -> finish value; failure -> pure failure
    118         4 -> finish (scopeTree marker scope)
    119         5 -> case payload of
    120           Fork supervised (Fork keep (Fork handles callback)) ->
    121             case (canonicalNat 1 supervised, canonicalNat 1 keep, decodeHandles handles) of
    122               (Just contain, Just retain, Just tokens) | contain <= 1 && retain <= 1 -> do
    123                 result <- S.spawn group (contain == 1) (retain == 1) tokens (\child fresh ->
    124                   loop runtime marker child (apply callback (ofList (map tokenTree fresh))) [])
    125                 finish (reply (spawnReply (retain == 1)) result)
    126               _ -> finish (bad "spawn")
    127           _ -> finish (bad "spawn")
    128         6 -> case decodeTask "io.v2.join" payload of
    129           Just ref -> S.join group ref >>= finish . reply outcomeTree
    130           _ -> finish (bad "join")
    131         7 -> case decodeTask "io.v2.join" payload of
    132           Just ref -> S.discard group ref >>= finish . reply (const Leaf)
    133           _ -> finish (bad "discard")
    134         8 -> case payload of
    135           Fork handle reason -> case decodeTask "io.v2.task" handle of
    136             Just ref -> S.cancel group ref reason >>= finish . reply (const Leaf)
    137             _ -> finish (bad "cancel")
    138           _ -> finish (bad "cancel")
    139         9 -> pure (Cancelled payload [])
    140         20 -> open finish R.openReader "open-reader" payload
    141         21 -> open finish R.openWriter "open-writer" payload
    142         22 -> case payload of
    143           Fork handle count -> case (decodeToken handle, canonicalNat 16 count) of
    144             (Just token, Just n) -> R.readSome runtime scope token (fromInteger n) >>= finish . reply readValue
    145             _ -> finish (bad "read")
    146           _ -> finish (bad "read")
    147         23 -> case payload of
    148           Fork handle bytes -> case (decodeToken handle, decodeChunk bytes) of
    149             (Just token, Right chunk) -> R.writeSome runtime scope token chunk >>= finish . reply (ofNumber . toInteger)
    150             _ -> finish (bad "write")
    151           _ -> finish (bad "write")
    152         24 -> case decodeToken payload of
    153           Just token -> R.closeResource runtime scope token >>= finish . reply (const Leaf)
    154           _ -> finish (bad "close")
    155         25 -> standard finish R.StandardInput payload
    156         26 -> standard finish R.StandardOutput payload
    157         27 -> standard finish R.StandardError payload
    158         50 -> open finish R.openAppender "open-appender" payload
    159         51 -> open finish R.openUpdate "open-update" payload
    160         52 -> positionOperation finish R.seekFile "seek" payload
    161         53 -> unary finish "position" R.filePosition ofNumber payload
    162         54 -> unary finish "size" R.fileSize ofNumber payload
    163         55 -> positionOperation finish R.resizeFile "resize" payload
    164         30 -> open finish Stage.openStage "stage-open" payload
    165         31 -> unary finish "seal" R.sealStage (const Leaf) payload
    166         32 -> case payload of
    167           Fork handle (Fork mode path) -> case (decodeToken handle, canonicalNat 1 mode, canonicalText path) of
    168             (Just token, Just replace, Just destination) | replace <= 1 ->
    169               R.publishStage runtime scope token (replace == 1) destination >>= finish . reply ofString
    170             _ -> finish (bad "publish")
    171           _ -> finish (bad "publish")
    172         40 -> open finish Digest.openDigest "digest-open" payload
    173         41 -> case payload of
    174           Fork handle bytes -> case (decodeToken handle, decodeChunk bytes) of
    175             (Just token, Right chunk) -> R.updateDigest runtime scope token chunk >>= finish . reply (const Leaf)
    176             _ -> finish (bad "digest-update")
    177           _ -> finish (bad "digest-update")
    178         42 -> unary finish "digest-finish" R.finishDigest ofString payload
    179         60 -> pathOperation finish "stat" (FS.statPath True) statusTree payload
    180         61 -> pathOperation finish "lstat" (FS.statPath False) statusTree payload
    181         62 -> pathOperation finish "create" FS.createDirectory (const Leaf) payload
    182         63 -> pathOperation finish "remove" FS.removeDirectory (const Leaf) payload
    183         64 -> pathOperation finish "remove-file" FS.removeFile (const Leaf) payload
    184         65 -> case payload of
    185           Fork old new -> case (canonicalText old, canonicalText new) of
    186             (Just source, Just target) -> FS.renamePath source target >>= finish . reply (const Leaf)
    187             _ -> finish (bad "rename")
    188           _ -> finish (bad "rename")
    189         66 -> open finish FS.openDirectory "open" payload
    190         67 -> unary finish "next" R.nextDirectory
    191           (maybe (Fork (ofString "eof") Leaf) (Fork (ofString "entry") . ofString)) payload
    192         80 -> case payload of
    193           Fork ownerRef (Fork endpoint backlog) -> case
    194               (decodeScope marker ownerRef, decodeEndpoint endpoint, canonicalNat 16 backlog) of
    195             (Just owner, Just target, Just limit) -> owned finish "listen" owner
    196               (TCP.listenTCP runtime owner target (fromInteger limit))
    197             _ -> finish (bad "listen")
    198           _ -> finish (bad "listen")
    199         81 -> case payload of
    200           Fork ownerRef endpoint -> case (decodeScope marker ownerRef, decodeEndpoint endpoint) of
    201             (Just owner, Just target) -> owned finish "connect" owner (TCP.connectTCP runtime owner target)
    202             _ -> finish (bad "connect")
    203           _ -> finish (bad "connect")
    204         82 -> case payload of
    205           Fork handle ownerRef -> case (decodeToken handle, decodeScope marker ownerRef) of
    206             (Just listener, Just owner) -> owned finish "accept" owner
    207               (R.acceptConnection runtime scope listener owner)
    208             _ -> finish (bad "accept")
    209           _ -> finish (bad "accept")
    210         83 -> unary finish "local-address" (\r s t -> R.socketAddress r s t False) endpointTree payload
    211         84 -> unary finish "peer-address" (\r s t -> R.socketAddress r s t True) endpointTree payload
    212         85 -> unary finish "shutdown-write" R.shutdownWrite (const Leaf) payload
    213         86 -> case payload of
    214           Fork host (Fork family (Fork port (Fork limit Leaf))) -> case
    215             (boundedHost host, resolveFamily family, canonicalNat 16 port, canonicalNat 8 limit) of
    216             (Just name, Just selection, Just service, Just count) ->
    217               Resolver.resolveTCP name selection service (fromInteger count) >>= finish . reply
    218                 (\(Resolver.Resolution endpoints truncated) -> ofList
    219                   [ofList (map endpointTree endpoints),ofNumber (if truncated then 1 else 0)])
    220             _ -> finish (bad "resolve")
    221           _ -> finish (bad "resolve")
    222         87 -> case payload of
    223           Fork reader (Fork directory (Fork limit (Fork size (Fork digest Leaf)))) -> case
    224             (decodeToken reader, canonicalText directory, canonicalNat 63 limit,
    225               canonicalNat 63 size, boundedDigest digest) of
    226             (Just token, Just path, Just maximum, Just count, Just expected) ->
    227               Codec.readIndexed runtime scope token path maximum count expected >>= finish . reply id
    228             _ -> finish (bad "read")
    229           _ -> finish (bad "read")
    230         88 -> case payload of
    231           Fork limit tree -> case canonicalNat 63 limit of
    232             Just maximum -> Codec.hashIndexed maximum tree >>= finish . reply encodedInfo
    233             _ -> finish (bad "hash")
    234           _ -> finish (bad "hash")
    235         89 -> case payload of
    236           Fork writer (Fork limit (Fork digest (Fork tree Leaf))) -> case
    237             (decodeToken writer, canonicalNat 63 limit, boundedDigest digest) of
    238             (Just token, Just maximum, Just expected) ->
    239               Codec.writeIndexed runtime scope token maximum expected tree >>= finish . reply encodedInfo
    240             _ -> finish (bad "write")
    241           _ -> finish (bad "write")
    242         95 -> case payload of
    243           Fork reader (Fork limit (Fork tree Leaf)) -> case (decodeToken reader, canonicalNat 63 limit) of
    244             (Just token, Just maximum) -> Codec.verifyIndexed runtime scope token maximum tree >>= finish . reply encodedInfo
    245             _ -> finish (bad "verify")
    246           _ -> finish (bad "verify")
    247         56 -> unary finish "sync" R.syncFile (const Leaf) payload
    248         68 -> pathOperation finish "sync" (FS.syncDirectory runtime scope) (const Leaf) payload
    249         96 -> case unicodeChunk UTF8.scalarLimit payload of
    250           Just text -> finish (reply ofBytes (UTF8.encode text))
    251           _ -> finish (bad "encode")
    252         97 -> case payload of
    253           Fork final (Fork bytes Leaf) -> case (canonicalNat 1 final, decodeChunk bytes) of
    254             (Just end, Right chunk) -> finish (reply (\(text,carry) -> ofList [ofString text,ofBytes carry])
    255               (UTF8.decode (end == 1) chunk))
    256             _ -> finish (bad "decode")
    257           _ -> finish (bad "decode")
    258         102 -> case payload of
    259           Leaf -> Clock.monotonicNanoseconds >>= finish . ok . ofNumber
    260           _ -> finish (bad "monotonic")
    261         103 -> case canonicalNat 63 payload of
    262           Just milliseconds -> Clock.sleepMilliseconds milliseconds >> finish (ok Leaf)
    263           _ -> finish (bad "sleep")
    264         104 -> case payload of
    265           Leaf -> Concurrent.yield >> finish (ok Leaf)
    266           _ -> finish (bad "yield")
    267         106 -> case payload of
    268           Leaf -> Context.workingDirectory >>= finish . reply ofString
    269           _ -> finish (bad "working-directory")
    270         107 -> case processText payload of
    271           Just name -> Context.environmentVariable name >>= finish . reply
    272             (maybe (ofList [ofString "missing"]) (\value -> ofList [ofString "value", ofString value]))
    273           _ -> finish (bad "environment-variable")
    274         105 -> case decodeProcess payload of
    275           Just spec -> Process.launch runtime group spec >>= finish . reply
    276             (\(task,pipes) -> ofList ([taskTree "io.v2.task" task, taskTree "io.v2.join" task] ++ map tokenTree pipes))
    277           Nothing -> finish (bad "spawn")
    278         108 -> case payload of
    279           Fork reader (Fork directory (Fork limit (Fork digest Leaf))) -> case
    280             (decodeToken reader, canonicalText directory, canonicalNat 63 limit, boundedDigest digest) of
    281             (Just token, Just path, Just maximum, Just expected) ->
    282               ByteStream.snapshot runtime scope token path maximum expected >>= finish . reply
    283                 (\(snapshot,size) -> ofList [tokenTree snapshot,ofNumber size])
    284             _ -> finish (bad "snapshot")
    285           _ -> finish (bad "snapshot")
    286         109 -> case payload of
    287           Fork reader (Fork writer (Fork count Leaf)) -> case
    288             (decodeToken reader, decodeToken writer, canonicalNat 63 count) of
    289             (Just input, Just output, Just size) ->
    290               ByteStream.transfer runtime scope input output size >>= finish . reply (const Leaf)
    291             _ -> finish (bad "transfer")
    292           _ -> finish (bad "transfer")
    293         100 -> case payload of
    294           Leaf -> finish (ok P.capabilities)
    295           _ -> finish (bad "capabilities")
    296         101 -> finish (reply id (P.inspectAction payload))
    297         _ -> pure protocol
    298     encodedInfo (size,digest) = ofList [ofNumber size, ofString digest]
    299     done value = case frames of
    300         [] -> pure (Completed value)
    301         next:rest -> loop runtime marker group (apply next value) rest
    302     owned finish name owner action = do
    303       allowed <- R.isAncestor runtime scope owner
    304       if allowed then action >>= finish . reply tokenTree else finish (bad name)
    305     pathOperation finish name operation encode payload = case canonicalText payload of
    306       Just path -> operation path >>= finish . reply encode
    307       _ -> finish (bad name)
    308     statusTree status = case status of
    309       FS.Regular size -> ofList [ofString "file",ofNumber size]
    310       FS.Directory -> ofList [ofString "directory"]
    311       FS.Symlink -> ofList [ofString "symlink"]
    312       FS.Other -> ofList [ofString "other"]
    313     positionOperation finish operation name payload = case payload of
    314       Fork handle value -> case (decodeToken handle, canonicalNat 63 value) of
    315         (Just token, Just position) -> operation runtime scope token position >>= finish . reply (const Leaf)
    316         _ -> finish (bad name)
    317       _ -> finish (bad name)
    318     standard finish stream payload = case payload of
    319       Leaf -> R.standardStream runtime scope stream >>= finish . reply tokenTree
    320       _ -> finish (bad "standard-stream")
    321     readValue bytes | BS.null bytes = Fork (ofString "eof") Leaf
    322                       | otherwise = Fork (ofString "data") (ofBytes bytes)
    323     unary finish name operation encode value = case decodeToken value of
    324       Just token -> operation runtime scope token >>= finish . reply encode
    325       _ -> finish (bad name)
    326     open finish opener name value = case value of
    327         Fork scopeRef path -> case (decodeScope marker scopeRef, canonicalText path) of
    328           (Just owner, Just filename) -> do
    329             allowed <- R.isAncestor runtime scope owner
    330             if allowed then opener runtime owner filename >>= finish . reply tokenTree else finish (bad name)
    331           _ -> finish (bad name)
    332         _ -> finish (bad name)
    333 
    334 -- Transfer lists are bounded separately from binary chunks. Excess tails are
    335 -- not forced; the bound is shared with capability reporting.
    336 decodeHandles :: T -> Maybe [R.Token]
    337 decodeHandles = walk P.transferLimit
    338   where
    339     walk _ Leaf = Just []
    340     walk 0 _ = Nothing
    341     walk n (Fork h rest) = (:) <$> decodeToken h <*> walk (n-1) rest
    342     walk _ _ = Nothing
    343 
    344 taskTree :: String -> S.TaskRef -> T
    345 taskTree tag (S.TaskRef identity key) = ofList [ofString tag, ofNumber identity, ofNumber key]
    346 decodeTask :: String -> T -> Maybe S.TaskRef
    347 decodeTask expected (Fork tag (Fork identity (Fork key Leaf)))
    348   | tag == ofString expected = S.TaskRef <$> canonicalNat 64 identity <*> canonicalNat 64 key
    349 decodeTask _ _ = Nothing
    350 spawnReply :: Bool -> S.TaskRef -> T
    351 spawnReply keep ref = ofList [taskTree "io.v2.task" ref, if keep then taskTree "io.v2.join" ref else Leaf]
    352 outcomeTree :: Outcome -> T
    353 outcomeTree (Completed value) = ofList [ofString "completed", value]
    354 outcomeTree (Failed diagnostic cleanup) = ofList [ofString "failed", diagnostic, ofList (map problemTree cleanup)]
    355 outcomeTree (Cancelled reason cleanup) = ofList [ofString "cancelled", reason, ofList (map problemTree cleanup)]
    356 
    357 canonicalText :: T -> Maybe String
    358 canonicalText value = case toString value of
    359   Right text | '\0' `notElem` text && value == ofString text -> Just text
    360   _ -> Nothing
    361 
    362 -- Endpoint components have fixed lengths; an excess element is not inspected.
    363 decodeEndpoint :: T -> Maybe R.Endpoint
    364 decodeEndpoint (Fork tag (Fork bytes (Fork port Leaf)))
    365   | tag == ofString "ipv4" = do
    366       values <- components 4 8 bytes
    367       p <- canonicalNat 16 port
    368       case values of
    369         [a,b,c,d] -> Just (R.IPv4 (fromInteger a,fromInteger b,fromInteger c,fromInteger d) (fromInteger p))
    370         _ -> Nothing
    371 decodeEndpoint (Fork tag (Fork words (Fork scope (Fork port Leaf))))
    372   | tag == ofString "ipv6" = do
    373       values <- components 8 16 words
    374       s <- canonicalNat 32 scope
    375       p <- canonicalNat 16 port
    376       case values of
    377         [a,b,c,d,e,f,g,h] -> Just (R.IPv6
    378           (fromInteger a,fromInteger b,fromInteger c,fromInteger d,fromInteger e,fromInteger f,fromInteger g,fromInteger h)
    379           (fromInteger s) (fromInteger p))
    380         _ -> Nothing
    381 decodeEndpoint _ = Nothing
    382 components :: Int -> Int -> T -> Maybe [Integer]
    383 components 0 _ Leaf = Just []
    384 components 0 _ _ = Nothing
    385 components n bits (Fork first rest) = (:) <$> canonicalNat bits first <*> components (n-1) bits rest
    386 components _ _ _ = Nothing
    387 endpointTree :: R.Endpoint -> T
    388 endpointTree (R.IPv4 (a,b,c,d) p) = ofList [ofString "ipv4",numbers [a,b,c,d],ofNumber (toInteger p)]
    389 endpointTree (R.IPv6 (a,b,c,d,e,f,g,h) s p) = ofList
    390   [ofString "ipv6",numbers [a,b,c,d,e,f,g,h],ofNumber (toInteger s),ofNumber (toInteger p)]
    391 numbers :: Integral a => [a] -> T
    392 numbers = ofList . map (ofNumber . toInteger)
    393 
    394 -- Exactly 64 lowercase hex digits; reject an excess spine without forcing it.
    395 boundedDigest :: T -> Maybe String
    396 boundedDigest = walk (64 :: Int)
    397   where
    398     walk 0 Leaf = Just []
    399     walk 0 _ = Nothing
    400     walk n (Fork c rest) = do
    401       code <- canonicalNat 7 c
    402       if (code >= 48 && code <= 57) || (code >= 97 && code <= 102)
    403         then (toEnum (fromInteger code) :) <$> walk (n-1) rest
    404         else Nothing
    405     walk _ _ = Nothing
    406 
    407 -- Text codecs accept NUL, unlike paths. Unicode surrogate code points and
    408 -- noncanonical scalar naturals are rejected before conversion to host Char.
    409 unicodeChunk :: Int -> T -> Maybe String
    410 unicodeChunk _ Leaf = Just []
    411 unicodeChunk 0 _ = Nothing
    412 unicodeChunk n (Fork c rest) = do
    413   scalar <- canonicalNat 21 c
    414   if scalar <= 0x10ffff && not (scalar >= 0xd800 && scalar <= 0xdfff)
    415     then (toEnum (fromInteger scalar) :) <$> unicodeChunk (n-1) rest
    416     else Nothing
    417 unicodeChunk _ _ = Nothing
    418 
    419 resolveFamily :: T -> Maybe Resolver.Family
    420 resolveFamily value
    421   | value == ofString "ipv4" = Just Resolver.IPv4Only
    422   | value == ofString "ipv6" = Just Resolver.IPv6Only
    423   | value == ofString "any" = Just Resolver.AnyFamily
    424   | otherwise = Nothing
    425 boundedHost :: T -> Maybe String
    426 boundedHost = walk Resolver.hostLimit
    427   where walk _ Leaf = Just []
    428         walk 0 _ = Nothing
    429         walk n (Fork first rest) = do
    430           code <- canonicalNat 7 first
    431           (toEnum (fromInteger code):) <$> walk (n-1) rest
    432         walk _ _ = Nothing
    433 
    434 -- Bounded before constructing host strings/lists; an excess element is inert.
    435 decodeProcess :: T -> Maybe Process.Spec
    436 decodeProcess (Fork executable (Fork arguments (Fork directory (Fork environment (Fork grace Leaf))))) = do
    437   exe <- processText executable
    438   args <- boundedList 256 processText arguments
    439   cwd <- case directory of
    440     Fork tag Leaf | tag == ofString "inherit" -> Just Nothing
    441     Fork tag (Fork path Leaf) | tag == ofString "at" -> Just <$> processText path
    442     _ -> Nothing
    443   env <- case environment of
    444     Fork tag Leaf | tag == ofString "inherit" -> Just Nothing
    445     Fork tag (Fork entries Leaf) | tag == ofString "replace" -> Just <$> boundedList 256 entry entries
    446     _ -> Nothing
    447   duration <- canonicalNat 63 grace
    448   let spec = Process.Spec exe args cwd env duration
    449   if Process.validSpec spec then Just spec else Nothing
    450   where
    451     entry (Fork key (Fork value Leaf)) = (,) <$> processText key <*> processText value
    452     entry _ = Nothing
    453 decodeProcess _ = Nothing
    454 
    455 boundedList :: Int -> (T -> Maybe a) -> T -> Maybe [a]
    456 boundedList _ _ Leaf = Just []
    457 boundedList 0 _ _ = Nothing
    458 boundedList n decode (Fork value rest) = (:) <$> decode value <*> boundedList (n-1) decode rest
    459 boundedList _ _ _ = Nothing
    460 
    461 processText :: T -> Maybe String
    462 processText = boundedList 4096 scalar
    463   where
    464     scalar value = do
    465       n <- canonicalNat 21 value
    466       if n > 0 && n <= 1114111 && not (n >= 55296 && n <= 57343)
    467         then Just (toEnum (fromInteger n)) else Nothing
	tricu An interpreted language for exploring Tree Calculus
	Log \| Files \| Refs \| README \| LICENSE