Propellant
02 Jul 2020

How to combine Servant and React Admin, Part 4 : POSTing a new Comment

15 minutes reading time
Kasper Janssens
Table of contents

Overview

Continuing from our last blog, we will add a POST method to the API and consume it from React. We will keep track of the added comments by using the ReaderT monad.

The API type

Let’s extend the API type with a POST method :

type WebApi
   = "comments" :> Get '[ JSON] (ListHeaders [Comment]) 
   :<|> "comments" :> Capture "id" Int :> Get '[ JSON] Comment
   :<|> "comments" :> ReqBody '[ JSON] NewComment :> Post '[JSON] NoContent

Nothing remarkable, except maybe the NewComment type. Also, something new here is that we express that NewComment should be in the body of the request as a JSON type by using ReqBody. The POST will not return any content. It might seem strange then that indeed you have to specify content type in the form of JSON when there is no content being returned. The reasoning behind it is explained here but basically boils down to not special casing for NoContent.

The NewComment type is basically the same as the Comment type except the id. Because the server is the one handing out id’s in our approach, we cannot have it specified by the Web UI, so it can never be present in the posted comment. NewComment is rather straightforward specified like this :

{-# LANGUAGE DeriveGeneric #-}

module NewComment where

import           Data.Aeson.Types           (FromJSON, ToJSON)
import           GHC.Generics               (Generic)

newtype NewComment
  = NewComment {content :: String}
  deriving (Generic, Show)

instance ToJSON NewComment

instance FromJSON NewComment

Note, we can see that there is duplication here. It would be better to define Comment like this :

data Comment =
  Comment
    { id     :: Int
    , payload :: NewComment
    }

This would avoid duplication between Comment and NewComment. However, this gives us another problem. When we would just derive the JSON implementation for Comment defined like this, it would create a nested JSON structured like this :

{
 "id" : 42,
  "payload" : {
    "comment" : "this is my comment"
  }
}

This is not how React Admin expects the JSON to be served. We could solve it by implementing to the toJSON and fromJSON ourselves instead of deriving it, but for the purpose of this blog we consider it fine to just introduce a new type and suck up a little duplication.

ReaderT

It might be slightly unexpected to use ReaderT here instead of the State monad. The main reason is that State does not work well with multithreading as well as often have the code end up with a large monad stack.

The idea of using the ReaderT monad is one I first encountered on Michael Snoyman’s blog here. It’s a good read listing the pros and cons.

So, let’s try to add a POST method to the API type that runs in the ReaderT monad. First of all, we need to add the transformers package

- transformers == 0.5.6.2

because that’s where ReaderT lives.

Next, we’ll declare our State and wrap it in the ReaderT monad, as explained in the Snoyman article :

newtype State =
  State
    { comments :: TVar [Comment]
    }

type AppM = ReaderT State Handler

We basically extend the functionality of the Handler monad to also have the possibility to access State, and State includes a mutable list of comments, protected for multithreading. Note that adding a different monad on top of Handler has no impact on the web API type, as it should.

Using our AppM monad

Currently we define our server type like this :

server :: Server WebApi
server = listComments :<|> getComment

Server here is shorthand for :

type Server api = ServerT api Handler

So, when we use the Server type we have chosen to use the default Handler type, which of course makes sense. If we want to choose our own monad to run it, we will need to specify it by using ServerT like this :

server :: ServerT WebApi AppM
server = listComments :<|> getComment

When we try to compile it, the compiler won’t be particularly happy because we use the server function here :

app :: Application
app = corsConfig $ serve api server

which is defined like this :

serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
serve p = serveWithContext p EmptyContext

As you can see, here as well the code refers to Server api, which has us run by default in the Handler monad.

Hoist it

Looking through the documentation we notice this hoistServer function :

HasServer api '[] => Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n

The type signature looks a bit daunting, but we can see that if we can define a transformation from our AppM monad to the Handler monad (so a function AppM a -> Handler a), we can call hoistServer on it and then use serve again to create an Application, and then we are back on track.

So, our next challenge is creating a function that takes an AppM a and makes a Handler a out of it, for every a.

It might not be immediately obvious but we can use runReaderT for this. Recall :

type AppM = ReaderT State Handler

and the definition of runReaderT, a function that is defined for anything that implements the ReaderT type class (and our AppM does AppM) :

runReaderT :: r -> m a

where r is our State and m is the Handler monad and we are getting pretty close to a function that transforms our AppM a to Handler a.

If we define our runState like this :

runWithState :: State -> AppM a -> Handler a
runWithState state appM = runReaderT appM state

we have our transformation function as soon as we supply a start state.

Our server definition then goes from :

app :: Application
app = corsConfig $ serve api server

to :

app :: Application
app = corsConfig $ serve api $ hoistServer api (runWithState undefined) server

our compiler will be happy again. We cheated a little by using the undefined function of course, but I feel it is better to do this in two steps so you can see the transformation happening more clearly, you’ll understand why in a minute.

So, for it to work we need to pass in an initial state in the app. No biggie, you just need to use the Transactional variables functions :

createInitialState :: IO State
createInitialState = do
  initalComments <- atomically $ newTVar fixedComments
  return $ State {comments = initalComments}

For this to work you need to be in the IO monad. Luckily the type of app is Application, which is defined like this :

type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived

so we run in the IO Monad.

If we would just naively implement the app function like this :

app :: Application
app = do
  initialState <- createInitialState
  corsConfig $ serve api (hoistServer api (runWithState initialState) server)

we would get the compiler complaining at us :

   • Couldn't match type ‘IO b0’
                    with ‘Network.Wai.Internal.Request
                          -> (Network.Wai.Internal.Response
                              -> IO Network.Wai.Internal.ResponseReceived)
                          -> IO Network.Wai.Internal.ResponseReceived’
     Expected type: Application
       Actual type: IO b0

That’s because we think we are running in the IO monad but we aren’t, as Application is shorthand for a function.

If we define the app function like this :

app :: Application
app req res = do
  initialState <- createInitialState
  corsConfig (serve api (hoistServer api (runWithState initialState) server)) req res

the compiler will be happy again.

We could make it even more explicit by defining it like this :

createApplicationWithoutMiddleware :: State -> Application
createApplicationWithoutMiddleware initialState = serve api (hoistServer api (runWithState initialState) server)

app :: Application
app req res = do
  initialState <- createInitialState
  corsConfig (createApplicationWithoutMiddleware initialState) req res

The corsConfig function has type Middleware, which is defined like this :

type Middleware = Application -> Application

so it takes an application and returns us a new one, with CORS stuff added. We then still have to apply the request element and response handler we matched on and our signature is correct.

Pffw, we’re still not there yet. Let’s first have our listComments and getComment functions run in our AppM monad, cause they still run in the Handler monad.

Transforming the listComments and getComment functions to the AppM monad

Recall that our definition of getComment was this :

getComment :: Int -> AppM Comment
getComment requestedId = 
  let maybeComment = L.find (\comment -> Comment.id comment == requestedId) fixedComments
   in maybe (throwError err404 {errBody = BSLazy.pack $ "Could not retrieve comment with id " ++ show requestedId}) return maybeComment

For us to use the state inside the TVar we need to refactor it to this:

getComment :: Int -> AppM Comment
getComment requestedId = do
  commentsTransactionVar <- asks comments
  comments <- liftIO $ readTVarIO commentsTransactionVar
  let maybeComment = L.find (\comment -> Comment.id comment == requestedId) comments
   in maybe (throwError err404 {errBody = BSLazy.pack $ "Could not retrieve comment with id " ++ show requestedId}) return maybeComment

It’s reasonably straight forward, we use the asks function to return the TVar. The type of commentsTransactionVar is now :

TVar [Comment]

Now we leverage the readTVarIO function to return the comments and as of then we can continue like before. The readTVarIO function runs in IO, so we need to lift it (as our AppM monad is more than IO).

The listComments function is rather similar :

listComments :: AppM (ListHeaders [Comment])
listComments = do
  commentsTransactionVar <- asks comments
  comments <- liftIO $ readTVarIO commentsTransactionVar
  return $ addHeader (List.length comments) comments

Alright, now we are finally ready to implement our insertComment function.

Let’s finally implement insertComment

You can see the way we used the TVar in listComments and getComment and you could suspect we would use it the same way. The problem is that if we would first atomically fetch the comments, update them and atomically write them back we have no guarantees that in between our read and write someone else didn’t perform a write action and invalidated our action. So, we will leverage STM and run the whole action atomically like this :

insertComment :: NewComment -> AppM NoContent
insertComment newComment = do
  commentsTransactionVar <- asks comments
  liftIO $ atomically $ do
    comments <- readTVar commentsTransactionVar
    let nextId = List.length comments + 1
    let comment = fromNewComment nextId newComment
    let updateComments = List.insert comment comments
    writeTVar commentsTransactionVar updateComments
  return NoContent

The way we calculate the nextId is a bit ham-fisted and will get us in trouble as soon as we allow deletes. But let’s pretend we’ll never do that for now.

Let’s focus a bit on what we do here, we read the comments, create a new one, insert it and update the transactional variable, all atomically. The atomicity depends on the STM implementation in Haskell. You can think of it as some kind of optimistic lock but outside of a database, just in memory. The atomically-function will retry until it succeeds. It can fail in case somebody wrote the TVar between our reading and writing to the TVar, but it will be retried. As such it is important not to have side effects inside an atomically block as they can get executed several times, in case our code snippet needs to be retried. Normally it is not possible to peform side effects as STM does not implement MonadIO. You can of course shoot yourself in the foot by using unsafeIO still, but it’s preferable not to.

Note that if we would have implemented our snippet like this :

insertCommentNotSoSafe :: NewComment -> AppM NoContent
insertCommentNotSoSafe newComment = do
  commentsTransactionVar <- asks comments
  comments <- liftIO $ readTVarIO commentsTransactionVar
  let nextId = List.length comments + 1
  let comment = fromNewComment nextId newComment
  let updateComments = List.insert comment comments
  liftIO $ atomically $ writeTVar commentsTransactionVar updateComments
  return NoContent

we still would not have been safe. We could have another insert also seeing for instance two elements in the TVar, adding a new one with id 3 before we did and nothing would have stopped us inserting a second comment with id 3.

Note that this is not the ideal way to handle STM, we will look into stateTVar in the next blog to express this more elegantly. It’s always nice to see what is going on behind the scenes which is why we currently left this implementation in.

Okay, we finally have updated our server to be ready to receive new comments, let’s go back to React-Admin.

React-Admin and POST

We’ll create our create-component like this :

export const CommentsCreate = props => (
    <Create {...props}>
        <SimpleForm>
            <TextInput source="content" validate={required()}/>
        </SimpleForm>
    </Create>
)

We are only interested in the content of the comment, the id is handed out by the REST server at the backend. Of course, content is a required field, hence the validation-required attribute. We can easily use the create component like this :

const App = () => (
    <Admin dataProvider={dataProvider}>
        <Resource name="comments" list={CommentsList} show={CommentsShow} create={CommentsCreate}/>
    </Admin>
);

After adding this component to the create attribute of the Admin component we will see a create-link in the UI:

Create Link When we click on it, our Create-component is triggered and we can fill out our new comments, but when we try to save we will get our NetworkError again. Checking the console confirms it, we need to handle more CORS stuff.

CORS, revisited

To know which request is launched and rejected, we need to open the Network-tab on the developer tools in the browser and try to add a comment again. We will then see that the request that’s being launched is an OPTIONS request. This is part of the CORS specification, for every POST first we validate whether we are allowed to POST, and this is done through an options request. So, let’s go back to our server and expand the CORS configuration.

The default methods that are allowed are GET, HEAD and POST. OPTION is not among them, so we should add it. When we check the CORS record we see that the methods are of type :

corsMethods ∷ ![HTTP.Method]

HTTP is a module in the http-types package, which we have to add to our package.yaml first:

- http-types == 0.12.3

We can then import the package, in this case qualified as HttpTypes and add the correct methods to our CORS record :

corsConfig :: Middleware
corsConfig = cors (const $ Just policy)
  where
    policy =
      simpleCorsResourcePolicy
        { corsExposedHeaders = Just ["X-Total-Count"],
          corsMethods = [HttpTypes.methodGet, HttpTypes.methodPost, HttpTypes.methodHead, HttpTypes.methodOptions]
        }

Remember, we have to add the default methods here as well as we override the content of simpleCorsResourcePolicy as we override the full list. After adding these methods, let’s check again!

Hmm, still the same. Maybe we should check the error response now. If we do so we will see this :

HTTP header requested in Access-Control-Request-Headers of CORS request is not supported; requested: content-type; supported are Accept, Accept-Language, Content-Language.

(Note, sometimes the response error only shows when you try to resend the request in the Network-tab in the developer options. It seems to be a firefox-quirk)

According to the simple cors description on content-type in the Mozilla CORS article (same as the one we shared before), the content-type should be allowed provided it is one of :

The only allowed values for the Content-Type header are:

    application/x-www-form-urlencoded
    multipart/form-data
    text/plain

When we check our request, we see that the header has value text/html. Okay, we can now choose between adding a blanket accept for Content-Type or refining it. For the sake of simplicity we will go for a blanket accept of the content-type header. Our CORS config then becomes :

import qualified Network.HTTP.Types as HttpTypes
import Network.Wai (Middleware)
import Network.Wai.Middleware.Cors
  ( cors,
    corsExposedHeaders,
    corsMethods,
    corsRequestHeaders,
    simpleCorsResourcePolicy,
  )

corsConfig :: Middleware
corsConfig = cors (const $ Just policy)
  where
    policy =
      simpleCorsResourcePolicy
        { corsExposedHeaders = Just ["X-Total-Count"],
          corsMethods = [HttpTypes.methodGet, HttpTypes.methodPost, HttpTypes.methodHead, HttpTypes.methodOptions],
          corsRequestHeaders = [HttpTypes.hContentType]
        }

Alright, if we now try again it has to work hasn’t it, we fill out our content and press the save button and see … another error. Something about json not being defined.

Return the freshly created comment

It’s a bit of a stumper, but it is React’s way of telling us that it expects our response to contain a body of type JSON. This has to do with the internals of how React handles our response, but it tells us it wants a JSON response body, not just NoContent as we specified. Oh yes, remember, our POST method does not return any content. In a way it does not have to, but React-admin expects the freshly created comment to be returned as JSON. Going back to our REST server it means a few changes. Our POST resource type needs to be changed to return the comment.

"comments" :> ReqBody '[JSON] NewComment :> Post '[JSON] Comment

Our implementation also needs to return the comment :

insertComment :: NewComment -> AppM Comment
insertComment newComment = do
  commentsTransactionVar <- asks comments
  liftIO $ atomically $ do
    comments <- readTVar commentsTransactionVar
    let nextId = List.length comments + 1
    let comment = fromNewComment nextId newComment
    let updateComments = List.insert comment comments
    writeTVar commentsTransactionVar updateComments
    return comment

When we try it now we will see the insertion process works correctly but when we try to retrieve id 3 it does not seem to be present. Bizarre. In fact, no matter what we do, the only thing that is getting returned is our initial state.

Oh damn. Recall that we mentioned that initialization should not be done inside the Application type because Application is run for every request. Indeed. if we add a print statement to the api function :


app :: Application
app req res = do
  print "create initial state"
  initialState <- createInitialState
  corsConfig (createApplicationWithoutMiddleware initialState) req res

we would notice that this print statement appears for every request. Silly us. We do all that effort to update our internal state and then overwrite it everytime with the base state. Okay let’s fix this :


createInitialState :: IO State
createInitialState = do
  initalComments <- atomically $ newTVar fixedComments
  return $ State {comments = initalComments}

app :: ServerT WebApi Handler -> Application
app initedServer =
  corsConfig $ serve api initedServer

start :: Int -> IO ()
start port = do
  initialState <- createInitialState
  let initedServer = hoistServer api (runWithState initialState) server
  run port $ app initedServer

Now we initialize the server before we call the run function. It’s the run function that runs our app for every request. If we now add a comment we will no longer see errors and we will see our freshly created comment arriving.

Conclusion

Okay, we made it. This was a significant effort, passing by all layers that make up our application, having to learn new stuff about Servant, CORS and React-Admin. We will continue in the next blog with something a bit easier, deleting stuff. The code for this blog can be found here.