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

IODriver.hs (49893B)
      1 module IODriver
      2   ( IOPermissions(..)
      3   , defaultPerms
      4   , unsafePerms
      5   , checkIOSentinel
      6   , runIO
      7   , runIOWithEnv
      8   , runIOWith
      9   ) where
     10 
     11 import Research (T(..), apply, toString, toNumber, ofString, ofNumber, ofBytes, toBytes, ofList)
     12 import qualified Data.ByteString as BS
     13 import System.IO (putStr, getLine)
     14 import qualified System.IO as IO
     15 import Control.Exception (try, catch, IOException, SomeException)
     16 import System.IO.Error (isDoesNotExistError, isPermissionError, isAlreadyExistsError)
     17 import Data.List (isPrefixOf, isInfixOf)
     18 import System.FilePath (normalise, isRelative, (</>), addTrailingPathSeparator, splitDirectories, takeDirectory)
     19 import System.Directory (canonicalizePath, doesPathExist, getCurrentDirectory, listDirectory, createDirectory, renameFile, removeFile, doesDirectoryExist)
     20 import Data.Time.Clock.POSIX (getPOSIXTime)
     21 import Crypto.Hash (hash, SHA256, Digest)
     22 import Data.ByteArray (convert)
     23 import Data.ByteString.Base16 (encode)
     24 import Data.Text.Encoding (decodeUtf8)
     25 import qualified Data.Text as T
     26 import Data.Char (toLower)
     27 import qualified Data.Map.Strict as Map
     28 import Data.Map.Strict (Map)
     29 import qualified Data.Sequence as Seq
     30 import Data.Sequence (Seq, (|>), ViewL(..))
     31 import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime, diffUTCTime)
     32 import Control.Concurrent (threadDelay, forkIO)
     33 import Control.Concurrent.STM (TVar, newTVarIO, atomically, readTVar, writeTVar, modifyTVar', retry)
     34 import qualified Data.Set as Set
     35 import Data.Set (Set)
     36 import qualified Data.Foldable as Fold
     37 import qualified Network.Socket as NS
     38 import qualified Network.Socket.ByteString as NSB
     39 
     40 -- ---------------------------------------------------------------------------
     41 -- Permissions
     42 -- ---------------------------------------------------------------------------
     43 
     44 data IOPermissions = IOPermissions
     45   { allowRead     :: [FilePath]
     46   , allowWrite    :: [FilePath]
     47   , allowReadAll  :: Bool
     48   , allowWriteAll :: Bool
     49   }
     50   deriving (Show)
     51 
     52 defaultPerms :: IOPermissions
     53 defaultPerms = IOPermissions [] [] False False
     54 
     55 unsafePerms :: IOPermissions
     56 unsafePerms = IOPermissions [] [] True True
     57 
     58 checkIOSentinel :: T -> Either String (Integer, T)
     59 checkIOSentinel tree =
     60   case tree of
     61     Fork sentinel (Fork version action) -> do
     62       s <- toString sentinel
     63       case s of
     64         "tricuIO" -> do
     65           v <- toNumber version
     66           return (v, action)
     67         _ -> Left "sentinel mismatch (expected \"tricuIO\")"
     68     _ -> Left "root is not an IO sentinel pair"
     69 
     70 -- ---------------------------------------------------------------------------
     71 -- Runtime, Frames, and Machine
     72 -- ---------------------------------------------------------------------------
     73 
     74 data Runtime = Runtime
     75   { rtPerms :: IOPermissions
     76   , rtEnv   :: T
     77   , rtState :: T
     78   }
     79   deriving (Show)
     80 
     81 data Frame
     82   = BindFrame T
     83   | LocalFrame T
     84   deriving (Show)
     85 
     86 data Machine = Machine
     87   { machineRuntime :: Runtime
     88   , machineCurrent :: T
     89   , machineFrames  :: [Frame]
     90   }
     91   deriving (Show)
     92 
     93 -- ---------------------------------------------------------------------------
     94 -- Result convention
     95 -- ---------------------------------------------------------------------------
     96 -- Direct-return actions pass the raw value to the continuation:
     97 --   pure, bind, putStr, getLine, ask, local, get, put,
     98 --   fork, await, yield, sleep
     99 --
    100 -- Result-return actions wrap the outcome as an ok/err pair:
    101 --   ok val  = Fork (Stem Leaf) (Fork val Leaf)   -- (t t) val t
    102 --   err code = Fork Leaf (Fork code Leaf)        -- t code t
    103 --   readFile, writeFile
    104 --
    105 -- Runtime protocol errors are returned as direct values via errResult.
    106 
    107 okResult :: T -> T
    108 okResult val = Fork (Stem Leaf) (Fork val Leaf)
    109 
    110 errResult :: String -> T
    111 errResult msg = Fork Leaf (Fork (ofString msg) Leaf)
    112 
    113 pureAction :: T -> T
    114 pureAction x = Fork (ofNumber 0) x
    115 
    116 invalidAsyncHandleResult :: T
    117 invalidAsyncHandleResult = errResult "invalid task handle"
    118 
    119 invalidSocketHandleResult :: T
    120 invalidSocketHandleResult = errResult "invalid socket handle"
    121 
    122 selfAwaitResult :: T
    123 selfAwaitResult = errResult "self await"
    124 
    125 deadlockResult :: T
    126 deadlockResult = errResult "deadlock"
    127 
    128 invalidSleepResult :: T
    129 invalidSleepResult = errResult "invalid sleep"
    130 
    131 ioErrorString :: IOException -> String
    132 ioErrorString e
    133   | isDoesNotExistError  e = "does not exist"
    134   | isPermissionError    e = "permission denied"
    135   | isAlreadyExistsError e = "already exists"
    136   | otherwise              = "io error"
    137 
    138 -- ---------------------------------------------------------------------------
    139 -- Task identity and handles
    140 -- ---------------------------------------------------------------------------
    141 
    142 newtype TaskId = TaskId Integer
    143   deriving (Eq, Ord, Show)
    144 
    145 taskHandle :: TaskId -> T
    146 taskHandle (TaskId n) =
    147   Fork (ofString "task") (ofNumber n)
    148 
    149 decodeTaskHandle :: T -> Either String TaskId
    150 decodeTaskHandle tree =
    151   case tree of
    152     Fork tag nTree -> do
    153       tagString <- toString tag
    154       if tagString == "task"
    155         then TaskId <$> toNumber nTree
    156         else Left "invalid task handle tag"
    157     _ ->
    158       Left "invalid task handle"
    159 
    160 -- ---------------------------------------------------------------------------
    161 -- Socket identity and handles
    162 -- ---------------------------------------------------------------------------
    163 
    164 newtype SockId = SockId Integer
    165   deriving (Eq, Ord, Show)
    166 
    167 sockHandle :: SockId -> T
    168 sockHandle (SockId n) =
    169   Fork (ofString "sock") (ofNumber n)
    170 
    171 decodeSockHandle :: T -> Either String SockId
    172 decodeSockHandle tree =
    173   case tree of
    174     Fork tag nTree -> do
    175       tagString <- toString tag
    176       if tagString == "sock"
    177         then SockId <$> toNumber nTree
    178         else Left "invalid socket handle tag"
    179     _ ->
    180       Left "invalid socket handle"
    181 
    182 getSocketPort :: NS.Socket -> IO (Maybe Integer)
    183 getSocketPort sock = do
    184   addr <- NS.getSocketName sock
    185   case addr of
    186     NS.SockAddrInet p _      -> return (Just (fromIntegral p))
    187     NS.SockAddrInet6 p _ _ _ -> return (Just (fromIntegral p))
    188     _                        -> return Nothing
    189 
    190 -- ---------------------------------------------------------------------------
    191 -- Socket registry
    192 -- ---------------------------------------------------------------------------
    193 
    194 data SocketRegistry = SocketRegistry
    195   { sockMap    :: Map SockId NS.Socket
    196   , sockNextId :: Integer
    197   }
    198 
    199 -- ---------------------------------------------------------------------------
    200 -- Free-monad action AST
    201 -- ---------------------------------------------------------------------------
    202 
    203 data Action
    204   = APure T
    205   | ABind T T
    206   | APutStr T
    207   | APutBytes T
    208   | AGetLine
    209   | AReadFile T
    210   | AWriteFile T T
    211   | AWriteBytes T T
    212   | AListDirectory T
    213   | ARenameFile T T
    214   | ACreateDirectory T
    215   | ADeleteFile T
    216   | AFileExists T
    217   | ASha256Hex T
    218   | ACurrentTime
    219   | AAsk
    220   | ALocal T T
    221   | AGet
    222   | APut T
    223   | AFork T
    224   | AAwait T
    225   | AYield
    226   | ASleep T
    227   | ASocket
    228   | ACloseSocket T
    229   | ABindSocket T T T
    230   | AListen T T
    231   | AAccept T
    232   | AConnect T T T
    233   | ARecv T T
    234   | ASend T T
    235   | AGetSocketName T
    236   deriving (Show)
    237 
    238 -- ---------------------------------------------------------------------------
    239 -- Action tag constants
    240 -- ---------------------------------------------------------------------------
    241 
    242 tagPure, tagBind :: Integer
    243 tagPure = 0
    244 tagBind = 1
    245 
    246 tagPutStr, tagPutBytes, tagGetLine :: Integer
    247 tagPutStr = 10
    248 tagPutBytes = 12
    249 tagGetLine = 11
    250 
    251 tagReadFile, tagWriteFile, tagWriteBytes :: Integer
    252 tagReadFile = 20
    253 tagWriteFile = 21
    254 tagWriteBytes = 22
    255 
    256 tagListDirectory, tagRenameFile, tagCreateDirectory, tagDeleteFile, tagFileExists :: Integer
    257 tagListDirectory = 23
    258 tagRenameFile = 24
    259 tagCreateDirectory = 25
    260 tagDeleteFile = 26
    261 tagFileExists = 27
    262 
    263 tagSha256Hex, tagCurrentTime :: Integer
    264 tagSha256Hex = 28
    265 tagCurrentTime = 29
    266 
    267 tagAsk, tagLocal :: Integer
    268 tagAsk = 30
    269 tagLocal = 31
    270 
    271 tagGet, tagPut :: Integer
    272 tagGet = 40
    273 tagPut = 41
    274 
    275 tagFork, tagAwait, tagYield, tagSleep :: Integer
    276 tagFork = 60
    277 tagAwait = 61
    278 tagYield = 62
    279 tagSleep = 63
    280 
    281 tagSocket, tagCloseSocket, tagBindSocket, tagListen, tagAccept :: Integer
    282 tagSocket = 70
    283 tagCloseSocket = 71
    284 tagBindSocket = 72
    285 tagListen = 73
    286 tagAccept = 74
    287 
    288 tagConnect, tagRecv, tagSend, tagGetSocketName :: Integer
    289 tagConnect = 75
    290 tagRecv = 76
    291 tagSend = 77
    292 tagGetSocketName = 78
    293 
    294 data Step
    295   = Halt Runtime T
    296   | Continue Machine
    297   | ForkRequested T Machine
    298   | AwaitRequested TaskId Machine
    299   | YieldRequested Machine
    300   | SleepRequested Integer Machine
    301   | AsyncAction (IO T) Machine
    302 
    303 instance Show Step where
    304   show (Halt _ v) = "Halt _ (" ++ show v ++ ")"
    305   show (Continue m) = "Continue (" ++ show m ++ ")"
    306   show (ForkRequested t m) = "ForkRequested (" ++ show t ++ ") (" ++ show m ++ ")"
    307   show (AwaitRequested tid m) = "AwaitRequested " ++ show tid ++ " (" ++ show m ++ ")"
    308   show (YieldRequested m) = "YieldRequested (" ++ show m ++ ")"
    309   show (SleepRequested n m) = "SleepRequested " ++ show n ++ " (" ++ show m ++ ")"
    310   show (AsyncAction _ m) = "AsyncAction <io> (" ++ show m ++ ")"
    311 
    312 decodeAction :: T -> Either String Action
    313 decodeAction tree =
    314   case tree of
    315     Fork tag payload ->
    316       case toNumber tag of
    317         Right n | n == tagPure ->
    318           Right (APure payload)
    319 
    320         Right n | n == tagBind ->
    321           case payload of
    322             Fork left k -> Right (ABind left k)
    323             _ -> Left "Invalid Bind: expected pair action continuation"
    324 
    325         Right n | n == tagPutStr ->
    326           Right (APutStr payload)
    327 
    328         Right n | n == tagPutBytes ->
    329           Right (APutBytes payload)
    330 
    331         Right n | n == tagGetLine ->
    332           Right AGetLine
    333 
    334         Right n | n == tagReadFile ->
    335           Right (AReadFile payload)
    336 
    337         Right n | n == tagWriteFile ->
    338           case payload of
    339             Fork path contents -> Right (AWriteFile path contents)
    340             _ -> Left "Invalid WriteFile: expected pair path contents"
    341 
    342         Right n | n == tagWriteBytes ->
    343           case payload of
    344             Fork path contents -> Right (AWriteBytes path contents)
    345             _ -> Left "Invalid WriteBytes: expected pair path contents"
    346 
    347         Right n | n == tagListDirectory ->
    348           Right (AListDirectory payload)
    349 
    350         Right n | n == tagRenameFile ->
    351           case payload of
    352             Fork old new -> Right (ARenameFile old new)
    353             _ -> Left "Invalid RenameFile: expected pair oldPath newPath"
    354 
    355         Right n | n == tagCreateDirectory ->
    356           Right (ACreateDirectory payload)
    357 
    358         Right n | n == tagDeleteFile ->
    359           Right (ADeleteFile payload)
    360 
    361         Right n | n == tagFileExists ->
    362           Right (AFileExists payload)
    363 
    364         Right n | n == tagSha256Hex ->
    365           Right (ASha256Hex payload)
    366 
    367         Right n | n == tagCurrentTime ->
    368           Right ACurrentTime
    369 
    370         Right n | n == tagAsk ->
    371           Right AAsk
    372 
    373         Right n | n == tagLocal ->
    374           case payload of
    375             Fork f action -> Right (ALocal f action)
    376             _ -> Left "Invalid Local: expected pair function action"
    377 
    378         Right n | n == tagGet ->
    379           Right AGet
    380 
    381         Right n | n == tagPut ->
    382           Right (APut payload)
    383 
    384         Right n | n == tagFork ->
    385           Right (AFork payload)
    386 
    387         Right n | n == tagAwait ->
    388           Right (AAwait payload)
    389 
    390         Right n | n == tagYield ->
    391           Right AYield
    392 
    393         Right n | n == tagSleep ->
    394           Right (ASleep payload)
    395 
    396         Right n | n == tagSocket ->
    397           Right ASocket
    398 
    399         Right n | n == tagCloseSocket ->
    400           Right (ACloseSocket payload)
    401 
    402         Right n | n == tagBindSocket ->
    403           case payload of
    404             Fork sock (Fork addr port) -> Right (ABindSocket sock addr port)
    405             _ -> Left "Invalid BindSocket: expected pair sock (pair addr port)"
    406 
    407         Right n | n == tagListen ->
    408           case payload of
    409             Fork sock backlog -> Right (AListen sock backlog)
    410             _ -> Left "Invalid Listen: expected pair sock backlog"
    411 
    412         Right n | n == tagAccept ->
    413           Right (AAccept payload)
    414 
    415         Right n | n == tagConnect ->
    416           case payload of
    417             Fork sock (Fork addr port) -> Right (AConnect sock addr port)
    418             _ -> Left "Invalid Connect: expected pair sock (pair addr port)"
    419 
    420         Right n | n == tagRecv ->
    421           case payload of
    422             Fork sock maxBytes -> Right (ARecv sock maxBytes)
    423             _ -> Left "Invalid Recv: expected pair sock maxBytes"
    424 
    425         Right n | n == tagSend ->
    426           case payload of
    427             Fork sock bytes -> Right (ASend sock bytes)
    428             _ -> Left "Invalid Send: expected pair sock bytes"
    429 
    430         Right n | n == tagGetSocketName ->
    431           Right (AGetSocketName payload)
    432 
    433         Right n ->
    434           Left $ "Unknown IO action tag: " ++ show n
    435 
    436         Left err ->
    437           Left $ "Invalid action tag: " ++ err
    438 
    439     _ ->
    440       Left $ "Invalid action tree: expected pair tag payload, got " ++ show tree
    441 
    442 -- ---------------------------------------------------------------------------
    443 -- Small-step IO machine
    444 -- ---------------------------------------------------------------------------
    445 
    446 finishValue :: Machine -> T -> IO Step
    447 finishValue machine value =
    448   case machineFrames machine of
    449     [] ->
    450       pure (Halt (machineRuntime machine) value)
    451 
    452     BindFrame k : rest ->
    453       pure (Continue machine
    454         { machineCurrent = apply k value
    455         , machineFrames = rest
    456         })
    457 
    458     LocalFrame oldEnv : rest ->
    459       let runtime' = (machineRuntime machine) { rtEnv = oldEnv }
    460       in pure (Continue machine
    461           { machineRuntime = runtime'
    462           , machineCurrent = pureAction value
    463           , machineFrames = rest
    464           })
    465 
    466 stepMachine :: TVar SocketRegistry -> Machine -> IO Step
    467 stepMachine sockVar machine =
    468   case decodeAction (machineCurrent machine) of
    469     Right action -> dispatch action
    470     Left _       -> finishValue machine (errResult "invalid action")
    471   where
    472     dispatch action = case action of
    473       APure val ->
    474         finishValue machine val
    475 
    476       ABind left k ->
    477         pure (Continue machine
    478           { machineCurrent = left
    479           , machineFrames = BindFrame k : machineFrames machine
    480           })
    481 
    482       APutStr str ->
    483         case decodeString str "PutStr" of
    484           Right s ->
    485             pure (AsyncAction (putStr s >> pure Leaf) machine)
    486           Left _ ->
    487             finishValue machine (errResult "invalid string")
    488 
    489       APutBytes bs ->
    490         case decodeBytes bs "PutBytes" of
    491           Right b ->
    492             pure (AsyncAction (BS.putStr b >> pure Leaf) machine)
    493           Left _ ->
    494             finishValue machine (errResult "invalid bytes")
    495 
    496       AGetLine ->
    497         pure (AsyncAction (ofString <$> getLine) machine)
    498 
    499       AReadFile path ->
    500         case decodeString path "ReadFile" of
    501           Right p -> do
    502             mDeny <- checkReadPerm p
    503             case mDeny of
    504               Just denied -> finishValue machine denied
    505               Nothing     -> pure (AsyncAction (tryReadFile p) machine)
    506           Left _ -> finishValue machine (errResult "invalid string")
    507 
    508       AWriteFile path contents ->
    509         case decodeString path "WriteFile" of
    510           Right p ->
    511             case decodeString contents "WriteFile" of
    512               Right c -> do
    513                 mDeny <- checkWritePerm p
    514                 case mDeny of
    515                   Just denied -> finishValue machine denied
    516                   Nothing     -> pure (AsyncAction (tryWriteFile p c) machine)
    517               Left _ -> finishValue machine (errResult "invalid string")
    518           Left _ -> finishValue machine (errResult "invalid string")
    519 
    520       AWriteBytes path contents ->
    521         case decodeString path "WriteBytes" of
    522           Right p ->
    523             case decodeBytes contents "WriteBytes" of
    524               Right c -> do
    525                 mDeny <- checkWritePerm p
    526                 case mDeny of
    527                   Just denied -> finishValue machine denied
    528                   Nothing     -> pure (AsyncAction (tryWriteFileBytes p c) machine)
    529               Left _ -> finishValue machine (errResult "invalid bytes")
    530           Left _ -> finishValue machine (errResult "invalid string")
    531 
    532       AListDirectory pathTree ->
    533         case decodeString pathTree "ListDirectory" of
    534           Right p -> do
    535             mDeny <- checkReadPerm p
    536             case mDeny of
    537               Just denied -> finishValue machine denied
    538               Nothing     -> pure (AsyncAction (tryListDirectory p) machine)
    539           Left _ -> finishValue machine (errResult "invalid string")
    540 
    541       ARenameFile oldTree newTree ->
    542         case decodeString oldTree "RenameFile" of
    543           Right old ->
    544             case decodeString newTree "RenameFile" of
    545               Right new -> do
    546                 mDenyOld <- checkWritePerm old
    547                 mDenyNew <- checkWritePerm new
    548                 case (mDenyOld, mDenyNew) of
    549                   (Just denied, _) -> finishValue machine denied
    550                   (_, Just denied) -> finishValue machine denied
    551                   (Nothing, Nothing) -> pure (AsyncAction (tryRenameFile old new) machine)
    552               Left _ -> finishValue machine (errResult "invalid string")
    553           Left _ -> finishValue machine (errResult "invalid string")
    554 
    555       ACreateDirectory pathTree ->
    556         case decodeString pathTree "CreateDirectory" of
    557           Right p -> do
    558             mDeny <- checkWritePerm p
    559             case mDeny of
    560               Just denied -> finishValue machine denied
    561               Nothing     -> pure (AsyncAction (tryCreateDirectory p) machine)
    562           Left _ -> finishValue machine (errResult "invalid string")
    563 
    564       ADeleteFile pathTree ->
    565         case decodeString pathTree "DeleteFile" of
    566           Right p -> do
    567             mDeny <- checkWritePerm p
    568             case mDeny of
    569               Just denied -> finishValue machine denied
    570               Nothing     -> pure (AsyncAction (tryDeleteFile p) machine)
    571           Left _ -> finishValue machine (errResult "invalid string")
    572 
    573       AFileExists pathTree ->
    574         case decodeString pathTree "FileExists" of
    575           Right p -> do
    576             mDeny <- checkReadPerm p
    577             case mDeny of
    578               Just denied -> finishValue machine denied
    579               Nothing     -> pure (AsyncAction (tryFileExists p) machine)
    580           Left _ -> finishValue machine (errResult "invalid string")
    581 
    582       ASha256Hex bytesTree ->
    583         case decodeBytes bytesTree "Sha256Hex" of
    584           Right bs -> pure (AsyncAction (pure $ trySha256Hex bs) machine)
    585           Left _ -> finishValue machine (errResult "invalid bytes")
    586 
    587       ACurrentTime ->
    588         pure (AsyncAction (tryCurrentTime) machine)
    589 
    590       AAsk ->
    591         finishValue machine (rtEnv (machineRuntime machine))
    592 
    593       ALocal f action' ->
    594         let runtime = machineRuntime machine
    595             oldEnv  = rtEnv runtime
    596             newEnv  = apply f oldEnv
    597             runtime' = runtime { rtEnv = newEnv }
    598         in pure (Continue machine
    599             { machineRuntime = runtime'
    600             , machineCurrent = action'
    601             , machineFrames = LocalFrame oldEnv : machineFrames machine
    602             })
    603 
    604       AGet ->
    605         finishValue machine (rtState (machineRuntime machine))
    606 
    607       APut newState ->
    608         let runtime' = (machineRuntime machine) { rtState = newState }
    609         in finishValue (machine { machineRuntime = runtime' }) Leaf
    610 
    611       AFork childAction ->
    612         pure (ForkRequested childAction machine)
    613 
    614       AAwait handleTree ->
    615         case decodeTaskHandle handleTree of
    616           Right taskId ->
    617             pure (AwaitRequested taskId machine)
    618           Left _ ->
    619             finishValue machine invalidAsyncHandleResult
    620 
    621       AYield ->
    622         pure (YieldRequested machine)
    623 
    624       ASleep msTree ->
    625         case toNumber msTree of
    626           Right ms | ms >= 0 ->
    627             pure (SleepRequested ms machine)
    628           _ ->
    629             finishValue machine invalidSleepResult
    630 
    631       ASocket -> do
    632         result <- try (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol) :: IO (Either SomeException NS.Socket)
    633         case result of
    634           Left e ->
    635             finishValue machine (errResult ("io error: " ++ show e))
    636           Right sock -> do
    637             NS.setSocketOption sock NS.ReuseAddr 1
    638             sid <- atomically $ do
    639               SocketRegistry m next <- readTVar sockVar
    640               let sid = SockId next
    641               writeTVar sockVar (SocketRegistry (Map.insert sid sock m) (next + 1))
    642               return sid
    643             finishValue machine (okResult (sockHandle sid))
    644 
    645       ACloseSocket sockTree ->
    646         case decodeSockHandle sockTree of
    647           Left _ -> finishValue machine invalidSocketHandleResult
    648           Right sid -> do
    649             mSock <- atomically $ do
    650               SocketRegistry m next <- readTVar sockVar
    651               case Map.lookup sid m of
    652                 Nothing -> return Nothing
    653                 Just sock -> do
    654                   writeTVar sockVar (SocketRegistry (Map.delete sid m) next)
    655                   return (Just sock)
    656             case mSock of
    657               Nothing -> finishValue machine invalidSocketHandleResult
    658               Just sock -> do
    659                 NS.close sock
    660                 finishValue machine (okResult Leaf)
    661 
    662       ABindSocket sockTree addrTree portTree ->
    663         case decodeSockHandle sockTree of
    664           Left _ -> finishValue machine invalidSocketHandleResult
    665           Right sid ->
    666             case decodeString addrTree "BindSocket" of
    667               Left _ -> finishValue machine (errResult "invalid address")
    668               Right addrStr ->
    669                 case toNumber portTree of
    670                   Left _ -> finishValue machine (errResult "invalid port")
    671                   Right port -> do
    672                     mSock <- atomically $ do
    673                       SocketRegistry m _ <- readTVar sockVar
    674                       return (Map.lookup sid m)
    675                     case mSock of
    676                       Nothing -> finishValue machine invalidSocketHandleResult
    677                       Just sock -> do
    678                         result <- try (do
    679                           addrInfo <- NS.getAddrInfo (Just $ NS.defaultHints { NS.addrSocketType = NS.Stream })
    680                                                      (Just addrStr)
    681                                                      (Just (show port))
    682                           let serverAddr = head addrInfo
    683                           NS.bind sock (NS.addrAddress serverAddr)
    684                           ) :: IO (Either SomeException ())
    685                         case result of
    686                           Left e ->
    687                             finishValue machine (errResult ("io error: " ++ show e))
    688                           Right () ->
    689                             finishValue machine (okResult Leaf)
    690 
    691       AListen sockTree backlogTree ->
    692         case decodeSockHandle sockTree of
    693           Left _ -> finishValue machine invalidSocketHandleResult
    694           Right sid ->
    695             case toNumber backlogTree of
    696               Left _ -> finishValue machine (errResult "invalid backlog")
    697               Right backlog -> do
    698                 mSock <- atomically $ do
    699                   SocketRegistry m _ <- readTVar sockVar
    700                   return (Map.lookup sid m)
    701                 case mSock of
    702                   Nothing -> finishValue machine invalidSocketHandleResult
    703                   Just sock -> do
    704                     result <- try (NS.listen sock (fromIntegral backlog)) :: IO (Either SomeException ())
    705                     case result of
    706                       Left e ->
    707                         finishValue machine (errResult ("io error: " ++ show e))
    708                       Right () ->
    709                         finishValue machine (okResult Leaf)
    710 
    711       AAccept listenTree ->
    712         case decodeSockHandle listenTree of
    713           Left _ -> finishValue machine invalidSocketHandleResult
    714           Right listenSid ->
    715             pure (AsyncAction (do
    716               mListenSock <- atomically $ do
    717                 SocketRegistry m _ <- readTVar sockVar
    718                 return (Map.lookup listenSid m)
    719               case mListenSock of
    720                 Nothing -> return (errResult "invalid socket handle")
    721                 Just listenSock -> do
    722                   result <- try (NS.accept listenSock) :: IO (Either SomeException (NS.Socket, NS.SockAddr))
    723                   case result of
    724                     Left e ->
    725                       return (errResult ("io error: " ++ show e))
    726                     Right (clientSock, addr) -> do
    727                       clientSid <- atomically $ do
    728                         SocketRegistry m next <- readTVar sockVar
    729                         let sid = SockId next
    730                         writeTVar sockVar (SocketRegistry (Map.insert sid clientSock m) (next + 1))
    731                         return sid
    732                       let addrStr = case addr of
    733                             NS.SockAddrInet p h ->
    734                               let (a,b,c,d) = NS.hostAddressToTuple h
    735                               in show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d ++ ":" ++ show p
    736                             _ -> show addr
    737                       return (okResult (Fork (sockHandle clientSid) (ofString addrStr)))
    738               ) machine)
    739 
    740       AConnect sockTree addrTree portTree ->
    741         case decodeSockHandle sockTree of
    742           Left _ -> finishValue machine invalidSocketHandleResult
    743           Right sid ->
    744             case decodeString addrTree "Connect" of
    745               Left _ -> finishValue machine (errResult "invalid address")
    746               Right addrStr ->
    747                 case toNumber portTree of
    748                   Left _ -> finishValue machine (errResult "invalid port")
    749                   Right port -> do
    750                     mSock <- atomically $ do
    751                       SocketRegistry m _ <- readTVar sockVar
    752                       return (Map.lookup sid m)
    753                     case mSock of
    754                       Nothing -> finishValue machine invalidSocketHandleResult
    755                       Just sock ->
    756                         pure (AsyncAction (do
    757                           result <- try (do
    758                             addrInfo <- NS.getAddrInfo (Just $ NS.defaultHints { NS.addrSocketType = NS.Stream })
    759                                                        (Just addrStr)
    760                                                        (Just (show port))
    761                             let serverAddr = head addrInfo
    762                             NS.connect sock (NS.addrAddress serverAddr)
    763                             ) :: IO (Either SomeException ())
    764                           case result of
    765                             Left e ->
    766                               return (errResult ("io error: " ++ show e))
    767                             Right () ->
    768                               return (okResult Leaf)
    769                           ) machine)
    770 
    771       ARecv sockTree maxBytesTree ->
    772         case decodeSockHandle sockTree of
    773           Left _ -> finishValue machine invalidSocketHandleResult
    774           Right sid ->
    775             case toNumber maxBytesTree of
    776               Left _ -> finishValue machine (errResult "invalid maxBytes")
    777               Right maxBytes -> do
    778                 mSock <- atomically $ do
    779                   SocketRegistry m _ <- readTVar sockVar
    780                   return (Map.lookup sid m)
    781                 case mSock of
    782                   Nothing -> finishValue machine invalidSocketHandleResult
    783                   Just sock ->
    784                     pure (AsyncAction (do
    785                       result <- try (NSB.recv sock (fromIntegral maxBytes)) :: IO (Either SomeException BS.ByteString)
    786                       case result of
    787                         Left e ->
    788                           return (errResult ("io error: " ++ show e))
    789                         Right bs ->
    790                           if BS.null bs
    791                             then return (errResult "connection closed")
    792                             else return (okResult (ofBytes bs))
    793                       ) machine)
    794 
    795       AGetSocketName sockTree ->
    796         case decodeSockHandle sockTree of
    797           Left _ -> finishValue machine invalidSocketHandleResult
    798           Right sid -> do
    799             mSock <- atomically $ do
    800               SocketRegistry m _ <- readTVar sockVar
    801               return (Map.lookup sid m)
    802             case mSock of
    803               Nothing -> finishValue machine invalidSocketHandleResult
    804               Just sock -> do
    805                 mPort <- getSocketPort sock
    806                 case mPort of
    807                   Just port -> finishValue machine (okResult (ofNumber port))
    808                   Nothing   -> finishValue machine (errResult "io error: could not get socket name")
    809 
    810       ASend sockTree bytesTree ->
    811         case decodeSockHandle sockTree of
    812           Left _ -> finishValue machine invalidSocketHandleResult
    813           Right sid ->
    814             case decodeBytes bytesTree "Send" of
    815               Left _ -> finishValue machine (errResult "invalid bytes")
    816               Right bs -> do
    817                 mSock <- atomically $ do
    818                   SocketRegistry m _ <- readTVar sockVar
    819                   return (Map.lookup sid m)
    820                 case mSock of
    821                   Nothing -> finishValue machine invalidSocketHandleResult
    822                   Just sock ->
    823                     pure (AsyncAction (do
    824                       result <- try (NSB.send sock bs) :: IO (Either SomeException Int)
    825                       case result of
    826                         Left e ->
    827                           return (errResult ("io error: " ++ show e))
    828                         Right sent ->
    829                           return (okResult (ofNumber (fromIntegral sent)))
    830                       ) machine)
    831 
    832     -- Permission and IO helpers
    833     checkReadPerm p =
    834       if allowReadAll (rtPerms (machineRuntime machine))
    835         then return Nothing
    836         else do
    837           mp <- canonicalizeSafe p
    838           case mp of
    839             Left _     -> return $ Just policyErrResult
    840             Right path -> do
    841               allowed <- pathAllowed path (allowRead (rtPerms (machineRuntime machine)))
    842               if allowed
    843                 then return Nothing
    844                 else return $ Just policyErrResult
    845 
    846     checkWritePerm p =
    847       if allowWriteAll (rtPerms (machineRuntime machine))
    848         then return Nothing
    849         else do
    850           mp <- canonicalizeSafe p
    851           case mp of
    852             Left _     -> return $ Just policyErrResult
    853             Right path -> do
    854               allowed <- pathAllowed path (allowWrite (rtPerms (machineRuntime machine)))
    855               if allowed
    856                 then return Nothing
    857                 else return $ Just policyErrResult
    858 
    859     policyErrResult = errResult "permission denied"
    860 
    861     canonicalizeSafe :: FilePath -> IO (Either String FilePath)
    862     canonicalizeSafe p = do
    863       exists <- doesPathExist p
    864       if exists
    865         then do
    866           result <- try (canonicalizePath p) :: IO (Either SomeException FilePath)
    867           case result of
    868             Right canon -> return $ Right canon
    869             Left _      -> normalizeSyntactic p
    870         else normalizeSyntactic p
    871 
    872     normalizeSyntactic :: FilePath -> IO (Either String FilePath)
    873     normalizeSyntactic p = do
    874       absPath <- if isRelative p then (</> p) <$> getCurrentDirectory else return p
    875       let norm = normalise absPath
    876           dirs = splitDirectories norm
    877       if ".." `elem` dirs
    878         then return $ Left "Path contains unresolved parent-directory references"
    879         else return $ Right norm
    880 
    881     pathAllowed :: FilePath -> [FilePath] -> IO Bool
    882     pathAllowed _ [] = return False
    883     pathAllowed p prefixes = do
    884       let validPrefixes = filter (not . null) prefixes
    885       if null validPrefixes
    886         then return False
    887         else do
    888           absPrefixes <- mapM resolvePrefix validPrefixes
    889           return $ any (isPathPrefixOf p) absPrefixes
    890 
    891     resolvePrefix :: FilePath -> IO FilePath
    892     resolvePrefix p = do
    893       let norm = normalise p
    894       absPath <- if isRelative norm then (</> norm) <$> getCurrentDirectory else return norm
    895       exists <- doesPathExist absPath
    896       if exists
    897         then do
    898           result <- try (canonicalizePath absPath) :: IO (Either SomeException FilePath)
    899           case result of
    900             Right canon -> return canon
    901             Left _      -> return absPath
    902         else return absPath
    903 
    904     isPathPrefixOf :: FilePath -> FilePath -> Bool
    905     isPathPrefixOf path prefix =
    906       let prefix' = addTrailingPathSeparator prefix
    907       in path == prefix || prefix' `isPrefixOf` path
    908 
    909     tryReadFile path = do
    910       result <- try (BS.readFile path) :: IO (Either IOException BS.ByteString)
    911       case result of
    912         Right content -> return $ okResult (ofBytes content)
    913         Left e        -> return $ errResult (ioErrorString e)
    914 
    915     tryWriteFile path contents = do
    916       result <- try (IO.writeFile path contents) :: IO (Either IOException ())
    917       case result of
    918         Right () -> return $ okResult Leaf
    919         Left e   -> return $ errResult (ioErrorString e)
    920 
    921     tryWriteFileBytes path contents = do
    922       result <- try (BS.writeFile path contents) :: IO (Either IOException ())
    923       case result of
    924         Right () -> return $ okResult Leaf
    925         Left e   -> return $ errResult (ioErrorString e)
    926 
    927     tryListDirectory path = do
    928       exists <- doesPathExist path
    929       if not exists
    930         then return $ errResult "does not exist"
    931         else do
    932           isDir <- doesDirectoryExist path
    933           if not isDir
    934             then return $ errResult "not a directory"
    935             else do
    936               result <- try (listDirectory path) :: IO (Either IOException [FilePath])
    937               case result of
    938                 Right entries ->
    939                   let filtered = filter (`notElem` [".", ".."]) entries
    940                   in return $ okResult (ofList (map ofString filtered))
    941                 Left e -> return $ errResult (ioErrorString e)
    942 
    943     tryRenameFile old new = do
    944       oldExists <- doesPathExist old
    945       if not oldExists
    946         then return $ errResult "does not exist"
    947         else do
    948           result <- try (renameFile old new) :: IO (Either IOException ())
    949           case result of
    950             Right () -> return $ okResult Leaf
    951             Left e
    952               | isDoesNotExistError e -> return $ errResult "does not exist"
    953               | isPermissionError e -> return $ errResult "permission denied"
    954               | "cross-device" `isInfixOf` map toLower (show e) || "exdev" `isInfixOf` map toLower (show e) ->
    955                   return $ errResult "cross-device rename"
    956               | otherwise -> return $ errResult (ioErrorString e)
    957 
    958     tryCreateDirectory path = do
    959       exists <- doesPathExist path
    960       if exists
    961         then do
    962           isDir <- doesDirectoryExist path
    963           if isDir
    964             then return $ okResult Leaf
    965             else return $ errResult "already exists"
    966         else do
    967           let parent = takeDirectory path
    968           parentExists <- doesPathExist parent
    969           if parentExists
    970             then do
    971               parentIsDir <- doesDirectoryExist parent
    972               if parentIsDir
    973                 then do
    974                   result <- try (createDirectory path) :: IO (Either IOException ())
    975                   case result of
    976                     Right () -> return $ okResult Leaf
    977                     Left e
    978                       | isDoesNotExistError e -> return $ errResult "does not exist"
    979                       | isPermissionError e -> return $ errResult "permission denied"
    980                       | isAlreadyExistsError e -> return $ errResult "already exists"
    981                       | otherwise -> return $ errResult (ioErrorString e)
    982                 else return $ errResult "not a directory"
    983             else do
    984               result <- try (createDirectory path) :: IO (Either IOException ())
    985               case result of
    986                 Right () -> return $ okResult Leaf
    987                 Left e
    988                   | isDoesNotExistError e -> return $ errResult "does not exist"
    989                   | isPermissionError e -> return $ errResult "permission denied"
    990                   | isAlreadyExistsError e -> return $ errResult "already exists"
    991                   | otherwise -> return $ errResult (ioErrorString e)
    992 
    993     tryDeleteFile path = do
    994       exists <- doesPathExist path
    995       if not exists
    996         then return $ okResult Leaf
    997         else do
    998           isDir <- doesDirectoryExist path
    999           if isDir
   1000             then return $ errResult "is a directory"
   1001             else do
   1002               result <- try (removeFile path) :: IO (Either IOException ())
   1003               case result of
   1004                 Right () -> return $ okResult Leaf
   1005                 Left e
   1006                   | isDoesNotExistError e -> return $ okResult Leaf
   1007                   | isPermissionError e -> return $ errResult "permission denied"
   1008                   | otherwise -> return $ errResult (ioErrorString e)
   1009 
   1010     tryFileExists path = do
   1011       result <- try (doesPathExist path) :: IO (Either IOException Bool)
   1012       case result of
   1013         Right exists -> return $ okResult (if exists then Stem Leaf else Leaf)
   1014         Left e
   1015           | isPermissionError e -> return $ errResult "permission denied"
   1016           | otherwise -> return $ errResult (ioErrorString e)
   1017 
   1018     trySha256Hex bs =
   1019       let digest = hash bs :: Digest SHA256
   1020           hexBs = encode (convert digest)
   1021           hexStr = T.unpack (decodeUtf8 hexBs)
   1022       in okResult (ofString hexStr)
   1023 
   1024     tryCurrentTime = do
   1025       now <- getPOSIXTime
   1026       return $ okResult (ofNumber (floor now))
   1027 
   1028     decodeString t ctx =
   1029       case toString t of
   1030         Right s  -> Right s
   1031         Left _ -> Left $ "Invalid " ++ ctx ++ " string"
   1032 
   1033     decodeBytes t ctx =
   1034       case toBytes t of
   1035         Right b  -> Right b
   1036         Left _ -> Left $ "Invalid " ++ ctx ++ " bytes"
   1037 
   1038 -- ---------------------------------------------------------------------------
   1039 -- Scheduler
   1040 -- ---------------------------------------------------------------------------
   1041 
   1042 data TaskStatus
   1043   = Runnable Machine
   1044   | BlockedOn TaskId Machine
   1045   | Sleeping UTCTime Machine
   1046   | AsyncWaiting Machine
   1047   deriving (Show)
   1048 
   1049 data Scheduler = Scheduler
   1050   { schedulerNextTaskId :: Integer
   1051   , schedulerRunnable   :: Seq TaskId
   1052   , schedulerTasks      :: Map TaskId TaskStatus
   1053   , schedulerWaiters    :: Map TaskId (Seq TaskId)
   1054   , schedulerSleepQueue :: Map UTCTime (Set TaskId)
   1055   , schedulerAsyncCompleted :: TVar (Map TaskId T)
   1056   , schedulerCompleted  :: Map TaskId (T, T)
   1057   , schedulerSockets    :: TVar SocketRegistry
   1058   , schedulerNextSockId :: Integer
   1059   }
   1060 
   1061 instance Show Scheduler where
   1062   show s = "Scheduler { schedulerNextTaskId = " ++ show (schedulerNextTaskId s)
   1063     ++ ", schedulerRunnable = " ++ show (schedulerRunnable s)
   1064     ++ ", schedulerTasks = " ++ show (schedulerTasks s)
   1065     ++ ", schedulerWaiters = " ++ show (schedulerWaiters s)
   1066     ++ ", schedulerSleepQueue = " ++ show (schedulerSleepQueue s)
   1067     ++ ", schedulerAsyncCompleted = <tvar>"
   1068     ++ ", schedulerCompleted = " ++ show (schedulerCompleted s)
   1069     ++ ", schedulerSockets = <tvar>"
   1070     ++ ", schedulerNextSockId = " ++ show (schedulerNextSockId s)
   1071     ++ " }"
   1072 
   1073 initialScheduler :: TVar (Map TaskId T) -> TVar SocketRegistry -> Machine -> Scheduler
   1074 initialScheduler asyncVar sockVar mainMachine =
   1075   Scheduler
   1076     { schedulerNextTaskId = 1
   1077     , schedulerRunnable = Seq.singleton (TaskId 0)
   1078     , schedulerTasks = Map.singleton (TaskId 0) (Runnable mainMachine)
   1079     , schedulerWaiters = Map.empty
   1080     , schedulerSleepQueue = Map.empty
   1081     , schedulerAsyncCompleted = asyncVar
   1082     , schedulerCompleted = Map.empty
   1083     , schedulerSockets = sockVar
   1084     , schedulerNextSockId = 0
   1085     }
   1086 
   1087 runtimeOfStatus :: TaskStatus -> Maybe Runtime
   1088 runtimeOfStatus (Runnable machine) = Just (machineRuntime machine)
   1089 runtimeOfStatus (BlockedOn _ machine) = Just (machineRuntime machine)
   1090 runtimeOfStatus (Sleeping _ machine) = Just (machineRuntime machine)
   1091 runtimeOfStatus (AsyncWaiting machine) = Just (machineRuntime machine)
   1092 
   1093 wakeAwaiters :: TaskId -> T -> Scheduler -> Scheduler
   1094 wakeAwaiters targetId value scheduler =
   1095   case Map.lookup targetId (schedulerWaiters scheduler) of
   1096     Nothing -> scheduler
   1097     Just waiters ->
   1098       let (tasks', queue') = Fold.foldl' (wakeOne targetId value)
   1099                               (schedulerTasks scheduler, schedulerRunnable scheduler)
   1100                               waiters
   1101       in scheduler
   1102            { schedulerTasks = tasks'
   1103            , schedulerRunnable = queue'
   1104            , schedulerWaiters = Map.delete targetId (schedulerWaiters scheduler)
   1105            }
   1106   where
   1107     wakeOne _ _ (tasks, queue) waiterId =
   1108       case Map.lookup waiterId tasks of
   1109         Just (BlockedOn _ machine) ->
   1110           let machine' = machine { machineCurrent = pureAction value }
   1111           in (Map.insert waiterId (Runnable machine') tasks, queue |> waiterId)
   1112         _ -> (tasks, queue)
   1113 
   1114 wakeDueSleepers :: Scheduler -> IO Scheduler
   1115 wakeDueSleepers scheduler = do
   1116   now <- getCurrentTime
   1117   let go sq accTasks accQueue =
   1118         case Map.lookupMin sq of
   1119           Nothing -> (accTasks, accQueue, sq)
   1120           Just (t, taskSet)
   1121             | t <= now ->
   1122                 let tasks' = Fold.foldl' (\m tid ->
   1123                       case Map.lookup tid m of
   1124                         Just (Sleeping _ machine) -> Map.insert tid (Runnable machine) m
   1125                         _ -> m
   1126                       ) accTasks (Set.toList taskSet)
   1127                     queue' = Fold.foldl' (|>) accQueue (Set.toList taskSet)
   1128                 in go (Map.deleteMin sq) tasks' queue'
   1129             | otherwise -> (accTasks, accQueue, sq)
   1130       (tasks', queue', sq') = go (schedulerSleepQueue scheduler)
   1131                                    (schedulerTasks scheduler)
   1132                                    (schedulerRunnable scheduler)
   1133   pure scheduler
   1134     { schedulerTasks = tasks'
   1135     , schedulerRunnable = queue'
   1136     , schedulerSleepQueue = sq'
   1137     }
   1138 
   1139 nearestSleepTime :: Scheduler -> Maybe UTCTime
   1140 nearestSleepTime = fmap fst . Map.lookupMin . schedulerSleepQueue
   1141 
   1142 hasAsyncWaiters :: Scheduler -> Bool
   1143 hasAsyncWaiters = any isAsync . Map.elems . schedulerTasks
   1144   where
   1145     isAsync (AsyncWaiting _) = True
   1146     isAsync _ = False
   1147 
   1148 resumeCurrentWith :: TaskId -> T -> Machine -> Scheduler -> IO Scheduler
   1149 resumeCurrentWith taskId value machine scheduler =
   1150   let machine' = machine { machineCurrent = pureAction value }
   1151   in pure scheduler
   1152       { schedulerTasks = Map.insert taskId (Runnable machine') (schedulerTasks scheduler)
   1153       , schedulerRunnable = schedulerRunnable scheduler |> taskId
   1154       }
   1155 
   1156 wouldCycle :: TaskId -> TaskId -> Map TaskId TaskStatus -> Bool
   1157 wouldCycle target current tasks =
   1158   case Map.lookup target tasks of
   1159     Just (BlockedOn next _) ->
   1160       next == current || wouldCycle next current tasks
   1161     _ -> False
   1162 
   1163 handleStep :: TaskId -> Step -> Scheduler -> IO Scheduler
   1164 handleStep taskId (Continue machine) scheduler =
   1165   pure scheduler
   1166     { schedulerTasks = Map.insert taskId (Runnable machine) (schedulerTasks scheduler)
   1167     , schedulerRunnable = schedulerRunnable scheduler |> taskId
   1168     }
   1169 
   1170 handleStep taskId (Halt runtime value) scheduler =
   1171   let scheduler' = wakeAwaiters taskId value scheduler
   1172   in pure scheduler'
   1173        { schedulerTasks = Map.delete taskId (schedulerTasks scheduler')
   1174        , schedulerCompleted = Map.insert taskId (value, rtState runtime) (schedulerCompleted scheduler')
   1175        }
   1176 
   1177 handleStep parentId (ForkRequested childAction parentMachine) scheduler =
   1178   let childId = TaskId (schedulerNextTaskId scheduler)
   1179       handle = taskHandle childId
   1180 
   1181       parentMachine' =
   1182         parentMachine { machineCurrent = pureAction handle }
   1183 
   1184       childMachine =
   1185         Machine
   1186           { machineRuntime = machineRuntime parentMachine
   1187           , machineCurrent = childAction
   1188           , machineFrames = []
   1189           }
   1190 
   1191       tasks' =
   1192         Map.insert parentId (Runnable parentMachine') $
   1193         Map.insert childId (Runnable childMachine) $
   1194         schedulerTasks scheduler
   1195 
   1196       queue' =
   1197         schedulerRunnable scheduler |> parentId |> childId
   1198 
   1199   in pure scheduler
   1200       { schedulerNextTaskId = schedulerNextTaskId scheduler + 1
   1201       , schedulerTasks = tasks'
   1202       , schedulerRunnable = queue'
   1203       }
   1204 
   1205 handleStep currentId (AwaitRequested targetId machine) scheduler
   1206   | currentId == targetId =
   1207       resumeCurrentWith currentId selfAwaitResult machine scheduler
   1208 
   1209   | otherwise =
   1210       case Map.lookup targetId (schedulerTasks scheduler) of
   1211         Nothing ->
   1212           case Map.lookup targetId (schedulerCompleted scheduler) of
   1213             Just (value, _) -> resumeCurrentWith currentId value machine scheduler
   1214             Nothing -> resumeCurrentWith currentId invalidAsyncHandleResult machine scheduler
   1215 
   1216         Just (BlockedOn nextId _) ->
   1217           if wouldCycle targetId currentId (schedulerTasks scheduler)
   1218             then resumeCurrentWith currentId (errResult "cyclic await") machine scheduler
   1219             else block
   1220 
   1221         Just _ -> block
   1222   where
   1223     block = pure scheduler
   1224       { schedulerTasks = Map.insert currentId (BlockedOn targetId machine) (schedulerTasks scheduler)
   1225       , schedulerWaiters = Map.alter addWaiter targetId (schedulerWaiters scheduler)
   1226       }
   1227     addWaiter Nothing = Just (Seq.singleton currentId)
   1228     addWaiter (Just sq) = Just (sq |> currentId)
   1229 
   1230 handleStep taskId (YieldRequested machine) scheduler =
   1231   resumeCurrentWith taskId Leaf machine scheduler
   1232 
   1233 handleStep taskId (SleepRequested ms machine) scheduler = do
   1234   now <- getCurrentTime
   1235   let seconds = fromIntegral ms / 1000
   1236       wakeTime = addUTCTime seconds now
   1237       machine' = machine { machineCurrent = pureAction Leaf }
   1238   pure scheduler
   1239     { schedulerTasks = Map.insert taskId (Sleeping wakeTime machine') (schedulerTasks scheduler)
   1240     , schedulerSleepQueue = Map.alter (Just . maybe (Set.singleton taskId) (Set.insert taskId)) wakeTime (schedulerSleepQueue scheduler)
   1241     }
   1242 
   1243 handleStep taskId (AsyncAction ioAction machine) scheduler = do
   1244   _ <- forkIO $ do
   1245     result <- (Right <$> ioAction) `catch` \(e :: SomeException) -> pure (Left (show e))
   1246     atomically $ modifyTVar' (schedulerAsyncCompleted scheduler) (Map.insert taskId $
   1247       case result of
   1248         Right val -> val
   1249         Left msg  -> errResult msg)
   1250   pure scheduler
   1251     { schedulerTasks = Map.insert taskId (AsyncWaiting machine) (schedulerTasks scheduler)
   1252     }
   1253 
   1254 handleNoRunnable :: Scheduler -> IO Scheduler
   1255 handleNoRunnable scheduler =
   1256   case nearestSleepTime scheduler of
   1257     Just wakeTime -> do
   1258       now <- getCurrentTime
   1259       let micros = max 0 (floor (diffUTCTime wakeTime now * 1000000))
   1260       threadDelay micros
   1261       wakeDueSleepers scheduler
   1262 
   1263     Nothing ->
   1264       if hasAsyncWaiters scheduler
   1265         then do
   1266           -- Block efficiently until at least one async operation completes.
   1267           atomically $ do
   1268             m <- readTVar (schedulerAsyncCompleted scheduler)
   1269             if Map.null m then retry else return ()
   1270           pure scheduler
   1271         else
   1272           case Map.lookup (TaskId 0) (schedulerTasks scheduler) of
   1273             Just status ->
   1274               case runtimeOfStatus status of
   1275                 Just runtime ->
   1276                   let scheduler' = wakeAwaiters (TaskId 0) deadlockResult scheduler
   1277                   in pure scheduler'
   1278                        { schedulerTasks = Map.delete (TaskId 0) (schedulerTasks scheduler')
   1279                        , schedulerCompleted = Map.insert (TaskId 0) (deadlockResult, rtState runtime) (schedulerCompleted scheduler')
   1280                        }
   1281                 Nothing -> pure scheduler
   1282             Nothing -> pure scheduler
   1283 
   1284 schedulerStep :: Scheduler -> IO Scheduler
   1285 schedulerStep scheduler = do
   1286   -- Poll completed async operations and resume their tasks.
   1287   completed <- atomically $ do
   1288     m <- readTVar (schedulerAsyncCompleted scheduler)
   1289     writeTVar (schedulerAsyncCompleted scheduler) Map.empty
   1290     return m
   1291   schedulerAfterAsync <- Fold.foldlM
   1292     (\s (tid, val) ->
   1293       case Map.lookup tid (schedulerTasks s) of
   1294         Just (AsyncWaiting machine) -> resumeCurrentWith tid val machine s
   1295         _ -> pure s)
   1296     scheduler
   1297     (Map.toList completed)
   1298 
   1299   scheduler1 <- wakeDueSleepers schedulerAfterAsync
   1300   case Seq.viewl (schedulerRunnable scheduler1) of
   1301     EmptyL ->
   1302       handleNoRunnable scheduler1
   1303 
   1304     taskId :< restQueue ->
   1305       case Map.lookup taskId (schedulerTasks scheduler1) of
   1306         Just (Runnable machine) -> do
   1307           step <- stepMachine (schedulerSockets scheduler1) machine
   1308           handleStep taskId step scheduler1 { schedulerRunnable = restQueue }
   1309 
   1310         _ ->
   1311           pure scheduler1 { schedulerRunnable = restQueue }
   1312 
   1313 runScheduler :: Scheduler -> IO (T, T)
   1314 runScheduler scheduler =
   1315   case Map.lookup (TaskId 0) (schedulerCompleted scheduler) of
   1316     Just (value, finalState) ->
   1317       pure (value, finalState)
   1318 
   1319     _ ->
   1320       schedulerStep scheduler >>= runScheduler
   1321 
   1322 -- ---------------------------------------------------------------------------
   1323 -- Public API
   1324 -- ---------------------------------------------------------------------------
   1325 
   1326 runIOWith :: IOPermissions -> T -> T -> T -> IO (Either String (T, T))
   1327 runIOWith perms env initialState action =
   1328   case checkIOSentinel action of
   1329     Left err -> pure (Left err)
   1330     Right (_, action') -> do
   1331       asyncVar <- newTVarIO Map.empty
   1332       sockVar  <- newTVarIO (SocketRegistry Map.empty 0)
   1333       let initialMachine = Machine
   1334             { machineRuntime = Runtime
   1335                 { rtPerms = perms
   1336                 , rtEnv = env
   1337                 , rtState = initialState
   1338                 }
   1339             , machineCurrent = action'
   1340             , machineFrames = []
   1341             }
   1342       Right <$> runScheduler (initialScheduler asyncVar sockVar initialMachine)
   1343 
   1344 runIOWithEnv :: IOPermissions -> T -> T -> IO (Either String T)
   1345 runIOWithEnv perms env action = do
   1346   result <- runIOWith perms env Leaf action
   1347   pure (fmap fst result)
   1348 
   1349 runIO :: IOPermissions -> T -> IO (Either String T)
   1350 runIO perms action = do
   1351   result <- runIOWith perms Leaf Leaf action
   1352   pure (fmap fst result)
	tricu An interpreted language for exploring Tree Calculus
	Log \| Files \| Refs \| README \| LICENSE