* initial work on AcidState session storage (http://happstack.com/docs/crashcourse/AcidState.html)
This commit is contained in:
parent
c880a6092c
commit
7b8f952413
1 changed files with 33 additions and 7 deletions
40
src/Main.hs
40
src/Main.hs
|
@ -1,28 +1,54 @@
|
|||
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, GeneralizedNewtypeDeriving,
|
||||
DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell,
|
||||
TypeFamilies, RecordWildCards #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Applicative ((<$>), (<*>), optional, pure)
|
||||
import Control.Monad (msum)
|
||||
import Data.Monoid (mempty)
|
||||
import Control.Monad.State (get, put)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Acid
|
||||
import Data.Acid.Advanced
|
||||
import Data.Acid.Local
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Data (Data, Typeable)
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
import Database.CouchDB
|
||||
import Happstack.Server
|
||||
import Network.CGI (liftIO)
|
||||
import Text.Blaze (toValue, preEscapedString)
|
||||
import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label)
|
||||
import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value)
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
import Text.JSON.Generic
|
||||
import System.Locale (defaultTimeLocale)
|
||||
|
||||
import Blog
|
||||
import Locales
|
||||
|
||||
{-session handling functions-}
|
||||
|
||||
data SessionState = SessionState { sessions :: [(String, Integer)] } -- id/date
|
||||
deriving (Eq, Ord, Read, Show, Data, Typeable)
|
||||
|
||||
$(deriveSafeCopy 0 'base ''SessionState)
|
||||
|
||||
initialSession :: SessionState
|
||||
initialSession = SessionState []
|
||||
|
||||
addSession :: (String, Integer) -> Update SessionState [(String, Integer)]
|
||||
addSession newS = do
|
||||
s@SessionState{..} <- get
|
||||
let newSessions = newS : sessions
|
||||
put $ s{ sessions = newSessions }
|
||||
return newSessions
|
||||
|
||||
querySessions :: Query SessionState [(String, Integer)]
|
||||
querySessions = sessions <$> ask
|
||||
|
||||
$(makeAcidic ''SessionState ['addSession, 'querySessions])
|
||||
|
||||
tmpPolicy :: BodyPolicy
|
||||
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
|
||||
|
||||
|
|
Loading…
Reference in a new issue