{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Snap.Snaplet.AcidState
( Acid
, HasAcid(..)
, acidInit
, acidInit'
, update
, query
, createCheckpoint
, closeAcidState
, module Data.Acid
) where
import qualified Data.Acid as A
import qualified Data.Acid.Advanced as A
import Data.Acid hiding (update
,query
,createCheckpoint
,closeAcidState
)
import Data.Typeable
import Data.Text (Text)
import Snap
------------------------------------------------------------------------------
-- |
description :: Text
description = "Snaplet providing acid-state functionality"
------------------------------------------------------------------------------
-- | Data type holding acid-state snaplet data.
data Acid st = Acid
{ _acidStore :: A.AcidState st
}
------------------------------------------------------------------------------
-- | Initializer that stores the state in the "state/[typeOf state]/"
-- directory.
acidInit :: (A.IsAcidic st, Typeable st)
=> st
-- ^ Initial state to be used if
-> SnapletInit b (Acid st)
acidInit initial = makeSnaplet "acid-state" description Nothing $ do
st <- liftIO $ A.openLocalState initial
return $ Acid st
------------------------------------------------------------------------------
-- | Initializer allowing you to specify the location of the acid-state store.
acidInit' :: A.IsAcidic st
=> FilePath
-- ^ Location of the acid-state store on disk
-> st
-- ^ Initial state to be used if
-> SnapletInit b (Acid st)
acidInit' location initial = makeSnaplet "acid-state" description Nothing $ do
st <- liftIO $ A.openLocalStateFrom location initial
return $ Acid st
------------------------------------------------------------------------------
-- | Type class standardizing a context that holds an AcidState.
--
-- You can minimize boilerplate in your application by adding an instance like
-- the following:
--
-- > data App = App { ... _acid :: Snaplet (Acid MyState) ... }
-- > instance HasAcid App MyState where
-- > getAcidStore = getL (snapletValue . acid)
class HasAcid myState acidState where
getAcidStore :: myState -> (Acid acidState)
instance HasAcid (Acid st) st where
getAcidStore = id
getAcidState :: forall a st. HasAcid a st => a -> AcidState st
getAcidState = _acidStore . getAcidStore
------------------------------------------------------------------------------
-- | Wrapper for acid-state's update function that works for arbitrary
-- instances of HasAcid.
update :: (MonadState s m, HasAcid s (A.MethodState event),
UpdateEvent event, MonadIO m)
=> event -> m (EventResult event)
update event = do
st <- gets getAcidState
liftIO $ A.update st event
------------------------------------------------------------------------------
-- | Wrapper for acid-state's query function that works for arbitrary
-- instances of HasAcid.
query :: (HasAcid s (A.MethodState event),
MonadIO m, QueryEvent event, MonadState s m)
=> event -> m (EventResult event)
query event = do
st <- gets getAcidState
liftIO $ A.query st event
------------------------------------------------------------------------------
-- | Wrapper for acid-state's createCheckpoint function that works for
-- arbitrary instances of HasAcid.
createCheckpoint = do
st <- gets getAcidState
liftIO $ A.createCheckpoint st
------------------------------------------------------------------------------
-- | Wrapper for acid-state's closeAcidState function that works for
-- arbitrary instances of HasAcid.
closeAcidState = do
st <- gets getAcidState
liftIO $ A.closeAcidState st