servant-token-bearer.hs

#! /usr/bin/env nix-shell
#! nix-shell -i runghc -p "haskellPackages.ghcWithPackages (pkgs: with pkgs; [servant-server])"
-- =======================================================================
--
-- If you have have Nix installed — just run this script as an executable:
--
-- $ ./servant-token-bearer.hs
-- Starting server at http://localhost:8088
--
-- You can then check that everything works using cURL:
--
-- $ curl 'http://localhost:8088'
-- "Hello, anonymous!"
--
-- $ curl -H'Authorization: secret-token' 'http://localhost:8088'
-- Error parsing header Authorization failed: cannot extract auth Bearer
--
-- $ curl -H'Authorization: Bearer secret-token' 'http://localhost:8088'
-- "Hello, <secret-token>!"
--
-- $ curl -I 'http://localhost:8088/auth'
-- HTTP/1.1 200 OK
-- Date: Thu, 08 Nov 2018 11:51:50 GMT
-- Server: Warp/3.2.25
-- Content-Type: application/json;charset=utf-8
-- Authorization: Bearer sample-token
--
-- =======================================================================
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import           Data.Proxy
import           Data.Text                        (Text)
import           Data.Text.Encoding               (decodeUtf8, encodeUtf8)
import qualified Network.Wai.Handler.Warp         as Warp
import qualified Network.Wai.Middleware.HttpAuth  as Wai
import           Servant
import           Web.HttpApiData                  (FromHttpApiData(..))

newtype Token = Token Text

instance FromHttpApiData Token where
  parseQueryParam = parseHeader . encodeUtf8
  parseHeader header = maybe
    (Left "cannot extract auth Bearer")
    (Right . Token . decodeUtf8)
    (Wai.extractBearerAuth header)

instance ToHttpApiData Token where
  toQueryParam (Token token) = "Bearer " <> token

type HelloAPI
    = Header "Authorization" Token :> Get '[JSON] Text
 :<|> "auth" :> Get '[JSON] (Headers '[Header "Authorization" Token] NoContent)

helloAPI :: Proxy HelloAPI
helloAPI = Proxy

helloHandler :: Maybe Token -> Handler Text
helloHandler (Just (Token token)) = return ("Hello, <" <> token <> ">!")
helloHandler Nothing = return ("Hello, anonymous!")

authHandler :: Handler (Headers '[Header "Authorization" Token] NoContent)
authHandler = return (addHeader (Token "sample-token") NoContent)

main :: IO ()
main = do
  putStrLn $ "Starting server at http://localhost:" <> show port
  Warp.run port $ serve helloAPI (helloHandler :<|> authHandler)
  where
    port = 8088