Servant, persistent, and DSLs

2015-06-28

A few days ago I hinted on how I used servant with persistent on reddit. My approach is about using a few DSLs to simplify the definition of the web application, and to make sure that all important side effects (authentication, access control, database failures, etc.) are handled in a single place. In this post I will define a DSL for access right management and another for writing the webservice itself.

I tried to extract the gist of my engine in that post, so this might seem a bit overengineered for such a simple example. Also I just made sure it compiled, and did not test it, so it might be buggy :)

This post is a literate Haskell file. It assumes you are already knowledgeable about servant, persistent and operational (for the last one, being familiar with free will be enough).

{-# LANGUAGE KitchenSink #-}

I am using servant, persistent and lens in this example, so there is quite a bit of boilerplate, as expected.

{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}

module Main where

import           Control.Lens
import           Control.Monad
import           Control.Monad.Error.Class
import           Control.Monad.IO.Class
import           Control.Monad.Logger
import qualified Control.Monad.Operational  as O
import           Control.Monad.Operational  hiding (view)
import           Control.Monad.Reader       (ask)
import           Control.Monad.Trans.Either
import           Data.Aeson
import           Data.Int
import qualified Data.Foldable              as F
import           Database.Persist.Sql
import           Database.Persist.Sqlite
import           Database.Persist.TH
import           Data.Text.Lens
import           Data.Text                  (Text)
import qualified Network.Wai.Handler.Warp
import           Servant

import AccessType

The AccessType module just exports the following definition, along with all the instances required to use it with servant and persistent :

data AccessType = NoAccess | ReadOnly | ReadWrite | Owner

Persistent model

A person is a user of the blog. They can have a special attribute that marks them as administrators, meaning they have all rights.

share [ mkPersist sqlSettings { mpsGenerateLenses = True }
      , mkMigrate "migrateAll"]
      [persistLowerCase|
Person json
    name Text
    isAdmin Bool
    UniqueName name
    deriving Show

The BlogPost definition is pretty basic.

BlogPost json
    title Text
    content Text
    deriving Show

Finally we have a table that associates an access right to a person. When no matching record exists, the access right is equivalent to NoAccess.

PostRights json
    person PersonId
    post BlogPostId
    access AccessType
    UniqueRight person post
    deriving Show
|]

API definition

I use a few tricks to define the API. The first one was stolen from this reddit comment:

type CRUD a = DN :> ReqBody '[JSON] a :> Post '[JSON] (MKey a) -- create
         :<|> DN :> Capture "id" (MKey a) :> Get '[JSON] a -- read
         :<|> DN :> Capture "id" (MKey a) :> ReqBody '[JSON] a :> Put '[JSON] () -- update
         :<|> DN :> Capture "id" (MKey a) :> Delete '[JSON] () -- delete

It lets you factor the four endpoints you will need for a basic CRUD interface, and will prove handy during the API definition. It uses some helper types:

type DN = Header "dn" Text

DN is a header that is provided by the web server. There is a web-facing server that handles the TLS authentication, adds the dn header when it succeeds or drops the connection when it fails. This field contains the distinguished name of the certificate the user presented. I can trust this value as much as I can trust my PKI, and will not verify it in the application code.

newtype MKey a = MKey { getMKey :: Int64 }
               deriving (FromJSON, ToJSON, FromText)

_MKey :: ToBackendKey SqlBackend a => Iso' (MKey a) (Key a)
_MKey = iso (toSqlKey . getMKey) (MKey . fromSqlKey)

The _MKey is a newtype that is isomorphic to persistent's Key. It is needed because Key does not have the instances I need to use it with servant. In this case the user-facing id of the entities will be their primary key in the database. Don't try this at home!

The API itself is just made of CRUD enpoints for Person and BlogPost :

type MyApi = "person" :> CRUD Person
        :<|> "post"   :> CRUD BlogPost

myApi :: Proxy MyApi
myApi = Proxy

Permission checking DSL

The first DSL that I am going to introduce is for permission checking. This will look overengineered in this toy program, but it turns out I can have funky permissions for my use case.

I use the operational package, mostly because I am used to it. It is overkill as this particular DSL probably only requires an Applicative instance. But as the next DSL requires a full Monad instance, both will be defined using the same machinery to keep things consistent.

Let's start with defining the actions :

type PermProgram = Program PermCheck
data PermCheck a where
    IsAdmin       :: PermCheck Bool
    BlogPostRight :: Key BlogPost -> PermCheck AccessType

I just have a pair of them here, but you should add one each time there is a new kind of access type you will need to enforce.

Now here are a few helper functions :

-- checks that the current user is an administrator
isAdmin :: PermProgram Bool
isAdmin = singleton IsAdmin

-- returns the access right of the current user on a particular blog post
blogPostRight :: Key BlogPost -> PermProgram AccessType
blogPostRight = singleton . BlogPostRight

-- checks that an `AccessType` is at least `ReadOnly`
ro :: PermProgram AccessType -> PermProgram Bool
ro = fmap (>= ReadOnly)

-- checks that an `AccessType` is at least `ReadWrite`
rw :: PermProgram AccessType -> PermProgram Bool
rw = fmap (>= ReadWrite)

-- checks that an `AccessType` is at least `Owner`
owner :: PermProgram AccessType -> PermProgram Bool
owner = fmap (>= Owner)

-- helper function for actions that everyone can perform
always :: PermProgram Bool
always = pure True

-- operator for "or-ing" two permission checking actions
(.||) :: PermProgram Bool -> PermProgram Bool -> PermProgram Bool
(.||) = liftM2 (||)

-- operator for "and-ing" two permission checking actions
(.&&) :: PermProgram Bool -> PermProgram Bool -> PermProgram Bool
(.&&) = liftM2 (&&)

And here is the kind of expression you can write :

isAdmin .|| (ro (blogPostRight postid) .&& owner (commentRight commentid))

Web application DSL

This DSL is a bit more complicated. It exposes primitives for interacting safely with the database and a way to cancel the computation and throw errors at the user. We expect the error throwing part to cancel the current SQL transaction and spit an error message to the webservice user.

The instructions are a direct mapping of their counterpart in persistent. The WebService monad is not an instance of MonadError ServantErr because "catching" an exception would not make sense (it would require nested SQL transactions, which I know nothing about). As all sort of constraints on our values are required to make persistent happy, the PC constraint synonym as been created.

In the real life, you will probably need a more versatile database access (arbitrary selects and deletes using esqueleto), logging and other goodies. They are not required for our simple example.

type WebService = Program WebAction
type PC val = (PersistEntityBackend val ~ SqlBackend, PersistEntity val)
data WebAction a where
    Throw :: ServantErr               -> WebAction a
    Get   :: PC val => Key val        -> WebAction (Maybe val)
    Del   :: PC val => Key val        -> WebAction ()
    GetBy :: PC val => Unique val     -> WebAction (Maybe (Entity val))
    New   :: PC val =>            val -> WebAction (Key val)
    Upd   :: PC val => Key val -> val -> WebAction ()

-- throws an error
throw :: ServantErr -> WebService a
throw = singleton . Throw

-- dual of `persistent`'s `get`
mget :: PC val => Key val -> WebService (Maybe val)
mget = singleton . Get

-- dual of `persistent`'s `getBy`
mgetBy :: PC val => Unique val ->  WebService (Maybe (Entity val))
mgetBy = singleton . GetBy

-- dual of `persistent`'s `insert`
mnew :: PC val => val ->  WebService (Key val)
mnew = singleton . New

-- dual of `persistent`'s `update`
mupd :: PC val => Key val -> val -> WebService ()
mupd k v = singleton (Upd k v)

-- dual of `persistent`'s `delete`
mdel :: PC val => Key val -> WebService ()
mdel = singleton . Del

-- like `mget` but throws a 404 if it could not find the corresponding record
mgetOr404 :: PC val => Key val -> WebService val
mgetOr404 = mget >=> maybe (throw err404) return

-- like `mgetBy` but throws a 404 if it could not find the corresponding record
mgetByOr404 :: PC val => Unique val -> WebService (Entity val)
mgetByOr404 = mgetBy >=> maybe (throw err404) return

Evaluating the permissions checking DSL

Now that we have defined the web application DSL, it's trivial to evaluate our expression checking DSL into it.

-- Given the current user, runs a `PermProgram` in the `WebService` monad.
checkPerms :: Entity Person -> PermProgram a -> WebService a
checkPerms ent cnd = eval (O.view cnd)
    where
        usr = entityVal ent
        userkey = entityKey ent
        eval :: ProgramView PermCheck a -> WebService a
        eval (Return a) = return a
        eval (IsAdmin :>>= nxt) =
              checkPerms ent (nxt (_personIsAdmin usr))

There might be no matching record when retrieving the access rights a given user has on a given blog post. In that case, NoAccess should be used.

        eval (BlogPostRight k :>>= nxt) =
              mgetBy (UniqueRight userkey k)
                  >>= checkPerms ent
                    . nxt
                    . maybe NoAccess (_postRightsAccess . entityVal)

Evaluating the web application DSL

Now we are going to turn the WebService type into something that can be used with persistent :

type ServantIO a = SqlPersistT (LoggingT (EitherT ServantErr IO)) a

The conversion practically writes itself, except for handling rollbacks. There is only one thing you should take care of: never use a bare throwError, except in the Throw handler, as the whole point of this exercise is to ensure that sessions are properly rollbacked in case of errors.

runServant :: WebService a -> ServantIO a
runServant ws = case O.view ws of
                  Return a -> return a
                  a :>>= f -> runM a f

runM :: WebAction a -> (a -> WebService b) -> ServantIO b
runM x f = case x of
    Throw rr@(ServantErr c rs _ _) -> do
                  conn <- ask
                  liftIO $ connRollback conn (getStmtConn conn)
                  logOtherNS "WS" LevelError (show (c,rs) ^. packed)
                  throwError rr
    Get k    -> get k       >>= tsf
    New v    -> insert v    >>= tsf
    Del v    -> delete v    >>= tsf
    GetBy u  -> getBy u     >>= tsf
    Upd k v  -> replace k v >>= tsf
  where
      tsf = runServant . f

Implementing the API

I start with defining a record that will hold the permission checking functions for my four CRUD actions:

data PermsFor a = PermsFor { _newPerms :: PermProgram Bool
                           , _getPerms :: Key a -> PermProgram Bool
                           , _updPerms :: Key a -> PermProgram Bool
                           , _delPerms :: Key a -> PermProgram Bool
                           }

adminOnly :: PermsFor a
adminOnly = PermsFor isAdmin (const isAdmin) (const isAdmin) (const isAdmin)

The runCrud function handles most of the logic. It needs as arguments a connection pool, the previously defined record, and two optional functions.

The first optional function is used when creating a new item in the database. It is here to setup appropriate rights for the object that was just created (set its owner).

The second optional function is used to perform additional cleanup before object deletion. Its main use is to remove cross references.

As a result you get all four crud actions defined and ready to use by the serve function!

runCrud :: (PersistEntity a, ToBackendKey SqlBackend a, PC b)
        => ConnectionPool -- ^ Connection pool
        -> PermsFor a -- ^ Permission checking record
        -> Maybe (Key Person -> Key a -> AccessType -> b)
           -- ^ Extra actions after creation
        -> Maybe (Key a -> WebService ()) -- ^ Extra actions after deletion
        -> (      Maybe Text           -> a -> EitherT ServantErr IO (MKey a))
           :<|> ((Maybe Text -> MKey a      -> EitherT ServantErr IO a)
           :<|> ((Maybe Text -> MKey a -> a -> EitherT ServantErr IO ())
           :<|> ( Maybe Text -> MKey a      -> EitherT ServantErr IO ()))
           )
runCrud pool (PermsFor pnew pget pupd pdel) rightConstructor predelete =
          runnew :<|> runget :<|> runupd :<|> rundel
    where
        auth Nothing _ = throw err401
        auth (Just dn) perm = do
            user <- mgetBy (UniqueName dn) >>= maybe (throw err403) return
            check <- checkPerms user perm
            unless check (throw err403)
            return user
        runget dn mk = runQuery $ do
            let k = mk ^. _MKey
            void $ auth dn (pget k)
            mgetOr404 k
        runnew dn val = runQuery $ do
            usr <- auth dn pnew
            k <- mnew val
            F.mapM_ (\c -> mnew (c (entityKey usr) k Owner)) rightConstructor
            return (k ^. from _MKey)
        runupd dn mk val = runQuery $ do
            let k = mk ^. _MKey
            void $ auth dn (pupd k)
            mupd k val
        rundel dn mk = runQuery $ do
            let k = mk ^. _MKey
            void $ auth dn (pdel k)
            F.mapM_ ($ k) predelete
            mdel k
        runQuery :: WebService a -> EitherT ServantErr IO a
        runQuery ws = runStderrLoggingT $ runSqlPool (runServant ws) pool

The last touch is a default null action that is going to be used when you do not need to setup extra stuff after object creation. You cannot just throw a Nothing as the type inference will fail (in the definition of runCrud you can see there is a b that needs to be known, even if it is not used). I picked randomly one of the available types that satisfy the PersistEntity constraint.

-- A default action for when you need not run additional actions after creation
noCreateRightAdjustment :: Maybe (Key Person -> Key a -> AccessType -> PostRights)
noCreateRightAdjustment = Nothing

Serving the API

The server function takes a ConnectionPool and can be directly served by ... the serve function from servant. It should be painless to add additional CRUD endpoints.

server :: ConnectionPool -> Server MyApi
server pool =
      runCrud pool adminOnly noCreateRightAdjustment Nothing
 :<|> defaultCrud blogPostRight PostRights Nothing
   where
     editRights c cid = rw (c cid) .|| isAdmin
     delRights c cid = owner (c cid) .|| isAdmin
     defaultPermissions c =
          PermsFor always
                  (const always)
                  (editRights c)
                  (delRights c)
     defaultCrud c r d = runCrud pool (defaultPermissions c)
                                 (Just r) d

Finally, the main function creates the connection pool, run the migration scripts and starts the web service.

main :: IO ()
main = do
  pool <- runStderrLoggingT $ do
      p <- createSqlitePool ":memory:" 1
      runSqlPool (runMigration migrateAll) p
      return p
  Network.Wai.Handler.Warp.run 8080 (serve myApi (server pool))

Conclusion

I am not sure how this post went. When I started it, I expected it to be just a few lines long, but it turned out I had to add all kind of parts to have a complete example that somebody else could compile and run. Hopefully it demonstrates how easy it is to integrate different libraries with the help of DSL glue.

What it didn't show is how useful this might be for testing, as you "just" need to write a pure variant of runServant that will mock the database endpoints to verify your logic.

This might also look overengineered, but I wrote all this machinery for a webservice that has around 100 endpoints, so the ability to concisely describe the endpoint logic and expected access rights pays off well.

Hbtvl