HTTP Basic Authentication with Servant

README.md

The authentication story for Servant is still in the works. Until that's finalized this gist may be useful for anyone who wants to add HTTP Basic Authentication to their Servant clients.

Try it out.

$ stack ghci servant-client servant-server --resolver=lts-3.14
Run from outside a project, using implicit global project config
Using resolver: lts-3.14 specified on command line
Configuring GHCi with the following packages: 
GHCi, version 7.10.2: http://www.haskell.org/ghc/  :? for help
Ok, modules loaded: none.

Load Main.hs.

Prelude> :load Main
[1 of 1] Compiling Main             ( Main.hs, interpreted )
Ok, modules loaded: Main.

Let's send a GET request to https://httpbin.org/basic-auth/alice/pass123 without login credentials.

*Main> runEitherT $ http "" "alice" "pass123"
Left (FailureResponse {responseStatus = Status {statusCode = 401, statusMessage = "UNAUTHORIZED"}, responseContentType = application/octet-stream, responseBody = ""})

Fails as expected. Let's try as the user "alice", but with an empty password.

*Main> runEitherT $ http "alice:" "alice" "pass123"
Left (FailureResponse {responseStatus = Status {statusCode = 401, statusMessage = "UNAUTHORIZED"}, responseContentType = application/octet-stream, responseBody = ""})

Also fails as expected. Finally, let's try to login with "alice:pass123".

*Main> runEitherT $ http "alice:pass123" "alice" "pass123"
Right (Response {authenticated = True, user = "alice"})

Success!

Main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Main where

import Control.Monad.Trans.Either
import Data.Aeson
import GHC.Generics
import Servant
import Servant.API
import Servant.Client
import Servant.Common.Req

import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import qualified Data.Text.Encoding as TE
import qualified Data.Text as T

data Response = Response
    { authenticated :: Bool
    , user :: String
    } deriving (Generic, Show)

instance FromJSON Response

type HTTPBin =
    "basic-auth" :> Capture "user" String
                 :> Capture "pass" String
                 :> Get '[JSON] Response

api :: Proxy HTTPBin
api = Proxy

authenticate :: String -> Req -> Req
authenticate creds req = req { headers = authHeader : headers req }
  where
    authHeader = ("Authorization", T.append "Basic " token)
    token = TE.decodeUtf8 (B64.encode (B.pack creds))

http :: String -> String -> String -> EitherT ServantError IO Response
http creds = clientWithRoute api req base
  where
    req = authenticate creds defReq
    base = BaseUrl Https "httpbin.org" 443