* initializing Acid sessions
* guardSession
This commit is contained in:
parent
7b8f952413
commit
bbdfa3eae2
1 changed files with 20 additions and 4 deletions
24
src/Main.hs
24
src/Main.hs
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue