Back to Table of Contents

acid-state

acid-state is a NoSQL, RAM-cloud, persistent data store. One of attractive feature is that it's designed to store arbitrary Haskell datatypes and queries are written using plain old Haskell code. This means you do not have to learn a special query language, or figure out how to turn your beautiful Haskell datastructures into some limited set of ints and strings.

acid-state and safecopy are the successors to the old happstack-state and happstack-data libraries. You can learn more at the acid-state homepage. acid-state is now completely independent from Happstack and can be used with any web framework. However, Happstack is still committed to the improvement and promotion of acid-state.

Apps written using happstack-state can be migrated to use acid-state relatively easily. Details on the process or documented here.

How acid-state works

A very simple way to model a database in Haskell would be to create a datatype to represent your data and then store that data in a mutable, global variable, such as a global IORef. Then you could just write normal Haskell functions to query that value and update it. No need to learn a special query language. No need to marshal your types from expressive Haskell datatypes to some limited set of types supported by an external database.

That works great.. as long as your application is only single-threaded, and as long as it never crashes, and never needs to be restarted. But, for a web application, those requires are completely unacceptable. The idea is still appealing though. acid-state provides a practical implementation of that idea which actually implements the ACID guarantees that you may be familiar with from traditional relational databases such as MySQL, postgres, etc.

In acid-state we start by defining a type that represents the state we wish to store. Then we write a bunch of pure functions that query that value or which return an updated value. However, we do not call those functions directly. Instead we keep the value inside an AcidState handle, and we call our functions indirectly by using the update and query functions. This allows acid-state to transparently log update events to disk, to ensure that update and query events run automatically and in isolation, etc. It is allows us to make remote API calls, and, eventually, replication and multimaster.

Note that when we say acid-state is pure, we are referring specifically to the fact that the functions we write to perform updates and queries are pure. acid-state itself must do IO in order to coordinate events from multiple threads, log events to disk, perform remote queries, etc.

Now that you have a vague idea how acid-state works, let's clarify it by looking at some examples.

acid-state counter

Our first example is a very simple hit counter app.

First a bunch of LANGUAGE pragmas and imports:

> {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving, 
>   MultiParamTypeClasses, TemplateHaskell, TypeFamilies, RecordWildCards #-}
>
> module Main where
>
> import Control.Applicative  ( (<$>) )
> import Control.Exception    ( bracket )
> import Control.Monad        ( msum )
> import Control.Monad.Reader ( ask )
> import Control.Monad.State  ( get, put )
> import Data.Data            ( Data, Typeable )
> import Happstack.Server     ( Response, ServerPart, dir, nullDir, nullConf, ok
>                             , simpleHTTP, toResponse )
> import Data.Acid            ( AcidState, Query, Update, makeAcidic, openLocalState )
> import Data.Acid.Advanced   ( query', update' )
> import Data.Acid.Local      ( createCheckpointAndClose )
> import Data.SafeCopy        ( base, deriveSafeCopy )

Next we define a type that we wish to store in our state. In this case we just create a simple record with a single field count:

> data CounterState = CounterState { count :: Integer }
>     deriving (Eq, Ord, Read, Show, Data, Typeable)
>
> $(deriveSafeCopy 0 'base ''CounterState)
>

deriveSafeCopy creates an instance of the SafeCopy class for CounterState. SafeCopy is class for versioned serialization, deserilization, and migration. The SafeCopy class is a bit like a combination of the Read and Show classes, except that it converts the data to a compact ByteString representation, and it includes version information in case the type changes and old data needs to be migrated.

Since this is the first version of the CounterState type, we give it version number 0 and declare it to be the base type. Later if we change the type, we will increment the version to 1 and declare it to be an extension of a previous type. We will also provide a migration instance to migrate the old type to the new type. The migration will happen automatically when the old state is read. For more information on SafeCopy, base, extension and migration see the haddock docs. (A detailed section on migration for the Crash Course is planned, but not yet written).

If you are not familiar with Template Haskell be sure to read this brief intro to Template Haskell

Next we will define an initial value that is suitable for initializing the CounterState state.

> initialCounterState :: CounterState
> initialCounterState = CounterState 0

Now that we have our types, we can define some update and query functions.

First let's define an update function which increments the count and returns the incremented value:

> incCountBy :: Integer -> Update CounterState Integer
> incCountBy n =
>     do c@CounterState{..} <- get
>        let newCount = count + n
>        put $ c { count = newCount }
>        return newCount
>

In this line:

> c@CounterState{..} <- get

we are using the RecordWildCards extension. The {..} binds all the fields of the record to symbols with the same name. That is why in the next line we can just write count instead of (count c). Using RecordWildCards here is completely optional, but tends to make the code less cluttered, and easier to read.

Also notice that we are using the get and put functions from MonadState to get and put the ACID state. The Update monad is basically an enchanced version of the State monad. For the moment it is perhaps easiest to just pretend that incCountBy has the type signature:

> incCountBy :: Integer -> State CounterState Integer

And then it becomes clearer that incCountBy is just a simple function in the State monad which updates CounterState and returns an Integer.

Note that even though we are using a monad here.. the code is still pure. If we wanted we could have required the update function to have a type like this instead:

> incCountBy :: Integer -> CounterState -> (CounterState, Integer)

In that version, the current state is explicitly passed in, and the function explicitly returns the updated state. The monadic version does the same thing, but uses >>= to make the plumbing easier. This makes the monadic version easier to read and reduces mistakes.

When we later use the update function to call incCountBy, incCountBy will be run in an isolated manner (the 'I' in ACID). That means that you do not need to worry about some other thread modifying the CounterState between the get and the put. It will also be run atomically (the 'A' in ACID), meaning that either the whole function will run or it will not run at all. If the server is killed mid-transaction, the transaction will either be completely applied or not applied at all.

You may also note that Update (and State) are not instances of the MonadIO class. This means you can not perform IO inside the update. This is by design. In order to ensure Durability and to support replication, events need to be pure. That allows us to be confident that if the event log has to be replayed -- it will result in the same state we had before.

We can also define a query which reads the state, and does not update it:

> peekCount :: Query CounterState Integer
> peekCount = count <$> ask
>

The Query monad is an enhanced version of the Reader monad. So we can pretend that peekCount has the type:

> peekCount :: Reader CounterState Integer

Although we could have just used get in the Update monad, it is better to use the Query monad if you are doing a read-only operation because it will not block other database transactions. It also lets the user calling the function know that the database will not be affected.

Next we have to turn the update and query functions into acid-state events. This is almost always done by using the template haskell function makeAcidic

> $(makeAcidic ''CounterState ['incCountBy, 'peekCount])
>

The makeAcidic function creates a bunch of boilerplate types and type class instances. If you want to see what is happening under the hood, check out the examples here. The examples with names like, HelloWorldNoTH.hs show how to implement the boilerplate by hand. In practice, you will probably never want to or need to do this. But you may find it useful to have a basic understanding of what is happening. You could also use the -ddump-splices flag to ghc to see the auto-generated instances -- but the lack of formatting makes it difficult to read.

Here we actually call our query and update functions:

> handlers :: AcidState CounterState -> ServerPart Response
> handlers acid =
>     msum [ dir "peek" $ do c <- query' acid PeekCount
>                            ok $ toResponse $ "peeked at the count and saw: " ++ show c
>          , do nullDir
>               c <- update' acid (IncCountBy 1)
>               ok $ toResponse $ "New count is: " ++ show c
>
>          ]
>

Note that we do not call the incCountBy and peekCount functions directly. Instead we invoke them using the update' and query' functions:

> update' :: (UpdateEvent event, MonadIO m) =>
>            AcidState (EventState event) -- ^ handle to acid-state
>         -> event                        -- ^ update event to execute
>         -> m (EventResult event)
> query'  :: (QueryEvent event , MonadIO m) =>
>            AcidState (EventState event) -- ^ handle to acid-state
>         -> event                        -- ^ query event to execute
>         -> m (EventResult event)

Thanks to makeAcidic, the functions that we originally defined now have types with the same name, but starting with an uppercase letter:

> data PeekCount  = PeekCount
> data IncCountBy = IncCountBy Integer

The arguments to the constructors are the same as the arguments to the original function.

So now we can decipher the meaning of the type for the update' and query' functions. For example, in this code:

> c <- update' acid (IncCountBy 1)

The event is (IncCountBy 1) which has the type IncCountBy. Since there is an UpdateEvent IncCountBy instance, we can use this event with the update' function. That gives us:

> update' :: (UpdateEvent IncCountBy, MonadIO m) =>
>            AcidState (EventState IncCountBy)
>         -> IncCountBy
>         -> m (EventResult IncCountBy)

EventState is a type function. EventState IncCountBy results in the type CounterState. So that reduces to AcidState CounterState. So, we see that we can not accidently call the IncCountBy event against an acid state handle of the wrong type.

EventResult is also a type function. EventResult IncCountBy is Integer, as we would expect from the type signature for IncCountBy.

As mentioned earlier, the underlying update and query events we created are pure functions. But, in order to have a durable database (aka, be able to recover after powerloss, etc) we do need to log these pure events to disk so that we can reply them in the event of a recovery. So, rather than invoke our update and query events directly, we call them indirectly via the update and query functions. update and query interact with the acid-state system to ensure that the acid-state events are properly logged, called in the correct order, run atomitically and isolated, etc.

There is no way in Haskell to save a function to disk or send it over the network. So, acid-state has to cheat a little. Instead of storing the function, it just stores the name of the function and the value of its arguments. That is what the IncCountBy type is for -- it is the value that can be serialized and saved to disk or sent over the network.

Finally, we have our main function:

> main :: IO ()
> main =
>     do bracket (openLocalState initialCounterState)
>                (createCheckpointAndClose)
>                (\acid ->
>                     simpleHTTP nullConf (handlers acid))

openLocalState starts up acid-state and returns a handle. If existing state is found on the disk, it will be automatically restored and used. If no pre-existing state is found, then initialCounterState will be used. openLocalState stores data in a directory named state/[typeOf state]. In this example, that would be, state/CounterState. If you want control over where the state information is stored use openLocalStateFrom instead.

The shutdown sequence creates a checkpoint when the server exits. This is good practice because it helps the server start faster, and makes migration go more smoothly. Calling createCheckpointAndClose is not critical to data integrity. If the server crashes unexpectedly, it will replay all the logged transactions (Durability). However, it is a good idea to create a checkpoint on close. If you change an existing update event, and then tried to replay old versions of the event, things would probably end poorly. However, restoring from a checkpoint does not require the old events to be replayed. Hence, always creating a checkpoint on shutdown makes it easier to upgrade the server.

[Source code for the app is here.]

IxSet: a set with multiple indexed keys

To use IxSet you will need to install the optional ixset package.

In the first acid-state example we stored a single value. But in real database we typically need to store a large collection of records. And we want to be able to efficiently search and update those records. For simple key/value pairs we can use Data.Map. However, in practice, we often want to have multiple keys. That is what IxSet set offers -- a set-like type which can be indexed by multiple keys.

Instead of having:

> Set Foo

we will have:

> IxSet Foo

with the ability to do queries based on the indices of Foo, which are defined using the Indexable type-class.

IxSet can be found here on hackage.

In this example, we will use IxSet to create a mini-blog.

> {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards
>   , TemplateHaskell, TypeFamilies, OverloadedStrings #-}
> module Main where
> import Control.Applicative  ((<$>), optional)
> import Control.Exception    (bracket)
> import Control.Monad        (msum, mzero)
> import Control.Monad.Reader (ask)
> import Control.Monad.State  (get, put)
> import Control.Monad.Trans  (liftIO)
> import Data.Acid            (AcidState, Update, Query, makeAcidic, openLocalState)
> import Data.Acid.Advanced   (update', query')
> import Data.Acid.Local      (createCheckpointAndClose)
> import Data.Data            (Data, Typeable)
> import Data.IxSet           ( Indexable(..), IxSet(..), (@=), Proxy(..), getOne
>                             , ixFun, ixSet )
> import qualified Data.IxSet as IxSet
> import Data.SafeCopy        (SafeCopy, base, deriveSafeCopy)
> import Data.Text            (Text)
> import Data.Text.Lazy       (toStrict)
> import qualified Data.Text  as Text
> import Data.Time            (UTCTime(..), getCurrentTime)
> import Happstack.Server     ( ServerPart, Method(POST, HEAD, GET), Response, decodeBody
>                             , defaultBodyPolicy, dir, lookRead, lookText, method
>                             , notFound, nullConf, nullDir, ok, seeOther, simpleHTTP
>                             , toResponse)
> import           Text.Blaze ((!), Html)
> import qualified Text.Blaze.Html4.Strict as H
> import qualified Text.Blaze.Html4.Strict.Attributes as A

The first thing we are going to need is a type to represent a blog post.

It is convenient to assign a unique id to each blog post so that it can be easily referenced in urls and easily queried in the IxSet. In order to keep ourselves sane, we can create a newtype wrapper around an Integer instead of just using a nameless Integer.

> newtype PostId = PostId { unPostId :: Integer }
>     deriving (Eq, Ord, Data, Enum, Typeable, SafeCopy)

Note that in addition to deriving normal classes like Eq and Ord, we also derive an instance of SafeCopy. This is not required by IxSet itself, but since we want to store the our blog posts in acid-state we will need it there.

A blog post will be able to have two statuses 'draft' and 'published'. We could use a boolean value, but it is easier to understand what Draft and Published mean instead of trying to remember what True and False mean. Additionally, we can easily extend the type with additional statuses later.

> data Status =
>     Draft
>   | Published
>     deriving (Eq, Ord, Data, Typeable)
>
> $(deriveSafeCopy 0 'base ''Status)

And now we can create a simple record which represents a single blog post:

> data Post = Post
>     { postId  :: PostId
>     , title   :: Text
>     , author  :: Text
>     , body    :: Text
>     , date    :: UTCTime
>     , status  :: Status
>     , tags    :: [Text]
>     }
>     deriving (Eq, Ord, Data, Typeable)
>
> $(deriveSafeCopy 0 'base ''Post)

Each IxSet key needs to have a unique type. Looking at Post it seems like that could be trouble -- because we have multiple fields which all have the type Text. Fortunately, we can easily get around this by introducing some newtypes which are used for indexing.

> newtype Title     = Title Text    deriving (Eq, Ord, Data, Typeable, SafeCopy)
> newtype Author    = Author Text   deriving (Eq, Ord, Data, Typeable, SafeCopy)
> newtype Tag       = Tag Text      deriving (Eq, Ord, Data, Typeable, SafeCopy)
> newtype WordCount = WordCount Int deriving (Eq, Ord, Data, Typeable, SafeCopy)

Defining the indexing keys

We are now ready to create an instance of the Indexable class. This is the class that defines the keys for a Post so that we can store it in an IxSet:

> instance Indexable Post where
>     empty = ixSet [ ixFun $ \bp -> [ postId bp ]
>                   , ixFun $ \bp -> [ Title  $ title bp  ]
>                   , ixFun $ \bp -> [ Author $ author bp ]
>                   , ixFun $ \bp -> [ status bp ]
>                   , ixFun $ \bp -> map Tag (tags bp)
>                   , ixFun $ (:[]) . date  -- point-free, just for variety
>                   , ixFun $ \bp -> [ WordCount (length $ Text.words $ body bp) ]
>                   ]
>

In the Indexable Post instance we create a list of Ix Post values by using the ixFun helper function:

> ixFun :: (Ord b, Typeable b) => (a -> [b]) -> Ix a

We pass to ixFun a key extraction function. For example, in this line:

> ixFun $ \bp -> [ postId bp ]

we extract the PostId from a Post. Note that we return a list of keys values not just a single key. That is because a single entry might have several keys for a specific type. For example, a Post has a list of tags. But, we want to be able to search for posts that match a specific tag. So, we index each tag separately:

> ixFun $ \bp -> map Tag (tags bp)

Note that the keys do not have to directly correspond to a field in the record. We can perform calculations to create arbitrary keys. For example, the WordCount key calculates the number of words in a post:

> ixFun $ \bp -> [ WordCount (length $ Text.words $ body bp) ]

For the Title and Author keys we add the newtype wrapper.

Now we will create the record that we will use with acid-state to hold the IxSet Post and other state information.

> data Blog = Blog
>     { nextPostId :: PostId
>     , posts      :: IxSet Post
>     }
>     deriving (Data, Typeable)
>
> $(deriveSafeCopy 0 'base ''Blog)
>
> initialBlogState :: Blog
> initialBlogState =
>     Blog { nextPostId = PostId 1
>          , posts      = empty
>          }

IxSet does not (currently) provide any auto-increment functionality for indexes, so we have to keep track of what the next available PostId is ourselves. That is why we have the nextPostId field. (Feel free to submit a patch that adds an auto-increment feature to IxSet!).

Note that in initialBlogState the nextPostId is initialized to 1 not 0. Sometimes we want to create a Post that is not yet in the database, and hence does not have a valid PostId. I like to reserve PostId 0 to mean uninitialized. If I ever see a PostId 0 stored in the database, I know there is a bug in my code.

Inserting a Record

Next we will create some update and query functions for our acid-state database.

> -- | create a new, empty post and add it to the database
> newPost :: UTCTime -> Update Blog Post
> newPost pubDate =
>     do b@Blog{..} <- get
>        let post = Post { postId = nextPostId
>                        , title  = Text.empty
>                        , author = Text.empty
>                        , body   = Text.empty
>                        , date   = pubDate
>                        , status = Draft
>                        , tags   = []
>                        }
>        put $ b { nextPostId = succ nextPostId
>                , posts      = IxSet.insert post posts
>                }
>        return post

Nothing in that function should be too surprising. We have to pass in UTCTime, because we can not do IO in the update function. Because PostId is an instance of Enum we can use succ to increment it. To add the new post to the IxSet we use IxSet.insert.

> insert :: (Typeable a, Ord a, Indexable a) => a -> IxSet a -> IxSet a

Updating a Record

Next we have a function that updates an existing Post in the database with a newer version:

> -- | update the post in the database (indexed by PostId)
> updatePost :: Post -> Update Blog ()
> updatePost updatedPost =
>     do b@Blog{..} <- get
>        put $ b { posts = IxSet.updateIx (postId updatedPost) updatedPost posts
>                }

Note that instead of insert we use updateIx:

> updateIx :: (Indexable a, Ord a, Typeable a, Typeable key) =>
>             key
>          -> a
>          -> IxSet a
>          -> IxSet a

The first argument to updateIx is a key that maps to the post we want to updated in the database. The key must uniquely identify a single entry in the database. In this case we use our primary key, PostId.

Looking up a value by its indexed key

Next we have some query functions.

> postById :: PostId -> Query Blog (Maybe Post)
> postById pid =
>      do Blog{..} <- ask
>         return $ getOne $ posts @= pid

postById is used to lookup a specific post by its PostId. This is our first example of querying an IxSet. Here we use the equals query operator:

> (@=) :: (Typeable key, Ord a, Typeable a, Indexable a) => IxSet a -> key -> IxSet a

It takes an IxSet and filters it to produce a new IxSet which only contains values that match the specified key. In this case, we have specified the primary key (PostId), so we expect exactly zero or one values in the resulting IxSet. We can use getOne to turn the result into a simple Maybe value:

> getOne :: Ord a => IxSet a -> Maybe a

Ordering the Results and the Proxy type

Here is a query function that gets all the posts with a specific status (Published vs Draft) and sorts them in reverse chronological order (aka, newest first):

> postsByStatus :: Status -> Query Blog [Post]
> postsByStatus status =
>     do Blog{..} <- ask
>        return $ IxSet.toDescList (Proxy :: Proxy UTCTime) $ posts @= status

We use the @= operator again to select just the posts which have the matching status. Since the publication date is a key (UTCTime) we can use toDescList to return a sorted list:

> toDescList :: (Typeable k, Typeable a, Indexable a) => Proxy k -> IxSet a -> [a]

toDescList takes a funny argument (Proxy :: Proxy UTCTime). While the Post type itself has an Ord instance -- we generally want to order by a specific key, which may have a different ordering. Since our keys are specified by type, we need a way to pass a type to 'toDescList' so that it knows which key we want to order by. The Proxy type exists for that sole reason:

> data Proxy a = Proxy

It just gives us a place to stick a type signature that toDescList and other functions can use.

Summary

You have now seen the basics of using IxSet. IxSet includes numerous other operations such as range-based queries, deleting records, convert to and from lists and Sets. See the haddock docs for a complete list of functions and their descriptions. You should have no difficulty understanding what they do based on what we have already seen.

Rest of the Example Code

The remainder of the code in this section integrates the above code into a fully functioning example. In order to keep things simple I have just used blaze-html. In a real application I would use digestive-functors to deal with the form generation and validation. (I would probably also use web-routes to provide type-safe urls, and HSP for the templates). But those topics will be covered elsewhere. The remainder of the code in this section does not continue any new concepts that have not already been covered in previous sections of the crash course.

> $(makeAcidic ''Blog
>   [ 'newPost
>   , 'updatePost
>   , 'postById
>   , 'postsByStatus
>   ])
> -- | HTML template that we use to render all the pages on the site
> template :: Text -> [Html] -> Html -> Response
> template title headers body =
>   toResponse $
>     H.html $ do
>       H.head $ do
>         css
>         H.title (H.toHtml title)
>         H.meta ! A.httpEquiv "Content-Type" ! A.content "text/html;charset=utf-8"
>         sequence_ headers
>       H.body $ do
>         H.ul ! A.id "menu" $ do
>          H.li $ H.a ! A.href "/" $ "home"
>          H.li $ H.a ! A.href "/drafts" $ "drafts"
>          H.li $ H.form ! A.enctype "multipart/form-data"
>                        ! A.method "POST"
>                        ! A.action "/new" $ H.button $ "new post"
>         body
>
> -- | CSS for our site
> --
> -- Normally this would live in an external .css file.
> -- It is included inline here to keep the example self-contained.
> css :: Html
> css =
>     let s = Text.concat [ "body { color: #555; padding: 0; margin: 0; margin-left: 1em;}"
>                         , "ul { list-style-type: none; }"
>                         , "ol { list-style-type: none; }"
>                         , "h1 { font-size: 1.5em; color: #555; margin: 0; }"
>                         , ".author { color: #aaa; }"
>                         , ".date { color: #aaa; }"
>                         , ".tags { color: #aaa; }"
>                         , ".post { border-bottom: 1px dotted #aaa; margin-top: 1em; }"
>                         , ".bdy  { color: #555; margin-top: 1em; }"
>                         , ".post-footer { margin-top: 1em; margin-bottom: 1em; }"
>                         , "label { display: inline-block; width: 3em; }"
>                         , "#menu { margin: 0; padding: 0; margin-left: -1em;"
>                         ,         "border-bottom: 1px solid #aaa; }"
>                         , "#menu li { display: inline; margin-left: 1em; }"
>                         , "#menu form { display: inline; margin-left: 1em; }"
>                         ]
>     in H.style ! A.type_ "text/css" $ H.toHtml s
>
-- | edit an existing blog post
> edit :: AcidState Blog -> ServerPart Response
> edit acid =
>     do pid   <- PostId <$> lookRead "id"
>        mMsg  <- optional $ lookText "msg"
>        mPost <- query' acid (PostById pid)
>        case mPost of
>          Nothing ->
>              notFound $ template "no such post" [] $ do "Could not find a post with id "
>                                                         H.toHtml (unPostId pid)
>          (Just p@(Post{..})) ->
>              msum [ do method GET
>                        ok $ template "foo" [] $ do
>                          case mMsg of
>                            (Just msg) | msg == "saved" -> "Changes saved!"
>                            _ -> ""
>                          H.form ! A.enctype "multipart/form-data"
>                               ! A.method "POST"
>                               ! A.action (H.toValue $ "/edit?id=" ++
>                                                       (show $ unPostId pid)) $ do
>                            H.label "title" ! A.for "title"
>                            H.input ! A.type_ "text"
>                                    ! A.name "title"
>                                    ! A.id "title"
>                                    ! A.size "80"
>                                    ! A.value (H.toValue title)
>                            H.br
>                            H.label "author" ! A.for "author"
>                            H.input ! A.type_ "text"
>                                    ! A.name "author"
>                                    ! A.id "author"
>                                    ! A.size "40"
>                                    ! A.value (H.toValue author)
>                            H.br
>                            H.label "tags" ! A.for "tags"
>                            H.input ! A.type_ "text"
>                                    ! A.name "tags"
>                                    ! A.id "tags"
>                                    ! A.size "40"
>                                    ! A.value (H.toValue $ Text.intercalate ", " tags)
>                            H.br
>                            H.label "body" ! A.for "body"
>                            H.br
>                            H.textarea ! A.cols "80" ! A.rows "20" ! A.name "body" $ H.toHtml body
>                            H.br
>                            H.button ! A.name "status" ! A.value "publish" $ "publish"
>                            H.button ! A.name "status" ! A.value "save"    $ "save as draft"
>                   , do method POST
>                        ttl   <- lookText' "title"
>                        athr  <- lookText' "author"
>                        tgs   <- lookText' "tags"
>
>                        bdy   <- lookText' "body"
>                        now   <- liftIO $ getCurrentTime
>                        stts  <- do s <- lookText' "status"
>                                    case s of
>                                       "save"    -> return Draft
>                                       "publish" -> return Published
>                                       _         -> mzero
>                        let updatedPost =
>                                p { title  = ttl
>                                  , author = athr
>                                  , body   = bdy
>                                  , date   = now
>                                  , status = stts
>                                  , tags   = map Text.strip $ Text.splitOn "," tgs
>                                  }
>                        update' acid (UpdatePost updatedPost)
>                        case status of
>                          Published ->
>                            seeOther ("/view?id=" ++ (show $ unPostId pid))
>                                     (toResponse ())
>                          Draft     ->
>                            seeOther ("/edit?msg=saved&id=" ++ (show $ unPostId pid))
>                                     (toResponse ())
>                   ]
>
>                  where lookText' = fmap toStrict . lookText
> -- | create a new blog post in the database , and then redirect to /edit
> new :: AcidState Blog -> ServerPart Response
> new acid =
>     do method POST
>        now <- liftIO $ getCurrentTime
>        post <- update' acid (NewPost now)
>        seeOther ("/edit?id=" ++ show (unPostId $ postId post)) (toResponse ())
> -- | render a single blog post into an HTML fragment
> postHtml  :: Post -> Html
> postHtml (Post{..}) =
>   H.div ! A.class_ "post" $ do
>     H.h1 $ H.toHtml title
>     H.div ! A.class_ "author" $ do "author: "    >> H.toHtml author
>     H.div ! A.class_ "date"   $ do "published: " >> H.toHtml (show date)
>     H.div ! A.class_ "tags"   $ do "tags: "       >> H.toHtml (Text.intercalate ", " tags)
>     H.div ! A.class_ "bdy" $ H.toHtml body
>     H.div ! A.class_ "post-footer" $ do
>      H.span $ H.a ! A.href (H.toValue $ "/view?id=" ++
>                             show (unPostId postId)) $ "permalink"
>      H.span $ " "
>      H.span $ H.a ! A.href (H.toValue $ "/edit?id=" ++
>                             show (unPostId postId)) $ "edit this post"
> -- | view a single blog post
> view :: AcidState Blog -> ServerPart Response
> view acid =
>     do pid <- PostId <$> lookRead "id"
>        mPost <- query' acid (PostById pid)
>        case mPost of
>          Nothing ->
>              notFound $ template "no such post" [] $ do "Could not find a post with id "
>                                                         H.toHtml (unPostId pid)
>          (Just p) ->
>              ok $ template (title p) [] $ do
>                  (postHtml p)
> -- | render all the Published posts (ordered newest to oldest)
> home :: AcidState Blog -> ServerPart Response
> home acid =
>     do published <- query' acid (PostsByStatus Published)
>        ok $ template "home" [] $ do
>          mapM_ postHtml published
> -- | show a list of all unpublished blog posts
> drafts :: AcidState Blog -> ServerPart Response
> drafts acid =
>     do drafts <- query' acid (PostsByStatus Draft)
>        case drafts of
>          [] -> ok $ template "drafts" [] $ "You have no unpublished posts at this time."
>          _ ->
>              ok $ template "home" [] $
>                  H.ol $ mapM_ editDraftLink drafts
>     where
>       editDraftLink Post{..} =
>         H.a ! A.href (H.toValue $ "/edit?id=" ++ show (unPostId postId)) $ H.toHtml title
> -- | route incoming requests
> route :: AcidState Blog -> ServerPart Response
> route acid =
>     do decodeBody (defaultBodyPolicy "/tmp/" 0 1000000 1000000)
>        msum [ dir "favicon.ico" $ notFound (toResponse ())
>             , dir "edit"        $ edit acid
>             , dir "new"         $ new acid
>             , dir "view"        $ view acid
>             , dir "drafts"      $ drafts acid
>             , nullDir          >> home acid
>             ]
> -- | start acid-state and the http server
> main :: IO ()
> main =
>     do bracket (openLocalState initialBlogState)
>                (createCheckpointAndClose)
>                (\acid ->
>                     simpleHTTP nullConf (route acid))

[Source code for the app is here.]

IxSet and Data.Lens

To use IxSet with Data.Lens you will need to install the optional data-lens-ixset, data-lens-template, and data-lens-fd packages.

It is very common to use records and nested records with IxSet and acid-state. Unfortunately, Haskell record support is pretty pitiful at the moment. People have been proposing improvements for years -- but until some proposals get implemented we need some way to make life more pleasant. One popular solution is the data-lens library.

At first, lenses sound like they must be something really crazy or difficult -- like Arrows but even worse! But, in reality, lenses are pretty simple. Lenses are really just some new syntax to make it easy to compose getters, setters, and modifiers.

It can take a bit of practice to get used to lenses. But, fortunately, using them is completely optional -- so if they are not your thing, you don't have to use them. In this tutorial we will start with a general introduction to using lenses, and then finish up with showing how to use them with IxSet and acid-state.

> {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving
>   , OverloadedStrings, TemplateHaskell #-}
> module Main where
>
> import Control.Applicative (pure)
> import Control.Category   ((.), (>>>))
> import Control.Comonad.Trans.Store.Lazy
> import Data.Acid          (Update)
> import Data.Data          (Data, Typeable)
> import Data.IxSet         (IxSet, Indexable(empty), (@=), fromList, ixFun, ixSet)
> import Data.Lens          ( Lens, (^$), (^.), (^=), (^%=), (^%%=), (^+=), (%=)
>                           , getL, setL, modL)
> import Data.Lens.Template (makeLens)
> import Data.Lens.IxSet    (ixLens)
> import Data.Lens.Partial.Common (PartialLens(..), maybeLens, totalLens)
> import Data.SafeCopy      (SafeCopy, base, deriveSafeCopy)
> import Data.Text          (Text)
> import Prelude            hiding ((.))

Creating Lenses

We start by defining a simple User record which contains some nested records:

> newtype UserId = UserId { _userInt :: Integer } 
>     deriving (Eq, Ord, Data, Typeable, SafeCopy, Show)
>
> $(makeLens ''UserId)
>
> data Name = Name 
>     { _nickName  :: Text
>     , _firstName :: Text
>     , _lastName  :: Text
>     }
>     deriving (Eq, Ord, Data, Typeable, Show)
>
> $(deriveSafeCopy 0 'base ''Name)
> $(makeLens ''Name)
>
> data User = User
>     { _userId :: UserId
>     , _name   :: Name
>     }
>     deriving (Eq, Ord, Data, Typeable, Show)
>
> $(deriveSafeCopy 0 'base ''User)
> $(makeLens ''User)
>
> -- | example user
> stepcut :: User
> stepcut = 
>     User { _userId = UserId 0
>          , _name   = Name { _nickName  = "stepcut"
>                           , _firstName = "Jeremy"
>                           , _lastName  = "Shaw"
>                           }
>          }

There are two things to notice:

  1. the field names all start with an underscore. That is because new helper functions will be generated that do not contain the underscore.

  2. there is a template haskell call $(makeLens ''Type). This template haskell call generates lens functions based on the fields in the record. If you want to see what it is actually generating you can compile with -ddump-splices. Here is one of the lenses generated by $(makeLens ''User):

> userId :: Lens User UserId
> userId = lens _userId (\ uid user -> user { _userId = uid })

We see that a lens is basically just a getter function and a setter function. In this case, a getter function that can get a UserId from a User and a setter function that can set the UserId in a User.

Getters

There are two getter operators: one for left-to-right composition and one for right-to-left composition. There is also a getter function. They all serve the same purpose -- it's just a matter of taste which you use.

The first operator is:

> (^$), (^$!)  :: Lens a b -> a -> b

There are two variations ^$ is the normal version. ^$! does the same thing except that internally it uses $! to more strictly evaluate the calculation. It is used like this:

> stepcutFirstName :: Text
> stepcutFirstName = firstName ^$ name ^$ stepcut

Notice that ^$ is used a lot like $. In fact we could write this with out lenses at all like this:

> stepcutFirstName2 :: Text
> stepcutFirstName2 = _firstName $ _name $ stepcut

The other getter operator is:

> (^.), (^!) :: a -> Lens a b -> b

Where ^. is the normal version and ^! is the stricter version.

We can use it like this:

> stepcutFirstName3 :: Text
> stepcutFirstName3 = (stepcut ^. name) ^. firstName

So, here ^. is meant to act like a field accessor in a traditional object oriented language where we would write:

stepcut.name.firstName

Finally, we have the getL function:

> getL :: Lens a b -> a -> b

getL is useful for creating partially applied functions. For example, we can create a function that gets a User's first name like this:

> getFirstName :: User -> Text
> getFirstName = getL firstName . getL name 

Lens is an instance of Category

Lens is an instance of Category. That means we can use the . operator from Category to compose lenses.

The normal . looks like this:

> -- | as defined in 'Prelude'
> (.) :: (b -> c) -> (a -> b) -> a -> c

But . can be generalized to work for any Category like this:

> -- | as defined in 'Control.Category'
> (.)  :: (Category cat) => cat b c -> cat a b -> cat a c

If you look closely at the imports at the top, you will notice that we hide . from the Prelude and imported the version from Control.Category instead. Now we can write this:

> stepcutFirstName4 :: Text
> stepcutFirstName4 = firstName . name ^$ stepcut

Which looks very similar to the non-lens version:

> stepcutFirstName5 :: Text
> stepcutFirstName5 = _firstName . _name $ stepcut

If we look at the type of firstName . name we see that we just get a lens that goes straight from User to Text:

*Main> :t firstName . name
firstName . name :: Lens User Text

Setters

Next we have the setter operator. This is where lenses start to shine. The setter operator is:

> (^=), (^!=) :: Lens a b -> b -> a -> a

Once again we have a lazier version ^= and a stricter version ^!=.

We can use it to update the UserId in the User type like this:

> setUserId :: (User -> User)
> setUserId = userId ^= (UserId 1)

So, we see that ^= is used to create an update function. If we wanted to update a specific record we could write it like this:

> setStepcutUserId :: User
> setStepcutUserId = userId ^= (UserId 1) $ stepcut

Instead of the infix operator we could instead setL:

> setL :: Lens a b -> b -> a -> a

as such:

> setUserId' :: (User -> User)
> setUserId' = setL userId (UserId 1)

Modifiers

Often times we want to apply a function to transform an existing value rather than just setting a new value. For that we use:

> (^%=), (^!%=) :: Lens a b -> (b -> b) -> a -> a

For example, we can increment the Integer inside the UserId like so:

> incUserId :: UserId -> UserId
> incUserId = (userInt ^%= succ)

Or we could use the modL function:

> modL :: Lens a b -> (b -> b) -> a -> a
> incUserId' :: UserId -> UserId
> incUserId' = modL userInt succ

Updating Nested Records

If we want to update a nested record then need to combine setters and modifiers. For example, we can update the nickName like this:

> setNick :: Text -> (User -> User)
> setNick nick = name ^%= (nickName ^= nick)

That says we want to modify the name field of a User by setting the nickName of the Name.

Another option would be to leverage the Category instance for Lens and use the . operator:

> setNick2 :: Text -> (User -> User)
> setNick2 newNick = (nickName . name) ^= newNick

However, I find that a bit confusing to read, because the field names are listed right-to-left, but the overall flow of that line is left-to-right. If we want a consistent left-to-right feel we can use the >>> operator:

> (>>>) :: Control.Category.Category cat => cat a b -> cat b c -> cat a c
> setNick3 :: Text -> (User -> User)
> setNick3 newNick = (name >>> nickName) ^= newNick

Other Modifiers

The lens library also provides some operators that encapsulate common updates such as addition and subtraction. For example,

> addToUserId :: Integer -> (UserId -> UserId)
> addToUserId i = (userInt ^+= i)

Lens for IxSet

So far we have examined updating fields in a record. But there is no reason why a lens need to be limited to a record. The idea can be used with just about any type where we have the ability to focus on a single element. We can create a lens for an IxSet by using this ixLens function:

> ixLens :: (Typeable key, Indexable a, Typeable a, Ord a) =>
>           key
>        -> Lens (IxSet a) (Maybe a)

For records, the names of the fields are known at compile time, so we were able to automatically create helper functions like userId, name, etc, to address those fields. For an IxSet we generally want to address some value by a key that is determined at runtime, so we can not automatically generate helper functions.

First we need an Indexable User instance:

> instance Indexable User where
>     empty = ixSet [ ixFun $ \u -> [ userId ^$ u ]
>                   ]

And then we will add the IxSet to a state record:

> data UserState = UserState 
>     { _nextUserId :: UserId
>     , _users      :: IxSet User
>     }
>     deriving (Eq, Ord, Data, Typeable, Show)
>
> $(deriveSafeCopy 0 'base ''UserState)
> $(makeLens ''UserState)
>
> userState :: UserState
> userState = 
>     UserState { _nextUserId = UserId 1
>               , _users      = fromList [ stepcut ]
>               }
>

Using a getter with IxSet

It is not a bad idea to define an alias for ixLens that has a more meaningful name and a more explicit type:

> user :: (Typeable key) => key -> Lens (IxSet User) (Maybe User)
> user = ixLens

That will help make it easier to read the code, and will make type errors more readable.

Now we can extract the User with UserId 0 from userState:

> user0 :: Maybe User
> user0 = user (UserId 0) ^$ users ^$ userState

Inserting an element into an IxSet

We can use the setter operator to add a new record to an IxSet:

> addUserId1 :: UserState
> addUserId1 = 
>     let stepcut1 = userId ^= (UserId 1) $ stepcut -- create a duplicate of the stepcut 
>                                                   -- record but with 'UserId 1'
>     in (users ^%= user (userId ^$ stepcut1) ^= (Just stepcut1)) userState

So, there is something a little tricky going on here. Under the hood, we are using updateIx to insert the record. In this case, we are updating the non-existing record for UserId 1.

An updateIx is performed by deleting the old record (if it exists) and inserting the new one. However, the key used to delete the old record may not match the key in the new record we are inserting. For example, if we did:

> addUserId1' :: UserState
> addUserId1' = 
>     let stepcut1 = userId ^= (UserId 1) $ stepcut -- create a duplicate of the stepcut 
>                                                   -- record but with 'UserId 1'
>     in (users ^%= user (UserId 0) ^= (Just stepcut1)) userState

That would delete the existing UserId 0 record and add a UserId 1 record instead. It would not insert the stepcut1 record as UserId 0.

Deleting an element from an IxSet

We can delete an element from an IxSet by updating it with Nothing.

> deleteUserId0 :: UserState
> deleteUserId0 = (users ^%= user (UserId 0) ^= Nothing) userState

Using a modifier with IxSet

Here we update the nickName for UserId 0:

> changeNick :: UserState
> changeNick =
>   (users ^%= user (UserId 0) ^%= fmap (name ^%= (nickName ^= "stepkut"))) userState

In a traditional imperative language we write changeNick something like:

changeNick() { userState.users[0].name.nickName = "stepkut"; }

Looking at the two, you can see the similarity, even if the syntax is not as nice.

One important things to note is that the ixLens returns a Maybe value since we might request a non-existent UserId. Here we use fmap to set the nick inside the Maybe value. However, that means that for a non-existent UserId the update silently does nothing. Sometimes that is ok, but if not, then you will need to take a different approach.

We can also try to use >>> instead of all those ^%=, but the fmap is a bit troublesome:

> changeNick2 :: UserState
> changeNick2 =
>  ((users >>> user (UserId 0)) ^%= fmap ((name >>> nickName) ^= "stepkut")) userState

Additionally, it seems like ^%= binds too tightly and so we need some extra ( ) to keep things happy.

Using `partial-lens` with IxSet

The partial-lens package attempts to address the fmap problem that we saw in the last section. A partial-lens is similar to a lens but allows for the fact that the lens may not always be able to produce a value:

> newtype PartialLens a b = PLens (a -> Maybe (Store b a))

However, it seems a bit awkward to use partial-lens at the moment. To use a normal lens with need to convert it to a partial lens using totalLens:

> totalLens :: Lens a b -> PartialLens a b

Additionally, partial-lens lacks the MonadState interaction that we will examine in the next section (aka, partial-lens-fd). But, hopefully these issues will be resolved in the future.

We can turn our ixLens into a partial lens like this:

> -- | note: `setPL` does not insert into an `IxSet` it only modifies a 
> -- value if the key already exists in the map
> ixPLens :: (Typeable key, Ord a, Typeable a, Indexable a) => key -> PartialLens (IxSet a) a
> ixPLens key = maybeLens . totalLens (ixLens key)

See the haddock page for partial-lens for more information. Using partial-lens is very similar to a normal lens.

Using a setter and modifier with IxSet in an acid-state event

If we are using IxSet with acid-state, we can use a special version of the modifier operator that automatically does the get/put for us:

> (%=) :: (MonadState a m) => Lens a b -> (b -> b) -> m b

Note that this version of %= was imported from Data.Lens which comes from the data-lens-fd package. There are similar functions in Data.Lens.Strict and Data.Lens.Lazy but they do not have the right type.

We can now make changeNick into an Update event like this:

> changeNick' :: Update UserState (IxSet User)
> changeNick' = users %= user (UserId 0) ^%= fmap (name ^%= (nickName ^= "stepkut"))

All we did was change the first ^%= to %=. This works because Update is an instance of MonadState.

data-lens-fd provides a few other functions that you can use to get, set, and modify the state in an Update or Query event. Check out the haddock documentation for data-lens-fd.

[Source code for the app is here.]

Passing multiple AcidState handles around transparently

Manually passing around the acid-state handle gets tedious very quickly. A common solution is to stick the AcidState handle in a ReaderT monad. For example:

> newtype MyApp =
>  MyApp { unMyApp :: ReaderT (AcidState MyAppState) (ServerPartT IO) Response }

We could then write some variants of the update and query functions which automatically retrieve the acid handle from ReaderT.

In this section we will show a slightly more sophisticated version of that solution which allows us to work with multiple AcidState handles and works well even if our app can be extended with optional plugins that contain additional AcidState handles.

> {-# 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)

The first thing we have is a very general class that allows us to retrieve a specific AcidState handle by its type from an arbitrary monad:

> class HasAcidState m st where
>    getAcidState :: m (AcidState st)

Next we redefine query and update so that they use getAcidState to automatically retrieve the the correct acid-state handle from whatever monad they are in:

> 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)

(These functions will eventually reside in acid-state itself, or some other library).

Now we can declare a couple acid-state types:

> -- 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])

Now that we have two states we can create a type to bundle them up like:

> 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)

Now we can create our App monad that stores the Acid in the ReaderT:

> 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

And finally, we need to write the HasAcidState instances:

> instance HasAcidState App CountState where
>     getAcidState = acidCountState    <$> ask
>
> instance HasAcidState App GreetingState where
>     getAcidState = acidGreetingState <$> ask

And that's it. We can now use update and query in the remainder of our code with out having to worry about the AcidState argument anymore.

Here is a page function that uses both the AcidStates in a transparent manner:

> 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

If have used happstack-state in the past, then this may remind you of how happstack-state worked. However, there is a critical different. In happstack-state it was possible to call update and query on events for state components that were not actually loaded. In this solution, however, the HasAcidState class ensures that we can only call update and query for valid AcidState handles.

Our main function is simply:

> main :: IO ()
> main =
>     withAcid Nothing $ \acid ->
>         simpleHTTP nullConf $ runApp acid page

Optional Plugins/Components

In an upcoming section we will explore various methods of extending your app via plugins and 3rd party libraries. These plugins and libraries may contain their own AcidState components. Very briefly, we will show how that might be handled.

Let's imagine we have this dummy plugin:

> 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

We could integrate it into our app by extending the Acid type to hold the FooState and then add an appropriate HasAcidState instance:

> 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

Now we can use fooAppPlugin like any other part in our app:

> fooAppPlugin :: App' Response
> fooAppPlugin = fooPlugin

An advantage of this method is that fooPlugin could also have access to the other AcidState components like CountState and GreetingState.

A different option would be for fooPlugin to use its own ReaderT

> 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

We will come back to this in detail later when we explore plugins and libraries.

[Source code for the app is here.]

Next: Template Haskell