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.

{-# 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
        status200
        [("Content-Type", "application/json")]
        $ fromValue newValue

invalidJson :: SomeException -> Iteratee ByteString IO Response
invalidJson ex = return $ ResponseBuilder
    status400
    [("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

{-# 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 #-}
{-# LANGUAGE GADTs #-}
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|
Person
    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
  where
    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:

<h1>_{MsgHelloWorld}

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