(: Aiche Tee Tee Pee :)
Perhaps the first webserver in Tree Calculus? Sure, it's married to a Haskell IO runtime... but we're managing all of the actual webserver semantics in tricu! This includes a demo Arboricx application server that is capable of storing and serving bundles.
This commit is contained in:
215
src/IODriver.hs
215
src/IODriver.hs
@@ -8,15 +8,22 @@ module IODriver
|
||||
, runIOWith
|
||||
) where
|
||||
|
||||
import Research (T(..), apply, toString, toNumber, ofString, ofNumber, ofBytes, toBytes)
|
||||
import Research (T(..), apply, toString, toNumber, ofString, ofNumber, ofBytes, toBytes, ofList)
|
||||
import qualified Data.ByteString as BS
|
||||
import System.IO (putStr, getLine)
|
||||
import qualified System.IO as IO
|
||||
import Control.Exception (try, catch, IOException, SomeException)
|
||||
import System.IO.Error (isDoesNotExistError, isPermissionError, isAlreadyExistsError)
|
||||
import Data.List (isPrefixOf)
|
||||
import System.FilePath (normalise, isRelative, (</>), addTrailingPathSeparator, splitDirectories)
|
||||
import System.Directory (canonicalizePath, doesPathExist, getCurrentDirectory)
|
||||
import Data.List (isPrefixOf, isInfixOf)
|
||||
import System.FilePath (normalise, isRelative, (</>), addTrailingPathSeparator, splitDirectories, takeDirectory)
|
||||
import System.Directory (canonicalizePath, doesPathExist, getCurrentDirectory, listDirectory, createDirectory, renameFile, removeFile, doesDirectoryExist)
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
import Crypto.Hash (hash, SHA256, Digest)
|
||||
import Data.ByteArray (convert)
|
||||
import Data.ByteString.Base16 (encode)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import qualified Data.Text as T
|
||||
import Data.Char (toLower)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Sequence as Seq
|
||||
@@ -202,6 +209,13 @@ data Action
|
||||
| AReadFile T
|
||||
| AWriteFile T T
|
||||
| AWriteBytes T T
|
||||
| AListDirectory T
|
||||
| ARenameFile T T
|
||||
| ACreateDirectory T
|
||||
| ADeleteFile T
|
||||
| AFileExists T
|
||||
| ASha256Hex T
|
||||
| ACurrentTime
|
||||
| AAsk
|
||||
| ALocal T T
|
||||
| AGet
|
||||
@@ -239,6 +253,17 @@ tagReadFile = 20
|
||||
tagWriteFile = 21
|
||||
tagWriteBytes = 22
|
||||
|
||||
tagListDirectory, tagRenameFile, tagCreateDirectory, tagDeleteFile, tagFileExists :: Integer
|
||||
tagListDirectory = 23
|
||||
tagRenameFile = 24
|
||||
tagCreateDirectory = 25
|
||||
tagDeleteFile = 26
|
||||
tagFileExists = 27
|
||||
|
||||
tagSha256Hex, tagCurrentTime :: Integer
|
||||
tagSha256Hex = 28
|
||||
tagCurrentTime = 29
|
||||
|
||||
tagAsk, tagLocal :: Integer
|
||||
tagAsk = 30
|
||||
tagLocal = 31
|
||||
@@ -319,6 +344,29 @@ decodeAction tree =
|
||||
Fork path contents -> Right (AWriteBytes path contents)
|
||||
_ -> Left "Invalid WriteBytes: expected pair path contents"
|
||||
|
||||
Right n | n == tagListDirectory ->
|
||||
Right (AListDirectory payload)
|
||||
|
||||
Right n | n == tagRenameFile ->
|
||||
case payload of
|
||||
Fork old new -> Right (ARenameFile old new)
|
||||
_ -> Left "Invalid RenameFile: expected pair oldPath newPath"
|
||||
|
||||
Right n | n == tagCreateDirectory ->
|
||||
Right (ACreateDirectory payload)
|
||||
|
||||
Right n | n == tagDeleteFile ->
|
||||
Right (ADeleteFile payload)
|
||||
|
||||
Right n | n == tagFileExists ->
|
||||
Right (AFileExists payload)
|
||||
|
||||
Right n | n == tagSha256Hex ->
|
||||
Right (ASha256Hex payload)
|
||||
|
||||
Right n | n == tagCurrentTime ->
|
||||
Right ACurrentTime
|
||||
|
||||
Right n | n == tagAsk ->
|
||||
Right AAsk
|
||||
|
||||
@@ -481,6 +529,64 @@ stepMachine sockVar machine =
|
||||
Left _ -> finishValue machine (errResult "invalid bytes")
|
||||
Left _ -> finishValue machine (errResult "invalid string")
|
||||
|
||||
AListDirectory pathTree ->
|
||||
case decodeString pathTree "ListDirectory" of
|
||||
Right p -> do
|
||||
mDeny <- checkReadPerm p
|
||||
case mDeny of
|
||||
Just denied -> finishValue machine denied
|
||||
Nothing -> pure (AsyncAction (tryListDirectory p) machine)
|
||||
Left _ -> finishValue machine (errResult "invalid string")
|
||||
|
||||
ARenameFile oldTree newTree ->
|
||||
case decodeString oldTree "RenameFile" of
|
||||
Right old ->
|
||||
case decodeString newTree "RenameFile" of
|
||||
Right new -> do
|
||||
mDenyOld <- checkWritePerm old
|
||||
mDenyNew <- checkWritePerm new
|
||||
case (mDenyOld, mDenyNew) of
|
||||
(Just denied, _) -> finishValue machine denied
|
||||
(_, Just denied) -> finishValue machine denied
|
||||
(Nothing, Nothing) -> pure (AsyncAction (tryRenameFile old new) machine)
|
||||
Left _ -> finishValue machine (errResult "invalid string")
|
||||
Left _ -> finishValue machine (errResult "invalid string")
|
||||
|
||||
ACreateDirectory pathTree ->
|
||||
case decodeString pathTree "CreateDirectory" of
|
||||
Right p -> do
|
||||
mDeny <- checkWritePerm p
|
||||
case mDeny of
|
||||
Just denied -> finishValue machine denied
|
||||
Nothing -> pure (AsyncAction (tryCreateDirectory p) machine)
|
||||
Left _ -> finishValue machine (errResult "invalid string")
|
||||
|
||||
ADeleteFile pathTree ->
|
||||
case decodeString pathTree "DeleteFile" of
|
||||
Right p -> do
|
||||
mDeny <- checkWritePerm p
|
||||
case mDeny of
|
||||
Just denied -> finishValue machine denied
|
||||
Nothing -> pure (AsyncAction (tryDeleteFile p) machine)
|
||||
Left _ -> finishValue machine (errResult "invalid string")
|
||||
|
||||
AFileExists pathTree ->
|
||||
case decodeString pathTree "FileExists" of
|
||||
Right p -> do
|
||||
mDeny <- checkReadPerm p
|
||||
case mDeny of
|
||||
Just denied -> finishValue machine denied
|
||||
Nothing -> pure (AsyncAction (tryFileExists p) machine)
|
||||
Left _ -> finishValue machine (errResult "invalid string")
|
||||
|
||||
ASha256Hex bytesTree ->
|
||||
case decodeBytes bytesTree "Sha256Hex" of
|
||||
Right bs -> pure (AsyncAction (pure $ trySha256Hex bs) machine)
|
||||
Left _ -> finishValue machine (errResult "invalid bytes")
|
||||
|
||||
ACurrentTime ->
|
||||
pure (AsyncAction (tryCurrentTime) machine)
|
||||
|
||||
AAsk ->
|
||||
finishValue machine (rtEnv (machineRuntime machine))
|
||||
|
||||
@@ -818,6 +924,107 @@ stepMachine sockVar machine =
|
||||
Right () -> return $ okResult Leaf
|
||||
Left e -> return $ errResult (ioErrorString e)
|
||||
|
||||
tryListDirectory path = do
|
||||
exists <- doesPathExist path
|
||||
if not exists
|
||||
then return $ errResult "does not exist"
|
||||
else do
|
||||
isDir <- doesDirectoryExist path
|
||||
if not isDir
|
||||
then return $ errResult "not a directory"
|
||||
else do
|
||||
result <- try (listDirectory path) :: IO (Either IOException [FilePath])
|
||||
case result of
|
||||
Right entries ->
|
||||
let filtered = filter (`notElem` [".", ".."]) entries
|
||||
in return $ okResult (ofList (map ofString filtered))
|
||||
Left e -> return $ errResult (ioErrorString e)
|
||||
|
||||
tryRenameFile old new = do
|
||||
oldExists <- doesPathExist old
|
||||
if not oldExists
|
||||
then return $ errResult "does not exist"
|
||||
else do
|
||||
result <- try (renameFile old new) :: IO (Either IOException ())
|
||||
case result of
|
||||
Right () -> return $ okResult Leaf
|
||||
Left e
|
||||
| isDoesNotExistError e -> return $ errResult "does not exist"
|
||||
| isPermissionError e -> return $ errResult "permission denied"
|
||||
| "cross-device" `isInfixOf` map toLower (show e) || "exdev" `isInfixOf` map toLower (show e) ->
|
||||
return $ errResult "cross-device rename"
|
||||
| otherwise -> return $ errResult (ioErrorString e)
|
||||
|
||||
tryCreateDirectory path = do
|
||||
exists <- doesPathExist path
|
||||
if exists
|
||||
then do
|
||||
isDir <- doesDirectoryExist path
|
||||
if isDir
|
||||
then return $ okResult Leaf
|
||||
else return $ errResult "already exists"
|
||||
else do
|
||||
let parent = takeDirectory path
|
||||
parentExists <- doesPathExist parent
|
||||
if parentExists
|
||||
then do
|
||||
parentIsDir <- doesDirectoryExist parent
|
||||
if parentIsDir
|
||||
then do
|
||||
result <- try (createDirectory path) :: IO (Either IOException ())
|
||||
case result of
|
||||
Right () -> return $ okResult Leaf
|
||||
Left e
|
||||
| isDoesNotExistError e -> return $ errResult "does not exist"
|
||||
| isPermissionError e -> return $ errResult "permission denied"
|
||||
| isAlreadyExistsError e -> return $ errResult "already exists"
|
||||
| otherwise -> return $ errResult (ioErrorString e)
|
||||
else return $ errResult "not a directory"
|
||||
else do
|
||||
result <- try (createDirectory path) :: IO (Either IOException ())
|
||||
case result of
|
||||
Right () -> return $ okResult Leaf
|
||||
Left e
|
||||
| isDoesNotExistError e -> return $ errResult "does not exist"
|
||||
| isPermissionError e -> return $ errResult "permission denied"
|
||||
| isAlreadyExistsError e -> return $ errResult "already exists"
|
||||
| otherwise -> return $ errResult (ioErrorString e)
|
||||
|
||||
tryDeleteFile path = do
|
||||
exists <- doesPathExist path
|
||||
if not exists
|
||||
then return $ okResult Leaf
|
||||
else do
|
||||
isDir <- doesDirectoryExist path
|
||||
if isDir
|
||||
then return $ errResult "is a directory"
|
||||
else do
|
||||
result <- try (removeFile path) :: IO (Either IOException ())
|
||||
case result of
|
||||
Right () -> return $ okResult Leaf
|
||||
Left e
|
||||
| isDoesNotExistError e -> return $ okResult Leaf
|
||||
| isPermissionError e -> return $ errResult "permission denied"
|
||||
| otherwise -> return $ errResult (ioErrorString e)
|
||||
|
||||
tryFileExists path = do
|
||||
result <- try (doesPathExist path) :: IO (Either IOException Bool)
|
||||
case result of
|
||||
Right exists -> return $ okResult (if exists then Stem Leaf else Leaf)
|
||||
Left e
|
||||
| isPermissionError e -> return $ errResult "permission denied"
|
||||
| otherwise -> return $ errResult (ioErrorString e)
|
||||
|
||||
trySha256Hex bs =
|
||||
let digest = hash bs :: Digest SHA256
|
||||
hexBs = encode (convert digest)
|
||||
hexStr = T.unpack (decodeUtf8 hexBs)
|
||||
in okResult (ofString hexStr)
|
||||
|
||||
tryCurrentTime = do
|
||||
now <- getPOSIXTime
|
||||
return $ okResult (ofNumber (floor now))
|
||||
|
||||
decodeString t ctx =
|
||||
case toString t of
|
||||
Right s -> Right s
|
||||
|
||||
Reference in New Issue
Block a user