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

src/Main.hs

@@ -5,6 +5,7 @@ import System.Exit (die)
 import Server (runServerWithPath)
 import Eval (evalTricu, evalTricuWithStore, mainResult, result)
 import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
+import IODriver (IOPermissions(..), checkIOSentinel, runIO)
 import Parser (parseTricu)
 import REPL (repl)
 import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
@@ -32,10 +33,13 @@ import System.Environment (lookupEnv)
 data TricuArgs
   = Repl
   | Eval
-      { evalFiles   :: [FilePath]
-      , evalFormat  :: EvaluatedForm
-      , evalOutput  :: FilePath
-      , evalDb      :: Maybe FilePath
+      { evalFiles      :: [FilePath]
+      , evalFormat     :: EvaluatedForm
+      , evalOutput     :: FilePath
+      , evalDb         :: Maybe FilePath
+      , evalIo         :: Bool
+      , evalAllowRead  :: [FilePath]
+      , evalAllowWrite :: [FilePath]
       }
   | ArboricxCompile
       { compileInput   :: FilePath
@@ -98,6 +102,20 @@ evalParser = Eval
      <> metavar "PATH"
      <> help "Content store database path"
       ))
+  <*> switch
+      ( long "io"
+     <> help "Interpret the result as an IO action tree and execute it"
+      )
+  <*> many (option str
+      ( long "allow-read"
+     <> metavar "PATH"
+     <> help "Allow reading from PATH prefix (repeatable)"
+      ))
+  <*> many (option str
+      ( long "allow-write"
+     <> metavar "PATH"
+     <> help "Allow writing to PATH prefix (repeatable)"
+      ))
 
 compileParser :: Parser TricuArgs
 compileParser = ArboricxCompile
@@ -273,10 +291,18 @@ runEval opts = do
     _  -> do
       finalEnv <- foldM (evaluateFileWithStore mconn) Map.empty files
       return $ mainResult finalEnv
+  finalT <- if evalIo opts
+    then case checkIOSentinel resultT of
+      Right (1, action) -> do
+        let perms = IOPermissions (evalAllowRead opts) (evalAllowWrite opts)
+        runIO perms action
+      Right (v, _) -> die $ "Unsupported IO ABI version: " ++ show v
+      Left err -> die $ "IO mode requested but " ++ err
+    else return resultT
   case mconn of
     Just conn -> close conn
     Nothing   -> return ()
-  writeOutput out (formatT form resultT)
+  writeOutput out (formatT form finalT)
 
 runCompile :: TricuArgs -> IO ()
 runCompile opts = do