Cookbook, part 2

June 14, 2011

GravatarBy Michael Snoyman

JSON Web Service

Let's create a very simple web service: it takes a JSON request and returns a JSON response. We're going to write the server in WAI/Warp, and the client in http-enumerator. We'll be using aeson for JSON parsing and rendering.


WAI uses the enumerator package to handle streaming request bodies, and efficiently generates responses using blaze-builder. aeson uses attoparsec for parsing; by using attoparsec-enumerator we get easy interoperability with WAI. And aeson can encode JSON directly into a Builder. This plays out as:

{-# LANGUAGE OverloadedStrings #-}
import Network.Wai (Response (ResponseBuilder), Application)
import Network.HTTP.Types (status200, status400)
import Network.Wai.Handler.Warp (run)
import Data.Aeson.Parser (json)
import Data.Attoparsec.Enumerator (iterParser)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (Value (Object, String))
import Data.Aeson.Encode (fromValue)
import Data.Enumerator (catchError, Iteratee)
import Control.Exception (SomeException)
import Data.ByteString (ByteString)
import qualified Data.Map as Map
import Data.Text (pack)

main :: IO ()
main = run 3000 app

app :: Application
app _ = flip catchError invalidJson $ do
    value <- iterParser json
    newValue <- liftIO $ modValue value
    return $ ResponseBuilder
        [("Content-Type", "application/json")]
        $ fromValue newValue

invalidJson :: SomeException -> Iteratee ByteString IO Response
invalidJson ex = return $ ResponseBuilder
    [("Content-Type", "application/json")]
    $ fromValue $ Object $ Map.fromList
        [ ("message", String $ pack $ show ex)

-- Application-specific logic would go here.
modValue :: Value -> IO Value
modValue = return


http-enumerator was written as a comapnion to WAI. It too uses enumerator and blaze-builder pervasively, meaning we once again get easy interop with aeson. A few extra comments for those not familiar with http-enumerator:

  • A Manager is present to keep track of open connections, so that multiple requests to the same server use the same connection. You usually want to use the withManager function to create and clean up this Manager, since it is exception safe.
  • We need to know the size of our request body, which can't be determined directly from a Builder. Instead, we convert the Builder into a lazy ByteString and take the size from there.
  • There are a number of different functions for initiating a request. We use http, which allows us to directly access the data stream. There are other higher level functions (such as httpLbs) that let you ignore the issues of enumerators and get the entire body directly.
{-# LANGUAGE OverloadedStrings #-}
import Network.HTTP.Enumerator
    ( http, parseUrl, withManager, RequestBody (RequestBodyLBS)
    , requestBody
import Data.Aeson (Value (Object, String))
import qualified Data.Map as Map
import Data.Aeson.Parser (json)
import Data.Attoparsec.Enumerator (iterParser)
import Control.Monad.IO.Class (liftIO)
import Data.Enumerator (run_)
import Data.Aeson.Encode (fromValue)
import Blaze.ByteString.Builder (toLazyByteString)

main :: IO ()
main = withManager $ \manager -> do
    value <- makeValue
    -- We need to know the size of the request body, so we convert to a
    -- ByteString
    let valueBS = toLazyByteString $ fromValue value
    req' <- parseUrl "http://localhost:3000/"
    let req = req' { requestBody = RequestBodyLBS valueBS }
    run_ $ flip (http req) manager $ \status headers -> do
        -- Might want to ensure we have a 200 status code and Content-Type is
        -- application/json. We skip that here.
        resValue <- iterParser json
        liftIO $ handleResponse resValue

-- Application-specific function to make the request value
makeValue :: IO Value
makeValue = return $ Object $ Map.fromList
    [ ("foo", String "bar")

-- Application-specific function to handle the response from the server
handleResponse :: Value -> IO ()
handleResponse = print

Persistent: Raw SQL

The Persistent package provides a type safe interface to data stores. It tries to be backend-agnostic, such as not relying on relational features of SQL. My experience has been you can easily perform 95% of what you need to do with the high-level interface. (In fact, most of my web apps use the high level interface exclusively.)

But occasionally you'll want to use a feature that's specific to a backend. One feature I've used in the past is full text search. In this case, we'll use the SQL "LIKE" operator, which is not modeled in Persistent. We'll get all people with the last name "Snoyman" and print the records out.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Database.Persist.Sqlite (withSqliteConn)
import Database.Persist.TH (mkPersist, persist, share, mkMigrate, sqlSettings)
import Database.Persist.GenericSql (runSqlConn, runMigration, SqlPersist)
import Database.Persist.GenericSql.Raw (withStmt)
import Database.Persist.GenericSql.Internal (RowPopper)
import Data.Text (Text)
import Database.Persist
import Control.Monad.IO.Class (liftIO)

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|
    name Text

main :: IO ()
main = withSqliteConn ":memory:" $ runSqlConn $ do
    runMigration migrateAll
    insert $ Person "Michael Snoyman"
    insert $ Person "Miriam Snoyman"
    insert $ Person "Eliezer Snoyman"
    insert $ Person "Gavriella Snoyman"
    insert $ Person "Greg Weber"
    insert $ Person "Rick Richardson"

    -- Persistent does not provide the LIKE keyword, but we'd like to get the
    -- whole Snoyman family...
    let sql = "SELECT name FROM Person WHERE name LIKE '%Snoyman'"
    withStmt sql [] withPopper

-- A popper returns one row at a time. We loop over it until it returns Nothing.
withPopper :: RowPopper (SqlPersist IO) -> SqlPersist IO ()
withPopper popper =
    loop = do
        mrow <- popper
        case mrow of
            Nothing -> return ()
            Just row -> liftIO (print row) >> loop

Internationalized Julius

Hamlet has built-in support for i18n via the underscope interpolation syntax:


There was a concious decision not to include this syntax for Cassius, Lucius and Julius, since it is relatively uncommon to need this interpolation, and the added complexity of using the library didn't seem to warrant it. However, there are times when you do want to add an internationalized message to your Javascript.

The trick is fairly simple: getMessageRender returns a function that will convert a type-safe message into an actual string. We can directly use those strings with normal variable interpolation. getMessageRender handles all the work of determining the user's language preference list.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
import Yesod

data JI = JI
type Handler = GHandler JI JI
mkYesod "JI" [parseRoutes|
/ RootR GET

instance Yesod JI where
    approot _ = ""

data JIMsg = MsgHello

instance RenderMessage JI JIMsg where
    renderMessage a [] x = renderMessage a ["en"] x
    renderMessage _ ("en":_) MsgHello = "Hello"
    renderMessage _ ("es":_) MsgHello = "Hola"
    renderMessage a (_:ls) x = renderMessage a ls x

getRootR :: Handler RepHtml
getRootR = do
    render <- getMessageRender
    defaultLayout $ addJulius [julius|alert("#{render MsgHello}")|]

main :: IO ()
main = warpDebug 3000 JI


comments powered by Disqus