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

IODriver.hs (62105B)
      1 {-# LANGUAGE ScopedTypeVariables #-}
      2 
      3 module IODriver
      4   ( IOPermissions(..)
      5   , defaultPerms
      6   , unsafePerms
      7   , checkIOSentinel
      8   , runIO
      9   , runIOWithEnv
     10   , runIOWith
     11   , runIOWithYieldHook
     12   , YieldStats(..)
     13   , runIOWithYieldStatsHook
     14   ) where
     15 
     16 import Runtime (T(..), EvaluatedForm(Decode), formatT, apply, toString, toNumber, ofString, ofNumber, ofBytes, toBytes, ofList)
     17 import ContentStore.Arboricx (treeTermDomain, decodeTreeTermShared, encodeTreeTerm)
     18 import ContentStore.Object (hashObject, validateObjectHash)
     19 import ContentStore.Indexed (indexedTreeDomain, decodeIndexedTree, encodeIndexedTree)
     20 import qualified Data.ByteString as BS
     21 import System.IO (putStr, getLine)
     22 import System.Posix.Files (createLink)
     23 import System.Posix.IO (openFd, closeFd, defaultFileFlags, OpenMode(ReadOnly))
     24 import System.Posix.Unistd (fileSynchronise)
     25 import qualified System.IO as IO
     26 import Control.Exception (try, catch, bracket, bracketOnError, evaluate, IOException, SomeException,
     27   SomeAsyncException, fromException, throwIO, mask_, finally)
     28 import System.IO.Error (isDoesNotExistError, isPermissionError, isAlreadyExistsError)
     29 import Data.List (isPrefixOf, isInfixOf)
     30 import System.FilePath (addTrailingPathSeparator, takeDirectory)
     31 import System.Directory (canonicalizePath, doesPathExist, listDirectory, createDirectory, renameFile, removeFile, doesDirectoryExist)
     32 import Data.Time.Clock.POSIX (getPOSIXTime)
     33 import Crypto.Hash (hash, SHA256, Digest)
     34 import Data.ByteArray (convert)
     35 import Data.ByteString.Base16 (encode)
     36 import Data.Text.Encoding (decodeUtf8, decodeUtf8', encodeUtf8)
     37 import qualified Data.Text as T
     38 import Data.Char (toLower)
     39 import qualified Data.Map.Strict as Map
     40 import Data.Map.Strict (Map)
     41 import qualified Data.Sequence as Seq
     42 import Data.Sequence (Seq, (|>), ViewL(..))
     43 import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime, diffUTCTime)
     44 import Control.Concurrent (threadDelay, forkIOWithUnmask, killThread, ThreadId, MVar, newEmptyMVar, putMVar, readMVar)
     45 import Control.Concurrent.STM (TVar, newTVarIO, atomically, readTVar, writeTVar, modifyTVar', retry)
     46 import qualified Data.Set as Set
     47 import Data.Set (Set)
     48 import qualified Data.Foldable as Fold
     49 import qualified Network.Socket as NS
     50 import qualified Network.Socket.ByteString as NSB
     51 
     52 -- ---------------------------------------------------------------------------
     53 -- Permissions
     54 -- ---------------------------------------------------------------------------
     55 
     56 data IOPermissions = IOPermissions
     57   { allowRead     :: [FilePath]
     58   , allowWrite    :: [FilePath]
     59   , allowReadAll  :: Bool
     60   , allowWriteAll :: Bool
     61   }
     62   deriving (Show)
     63 
     64 defaultPerms :: IOPermissions
     65 defaultPerms = IOPermissions [] [] False False
     66 
     67 unsafePerms :: IOPermissions
     68 unsafePerms = IOPermissions [] [] True True
     69 
     70 checkIOSentinel :: T -> Either String (Integer, T)
     71 checkIOSentinel tree =
     72   case tree of
     73     Fork sentinel (Fork version action) -> do
     74       s <- toString sentinel
     75       case s of
     76         "tricuIO" -> do
     77           v <- toNumber version
     78           return (v, action)
     79         _ -> Left "sentinel mismatch (expected \"tricuIO\")"
     80     _ -> Left "root is not an IO sentinel pair"
     81 
     82 -- ---------------------------------------------------------------------------
     83 -- Runtime, Frames, and Machine
     84 -- ---------------------------------------------------------------------------
     85 
     86 data Runtime = Runtime
     87   { rtPerms :: IOPermissions
     88   , rtEnv   :: T
     89   , rtState :: T
     90   }
     91   deriving (Show)
     92 
     93 data Frame
     94   = BindFrame T
     95   | LocalFrame T
     96   deriving (Show)
     97 
     98 data Machine = Machine
     99   { machineRuntime :: Runtime
    100   , machineCurrent :: T
    101   , machineFrames  :: [Frame]
    102   }
    103   deriving (Show)
    104 
    105 -- ---------------------------------------------------------------------------
    106 -- Result convention
    107 -- ---------------------------------------------------------------------------
    108 -- Direct-return actions pass the raw value to the continuation:
    109 --   pure, bind, putStr, getLine, ask, local, get, put,
    110 --   fork, await, yield, sleep
    111 --
    112 -- Result-return actions wrap the outcome as an ok/err pair:
    113 --   ok val  = Fork (Stem Leaf) (Fork val Leaf)   -- (t t) val t
    114 --   err code = Fork Leaf (Fork code Leaf)        -- t code t
    115 --   readFile, writeFile
    116 --
    117 -- Runtime protocol errors are returned as direct values via errResult.
    118 
    119 okResult :: T -> T
    120 okResult val = Fork (Stem Leaf) (Fork val Leaf)
    121 
    122 errResult :: String -> T
    123 errResult msg = Fork Leaf (Fork (ofString msg) Leaf)
    124 
    125 pureAction :: T -> T
    126 pureAction x = Fork (ofNumber 0) x
    127 
    128 invalidAsyncHandleResult :: T
    129 invalidAsyncHandleResult = errResult "invalid task handle"
    130 
    131 invalidSocketHandleResult :: T
    132 invalidSocketHandleResult = errResult "invalid socket handle"
    133 
    134 selfAwaitResult :: T
    135 selfAwaitResult = errResult "self await"
    136 
    137 deadlockResult :: T
    138 deadlockResult = errResult "deadlock"
    139 
    140 invalidSleepResult :: T
    141 invalidSleepResult = errResult "invalid sleep"
    142 
    143 ioErrorString :: IOException -> String
    144 ioErrorString e
    145   | isDoesNotExistError  e = "does not exist"
    146   | isPermissionError    e = "permission denied"
    147   | isAlreadyExistsError e = "already exists"
    148   | otherwise              = "io error"
    149 
    150 -- ---------------------------------------------------------------------------
    151 -- Task identity and handles
    152 -- ---------------------------------------------------------------------------
    153 
    154 newtype TaskId = TaskId Integer
    155   deriving (Eq, Ord, Show)
    156 
    157 taskHandle :: TaskId -> T
    158 taskHandle (TaskId n) =
    159   Fork (ofString "task") (ofNumber n)
    160 
    161 decodeTaskHandle :: T -> Either String TaskId
    162 decodeTaskHandle tree =
    163   case tree of
    164     Fork tag nTree -> do
    165       tagString <- toString tag
    166       if tagString == "task"
    167         then TaskId <$> toNumber nTree
    168         else Left "invalid task handle tag"
    169     _ ->
    170       Left "invalid task handle"
    171 
    172 -- ---------------------------------------------------------------------------
    173 -- Socket identity and handles
    174 -- ---------------------------------------------------------------------------
    175 
    176 newtype SockId = SockId Integer
    177   deriving (Eq, Ord, Show)
    178 
    179 sockHandle :: SockId -> T
    180 sockHandle (SockId n) =
    181   Fork (ofString "sock") (ofNumber n)
    182 
    183 decodeSockHandle :: T -> Either String SockId
    184 decodeSockHandle tree =
    185   case tree of
    186     Fork tag nTree -> do
    187       tagString <- toString tag
    188       if tagString == "sock"
    189         then SockId <$> toNumber nTree
    190         else Left "invalid socket handle tag"
    191     _ ->
    192       Left "invalid socket handle"
    193 
    194 getSocketPort :: NS.Socket -> IO (Maybe Integer)
    195 getSocketPort sock = do
    196   addr <- NS.getSocketName sock
    197   case addr of
    198     NS.SockAddrInet p _      -> return (Just (fromIntegral p))
    199     NS.SockAddrInet6 p _ _ _ -> return (Just (fromIntegral p))
    200     _                        -> return Nothing
    201 
    202 -- ---------------------------------------------------------------------------
    203 -- Socket registry
    204 -- ---------------------------------------------------------------------------
    205 
    206 data SocketRegistry = SocketRegistry
    207   { sockMap    :: Map SockId NS.Socket
    208   , sockNextId :: Integer
    209   }
    210 
    211 -- Call with async exceptions masked from acquisition through registration.
    212 registerSocket :: TVar SocketRegistry -> NS.Socket -> IO SockId
    213 registerSocket registry sock = atomically $ do
    214   SocketRegistry sockets next <- readTVar registry
    215   let sid = SockId next
    216   writeTVar registry (SocketRegistry (Map.insert sid sock sockets) (next + 1))
    217   pure sid
    218 
    219 -- All OS workers belong to one run. Completed workers unregister immediately;
    220 -- cleanup cancels and joins the remaining workers before closing their sockets.
    221 type Workers = TVar (Map ThreadId (MVar ()))
    222 
    223 startWorker :: Workers -> IO () -> IO ()
    224 startWorker workers action = mask_ $ do
    225   start <- newEmptyMVar
    226   done <- newEmptyMVar
    227   tid <- forkIOWithUnmask $ \unmask -> do
    228     self <- readMVar start
    229     unmask action `finally` do
    230       atomically $ modifyTVar' workers (Map.delete self)
    231       putMVar done ()
    232   atomically $ modifyTVar' workers (Map.insert tid done)
    233   putMVar start tid
    234 
    235 cleanupRun :: (TVar (Map TaskId T), TVar SocketRegistry, Workers) -> IO ()
    236 cleanupRun (_, sockets, workers) = do
    237   pending <- atomically $ readTVar workers
    238   mapM_ killThread (Map.keys pending)
    239   mapM_ readMVar (Map.elems pending)
    240   owned <- atomically $ do
    241     SocketRegistry owned next <- readTVar sockets
    242     writeTVar sockets (SocketRegistry Map.empty next)
    243     pure owned
    244   mapM_ (\sock -> NS.close sock `catch` (\(_ :: IOException) -> pure ())) owned
    245 
    246 -- ---------------------------------------------------------------------------
    247 -- Free-monad action AST
    248 -- ---------------------------------------------------------------------------
    249 
    250 data Action
    251   = APure T
    252   | ABind T T
    253   | AAbort T
    254   | APutStr T
    255   | APutBytes T
    256   | AGetLine
    257   | AReadSourceFile T
    258   | AEncodeSourceText T
    259   | AReadFile T
    260   | AReadIndexedTree T T
    261   | AHashIndexedTree T
    262   | AWriteIndexedTreeIfAbsent T T T
    263   | AReadTreeTerm T T
    264   | AHashTreeTerm T
    265   | AWriteTreeTermIfAbsent T T T
    266   | AWriteFile T T
    267   | AWriteBytes T T
    268   | AWriteBytesIfAbsent T T
    269   | AAtomicWriteBytes T T
    270   | AListDirectory T
    271   | ARenameFile T T
    272   | ACreateDirectory T
    273   | ADeleteFile T
    274   | AFileExists T
    275   | ASha256Hex T
    276   | ACurrentTime
    277   | AAsk
    278   | ALocal T T
    279   | AGet
    280   | APut T
    281   | AFork T
    282   | AAwait T
    283   | AYield
    284   | ASleep T
    285   | ASocket
    286   | ACloseSocket T
    287   | ABindSocket T T T
    288   | AListen T T
    289   | AAccept T
    290   | AConnect T T T
    291   | ARecv T T
    292   | ASend T T
    293   | AGetSocketName T
    294   deriving (Show)
    295 
    296 -- ---------------------------------------------------------------------------
    297 -- Action tag constants
    298 -- ---------------------------------------------------------------------------
    299 
    300 tagPure, tagBind, tagAbort :: Integer
    301 tagPure = 0
    302 tagBind = 1
    303 tagAbort = 2
    304 
    305 tagPutStr, tagPutBytes, tagGetLine :: Integer
    306 tagPutStr = 10
    307 tagPutBytes = 12
    308 tagGetLine = 11
    309 
    310 tagReadFile, tagWriteFile, tagWriteBytes :: Integer
    311 tagReadFile = 20
    312 tagWriteFile = 21
    313 tagWriteBytes = 22
    314 
    315 tagListDirectory, tagRenameFile, tagCreateDirectory, tagDeleteFile, tagFileExists :: Integer
    316 tagListDirectory = 23
    317 tagRenameFile = 24
    318 tagCreateDirectory = 25
    319 tagDeleteFile = 26
    320 tagFileExists = 27
    321 
    322 tagSha256Hex, tagCurrentTime, tagWriteBytesIfAbsent, tagAtomicWriteBytes :: Integer
    323 tagSha256Hex = 28
    324 tagCurrentTime = 29
    325 tagWriteBytesIfAbsent = 32
    326 tagAtomicWriteBytes = 33
    327 
    328 tagReadTreeTerm :: Integer
    329 tagReadTreeTerm = 34
    330 
    331 tagHashTreeTerm, tagWriteTreeTermIfAbsent :: Integer
    332 tagHashTreeTerm = 35
    333 tagWriteTreeTermIfAbsent = 36
    334 
    335 tagReadSourceFile, tagEncodeSourceText :: Integer
    336 tagReadSourceFile = 37
    337 tagEncodeSourceText = 38
    338 -- 37/38 are source UTF-8 operations; 40/41 are state operations.
    339 tagReadIndexedTree, tagHashIndexedTree, tagWriteIndexedTreeIfAbsent :: Integer
    340 tagReadIndexedTree = 50
    341 tagHashIndexedTree = 51
    342 tagWriteIndexedTreeIfAbsent = 52
    343 
    344 tagAsk, tagLocal :: Integer
    345 tagAsk = 30
    346 tagLocal = 31
    347 
    348 tagGet, tagPut :: Integer
    349 tagGet = 40
    350 tagPut = 41
    351 
    352 tagFork, tagAwait, tagYield, tagSleep :: Integer
    353 tagFork = 60
    354 tagAwait = 61
    355 tagYield = 62
    356 tagSleep = 63
    357 
    358 tagSocket, tagCloseSocket, tagBindSocket, tagListen, tagAccept :: Integer
    359 tagSocket = 70
    360 tagCloseSocket = 71
    361 tagBindSocket = 72
    362 tagListen = 73
    363 tagAccept = 74
    364 
    365 tagConnect, tagRecv, tagSend, tagGetSocketName :: Integer
    366 tagConnect = 75
    367 tagRecv = 76
    368 tagSend = 77
    369 tagGetSocketName = 78
    370 
    371 data Step
    372   = Halt Runtime T
    373   | ExecutionFailed String
    374   | Continue Machine
    375   | ForkRequested T Machine
    376   | AwaitRequested TaskId Machine
    377   | YieldRequested Machine
    378   | SleepRequested Integer Machine
    379   | AsyncAction (IO T) Machine
    380 
    381 instance Show Step where
    382   show (Halt _ v) = "Halt _ (" ++ show v ++ ")"
    383   show (ExecutionFailed message) = "ExecutionFailed " ++ show message
    384   show (Continue m) = "Continue (" ++ show m ++ ")"
    385   show (ForkRequested t m) = "ForkRequested (" ++ show t ++ ") (" ++ show m ++ ")"
    386   show (AwaitRequested tid m) = "AwaitRequested " ++ show tid ++ " (" ++ show m ++ ")"
    387   show (YieldRequested m) = "YieldRequested (" ++ show m ++ ")"
    388   show (SleepRequested n m) = "SleepRequested " ++ show n ++ " (" ++ show m ++ ")"
    389   show (AsyncAction _ m) = "AsyncAction <io> (" ++ show m ++ ")"
    390 
    391 decodeAction :: T -> Either String Action
    392 decodeAction tree =
    393   case tree of
    394     Fork tag payload ->
    395       case toNumber tag of
    396         Right n | n == tagPure ->
    397           Right (APure payload)
    398 
    399         Right n | n == tagAbort ->
    400           Right (AAbort payload)
    401 
    402         Right n | n == tagBind ->
    403           case payload of
    404             Fork left k -> Right (ABind left k)
    405             _ -> Left "Invalid Bind: expected pair action continuation"
    406 
    407         Right n | n == tagPutStr ->
    408           Right (APutStr payload)
    409 
    410         Right n | n == tagPutBytes ->
    411           Right (APutBytes payload)
    412 
    413         Right n | n == tagGetLine ->
    414           Right AGetLine
    415 
    416         Right n | n == tagReadSourceFile ->
    417           Right (AReadSourceFile payload)
    418 
    419         Right n | n == tagEncodeSourceText ->
    420           Right (AEncodeSourceText payload)
    421 
    422         Right n | n == tagReadFile ->
    423           Right (AReadFile payload)
    424 
    425         Right n | n == tagReadTreeTerm ->
    426           case payload of
    427             Fork path expected -> Right (AReadTreeTerm path expected)
    428             _ -> Left "Invalid ReadTreeTerm: expected pair path digest"
    429 
    430         Right n | n == tagHashTreeTerm ->
    431           Right (AHashTreeTerm payload)
    432 
    433         Right n | n == tagWriteTreeTermIfAbsent ->
    434           case payload of
    435             Fork path (Fork expected value) -> Right (AWriteTreeTermIfAbsent path expected value)
    436             _ -> Left "Invalid WriteTreeTermIfAbsent: expected path digest tree"
    437 
    438         Right n | n == tagReadIndexedTree ->
    439           case payload of
    440             Fork path expected -> Right (AReadIndexedTree path expected)
    441             _ -> Left "Invalid ReadIndexedTree: expected pair path digest"
    442 
    443         Right n | n == tagHashIndexedTree ->
    444           Right (AHashIndexedTree payload)
    445 
    446         Right n | n == tagWriteIndexedTreeIfAbsent ->
    447           case payload of
    448             Fork path (Fork expected value) -> Right (AWriteIndexedTreeIfAbsent path expected value)
    449             _ -> Left "Invalid WriteIndexedTreeIfAbsent: expected path digest tree"
    450 
    451         Right n | n == tagWriteFile ->
    452           case payload of
    453             Fork path contents -> Right (AWriteFile path contents)
    454             _ -> Left "Invalid WriteFile: expected pair path contents"
    455 
    456         Right n | n == tagWriteBytes ->
    457           case payload of
    458             Fork path contents -> Right (AWriteBytes path contents)
    459             _ -> Left "Invalid WriteBytes: expected pair path contents"
    460 
    461         Right n | n == tagWriteBytesIfAbsent ->
    462           case payload of
    463             Fork path contents -> Right (AWriteBytesIfAbsent path contents)
    464             _ -> Left "Invalid WriteBytesIfAbsent: expected pair path contents"
    465 
    466         Right n | n == tagAtomicWriteBytes ->
    467           case payload of
    468             Fork path contents -> Right (AAtomicWriteBytes path contents)
    469             _ -> Left "Invalid AtomicWriteBytes: expected pair path contents"
    470 
    471         Right n | n == tagListDirectory ->
    472           Right (AListDirectory payload)
    473 
    474         Right n | n == tagRenameFile ->
    475           case payload of
    476             Fork old new -> Right (ARenameFile old new)
    477             _ -> Left "Invalid RenameFile: expected pair oldPath newPath"
    478 
    479         Right n | n == tagCreateDirectory ->
    480           Right (ACreateDirectory payload)
    481 
    482         Right n | n == tagDeleteFile ->
    483           Right (ADeleteFile payload)
    484 
    485         Right n | n == tagFileExists ->
    486           Right (AFileExists payload)
    487 
    488         Right n | n == tagSha256Hex ->
    489           Right (ASha256Hex payload)
    490 
    491         Right n | n == tagCurrentTime ->
    492           Right ACurrentTime
    493 
    494         Right n | n == tagAsk ->
    495           Right AAsk
    496 
    497         Right n | n == tagLocal ->
    498           case payload of
    499             Fork f action -> Right (ALocal f action)
    500             _ -> Left "Invalid Local: expected pair function action"
    501 
    502         Right n | n == tagGet ->
    503           Right AGet
    504 
    505         Right n | n == tagPut ->
    506           Right (APut payload)
    507 
    508         Right n | n == tagFork ->
    509           Right (AFork payload)
    510 
    511         Right n | n == tagAwait ->
    512           Right (AAwait payload)
    513 
    514         Right n | n == tagYield ->
    515           Right AYield
    516 
    517         Right n | n == tagSleep ->
    518           Right (ASleep payload)
    519 
    520         Right n | n == tagSocket ->
    521           Right ASocket
    522 
    523         Right n | n == tagCloseSocket ->
    524           Right (ACloseSocket payload)
    525 
    526         Right n | n == tagBindSocket ->
    527           case payload of
    528             Fork sock (Fork addr port) -> Right (ABindSocket sock addr port)
    529             _ -> Left "Invalid BindSocket: expected pair sock (pair addr port)"
    530 
    531         Right n | n == tagListen ->
    532           case payload of
    533             Fork sock backlog -> Right (AListen sock backlog)
    534             _ -> Left "Invalid Listen: expected pair sock backlog"
    535 
    536         Right n | n == tagAccept ->
    537           Right (AAccept payload)
    538 
    539         Right n | n == tagConnect ->
    540           case payload of
    541             Fork sock (Fork addr port) -> Right (AConnect sock addr port)
    542             _ -> Left "Invalid Connect: expected pair sock (pair addr port)"
    543 
    544         Right n | n == tagRecv ->
    545           case payload of
    546             Fork sock maxBytes -> Right (ARecv sock maxBytes)
    547             _ -> Left "Invalid Recv: expected pair sock maxBytes"
    548 
    549         Right n | n == tagSend ->
    550           case payload of
    551             Fork sock bytes -> Right (ASend sock bytes)
    552             _ -> Left "Invalid Send: expected pair sock bytes"
    553 
    554         Right n | n == tagGetSocketName ->
    555           Right (AGetSocketName payload)
    556 
    557         Right n ->
    558           Left $ "Unknown IO action tag: " ++ show n
    559 
    560         Left err ->
    561           Left $ "Invalid action tag: " ++ err
    562 
    563     _ ->
    564       Left $ "Invalid action tree: expected pair tag payload, got " ++ show tree
    565 
    566 -- ---------------------------------------------------------------------------
    567 -- Small-step IO machine
    568 -- ---------------------------------------------------------------------------
    569 
    570 finishValue :: Machine -> T -> IO Step
    571 finishValue machine value =
    572   case machineFrames machine of
    573     [] ->
    574       pure (Halt (machineRuntime machine) value)
    575 
    576     BindFrame k : rest ->
    577       pure (Continue machine
    578         { machineCurrent = apply k value
    579         , machineFrames = rest
    580         })
    581 
    582     LocalFrame oldEnv : rest ->
    583       let runtime' = (machineRuntime machine) { rtEnv = oldEnv }
    584       in pure (Continue machine
    585           { machineRuntime = runtime'
    586           , machineCurrent = pureAction value
    587           , machineFrames = rest
    588           })
    589 
    590 stepMachine :: TVar SocketRegistry -> Machine -> IO Step
    591 stepMachine sockVar machine =
    592   case decodeAction (machineCurrent machine) of
    593     Right action -> dispatch action
    594     Left _       -> finishValue machine (errResult "invalid action")
    595   where
    596     dispatch action = case action of
    597       APure val ->
    598         finishValue machine val
    599 
    600       AAbort diagnostic ->
    601         pure (ExecutionFailed
    602           ("execution aborted: " ++ either (const $ formatT Decode diagnostic) id (toString diagnostic)))
    603 
    604       ABind left k ->
    605         pure (Continue machine
    606           { machineCurrent = left
    607           , machineFrames = BindFrame k : machineFrames machine
    608           })
    609 
    610       APutStr str ->
    611         case decodeString str "PutStr" of
    612           Right s ->
    613             pure (AsyncAction (putStr s >> pure Leaf) machine)
    614           Left _ ->
    615             finishValue machine (errResult "invalid string")
    616 
    617       APutBytes bs ->
    618         case decodeBytes bs "PutBytes" of
    619           Right b ->
    620             pure (AsyncAction (BS.putStr b >> pure Leaf) machine)
    621           Left _ ->
    622             finishValue machine (errResult "invalid bytes")
    623 
    624       AGetLine ->
    625         pure (AsyncAction (ofString <$> getLine) machine)
    626 
    627       AReadSourceFile path -> dispatchFileRead tryReadSourceFile path
    628 
    629       AEncodeSourceText text ->
    630         case decodeString text "EncodeSourceText" of
    631           Right contents | text == ofString contents -> finishValue machine
    632             (okResult (ofBytes (encodeUtf8 (T.pack contents))))
    633           _ -> finishValue machine (errResult "invalid source scalar list")
    634 
    635       AReadFile path -> dispatchFileRead tryReadFile path
    636 
    637       AReadTreeTerm path expected ->
    638         dispatchTreeRead tryReadTreeTerm path expected
    639 
    640       AHashTreeTerm tree ->
    641         pure (AsyncAction (do
    642           digest <- evaluate (hashObject treeTermDomain (encodeTreeTerm tree))
    643           return (okResult (ofString (T.unpack digest)))) machine)
    644 
    645       AWriteTreeTermIfAbsent path expected tree ->
    646         dispatchTreeWrite tryWriteTreeTerm path expected tree
    647 
    648       AReadIndexedTree path expected ->
    649         dispatchTreeRead tryReadIndexedTree path expected
    650 
    651       AHashIndexedTree tree ->
    652         pure (AsyncAction (do
    653           payload <- encodeIndexedTree tree
    654           digest <- evaluate (hashObject indexedTreeDomain payload)
    655           return (okResult (ofString (T.unpack digest)))) machine)
    656 
    657       AWriteIndexedTreeIfAbsent path expected tree ->
    658         dispatchTreeWrite tryWriteIndexedTree path expected tree
    659 
    660       AWriteFile path contents ->
    661         case decodeString path "WriteFile" of
    662           Right p ->
    663             case decodeString contents "WriteFile" of
    664               Right c -> do
    665                 mDeny <- checkWritePerm p
    666                 case mDeny of
    667                   Just denied -> finishValue machine denied
    668                   Nothing     -> pure (AsyncAction (tryWriteFile p c) machine)
    669               Left _ -> finishValue machine (errResult "invalid string")
    670           Left _ -> finishValue machine (errResult "invalid string")
    671 
    672       AWriteBytes path contents ->
    673         case decodeString path "WriteBytes" of
    674           Right p ->
    675             case decodeBytes contents "WriteBytes" of
    676               Right c -> do
    677                 mDeny <- checkWritePerm p
    678                 case mDeny of
    679                   Just denied -> finishValue machine denied
    680                   Nothing     -> pure (AsyncAction (tryWriteFileBytes p c) machine)
    681               Left _ -> finishValue machine (errResult "invalid bytes")
    682           Left _ -> finishValue machine (errResult "invalid string")
    683 
    684       AWriteBytesIfAbsent path contents ->
    685         dispatchAtomicBytes path contents True
    686 
    687       AAtomicWriteBytes path contents ->
    688         dispatchAtomicBytes path contents False
    689 
    690       AListDirectory pathTree ->
    691         case decodeString pathTree "ListDirectory" of
    692           Right p -> do
    693             mDeny <- checkReadPerm p
    694             case mDeny of
    695               Just denied -> finishValue machine denied
    696               Nothing     -> pure (AsyncAction (tryListDirectory p) machine)
    697           Left _ -> finishValue machine (errResult "invalid string")
    698 
    699       ARenameFile oldTree newTree ->
    700         case decodeString oldTree "RenameFile" of
    701           Right old ->
    702             case decodeString newTree "RenameFile" of
    703               Right new -> do
    704                 mDenyOld <- checkWritePerm old
    705                 mDenyNew <- checkWritePerm new
    706                 case (mDenyOld, mDenyNew) of
    707                   (Just denied, _) -> finishValue machine denied
    708                   (_, Just denied) -> finishValue machine denied
    709                   (Nothing, Nothing) -> pure (AsyncAction (tryRenameFile old new) machine)
    710               Left _ -> finishValue machine (errResult "invalid string")
    711           Left _ -> finishValue machine (errResult "invalid string")
    712 
    713       ACreateDirectory pathTree ->
    714         case decodeString pathTree "CreateDirectory" of
    715           Right p -> do
    716             mDeny <- checkWritePerm p
    717             case mDeny of
    718               Just denied -> finishValue machine denied
    719               Nothing     -> pure (AsyncAction (tryCreateDirectory p) machine)
    720           Left _ -> finishValue machine (errResult "invalid string")
    721 
    722       ADeleteFile pathTree ->
    723         case decodeString pathTree "DeleteFile" of
    724           Right p -> do
    725             mDeny <- checkWritePerm p
    726             case mDeny of
    727               Just denied -> finishValue machine denied
    728               Nothing     -> pure (AsyncAction (tryDeleteFile p) machine)
    729           Left _ -> finishValue machine (errResult "invalid string")
    730 
    731       AFileExists pathTree ->
    732         case decodeString pathTree "FileExists" of
    733           Right p -> do
    734             mDeny <- checkReadPerm p
    735             case mDeny of
    736               Just denied -> finishValue machine denied
    737               Nothing     -> pure (AsyncAction (tryFileExists p) machine)
    738           Left _ -> finishValue machine (errResult "invalid string")
    739 
    740       ASha256Hex bytesTree ->
    741         case decodeBytes bytesTree "Sha256Hex" of
    742           Right bs -> pure (AsyncAction (pure $ trySha256Hex bs) machine)
    743           Left _ -> finishValue machine (errResult "invalid bytes")
    744 
    745       ACurrentTime ->
    746         pure (AsyncAction (tryCurrentTime) machine)
    747 
    748       AAsk ->
    749         finishValue machine (rtEnv (machineRuntime machine))
    750 
    751       ALocal f action' ->
    752         let runtime = machineRuntime machine
    753             oldEnv  = rtEnv runtime
    754             newEnv  = apply f oldEnv
    755             runtime' = runtime { rtEnv = newEnv }
    756         in pure (Continue machine
    757             { machineRuntime = runtime'
    758             , machineCurrent = action'
    759             , machineFrames = LocalFrame oldEnv : machineFrames machine
    760             })
    761 
    762       AGet ->
    763         finishValue machine (rtState (machineRuntime machine))
    764 
    765       APut newState ->
    766         let runtime' = (machineRuntime machine) { rtState = newState }
    767         in finishValue (machine { machineRuntime = runtime' }) Leaf
    768 
    769       AFork childAction ->
    770         pure (ForkRequested childAction machine)
    771 
    772       AAwait handleTree ->
    773         case decodeTaskHandle handleTree of
    774           Right taskId ->
    775             pure (AwaitRequested taskId machine)
    776           Left _ ->
    777             finishValue machine invalidAsyncHandleResult
    778 
    779       AYield ->
    780         pure (YieldRequested machine)
    781 
    782       ASleep msTree ->
    783         case toNumber msTree of
    784           Right ms | ms >= 0 ->
    785             pure (SleepRequested ms machine)
    786           _ ->
    787             finishValue machine invalidSleepResult
    788 
    789       ASocket -> mask_ $ do
    790         -- Acquisition through registry insertion is one ownership transfer.
    791         result <- try $ bracketOnError
    792           (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol) NS.close $ \sock -> do
    793             NS.setSocketOption sock NS.ReuseAddr 1
    794             registerSocket sockVar sock
    795         case result of
    796           Left (e :: IOException) -> finishValue machine (errResult ("io error: " ++ show e))
    797           Right sid -> finishValue machine (okResult (sockHandle sid))
    798 
    799       ACloseSocket sockTree -> mask_ $
    800         case decodeSockHandle sockTree of
    801           Left _ -> finishValue machine invalidSocketHandleResult
    802           Right sid -> do
    803             mSock <- atomically $ do
    804               SocketRegistry m next <- readTVar sockVar
    805               case Map.lookup sid m of
    806                 Nothing -> return Nothing
    807                 Just sock -> do
    808                   writeTVar sockVar (SocketRegistry (Map.delete sid m) next)
    809                   return (Just sock)
    810             case mSock of
    811               Nothing -> finishValue machine invalidSocketHandleResult
    812               Just sock -> do
    813                 NS.close sock
    814                 finishValue machine (okResult Leaf)
    815 
    816       ABindSocket sockTree addrTree portTree ->
    817         case decodeSockHandle sockTree of
    818           Left _ -> finishValue machine invalidSocketHandleResult
    819           Right sid ->
    820             case decodeString addrTree "BindSocket" of
    821               Left _ -> finishValue machine (errResult "invalid address")
    822               Right addrStr ->
    823                 case toNumber portTree of
    824                   Left _ -> finishValue machine (errResult "invalid port")
    825                   Right port -> do
    826                     mSock <- atomically $ do
    827                       SocketRegistry m _ <- readTVar sockVar
    828                       return (Map.lookup sid m)
    829                     case mSock of
    830                       Nothing -> finishValue machine invalidSocketHandleResult
    831                       Just sock -> do
    832                         result <- try (do
    833                           addrInfo <- NS.getAddrInfo (Just $ NS.defaultHints { NS.addrSocketType = NS.Stream })
    834                                                      (Just addrStr)
    835                                                      (Just (show port))
    836                           let serverAddr = head addrInfo
    837                           NS.bind sock (NS.addrAddress serverAddr)
    838                           ) :: IO (Either IOException ())
    839                         case result of
    840                           Left e ->
    841                             finishValue machine (errResult ("io error: " ++ show e))
    842                           Right () ->
    843                             finishValue machine (okResult Leaf)
    844 
    845       AListen sockTree backlogTree ->
    846         case decodeSockHandle sockTree of
    847           Left _ -> finishValue machine invalidSocketHandleResult
    848           Right sid ->
    849             case toNumber backlogTree of
    850               Left _ -> finishValue machine (errResult "invalid backlog")
    851               Right backlog -> do
    852                 mSock <- atomically $ do
    853                   SocketRegistry m _ <- readTVar sockVar
    854                   return (Map.lookup sid m)
    855                 case mSock of
    856                   Nothing -> finishValue machine invalidSocketHandleResult
    857                   Just sock -> do
    858                     result <- try (NS.listen sock (fromIntegral backlog)) :: IO (Either IOException ())
    859                     case result of
    860                       Left e ->
    861                         finishValue machine (errResult ("io error: " ++ show e))
    862                       Right () ->
    863                         finishValue machine (okResult Leaf)
    864 
    865       AAccept listenTree ->
    866         case decodeSockHandle listenTree of
    867           Left _ -> finishValue machine invalidSocketHandleResult
    868           Right listenSid ->
    869             pure (AsyncAction (mask_ $ do
    870               mListenSock <- atomically $ do
    871                 SocketRegistry m _ <- readTVar sockVar
    872                 return (Map.lookup listenSid m)
    873               case mListenSock of
    874                 Nothing -> return (errResult "invalid socket handle")
    875                 Just listenSock -> do
    876                   result <- try (NS.accept listenSock) :: IO (Either IOException (NS.Socket, NS.SockAddr))
    877                   case result of
    878                     Left e ->
    879                       return (errResult ("io error: " ++ show e))
    880                     Right (clientSock, addr) -> do
    881                       clientSid <- registerSocket sockVar clientSock
    882                       let addrStr = case addr of
    883                             NS.SockAddrInet p h ->
    884                               let (a,b,c,d) = NS.hostAddressToTuple h
    885                               in show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d ++ ":" ++ show p
    886                             _ -> show addr
    887                       return (okResult (Fork (sockHandle clientSid) (ofString addrStr)))
    888               ) machine)
    889 
    890       AConnect sockTree addrTree portTree ->
    891         case decodeSockHandle sockTree of
    892           Left _ -> finishValue machine invalidSocketHandleResult
    893           Right sid ->
    894             case decodeString addrTree "Connect" of
    895               Left _ -> finishValue machine (errResult "invalid address")
    896               Right addrStr ->
    897                 case toNumber portTree of
    898                   Left _ -> finishValue machine (errResult "invalid port")
    899                   Right port -> do
    900                     mSock <- atomically $ do
    901                       SocketRegistry m _ <- readTVar sockVar
    902                       return (Map.lookup sid m)
    903                     case mSock of
    904                       Nothing -> finishValue machine invalidSocketHandleResult
    905                       Just sock ->
    906                         pure (AsyncAction (do
    907                           result <- try (do
    908                             addrInfo <- NS.getAddrInfo (Just $ NS.defaultHints { NS.addrSocketType = NS.Stream })
    909                                                        (Just addrStr)
    910                                                        (Just (show port))
    911                             let serverAddr = head addrInfo
    912                             NS.connect sock (NS.addrAddress serverAddr)
    913                             ) :: IO (Either IOException ())
    914                           case result of
    915                             Left e ->
    916                               return (errResult ("io error: " ++ show e))
    917                             Right () ->
    918                               return (okResult Leaf)
    919                           ) machine)
    920 
    921       ARecv sockTree maxBytesTree ->
    922         case decodeSockHandle sockTree of
    923           Left _ -> finishValue machine invalidSocketHandleResult
    924           Right sid ->
    925             case toNumber maxBytesTree of
    926               Left _ -> finishValue machine (errResult "invalid maxBytes")
    927               Right maxBytes -> do
    928                 mSock <- atomically $ do
    929                   SocketRegistry m _ <- readTVar sockVar
    930                   return (Map.lookup sid m)
    931                 case mSock of
    932                   Nothing -> finishValue machine invalidSocketHandleResult
    933                   Just sock ->
    934                     pure (AsyncAction (do
    935                       result <- try (NSB.recv sock (fromIntegral maxBytes)) :: IO (Either IOException BS.ByteString)
    936                       case result of
    937                         Left e ->
    938                           return (errResult ("io error: " ++ show e))
    939                         Right bs ->
    940                           if BS.null bs
    941                             then return (errResult "connection closed")
    942                             else return (okResult (ofBytes bs))
    943                       ) machine)
    944 
    945       AGetSocketName sockTree ->
    946         case decodeSockHandle sockTree of
    947           Left _ -> finishValue machine invalidSocketHandleResult
    948           Right sid -> do
    949             mSock <- atomically $ do
    950               SocketRegistry m _ <- readTVar sockVar
    951               return (Map.lookup sid m)
    952             case mSock of
    953               Nothing -> finishValue machine invalidSocketHandleResult
    954               Just sock -> do
    955                 mPort <- getSocketPort sock
    956                 case mPort of
    957                   Just port -> finishValue machine (okResult (ofNumber port))
    958                   Nothing   -> finishValue machine (errResult "io error: could not get socket name")
    959 
    960       ASend sockTree bytesTree ->
    961         case decodeSockHandle sockTree of
    962           Left _ -> finishValue machine invalidSocketHandleResult
    963           Right sid ->
    964             case decodeBytes bytesTree "Send" of
    965               Left _ -> finishValue machine (errResult "invalid bytes")
    966               Right bs -> do
    967                 mSock <- atomically $ do
    968                   SocketRegistry m _ <- readTVar sockVar
    969                   return (Map.lookup sid m)
    970                 case mSock of
    971                   Nothing -> finishValue machine invalidSocketHandleResult
    972                   Just sock ->
    973                     pure (AsyncAction (do
    974                       result <- try (NSB.send sock bs) :: IO (Either IOException Int)
    975                       case result of
    976                         Left e ->
    977                           return (errResult ("io error: " ++ show e))
    978                         Right sent ->
    979                           return (okResult (ofNumber (fromIntegral sent)))
    980                       ) machine)
    981 
    982     dispatchFileRead reader path =
    983       case toString path of
    984         Left _ -> finishValue machine (errResult "invalid string")
    985         Right p -> permittedRead reader p
    986 
    987     permittedRead reader path = do
    988       denied <- checkReadPerm path
    989       case denied of
    990         Just result -> finishValue machine result
    991         Nothing -> pure (AsyncAction (reader path) machine)
    992 
    993     -- Keep validation before permissions, and permissions before encoding or OS
    994     -- work. In particular, denied tree publication must not force the tree.
    995     withTreeIdentity path expected next =
    996       case (toString path, toString expected) of
    997         (Right p, Right digest) -> case validateObjectHash (T.pack digest) of
    998           Left _ -> finishValue machine (errResult "invalid CAS digest")
    999           Right () -> next p (T.pack digest)
   1000         _ -> finishValue machine (errResult "invalid string")
   1001 
   1002     dispatchTreeRead reader path expected = withTreeIdentity path expected $ \p digest ->
   1003       permittedRead (\file -> reader file digest) p
   1004 
   1005     dispatchTreeWrite writer path expected tree = withTreeIdentity path expected $ \p digest -> do
   1006       -- Verifying a pre-existing/racing winner requires read permission too.
   1007       writeDenied <- checkWritePerm p
   1008       readDenied <- checkReadPerm p
   1009       case (writeDenied, readDenied) of
   1010         (Just result, _) -> finishValue machine result
   1011         (_, Just result) -> finishValue machine result
   1012         _ -> pure (AsyncAction (writer p digest tree) machine)
   1013 
   1014     dispatchAtomicBytes pathTree contentsTree exclusive =
   1015       case decodeString pathTree "AtomicWriteBytes" of
   1016         Right p ->
   1017           case decodeBytes contentsTree "AtomicWriteBytes" of
   1018             Right bs -> do
   1019               mDeny <- checkWritePerm p
   1020               case mDeny of
   1021                 Just denied -> finishValue machine denied
   1022                 Nothing -> pure (AsyncAction
   1023                   (tryAtomicBytes p bs exclusive) machine)
   1024             Left _ -> finishValue machine (errResult "invalid bytes")
   1025         Left _ -> finishValue machine (errResult "invalid string")
   1026 
   1027     -- Resolve existing symlinked ancestors even when the final name is new.
   1028     -- Canonicalization failures deny access; they must never fall back to a
   1029     -- syntactic prefix. This is a path policy, not a race-free filesystem sandbox.
   1030     checkReadPerm = checkPathPerm allowReadAll allowRead
   1031     checkWritePerm = checkPathPerm allowWriteAll allowWrite
   1032 
   1033     checkPathPerm unrestricted roots path
   1034       | unrestricted perms = pure Nothing
   1035       | otherwise = do
   1036           checked <- try $ do
   1037             canonical <- canonicalizePath path
   1038             prefixes <- mapM canonicalizePath (filter (not . null) (roots perms))
   1039             pure (any (isPathPrefixOf canonical) prefixes)
   1040           pure $ case checked of
   1041             Right True -> Nothing
   1042             Right False -> Just policyErrResult
   1043             Left (_ :: IOException) -> Just policyErrResult
   1044       where perms = rtPerms (machineRuntime machine)
   1045 
   1046     policyErrResult = errResult "permission denied"
   1047 
   1048     isPathPrefixOf :: FilePath -> FilePath -> Bool
   1049     isPathPrefixOf path prefix =
   1050       let prefix' = addTrailingPathSeparator prefix
   1051       in path == prefix || prefix' `isPrefixOf` path
   1052 
   1053     -- Source-only boundary: preserve the exact octets alongside decoded scalars.
   1054     -- No BOM stripping, replacement decoding, newline folding or normalization.
   1055     tryReadSourceFile path = do
   1056       result <- try (BS.readFile path) :: IO (Either IOException BS.ByteString)
   1057       return $ case result of
   1058         Left e -> errResult (ioErrorString e)
   1059         Right bytes -> case decodeUtf8' bytes of
   1060           Left problem -> errResult (path ++ ": invalid UTF-8 source: " ++ show problem)
   1061           Right text
   1062             | T.isPrefixOf (T.singleton '\xfeff') text ->
   1063                 errResult (path ++ ": UTF-8 source BOM is not permitted")
   1064             | otherwise -> okResult (Fork (ofBytes bytes) (ofString (T.unpack text)))
   1065 
   1066     tryReadFile path = do
   1067       result <- try (BS.readFile path) :: IO (Either IOException BS.ByteString)
   1068       case result of
   1069         Right content -> return $ okResult (ofBytes content)
   1070         Left e        -> return $ errResult (ioErrorString e)
   1071 
   1072     -- Fixed canonical domain, no source evaluation and no byte-list roundtrip.
   1073     -- Verify before decoding so malformed bytes cannot bypass integrity checks.
   1074     tryReadTreeTerm = tryReadTreeObject treeTermDomain decodeTreeTermShared "invalid canonical tree-term"
   1075     tryReadIndexedTree = tryReadTreeObject indexedTreeDomain decodeIndexedTree "invalid indexed tree"
   1076 
   1077     tryReadTreeObject domain decode invalid path expected = do
   1078       result <- try (BS.readFile path) :: IO (Either IOException BS.ByteString)
   1079       case result of
   1080         Left e -> return $ errResult (ioErrorString e)
   1081         Right payload
   1082           | hashObject domain payload /= expected ->
   1083               return $ errResult "CAS digest mismatch"
   1084           | otherwise -> case decode payload of
   1085               Left _ -> return $ errResult invalid
   1086               Right tree -> return $ okResult tree
   1087 
   1088     tryWriteTreeTerm path expected tree =
   1089       tryWriteTreeObject treeTermDomain path expected (encodeTreeTerm tree)
   1090     tryWriteIndexedTree path expected tree = do
   1091       payload <- encodeIndexedTree tree
   1092       tryWriteTreeObject indexedTreeDomain path expected payload
   1093 
   1094     tryWriteTreeObject domain path expected payload = do
   1095       if hashObject domain payload /= expected
   1096         then return $ errResult "CAS digest mismatch"
   1097         else do
   1098           published <- tryAtomicBytes path payload True
   1099           case published of
   1100             Fork (Stem Leaf) (Fork _ Leaf) -> do
   1101               -- Preserve byte-for-byte winner checking, not merely hash checking.
   1102               winner <- try (BS.readFile path) :: IO (Either IOException BS.ByteString)
   1103               case winner of
   1104                 Left e -> return $ errResult (ioErrorString e)
   1105                 Right bytes
   1106                   | bytes == payload -> return published
   1107                   | otherwise -> return $ errResult "CAS object exists with different bytes"
   1108             _ -> return published
   1109 
   1110     tryWriteFile path contents = tryWriteUnit (IO.writeFile path contents)
   1111     tryWriteFileBytes path contents = tryWriteUnit (BS.writeFile path contents)
   1112 
   1113     tryWriteUnit action = do
   1114       result <- try action :: IO (Either IOException ())
   1115       pure $ either (errResult . ioErrorString) (const (okResult Leaf)) result
   1116 
   1117     -- Sync file contents before exposing the name and its parent directory
   1118     -- after publication. A losing writer also syncs the winning object so a
   1119     -- following lock/alias cannot outlive the object on a power loss.
   1120     syncPath path = bracket
   1121       (openFd path ReadOnly defaultFileFlags)
   1122       closeFd fileSynchronise
   1123 
   1124     syncParent path = syncPath (takeDirectory path)
   1125 
   1126     tryAtomicBytes path contents exclusive = do
   1127       let tmpDir = takeDirectory path
   1128           cleanup tmp h = do
   1129             IO.hClose h `catch` (\(_ :: IOException) -> return ())
   1130             removeFile tmp `catch` (\(_ :: IOException) -> return ())
   1131       result <- try $ bracket
   1132         (IO.openBinaryTempFile tmpDir ".tricu-write-")
   1133         (\(tmp, h) -> cleanup tmp h)
   1134         (\(tmp, h) -> do
   1135           BS.hPut h contents
   1136           IO.hClose h
   1137           syncPath tmp
   1138           if exclusive
   1139             then do
   1140               linked <- try (createLink tmp path) :: IO (Either IOException ())
   1141               case linked of
   1142                 Right () -> syncParent path >> return True
   1143                 Left e | isAlreadyExistsError e -> do
   1144                            syncPath path
   1145                            syncParent path
   1146                            return False
   1147                        | otherwise -> ioError e
   1148             else renameFile tmp path >> syncParent path >> return True)
   1149       case result of
   1150         Right newlyWritten -> return $ okResult
   1151           (if newlyWritten then Stem Leaf else Leaf)
   1152         Left (e :: IOException) -> return $ errResult (ioErrorString e)
   1153 
   1154     tryListDirectory path = do
   1155       exists <- doesPathExist path
   1156       if not exists
   1157         then return $ errResult "does not exist"
   1158         else do
   1159           isDir <- doesDirectoryExist path
   1160           if not isDir
   1161             then return $ errResult "not a directory"
   1162             else do
   1163               result <- try (listDirectory path) :: IO (Either IOException [FilePath])
   1164               case result of
   1165                 Right entries ->
   1166                   let filtered = filter (`notElem` [".", ".."]) entries
   1167                   in return $ okResult (ofList (map ofString filtered))
   1168                 Left e -> return $ errResult (ioErrorString e)
   1169 
   1170     tryRenameFile old new = do
   1171       oldExists <- doesPathExist old
   1172       if not oldExists
   1173         then return $ errResult "does not exist"
   1174         else do
   1175           result <- try (renameFile old new) :: IO (Either IOException ())
   1176           case result of
   1177             Right () -> return $ okResult Leaf
   1178             Left e
   1179               | isDoesNotExistError e -> return $ errResult "does not exist"
   1180               | isPermissionError e -> return $ errResult "permission denied"
   1181               | "cross-device" `isInfixOf` map toLower (show e) || "exdev" `isInfixOf` map toLower (show e) ->
   1182                   return $ errResult "cross-device rename"
   1183               | otherwise -> return $ errResult (ioErrorString e)
   1184 
   1185     tryCreateDirectory path = do
   1186       exists <- doesPathExist path
   1187       if exists
   1188         then do
   1189           isDir <- doesDirectoryExist path
   1190           if isDir
   1191             then durableDirectoryResult path
   1192             else return $ errResult "already exists"
   1193         else do
   1194           let parent = takeDirectory path
   1195           parentExists <- doesPathExist parent
   1196           if parentExists
   1197             then do
   1198               parentIsDir <- doesDirectoryExist parent
   1199               if parentIsDir
   1200                 then do
   1201                   result <- try (createDirectory path) :: IO (Either IOException ())
   1202                   case result of
   1203                     Right () -> durableDirectoryResult path
   1204                     Left e
   1205                       | isDoesNotExistError e -> return $ errResult "does not exist"
   1206                       | isPermissionError e -> return $ errResult "permission denied"
   1207                       | isAlreadyExistsError e -> existingDirectoryResult path
   1208                       | otherwise -> return $ errResult (ioErrorString e)
   1209                 else return $ errResult "not a directory"
   1210             else do
   1211               result <- try (createDirectory path) :: IO (Either IOException ())
   1212               case result of
   1213                 Right () -> durableDirectoryResult path
   1214                 Left e
   1215                   | isDoesNotExistError e -> return $ errResult "does not exist"
   1216                   | isPermissionError e -> return $ errResult "permission denied"
   1217                   | isAlreadyExistsError e -> existingDirectoryResult path
   1218                   | otherwise -> return $ errResult (ioErrorString e)
   1219 
   1220     durableDirectoryResult path = do
   1221       result <- try (syncPath path >> syncParent path) :: IO (Either IOException ())
   1222       return $ either (errResult . ioErrorString) (const (okResult Leaf)) result
   1223 
   1224     existingDirectoryResult path = do
   1225       isDir <- doesDirectoryExist path
   1226       if isDir then durableDirectoryResult path
   1227         else return $ errResult "already exists"
   1228 
   1229     tryDeleteFile path = do
   1230       exists <- doesPathExist path
   1231       if not exists
   1232         then return $ okResult Leaf
   1233         else do
   1234           isDir <- doesDirectoryExist path
   1235           if isDir
   1236             then return $ errResult "is a directory"
   1237             else do
   1238               result <- try (removeFile path) :: IO (Either IOException ())
   1239               case result of
   1240                 Right () -> return $ okResult Leaf
   1241                 Left e
   1242                   | isDoesNotExistError e -> return $ okResult Leaf
   1243                   | isPermissionError e -> return $ errResult "permission denied"
   1244                   | otherwise -> return $ errResult (ioErrorString e)
   1245 
   1246     tryFileExists path = do
   1247       result <- try (doesPathExist path) :: IO (Either IOException Bool)
   1248       case result of
   1249         Right exists -> return $ okResult (if exists then Stem Leaf else Leaf)
   1250         Left e
   1251           | isPermissionError e -> return $ errResult "permission denied"
   1252           | otherwise -> return $ errResult (ioErrorString e)
   1253 
   1254     trySha256Hex bs =
   1255       let digest = hash bs :: Digest SHA256
   1256           hexBs = encode (convert digest)
   1257           hexStr = T.unpack (decodeUtf8 hexBs)
   1258       in okResult (ofString hexStr)
   1259 
   1260     tryCurrentTime = do
   1261       now <- getPOSIXTime
   1262       return $ okResult (ofNumber (floor now))
   1263 
   1264     decodeString t ctx =
   1265       case toString t of
   1266         Right s  -> Right s
   1267         Left _ -> Left $ "Invalid " ++ ctx ++ " string"
   1268 
   1269     decodeBytes t ctx =
   1270       case toBytes t of
   1271         Right b  -> Right b
   1272         Left _ -> Left $ "Invalid " ++ ctx ++ " bytes"
   1273 
   1274 -- ---------------------------------------------------------------------------
   1275 -- Scheduler
   1276 -- ---------------------------------------------------------------------------
   1277 
   1278 data TaskStatus
   1279   = Runnable Machine
   1280   | BlockedOn TaskId Machine
   1281   | Sleeping UTCTime Machine
   1282   | AsyncWaiting Machine
   1283   deriving (Show)
   1284 
   1285 data Scheduler = Scheduler
   1286   { schedulerNextTaskId :: Integer
   1287   , schedulerRunnable   :: Seq TaskId
   1288   , schedulerTasks      :: Map TaskId TaskStatus
   1289   , schedulerWaiters    :: Map TaskId (Seq TaskId)
   1290   , schedulerSleepQueue :: Map UTCTime (Set TaskId)
   1291   , schedulerAsyncCompleted :: TVar (Map TaskId T)
   1292   , schedulerCompleted  :: Map TaskId (T, T)
   1293   , schedulerSockets    :: TVar SocketRegistry
   1294   , schedulerWorkers :: Workers
   1295   , schedulerFailure :: Maybe String
   1296   , schedulerYieldHook :: YieldStats -> IO ()
   1297   }
   1298 
   1299 instance Show Scheduler where
   1300   show s = "Scheduler { schedulerNextTaskId = " ++ show (schedulerNextTaskId s)
   1301     ++ ", schedulerRunnable = " ++ show (schedulerRunnable s)
   1302     ++ ", schedulerTasks = " ++ show (schedulerTasks s)
   1303     ++ ", schedulerWaiters = " ++ show (schedulerWaiters s)
   1304     ++ ", schedulerSleepQueue = " ++ show (schedulerSleepQueue s)
   1305     ++ ", schedulerAsyncCompleted = <tvar>"
   1306     ++ ", schedulerCompleted = " ++ show (schedulerCompleted s)
   1307     ++ ", schedulerSockets = <tvar>"
   1308     ++ ", schedulerFailure = " ++ show (schedulerFailure s)
   1309     ++ " }"
   1310 
   1311 -- Counts describe the scheduler at a yield without exposing retained trees.
   1312 data YieldStats = YieldStats
   1313   { yieldBindFrames :: !Int
   1314   , yieldLocalFrames :: !Int
   1315   , yieldTasks :: !Int
   1316   } deriving (Eq, Show)
   1317 
   1318 initialScheduler :: (YieldStats -> IO ()) -> TVar (Map TaskId T) -> TVar SocketRegistry -> Workers -> Machine -> Scheduler
   1319 initialScheduler yieldHook asyncVar sockVar workers mainMachine =
   1320   Scheduler
   1321     { schedulerNextTaskId = 1
   1322     , schedulerRunnable = Seq.singleton (TaskId 0)
   1323     , schedulerTasks = Map.singleton (TaskId 0) (Runnable mainMachine)
   1324     , schedulerWaiters = Map.empty
   1325     , schedulerSleepQueue = Map.empty
   1326     , schedulerAsyncCompleted = asyncVar
   1327     , schedulerCompleted = Map.empty
   1328     , schedulerSockets = sockVar
   1329     , schedulerWorkers = workers
   1330     , schedulerFailure = Nothing
   1331     , schedulerYieldHook = yieldHook
   1332     }
   1333 
   1334 runtimeOfStatus :: TaskStatus -> Maybe Runtime
   1335 runtimeOfStatus (Runnable machine) = Just (machineRuntime machine)
   1336 runtimeOfStatus (BlockedOn _ machine) = Just (machineRuntime machine)
   1337 runtimeOfStatus (Sleeping _ machine) = Just (machineRuntime machine)
   1338 runtimeOfStatus (AsyncWaiting machine) = Just (machineRuntime machine)
   1339 
   1340 wakeAwaiters :: TaskId -> T -> Scheduler -> Scheduler
   1341 wakeAwaiters targetId value scheduler =
   1342   case Map.lookup targetId (schedulerWaiters scheduler) of
   1343     Nothing -> scheduler
   1344     Just waiters ->
   1345       let (tasks', queue') = Fold.foldl' (wakeOne targetId value)
   1346                               (schedulerTasks scheduler, schedulerRunnable scheduler)
   1347                               waiters
   1348       in scheduler
   1349            { schedulerTasks = tasks'
   1350            , schedulerRunnable = queue'
   1351            , schedulerWaiters = Map.delete targetId (schedulerWaiters scheduler)
   1352            }
   1353   where
   1354     wakeOne _ _ (tasks, queue) waiterId =
   1355       case Map.lookup waiterId tasks of
   1356         Just (BlockedOn _ machine) ->
   1357           let machine' = machine { machineCurrent = pureAction value }
   1358           in (Map.insert waiterId (Runnable machine') tasks, queue |> waiterId)
   1359         _ -> (tasks, queue)
   1360 
   1361 wakeDueSleepers :: Scheduler -> IO Scheduler
   1362 wakeDueSleepers scheduler = do
   1363   now <- getCurrentTime
   1364   let go sq accTasks accQueue =
   1365         case Map.lookupMin sq of
   1366           Nothing -> (accTasks, accQueue, sq)
   1367           Just (t, taskSet)
   1368             | t <= now ->
   1369                 let tasks' = Fold.foldl' (\m tid ->
   1370                       case Map.lookup tid m of
   1371                         Just (Sleeping _ machine) -> Map.insert tid (Runnable machine) m
   1372                         _ -> m
   1373                       ) accTasks (Set.toList taskSet)
   1374                     queue' = Fold.foldl' (|>) accQueue (Set.toList taskSet)
   1375                 in go (Map.deleteMin sq) tasks' queue'
   1376             | otherwise -> (accTasks, accQueue, sq)
   1377       (tasks', queue', sq') = go (schedulerSleepQueue scheduler)
   1378                                    (schedulerTasks scheduler)
   1379                                    (schedulerRunnable scheduler)
   1380   pure scheduler
   1381     { schedulerTasks = tasks'
   1382     , schedulerRunnable = queue'
   1383     , schedulerSleepQueue = sq'
   1384     }
   1385 
   1386 nearestSleepTime :: Scheduler -> Maybe UTCTime
   1387 nearestSleepTime = fmap fst . Map.lookupMin . schedulerSleepQueue
   1388 
   1389 hasAsyncWaiters :: Scheduler -> Bool
   1390 hasAsyncWaiters = any isAsync . Map.elems . schedulerTasks
   1391   where
   1392     isAsync (AsyncWaiting _) = True
   1393     isAsync _ = False
   1394 
   1395 resumeCurrentWith :: TaskId -> T -> Machine -> Scheduler -> IO Scheduler
   1396 resumeCurrentWith taskId value machine scheduler =
   1397   let machine' = machine { machineCurrent = pureAction value }
   1398   in pure scheduler
   1399       { schedulerTasks = Map.insert taskId (Runnable machine') (schedulerTasks scheduler)
   1400       , schedulerRunnable = schedulerRunnable scheduler |> taskId
   1401       }
   1402 
   1403 wouldCycle :: TaskId -> TaskId -> Map TaskId TaskStatus -> Bool
   1404 wouldCycle target current tasks =
   1405   case Map.lookup target tasks of
   1406     Just (BlockedOn next _) ->
   1407       next == current || wouldCycle next current tasks
   1408     _ -> False
   1409 
   1410 handleStep :: TaskId -> Step -> Scheduler -> IO Scheduler
   1411 handleStep taskId (Continue machine) scheduler =
   1412   pure scheduler
   1413     { schedulerTasks = Map.insert taskId (Runnable machine) (schedulerTasks scheduler)
   1414     , schedulerRunnable = schedulerRunnable scheduler |> taskId
   1415     }
   1416 
   1417 handleStep taskId (Halt runtime value) scheduler =
   1418   let scheduler' = wakeAwaiters taskId value scheduler
   1419   in pure scheduler'
   1420        { schedulerTasks = Map.delete taskId (schedulerTasks scheduler')
   1421        , schedulerCompleted = Map.insert taskId (value, rtState runtime) (schedulerCompleted scheduler')
   1422        }
   1423 
   1424 handleStep parentId (ForkRequested childAction parentMachine) scheduler =
   1425   let childId = TaskId (schedulerNextTaskId scheduler)
   1426       handle = taskHandle childId
   1427 
   1428       parentMachine' =
   1429         parentMachine { machineCurrent = pureAction handle }
   1430 
   1431       childMachine =
   1432         Machine
   1433           { machineRuntime = machineRuntime parentMachine
   1434           , machineCurrent = childAction
   1435           , machineFrames = []
   1436           }
   1437 
   1438       tasks' =
   1439         Map.insert parentId (Runnable parentMachine') $
   1440         Map.insert childId (Runnable childMachine) $
   1441         schedulerTasks scheduler
   1442 
   1443       queue' =
   1444         schedulerRunnable scheduler |> parentId |> childId
   1445 
   1446   in pure scheduler
   1447       { schedulerNextTaskId = schedulerNextTaskId scheduler + 1
   1448       , schedulerTasks = tasks'
   1449       , schedulerRunnable = queue'
   1450       }
   1451 
   1452 handleStep currentId (AwaitRequested targetId machine) scheduler
   1453   | currentId == targetId =
   1454       resumeCurrentWith currentId selfAwaitResult machine scheduler
   1455 
   1456   | otherwise =
   1457       case Map.lookup targetId (schedulerTasks scheduler) of
   1458         Nothing ->
   1459           case Map.lookup targetId (schedulerCompleted scheduler) of
   1460             Just (value, _) -> resumeCurrentWith currentId value machine scheduler
   1461             Nothing -> resumeCurrentWith currentId invalidAsyncHandleResult machine scheduler
   1462 
   1463         Just (BlockedOn nextId _) ->
   1464           if wouldCycle targetId currentId (schedulerTasks scheduler)
   1465             then resumeCurrentWith currentId (errResult "cyclic await") machine scheduler
   1466             else block
   1467 
   1468         Just _ -> block
   1469   where
   1470     block = pure scheduler
   1471       { schedulerTasks = Map.insert currentId (BlockedOn targetId machine) (schedulerTasks scheduler)
   1472       , schedulerWaiters = Map.alter addWaiter targetId (schedulerWaiters scheduler)
   1473       }
   1474     addWaiter Nothing = Just (Seq.singleton currentId)
   1475     addWaiter (Just sq) = Just (sq |> currentId)
   1476 
   1477 handleStep taskId (YieldRequested machine) scheduler = do
   1478   let binds = length [() | BindFrame _ <- machineFrames machine]
   1479       locals = length [() | LocalFrame _ <- machineFrames machine]
   1480   schedulerYieldHook scheduler (YieldStats binds locals (Map.size (schedulerTasks scheduler)))
   1481   resumeCurrentWith taskId Leaf machine scheduler
   1482 
   1483 handleStep taskId (SleepRequested ms machine) scheduler = do
   1484   now <- getCurrentTime
   1485   let seconds = fromIntegral ms / 1000
   1486       wakeTime = addUTCTime seconds now
   1487       machine' = machine { machineCurrent = pureAction Leaf }
   1488   pure scheduler
   1489     { schedulerTasks = Map.insert taskId (Sleeping wakeTime machine') (schedulerTasks scheduler)
   1490     , schedulerSleepQueue = Map.alter (Just . maybe (Set.singleton taskId) (Set.insert taskId)) wakeTime (schedulerSleepQueue scheduler)
   1491     }
   1492 
   1493 handleStep _ (ExecutionFailed message) scheduler =
   1494   pure scheduler { schedulerFailure = Just message }
   1495 
   1496 handleStep taskId (AsyncAction ioAction machine) scheduler = do
   1497   startWorker (schedulerWorkers scheduler) $ do
   1498     result <- (Right <$> ioAction) `catch` \(e :: SomeException) ->
   1499       case fromException e :: Maybe SomeAsyncException of
   1500         Just _ -> throwIO e
   1501         Nothing -> pure (Left (show e))
   1502     atomically $ modifyTVar' (schedulerAsyncCompleted scheduler) (Map.insert taskId $
   1503       case result of
   1504         Right val -> val
   1505         Left msg  -> errResult msg)
   1506   pure scheduler
   1507     { schedulerTasks = Map.insert taskId (AsyncWaiting machine) (schedulerTasks scheduler)
   1508     }
   1509 
   1510 handleNoRunnable :: Scheduler -> IO Scheduler
   1511 handleNoRunnable scheduler =
   1512   case nearestSleepTime scheduler of
   1513     Just wakeTime -> do
   1514       now <- getCurrentTime
   1515       let micros = max 0 (floor (diffUTCTime wakeTime now * 1000000))
   1516       threadDelay micros
   1517       wakeDueSleepers scheduler
   1518 
   1519     Nothing ->
   1520       if hasAsyncWaiters scheduler
   1521         then do
   1522           -- Block efficiently until at least one async operation completes.
   1523           atomically $ do
   1524             m <- readTVar (schedulerAsyncCompleted scheduler)
   1525             if Map.null m then retry else return ()
   1526           pure scheduler
   1527         else
   1528           case Map.lookup (TaskId 0) (schedulerTasks scheduler) of
   1529             Just status ->
   1530               case runtimeOfStatus status of
   1531                 Just runtime ->
   1532                   let scheduler' = wakeAwaiters (TaskId 0) deadlockResult scheduler
   1533                   in pure scheduler'
   1534                        { schedulerTasks = Map.delete (TaskId 0) (schedulerTasks scheduler')
   1535                        , schedulerCompleted = Map.insert (TaskId 0) (deadlockResult, rtState runtime) (schedulerCompleted scheduler')
   1536                        }
   1537                 Nothing -> pure scheduler
   1538             Nothing -> pure scheduler
   1539 
   1540 schedulerStep :: Scheduler -> IO Scheduler
   1541 schedulerStep scheduler = do
   1542   -- Poll completed async operations and resume their tasks.
   1543   completed <- atomically $ do
   1544     m <- readTVar (schedulerAsyncCompleted scheduler)
   1545     writeTVar (schedulerAsyncCompleted scheduler) Map.empty
   1546     return m
   1547   schedulerAfterAsync <- Fold.foldlM
   1548     (\s (tid, val) ->
   1549       case Map.lookup tid (schedulerTasks s) of
   1550         Just (AsyncWaiting machine) -> resumeCurrentWith tid val machine s
   1551         _ -> pure s)
   1552     scheduler
   1553     (Map.toList completed)
   1554 
   1555   scheduler1 <- wakeDueSleepers schedulerAfterAsync
   1556   case Seq.viewl (schedulerRunnable scheduler1) of
   1557     EmptyL ->
   1558       handleNoRunnable scheduler1
   1559 
   1560     taskId :< restQueue ->
   1561       case Map.lookup taskId (schedulerTasks scheduler1) of
   1562         Just (Runnable machine) -> do
   1563           step <- stepMachine (schedulerSockets scheduler1) machine
   1564           handleStep taskId step scheduler1 { schedulerRunnable = restQueue }
   1565 
   1566         _ ->
   1567           pure scheduler1 { schedulerRunnable = restQueue }
   1568 
   1569 runScheduler :: Scheduler -> IO (Either String (T, T))
   1570 runScheduler scheduler =
   1571   case schedulerFailure scheduler of
   1572     Just message -> pure (Left message)
   1573     Nothing -> case Map.lookup (TaskId 0) (schedulerCompleted scheduler) of
   1574       Just (value, finalState) -> pure (Right (value, finalState))
   1575       Nothing -> schedulerStep scheduler >>= runScheduler
   1576 
   1577 -- ---------------------------------------------------------------------------
   1578 -- Public API
   1579 -- ---------------------------------------------------------------------------
   1580 
   1581 runIOWith :: IOPermissions -> T -> T -> T -> IO (Either String (T, T))
   1582 runIOWith = runIOWithYieldHook (pure ())
   1583 
   1584 -- Profiling observes a yield while its pending continuations remain live.
   1585 runIOWithYieldHook :: IO () -> IOPermissions -> T -> T -> T -> IO (Either String (T, T))
   1586 runIOWithYieldHook yieldHook = runIOWithYieldStatsHook (\_ -> yieldHook)
   1587 
   1588 runIOWithYieldStatsHook :: (YieldStats -> IO ()) -> IOPermissions -> T -> T -> T -> IO (Either String (T, T))
   1589 runIOWithYieldStatsHook yieldHook perms env initialState action =
   1590   case checkIOSentinel action of
   1591     Left err -> pure (Left err)
   1592     Right (_, action') -> bracket acquire cleanupRun $ \(asyncVar, sockVar, workers) -> do
   1593       let initialMachine = Machine
   1594             { machineRuntime = Runtime
   1595                 { rtPerms = perms
   1596                 , rtEnv = env
   1597                 , rtState = initialState
   1598                 }
   1599             , machineCurrent = action'
   1600             , machineFrames = []
   1601             }
   1602       runScheduler (initialScheduler yieldHook asyncVar sockVar workers initialMachine)
   1603 
   1604   where
   1605     acquire = do
   1606       asyncVar <- newTVarIO Map.empty
   1607       sockVar <- newTVarIO (SocketRegistry Map.empty 0)
   1608       workers <- newTVarIO Map.empty
   1609       pure (asyncVar, sockVar, workers)
   1610 
   1611 runIOWithEnv :: IOPermissions -> T -> T -> IO (Either String T)
   1612 runIOWithEnv perms env action = do
   1613   result <- runIOWith perms env Leaf action
   1614   pure (fmap fst result)
   1615 
   1616 runIO :: IOPermissions -> T -> IO (Either String T)
   1617 runIO perms action = do
   1618   result <- runIOWith perms Leaf Leaf action
   1619   pure (fmap fst result)
	tricu An interpreted language for exploring Tree Calculus
	Log \| Files \| Refs \| README \| LICENSE