mahoro-0.1.1: DBState.hs

{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,
  TypeSynonymInstances, MultiParamTypeClasses, TypeFamilies,
  FlexibleContexts #-}

-- | DBState.hs
-- A module which contain happstack state instances.

module DBState where

import DB

import Happstack.State
import Data.Typeable

import Control.Monad.State
import Control.Monad.Reader
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq

---

data DBWrap = DBWrap DB
              deriving (Show, Typeable)

instance Version URL
$(deriveSerialize ''URL)

instance Version JID
$(deriveSerialize ''JID)

instance Version (Seq.Seq a) where mode = Primitive
instance Serialize a => Serialize (Seq.Seq a) where
    getCopy = contain $ fmap Seq.fromList safeGet
    putCopy = contain . safePut . F.toList

instance Version DBWrap
$(deriveSerialize ''DBWrap)

---

addThread' url jid  = processDB $ addThread url jid
delThread' url jid  = processDB $ delThread url jid
delThreadAll' url   = processDB $ delThreadAll url
bye' jid            = processDB $ bye jid
setDescription' d url jid
                    = processDB $ setDescription url jid d
updateThread' url l = processDB $ updateThread url l

processDB :: DBProcess -> Update DBWrap String
processDB f = do
    DBWrap db <- get
    let (msg, db') = f db
    put $ DBWrap db'
    return msg

getDB :: Query DBWrap DB
getDB = do
    DBWrap db <- ask
    return db

---

$(mkMethods ''DBWrap ['addThread', 'delThread',
                      'delThreadAll', 'bye',
                      'setDescription', 'updateThread',
                      'getDB])

instance Component DBWrap where
    type Dependencies DBWrap = End
    initialValue = DBWrap newDB