Typed & Authorized REST API with Servant: Part 1

Posted on March 6, 2016

TL;DR

Here is my attempt to build a simple authorized clockin/clockout time-logger using Servant for the backend. The Servant website offers some great tutorials, but in this post I offer my explanations and solutions to problems that I think anyone building with Servant will run into that perhaps aren’t properly addressed elsewhere.

See the end product on github.

Motivation

I recently wanted to build a demo app using Haskell, and was faced with problem of choosing what stack of libraries to use. There are a lot to choose from.

Yesod came highly recommended at /r/haskell, and after giving it a solid run, and a couple weeks’ effort, I found it was a bit too opinionated for me. Part of what I love about Haskell is solving problems by composing lower-level pieces in a modular way, but Yesod is a bit too opinionated for me.

I tried a few other of the most common options, and while many of them felt like they were straight ports of other notable imperative web frameworks, one stood out against the rest.

Disclaimer

I made this post for my own benefit, as a way of dumping my thoughts into text. As such, it is lacking a level of polish. (read: any level of polish ;) )

I hope to clean it up sometime when it’s design settles, and I am able to formulate it into prettier little value bombs.

1. MVP, simple servant app

{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators   #-}
module Lib
    ( startApp
    , app
    ) where

-- Server - type family
-- Handler - monad

import Data.Aeson
import Data.Aeson.TH
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Network.Wai
import Network.Wai.Handler.Warp
import Servant

data TimeEntry = TimeEntry
  { clockin :: UTCTime
  , description :: String
  } deriving (Eq, Show)

$(deriveJSON defaultOptions ''TimeEntry)

type API = "times" :> Get '[JSON] [TimeEntry]

-- dummy data
times :: [TimeEntry]
times = [ TimeEntry (posixSecondsToUTCTime 0) "first"
        , TimeEntry (posixSecondsToUTCTime 2) "second"]

api :: Proxy API
api = Proxy

server :: Server API -- `Server` is a type family
server = return times

app :: Application
app = serve api server

startApp :: IO ()
startApp = run 8080 app

visit: http://localhost:8080/times

2. Capturing URL Vars

You can capture a variable from the client-requested URI using Servant’s Capture. Notice that a Capture is part of the type level DSL, and then the server’s endpoint is supplied with a function that takes the captured value.

type API = "times" :> Get '[JSON] [TimeEntry]
      :<|> "times" :> Capture "timeid" Int :> Get '[JSON] TimeEntry
      
server :: Server API
server = listTimes
    :<|> getTime

  where listTimes :: Handler [TimeEntry]
        listTimes = return times

        -- Captured data becomes input to this function
        getTime :: Int -> Handler TimeEntry
        getTime i = return $ head $ filter (\t -> timeid t == i) times -- warning: `head` is a partial function, so errors when `filter` returns an empty list

visit: http://localhost:8080/times/1

If you enter a timeid that doesn’t exist, it will error. This is because I wrote the minimum viable way of searching through a list of times which future iterations will address.

3. liftIO

In order to use effects, such as the current time on the system clock, use liftIO.

type API = ...
           :<|> "now" :> Get '[JSON] UTCTime

server = ...
         :<|> now

  where ...
        now :: Handler UTCTime
        now = liftIO getCurrentTime >>= return

visit: http://localhost:8080/now

4. Errors

The standard monad stack allows you to easily return http codes as errors using throwError errXXX.

{-# LANGUAGE OverloadedStrings #-}
type API = ...
           :<|> "error" :> Get '[JSON] String

server = ...
         :<|> error
  where ...
        error :: Handler String
        error = throwError err503 { errBody = "a dinosaur ate the server" }

visit: http://localhost:8080/error

5. Decomposing the API into Separate Concerns

This was an experiment to see how routes in Servant compose.

{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators   #-}
{-# LANGUAGE OverloadedStrings #-}
module Lib
    ( startApp
    , app
    ) where

-- Server - type family
-- Handler - monad

import Data.Aeson
import Data.Aeson.TH
import Data.Time (UTCTime, getCurrentTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)

import Control.Monad.IO.Class (liftIO)

import Network.Wai
import Network.Wai.Handler.Warp
import Servant

data TimeEntry = TimeEntry
  { timeid :: Int
  , clockin :: UTCTime
  , description :: String
  } deriving (Eq, Show)

$(deriveJSON defaultOptions ''TimeEntry)

times :: [TimeEntry]
times = [ TimeEntry 1 (posixSecondsToUTCTime 0) "first"
        , TimeEntry 2 (posixSecondsToUTCTime 2) "second"]

----------

type MiscAPI = "now" :> Get '[JSON] UTCTime
               :<|> "error" :> Get '[JSON] String

type TimesAPI = Get '[JSON] [TimeEntry]
                :<|> Capture "timeid" Int :> Get '[JSON] TimeEntry

type API = MiscAPI
           :<|> "times" :> TimesAPI

miscServer :: Server MiscAPI
miscServer = now
             :<|> error
  where
        now :: Handler UTCTime
        now = liftIO getCurrentTime >>= return
        error :: Handler String
        error = throwError err404 { errBody = "a dinosaur ate the server" }

timesServer :: Server TimesAPI
timesServer = listTimes
              :<|> getTime
  where listTimes :: Handler [TimeEntry]
        listTimes = return times

        getTime :: Int -> Handler TimeEntry
        getTime i = return $ head $ filter (\t -> timeid t == i) times
        
server :: Server API
server = miscServer
         :<|> timesServer

api :: Proxy API
api = Proxy

app :: Application
app = serve api server

startApp :: IO ()
startApp = run 8080 app

6. Basic Auth - PS don’t use it

Servant offers a little basic auth, but they recommend against using it. I played with it here since it is a minimal case that shows me how to deal with auth in this app.

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}

import Data.Typeable (Typeable)
import GHC.Generics (Generic)

type MiscAPI = ...
    :<|> "protected" :> BasicAuth "some-realm" User :> Get '[JSON] String

miscServer = ...
    protected :: User -> Handler String
    protected (User user) = return "you found the secret!"

authCheck :: BasicAuthCheck User
authCheck = BasicAuthCheck check
  where
    --check :: (Monad m) => BasicAuthData -> m (BasicAuthResult usr)
    check (BasicAuthData str pwd) = if str == "superman"
                                      then return (Authorized (User "why is text so weird!"))
                                      else return Unauthorized

7. Auth: Setup

servant-auth

I decided to use the servant-auth library since it is inline with Servant’s “typed api” philosophy and offers a lot of the security primitives I need.

-- Types and Utility Fn
data User = User { name :: String, email :: String }
   deriving (Eq, Show, Read, Generic)

instance ToJSON User
instance ToJWT User
instance FromJSON User
instance FromJWT User

data Login = Login { username :: String, password :: String }
   deriving (Eq, Show, Read, Generic)

instance ToJSON Login
instance FromJSON Login

checkCreds :: CookieSettings -> JWTSettings -> Login
  -> Handler (Headers '[Header "Set-Cookie" SetCookie] String)
checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do
   let usr = User "Ali Baba" "ali@email.com"
   mcookie <- liftIO $ makeCookie cookieSettings jwtSettings usr
   case mcookie of
     Nothing     -> throwError err401
     Just cookie -> return $ addHeader cookie $ show cookie
checkCreds _ _ _ = throwError err401

8. Auth: JWT Tokens

There is a heated debate about when to use or not use JWT Tokens. For example, a JWT Token is difficult to invalidate when a user logs out.

Here is how you would use them. Notice that the protected function expects an AuthResult and if it doesn’t contain a User, the API returns a 401 Unauthorized error.

type API auths = ...
                 :<|> (Auth auths User :> Protected)
                 
type Protected
    = "name"  :> Get '[JSON] String
 :<|> "email" :> Get '[JSON] String

protected :: AuthResult User -> Server Protected
protected (Authenticated user) = return (name user) :<|> return (email user)
protected _ = throwAll err401

9. Auth: Cookies

If you use cookies to hold a JWT Token to authorize a session, you haven’t really solved the above-mentioned problems, but nonetheless, cookies are a useful tool to have depending on how you use them. Here’s how to do cookies with servant-auth.

type Unprotected =
 "login"
     :> ReqBody '[JSON] Login
     :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie] String)
  :<|> Raw

unprotected :: CookieSettings -> JWTSettings -> Server Unprotected
unprotected cs jwts = checkCreds cs jwts
                 :<|> serveDirectory "example/static"

Conclusion

This post is a bit of a dump of all of the things I’ve learned so far. I kind of prefer posts that are high-content low fluff, so forgive if I under explained anything.

In a future post I may include things like

abstracting CRUD endpoints
adding a PostGres database (Persistent)
adding user roles to the authorization workflow
and how to create users that can be authenticated in the first place.

And here’s the finished product so far! Note that the protected routes need a header like: "Authorization Bearer "eyJhb..." that contain a valid token for the keys of that session.

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeOperators     #-}

module Lib
    ( startApp
    ) where

import Data.Aeson
import Data.Aeson.TH
import Data.Text              (Text, pack, unpack)
import Data.Time              (UTCTime, getCurrentTime)
import Data.Time.Clock.POSIX  (posixSecondsToUTCTime)
import Data.Typeable          (Typeable)

import Control.Monad.IO.Class (liftIO)

import GHC.Generics           (Generic)

import Network.Wai
import Network.Wai.Handler.Warp

import Servant
import Servant.Auth.Server
import Servant.Auth.Server.SetCookieOrphan ()

--------------------------------------------------
-- Types

data TimeEntry = TimeEntry
  { timeid :: Int
  , clockin :: UTCTime
  , description :: String
  } deriving (Eq, Show)

$(deriveJSON defaultOptions ''TimeEntry)

times :: [TimeEntry]
times = [ TimeEntry 1 (posixSecondsToUTCTime 0) "first"
        , TimeEntry 2 (posixSecondsToUTCTime 2) "second"]

--------------------------------------------------
-- Misc API

type MiscAPI = "now" :> Get '[JSON] UTCTime
          :<|> "error" :> Get '[JSON] String

miscServer :: Server MiscAPI
miscServer = now
             :<|> error
  where
        now :: Handler UTCTime
        now = liftIO getCurrentTime >>= return
        error :: Handler String
        error = throwError err404 { errBody = "a dinosaur ate the server" }
        
--------------------------------------------------
-- Time API

type TimesAPI = Get '[JSON] [TimeEntry]
           :<|> Capture "timeid" Int :> Get '[JSON] TimeEntry

timesServer :: Server TimesAPI
timesServer = listTimes
              :<|> getTime
  where listTimes :: Handler [TimeEntry]
        listTimes = return times

        getTime :: Int -> Handler TimeEntry
        getTime i = return $ head $ filter (\t -> timeid t == i) times

--------------------------------------------------
-- Auth API

type Protected
    = "name"  :> Get '[JSON] String
 :<|> "email" :> Get '[JSON] String

type Unprotected =
 "login"
     :> ReqBody '[JSON] Login
     :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie] String)
  :<|> Raw

protected :: AuthResult User -> Server Protected
protected (Authenticated user) = return (name user) :<|> return (email user)
protected _ = throwAll err401

unprotected :: CookieSettings -> JWTSettings -> Server Unprotected
unprotected cs jwts = checkCreds cs jwts
                 :<|> serveDirectory "example/static" 

--------------------------------------------------
-- servant-auth

data User = User { name :: String, email :: String }
   deriving (Eq, Show, Read, Generic)

instance ToJSON User
instance ToJWT User
instance FromJSON User
instance FromJWT User

data Login = Login { username :: String, password :: String }
   deriving (Eq, Show, Read, Generic)

instance ToJSON Login
instance FromJSON Login

checkCreds :: CookieSettings -> JWTSettings -> Login
  -> Handler (Headers '[Header "Set-Cookie" SetCookie] String)
checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do
   let usr = User "Ali Baba" "ali@email.com"
   mcookie <- liftIO $ makeCookie cookieSettings jwtSettings usr
   case mcookie of
     Nothing     -> throwError err401
     Just cookie -> return $ addHeader cookie $ show cookie
checkCreds _ _ _ = throwError err401

--------------------------------------------------
-- RUN

type API auths = MiscAPI
                 :<|> "times" :> TimesAPI
                 :<|> (Auth auths User :> Protected)
                 :<|> Unprotected

server :: CookieSettings -> JWTSettings -> Server (API auths)
server cs jwts = miscServer
                 :<|> timesServer
                 :<|> protected
                 :<|> unprotected cs jwts

startApp :: IO ()
startApp = do
  myKey <- generateKey
  let jwtCfg = defaultJWTSettings myKey
      cfg = defaultCookieSettings :. jwtCfg :. EmptyContext
      api = Proxy :: Proxy (API '[JWT])

  -- generate a valid test token
  etoken <- makeJWT (User "charizard" "pokemon.awesome@hotmail.com") jwtCfg Nothing
  case etoken of
    Left e -> putStrLn $ "Error generating token: " ++ show e 
    Right v -> putStrLn $ "try this: " ++ "curl -H \"Authorization: Bearer " ++ show v ++ "\" localhost:8080/name -v"
    
  run 8080 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)

-- outputs something like the following, before starting the server:
-- curl -H "Authorization: Bearer "eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJjaGFyaXphcmQuYXdlc29tZUBob3RtYWlsLmNvbSIsIm5hbWUiOiJjaGFyaXphcmQifX0.t-VlSuSZi6l67uguOEZXDBkcMkxMvDx-f8sRVMPy-O8"" localhost:8080/name -v