summaryrefslogtreecommitdiff
path: root/tests/examplefiles/AcidStateAdvanced.hs
diff options
context:
space:
mode:
Diffstat (limited to 'tests/examplefiles/AcidStateAdvanced.hs')
-rw-r--r--tests/examplefiles/AcidStateAdvanced.hs209
1 files changed, 209 insertions, 0 deletions
diff --git a/tests/examplefiles/AcidStateAdvanced.hs b/tests/examplefiles/AcidStateAdvanced.hs
new file mode 100644
index 00000000..9e3e7718
--- /dev/null
+++ b/tests/examplefiles/AcidStateAdvanced.hs
@@ -0,0 +1,209 @@
+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving
+ , MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TemplateHaskell
+ , TypeFamilies, FlexibleInstances #-}
+module Main where
+import Control.Applicative (Applicative, Alternative, (<$>))
+import Control.Exception.Lifted (bracket)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad (MonadPlus, mplus)
+import Control.Monad.Reader (MonadReader, ReaderT(..), ask)
+import Control.Monad.Trans (MonadIO(..))
+import Data.Acid ( AcidState(..), EventState(..), EventResult(..)
+ , Query(..), QueryEvent(..), Update(..), UpdateEvent(..)
+ , IsAcidic(..), makeAcidic, openLocalState
+ )
+import Data.Acid.Local ( createCheckpointAndClose
+ , openLocalStateFrom
+ )
+import Data.Acid.Advanced (query', update')
+import Data.Maybe (fromMaybe)
+import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)
+import Data.Data (Data, Typeable)
+import Data.Lens ((%=), (!=))
+import Data.Lens.Template (makeLens)
+import Data.Text.Lazy (Text)
+import Happstack.Server ( Happstack, HasRqData, Method(GET, POST), Request(rqMethod)
+ , Response
+ , ServerPartT(..), WebMonad, FilterMonad, ServerMonad
+ , askRq, decodeBody, dir, defaultBodyPolicy, lookText
+ , mapServerPartT, nullConf, nullDir, ok, simpleHTTP
+ , toResponse
+ )
+import Prelude hiding (head, id)
+import System.FilePath ((</>))
+import Text.Blaze ((!))
+import Text.Blaze.Html4.Strict (body, head, html, input, form, label, p, title, toHtml)
+import Text.Blaze.Html4.Strict.Attributes (action, enctype, for, id, method, name, type_, value)
+class HasAcidState m st where
+ getAcidState :: m (AcidState st)
+query :: forall event m.
+ ( Functor m
+ , MonadIO m
+ , QueryEvent event
+ , HasAcidState m (EventState event)
+ ) =>
+ event
+ -> m (EventResult event)
+query event =
+ do as <- getAcidState
+ query' (as :: AcidState (EventState event)) event
+update :: forall event m.
+ ( Functor m
+ , MonadIO m
+ , UpdateEvent event
+ , HasAcidState m (EventState event)
+ ) =>
+ event
+ -> m (EventResult event)
+update event =
+ do as <- getAcidState
+ update' (as :: AcidState (EventState event)) event
+-- | bracket the opening and close of the `AcidState` handle.
+
+-- automatically creates a checkpoint on close
+withLocalState :: (MonadBaseControl IO m, MonadIO m, IsAcidic st, Typeable st) =>
+ Maybe FilePath -- ^ path to state directory
+ -> st -- ^ initial state value
+ -> (AcidState st -> m a) -- ^ function which uses the `AcidState` handle
+ -> m a
+withLocalState mPath initialState =
+ bracket (liftIO $ (maybe openLocalState openLocalStateFrom mPath) initialState)
+ (liftIO . createCheckpointAndClose)
+-- State that stores a hit count
+
+data CountState = CountState { _count :: Integer }
+ deriving (Eq, Ord, Data, Typeable, Show)
+
+$(deriveSafeCopy 0 'base ''CountState)
+$(makeLens ''CountState)
+
+initialCountState :: CountState
+initialCountState = CountState { _count = 0 }
+
+incCount :: Update CountState Integer
+incCount = count %= succ
+
+$(makeAcidic ''CountState ['incCount])
+-- State that stores a greeting
+data GreetingState = GreetingState { _greeting :: Text }
+ deriving (Eq, Ord, Data, Typeable, Show)
+
+$(deriveSafeCopy 0 'base ''GreetingState)
+$(makeLens ''GreetingState)
+
+initialGreetingState :: GreetingState
+initialGreetingState = GreetingState { _greeting = "Hello" }
+
+getGreeting :: Query GreetingState Text
+getGreeting = _greeting <$> ask
+
+setGreeting :: Text -> Update GreetingState Text
+setGreeting txt = greeting != txt
+
+$(makeAcidic ''GreetingState ['getGreeting, 'setGreeting])
+data Acid = Acid { acidCountState :: AcidState CountState
+ , acidGreetingState :: AcidState GreetingState
+ }
+
+withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a
+withAcid mBasePath action =
+ let basePath = fromMaybe "_state" mBasePath
+ in withLocalState (Just $ basePath </> "count") initialCountState $ \c ->
+ withLocalState (Just $ basePath </> "greeting") initialGreetingState $ \g ->
+ action (Acid c g)
+newtype App a = App { unApp :: ServerPartT (ReaderT Acid IO) a }
+ deriving ( Functor, Alternative, Applicative, Monad, MonadPlus, MonadIO
+ , HasRqData, ServerMonad ,WebMonad Response, FilterMonad Response
+ , Happstack, MonadReader Acid)
+
+runApp :: Acid -> App a -> ServerPartT IO a
+runApp acid (App sp) = mapServerPartT (flip runReaderT acid) sp
+instance HasAcidState App CountState where
+ getAcidState = acidCountState <$> ask
+
+instance HasAcidState App GreetingState where
+ getAcidState = acidGreetingState <$> ask
+page :: App Response
+page =
+ do nullDir
+ g <- greet
+ c <- update IncCount -- ^ a CountState event
+ ok $ toResponse $
+ html $ do
+ head $ do
+ title "acid-state demo"
+ body $ do
+ form ! action "/" ! method "POST" ! enctype "multipart/form-data" $ do
+ label "new message: " ! for "msg"
+ input ! type_ "text" ! id "msg" ! name "greeting"
+ input ! type_ "submit" ! value "update message"
+ p $ toHtml g
+ p $ do "This page has been loaded "
+ toHtml c
+ " time(s)."
+ where
+ greet =
+ do m <- rqMethod <$> askRq
+ case m of
+ POST ->
+ do decodeBody (defaultBodyPolicy "/tmp/" 0 1000 1000)
+ newGreeting <- lookText "greeting"
+ update (SetGreeting newGreeting) -- ^ a GreetingState event
+ return newGreeting
+ GET ->
+ do query GetGreeting -- ^ a GreetingState event
+main :: IO ()
+main =
+ withAcid Nothing $ \acid ->
+ simpleHTTP nullConf $ runApp acid page
+newtype FooState = FooState { foo :: Text }
+ deriving (Eq, Ord, Data, Typeable, SafeCopy)
+
+initialFooState :: FooState
+initialFooState = FooState { foo = "foo" }
+
+askFoo :: Query FooState Text
+askFoo = foo <$> ask
+
+$(makeAcidic ''FooState ['askFoo])
+fooPlugin :: (Happstack m, HasAcidState m FooState) => m Response
+fooPlugin =
+ dir "foo" $ do
+ txt <- query AskFoo
+ ok $ toResponse txt
+data Acid' = Acid' { acidCountState' :: AcidState CountState
+ , acidGreetingState' :: AcidState GreetingState
+ , acidFooState' :: AcidState FooState
+ }
+withAcid' :: Maybe FilePath -> (Acid' -> IO a) -> IO a
+withAcid' mBasePath action =
+ let basePath = fromMaybe "_state" mBasePath
+ in withLocalState (Just $ basePath </> "count") initialCountState $ \c ->
+ withLocalState (Just $ basePath </> "greeting") initialGreetingState $ \g ->
+ withLocalState (Just $ basePath </> "foo") initialFooState $ \f ->
+ action (Acid' c g f)
+newtype App' a = App' { unApp' :: ServerPartT (ReaderT Acid' IO) a }
+ deriving ( Functor, Alternative, Applicative, Monad, MonadPlus, MonadIO
+ , HasRqData, ServerMonad ,WebMonad Response, FilterMonad Response
+ , Happstack, MonadReader Acid')
+
+instance HasAcidState App' FooState where
+ getAcidState = acidFooState' <$> ask
+fooAppPlugin :: App' Response
+fooAppPlugin = fooPlugin
+fooReaderPlugin :: ReaderT (AcidState FooState) (ServerPartT IO) Response
+fooReaderPlugin = fooPlugin
+instance HasAcidState (ReaderT (AcidState FooState) (ServerPartT IO)) FooState where
+ getAcidState = ask
+withFooPlugin :: (MonadIO m, MonadBaseControl IO m) =>
+ FilePath -- ^ path to state directory
+ -> (ServerPartT IO Response -> m a) -- ^ function that uses fooPlugin
+ -> m a
+withFooPlugin basePath f =
+ do withLocalState (Just $ basePath </> "foo") initialFooState $ \fooState ->
+ f $ runReaderT fooReaderPlugin fooState
+main' :: IO ()
+main' =
+ withFooPlugin "_state" $ \fooPlugin' ->
+ withAcid Nothing $ \acid ->
+ simpleHTTP nullConf $ fooPlugin' `mplus` runApp acid page
View Lorry Controller Status