* 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
|
module Main where
|
||||||
|
|
||||||
import Control.Applicative ((<$>), (<*>), optional, pure)
|
import Control.Applicative ((<$>), (<*>), optional, pure)
|
||||||
import Control.Monad (msum)
|
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.ByteString.Char8 (ByteString)
|
||||||
|
import Data.Data (Data, Typeable)
|
||||||
|
import Data.Monoid (mempty)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Time
|
import Data.Time
|
||||||
|
import Data.SafeCopy (base, deriveSafeCopy)
|
||||||
import Database.CouchDB
|
import Database.CouchDB
|
||||||
import Happstack.Server
|
import Happstack.Server
|
||||||
import Network.CGI (liftIO)
|
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 Text.JSON.Generic
|
||||||
import System.Locale (defaultTimeLocale)
|
import System.Locale (defaultTimeLocale)
|
||||||
|
|
||||||
import Blog
|
import Blog
|
||||||
import Locales
|
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 :: BodyPolicy
|
||||||
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
|
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue