[Fencommits] fenserve: refactor
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Mar 22 19:49:09 EET 2007
Thu Mar 22 05:17:04 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* refactor
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-03-22 19:49:09.000000000 +0200
+++ new-fenserve/FenServe.hs 2007-03-22 19:49:09.000000000 +0200
@@ -195,24 +195,93 @@
updateData :: (FromRDF a, ToRDF a, StormMonad m) => EndoM m a -> EndoM m Node
updateData f node = readData node >>= f >>= writeData (bURI $ bID node)
+handlePath :: [String] -> Request -> FenServe Result
+handlePath path req = do get -> dir
+ (r, dir') <- handlePath' dir path req
+ put dir'; return r where
+ notFound err = return $ (mkResult 404 "text/html" $ toUTF err, [])
+ handlePath' d [x] req = do
+ Dir _ entries <- readData d; (r, entries') <- f entries
+ d' <- writeData (bURI $ bID d) (Dir d entries'); return (r,d') where
+ f es@(FileEntry n r : _) | x `elem` [n,n++".code"] = case rqMethod req of
+ GET -> do s <- getBlock (bID r)
+ return (mkResult 200 "text/html" s, es)
+ PUT -> f (tail es)
+ f es@(ExecutableEntry n c : _) | n == x = do result <- execute c req
+ return (result, es)
+ f (e : es) = do (r,es') <- f es; return (r,e:es')
+ f [] = case rqMethod req of
+ GET -> notFound $ "not found: " ++ x
+ PUT -> do r <- liftM bIRI $ addBlock (unBody $ rqBody req)
+ return (mkResult 200 "text/html" (toUTF "Ok.\n"),
+ if ".code" `List.isSuffixOf` x
+ then [ExecutableEntry (take (length x - 5) x) r]
+ else [FileEntry x r])
+ handlePath' d (x:xs) req = do
+ Dir _ entries <- readData d; (r, entries') <- f entries
+ d' <- writeData (bURI $ bID d) (Dir d entries'); return (r,d') where
+ f (DirEntry n sub : es) | n == x = do (r,sub') <- handlePath' sub xs req
+ return (r, DirEntry n sub' : es)
+ f (_ : es) = f es
+ f [] = case rqMethod req of
+ PUT -> do (r,sub) <- handlePath' (fst emptyState) xs req
+ return (r, [DirEntry x sub])
+ _ -> notFound $ "dir not found: " ++ x
+
+{-
getURI :: [String] -> Request -> FenServe Result
getURI path req = getEntry path >>= \entry -> case entry of
- Left err -> return $ mkResult 404 "text/html" $ toUTF err
+ Left err ->
Right (FileEntry n r) -> do s <- getBlock (bID r)
return $ mkResult 200 "text/html" s
Right (ExecutableEntry n c) -> execute c req
+-}
getEntry :: [String] -> FenServe (Either String Entry)
getEntry path = do dir <- get; getEntry' path dir where
getEntry' [x] dir = readData dir >>= f . dirEntries where
f (e@(FileEntry n _) : _ ) | n == x = return $ Right e
f (e@(ExecutableEntry n _) : _ ) | n == x = return $ Right e
+ f (_ : es) = f es
f [] = return $ Left $ "not found: " ++ x
getEntry' (x:xs) dir = readData dir >>= f . dirEntries where
f (DirEntry n sub : _ ) | n == x = getEntry' xs sub
f (_ : es) = f es
f [] = return $ Left $ "dir not found: " ++ x
+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 = addBlock (unBody $ rqBody rq) >>= putBlock path . bIRI
+
+putBlock :: [String] -> Node -> FenServe Result
+putBlock path r = do get >>= putBlock' path r >>= put
+ return $ mkResult 200 "text/html" (toUTF "Ok.\n") where
+ putBlock' [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
+ | n ++ ".code" == x = ExecutableEntry n r : es
+ f (ExecutableEntry n _ : es) | n == x = FileEntry n r : es
+ | n ++ ".code" == x = ExecutableEntry n r : es
+ f (e : es) = e : f es
+ f [] | ".code" `List.isSuffixOf` x
+ = [ExecutableEntry (take (length x - 5) x) r]
+ | otherwise = [FileEntry x r]
+ putBlock' (x:xs) r dir = updateData f' dir where
+ recurse sub = do sub' <- putBlock' xs r sub; return [DirEntry x sub']
+ f' (Dir n entries) = do es' <- f entries; return (Dir n es')
+ f (DirEntry n sub : es) | n == x = liftM (++es) (recurse sub)
+ f (e : es) = do es' <- f es; return (e:es')
+ f [] = recurse (fst $ emptyState)
+-}
+
+--------------------------------------------------------------------------
+-- Running executable resources
+--------------------------------------------------------------------------
+
execute :: Node -> Request -> FenServe Result
execute code req = do
s <- getBlock (bID code)
@@ -250,32 +319,6 @@
removeFile fp; return h'
h req -- run the loaded handler
-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 = addBlock (unBody $ rqBody rq) >>= putBlock path . bIRI
-
-putBlock :: [String] -> Node -> FenServe Result
-putBlock path r = do get >>= putBlock' path r >>= put
- return $ mkResult 200 "text/html" (toUTF "Ok.\n") where
- putBlock' [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
- | n ++ ".code" == x = ExecutableEntry n r : es
- f (ExecutableEntry n _ : es) | n == x = FileEntry n r : es
- | n ++ ".code" == x = ExecutableEntry n r : es
- f (e : es) = e : f es
- f [] | ".code" `List.isSuffixOf` x
- = [ExecutableEntry (take (length x - 5) x) r]
- | otherwise = [FileEntry x r]
- putBlock' (x:xs) r dir = updateData f' dir where
- recurse sub = do sub' <- putBlock' xs r sub; return [DirEntry x sub']
- f' (Dir n entries) = do es' <- f entries; return (Dir n es')
- f (DirEntry n sub : es) | n == x = liftM (++es) (recurse sub)
- f (e : es) = do es' <- f es; return (e:es')
- f [] = recurse (fst $ emptyState)
--------------------------------------------------------------------------
-- Copied from HAppS.Protocols.SimpleHTTP2, which is BSD3-licensed
diff -rN -u old-fenserve/Main.hs new-fenserve/Main.hs
--- old-fenserve/Main.hs 2007-03-22 19:49:09.000000000 +0200
+++ new-fenserve/Main.hs 2007-03-22 19:49:09.000000000 +0200
@@ -24,7 +24,9 @@
import HAppS hiding (query, Handler)
+import Control.Monad (when)
import Control.Monad.State (State, get, gets, put, modify, execState)
+import Control.Monad.Trans (liftIO)
import qualified Data.ByteString as ByteString
import qualified Data.Map as Map
@@ -37,15 +39,15 @@
if fst (rqPeer req) == "localhost" then request req else respond $ return $
mkResult 403 "text/html" $ toUTF "403 Forbidden: Try from localhost"
+fenserveHandler hdl = Handle $ \req -> do
+ state <- get; rq <- getEvent; let pa = splitPath (path $ rqURI req)
+ let (result, state') = runFenServe (hdl pa rq) state
+ when (not $ rqMethod req `elem` [GET,HEAD]) $ put state'
+ respond $ return result
+
main :: IO ()
main = stdHTTP
[ debugFilter
, localhostOnlyFilter
- , h asURI GET $ ok $ \uri () -> do
- state <- get; rq <- getEvent; let pa = splitPath (path uri)
- respond $ evalFenServe (getURI pa rq) state
- , h asURI PUT $ ok $ \uri () -> do
- state <- get; rq <- getEvent; let pa = splitPath (path uri)
- let (result, state') = runFenServe (putURI pa rq) state
- put state'; respond result
+ , fenserveHandler handlePath
]
diff -rN -u old-fenserve/board-demo.page new-fenserve/board-demo.page
--- old-fenserve/board-demo.page 2007-03-22 19:49:09.000000000 +0200
+++ new-fenserve/board-demo.page 2007-03-22 19:49:09.000000000 +0200
@@ -70,10 +70,6 @@
handler req = do
e <- getEntry ["testdata","blog"]
- bid <- case e of
- Right (FileEntry _ r) -> return (bID r)
- _ -> do bid <- writeGraph example
- putBlock ["testdata","blog"] (bIRI bid)
- return bid
- graph <- readGraph bid
+ graph <- case e of Right (FileEntry _ r) -> readGraph (bID r)
+ _ -> return example
flip pageHandler req $ let ?graph = graph in renderBoard blog
diff -rN -u old-fenserve/handler-demo.page new-fenserve/handler-demo.page
--- old-fenserve/handler-demo.page 2007-03-22 19:49:09.000000000 +0200
+++ new-fenserve/handler-demo.page 2007-03-22 19:49:09.000000000 +0200
@@ -1,4 +1,4 @@
handler req = do
- getURI ["testdata","foo"] req
+ handlePath ["testdata","foo"] req
More information about the Fencommits
mailing list