79 lines
2.5 KiB
Haskell
79 lines
2.5 KiB
Haskell
module Handler.JWT where
|
|
|
|
import Import hiding (Proxy, fromList)
|
|
|
|
import qualified Data.ByteString as BS
|
|
import Data.Word8 (isSpace, toLower)
|
|
import Network.Wai (requestHeaders)
|
|
import qualified Jose.Jwt as JWT
|
|
import qualified Jose.Jwa as JWA
|
|
|
|
import Data.Aeson
|
|
|
|
data JwtAuthInfo = JwtAuthInfo {
|
|
jwtAuthInfoUsername :: Text,
|
|
jwtAuthInfoFamilyName :: Maybe Text,
|
|
jwtAuthInfoGivenName :: Maybe Text
|
|
}
|
|
|
|
deriving (Show, Eq)
|
|
|
|
instance FromJSON JwtAuthInfo where
|
|
parseJSON (Object v) =
|
|
JwtAuthInfo <$> v .: "preferred_username"
|
|
<*> v .:? "family_name"
|
|
<*> v .:? "given_name"
|
|
parseJSON _ = mzero
|
|
|
|
jwtAuthInfoIdent :: JwtAuthInfo -> Text
|
|
jwtAuthInfoIdent jwtAuthInfo = jwtAuthInfoUsername jwtAuthInfo
|
|
|
|
jwtAuthInfoCustomField :: Text -> JwtAuthInfo -> Maybe Text
|
|
jwtAuthInfoCustomField "given_name" jwt = jwtAuthInfoGivenName jwt
|
|
jwtAuthInfoCustomField "family_name" jwt = jwtAuthInfoFamilyName jwt
|
|
jwtAuthInfoCustomField _ _ = Nothing
|
|
|
|
authorizationTokenAuth :: Handler (Maybe JwtAuthInfo)
|
|
authorizationTokenAuth = do
|
|
app <- getYesod
|
|
let mJwk = appJSONWebKey $ appSettings app
|
|
|
|
case mJwk of
|
|
Just jwk -> do
|
|
req <- waiRequest
|
|
case lookup "Authorization" (Network.Wai.requestHeaders req) of
|
|
Nothing -> return Nothing
|
|
Just authHead -> case BS.break isSpace authHead of
|
|
(strategy, token')
|
|
| BS.map Data.Word8.toLower strategy == "bearer" -> do
|
|
let token = BS.filter (/= 32) token'
|
|
einfo <- liftIO $ JWT.decode [jwk] (Just (JWT.JwsEncoding JWA.RS256)) token
|
|
return $ case einfo of
|
|
Right (JWT.Jws (_, infos)) -> decode $ fromStrict infos
|
|
_ -> Nothing
|
|
| otherwise -> return Nothing
|
|
Nothing -> return Nothing
|
|
|
|
maybeAuthPossiblyByToken :: Handler (Maybe (Entity User))
|
|
maybeAuthPossiblyByToken = do
|
|
mInfo <- authorizationTokenAuth
|
|
case mInfo of
|
|
Just infos -> do
|
|
x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos
|
|
case x of
|
|
Just entUser -> return $ Just entUser
|
|
Nothing -> maybeAuth
|
|
Nothing -> maybeAuth
|
|
|
|
|
|
requireAuthPossiblyByToken :: Handler (Entity User)
|
|
requireAuthPossiblyByToken = do
|
|
mInfo <- authorizationTokenAuth
|
|
case mInfo of
|
|
Just infos -> do
|
|
x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos
|
|
case x of
|
|
Just entUser -> return entUser
|
|
Nothing -> requireAuth
|
|
Nothing -> requireAuth
|