Monad Transformers

Shrek- more or less

Monads are like onions. Monads are not like cakes.

Before we get into the heart of Yesod’s monads, we need to understand a bit about monad transformers. (If you already know all about monad transformers, you can likely skip this section.) Different monads provide different functionality: Reader allows read-only access to some piece of data throughout a computation, Error allows you to short-circuit computations, and so on.

Often times, however, you would like to be able to combine a few of these features together. After all, why not have a computation with read-only access to some settings variable, that could error out at any time? One approach to this would be to write a new monad like ReaderError, but this has the obvious downside of exponential complexity: you’ll need to write a new monad for every single possible combination.

Instead, we have monad transformers. In addition to Reader, we have ReaderT, which adds reader functionality to any other monad. So we could represent our ReaderError as (conceptually):

type ReaderError = ReaderT Error

In order to access our settings variable, we can use the ask function. But what about short-circuiting a computation? We’d like to use throwError, but that won’t exactly work. Instead, we need to lift our call into the next monad up. In other words:

throwError :: errValue -> Error
lift . throwError :: errValue -> ReaderT Error

There are a few things you should pick up here:

• A transformer can be used to add functionality to an existing monad.

• A transformer must always wrap around an existing monad.

• The functionality available in a wrapped monad will be dependent not only on the monad transformer, but also on the inner monad that is being wrapped.

A great example of that last point is the IO monad. No matter how many layers of transformers you have around an IO, there’s still an IO at the core, meaning you can perform I/O in any of these monad transformer stacks. You’ll often see code that looks like liftIO $ putStrLn "Hello There!".

The Three Monads

Prior to Yesod 1.6, Handler and Widget were implemented via monad transformers. Nowadays, we use the ReaderT pattern. Handler and Widget are application-specific synonyms for the more generic HandlerFor and WidgetFor.

newtype HandlerFor site a = HandlerFor
    { unHandlerFor :: HandlerData site site -> IO a
    }

newtype WidgetFor site a = WidgetFor
    { unWidgetFor :: WidgetData site -> IO a
    }

site is your foundation data type.

In persistent, we have a few typeclasses that define all of the primitive operations you can perform on a database, like get in PersistStoreRead. There are instances of these typeclasses for each database backend supported by persistent. For example, for SQL databases, there is a datatype called SqlBackend. We then use a standard ReaderT transformer to provide that SqlBackend value to all of our operations. This means that you can run a SQL database with any underlying monad which is an instance of MonadIO. The takeaway here is that we can layer our Persistent transformer on top of Handler or Widget.

In order to make it simpler to refer to the relevant Persistent transformer, the yesod-persistent package defines the YesodPersistBackend associated type. For example, if I have a site called MyApp and it uses SQL, I would define something like type instance YesodPersistBackend MyApp = SqlBackend. And for more convenience, we have a type synonym called YesodDB which is defined as:

type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerFor site)

Our database actions will then have types that look like YesodDB MyApp SomeResult. In order to run these, we can use the standard Persistent unwrap functions (like runSqlPool) to run the action and get back a normal Handler. To automate this, we provide the runDB function. Putting it all together, we can now run database actions inside our handlers.

Most of the time in Yesod code, and especially thus far in this book, widgets have been treated as actionless containers that simply combine together HTML, CSS and JavaScript. But in reality, a Widget can do anything that a Handler can do, by using the handlerToWidget function. So for example, you can run database queries inside a Widget by using something like handlerToWidget . runDB.

Example: Database-driven navbar

Let’s put some of this new knowledge into action. We want to create a Widget that generates its output based on the contents of the database. Previously, our approach would have been to load up the data in a Handler, and then pass that data into a Widget. Now, we’ll do the loading of data in the Widget itself. This is a boon for modularity, as this Widget can be used in any Handler we want, without any need to pass in the database contents.

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
import           Control.Monad.Logger    (runNoLoggingT)
import           Data.Text               (Text)
import           Data.Time
import           Database.Persist.Sqlite
import           Yesod

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Link
    title Text
    url Text
    added UTCTime
|]

data App = App ConnectionPool

mkYesod "App" [parseRoutes|
/         HomeR    GET
/add-link AddLinkR POST
|]

instance Yesod App

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

instance YesodPersist App where
    type YesodPersistBackend App = SqlBackend
    runDB db = do
        App pool <- getYesod
        runSqlPool db pool

getHomeR :: Handler Html
getHomeR = defaultLayout
    [whamlet|
        <form method=post action=@{AddLinkR}>
            <p>
                Add a new link to
                <input type=url name=url value=http://>
                titled
                <input type=text name=title>
                <input type=submit value="Add link">
        <h2>Existing links
        ^{existingLinks}
    |]

existingLinks :: Widget
existingLinks = do
    links <- handlerToWidget $ runDB $ selectList [] [LimitTo 5, Desc LinkAdded]
    [whamlet|
        <ul>
            $forall Entity _ link <- links
                <li>
                    <a href=#{linkUrl link}>#{linkTitle link}
    |]

postAddLinkR :: Handler ()
postAddLinkR = do
    url <- runInputPost $ ireq urlField "url"
    title <- runInputPost $ ireq textField "title"
    now <- liftIO getCurrentTime
    runDB $ insert $ Link title url now
    setMessage "Link added"
    redirect HomeR

main :: IO ()
main = runNoLoggingT $ withSqlitePool "links.db3" 10 $ \pool -> liftIO $ do
    runSqlPersistMPool (runMigration migrateAll) pool
    warp 3000 $ App pool

Pay attention in particular to the existingLinks function. Notice how all we needed to do was apply handlerToWidget . runDB to a normal database action. And from within getHomeR, we treated existingLinks like any ordinary Widget, no special parameters at all. See the figure for the output of this app.

Screenshot of the navbar

Example: Request information

Likewise, you can get request information inside a Widget. Here we can determine the sort order of a list based on a GET parameter.

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
import           Data.List (sortOn)
import           Data.Text (Text)
import           Yesod

data Person = Person
    { personName :: Text
    , personAge  :: Int
    }

people :: [Person]
people =
    [ Person "Miriam" 25
    , Person "Eliezer" 3
    , Person "Michael" 26
    , Person "Gavriella" 1
    ]

data App = App

mkYesod "App" [parseRoutes|
/ HomeR GET
|]

instance Yesod App

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage


getHomeR :: Handler Html
getHomeR = defaultLayout
    [whamlet|
        <p>
            <a href="?sort=name">Sort by name
            |
            <a href="?sort=age">Sort by age
            |
            <a href="?">No sort
        ^{showPeople}
    |]

showPeople :: Widget
showPeople = do
    msort <- runInputGet $ iopt textField "sort"
    let people' =
            case msort of
                Just "name" -> sortOn personName people
                Just "age"  -> sortOn personAge  people
                _           -> people
    [whamlet|
        <dl>
            $forall person <- people'
                <dt>#{personName person}
                <dd>#{show $ personAge person}
    |]

main :: IO ()
main = warp 3000 App

Notice that in this case, we didn’t even have to call handlerToWidget. The reason is that a number of the functions included in Yesod automatically work for both Handler and Widget, by means of the MonadHandler typeclass. In fact, MonadHandler will allow these functions to be "autolifted" through many common monad transformers.

But if you want to, you can wrap up the call to runInputGet above using handlerToWidget, and everything will work the same.

Adding a new monad transformer

At times, you’ll want to add your own monad transformer in part of your application. As a motivating example, let’s consider the monadcryptorandom package from Hackage, which defines both a MonadCRandom typeclass for monads which allow generating cryptographically-secure random values, and CRandT as a concrete instance of that typeclass. You would like to write some code that generates a random bytestring, e.g.:

import Control.Monad.CryptoRandom
import Data.ByteString.Base16 (encode)
import Data.Text.Encoding (decodeUtf8)

getHomeR = do
    randomBS <- getBytes 128
    defaultLayout
        [whamlet|
            <p>Here's some random data: #{decodeUtf8 $ encode randomBS}
        |]

However, this results in an error message along the lines of:

    No instance for 'MonadCRandom e0 (HandlerFor App)'
      arising from a use of ‘getBytes’
    In a stmt of a 'do' block: randomBS <- getBytes 128

How do we get such an instance? One approach is to simply use the CRandT monad transformer when we call getBytes. A complete example of doing so would be:

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}
import Yesod
import Crypto.Random (SystemRandom)
import Control.Monad.CryptoRandom
import Data.ByteString.Base16 (encode)
import Data.Text.Encoding (decodeUtf8)

data App = App

mkYesod "App" [parseRoutes|
/ HomeR GET
|]

instance Yesod App

getHomeR :: Handler Html
getHomeR = do
    gen <- liftIO newGenIO
    eres <- evalCRandT (getBytes 16) (gen :: SystemRandom)
    randomBS <-
        case eres of
            Left e -> error $ show (e :: GenError)
            Right gen -> return gen
    defaultLayout
        [whamlet|
            <p>Here's some random data: #{decodeUtf8 $ encode randomBS}
        |]

main :: IO ()
main = warp 3000 App

Note that what we’re doing is layering the CRandT transformer on top of the HandlerFor monad. This is the same approach we take with Persistent: its transformer also goes on top of HandlerFor.

But there are two downsides to this approach:

1. It requires you to jump into this alternate monad each time you want to work with random values.

2. It’s inefficient: you need to create a new random seed each time you enter this other monad.

The second point could be worked around by storing the random seed in the foundation datatype, in a mutable reference like an IORef, and then atomically sampling it each time we enter the CRandT transformer. But we can even go a step further, and use this trick to make our Handler monad itself an instance of MonadCRandom! Let’s look at the code, which is in fact a bit involved:

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeSynonymInstances  #-}
import           Control.Monad              (join)
import           Control.Monad.Catch        (throwM)
import           Control.Monad.CryptoRandom
import           Control.Monad.Error.Class  (MonadError (..))
import           Crypto.Random              (SystemRandom)
import           Data.ByteString.Base16     (encode)
import           Data.IORef
import           Data.Text.Encoding         (decodeUtf8)
import           UnliftIO.Exception         (catch)
import           Yesod

data App = App
    { randGen :: IORef SystemRandom
    }

mkYesod "App" [parseRoutes|
/ HomeR GET
|]

instance Yesod App

getHomeR :: Handler Html
getHomeR = do
    randomBS <- getBytes 16
    defaultLayout
        [whamlet|
            <p>Here's some random data: #{decodeUtf8 $ encode randomBS}
        |]

instance MonadError GenError Handler where
    throwError = throwM
    catchError = catch
instance MonadCRandom GenError Handler where
    getCRandom = wrap crandom
    {-# INLINE getCRandom #-}
    getBytes i = wrap (genBytes i)
    {-# INLINE getBytes #-}
    getBytesWithEntropy i e = wrap (genBytesWithEntropy i e)
    {-# INLINE getBytesWithEntropy #-}
    doReseed bs = do
        genRef <- fmap randGen getYesod
        join $ liftIO $ atomicModifyIORef genRef $ \gen ->
            case reseed bs gen of
                Left e -> (gen, throwM e)
                Right gen' -> (gen', return ())
    {-# INLINE doReseed #-}

wrap :: (SystemRandom -> Either GenError (a, SystemRandom)) -> Handler a
wrap f = do
    genRef <- fmap randGen getYesod
    join $ liftIO $ atomicModifyIORef genRef $ \gen ->
        case f gen of
            Left e -> (gen, throwM e)
            Right (x, gen') -> (gen', return x)

main :: IO ()
main = do
    gen <- newGenIO
    genRef <- newIORef gen
    warp 3000 App
        { randGen = genRef
        }

This really comes down to a few different concepts:

1. We modify the App datatype to have a field for an IORef SystemRandom.

2. Similarly, we modify the main function to generate an IORef SystemRandom.

3. Our getHomeR function became a lot simpler: we can now simply call getBytes without playing with transformers.

4. However, we have gained some complexity in needing a MonadCRandom instance. Since this is a book on Yesod, and not on monadcryptorandom, I’m not going to go into details on this instance, but I encourage you to inspect it, and if you’re interested, compare it to the instance for CRandT.

Hopefully, this helps get across an important point: the power of the ReaderT pattern. By just providing you with a readable environment, you’re able to recreate a StateT transformer by relying on mutable references. In fact, if you rely on the underlying IO monad for runtime exceptions, you can implement most cases of ReaderT, WriterT, StateT, and ErrorT with this abstraction.

Summary

If you completely ignore this chapter, you’ll still be able to use Yesod to great benefit. The advantage of understanding how Yesod’s monads interact is to be able to produce cleaner, more modular code. Being able to perform arbitrary actions in a Widget can be a powerful tool, and understanding how Persistent and your Handler code interact can help you make more informed design decisions in your app.