Refine the jwt api

servant-client/src/Servant/Client/Authentication.hs

@@ -11,7 +11,7 @@ import Data.ByteString.Base64  (encode)
 import Data.Monoid ((<>))
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8)
-import Servant.API.Authentication (BasicAuth(BasicAuth))
+import Servant.API.Authentication (BasicAuth(BasicAuth), JWTAuth(..))
 import Servant.Common.Req (addHeader, Req)
 
 -- | Class to represent the ability to authenticate a 'Request'
@@ -25,8 +25,7 @@ instance AuthenticateRequest (BasicAuth realm) where
         let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) in
             addHeader "Authorization" authText req
 
-type JSON = Text
+instance AuthenticateRequest JWTAuth where
-instance AuthenticateRequest JSON where
+  authReq (JWTAuth token) req =
-  authReq token req =
     let authText = ("Bearer " <> token)
     in addHeader "Authorization" authText req

servant-examples/tutorial/T3.hs

@@ -10,6 +10,8 @@ import           Data.List
 import           GHC.Generics
 import           Network.Wai
 import           Servant
+import           Servant.Server.Internal.Authentication
+
 
 data Position = Position
   { x :: Int

servant-mock/servant-mock.cabal

@@ -31,7 +31,8 @@ library
     servant-server >= 0.4,
     transformers >= 0.3 && <0.5,
     QuickCheck >= 2.7 && <2.9,
-    wai >= 3.0 && <3.1
+    wai >= 3.0 && <3.1,
+    jwt
   hs-source-dirs:      src
   default-language:    Haskell2010
 

servant-mock/src/Servant/Mock.hs

@@ -64,7 +64,7 @@ import           Network.Wai
 import           Servant
 import           Servant.API.Authentication
 import           Servant.API.ContentTypes
-import            Servant.Server.Internal.Authentication
+import           Web.JWT
 import           Test.QuickCheck.Arbitrary  (Arbitrary (..), vector)
 import           Test.QuickCheck.Gen        (Gen, generate)
 
@@ -156,9 +156,8 @@ instance (HasMock rest, Arbitrary usr, KnownSymbol realm)
 instance (HasMock rest, Arbitrary usr)
       => HasMock (AuthProtect JWTAuth (usr :: *) 'Strict :> rest) where
   mock _ = strictProtect (\_ -> do { a <- generate arbitrary; return (Just a)})
-                         (AuthHandlers (return authFailure) ((const . return) authFailure))
+                         jwtAuthHandlers
                          (\_ -> mock (Proxy :: Proxy rest))
-    where authFailure = responseBuilder status401 [] mempty
 
 instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where
   mock _ = mockArbitrary

servant-server/src/Servant/Server.hs

@@ -71,12 +71,14 @@ module Servant.Server
   , err504
   , err505
 
+  , module Servant.Server.Internal.Authentication
   ) where
 
 import           Data.Proxy                    (Proxy)
 import           Network.Wai                   (Application)
 import           Servant.Server.Internal
 import           Servant.Server.Internal.Enter
+import           Servant.Server.Internal.Authentication
 
 
 -- * Implementing Servers

servant-server/src/Servant/Server/Internal/Authentication.hs

@@ -14,7 +14,7 @@ module Servant.Server.Internal.Authentication
 , laxProtect
 , strictProtect
 , jwtAuthHandlers
-, jwtAuth
+, jwtAuthStrict
         ) where
 
 import           Control.Monad              (guard, (<=<))
@@ -37,10 +37,10 @@ import           Network.Wai                (Request, Response, requestHeaders,
 import           Servant.API.Authentication (AuthPolicy (Strict, Lax),
                                              AuthProtected,
                                              BasicAuth (BasicAuth),
-                                             JWTAuth)
+                                             JWTAuth (..))
 
 import            Web.JWT                    (JWT, UnverifiedJWT, VerifiedJWT, Secret, JSON)
-import qualified  Web.JWT as JWT             (decode, verify, secret)
+import qualified  Web.JWT as JWT             (decode, decodeAndVerifySignature, secret)
 
 -- | Class to represent the ability to extract authentication-related
 -- data from a 'Request' object.
@@ -122,21 +122,23 @@ instance AuthData JWTAuth where
     -- 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 -- try decode it. otherwise it's not a proper token
+    JWT.decode token -- try decode it. otherwise it's not a proper token
-    return token
+    return . JWTAuth $ token
 
 
-jwtAuthHandlers :: AuthHandlers JSON
+jwtAuthHandlers :: AuthHandlers JWTAuth
-jwtAuthHandlers =
+jwtAuthHandlers = AuthHandlers (return missingData) ((const . return) authFailure)
-  let authFailure = responseBuilder status401 [] mempty
+  where
-  in AuthHandlers (return authFailure) ((const . return) authFailure)
+    withError e =
+      responseBuilder status401 [("WWW-Authenticate", "Bearer error=\""<>e<>"\"")] mempty
+    missingData = withError "invalid_request"
+    authFailure = withError "invalid_token"
 
 
 -- | 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@
+-- and authorization schemes.
--- TODO more advanced one
+jwtAuthStrict :: Secret -> subserver -> AuthProtected JWTAuth (JWT VerifiedJWT) subserver 'Strict
-jwtAuth :: Text -> subserver -> AuthProtected JSON (JWT VerifiedJWT) subserver 'Strict
+jwtAuthStrict secret subserver = strictProtect (return . JWT.decodeAndVerifySignature secret . unJWTAuth) jwtAuthHandlers subserver
-jwtAuth secret subserver = strictProtect (return . (JWT.verify (JWT.secret secret) <=< JWT.decode)) jwtAuthHandlers subserver
 

servant/src/Servant/API/Authentication.hs

@@ -9,7 +9,7 @@ module Servant.API.Authentication
 , AuthProtect (..)
 , AuthProtected (..)
 , BasicAuth (..)
-, JWTAuth
+, JWTAuth (..)
 ) where
 
 
@@ -38,4 +38,4 @@ data BasicAuth (realm :: Symbol) = BasicAuth { baUser :: ByteString
                                              , baPass :: ByteString
                                              } deriving (Eq, Show, Typeable)
 
-type JWTAuth = Text
+newtype JWTAuth = JWTAuth { unJWTAuth :: Text }

stack.yaml

@@ -16,4 +16,5 @@ packages:
 extra-deps:
 - engine-io-wai-1.0.2
 - control-monad-omega-0.3.1
+- jwt-0.6.0
 resolver: nightly-2015-10-08