James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

(: Aiche Tee Tee Pee :)

Browse Source 
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:
James Eversole
2026-05-20 15:52:03 -05:00
parent 7ae3fc33f4
commit bf30d5945e
27 changed files with 1852 additions and 400 deletions
Download Patch File Download Diff File Expand all files Collapse all files

215
src/IODriver.hs
View File

@@ -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

42
src/Main.hs
View File

@@ -2,7 +2,6 @@ module Main where
import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, loadTree, resolveExportTarget)
import System.Exit (die)
import Server (runServerWithPath)
import Eval (evalTricu, evalTricuWithStore, mainResult, result)
import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
import IODriver (IOPermissions(..), runIO)
@@ -61,11 +60,6 @@ data TricuArgs
, exportDb :: Maybe FilePath
, dag :: Bool
}
| ArboricxServe
{ serveHost :: String
, servePort :: Int
, serveDb :: Maybe FilePath
}
deriving (Show)
-- ---------------------------------------------------------------------------
@@ -209,28 +203,6 @@ exportParser = ArboricxExport
<> help "Export as a topologically-sorted DAG node table instead of a bundle"
)
serveParser :: Parser TricuArgs
serveParser = ArboricxServe
<$> option str
( long "host"
<> metavar "HOST"
<> value "127.0.0.1"
<> help "Host to bind the server to"
)
<*> option auto
( long "port"
<> short 'p'
<> metavar "PORT"
<> value 8787
<> help "HTTP port to listen on"
)
<*> optional (option str
( long "db"
<> short 'd'
<> metavar "PATH"
<> help "Content store database path"
))
versionStr :: String
versionStr = "tricu " ++ showVersion version
@@ -253,8 +225,6 @@ arboricxParser = subparser $ mconcat
(progDesc "Import an Arboricx bundle into the content store"))
, command "export" (info (exportParser <**> helper)
(progDesc "Export one or more terms from the content store"))
, command "serve" (info (serveParser <**> helper)
(progDesc "Start a read-only HTTP server for Arboricx bundles"))
]
-- ---------------------------------------------------------------------------
@@ -274,7 +244,7 @@ main = do
ArboricxCompile {} -> runCompile args
ArboricxImport {} -> runImport args
ArboricxExport {} -> runExport args
ArboricxServe {} -> runServe args
-- ---------------------------------------------------------------------------
-- Command runners
@@ -395,16 +365,6 @@ runExportDag opts = do
[] -> die "tricu arboricx export --dag: exactly one --target is required"
_ -> die "tricu arboricx export --dag: exactly one --target is required"
runServe :: TricuArgs -> IO ()
runServe opts = do
let hostStr = serveHost opts
portNum = servePort opts
putStrLn $ "Starting Arboricx bundle server on " ++ hostStr ++ ":" ++ show portNum
putStrLn $ " GET /bundle/hash/:hash -- primary endpoint"
putStrLn $ " GET /bundle/name/:name -- convenience endpoint"
putStrLn $ " Content-Type: application/vnd.arboricx.bundle"
runServerWithPath (serveDb opts) hostStr portNum
-- ---------------------------------------------------------------------------
-- Helpers
-- ---------------------------------------------------------------------------

210
src/Server.hs
View File

@@ -1,210 +0,0 @@
module Server
( runServer
, runServerWithPath
) where
import ContentStore (initContentStore, initContentStoreWithPath, nameToTerm, hashToTerm, listStoredTerms,
parseNameList, StoredTerm(..), termHash, loadTree)
import Database.SQLite.Simple (Connection, close)
import Wire (buildBundle, encodeBundle)
import Control.Monad (when, void)
import Data.Maybe (catMaybes)
import Network.HTTP.Types (Header, Status, status200, status400, status404, status405, hContentType)
import Network.Wai
import Network.Wai.Handler.Warp (defaultSettings, runSettings, setHost, setPort)
import Data.String (fromString)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Char (isHexDigit, toLower)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 (unpack)
import Data.ByteString.Lazy (fromStrict)
import qualified Data.Text as T
-- | Start an HTTP server that serves Arboricx bundles from the
-- local content store.
runServer :: String -> Int -> IO ()
runServer = runServerWithPath Nothing
-- | Start an HTTP server with an explicit database path.
runServerWithPath :: Maybe FilePath -> String -> Int -> IO ()
runServerWithPath mDbPath hostStr port =
runSettings settings (app mkConn)
where
mkConn = initContentStoreWithPath mDbPath
settings = setPort port $ setHost (fromString hostStr) defaultSettings
-- | WAI application backed by the content store.
app :: IO Connection -> Application
app mkConn request respond = case (requestMethod request, pathInfo request) of
("GET", ["health"]) ->
respond $ healthResponse
("GET", ["bundle", "roots"]) ->
rootsHandler mkConn request respond
("GET", ["bundle", "name", nameText]) -> do
body <- nameHandler mkConn nameText
respond body
("GET", ["bundle", "hash", hashText]) -> do
body <- hashHandler mkConn hashText
respond body
("GET", ["terms"]) -> do
body <- termsResponse mkConn
respond body
("POST", _) ->
respond $ responseLBS status405 [] "Method not allowed"
("PUT", _) ->
respond $ responseLBS status405 [] "Method not allowed"
("DELETE", _) ->
respond $ responseLBS status405 [] "Method not allowed"
_ ->
respond $ responseLBS status404 [] "not found"
healthResponse :: Response
healthResponse = responseLBS status200 [] "ok"
-- | GET /bundle/roots?n=root&n=helper&h=abc123...
rootsHandler :: IO Connection -> Request -> (Response -> IO a) -> IO a
rootsHandler mkConn request respond = do
conn <- mkConn
let qs = queryString request
nParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "n"]
hParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "h"]
-- Resolve 'n' params to (name, hash) pairs
nResults <- mapM (\nVal -> do
stored <- nameToTerm conn (decodeUtf8 nVal)
case stored of
Nothing -> return Nothing
Just t -> return $ Just (decodeUtf8 nVal, termHash t)) nParams
let namedHashesFromN = catMaybes nResults
-- Validate 'h' params and build (name, hash) pairs
namedHashesFromH <- mapM (\hVal -> do
let raw = T.pack (dropWhile (=='#') (T.unpack (decodeUtf8 hVal)))
if T.all isHexDigit raw && T.length raw >= 16
then do
stored <- hashToTerm conn raw
let names = maybe "root" firstOrRoot (termNames <$> stored)
return $ Just (names, raw)
else return Nothing)
hParams
let allNamedHashes = namedHashesFromN ++ catMaybes namedHashesFromH
-- Require at least one root
when (null allNamedHashes) $ do
let resp = responseLBS status400 [] "400 Bad Request: at least one n= or h= parameter required"
close conn
void $ respond resp
-- Build and return the bundle
bundleData <- buildAndEncodeBundle conn allNamedHashes
let firstHash = snd (head allNamedHashes)
cd = T.pack "attachment; filename=roots.bundle"
close conn
respond $ responseLBS status200
(bundleHeaders firstHash cd)
(fromStrict bundleData)
-- | GET /bundle/name/:name
nameHandler :: IO Connection -> Text -> IO Response
nameHandler mkConn nameText = do
conn <- mkConn
stored <- nameToTerm conn nameText
case stored of
Nothing -> do
close conn
return $ textResponse status404 ("not found: " <> nameText)
Just term' -> do
let th = termHash term'
namedHashes = [(firstOrRoot (termNames term'), th)]
bundleData <- buildAndEncodeBundle conn namedHashes
let cd = T.pack $ "attachment; filename=" ++ safeFileName (T.unpack nameText) ++ ".bundle"
close conn
return $ responseLBS status200 (bundleHeaders th cd) (fromStrict bundleData)
-- | GET /bundle/hash/:hash
hashHandler :: IO Connection -> Text -> IO Response
hashHandler mkConn hashText =
let raw = T.pack (dropWhile (== '#') (T.unpack hashText))
in if not (T.all isHexDigit raw) || T.length raw < 16
then return $ responseLBS status400 [] "400 Bad Request: invalid hash"
else do
conn <- mkConn
stored <- hashToTerm conn raw
case stored of
Nothing -> do
close conn
return $ textResponse status404 ("not found: " <> hashText)
Just term' -> do
let th = termHash term'
namedHashes' = [(firstOrRoot (termNames term'), th)]
bundleData <- buildAndEncodeBundle conn namedHashes'
close conn
return $ responseLBS status200
(bundleHeaders th "attachment; filename=hash.bundle")
(fromStrict bundleData)
-- | Helper: load terms by hash and build an indexed bundle.
buildAndEncodeBundle :: Connection -> [(Text, Text)] -> IO ByteString
buildAndEncodeBundle conn namedHashes = do
terms <- mapM (\(_, h) -> do
maybeTree <- loadTree conn h
case maybeTree of
Nothing -> error $ "Server: hash not found in store: " ++ T.unpack h
Just tree -> return tree) namedHashes
let namedTerms = zip (map fst namedHashes) terms
bundle = buildBundle namedTerms
return $ encodeBundle bundle
-- | GET /terms
termsResponse :: IO Connection -> IO Response
termsResponse mkConn = do
conn <- mkConn
terms <- listStoredTerms conn
close conn
let lines' = [ names <> " " <> hash <> " " <> T.pack (show created)
| term <- terms
, let names = termNames term
, let hash = termHash term
, let created = termCreatedAt term ]
return $ responseLBS status200
[ (hContentType, encodeUtf8 "text/plain; charset=utf-8")
]
(fromStrict $ encodeUtf8 $ T.unlines lines')
textResponse :: Status -> Text -> Response
textResponse status body =
responseLBS status
[ (hContentType, encodeUtf8 "text/plain; charset=utf-8") ]
(fromStrict $ encodeUtf8 body)
bundleHeaders :: Text -> Text -> [Header]
bundleHeaders root cd =
[ (hContentType, encodeUtf8 "application/vnd.arboricx.bundle")
, ("X-Arboricx-Root-Hash", encodeUtf8 root)
, ("Content-Disposition", encodeUtf8 cd)
]
firstOrRoot :: Text -> Text
firstOrRoot names =
case parseNameList names of
[] -> "root"
(x:_) -> x
safeFileName :: String -> String
safeFileName = map go
where
go c
| c >= 'a' && c <= 'z' = c
| c >= 'A' && c <= 'Z' = c
| c >= '0' && c <= '9' = c
| c == '-' = c
| c == '_' = c
| otherwise = '_'