* initializing Acid sessions

* guardSession
This commit is contained in:
"Vincent Ambo ext:(%22) 2012-03-08 11:42:10 +01:00
parent 7b8f952413
commit bbdfa3eae2

View file

@ -5,7 +5,8 @@
module Main where module Main where
import Control.Applicative ((<$>), (<*>), optional, pure) import Control.Applicative ((<$>), (<*>), optional, pure)
import Control.Monad (msum) import Control.Exception (bracket)
import Control.Monad (msum, mzero, when, unless)
import Control.Monad.State (get, put) import Control.Monad.State (get, put)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Data.Acid import Data.Acid
@ -49,16 +50,31 @@ querySessions = sessions <$> ask
$(makeAcidic ''SessionState ['addSession, 'querySessions]) $(makeAcidic ''SessionState ['addSession, 'querySessions])
guardSession :: AcidState SessionState -> ServerPartT IO ()
guardSession acid = do
sID <- lookCookieValue "session"
sDate <- readCookieValue "sdate"
cSessions <- query' acid QuerySessions
cDate <- liftIO $ currentSeconds
when (not $ elem (sID, sDate) cSessions)
mzero
when (32400 > (cDate - sDate))
mzero
{- Server -}
tmpPolicy :: BodyPolicy tmpPolicy :: BodyPolicy
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000) tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
main :: IO() main :: IO()
main = do main = do
putStrLn ("TazBlog " ++ version ++ " in Haskell starting") putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
simpleHTTP nullConf tazBlog bracket (openLocalState initialSession)
(createCheckpointAndClose)
(\acid -> simpleHTTP nullConf $ tazBlog acid)
tazBlog :: ServerPart Response tazBlog :: AcidState SessionState -> ServerPart Response
tazBlog = do tazBlog acid = do
msum [ dir (show DE) $ blogHandler DE msum [ dir (show DE) $ blogHandler DE
, dir (show EN) $ blogHandler EN , dir (show EN) $ blogHandler EN
, do nullDir , do nullDir