From e3d41fd544d097af676d7b4014d1bde3c0ba5cd6 Mon Sep 17 00:00:00 2001
From: Arian van Putten <aeroboy94@gmail.com>
Date: Thu, 1 Oct 2015 11:06:17 +0200
Subject: [PATCH] Add JWT to servant-server

---
 servant-server/servant-server.cabal           |  1 +
 .../Servant/Server/Internal/Authentication.hs | 32 ++++++++++++++++++-
 2 files changed, 32 insertions(+), 1 deletion(-)

diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal
index 56eb610c..af133d09 100644
--- a/servant-server/servant-server.cabal
+++ b/servant-server/servant-server.cabal
@@ -68,6 +68,7 @@ library
       , wai-app-static     >= 3.0  && < 3.2
       , warp               >= 3.0  && < 3.2
       , word8              >= 0.1.0
+      , jwt
   hs-source-dirs: src
   default-language: Haskell2010
   ghc-options: -Wall
diff --git a/servant-server/src/Servant/Server/Internal/Authentication.hs b/servant-server/src/Servant/Server/Internal/Authentication.hs
index dfad221a..36919a9f 100644
--- a/servant-server/src/Servant/Server/Internal/Authentication.hs
+++ b/servant-server/src/Servant/Server/Internal/Authentication.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE FlexibleInstances   #-}
 
 module Servant.Server.Internal.Authentication
 ( AuthProtected (..)
@@ -14,7 +15,7 @@ module Servant.Server.Internal.Authentication
 , strictProtect
         ) where
 
-import           Control.Monad              (guard)
+import           Control.Monad              (guard, (<=<))
 import qualified Data.ByteString            as B
 import           Data.ByteString.Base64     (decodeLenient)
 #if !MIN_VERSION_base(4,8,0)
@@ -26,6 +27,8 @@ import           Data.Proxy                 (Proxy (Proxy))
 import           Data.String                (fromString)
 import           Data.Word8                 (isSpace, toLower, _colon)
 import           GHC.TypeLits               (KnownSymbol, symbolVal)
+import           Data.Text.Encoding         (decodeUtf8)
+import           Data.Text                  (splitOn)
 import           Network.HTTP.Types.Status  (status401)
 import           Network.Wai                (Request, Response, requestHeaders,
                                              responseBuilder)
@@ -33,6 +36,9 @@ import           Servant.API.Authentication (AuthPolicy (Strict, Lax),
                                              AuthProtected,
                                              BasicAuth (BasicAuth))
 
+import            Web.JWT                    (JWT, UnverifiedJWT, VerifiedJWT, Secret)
+import qualified  Web.JWT as JWT             (decode, verify)
+
 -- | Class to represent the ability to extract authentication-related
 -- data from a 'Request' object.
 class AuthData a where
@@ -105,3 +111,27 @@ basicAuthLax :: KnownSymbol realm
              -> subserver
              -> AuthProtected (BasicAuth realm) usr subserver 'Lax
 basicAuthLax = laxProtect
+
+
+
+instance AuthData (JWT UnverifiedJWT) where
+  authData req = do
+    -- We might want to write a proper parser for this? but split works fine...
+    hdr <- lookup "Authorization" . requestHeaders $ req
+    ["Bearer", token] <- return . splitOn " " . decodeUtf8 $ hdr
+    JWT.decode token
+
+
+jwtAuthHandlers :: AuthHandlers (JWT UnverifiedJWT)
+jwtAuthHandlers =
+  let authFailure = responseBuilder status401 [] mempty
+  in AuthHandlers (return authFailure) ((const . return) authFailure)
+
+
+-- | A default implementation of an AuthProtected for JWT.
+-- Use this to quickly add jwt authentication to your project.
+-- One can use  strictProtect and laxProtect to make more complex authentication
+-- and authorization schemes.  For an example of that, see our tutorial: @placeholder@
+jwtAuth :: Secret -> subserver -> AuthProtected (JWT UnverifiedJWT) (JWT VerifiedJWT) subserver 'Strict
+jwtAuth  secret subserver = strictProtect (return . JWT.verify secret) jwtAuthHandlers subserver
+