tricu

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

Reactor.hs (13665B)

      1 {-# LANGUAGE ForeignFunctionInterface #-}
      2 {-# LANGUAGE ScopedTypeVariables #-}
      3 module Reactor where
      4 
      5 import qualified CompilerProbe as C
      6 import qualified BrowserRuntime as R
      7 import qualified BrowserTrees as BT
      8 import qualified BrowserModules as M
      9 import Data.Array (Array, (!))
     10 import Text.Read (readMaybe)
     11 import Runtime.Tree
     12 import Runtime.Value
     13 import Control.Exception (SomeException, SomeAsyncException, catch, evaluate, fromException, displayException)
     14 import Control.Monad (unless)
     15 import Data.IORef
     16 import Data.List (nub)
     17 import qualified Data.ByteString as BS
     18 import qualified Data.Text as Text
     19 import qualified Data.Text.Encoding as Text
     20 import Foreign.Ptr (Ptr, castPtr)
     21 import Foreign.C.Types (CInt(..))
     22 import Foreign.Marshal.Utils (copyBytes)
     23 import System.IO.Unsafe (unsafePerformIO)
     24 import System.Mem (performGC)
     25 import System.IO.Error (isUserError, ioeGetErrorString)
     26 
     27 {-# NOINLINE context #-}
     28 context :: IORef (Maybe (T,T))
     29 context = unsafePerformIO (newIORef Nothing)
     30 {-# NOINLINE current #-}
     31 current :: IORef [(String,T)]
     32 current = unsafePerformIO (newIORef [])
     33 {-# NOINLINE compilerLibrary #-}
     34 compilerLibrary :: IORef M.Bindings
     35 compilerLibrary = unsafePerformIO (newIORef [])
     36 {-# NOINLINE expressionBindings #-}
     37 expressionBindings :: IORef M.Bindings
     38 expressionBindings = unsafePerformIO (newIORef [])
     39 {-# NOINLINE pendingModule #-}
     40 pendingModule :: IORef (Maybe (M.Stage,[(String,M.Bindings)]))
     41 pendingModule = unsafePerformIO (newIORef Nothing)
     42 {-# NOINLINE response #-}
     43 response :: IORef BS.ByteString
     44 response = unsafePerformIO (newIORef BS.empty)
     45 
     46 -- One owned response at a time; no tree handles or Haskell heap addresses cross
     47 -- the boundary. JS copies it out before another request. Inputs are copied in.
     48 reply :: String -> IO ()
     49 reply s = do
     50   let bounded=take (16777216+1) s
     51   unless (length bounded<=16777216) (fail "response limit exceeded")
     52   let bytes=Text.encodeUtf8 (Text.pack bounded)
     53   unless (BS.length bytes<=16777216) (fail "response byte limit exceeded")
     54   _<-evaluate (BS.length bytes)
     55   writeIORef response bytes
     56 
     57 guardRequest :: IO () -> IO CInt
     58 guardRequest action = (action >> pure 0) `catch` \(e::SomeException) -> do
     59   let message=case fromException e of
     60         Just ioError | isUserError ioError -> ioeGetErrorString ioError
     61         _ -> displayException e
     62   reply ("error\n"++take 2048 message)
     63   pure (case (fromException e :: Maybe SomeAsyncException) of Just _->2;Nothing->1)
     64 
     65 input :: Ptr () -> CInt -> IO String
     66 input ptr len = do
     67   unless (len>=0 && len<=16777216) (fail "input byte limit exceeded")
     68   bytes<-BS.packCStringLen (castPtr ptr,fromIntegral len)
     69   either (fail . show) (pure . Text.unpack) (Text.decodeUtf8' bytes)
     70 
     71 initialize :: IO CInt
     72 initialize = guardRequest $ do
     73   existing<-readIORef context
     74   case existing of Just _->fail "already initialized"; Nothing->pure ()
     75   (compiler,env,library)<-C.loadLibrary "/data"
     76   writeIORef context (Just (compiler,env))
     77   writeIORef compilerLibrary library
     78   reply "ok\nready"
     79 
     80 compileSource :: Ptr () -> CInt -> IO CInt
     81 compileSource ptr len = guardRequest $ do
     82   source<-input ptr len
     83   ctx<-readIORef context
     84   (compiler,env)<-maybe (fail "not initialized") pure ctx
     85   compileWith compiler env source
     86 
     87 compileWith :: T -> T -> String -> IO ()
     88 compileWith compiler env source = do
     89   requireIdle
     90   unless(not(null source)&&length source<=16384)(fail "source scalar limit exceeded")
     91   let argument=ofString source
     92   _<-evaluate(C.force argument)
     93   defs<-case C.definitions(C.compile compiler env argument) of
     94     Left message->fail message
     95     Right values->pure values
     96   let names=map fst(take 4097 defs)
     97   unless(not(null names)&&length names<=4096&&all (\n->not(null n)&&length n<=128) names&&length(nub names)==length names)
     98     (fail "invalid compiler export names")
     99   reply("ok\n"++unlines names)
    100   writeIORef current defs
    101   writeIORef expressionBindings defs
    102   writeIORef pendingModule Nothing
    103 
    104 observe :: Ptr () -> CInt -> IO CInt
    105 observe ptr len = guardRequest $ do
    106   request<-input ptr len
    107   (name,args)<-case lines request of []->fail "missing export"; n:as->pure(n,as)
    108   unless (length args<=16 && all ((<=50000).length) args) (fail "argument limit exceeded")
    109   defs<-readIORef current
    110   term<-maybe (fail "missing export") pure (lookup name defs)
    111   let result=foldl apply term (map C.fromTernary args)
    112   reply ("ok\n"++C.ternary result)
    113 
    114 dump :: IO CInt
    115 dump = guardRequest $ do
    116   defs<-readIORef current
    117   reply ("ok\n"++unlines [name++"\t"++C.ternary term | (name,term)<-defs])
    118 
    119 reset :: IO CInt
    120 reset = guardRequest $ do
    121   writeIORef current []
    122   writeIORef expressionBindings []
    123   writeIORef pendingModule Nothing
    124   writeIORef response BS.empty
    125   performGC
    126   reply "ok\nreset"
    127 
    128 collect :: IO CInt
    129 collect = guardRequest (performGC >> reply "ok\ncollected")
    130 
    131 responseSize :: IO CInt
    132 responseSize = fromIntegral . BS.length <$> readIORef response
    133 responseCopy :: Ptr () -> CInt -> IO CInt
    134 responseCopy ptr capacity = do
    135   bytes<-readIORef response
    136   if fromIntegral capacity<BS.length bytes then pure (-1) else do
    137     BS.useAsCStringLen bytes $ \(src,len)->copyBytes ptr (castPtr src) len
    138     writeIORef response BS.empty
    139     pure (fromIntegral (BS.length bytes))
    140 
    141 
    142 -- Only protocol 2 may allocate a private tree run. Framing rejection leaves
    143 -- definitions intact and never evaluates the computation or calls the host.
    144 beginSelectedIO :: T -> IO ()
    145 beginSelectedIO term = do
    146   (_,action)<-R.ioEnvelope term
    147   handles<-BT.begin action
    148   reply("ok\n"++R.json(R.O [("kind",R.S "v2"),("tree",handles)]))
    149 
    150 requireIdle :: IO ()
    151 requireIdle = do
    152   treeActive<-BT.active
    153   unless(not treeActive)(fail "private tree run is pending")
    154 
    155 select :: BS.ByteString -> BS.ByteString -> [BS.ByteString] -> IO T
    156 select nameBytes dag roots=do
    157   name<-R.utf8 nameBytes
    158   defs<-readIORef current
    159   worker<-maybe (fail "missing export") pure (lookup name defs)
    160   unless(length roots<=16)(fail "argument limit exceeded")
    161   (trees,n)<-R.loadDAG dag
    162   indices<-mapM (R.index n) roots
    163   pure(foldl apply worker [trees!i | i<-indices])
    164 
    165 bindings :: Array Int T -> Int -> [BS.ByteString] -> IO [(String,T)]
    166 bindings trees n entries=do
    167   unless(length entries<=8192&&even(length entries))(fail "invalid binding table")
    168   let pairs []=pure []
    169       pairs (nameBytes:rootBytes:rest)=do
    170         name<-R.utf8 nameBytes
    171         unless(not(null name)&&length name<=4096)(fail "invalid binding name")
    172         root<-R.index n rootBytes
    173         ((name,trees!root):) <$> pairs rest
    174       pairs _=fail "invalid binding table"
    175   defs<-pairs entries
    176   unless(length(nub(map fst defs))==length defs)(fail "duplicate binding name")
    177   pure defs
    178 
    179 request :: Ptr () -> CInt -> IO CInt
    180 request ptr len = guardRequest $ do
    181   unless(len>=0 && len<=16777216)(fail "input byte limit exceeded")
    182   bytes<-BS.packCStringLen(castPtr ptr,fromIntegral len)
    183   fs<-R.fields bytes
    184   (op,arguments)<-case fs of
    185     tag:rest->do name<-R.utf8 tag;pure(name,rest)
    186     _->fail "missing operation"
    187   case (op,arguments) of
    188     ("module-header",[sourceBytes])->do
    189       requireIdle
    190       initialized<-readIORef context
    191       case initialized of Nothing->fail "compiler not initialized"; Just _->pure ()
    192       library<-readIORef compilerLibrary
    193       source<-R.utf8 sourceBytes
    194       staged<-M.stage library source
    195       reply("ok\n"++R.json(M.stageJSON staged))
    196     ("module-stage",[sourceBytes])->do
    197       requireIdle
    198       writeIORef current []
    199       writeIORef expressionBindings []
    200       writeIORef pendingModule Nothing
    201       initialized<-readIORef context
    202       case initialized of Nothing->fail "compiler not initialized"; Just _->pure ()
    203       library<-readIORef compilerLibrary
    204       source<-R.utf8 sourceBytes
    205       staged<-M.stage library source
    206       reply("ok\n"++R.json(M.stageJSON staged))
    207       writeIORef pendingModule (Just (staged,[]))
    208     ("module-dependency",refBytes:dag:entries)->do
    209       requireIdle
    210       saved<-readIORef pendingModule
    211       (staged,modules)<-maybe (fail "No pending module") pure saved
    212       ref<-R.utf8 refBytes
    213       unless(length ref==64 && all (`elem` ("0123456789abcdef"::String)) ref && not(ref `elem` map fst modules))
    214         (fail "Invalid or duplicate module reference")
    215       (trees,n)<-R.loadDAG dag
    216       values<-bindings trees n entries
    217       writeIORef pendingModule (Just(staged,modules++[(ref,values)]))
    218       reply "ok\nloaded"
    219     ("module-compile",[])->do
    220       requireIdle
    221       saved<-readIORef pendingModule
    222       (staged,modules)<-maybe (fail "No pending module") pure saved
    223       ctx<-readIORef context
    224       (compiler,_)<-maybe (fail "compiler not initialized") pure ctx
    225       library<-readIORef compilerLibrary
    226       (public,scope)<-M.compile library compiler staged modules
    227       reply("ok\n"++unlines(map fst public))
    228       writeIORef current public
    229       writeIORef expressionBindings scope
    230       writeIORef pendingModule Nothing
    231     ("module-scope",[])->do
    232       scope<-readIORef expressionBindings
    233       reply("ok\n"++R.json(R.A(map (R.S . fst) scope)))
    234     ("module-abort",[])->do
    235       requireIdle
    236       writeIORef current []
    237       writeIORef expressionBindings []
    238       writeIORef pendingModule Nothing
    239       reply "ok\naborted"
    240     ("compile",sourceBytes:dag:entries)->do
    241       requireIdle
    242       ctx<-readIORef context
    243       (compiler,_)<-maybe (fail "compiler not initialized") pure ctx
    244       source<-R.utf8 sourceBytes
    245       (trees,n)<-R.loadDAG dag
    246       defs<-bindings trees n entries
    247       compileWith compiler (ofList [Fork (ofString name) tree | (name,tree)<-defs]) source
    248     -- Compile against existing named trees without serializing, evaluating or
    249     -- replacing them. The temporary result lives only in this call/IO session.
    250     ("expression",[nameBytes,sourceBytes,modeBytes,codec])->do
    251       requireIdle
    252       ctx<-readIORef context
    253       (compiler,_)<-maybe (fail "compiler not initialized") pure ctx
    254       name<-R.utf8 nameBytes
    255       source<-R.utf8 sourceBytes
    256       mode<-R.utf8 modeBytes
    257       kind<-R.utf8 codec
    258       unless(not(null source)&&length source<=16384)(fail "source scalar limit exceeded")
    259       defs<-readIORef expressionBindings
    260       let env=ofList [Fork (ofString key) tree | (key,tree)<-defs]
    261       values<-either fail pure (C.definitions(C.compile compiler env (ofString source)))
    262       term<-case values of
    263         [(key,value)] | key==name->pure value
    264         _->fail "Enter one expression, not a source unit"
    265       case mode of
    266         "pure"->do
    267           value<-R.view kind term
    268           reply("ok\n"++R.json value)
    269         "io"->do
    270           beginSelectedIO term
    271         _->fail "invalid expression mode"
    272     ("load",dag:entries)->do
    273       requireIdle
    274       (trees,n)<-R.loadDAG dag
    275       unless(not(null entries)&&length entries<=8192&&even(length entries))(fail "invalid export table")
    276       defs<-bindings trees n entries
    277       reply("ok\n"++R.json(R.A(map (R.S . fst) defs)))
    278       writeIORef current defs
    279       writeIORef expressionBindings defs
    280       writeIORef pendingModule Nothing
    281     ("inspect-definition",[nameBytes,codec])->do
    282       requireIdle
    283       name<-R.utf8 nameBytes
    284       kind<-R.utf8 codec
    285       defs<-readIORef expressionBindings
    286       term<-maybe (fail "missing definition") pure (lookup name defs)
    287       value<-R.view kind term
    288       reply("ok\n"++R.json value)
    289     ("evaluate",name:codec:dag:roots)->do
    290       kind<-R.utf8 codec
    291       term<-select name dag roots
    292       value<-R.view kind term
    293       reply("ok\n"++R.json value)
    294     ("preview",name:limit:dag:roots)->do
    295       size<-R.index 257 limit
    296       term<-select name dag roots
    297       value<-R.preview size term
    298       reply("ok\n"++R.json value)
    299     ("module-snapshot",[])->do
    300       requireIdle
    301       defs<-readIORef current
    302       unless(not(null defs) && length defs<=4096)(fail "No compiled module")
    303       value<-R.preview 100000 (foldr (Fork . snd) Leaf defs)
    304       reply("ok\n"++R.json(R.O [("names",R.A(map (R.S . fst) defs)),("snapshot",value)]))
    305     ("snapshot",name:limit:dag:roots)->do
    306       size<-R.index 100001 limit
    307       term<-select name dag roots
    308       value<-R.preview size term
    309       reply("ok\n"++R.json value)
    310     ("io-definition-start",[nameBytes])->do
    311       requireIdle
    312       name<-R.utf8 nameBytes
    313       defs<-readIORef expressionBindings
    314       term<-maybe (fail "missing definition") pure (lookup name defs)
    315       beginSelectedIO term
    316     ("io-tree-start",name:dag:roots)->do
    317       requireIdle
    318       term<-select name dag roots
    319       value<-BT.begin term
    320       reply("ok\n"++R.json value)
    321     ("io-tree",fields)->do
    322       decoded<-mapM R.utf8 fields
    323       value<-BT.command decoded
    324       reply("ok\n"++R.json value)
    325     ("io-header",name:dag:roots)->do
    326       requireIdle
    327       term<-select name dag roots
    328       value<-R.ioHeader term
    329       reply("ok\n"++R.json value)
    330     ("io-start",name:dag:roots)->do
    331       requireIdle
    332       term<-select name dag roots
    333       beginSelectedIO term
    334     _->fail "invalid operation fields"
    335 
    336 initializeEmpty :: IO CInt
    337 initializeEmpty = guardRequest (reply "ok\nready")
    338 
    339 foreign export ccall "tricu_request" request :: Ptr () -> CInt -> IO CInt
    340 foreign export ccall "tricu_initialize_empty" initializeEmpty :: IO CInt
    341 
    342 foreign export ccall "tricu_initialize" initialize :: IO CInt
    343 foreign export ccall "tricu_compile" compileSource :: Ptr () -> CInt -> IO CInt
    344 foreign export ccall "tricu_observe" observe :: Ptr () -> CInt -> IO CInt
    345 foreign export ccall "tricu_dump" dump :: IO CInt
    346 foreign export ccall "tricu_reset" reset :: IO CInt
    347 foreign export ccall "tricu_collect" collect :: IO CInt
    348 foreign export ccall "tricu_response_size" responseSize :: IO CInt
    349 foreign export ccall "tricu_response_copy" responseCopy :: Ptr () -> CInt -> IO CInt