Building a Blog in Haskell with Yesod–JSON API

You can keep reading here or jump to my blog to get the full experience, including the wonderful pink, blue and white palette.

This is a series about Yesod: a Haskell web framework that follows a similar philosophy to Rails. In fact, it is strongly opinionated and provides a lot of functionality out of the box.

A good read about Yesod is available online for free: Developing web applications with Haskell and Yesod. That's why this series will be a commentary of the commits from a repo we will use to develop a super simple blog.

In other words, this won't be good material to learn how to use Yesod. However, it will hopefully give an overview of how the framework works.

Back in Business

Last week's post started on a bitter note:

The plan for this post was to transform the entire blog into an API. Unfortunately, the compiler got in the middle.

It's not a secret that the Haskell compiler can be at times difficult to satisfy. However, what a joy it is when the program finally type checks! This time we got it covered. So let's dive into it.

Authentication

Last week's post was a bit of a lie. In fact, since the authentication wasn't taken care of, the user had to adhere to the following steps to get the list of posts in JSON format:

visit /api/posts on a browser
the application would have shown the login form
submit the login form
visit /api/posts on a browser again

That is because the user didn't have any means to authenticate the /api/posts requests. Therefore, they had to create a session (cookie) by logging in.

Commit cd78427e82babef42f170bf7b3e4ff423d88a729 fixes that by patching maybeAuthId:

    maybeAuthId = do
        request <- waiRequest
        let mHeader = lookup "X-User-Id" (Network.Wai.requestHeaders request)
            bsToText = T.pack . BSC8.unpack
        case bsToText <$> mHeader of
          Just v ->
            return $ fromPathPiece v
          Nothing ->
            defaultMaybeAuthId

The default maybeAuthId

Retrieves user credentials, if user is authenticated.

By default, this calls defaultMaybeAuthId to get the user ID from the session.

The docs go on saying

This can be overridden to allow authentication via other means, such as checking for a special token in a request header. This is especially useful for creating an API to be accessed via some means other than a browser.

That is why, the patched code above looks for the id in the X-User-Id header and delegates to the default behaviour when not found.

Registration

Up until now we've been using Yesod.Auth.Dummy for both authentication and registration. In fact, Yesod.Auth.Dummy renders a login form with one text field. If it's submitted with the username of an existing user, then that becomes the logged in user. Otherwise, it first adds a new record to the database and then creates the session.

Unfortunately, Yesod.Auth.Dummy does not support registration via JSON requests. Therefore, we have to patch it ourselves.

Commit 78e13f807f5674aa0a84e2633d7967fa02b755cf just copy / pastes the authDummy code from Yesod.Auth.Dummy. The real change is done in commit cd78427e82babef42f170bf7b3e4ff423d88a729.

Firstly, we introduce a parser

parser :: Value -> Parser Text
parser = withObject "ident" (\obj -> do
                ident <- obj .: "ident"
                return ident)

that is capable of extracting ident from a JSON like the following

{ "ident": "MY USERNAME" }

Secondly, we patch the dispatch function of the authDummy plugin. That is the place in charge of taking care of the POST requests to /auth/page/dummy. Up until now, it only worked when the html form was submitted. To make it work with a JSON request we need to make a few changes:

 authDummy :: YesodAuth m => AuthPlugin m
 authDummy =
     AuthPlugin "dummy" dispatch login
   where
     dispatch "POST" [] = do
-        ident <- runInputPost $ ireq textField "ident"
-        setCredsRedirect $ Creds "dummy" ident []
+        result <- runInputPostResult $ ireq textField "ident"
+        case result of
+          FormSuccess ident ->
+            setCredsRedirect $ Creds "dummy" ident []
+          _ -> do
+            (result :: Result Value) <- parseCheckJsonBody
+            case result of
+              Success val -> do
+                let mIdent = parseEither parser val
+                case mIdent of
+                  Right ident ->
+                    setCredsRedirect $ Creds "dummy" ident []
+                  Left err ->
+                    invalidArgs [T.pack err]
+              Error err ->
+                invalidArgs [T.pack err]
     dispatch _ _ = notFound

In more detail, we first try to extract ident from the POST params (i.e. form submission) with runInputPostResult. If that succeeds (i.e. FormSuccess) we leave the original behaviour intact.

If it fails, we try to get the JSON body with parseCheckJsonBody. If that fails we return invalidArgs (i.e. HTTP 400). If it succeeds, we try to extract from the JSON body the ident Text. If that succeeds we do the same thing as when the POST params succeed.

Create a New Post

It turns out, many concepts used in the previous section apply to creating a new post. We do that in commit 4922c8db2706fd0999ef478373b82326f5851b4d:

postApiPostsR :: Handler Value
postApiPostsR = do
  (result :: Result Value) <- parseCheckJsonBody
  case result of
    Success val -> do
      let mPost = parseEither postParser val
      case mPost of
        Right post -> do
          postId <- runDB $ insert post
          return $ object [ "post" .= post, "id" .= postId ]
        Left err ->
          invalidArgs [pack err]
    Error err ->
      invalidArgs [pack err]

postParser :: Value -> Parser Post
postParser = withObject "Post" (\obj -> do
                title <- obj .: "title"
                text <- obj .: "text"
                userId <- obj .: "userId"
                return $ Post title text userId)

Delete a Post

This is the easiest part, look how small commit 166aa28741fe532ae664308a2af4b28638b6d560 is!

The only thing worth mentioning is the return Null in

deleteApiPostR :: PostId -> Handler Value
deleteApiPostR postId = do
  _ <- runDB $ delete postId
  return Null

That is just a shortcut to return an empty JSON body.

CURLing

curl -XPOST -d '{"ident":"super cool username"}' -H "Content-Type: application/json" -H "Accept: application/json" http://localhost:3000/auth/page/dummy

# {"message":"Login Successful"}

Un-authenticated request:

curl -H "Accept: application/json" http://localhost:3000/api/posts

# {"authentication_url":"http://localhost:3000/auth/login","message":"Not logged in"}

List of posts:

curl -H "X-User-Id: 1" -H "Accept: application/json" http://localhost:3000/api/posts

# {"posts":[{"text":"Luigi","user": {"username":"luigi","id":3},"id":5,"title":"I am"},{"text":"333","user":{"username":"mario","id":2},"id":4,"title":"333"},{"text":"text","user":{"username":"mario","id":2},"id":3,"title":"title"},{"text":"text","user"{"username":"riccardo","id":1},"id":2,"title":"title"},{"text":"1","user":{"username":"riccardo","id":1},"id":1,"title":"1"}]}

Create a new post with missing parameter:

curl -XPOST -d '{"title":"some title","text":"some text"}' -H "X-User-Id: 1" -H "Content-Type: application/json" -H "Accept: application/json" http://localhost:3000/api/posts

# {"message":"Invalid Arguments","errors":["Error in $: key \"userId\" not present"]}

Create a new post:

curl -XPOST -d '{"title":"some title","text":"some text","userId": 1}' -H "X-User-Id: 1" -H "Content-Type: application/json" -H "Accept: application/json" http://localhost:3000/api/posts

# {"post":{"text":"some text","userId":1,"title":"some title"},"id":6}

Delete a post when not owner:

curl -XDELETE -H "X-User-Id: 2" -H "Accept: application/json" http://localhost:3000/api/posts/6

# {"message":"Permission Denied. only the author can delete their post"}

Delete a post:

curl -XDELETE -H "X-User-Id: 1" -H "Accept: application/json" http://localhost:3000/api/posts/6

# null

Outro

Here we have our JSON API. This has been quite a struggle. But what a great feeling when it finally compiled!!!

Get the latest content via email from me personally. Reply with your thoughts. Let's learn from each other. Subscribe to my PinkLetter!

Blog