[Fencommits] fenserve: finally, a working milestone of fenserve
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Mar 22 19:49:27 EET 2007
Sun Mar 18 02:59:53 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* finally, a working milestone of fenserve
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-03-22 19:49:27.000000000 +0200
+++ new-fenserve/FenServe.hs 2007-03-22 19:49:27.000000000 +0200
@@ -38,7 +38,6 @@
import Network.URI (uriToString)
-import System.Glib.UTFString (newUTFString, peekUTFString)
import System.IO.Unsafe (unsafePerformIO)
fs = "http://fenfire.org/2007/fenserve#"
@@ -58,9 +57,12 @@
rget p s g = fromJust $ getOne g s p Pos
data Entry = DirEntry { entryName :: String, entrySubdir :: Node }
- | FileEntry { entryName :: String, entryRepr :: Node }
+ | FileEntry { entryName :: String, entryRepr :: Node } deriving (Show, Read)
-data Directory = Dir { dirNode :: Node, dirEntries :: [Entry] }
+data Directory = Dir { dirNode :: Node, dirEntries :: [Entry] } deriving (Show, Read)
+
+emptyState :: Ptr; emptyState = writeBlock (Dir (IRI "#dir") []) Map.empty
+emptyDir :: BlockId; emptyDir = fst emptyState
type Ptr = (BlockId, Pool)
@@ -106,11 +108,7 @@
(node, fs_subdir, subdir) ]
return $ DirEntry name subdir
-instance StartState Ptr where
- startStateM = return $ flip writeGraph Map.empty $
- setGraphURI "ex:graph" $ listToGraph
- [ (IRI "ex:graph#dir", rdf_type, fs_Directory)
- , (IRI "ex:graph#dir", fs_entries, rdf_nil) ]
+instance StartState Ptr where startStateM = return emptyState
instance Serialize Ptr where
typeString _ = "FenServe.State"
@@ -125,68 +123,62 @@
main :: IO ()
main = stdHTTP
- [ h asPath GET $ ok $ \uri () -> get >>= return . Right . getURI uri
+ [ debugFilter
+ , h asPath GET $ ok $ \uri () -> get >>= return . Right . getURI uri
, h asPath PUT $ ok $ \uri () -> do
Request { rqBody=Body body } <- getEvent
modify (putURI uri body); return $ Right "Ok."
]
bURI :: BlockId -> String
-bURI bid = "blk:" ++ bid
+bURI (BlockId bid) = "blk:" ++ bid
bID :: Node -> BlockId
-bID (IRI ('b':'l':'k':':':s)) = takeWhile (/= '#') s
+bID (IRI ('b':'l':'k':':':s)) = BlockId $ takeWhile (/= '#') s
readGraph :: (BlockId, Pool) -> Graph
-readGraph (bid, pool) = setGraphURI (bURI bid) $ read $ fromUTF $ pool Map.! bid
-{-raptorToGraph triples namespaces (bURI bid) where
- (triples, namespaces) =
- unsafePerformIO $ Raptor.bytesToTriples "turtle" (pool Map.! bid) (bURI bid)-}
-
-writeGraph :: Graph -> Pool -> (BlockId, Pool)
-writeGraph graph pool = addBlock {-body-} (toUTF $ show graph) pool where
-{- (triples, namespaces) = graphToRaptor graph
- body = unsafePerformIO $ Raptor.triplesToBytes triples namespaces ""-}
-
-toUTF :: String -> ByteString
-toUTF s = unsafePerformIO $ newUTFString s >>= ByteString.copyCString
-
-fromUTF :: ByteString -> String
-fromUTF s = unsafePerformIO $ ByteString.useAsCString s peekUTFString
+readGraph (bid, pool) = setGraphURI (bURI bid) $ readBlock (bid, pool)
getURI :: [String] -> (BlockId, Pool) -> ByteString
getURI [x] (bid,pool) = f entries where
- graph = readGraph (bid,pool); node = IRI $ bURI bid ++ "#dir"
- Dir _ entries = fromRDF graph node
- f (FileEntry n r : _ ) | n == x = unsafePerformIO $ return $ toUTF (show r ++ "\n" ++ show (Map.keys pool)) --pool Map.! bID r
+ Dir _ entries = readBlock (bid,pool)
+ f (FileEntry n r : _ ) | n == x = getBlock (bID r, pool)
f (_ : es) = f es
- f [] = toUTF "not found"
+ f [] = toUTF $ "not found: " ++ x
getURI (x:xs) (bid,pool) = f entries where
- graph = readGraph (bid,pool); node = IRI $ bURI bid ++ "#dir"
- Dir _ entries = fromRDF graph node
- f (DirEntry n sub : _ ) | n == x = getURI xs (bID sub,pool)
+ Dir _ entries = 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) => Endo a -> Endo (BlockId, Pool)
+updateData f (bid,pool) = writeBlock (f $ readBlock (bid,pool)) pool
putURI :: [String] -> ByteString -> Endo (BlockId, Pool)
-putURI [x] s (bid,pool) = updateData f' node (bid, pool') where
- node = IRI $ bURI bid ++ "#dir"
+putURI [x] s (bid, pool) = updateData f' (bid, pool') where
(rid, pool') = addBlock s pool; r = IRI $ bURI rid
-
+
f' (Dir n entries) = Dir n (f entries)
f (FileEntry n _ : es) | n == x = (FileEntry n r) : es
f (e : es) = e : f es
f [] = [FileEntry x r]
-
-{-putURI (x:xs) s (bid,pool) = f entries where
- graph = readGraph (bid,pool); node = IRI $ bURI bid ++ "#dir"
- Dir _ entries = fromRDF graph node
- f (DirEntry n sub : _ ) | n == x = getURI xs (bID sub,pool)
- f (_ : es) = f es-}
+putURI (x:xs) s (bid, pool) = writeBlock (Dir dir entries') pool' where
+ Dir dir entries = readBlock (bid, pool)
+ (entries', pool') = f entries
+
+ f (DirEntry n sub : es) | n == x
+ = let (sub', pool') = putURI xs s (bID sub, pool)
+ in (DirEntry n (IRI $ bURI sub') : es, pool')
+ f (e : es) = let (es', pool') = f es in (e:es', pool')
+ f [] = let (sub, pool') = putURI xs s (emptyDir, pool)
+ in ([DirEntry x (IRI $ bURI sub)], pool')
--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
diff -rN -u old-fenserve/Makefile new-fenserve/Makefile
--- old-fenserve/Makefile 2007-03-22 19:49:27.000000000 +0200
+++ new-fenserve/Makefile 2007-03-22 19:49:27.000000000 +0200
@@ -18,6 +18,9 @@
run: build
./dist/build/fenserve/fenserve $(ARGS)
+
+reset:
+ rm -rf fenserve_state fenserve_error.log
clean:
runhaskell Setup.hs clean
diff -rN -u old-fenserve/Storm.hs new-fenserve/Storm.hs
--- old-fenserve/Storm.hs 2007-03-22 19:49:27.000000000 +0200
+++ new-fenserve/Storm.hs 2007-03-22 19:49:27.000000000 +0200
@@ -22,12 +22,37 @@
import SHA1
import qualified Data.ByteString as ByteString
import Data.ByteString (ByteString)
+import qualified Data.Char as Char
import qualified Data.Map as Map
import Data.Map (Map)
+import Data.Maybe (fromMaybe)
-type BlockId = String
+newtype BlockId = BlockId { blockId :: String } deriving (Eq,Ord,Show,Read)
type Pool = Map BlockId ByteString
addBlock :: ByteString -> Pool -> (BlockId, Pool)
-addBlock body pool = (id', pool') where id' = sha1 $ ByteString.unpack body
- pool' = Map.insert id' body pool
+addBlock body pool = (id', pool') where
+ id' = BlockId $ sha1 $ ByteString.unpack body
+ pool' = Map.insert id' body pool
+
+getBlock :: (BlockId, Pool) -> ByteString
+getBlock (bid,pool) = fromMaybe (error $ "Storm.getBlock: Block "++show bid
+ ++" not in pool "++show (Map.keys pool))
+ (Map.lookup bid pool)
+
+readBlock :: Read a => (BlockId, Pool) -> a
+readBlock (bid, pool) = f $ reads $ fromUTF $ getBlock (bid,pool) where
+ f ((x,""):xs) = x
+ f (_ :xs) = f xs
+ f [] = error $ "Storm.readBlock: no parse in " ++ blockId bid
+ ++ ": " ++ fromUTF (getBlock (bid,pool))
+
+writeBlock :: Show a => a -> Pool -> (BlockId, Pool)
+writeBlock x pool = addBlock (toUTF $ show x) pool where
+
+
+toUTF :: String -> ByteString -- note: only for ASCII =)
+toUTF s = ByteString.pack $ map (fromIntegral . Char.ord) s
+
+fromUTF :: ByteString -> String -- note: only for ASCII =)
+fromUTF s = map (Char.chr . fromIntegral) $ ByteString.unpack s
More information about the Fencommits
mailing list