[Fencommits] fenserve: monadified storm IO
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Mar 22 19:49:26 EET 2007
Sun Mar 18 12:18:28 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* monadified storm IO
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-03-22 19:49:26.000000000 +0200
+++ new-fenserve/FenServe.hs 2007-03-22 19:49:26.000000000 +0200
@@ -26,6 +26,7 @@
import HAppS
+import Control.Monad (liftM)
import Control.Monad.State (State, get, gets, put, modify, execState)
import qualified Data.ByteString as ByteString
@@ -61,8 +62,8 @@
data Directory = Dir { dirNode :: Node, dirEntries :: [Entry] } deriving (Show, Read)
-emptyState :: Ptr; emptyState = writeBlock (Dir (IRI "#dir") []) Map.empty
-emptyDir :: BlockId; emptyDir = fst emptyState
+emptyState :: Ptr
+emptyState = runStormIO (writeBlock (Dir (IRI "#dir") [])) Map.empty
type Ptr = (BlockId, Pool)
@@ -127,26 +128,29 @@
, 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."
+ 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, Pool) -> Graph
-readGraph (bid, pool) = setGraphURI (bURI bid) $ readBlock (bid, pool)
+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 = readBlock (bid,pool)
- f (FileEntry n r : _ ) | n == x = getBlock (bID r, pool)
+ 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 = readBlock (bid,pool)
+ 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
@@ -158,27 +162,23 @@
in writeGraph graph' pool
-}
-updateData :: (Read a, Show a) => Endo a -> Endo (BlockId, Pool)
-updateData f (bid,pool) = writeBlock (f $ readBlock (bid,pool)) pool
+updateData :: (Read a, Show a) => EndoM StormIO a -> EndoM StormIO BlockId
+updateData f bid = writeBlock =<< f =<< readBlock bid
-putURI :: [String] -> ByteString -> Endo (BlockId, Pool)
-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
+putURI :: [String] -> ByteString -> BlockId -> StormIO BlockId
+putURI path s bid = do rid <- addBlock s; putURI' path (bIRI rid) bid where
+ putURI' [x] r bid = do updateData f' bid where
+ f' (Dir n entries) = return $ 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) = 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:xs) r bid = updateData f' bid where
+ 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 (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
diff -rN -u old-fenserve/Storm.hs new-fenserve/Storm.hs
--- old-fenserve/Storm.hs 2007-03-22 19:49:26.000000000 +0200
+++ new-fenserve/Storm.hs 2007-03-22 19:49:26.000000000 +0200
@@ -20,6 +20,9 @@
-- MA 02111-1307 USA
import SHA1
+
+import Control.Monad.State
+
import qualified Data.ByteString as ByteString
import Data.ByteString (ByteString)
import qualified Data.Char as Char
@@ -29,26 +32,30 @@
newtype BlockId = BlockId { blockId :: String } deriving (Eq,Ord,Show,Read)
type Pool = Map BlockId ByteString
+type StormIO = State Pool -- might be good to have StormI = Reader Pool?
+
+runStormIO :: StormIO a -> Pool -> (a, Pool)
+runStormIO = runState
-addBlock :: ByteString -> Pool -> (BlockId, 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))
+addBlock :: ByteString -> StormIO BlockId
+addBlock body = let id' = BlockId $ sha1 $ ByteString.unpack body
+ in modify (Map.insert id' body) >> return id'
+
+getBlock :: BlockId -> StormIO ByteString
+getBlock bid = get >>= \pool ->
+ return $ fromMaybe (error $ "Storm.getBlock: Block "++show bid
+ ++" not in pool "++show (Map.keys pool))
+ (Map.lookup bid pool)
+
+readBlock :: Read a => BlockId -> StormIO a
+readBlock bid = do b <- getBlock bid; return $ f b $ reads $ fromUTF b where
+ f _ ((x,""):xs) = x
+ f b (_ :xs) = f b xs
+ f b [] = error $ "Storm.readBlock: no parse in " ++ blockId bid
+ ++ ": " ++ fromUTF b
-writeBlock :: Show a => a -> Pool -> (BlockId, Pool)
-writeBlock x pool = addBlock (toUTF $ show x) pool where
+writeBlock :: Show a => a -> StormIO BlockId
+writeBlock = addBlock . toUTF . show
toUTF :: String -> ByteString -- note: only for ASCII =)
More information about the Fencommits
mailing list