diff --git a/lib/base.tri b/lib/base.tri index a6e7641..7eadaaf 100644 --- a/lib/base.tri +++ b/lib/base.tri @@ -72,3 +72,18 @@ succ = y (self : (t (t t)) (_ tail : t t (self tail)) t)) + +ok = value rest : pair true (pair value rest) +err = code rest : pair false (pair code rest) + +matchResult = (errCase okCase result : + matchPair + (tag payload : + matchPair + (value rest : + matchBool + (okCase value rest) + (errCase value rest) + tag) + payload) + result) diff --git a/lib/binary.tri b/lib/binary.tri index b7f00e0..5c84117 100644 --- a/lib/binary.tri +++ b/lib/binary.tri @@ -6,21 +6,6 @@ errUnexpectedEof = 1 errUnexpectedBytes = 2 errUnexpectedByte = 3 -ok = value rest : pair true (pair value rest) -err = code rest : pair false (pair code rest) - -matchResult = (errCase okCase result : - matchPair - (tag payload : - matchPair - (value rest : - matchBool - (okCase value rest) - (errCase value rest) - tag) - payload) - result) - readU8 = (bytes : matchList (err errUnexpectedEof t) (h r : ok h r) diff --git a/lib/conversions.tri b/lib/conversions.tri new file mode 100644 index 0000000..f9de661 --- /dev/null +++ b/lib/conversions.tri @@ -0,0 +1,39 @@ +!import "base.tri" !Local +!import "list.tri" !Local + +pred = y (self : triage + 0 + (_ : 0) + (bit rest : + matchBool + -- odd: 2n + 1 -> 2n + (matchBool + 0 + (pair 0 rest) + (equal? rest 0)) + -- even: 2n -> 2n - 1 + (matchBool + 0 + (pair 1 (self rest)) + (equal? rest 0)) + bit)) + +incDecRev = y (self : matchList + "1" + (digit rest : + matchBool + (pair 48 (self rest)) + (pair (succ digit) rest) + (equal? digit 57))) + +showNumberRev_ = y (self n acc : + matchBool + acc + (self (pred n) (incDecRev acc)) + (equal? n 0)) + +showNumber = (n : + matchBool + "0" + (reverse (showNumberRev_ n t)) + (equal? n 0)) diff --git a/lib/io.tri b/lib/io.tri new file mode 100644 index 0000000..a28310e --- /dev/null +++ b/lib/io.tri @@ -0,0 +1,82 @@ +!import "base.tri" !Local +!import "list.tri" !Local +!import "conversions.tri" !Local + +-- IO constructors for host-interpreted interaction trees. +-- See docs/io-in-tricu.md for the full protocol. + +version = 1 + +io = action : pair "tricuIO" (pair version action) +pure = x : pair 0 x +putStr = s k : pair 1 (pair s k) +getLine = k : pair 2 k +readFile = p k : pair 3 (pair p k) +writeFile = p c k : pair 4 (pair p (pair c k)) + +-- --------------------------------------------------------------------------- +-- CPS sequencing helpers +-- --------------------------------------------------------------------------- + +-- Print a string and finish successfully. +print = s : putStr s (_ : pure t) + +-- Print a string plus newline and finish successfully. +printLn = s : putStr (append s "\n") (_ : pure t) + +-- CPS print with newline. +putStrLn = s k : putStr (append s "\n") k + +-- Sequence after putStr, ignoring Unit. +afterPutStr = s next : putStr s (_ : next) + +-- Sequence after putStrLn, ignoring Unit. +afterPutStrLn = s next : putStr (append s "\n") (_ : next) + +-- --------------------------------------------------------------------------- +-- Result-aware file helpers +-- --------------------------------------------------------------------------- + +-- Read a file, forcing the caller to handle both success and error. +onReadFile = (path errCase okCase : + readFile path (result : + matchResult errCase okCase result)) + +-- Write a file, forcing the caller to handle both success and error. +onWriteFile = (path contents errCase okCase : + writeFile path contents (result : + matchResult errCase okCase result)) + +-- --------------------------------------------------------------------------- +-- Convenience helpers for the common cases +-- --------------------------------------------------------------------------- + +-- Read a file; on error print a message and finish. +readFileOrPrintError = (path okCase : + onReadFile path + (err rest : + putStrLn "Read failed" (_ : + pure t)) + okCase) + +-- Write a file; on error print a message and finish. +writeFileOrPrintError = (path contents okCase : + onWriteFile path contents + (err rest : + putStrLn "Write failed" (_ : + pure t)) + okCase) + +-- Copy src to dst, then continue with k on success. +copyFile = (src dst k : + onReadFile src + (err rest : + putStrLn "Read failed" (_ : + pure t)) + (contents rest : + onWriteFile dst contents + (err rest : + putStrLn "Write failed" (_ : + pure t)) + (ok rest : + k t))) diff --git a/src/IODriver.hs b/src/IODriver.hs new file mode 100644 index 0000000..3695f1f --- /dev/null +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index deeb768..1567604 100644 --- a/src/Main.hs +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index 8bf5cfc..29dc5c6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -8,10 +8,12 @@ import REPL import Research import Wire import ContentStore +import IODriver import Control.Exception (evaluate, try, SomeException) import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) +import System.IO.Temp (withSystemTempDirectory) import Data.Bits (xor) import Data.Char (digitToInt) import Data.List (isInfixOf) @@ -51,6 +53,7 @@ tests = testGroup "Tricu Tests" , wireTests , tricuReaderTests , byteListUtilities + , ioDriverTests ] lexer :: TestTree @@ -1252,3 +1255,58 @@ byteListUtilities = testGroup "Byte List Utility Tests" let env = evalTricu library (parseTricu input) result env @?= falseT ] + +-- -------------------------------------------------------------------------- +-- IO driver tests +-- -------------------------------------------------------------------------- + +ioDriverTests :: TestTree +ioDriverTests = testGroup "IO driver tests" + [ testCase "readFile through onReadFile returns file contents" $ + withSystemTempDirectory "tricu-io-read" $ \dir -> do + let sourcePath = dir ++ "/input.txt" + writeFile sourcePath "abc123" + final <- runIOSource $ + unlines + [ "main = io (onReadFile \"" ++ sourcePath ++ "\"" + , " (err rest : pure \"read failed\")" + , " (contents rest : pure contents))" + ] + final @?= ofString "abc123" + + , testCase "readFile error path returns explicit error branch" $ + withSystemTempDirectory "tricu-io-read-missing" $ \dir -> do + let sourcePath = dir ++ "/missing.txt" + final <- runIOSource $ + unlines + [ "main = io (onReadFile \"" ++ sourcePath ++ "\"" + , " (err rest : pure \"read failed\")" + , " (contents rest : pure contents))" + ] + final @?= ofString "read failed" + + , testCase "chains multiple readFile actions through Result-aware helper" $ + withSystemTempDirectory "tricu-io-chain" $ \dir -> do + let firstPath = dir ++ "/first.txt" + secondPath = dir ++ "/second.txt" + writeFile firstPath "abc" + writeFile secondPath "def" + final <- runIOSource $ + unlines + [ "main = io (onReadFile \"" ++ firstPath ++ "\"" + , " (err rest : pure \"first read failed\")" + , " (first rest : onReadFile \"" ++ secondPath ++ "\"" + , " (err rest : pure \"second read failed\")" + , " (second rest : pure (append first second))))" + ] + final @?= ofString "abcdef" + ] + +runIOSource :: String -> IO T +runIOSource source = do + ioEnv <- evaluateFile "./lib/io.tri" + env <- evalTricuWithStore Nothing ioEnv (parseTricu source) + case checkIOSentinel (mainResult env) of + Right (1, action) -> runIO defaultPerms action + Right (v, _) -> assertFailure ("Unsupported IO ABI version: " ++ show v) + Left err -> assertFailure ("Expected IO sentinel: " ++ err) diff --git a/tricu.cabal b/tricu.cabal index 6489386..cff4def 100644 --- a/tricu.cabal +++ b/tricu.cabal @@ -68,6 +68,7 @@ executable tricu ContentStore Eval FileEval + IODriver Lexer Parser Paths_tricu @@ -109,9 +110,11 @@ test-suite tricu-tests , stm , tasty , tasty-hunit + , temporary , text , time , transformers + , unix , vector , wai , warp @@ -121,6 +124,7 @@ test-suite tricu-tests ContentStore Eval FileEval + IODriver Lexer Parser Paths_tricu