[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