[Fencommits] fenserve: use a storm directory on the disk

Benja Fallenstein benja.fallenstein at gmail.com
Mon Mar 26 01:56:17 EEST 2007


Mon Mar 26 01:55:59 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * use a storm directory on the disk
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs	2007-03-26 01:56:17.000000000 +0300
+++ new-fenserve/FenServe.hs	2007-03-26 01:56:17.000000000 +0300
@@ -79,20 +79,19 @@
 data Directory = Dir { dirNode :: Node, dirEntries :: [(String,Entry)] }
                  deriving (Show, Read)
 
-emptyState :: Ptr
-emptyState = runStormIO (writeData "ex:" $ Dir (IRI "ex:") []) Map.empty
-
-type Ptr = (Node, Pool)
 type FenServe = StateT Node StormIO
 
-runFenServe :: FenServe a -> Ptr -> (a, Ptr)
-runFenServe m (node,pool) = (r, (node', pool')) where
-    ((r, node'), pool') = runStormIO (runStateT m node) pool
+runFenServe :: FenServe a -> Node -> Maybe FilePath -> IO (a, Node, Pool)
+runFenServe m node dir = do ((r,n),p) <- runStormIO (runStateT m node) dir
+                            return (r,n,p)
     
 instance StormMonad FenServe where
     getBlock = lift . getBlock
     addBlock = lift . addBlock
 
+writeEmptyState :: FenServe Node
+writeEmptyState = writeData "ex:" $ Dir (IRI "ex:") []
+
 type Handler = Request -> FenServe Result
 
 mkResult :: Int -> String -> ByteString -> Result
@@ -148,9 +147,12 @@
             tellTs [ (node, fs_subdir, code) ]
             return $ ExecutableEntry code
 
-instance StartState Ptr where startStateM = return emptyState
+instance StartState Node where 
+    startStateM =
+        runFenServe writeEmptyState e Nothing >>= \(r,_,_) -> return r  where
+            e = error "FenServe.(StartState Node): this shouldn't be evaluated"
 
-instance Serialize Ptr where
+instance Serialize Node where
     typeString _  = "FenServe.State"
     decodeStringM = defaultDecodeStringM
     encodeStringM = defaultEncodeStringM
@@ -260,7 +262,7 @@
     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)
+    f []                       = writeEmptyState >>= recurse
 
 --------------------------------------------------------------------------
 -- Running executable resources
diff -rN -u old-fenserve/Main.hs new-fenserve/Main.hs
--- old-fenserve/Main.hs	2007-03-26 01:56:17.000000000 +0300
+++ new-fenserve/Main.hs	2007-03-26 01:56:17.000000000 +0300
@@ -32,6 +32,9 @@
 import qualified Data.Map as Map
 import Data.Map (Map)
 
+import System.Directory (createDirectoryIfMissing)
+import System.Environment (getProgName)
+import System.IO.Unsafe (unsafePerformIO)
 import System.Posix.Resource
 
 asURI :: SURI -> Maybe SURI
@@ -43,13 +46,13 @@
     if isLocalhost req then request req else respond $ return $
         mkResult 403 "text/html" $ toUTF "403 Forbidden: Try from localhost"-}
         
-fenserveHandler = Handle $ \req -> do
-    state <- get; rq <- getEvent
-    let (result, state') = runFenServe (handleRequest rq) state
-    if rqMethod req `elem` [GET,HEAD] then respond $ return result
-        else if isLocalhost req then do put state'; respond $ return result
-        else if state == state' then respond $ return result
-        else respond $ return $ mkResult 403 "text/html" $ toUTF
+fenserveHandler dir = Handle $ \req -> do
+    node <- get
+    let (result, node', pool) = unsafePerformIO $ runFenServe (handleRequest req) node (Just dir)
+    if (rqMethod req `elem` [GET,HEAD]) then respond $ return result
+      else if isLocalhost req then do put node'; respond $ do writePool pool; return result
+      else if node == node' then respond $ return result
+      else respond $ return $ mkResult 403 "text/html" $ toUTF
                "403 Forbidden: state changes only from localhost at this time"
 
 main :: IO ()
@@ -58,7 +61,10 @@
       (ResourceLimit 180) (ResourceLimit 300)
   setResourceLimit ResourceTotalMemory $ let mb = 1024*1024 in ResourceLimits 
       (ResourceLimit $ 50 * mb) (ResourceLimit $ 100 * mb)
+  pn <- getProgName; let dir = pn++"_storm"
+  createDirectoryIfMissing True dir
+  runFenServe writeEmptyState (error "Main: shouldn't be evaluated") (Just dir)
   stdHTTP [ debugFilter
           --, localhostOnlyFilter
-          , fenserveHandler
+          , fenserveHandler dir
           ]
diff -rN -u old-fenserve/Makefile new-fenserve/Makefile
--- old-fenserve/Makefile	2007-03-26 01:56:17.000000000 +0300
+++ new-fenserve/Makefile	2007-03-26 01:56:17.000000000 +0300
@@ -20,7 +20,7 @@
 	./dist/build/fenserve/fenserve $(ARGS)
 	
 reset:
-	rm -rf fenserve_state fenserve_error.log
+	rm -rf fenserve_state fenserve_storm 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-26 01:56:17.000000000 +0300
+++ new-fenserve/Storm.hs	2007-03-26 01:56:17.000000000 +0300
@@ -21,6 +21,9 @@
 
 import SHA1
 
+import Fenfire.Utils
+
+import Control.Monad
 import Control.Monad.State
 
 import qualified Data.ByteString as ByteString
@@ -32,24 +35,37 @@
 import Data.Maybe (fromMaybe)
 
 newtype BlockId = BlockId { blockId :: String } deriving (Eq,Ord,Show,Read,Typeable)
-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
+-- The poolDir is used to retrieve blocks from the disk, the poolMap
+-- contains blocks that have been created during the processing of the
+-- current request (these will be written if the processing is successful).
+-- If poolDir is Nothing, stuff will be held only in memory.
+data Pool = Pool { poolDir :: Maybe FilePath, 
+                   poolMap :: Map BlockId ByteString }
+type StormIO = StateT Pool IO
+
+runStormIO :: StormIO a -> Maybe FilePath -> IO (a, Pool)
+runStormIO m dir = runStateT m (Pool dir Map.empty)
+                      
+writePool :: Pool -> IO ()
+writePool (Pool (Just d) m) = forM_ (Map.toList m) $ \(bid,bs) ->
+                              ByteString.writeFile (d ++ "/" ++ blockId bid) bs
+writePool _ = error "Storm.writePool: pool must have a directory"
 
 class Monad m => StormMonad m where
     getBlock :: BlockId -> m ByteString
     addBlock :: ByteString -> m BlockId
 
 instance StormMonad StormIO where
-    getBlock bid = get >>= \pool ->
-        return $ fromMaybe (error $ "Storm.getBlock: Block "++show bid
-                                  ++" not in pool "++show (Map.keys pool))
-                           (Map.lookup bid pool)
+    getBlock bid = do
+        pool <- get; case Map.lookup bid (poolMap pool) of
+            Just bytes -> return bytes
+            Nothing -> maybe (error $ "Storm.getBlock: not found: "++show bid)
+               (\dir' -> liftIO $ ByteString.readFile $ dir'++"/"++blockId bid)
+               (poolDir pool)
 
     addBlock body = let id' = BlockId $ sha1 $ ByteString.unpack body
-                     in modify (Map.insert id' body) >> return id'
+                     in modify (u_poolMap $ Map.insert id' body) >> return id'
+        where u_poolMap f p = p { poolMap = f (poolMap p) }
 
 readBlock :: (Read a, StormMonad m) => BlockId -> m a
 readBlock bid = do b <- getBlock bid; return $ f b $ reads $ fromUTF b where




More information about the Fencommits mailing list