{-# OPTIONS_GHC -fglasgow-exts #-}
module Storm 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 SHA1

import Fenfire.Utils

import Control.Monad
import Control.Monad.State

import qualified Data.ByteString as ByteString
import Data.ByteString (ByteString)
import qualified Data.Char as Char
import Data.Dynamic (Typeable)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe)

newtype BlockId = BlockId { blockId :: String } deriving (Eq,Ord,Show,Read,Typeable)
-- 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 = 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 body
                     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
    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, StormMonad m) => a -> m BlockId
writeBlock = addBlock . toUTF . show
    

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