[Fencommits] fenserve: refactor, creating a FenServe monad which encapsulates server state (pool + root block)
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Mar 22 19:49:11 EET 2007
Wed Mar 21 22:07:10 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* refactor, creating a FenServe monad which encapsulates server state (pool + root block)
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-03-22 19:49:11.000000000 +0200
+++ new-fenserve/FenServe.hs 2007-03-22 19:49:11.000000000 +0200
@@ -27,7 +27,9 @@
import HAppS hiding (query, Handler)
import Control.Monad (liftM)
-import Control.Monad.State (State, get, gets, put, modify, execState)
+import Control.Monad.State (State, StateT, runStateT,
+ get, gets, put, modify, execState)
+import Control.Monad.Trans (lift)
import qualified Data.ByteString as ByteString
import Data.ByteString (ByteString)
@@ -77,8 +79,19 @@
emptyState = runStormIO (writeData "" $ Dir (IRI "") []) Map.empty
type Ptr = (Node, Pool)
+type FenServe = StateT Node StormIO
-type Handler = Request -> StormIO Result --State Ptr Result
+runFenServe :: FenServe a -> Ptr -> (a, Ptr)
+runFenServe m (node,pool) = (r, (node', pool')) where
+ ((r, node'), pool') = runStormIO (runStateT m node) pool
+
+evalFenServe m = fst . runFenServe m; execFenServe m = snd . runFenServe m
+
+instance StormMonad FenServe where
+ getBlock = lift . getBlock
+ addBlock = lift . addBlock
+
+type Handler = Request -> FenServe Result
mkResult :: Int -> String -> ByteString -> Result
mkResult code mimeType body = Result {
@@ -159,41 +172,45 @@
bID (IRI ('b':'l':'k':':':s)) = BlockId $ takeWhile (/= '#') s
bID node = error $ "Not a block IRI: " ++ show node
-readGraph :: BlockId -> StormIO Graph
+readGraph :: StormMonad m => BlockId -> m Graph
readGraph bid = do triples <- readBlock bid; let uri = bURI bid
let triples' = everywhere (mkT $ absolutizeNode uri) triples
return $ toGraph (IRI uri) (triples' :: Set Triple)
-writeGraph :: Graph -> StormIO BlockId
+writeGraph :: StormMonad m => Graph -> m BlockId
writeGraph g = let triples = fromGraph g; uri = iriStr $ defaultGraph g
triples' = everywhere (mkT $ relativizeNode uri) triples
in writeBlock (triples' :: Set Triple)
-readData :: FromRDF a => Node -> StormIO a
+readData :: (FromRDF a, StormMonad m) => Node -> m a
readData node = do graph <- readGraph (bID node)
return $ fromRDF graph node
-writeData :: ToRDF a => String -> a -> StormIO Node
+writeData :: (ToRDF a, StormMonad m) => String -> a -> m Node
writeData baseURI value = do
let (node, ts) = runToRDF baseURI $ toRDF value
bid <- writeGraph $ toGraph (IRI baseURI) ts
return $ changeBaseURI baseURI (bURI bid) node
-updateData :: (FromRDF a, ToRDF a) => EndoM StormIO a -> EndoM StormIO Node
+updateData :: (FromRDF a, ToRDF a, StormMonad m) => EndoM m a -> EndoM m Node
updateData f node = readData node >>= f >>= writeData (bURI $ bID node)
-getURI :: Request -> [String] -> Node -> StormIO ByteString
-getURI req [x] dir = readData dir >>= f . dirEntries where
- f (FileEntry n r : _ ) | n == x = getBlock (bID r)
+getURI :: [String] -> Request -> FenServe Result
+getURI path req = do dir <- get; getURI' path dir where
+ getURI' [x] dir = readData dir >>= f . dirEntries where
+ f (FileEntry n r : _ ) | n == x = getBlock (bID r) >>= return .
+ mkResult 200 "text/html"
f (ExecutableEntry n c : _ ) | n == x = execute c req
f (_ : es) = f es
- f [] = return $ toUTF $ "not found: " ++ x
-getURI req (x:xs) dir = readData dir >>= f . dirEntries where
- f (DirEntry n sub : _ ) | n == x = getURI req xs sub
+ f [] = return $ mkResult 404 "text/html" $
+ toUTF $ "not found: " ++ x
+ getURI' (x:xs) dir = readData dir >>= f . dirEntries where
+ f (DirEntry n sub : _ ) | n == x = getURI' xs sub
f (_ : es) = f es
- f [] = return $ toUTF $ "dir not found: " ++ x
+ f [] = return $ mkResult 404 "text/html" $
+ toUTF $ "dir not found: " ++ x
-execute :: Node -> Request -> StormIO ByteString
+execute :: Node -> Request -> FenServe Result
execute code req = do
s <- getBlock (bID code)
let errH stage msg = return $ \req -> return $
@@ -228,11 +245,16 @@
Plugins.LoadFailure err ->
errH "Load" $ concat (List.intersperse "\n" err)
removeFile fp; return h'
- response <- h req
- return $ ByteString.concat $ rsBody response
+ h req -- run the loaded handler
-putURI :: [String] -> ByteString -> Node -> StormIO Node
-putURI path s dir = do rid <- addBlock s; putURI' path (bIRI rid) dir where
+unBody NoBody = ByteString.empty
+unBody (Body b) = b
+unBody (LargeBody _ _) = error "FenServe.unBody: large body not handled"
+
+putURI :: [String] -> Request -> FenServe Result
+putURI path rq = do dir <- get; rid <- addBlock (unBody $ rqBody rq)
+ putURI' path (bIRI rid) dir >>= put
+ return $ mkResult 200 "text/html" (toUTF "Ok.\n") where
putURI' [x] r dir = updateData f' dir where
f' (Dir n entries) = return $ Dir n (f entries)
f (FileEntry n _ : es) | n == x = FileEntry n r : es
diff -rN -u old-fenserve/Main.hs new-fenserve/Main.hs
--- old-fenserve/Main.hs 2007-03-22 19:49:11.000000000 +0200
+++ new-fenserve/Main.hs 2007-03-22 19:49:11.000000000 +0200
@@ -26,6 +26,7 @@
import Control.Monad.State (State, get, gets, put, modify, execState)
+import qualified Data.ByteString as ByteString
import qualified Data.Map as Map
import Data.Map (Map)
@@ -35,17 +36,16 @@
localhostOnlyFilter = Handle $ \req -> do
if fst (rqPeer req) == "localhost" then request req else respond $ return $
mkResult 403 "text/html" $ toUTF "403 Forbidden: Try from localhost"
-
+
main :: IO ()
main = stdHTTP
- [ localhostOnlyFilter
- , debugFilter
+ [ debugFilter
+ , localhostOnlyFilter
, h asURI GET $ ok $ \uri () -> do
- let pa = splitPath (path uri)
- rq <- getEvent
- (b,p) <- get; return $ Right $ fst $ runStormIO (getURI rq pa b) p
+ state <- get; rq <- getEvent; let pa = splitPath (path uri)
+ respond $ evalFenServe (getURI pa rq) state
, h asURI PUT $ ok $ \uri () -> do
- let pa = splitPath (path uri)
- Request { rqBody=Body body } <- getEvent
- modify (\(b,p) -> runStormIO (putURI pa body b) p); return $ Right "Ok."
+ state <- get; rq <- getEvent; let pa = splitPath (path uri)
+ let (result, state') = runFenServe (putURI pa rq) state
+ put state'; respond result
]
diff -rN -u old-fenserve/Storm.hs new-fenserve/Storm.hs
--- old-fenserve/Storm.hs 2007-03-22 19:49:11.000000000 +0200
+++ new-fenserve/Storm.hs 2007-03-22 19:49:11.000000000 +0200
@@ -38,24 +38,27 @@
runStormIO :: StormIO a -> Pool -> (a, Pool)
runStormIO = runState
-addBlock :: ByteString -> StormIO BlockId
-addBlock body = let id' = BlockId $ sha1 $ ByteString.unpack body
- in modify (Map.insert id' body) >> return id'
-
-getBlock :: BlockId -> StormIO ByteString
-getBlock bid = get >>= \pool ->
- return $ fromMaybe (error $ "Storm.getBlock: Block "++show bid
- ++" not in pool "++show (Map.keys pool))
- (Map.lookup bid pool)
+class Monad m => StormMonad m where
+ getBlock :: BlockId -> m ByteString
+ addBlock :: ByteString -> m BlockId
+
+instance StormMonad StormIO where
+ getBlock bid = get >>= \pool ->
+ return $ fromMaybe (error $ "Storm.getBlock: Block "++show bid
+ ++" not in pool "++show (Map.keys pool))
+ (Map.lookup bid pool)
-readBlock :: Read a => BlockId -> StormIO a
+ addBlock body = let id' = BlockId $ sha1 $ ByteString.unpack body
+ in modify (Map.insert id' body) >> return id'
+
+readBlock :: (Read a, StormMonad m) => BlockId -> m a
readBlock bid = do b <- getBlock bid; return $ f b $ reads $ fromUTF b where
f _ ((x,""):xs) = x
f b (_ :xs) = f b xs
f b [] = error $ "Storm.readBlock: no parse in " ++ blockId bid
++ ": " ++ fromUTF b
-writeBlock :: Show a => a -> StormIO BlockId
+writeBlock :: (Show a, StormMonad m) => a -> m BlockId
writeBlock = addBlock . toUTF . show
More information about the Fencommits
mailing list