tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

BrowserRuntime.hs (8345B)

      1 {-# LANGUAGE BangPatterns #-}
      2 -- Browser embedding primitives, not an alternate evaluator. All application is
      3 -- Runtime.Tree.apply; observation budgets bound transport, not reduction fuel.
      4 module BrowserRuntime where
      5 import Runtime.Tree
      6 import Runtime.Value
      7 import qualified IO.Wire as Wire
      8 import Control.Exception (evaluate)
      9 import Control.Monad (unless, forM_)
     10 import Data.Array (Array, listArray, (!), elems)
     11 import Data.Bits ((.|.), shiftL)
     12 import qualified Data.ByteString as BS
     13 import qualified Data.Text as Text
     14 import qualified Data.Text.Encoding as Text
     15 import qualified Data.IntMap.Strict as IM
     16 import qualified Data.IntSet as IS
     17 import Data.IORef
     18 import Data.Char (ord, generalCategory, GeneralCategory(Space))
     19 import System.IO.Error (catchIOError)
     20 import Data.List (intercalate)
     21 import System.Mem.StableName
     22 import Data.Word (Word32)
     23 import Numeric (showHex)
     24 import Text.Read (readMaybe)
     25 
     26 -- JSON output only. Inputs use length-prefixed byte fields, avoiding a second
     27 -- implementation of the site's JSON/literal validator inside the RTS.
     28 data J = S String | N Integer | B Bool | A [J] | O [(String,J)]
     29 json :: J -> String
     30 json (S s)='"':concatMap escape s++"\"" where
     31   escape '"'="\\\""; escape '\\'="\\\\"
     32   escape c | ord c<32 = let h=showHex (ord c) "" in "\\u"++replicate (4-length h) '0'++h
     33            | otherwise=[c]
     34 json (N n)=show n
     35 json (B b)=if b then "true" else "false"
     36 json (A xs)="["++intercalate "," (map json xs)++"]"
     37 json (O xs)="{"++intercalate "," [json(S k)++":"++json v | (k,v)<-xs]++"}"
     38 number :: Int -> J
     39 number=N . toInteger
     40 
     41 word :: BS.ByteString -> Int -> Int
     42 word b at=fromIntegral (foldr (.|.) 0 [fromIntegral(BS.index b (at+j)) `shiftL` (8*j) | j<-[0..3]] :: Word32)
     43 fields :: BS.ByteString -> IO [BS.ByteString]
     44 fields b=go 0 0 where
     45   go at count
     46     | at==BS.length b=pure []
     47     | count>=16384 || BS.length b-at<4=fail "invalid field framing"
     48     | otherwise=do
     49         let n=word b at
     50         unless(n>=0 && n<=BS.length b-at-4)(fail "truncated field")
     51         rest<-go (at+4+n) (count+1)
     52         pure(BS.take n (BS.drop (at+4) b):rest)
     53 utf8 :: BS.ByteString -> IO String
     54 utf8=either (fail.show) (pure.Text.unpack) . Text.decodeUtf8'
     55 index :: Int -> BS.ByteString -> IO Int
     56 index upper b=do
     57   s<-utf8 b
     58   case readMaybe s of Just n | n>=0 && n<upper -> pure n; _->fail "invalid index"
     59 
     60 loadDAG :: BS.ByteString -> IO (Array Int T,Int)
     61 loadDAG b=do
     62   unless(BS.length b>=8)(fail "truncated DAG")
     63   let n=word b 0;root=word b 4
     64   unless(n>0 && n<=1000000 && root>=0 && root<n && BS.length b==8+9*n)(fail "invalid DAG header")
     65   forM_ [0..n-1] $ \i->do
     66     let at=8+9*i;tag=BS.index b at;l=word b (at+1);r=word b(at+5);prior x=x>=0&&x<i
     67     unless(case tag of 0->l==0&&r==0;1->prior l&&r==0;2->prior l&&prior r;_->False)(fail "invalid DAG record")
     68   let trees=listArray (0,n-1) [case BS.index b(8+9*i) of
     69         0->Leaf;1->Stem(trees!word b(9+9*i));_->Fork(trees!word b(9+9*i))(trees!word b(13+9*i)) | i<-[0..n-1]]
     70   forM_ (elems trees) $ \t->evaluate(case t of Leaf->();Stem x->x `seq` ();Fork x y->x `seq` y `seq` ())
     71   pure(trees,n)
     72 
     73 boundedList :: Int -> T -> IO [T]
     74 boundedList limit=go limit where
     75   go n tree=case tree of
     76     Leaf->pure []
     77     Fork a rest | n>0 ->(a:) <$> go(n-1) rest
     78                 | otherwise->fail "List decode limit exceeded"
     79     _->fail "Invalid canonical list"
     80 natural :: T -> IO Integer
     81 natural=go 0 1 0 where
     82   go !bits !place !acc tree
     83     | bits>4096=fail "Natural number decode limit exceeded"
     84     | otherwise=case tree of
     85         Leaf->pure acc
     86         Fork bit rest->case bit of
     87           Leaf->go(bits+1)(2*place)acc rest
     88           Stem Leaf->go(bits+1)(2*place)(acc+place)rest
     89           _->fail "Invalid number bit"
     90         _->fail "Invalid canonical number"
     91 text :: Int -> T -> IO String
     92 text limit tree=boundedList limit tree >>= mapM (\t->natural t >>= either fail pure . toChar)
     93 boolean :: T -> IO Bool
     94 boolean Leaf=pure False
     95 boolean (Stem Leaf)=pure True
     96 boolean _=fail "Invalid canonical Boolean"
     97 pair :: T -> IO (T,T)
     98 pair (Fork a b)=pure(a,b)
     99 pair _=fail "Expected pair"
    100 
    101 -- Local IDs label a snapshot only. Register children WITHOUT evaluating them.
    102 -- Stable-name collisions are resolved by equality; aliases record thunk updates.
    103 -- Hitting the budget never forces the next pending child.
    104 preview :: Int -> T -> IO J
    105 preview limit root=do
    106   unless(limit>=1 && limit<=100000)(fail "Invalid snapshot budget")
    107   memo<-newIORef IM.empty
    108   next<-newIORef 0
    109   done<-newIORef IS.empty
    110   let register t=do
    111         sn<-makeStableName t
    112         seen<-readIORef memo
    113         case lookup sn (IM.findWithDefault [] (hashStableName sn) seen) of
    114           Just ident->pure ident
    115           Nothing->do
    116             ident<-readIORef next;modifyIORef' next (+1)
    117             modifyIORef' memo (IM.insertWith (++) (hashStableName sn) [(sn,ident)])
    118             pure ident
    119       go [] _ rows aliases=pure(rows,aliases,False)
    120       go _ 0 rows aliases=pure(rows,aliases,True)
    121       go ((ident,input):pending) budget rows aliases=do
    122         tree<-evaluate input
    123         sn<-makeStableName tree
    124         seen<-readIORef memo
    125         case lookup sn (IM.findWithDefault [] (hashStableName sn) seen) of
    126           Just other | other/=ident ->go pending budget rows ((ident,other):aliases)
    127           _->do
    128             modifyIORef' memo (IM.insertWith (++) (hashStableName sn) [(sn,ident)])
    129             visited<-readIORef done
    130             if IS.member ident visited then go pending budget rows aliases else do
    131               modifyIORef' done (IS.insert ident)
    132               let (kind,children)=case tree of Leaf->("leaf",[]);Stem a->("stem",[a]);Fork a b->("fork",[a,b])
    133               ids<-mapM register children
    134               go (reverse(zip ids children)++pending) (budget-1) ((ident,kind,ids):rows) aliases
    135   rid<-register root
    136   (rows,aliases,truncated)<-go [(rid,root)] limit [] []
    137   pure(O [("root",number rid),("nodes",A [O[("id",number i),("kind",S k),("children",A(map number cs))] | (i,k,cs)<-reverse rows]),
    138           ("aliases",A[O[("from",number a),("to",number b)] | (a,b)<-reverse aliases]),("truncated",B truncated)])
    139 
    140 -- Ordinary decoded lists have a separate bound from 32-item graph previews.
    141 decodedListLimit :: Int
    142 decodedListLimit=4096
    143 
    144 view :: String -> T -> IO J
    145 view kind tree=do
    146   value<-case kind of
    147     "tricu"->preview 100000 tree
    148     "triangle"->preview 100000 tree
    149     "dag"->preview 100000 tree
    150     "ternary"->preview 100000 tree
    151     "io-envelope"->catchIOError (ioEnvelope tree >> pure(B True)) (\_ -> pure(B False))
    152     "tree"->preview 64 tree
    153     "string"->S <$> text 4096 tree
    154     "number"->S . show <$> natural tree
    155     "bool"->B <$> boolean tree
    156     "bytes"->do
    157       xs<-boundedList 4096 tree
    158       A <$> mapM (\x->do n<-natural x;unless(n<=255)(fail "Invalid byte");pure(N n)) xs
    159     "list"->boundedList 32 tree >>= fmap A . mapM (preview 8)
    160     "values"->boundedList decodedListLimit tree >>= fmap A . mapM scalar
    161     _->fail "Unsupported output codec"
    162   pure(O[("type",S kind),("value",value)])
    163   where
    164     scalar t=catchIOError (do
    165       s<-text 4096 t
    166       unless(not(null s) && all readable s)(fail "Not readable text")
    167       pure(O[("type",S "string"),("value",S s)])) (\_ -> do
    168         n<-natural t
    169         pure(O[("type",S "number"),("value",S(show n))]))
    170     readable c=generalCategory c<=Space || c `elem` "\t\n\r\x200c\x200d"
    171 
    172 -- Bounded framing selection does not inspect the computation or its payload.
    173 ioEnvelope :: T -> IO (Integer,T)
    174 ioEnvelope root=do
    175   (sentinel,body)<-pair root
    176   let match [] Leaf=True
    177       match (c:cs) (Fork x xs)=Wire.canonicalNat 7 x==Just(toInteger(ord c)) && match cs xs
    178       match _ _=False
    179   unless(match "tricuIO" sentinel)(fail "Missing tricuIO sentinel")
    180   (version,action)<-pair body
    181   case Wire.canonicalNat 2 version of
    182     Just 2 -> pure(2,action)
    183     _ -> fail "Unsupported tricuIO version"
    184 
    185 -- Private embedding inspection, not an IO start or capability claim. Only a
    186 -- computation header is classified; arguments and terminal payloads stay lazy.
    187 ioHeader :: T -> IO J
    188 ioHeader tree = case Wire.decodeAction tree of
    189   Left message -> fail message
    190   Right (Wire.Core code _) -> pure (O [("kind",S "core"),("code",N code)])
    191   Right (Wire.Request group revision operation _) -> pure (O
    192     [("kind",S "request"),("group",S group),("revision",N revision),("operation",S operation)])