{-# LANGUAGE OverloadedStrings #-}
-- | This module provides functionality for verifying the JSON Web Tokens in a wai setting.
module JwtMiddleware where

import           Control.Applicative
import           Control.Monad
import           Data.Aeson            ((.=))
import qualified Data.Aeson            as Aeson
import qualified Data.ByteString       as SBS
import qualified Data.ByteString.Lazy  as LBS
import qualified Data.List             as List
import qualified Data.Text             as Text
import           Data.Time.Clock.POSIX (POSIXTime)
import qualified Data.Time.Clock.POSIX as Clock
import qualified Network.HTTP.Types    as Http
import qualified Network.Wai           as Wai
import qualified Web.JWT               as JWT

import           AccessControl
import           JwtAuth
import           Store                 (Path)

-- | Defines the kinds of errors that cause authorization to fail.
data AuthError
  = TokenError TokenError
    -- ^ Authorization was denied due to an invalid token.
  | OperationNotAllowed
    -- ^ Authorization was denied because the operation is not allowed by the token.

-- | Result of checking authorization
data AuthResult
  = AuthRejected AuthError
    -- ^ Authorization was denied because of the specified reason
  | AuthAccepted
    -- ^ Authorization was successful

-- * Requests

-- | Check whether accessing the given path with the given mode is authorized by
-- the token supplied in the request headers or query string (which may not be
-- present, then failing the check).
isRequestAuthorized :: Http.RequestHeaders -> Http.Query -> POSIXTime -> Maybe JWT.Signer -> Path -> AccessMode -> AuthResult
isRequestAuthorized :: RequestHeaders
-> Query
-> POSIXTime
-> Maybe Signer
-> Path
-> AccessMode
-> AuthResult
isRequestAuthorized RequestHeaders
headers Query
query POSIXTime
now Maybe Signer
maybeSecret Path
path AccessMode
mode =
  case RequestHeaders
-> Query
-> POSIXTime
-> Maybe Signer
-> Either TokenError IcepeakClaim
getRequestClaim RequestHeaders
headers Query
query POSIXTime
now Maybe Signer
maybeSecret of
    Left TokenError
err -> AuthError -> AuthResult
AuthRejected (TokenError -> AuthError
TokenError TokenError
err)
    Right IcepeakClaim
claim | IcepeakClaim -> Path -> AccessMode -> Bool
isAuthorizedByClaim IcepeakClaim
claim Path
path AccessMode
mode
                  -> AuthResult
AuthAccepted
                | Bool
otherwise
                  -> AuthError -> AuthResult
AuthRejected AuthError
OperationNotAllowed

-- | Extract the JWT claim from the request.
getRequestClaim :: Http.RequestHeaders -> Http.Query -> POSIXTime -> Maybe JWT.Signer -> Either TokenError IcepeakClaim
getRequestClaim :: RequestHeaders
-> Query
-> POSIXTime
-> Maybe Signer
-> Either TokenError IcepeakClaim
getRequestClaim RequestHeaders
headers Query
query POSIXTime
now Maybe Signer
maybeSecret =
  let getTokenBytes :: Either TokenError ByteString
getTokenBytes = Either TokenError ByteString
-> (ByteString -> Either TokenError ByteString)
-> Maybe ByteString
-> Either TokenError ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TokenError -> Either TokenError ByteString
forall a b. a -> Either a b
Left (TokenError -> Either TokenError ByteString)
-> TokenError -> Either TokenError ByteString
forall a b. (a -> b) -> a -> b
$ VerificationError -> TokenError
VerificationError VerificationError
TokenNotFound) ByteString -> Either TokenError ByteString
forall a b. b -> Either a b
Right (RequestHeaders -> Query -> Maybe ByteString
findTokenBytes RequestHeaders
headers Query
query)
  in case Maybe Signer
maybeSecret of
       Maybe Signer
Nothing     ->
         -- authorization is enabled, but no secret provided, accept all tokens
         Either TokenError ByteString
getTokenBytes Either TokenError ByteString
-> (ByteString -> Either TokenError IcepeakClaim)
-> Either TokenError IcepeakClaim
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Either TokenError IcepeakClaim
extractClaimUnverified
       Just Signer
secret -> Either TokenError ByteString
getTokenBytes Either TokenError ByteString
-> (ByteString -> Either TokenError IcepeakClaim)
-> Either TokenError IcepeakClaim
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= POSIXTime -> Signer -> ByteString -> Either TokenError IcepeakClaim
extractClaim POSIXTime
now Signer
secret

-- | Lookup a token, first in the @Authorization@ header of the request, then
-- falling back to the @access_token@ query parameter.
findTokenBytes :: Http.RequestHeaders -> Http.Query -> Maybe SBS.ByteString
findTokenBytes :: RequestHeaders -> Query -> Maybe ByteString
findTokenBytes RequestHeaders
headers Query
query = RequestHeaders -> Maybe ByteString
headerToken RequestHeaders
headers Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Query -> Maybe ByteString
queryToken Query
query

-- | Look up a token from the @Authorization@ header.
-- Header should be in the format @Bearer <token>@.
headerToken :: Http.RequestHeaders -> Maybe SBS.ByteString
headerToken :: RequestHeaders -> Maybe ByteString
headerToken =
  ByteString -> ByteString -> Maybe ByteString
SBS.stripPrefix ByteString
"Bearer " (ByteString -> Maybe ByteString)
-> (RequestHeaders -> Maybe ByteString)
-> RequestHeaders
-> Maybe ByteString
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup HeaderName
Http.hAuthorization

-- | Look up a token from the @access_token@ query parameter
queryToken :: Http.Query -> Maybe SBS.ByteString
queryToken :: Query -> Maybe ByteString
queryToken = Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe ByteString) -> Maybe ByteString)
-> (Query -> Maybe (Maybe ByteString)) -> Query -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Query -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"access_token"

-- * Responses

instance Aeson.ToJSON AuthError where
  toJSON :: AuthError -> Value
toJSON AuthError
aerr = case AuthError
aerr of
    TokenError TokenError
terr -> case TokenError
terr of
      ClaimError String
ce -> [Pair] -> Value
Aeson.object [ Text
"error" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
ce ]
      VerificationError VerificationError
ve | VerificationError
ve VerificationError -> [VerificationError] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VerificationError
TokenInvalid, VerificationError
TokenNotFound]
                             -> [Pair] -> Value
Aeson.object [ Text
"error" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
"invalid token format" ]
      TokenError
_ -> [Pair] -> Value
Aeson.object [ Text
"data" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
Aeson.Null ]
    AuthError
OperationNotAllowed -> [Pair] -> Value
Aeson.object [ Text
"error" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
"not allowed" ]

-- | Generate a 401 Unauthorized response for a given authorization error.
errorResponseBody :: AuthError -> LBS.ByteString
errorResponseBody :: AuthError -> ByteString
errorResponseBody = AuthError -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode

-- * Middleware

jwtMiddleware :: Maybe JWT.Signer -> Wai.Application -> Wai.Application
jwtMiddleware :: Maybe Signer -> Application -> Application
jwtMiddleware Maybe Signer
secret Application
app Request
req Response -> IO ResponseReceived
respond = do
    POSIXTime
now <- IO POSIXTime
Clock.getPOSIXTime
    case RequestHeaders
-> Query
-> POSIXTime
-> Maybe Signer
-> Either TokenError IcepeakClaim
getRequestClaim RequestHeaders
headers Query
query POSIXTime
now Maybe Signer
secret of
      Left TokenError
err -> AuthError -> IO ResponseReceived
forall a. ToJSON a => a -> IO ResponseReceived
rejectUnauthorized (TokenError -> AuthError
TokenError TokenError
err)
      Right IcepeakClaim
claim | IcepeakClaim -> Bool
isAuthorized IcepeakClaim
claim -> Application
app Request
req Response -> IO ResponseReceived
respond
                  | Bool
otherwise -> AuthError -> IO ResponseReceived
forall a. ToJSON a => a -> IO ResponseReceived
rejectUnauthorized AuthError
OperationNotAllowed
  where
    -- read request
    path :: Path
path = Request -> Path
Wai.pathInfo Request
req
    query :: Query
query = Request -> Query
Wai.queryString Request
req
    headers :: RequestHeaders
headers = Request -> RequestHeaders
Wai.requestHeaders Request
req

    -- translate HTTP request methods to modes
    maybeMode :: Maybe AccessMode
maybeMode | Request -> ByteString
Wai.requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
Http.methodGet = AccessMode -> Maybe AccessMode
forall a. a -> Maybe a
Just AccessMode
ModeRead
              | Request -> ByteString
Wai.requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
Http.methodPut = AccessMode -> Maybe AccessMode
forall a. a -> Maybe a
Just AccessMode
ModeWrite
              | Request -> ByteString
Wai.requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
Http.methodDelete = AccessMode -> Maybe AccessMode
forall a. a -> Maybe a
Just AccessMode
ModeWrite
              | Bool
otherwise = Maybe AccessMode
forall a. Maybe a
Nothing

    isAuthorized :: IcepeakClaim -> Bool
isAuthorized IcepeakClaim
claim = Bool -> (AccessMode -> Bool) -> Maybe AccessMode -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (IcepeakClaim -> Path -> AccessMode -> Bool
isAuthorizedByClaim IcepeakClaim
claim Path
path) Maybe AccessMode
maybeMode

    rejectUnauthorized :: a -> IO ResponseReceived
rejectUnauthorized a
err = Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> ByteString -> Response
Wai.responseLBS
           Status
Http.unauthorized401
           [(HeaderName
Http.hContentType, ByteString
"application/json")]
           (a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode a
err)