[Fencommits] fenserve: refactor so that Entry objects in Haskell don't know their filename
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Mar 22 19:49:05 EET 2007
Thu Mar 22 18:49:52 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* refactor so that Entry objects in Haskell don't know their filename
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-03-22 19:49:05.000000000 +0200
+++ new-fenserve/FenServe.hs 2007-03-22 19:49:05.000000000 +0200
@@ -68,12 +68,13 @@
fs_mimeType = IRI "http://fenfire.org/2007/fenserve#mimeType"
fs_language = IRI "http://fenfire.org/2007/fenserve#language"
-data Entry = DirEntry { entryName :: String, entrySubdir :: Node }
- | FileEntry { entryName :: String, entryRepr :: Node }
- | ExecutableEntry { entryName :: String, entryCode :: Node }
+data Entry = DirEntry { entrySubdir :: Node }
+ | FileEntry { entryRepr :: Node }
+ | ExecutableEntry { entryCode :: Node }
deriving (Show, Read)
-data Directory = Dir { dirNode :: Node, dirEntries :: [Entry] } deriving (Show, Read)
+data Directory = Dir { dirNode :: Node, dirEntries :: [(String,Entry)] }
+ deriving (Show, Read)
emptyState :: Ptr
emptyState = runStormIO (writeData "" $ Dir (IRI "") []) Map.empty
@@ -85,8 +86,6 @@
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
@@ -100,57 +99,51 @@
instance ToRDF Directory where
toRDF (Dir node entries) = do
- l <- toRDF entries
+ l <- toRDFList toRDFEntry entries
tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
return node
+ where toRDFEntry (name, entry) = do e <- toRDF entry; n <- toRDF name
+ tellTs [(e,fs_filename,n)]; return e
instance FromRDF Directory where
readRDF g node = do
let l = query (node, fs_entries, X) g
tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
- entries <- readRDF g l
- return $ Dir node entries
+ entries <- readRDFList readRDFEntry g l
+ return $ Dir node entries
+ where readRDFEntry g n = do
+ let nameR = query (n, fs_filename, X) g
+ name <- readRDF g nameR; entry <- readRDF g n
+ tellTs [ (n, fs_filename, nameR) ]; return (name, entry)
instance ToRDF Entry where
- toRDF (FileEntry name repr) = do
- e <- newBNode; nameR <- toRDF name
- tellTs [ (e, fs_filename, nameR), (e, rdf_type, fs_FileEntry),
- (e, fs_representation, repr) ]
+ toRDF (FileEntry repr) = do
+ e <- newBNode
+ tellTs [ (e, rdf_type, fs_FileEntry), (e, fs_representation, repr) ]
return e
- toRDF (DirEntry name subdir) = do
- e <- newBNode; nameR <- toRDF name
- tellTs [ (e, fs_filename, nameR), (e, rdf_type, fs_DirEntry),
- (e, fs_subdir, subdir) ]
+ toRDF (DirEntry subdir) = do
+ e <- newBNode
+ tellTs [ (e, rdf_type, fs_DirEntry), (e, fs_subdir, subdir) ]
return e
- toRDF (ExecutableEntry name code) = do
- e <- newBNode; nameR <- toRDF name
- tellTs [ (e, fs_filename, nameR), (e, rdf_type, fs_ExecutableEntry),
- (e, fs_code, code) ]
+ toRDF (ExecutableEntry code) = do
+ e <- newBNode
+ tellTs [ (e, rdf_type, fs_ExecutableEntry), (e, fs_code, code) ]
return e
instance FromRDF Entry where
readRDF g node = case query (node, rdf_type, X) g of
x | x == fs_FileEntry -> do
- let nameR = query (node, fs_filename, X) g
- name <- readRDF g nameR
let repr = query (node, fs_representation, X) g
- tellTs [ (node, fs_filename, nameR),
- (node, fs_representation, repr) ]
- return $ FileEntry name repr
+ tellTs [ (node, fs_representation, repr) ]
+ return $ FileEntry repr
x | x == fs_DirEntry -> do
- let nameR = query (node, fs_filename, X) g
- name <- readRDF g nameR
let subdir = query (node, fs_subdir, X) g
- tellTs [ (node, fs_filename, nameR),
- (node, fs_subdir, subdir) ]
- return $ DirEntry name subdir
+ tellTs [ (node, fs_subdir, subdir) ]
+ return $ DirEntry subdir
x | x == fs_ExecutableEntry -> do
- let nameR = query (node, fs_filename, X) g
- name <- readRDF g nameR
let code = query (node, fs_code, X) g
- tellTs [ (node, fs_filename, nameR),
- (node, fs_subdir, code) ]
- return $ ExecutableEntry name code
+ tellTs [ (node, fs_subdir, code) ]
+ return $ ExecutableEntry code
instance StartState Ptr where startStateM = return emptyState
@@ -198,55 +191,58 @@
handlePath :: [String] -> Request -> FenServe Result
handlePath path req = do
e <- getEntry path
- case e of Right (ExecutableEntry _ code) -> execute code req
+ case e of Right (ExecutableEntry code) -> execute code req
_ -> case rqMethod req of GET -> getURI path req
PUT -> putURI path req
getURI :: [String] -> Request -> FenServe Result
getURI path req = getEntry path >>= \entry -> case entry of
Left err -> return $ mkResult 404 "text/html" (toUTF err)
- Right (FileEntry n r) -> do s <- getBlock (bID r)
- return $ mkResult 200 "text/html" s
- Right (ExecutableEntry n c) -> execute c req
+ Right (FileEntry r) -> do s <- getBlock (bID r)
+ return $ mkResult 200 "text/html" s
+ Right (ExecutableEntry 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
+ f entries = case lookup x entries of
+ Just (DirEntry sub) -> getEntry' [""] sub
+ Just e -> return $ Right e
+ Nothing -> 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
+ f entries = case lookup x entries of
+ Just (DirEntry sub) -> getEntry' xs sub
+ Just e -> return $ Left $ "is not a dir: " ++ x
+ Nothing -> 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']
+putURI path rq = do b <- liftM bIRI $ addBlock (unBody $ rqBody rq)
+ let (e,path') = if List.last path /= ".code"
+ then (FileEntry b, path)
+ else (ExecutableEntry b, List.init path)
+ putEntry path' e
+
+putEntry :: [String] -> Entry -> FenServe Result
+putEntry path e' = do get >>= putEntry' path >>= put
+ return $ mkResult 200 "text/html" (toUTF "Ok.\n") where
+ putEntry' [x] dir = updateData f' dir where
+ f' (Dir n entries) = do entries' <- f entries; return $ Dir n entries'
+ f ((n, DirEntry sub) : es) | n == x = do sub' <- putEntry' [""] sub
+ return ((n, DirEntry sub'):es)
+ f ((n, e) : es) | n == x = return $ (n,e'):es
+ | otherwise = do es' <- f es; return $ (n,e):es'
+ f [] = return [(x, e')]
+ putEntry' (x:xs) dir = updateData f' dir where
+ recurse sub = do sub' <- putEntry' xs sub; return [(x, DirEntry 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)
+ f ((n, DirEntry sub) : es) | n == x = liftM (++es) (recurse sub)
+ f ((n, e) : es) | n == x = error ("FIXME: not a dir: " ++ n)
+ f (e : es) = do es' <- f es; return (e:es')
+ f [] = recurse (fst $ emptyState)
--------------------------------------------------------------------------
-- Running executable resources
diff -rN -u old-fenserve/code-demo.page new-fenserve/code-demo.page
--- old-fenserve/code-demo.page 2007-03-22 19:49:05.000000000 +0200
+++ new-fenserve/code-demo.page 2007-03-22 19:49:05.000000000 +0200
@@ -1,12 +1,18 @@
import Storm (getBlock, addBlock, fromUTF, toUTF)
+import Control.Monad (liftM)
+import qualified Data.ByteString as ByteString
+import Data.Maybe (fromMaybe)
+
handler req = do
let path' = fromMaybe "/edit" $ lookM req "path"
case rqMethod req of
GET -> do e <- getEntry $ splitPath path'; contents <- case e of
- Right (ExecutableEntry _ c) -> getBlock (bID c)
+ Right (ExecutableEntry c) -> getBlock (bID c)
_ -> return ByteString.empty
- mkResult 200 "text/plain" contents
- PUT -> do putURI (splitPath $ path' ++ ".code") req
+ return $ mkResult 200 "text/plain" contents
+ PUT -> do c <- liftM bIRI $ addBlock $ unBody $ rqBody req
+ putEntry (splitPath path') (ExecutableEntry c)
+ return $ mkResult 200 "text/html" (toUTF "Ok.\n")
diff -rN -u old-fenserve/edit-demo.page new-fenserve/edit-demo.page
--- old-fenserve/edit-demo.page 2007-03-22 19:49:05.000000000 +0200
+++ new-fenserve/edit-demo.page 2007-03-22 19:49:05.000000000 +0200
@@ -11,12 +11,12 @@
if rqMethod req == POST
then case lookM req "contents" of
Just contents -> do b <- liftM bIRI $ addBlock $ toUTF contents
- putBlock path' b; return ()
+ putEntry path' (FileEntry b); return ()
_ -> return ()
else return ()
e <- getEntry path'; contents <- case e of
- Right (FileEntry _ r) -> liftM fromUTF $ getBlock (bID r)
+ Right (FileEntry r) -> liftM fromUTF $ getBlock (bID r)
_ -> return ""
return $ mkResult 200 "text/html" $ toUTF $
More information about the Fencommits
mailing list