Authorization in Servant

Words of caution: This article is about servant-server 0.11's experimental-auth which is still in experimental stage. Deployment in production is not couraged. And yes, I know about servant-auth but I haven't read it thoroughfully, yet.

One of my friend once complained about the lacks of Servant's documentation on authorization, connecting to db, and many more. So, I want to help him.

Minimum Requirements

The reader of this article only has to understands basic haskell.

Final Result

We will have a working REST interface with the following scheme (or something):

/auth          POST -> requesting for jwt token.
/secrets       POST -> creating new secret. (JWT Auth.)
/secrets/:user GET  -> get secrets by username. (JWT Auth.)

Prerequisites.

There are a few things that we will use in this article. Namely:

A nice to have setup:

Installation.

We will create a servant project using stack. A pretty simple command line input will suffice. Something like this:

stack new OurServant servant

The previous line means that we ask stack to create a new project in folder named OurServant using servant template. There are many other templates, though. You can check it out. It's nice.

Then we will change our directory to our project's directory and open an emacs instance there.

cd OurServant; emacs . -nw

Navigate to OurServant.cabal and then you will see a part like the following:

library
  hs-source-dirs:     src
  exposed-modules:    Lib
  build-depends:      base >= 4.7 && < 5
                    , aeson
                    , servant-server
                    , wai
                    , warp
  default-language:   Haskell2010

Then you add dependencies:

And let's add a few other lines in our cabal file so it will look like the following:

library
  hs-source-dirs:     src
  exposed-modules:    Lib
  other-modules:      Models -- new
  build-depends:      base >= 4.7 && < 5
                    , aeson
                    , persistent --new
                    , persistent-mysql --new
                    , persistent-template --new
                    , servant-server
                    , text --new
                    , wai
                    , warp
  default-language:   Haskell2010

Writing Code

Database and Models

Then we will create a new haskell source file named Models.hs in src directory.

-- src/Models.hs
module Models where

import Data.Aeson -- json (de)serialisation.
import Data.Text
import Data.Time
import Database.Persist.Sql
import Database.Persist.TH

For each import lines above, we tell that we will use their functionality in our sources. And then, we will put the following lines below the previous part.

-- src/Models.hs
share
  [mkPersist sqlSettings, mkMigrate "migrateAll"]
  [persistLowerCase|
  Users json
    name Text maxlen=52 sqltype=varchar(52)
    pass Text maxlen=52 sqltype=varchar(52)
    Primary name
    -- Unique of table Users named Name referring column name.
    UniqueUsersName name
    deriving show
|]

The part of source code above means that we will create a migration plan named migrateAll by creating tables users which has name and pass columns and column name will be unique and will be used as the primary key. And the type of those two will be varchar with maximal length 52 characters.

If we try to compile our project by inputting stack build at our root project directory, it will produce error something like parse error on input '=' perhaps you need a 'let' in a 'do' block? It means that GHC doesn't understand that we use QuasiQuotes syntax extension in our code. So we will add it at the topmost of our source code.

{-# LANGUAGE QuasiQuotes #-}
module Models where

import Data.Aeson
import Data.Text

Again, we will receive an error stated that we have a naked expression and perhaps we intended to use TemplateHaskell. So, we'll add that syntax extension!

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Models where

import Data.Aeson

And again, it looks like the GHC refused to compile our source again. GHC suggested that we use TypeFamilies extension. So we will give it what it wants!

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Models where

But wait, there's more! Because UsersId in our data has a specialised result, we have to use ExistensialQualification or GADTs to allow this. And because we have added a Users json, which is an instance declaration for ToJSON, we have to use FlexibleInstance. GHC's suggestions are our commands~

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Models where

We can compile it just fine! And then, we will create a new table.

-- src/Models.hs
    UniqueUsersName name
    deriving Show Eq
  SuperSecrets json
    something Text
    at UTCTime
    by UsersId maxlen=52
    deriving Show Eq

It means that we declare that we will create a new table named super_secrets which has something column, a column with datetime type, and a foreign key by which refers to table users' primary key. Alas, when we compile our project, there will be an error stating that it is an illegal instance for ToBackendKey SqlBackend SuperSecrets but GHC suggests that we can use MultiParamTypeClasses to allow more. So we will reply GHC's call by applying the suggestion.

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Models where

Okay, it's cool and dandy when we compile it. Then, we will create a migration plan (I don't know how should it be called or its real name).

-- src/Models.hs
doMigration = runMigration migrateAll

When we compile it again, GHC will fail to compile because of ambiguous type variable m0. GHC inferred that doMigration has ReaderT SqlBackend m0 () as its type and has potential instance of IO in place of m0 as its fix. So we'll add that as doMigration's type signature.

-- src/Models.hs
doMigration :: ReaderT SqlBackend IO ()
doMigration = runMigration migrateAll

The next step is creating a model for our reply token and POST data for our REST interface. In order to be able to encode our data to Json, AuthUser have to derive Generic. Which in turn, we have to import GHC.Generics. And then GHC will suggest that we have to use DeriveGeneric extension. So we will do that!

-- src/Models.hs
{-# LANGUAGE DeriveGeneric #-}
import GHC.Generics
-- snip!
data AuthUser = AuthUser
  { authName :: Text
  , token    :: Text
  } deriving (Show, Generic, Eq)
data UsersSecret = UsersSecret
  { something :: Text
  } deriving (Show, Generic)

instance FromJSON AuthUser
instance ToJSON AuthUser
instance FromJSON UsersSecret
instance ToJSON UsersSecret

We don't have to create instances of FromJSON and ToJSON for our Users and SuperSecrets because in our template above, we have already declared that!

Communicating to Database.

We will take a shortcut without reading outside config whatsoever. That means, we will hardcode our database connection string etc to our code.

Next, we create a file named DB.hs in our src directory and then open it in our editor.

According to persistent-mysql documentation, we can create a connection pool to mysql using createMySQLPool which takes a ConnectInfo and an integer that represents number of pool connections.

-- src/DB.hs
module DB where

import Database.Persist.MySQL

createPool = createMySQLPool connection 5
  where
    connection =
      defaultConnectInfo
      { connectHost = "localhost"
      , connectPort = fromIntegral 3306
      , connectUser = "ibnu"
      , connectPassword = "jaran"
      , connectDatabase = "owo"
      }

When we compile that, we will receive an error that states that we have an error of ambiguous type. We can easily supress that error by defining our createPool's signature. But when we give our function a signature (IO ConnectionPool), we will receive an error that no instance of MonadLogger IO in our function. Again, that is an easy problem. We can import Control.Monad.Logger and put runStdoutLoggingT (a stdout logger transformer) in front of createMySQLPool. So, the final shape of the function is like the following snippet.

-- src/DB.hs
import Control.Monad.Logger

createPool :: IO ConnectionPool
createPool = runStdoutLoggingT $ createMySQLPool connection 5

After we have a wrapper for our connection pool, then we will create a query runner. That is, a function that takes a query and then execute it.

-- src/DB.hs
runQuery query = do
  pool <- createPool
  runSqlPool query pool

In order to be able to query, we have to import Database.Persist. And we will also create a normal sql query for looking a user in our db by username and password.

-- src/DB.hs
import Data.Text -- for our functions' signatures.
import Database.Persist
-- snip
lookUserByUsernameAndPassword :: Text -> Text -> IO (Maybe Users)
lookUserByUsernameAndPassword username password = do
  mUser <- runQuery $ selectFirst [UsersName ==. username, UsersPass ==. password] []
--case mUser of
--  Nothing -> return Nothin
--  Just user -> return $ Just $ entityVal user
  return $ fmap entityVal mUser

A little explanation:

Then we will create an insert and a get function for super_secrets table.

-- src/DB.hs
import Data.Text hiding (map)
import Data.Time
-- snip
lookSecretByUsername :: Text -> IO [SuperSecrets]
lookSecretByUsername username = do
  secrets <- runQuery $ selectList [SuperSecretsBy ==. (UsersKey username)]
  return $ map entityVal secrets
insertSecret :: Text -> UsersSecret -> IO (Key SuperSecrets)
insertSecret username usersSecret = do
  now <- getCurrentTime
  runQuery $
    insert $ SuperSecrets (something UsersSecret) now (UsersKey username)

A little explanation for first function:

What we've done so far, has been committed to git. Check it here.

Auth (JWT)

Our auth process is:

We will use JWT for our authentication and/or authorization framework. So, we will create a new source file named Auth.hs. But firstly, we have to define what kind of payload we will send and receive. So, let's say something like this:

{
  "exp": int64, --seconds since unix epoch.
  "iat": int64, --seconds since unix epoch.
  "jti": guid,
  "iss": string,
  "sub": string
  "name": string, -- an unregistered claim.
}

Because we have decided that we will use unix' epoch and guid, we will add guid and jwt packages into our dependencies. Don't forget to add Auth into other-modules.

-- cabal file.
  other-modules:      Models
                    , DB
                    , Auth --new
  build-depends:      base >= 4.7 && < 5
                    , aeson
                    , jwt --new
                    , guid --new

Because stack is unable to resolve guid, we have to input stack solver --update-config at our shell in our root directory and then we input stack build in shell.

So, we will edit src/Auth.hs in our editor.

-- src/Auth.hs
module Auth where
import Data.Time
import Data.Time.Clock.POSIX -- for our jwt's exp and iat.

nowPosix :: IO POSIXTime
nowPosix = do
  now <- getCurrentTime
  return $ utcTimeToPOSIXSeconds now

The explanation is just a standard explanation, nowPosix is a wrapper for the amount of seconds that have passed since unix epoch.

And then we will write our token creation function.

--src/Auth.hs
{-# LANGUAGE OverloadedStrings #-}
import Data.Aeson
import Data.GUID
import Data.Map as Map -- insert package `containers` into your dependecies in your cabal file.
import Prelude hiding (exp)
import Web.JWT
-- snip
createToken :: Users -> IO AuthUser
createToken user = do
  now <- nowPosix -- the previous function.
  guid <- genText -- from Data.GUID
  let creation = numericDate $ now
      expiration = numericDate $ now + 60
      claims =
        def
        { exp = expiration
        , iat = creation
        , iss = stringOrURI "issuer"
        , jti = stringOrURI guid
        , sub = stringOrURI "localhost"
        , unregisteredClaims =
            Map.fromList [ ("name", String $ usersName user)]
        }
      key = secret "Indonesia Raya"
      token = encodeSigned HS256 key claims
  return $ AuthUser (usersName user) token

Explanation

Then we will use the function above to match the query result from DB.

-- src/Auth.hs
-- snip
createTokenForUser :: Maybe Users -> IO AuthUser
createTokenForUser Nothing = return $ AuthUser "" ""
createTokenForUser (Just user) = createToken user

What we've done so far, has been committed to git. Check it here.

REST interface using Servant.

So, here we are, we will design our REST interface. So, navigate to src/Lib.hs and delete the content.

-- src/Lib.hs
module Lib where

import Data.Text -- To be able to use Text
import Servant  -- Servant's functions. Like, :>, :<|>, etc.
import Servant.Server.Experimental.Auth -- Auth

import Auth
import Models
import DB

type instance AuthServerData (AuthProtect "jwt-auth") = Users

type TopSekrit =
       "auth"
       :> ReqBody '[ JSON] Users
       :> Post '[ JSON] AuthUser
  :<|> "secrets"
       :> AuthProtect "jwt-auth"
       :> ReqBody '[ JSON] UsersSecret
       :> Post '[ JSON] ()
  :<|> "secrets"
       :> Capture "username" Text
       :> AuthProtect "jwt-auth"
       :> ReqBody '[ JSON] UsersSecret
       :> Get '[ JSON] [SuperSecrets]

If you compile the snippet above, you will get a lot of errors. For example, GHC suggests that we have to use DataKinds. And when have added that, we will get another error about illegal operators and how to fix it by adding TypeOperators extension. Which in turn, another error appeared, illegal family instance and how to fix it by adding TypeFamilies extension. After we've added those three extensions at the topmost source file, the source will be looked like this, and compiles just fine.

-- src/Lib.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Lib where

And the explanation of the snippet above is:

And then, we will create Context for our auth protected resources, where Context itself, in short, a list of our handler requirements.

So, we will create our secretContext:

- src/Lib.hs
{-# Language FlexibleContexts #-}
import Control.Error.Class
import Network.Wai

secretContext :: Context '[AuthHandler Request Users]
secretContext = mkAuthHandler secretHandler :. EmptyContext
  where
    secretHandler :: (MonadError ServantErr m) => Request -> m Users
    secretHandler req =
      case lookup "Authorization" (requestHeaders req) of
        Nothing -> throwError err401
        Just token -> undefined -- reserved for token validation.

Explanation:

What we've done so far, has been committed to git. Check it here.

So, let's open src/Auth.hs

-- src/Auth.hs
import Data.ByteString -- insert bytestring to your cabal dependencies.
import Data.Text
import Data.Text.Encoding
-- snip
decodeTokenHeader :: ByteString -> Maybe (JWT VerifiedJWT)
decodeTokenHeader rawToken = do
  jwt <- decodedJWT
  verify (secret "Indonesia Raya") jwt
  where
    (bearer, jwtBase64) = breakOnEnd " " $ decodeUtf8 rawToken
    decodedJWT = Web.JWT.decode jwtBase64

The snippet above means that

After that, we will create two functions, the first one will be used check the expiration of the token. And the second one will be used to get the name claim from the token.

-- src/Auth.hs
-- snip!
isTokenExpired :: JWT r -> IO Bool
isTokenExpired token = do
  now <- nowPosix
  case ((exp $ claims token), (numericDate now)) of
    (Just expiration, Just now) -> return $ expiration < now
    _ -> return True

This above function has the following explanation:

-- src/Auth.hs
import Data.String
-- snip!
getNameClaimsFromToken :: (FromJSON t, IsString t) => JWT r -> t
getNameClaimsFromToken token =
  case lookup "name" $ Map.toList $ unregisteredClaims $ claims token of
    Nothing -> ""
    Just a  ->
      case fromJSON a of
        Success s -> s
        Error _   -> ""

Compared to the previous function, this function is a bit longer.

The next step is creating a query into database to look for a user by its name. So, let's open src/DB.hs.

-- src/DB.hs
lookUserByUsername :: Text -> IO (Maybe Users)
lookUserByUsername username = do
  mUser <- runQuery $ selectFirst [UsersName ==. username] []
  return $ fmap entityVal mUser

Basically, the same explanation with lookByUsernameAndPassword function. But simpler because we only use one criterion.

Because we've written that function, let's back to src/Lib.hs and continue from undefined node of secretHandler.

-- src/Lib.hs
import Control.Monad.Class.IO
-- snip!
    secretHandler :: Request -> Handler Users
    secretHandler req =
      case lookup "Authorization" (requestHeaders req) of
        Nothing -> throwError err401
        Just token -> -- continue from here.
          case decodeTokenHeader token of
            Nothing -> throwError err401
            Just token -> getUserFromToken token
    getUserFromToken token = do
      expired <- liftIO $ isTokenExpired token
      if expired
        then throwError err401
        else do
          maybeUser <- liftIO $ lookUserByUsername . getNameClaimsFromToken $ token
          case maybeUser of
            Nothing -> throwError err401
            Just user -> return user

The continuation of the previous explanation is:

What we've done so far, has been committed to git. Check it here.

Writing Server Application.

After finishing the previous sections, we already have the requirements to create the server application. So, the next step is really building it!

Let's navigate to src/Lib.hs

-- src/Lib.hs
secretServer :: Server TopSekrit
secretServer = pAuthH :<|> pSecretH :<|> gSecretUserH
  where
    pAuthH :: (MonadIO m) => Users -> m AuthUser
    pAuthH requestFromUser = do
      mUser <-
        liftIO $
        lookUserByUsernameAndPassword (usersName requestFromUser) (usersPass requestFromUser)
      liftIO $ createTokenForUser mUser
    pSecretH :: (MonadIO m) => Users -> UsersSecret -> m (Key SuperSecrets)
    pSecretH users userSecret = do
      key <- liftIO $ insertSecret (usersName users) userSecret
      return key
    gSecretUserH :: (MonadIO m, MonadError ServantErr m) => Users -> Text -> m [SuperSecrets]
    gSecretUserH users username = do
      if (usersName users /= username)
        then throwError401 err401
        else liftIO $ lookSecretByUsername username

Let's explain that snippet a little.

After writing our server library's main function, we will continue by writing our proxy (whatever that means, actually. I don't understand it).

-- src/Lib.hs
import Database.Persist.Sql
import Network.Wai.Handler.Warp as Warp
secretProxy :: Proxy TopSekrit
secretProxy = Proxy

secretApp :: IO ()
secretApp = do
  runQuery doMigration
  Warp.run 8000 $ serveWithContext secretProxy authContext secretServer

Again, we will import a few modules for this function. Then we will make our secretProxy has the shape of TopSekrit. Ultimately, we will make our function as an IO wrapped function which will executer our database migration plan and then run the server (with our secretContext, secretProxy, and secretServer) at port 8000.

-- app/Main.hs
module Main where
import Lib

main :: IO ()
main = secretApp

The snippet above is our main function of our application. So, we just put the main function of our library.

Requesting auth ok!

The image above is the result of the request when there's data in db where name column equals to ibnu and pass column equals to jaran. Requesting auth not ok!

The image above is the result of the request when there's no data in db where name column equals to ibnu and pass column equals to kuda. Posting secret ok!

The image above is the result of the request when the request has Authorization header with a valid token. Posting secret not ok!

The image above is the result of the request when the request has Authorization header with a valid token but it has expired. Requesting secret ok!

Requesting secret not ok!

FINISH!

Final result of the walkthrough is here!

Index
Resume
Contact
About
Feed
This material is shared under the CC-BY License.