[Fencommits] fenserve: simplify code; add version I'm not going to use, for reference
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Mar 22 19:49:25 EET 2007
Sun Mar 18 13:38:14 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* simplify code; add version I'm not going to use, for reference
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-03-22 19:49:24.000000000 +0200
+++ new-fenserve/FenServe.hs 2007-03-22 19:49:25.000000000 +0200
@@ -173,18 +173,11 @@
f (e : es) = e : f es
f [] = [FileEntry x r]
putURI' (x:xs) r bid = updateData f' bid where
+ recurse sub = do sub' <- putURI' xs r sub; return [DirEntry x (bIRI sub')]
f' (Dir n entries) = do es' <- f entries; return (Dir n es')
- f (DirEntry n sub : es) | n == x = do sub' <- putURI' xs r (bID sub)
- return (DirEntry n (bIRI sub') : es)
+ f (DirEntry n sub : es) | n == x = liftM (++es) (recurse $ bID sub)
f (e : es) = do es' <- f es; return (e:es')
- f [] = do sub <- putURI' xs r (fst emptyState)
- return [DirEntry x (bIRI sub)]
-
---putURI [x] s (Dir m) = Dir $ Map.insert x (File s) m
---putURI (x:xs) s (Dir m) = Dir $ updateWithDefault (Dir Map.empty) (putURI xs s) x m
-
-updateWithDefault :: Ord k => a -> (a -> a) -> k -> Map k a -> Map k a
-updateWithDefault x f = Map.alter (Just . f . fromMaybe x)
+ f [] = recurse (fst $ emptyState)
--------------------------------------------------------------------------
-- Copied from HAppS.Protocols.SimpleHTTP2, which is BSD3-licensed
diff -rN -u old-fenserve/FenServe.hs.2 new-fenserve/FenServe.hs.2
--- old-fenserve/FenServe.hs.2 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/FenServe.hs.2 2007-03-22 19:49:25.000000000 +0200
@@ -0,0 +1,190 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module Main where
+
+-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup
+-- This file is part of Fenfire.
+--
+-- Fenfire is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by
+-- the Free Software Foundation; either version 2 of the License, or
+-- (at your option) any later version.
+--
+-- Fenfire is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+-- Public License for more details.
+--
+-- You should have received a copy of the GNU General
+-- Public License along with Fenfire; if not, write to the Free
+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
+-- MA 02111-1307 USA
+
+import Storm
+import Fenfire.RDF
+import Fenfire.Utils
+import qualified Fenfire.Raptor as Raptor
+
+import HAppS
+
+import Control.Monad (liftM)
+import Control.Monad.State (State, get, gets, put, modify, execState)
+
+import qualified Data.ByteString as ByteString
+import Data.ByteString (ByteString)
+import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Set as Set
+import Data.Maybe (fromMaybe, fromJust)
+import Data.Typeable
+
+import Network.URI (uriToString)
+
+import System.IO.Unsafe (unsafePerformIO)
+
+fs = "http://fenfire.org/2007/fenserve#"
+fs_Directory = IRI "http://fenfire.org/2007/fenserve#Directory"
+fs_DirEntry = IRI "http://fenfire.org/2007/fenserve#DirEntry"
+fs_FileEntry = IRI "http://fenfire.org/2007/fenserve#FileEntry"
+fs_FirstVersion = IRI "http://fenfire.org/2007/fenserve#FirstVersion"
+fs_previousVersion = IRI "http://fenfire.org/2007/fenserve#previousVersion"
+fs_entries = IRI "http://fenfire.org/2007/fenserve#entries"
+fs_filename = IRI "http://fenfire.org/2007/fenserve#filename"
+fs_subdir = IRI "http://fenfire.org/2007/fenserve#"
+fs_representation = IRI "http://fenfire.org/2007/fenserve#representation"
+fs_mimeType = IRI "http://fenfire.org/2007/fenserve#mimeType"
+fs_language = IRI "http://fenfire.org/2007/fenserve#language"
+
+rget :: Node -> Node -> Graph -> Node
+rget p s g = fromJust $ getOne g s p Pos
+
+data Entry = DirEntry { entryName :: String, entrySubdir :: Node }
+ | FileEntry { entryName :: String, entryRepr :: Node } deriving (Show, Read)
+
+data Directory = Dir { dirNode :: Node, dirEntries :: [Entry] } deriving (Show, Read)
+
+emptyState :: Ptr
+emptyState = runStormIO (writeBlock (Dir (IRI "#dir") [])) Map.empty
+
+type Ptr = (BlockId, Pool)
+
+instance ToRDF Directory where
+ toRDF (Dir node entries) = do
+ l <- toRDF entries
+ tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
+ return node
+
+instance FromRDF Directory where
+ readRDF g node = do
+ let l = rget fs_entries node g
+ tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
+ entries <- readRDF g l
+ return $ Dir node entries
+
+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) ]
+ 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) ]
+ return e
+
+instance FromRDF Entry where
+ readRDF g node = case rget rdf_type node g of
+ x | x == fs_FileEntry -> do
+ let nameR = rget fs_filename node g
+ name <- readRDF g nameR
+ let repr = rget fs_representation node g
+ tellTs [ (node, fs_filename, nameR),
+ (node, fs_representation, repr) ]
+ return $ FileEntry name repr
+ x | x == fs_DirEntry -> do
+ let nameR = rget fs_filename node g
+ name <- readRDF g nameR
+ let subdir = rget fs_representation node g
+ tellTs [ (node, fs_filename, nameR),
+ (node, fs_subdir, subdir) ]
+ return $ DirEntry name subdir
+
+instance StartState Ptr where startStateM = return emptyState
+
+instance Serialize Ptr where
+ typeString _ = "FenServe.State"
+ decodeStringM = defaultDecodeStringM
+ encodeStringM = defaultEncodeStringM
+
+instance ToMessage ByteString where
+ toMessageBodyM = return
+
+asPath :: SURI -> Maybe [String]
+asPath = Just . splitPath . path
+
+main :: IO ()
+main = stdHTTP
+ [ debugFilter
+ , h asPath GET $ ok $ \uri () -> get >>= return . Right . getURI uri
+ , h asPath PUT $ ok $ \uri () -> do
+ Request { rqBody=Body body } <- getEvent
+ modify (\(b,p) -> runStormIO (putURI uri body b) p); return $ Right "Ok."
+ ]
+
+bURI :: BlockId -> String
+bURI (BlockId bid) = "blk:" ++ bid
+
+bIRI :: BlockId -> Node
+bIRI bid = IRI $ bURI bid
+
+bID :: Node -> BlockId
+bID (IRI ('b':'l':'k':':':s)) = BlockId $ takeWhile (/= '#') s
+
+readGraph :: BlockId -> StormIO Graph
+readGraph bid = liftM (setGraphURI $ bURI bid) $ readBlock bid
+
+getURI :: [String] -> (BlockId, Pool) -> ByteString
+getURI [x] (bid,pool) = f entries where
+ Dir _ entries = fst $ runStormIO (readBlock bid) pool
+ f (FileEntry n r : _ ) | n == x = fst $ runStormIO (getBlock (bID r)) pool
+ f (_ : es) = f es
+ f [] = toUTF $ "not found: " ++ x
+getURI (x:xs) (bid,pool) = f entries where
+ Dir _ entries = fst $ runStormIO (readBlock bid) pool
+ f (DirEntry n sub : _ ) | n == x = getURI xs (bID sub, pool)
+ f (_ : es) = f es
+ f [] = toUTF $ "dir not found: " ++ x
+
+{-
+updateData :: (FromRDF a, ToRDF a) => (a -> a) -> Node -> Endo (BlockId,Pool)
+updateData f node (bid,pool) = let graph = readGraph (bid, pool)
+ graph' = updateRDF f node graph
+ in writeGraph graph' pool
+-}
+
+updateData :: (Read a, Show a) => EndoM StormIO a -> EndoM StormIO BlockId
+updateData f bid = writeBlock =<< f =<< readBlock bid
+
+putURI :: [String] -> ByteString -> BlockId -> StormIO BlockId
+putURI path s bid = do rid <- addBlock s; putURI' path (bIRI rid) bid where
+ upd :: String -> (EndoM StormIO Entry) -> Entry -> EndoM StormIO Directory
+ upd fn f dflt (Dir n es) = do es' <- upd' fn f dflt es; return (Dir n es')
+ upd' fn f dflt (e:es) | entryName e == fn = do e' <- f e; return (e':es)
+ upd' fn f dflt (e:es) = do es' <- upd' fn f dflt es; return (e:es')
+ upd' _ f dflt [] = do e <- f dflt; return [e]
+
+ putURI' [x] r = updateData (upd x (const $ return e) e) where e = FileEntry x r
+ putURI' (x:xs) r = updateData (upd x f (DirEntry x (bIRI $ fst emptyState))) where
+ f (DirEntry n sub) = do sub' <- putURI' xs r (bID sub)
+ return $ DirEntry x (bIRI sub')
+
+--------------------------------------------------------------------------
+-- Copied from HAppS.Protocols.SimpleHTTP2, which is BSD3-licensed
+--------------------------------------------------------------------------
+
+splitPath :: String -> [String]
+splitPath ('/':x) = a : splitPath b where (a,b) = break (=='/') x
+splitPath [] = []
+splitPath _ = error "splitPath: malformed path"
+
+--------------------------------------------------------------------------
More information about the Fencommits
mailing list