[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