feat(haskell): Interaction Tree IO

oops, now we have purely modelled IO 🤷

src/IODriver.hs

@@ -0,0 +1,120 @@
+module IODriver
+  ( IOPermissions(..)
+  , defaultPerms
+  , checkIOSentinel
+  , runIO
+  ) where
+
+import Research (T(..), apply, toString, toNumber, ofString, ofNumber)
+import System.IO (putStr, getLine)
+import qualified System.IO as IO
+import Control.Exception (try, IOException)
+import Control.Monad (unless)
+import System.Exit (die)
+import System.IO.Error (isDoesNotExistError, isPermissionError, isAlreadyExistsError)
+import Data.List (isPrefixOf)
+
+data IOPermissions = IOPermissions
+  { allowRead  :: [FilePath]
+  , allowWrite :: [FilePath]
+  }
+
+defaultPerms :: IOPermissions
+defaultPerms = IOPermissions [] []
+
+checkIOSentinel :: T -> Either String (Integer, T)
+checkIOSentinel tree =
+  case tree of
+    Fork sentinel (Fork version action) -> do
+      s <- toString sentinel
+      case s of
+        "tricuIO" -> do
+          v <- toNumber version
+          return (v, action)
+        _ -> Left "sentinel mismatch (expected \"tricuIO\")"
+    _ -> Left "root is not an IO sentinel pair"
+
+runIO :: IOPermissions -> T -> IO T
+runIO perms actionTree = go actionTree
+  where
+    go tree =
+      case tree of
+        Fork tag payload -> do
+          tagNum <- case toNumber tag of
+            Right n  -> return n
+            Left err -> die $ "Invalid IO action tag: " ++ err
+          dispatch tagNum payload
+        _ -> die $ "Invalid IO action tree: expected pair tag payload, got " ++ show tree
+
+    dispatch tagNum payload = case tagNum of
+      0 -> return payload  -- Pure
+
+      1 -> case payload of
+        Fork str k -> do
+          s <- decodeString str "PutStr"
+          putStr s
+          go (apply k Leaf)
+        _ -> die "Invalid PutStr payload: expected pair string continuation"
+
+      2 -> do
+        line <- getLine
+        go (apply payload (ofString line))
+
+      3 -> case payload of
+        Fork path k -> do
+          p <- decodeString path "ReadFile"
+          checkReadPerm p
+          content <- tryReadFile p
+          go (apply k content)
+        _ -> die "Invalid ReadFile payload: expected pair path continuation"
+
+      4 -> case payload of
+        Fork path rest -> case rest of
+          Fork contents k -> do
+            p <- decodeString path "WriteFile"
+            c <- decodeString contents "WriteFile"
+            checkWritePerm p
+            res <- tryWriteFile p c
+            go (apply k res)
+          _ -> die "Invalid WriteFile payload: expected pair contents continuation"
+        _ -> die "Invalid WriteFile payload: expected pair path (pair contents continuation)"
+
+      _ -> die $ "Unknown IO action tag: " ++ show tagNum
+
+    decodeString t ctx =
+      case toString t of
+        Right s  -> return s
+        Left err -> die $ "Invalid " ++ ctx ++ " string: " ++ err
+
+    checkReadPerm p =
+      unless (pathAllowed p (allowRead perms)) $
+        die $ "Permission denied: read not allowed for " ++ p
+
+    checkWritePerm p =
+      unless (pathAllowed p (allowWrite perms)) $
+        die $ "Permission denied: write not allowed for " ++ p
+
+    pathAllowed _ [] = True  -- No restrictions
+    pathAllowed p prefixes = any (\prefix -> prefix `isPrefixOf` p) prefixes
+
+    tryReadFile path = do
+      result <- try (IO.readFile path) :: IO (Either IOException String)
+      case result of
+        Right content -> return $ okResult (ofString content)
+        Left e        -> return $ errResult (ioErrorCode e)
+
+    tryWriteFile path contents = do
+      result <- try (IO.writeFile path contents) :: IO (Either IOException ())
+      case result of
+        Right () -> return $ okResult Leaf
+        Left e   -> return $ errResult (ioErrorCode e)
+
+    okResult val  = Fork (Stem Leaf) (Fork val Leaf)          -- pair true (pair val t)
+    errResult code = Fork Leaf (Fork (ofNumber code) Leaf)    -- pair false (pair code t)
+
+    ioErrorCode :: IOException -> Integer
+    ioErrorCode e
+      | isDoesNotExistError  e = 1
+      | isPermissionError    e = 2
+      | isAlreadyExistsError e = 3
+      | otherwise              = 4