*tl;dr See the code at the end

Very often when developing a web application I run into the age-old problem of how to do partial updates. Doing the “U” (Update) in CRUD is actually a little more complicated than just accepting PUTs at some endpoint if you dont’ want to replace the object as a whole. I’ve often worked around this while maintaining somewhere-near spec complicance by just using the catch-all that is POST, and taking whatever object represented the update and doing whatever needed to be done.

There is however, a right (HTTP spec compliant) way to do things. A guy named William Durand has written a great blog post on the subject. Basically, to PATCHing like an idiot, use the objects, content types, and other conventions of the HTTP spec, turns out it’s not that hard. You no longer even have to accept this thing with a list of operations, there’s something called the merge-patch content type in the spec that let’s you send a sparse JSON structure!

After reading this (and a enought to be dangerous of the spec), I set about the task of updating Servant to handle this new content type. Turns out it’s pretty easy, but of course, because it’s me, I was confused for a while.

Making types MergePatchable

SKIP THIS if you just want to extend servant, the information below is for how I chose to handle doing the actual merge patching in a repeatable way

So, I’d like to avoid writing one-off controller functions/endpoints to handle merge patching certain resources, so I started to work on a type class that would accept and work with a theoretical MergePatchChangeObject type. The goal was to write a class that I can just implement one or two methods on that would handle merge patching in a reasonable way for types like Job and UserInfo.

class MergePatchable a where
    mergePatchableFields :: a -> HashMap DT.Text (Value -> a -> a)

    mergePatchFields :: a -> Object -> a
    mergePatchFields old = foldrWithKey (mergePatch old) old

    mergeChanges :: Object -> a -> a
    mergeChanges changes obj = mergePatchFields obj changes

    mergePatch :: a -> DT.Text -> Value -> a -> a
    mergePatch current k v old = maybe old (\f -> f v old) $ HMS.lookup k (mergePatchableFields current)

This is what I came up with. As you can see, most of the methods actually have automatic defaults, so all someone really needs to provide is mergePatchableFields, which is a map of text fields (the JSON property names) to functions that take a value (the JSON property’s value) and creates a new a (the MergePatchable type);

Here’s what the implementation looks like:

instance MergePatchable Company where
    mergePatchableFields _ = HMS.fromList [ ("companyName", \v old -> case v of {(String s) -> old { companyName=DT.unpack s }; _ -> old })

                                          , ("companyDescription", \v old -> case v of {(String s) -> old { companyDescription=s }; _ -> old })

                                          -- ... lots more fields and functions ...

                                          , ("companyAddressID", \v old -> case v of
                                                                             Number n -> old { companyAddressID=convertToInt n }
                                                                             Null -> old { companyAddressID=Nothing }
                                                                             _ -> old )

As you can see, it’s kinda of janky. I basically do a lot of unwrapping and casing to get the thing out of the JSON object, and then do record updates on the old. I’ve heard Lenses would make this better, but am not yet ready to jump into them… And not sure I ever will be. With this, I can just call

Extending Servant with the new content type

Extending servant with a new content type is a documented usecase, but in the end, I had to look at some code (particularly ContentTypes.hs) to figure out just what typeclasses I needed to instantiate and which classes I needed to create. The code I link to in the previous sentence had some great comments that helped me understand a log more. This reminds me of my intense disdain for people who think “good code should be self-commenting” that’s not a thing, no one shoudl think that, even overly verbose comments are far better than none. I understand there’s more nuance to it than “never use comments”, but I don’t care how expressive your language is, if it also allows for being clever (and being clever is part of using it axiomatically), then please leave me a comment with what you were actually trying to accomplish with the sick oneliner you wrote.

The code for this is actually pretty easy. I’ve included the imports I needed as well, since I often find that’s never provided and hard to find sometimes.

import           Data.Typeable (Typeable)
import           Network.HTTP.Media ((//), (/:))
import           Servant (Accept(..), MimeUnrender(..))

data PatchJSON deriving Typeable

instance Accept PatchJSON where
   contentType _ = "application" // "merge-patch+json" /: ("charset", "utf-8")

instance (Show a, Read a, FromJSON a) => MimeUnrender PatchJSON a where
   mimeUnrender _ = eitherDecodeLenient

Here’s the content type in use in a route:

-- ... lots of other routes ...
:<|> "jobs" :> "postings" :> "requests" :> CookieAuth :> Capture "id" JobPostingRequestID :> ReqBody '[PatchJSON] MergePatchChangeObject :> Patch '[JSON] (EnvelopedResponse (ModelWithID JobPostingRequest))
-- ... lots of other routes ...

With the changes added for the MergePatchable typeclass, my merge-patching controller function/endpoint for that route looks like this:

{-# ANN patchJobPostingRequestByID ("HLint: ignore" :: String) #-}
patchJobPostingRequestByID :: Auth.WAISession -> JobPostingRequestID -> MergePatchChangeObject -> WithApplicationGlobals Handler (EnvelopedResponse (ModelWithID JobPo\
stingRequest))
patchJobPostingRequestByID s jid changes = requireRoleFromRawSession Administrator s
                                           >> getBackendOrFail
                                           >>= \backend -> liftIO (getJobPostingRequestByID backend jid)
                                           >>= ifNothingThrowError Err.failedToUpdateResource
                                           >>= return . mergeChanges changes . model
                                           >>= liftIO . updateJobPostingRequestByID backend jid
                                           >>= ifNothingThrowError Err.failedToUpdateResource
                                           >>= return . EnvelopedResponse "success" "Successfully patched job posting request"

Ignore that Hlint ;)… It’s there because hlint wants me to use fmap, and I don’t want to, because it makes the cod eway harder to understand at a glance (at least the proposed way was).

You can see the code basically:

• Does a check for role from the logged in user
• Gets the backend (the utility function uses the ApplicationGlobals object that’s part of my non-standard Servant Monad stack WithApplicationGlobals)
• Attempts to get teh job posting request by ID
• If that’s missing, throw a servant error, stopping future processing
• Attempt to merge the changes that were provided into the actual model with the mergeChanges function provided by the MergePatchable typeclass
• Update the model with the changes on the backend
• If that fails, return an error
• Return enveloped response containing success message and the update result

Wrapping up

So while a lot more complexity here was added because of the MergePatchable typeclass, I think it was worth it because now in the future when I want to make another entity MergePatchable, there’s a simple, obvious way to do that, and it’ll be much quicker to write functions that use that functionality. Actually extending servant to recognize and check the right content type for merge-patch was something like 9 lines alltogether (including imports, and the route). Doesn’t get easier than that!