module CJ.Auth.Token
( UserBearerToken(..)
, JSONToken(..)
, decodeToken
, encodeToken
) where
import qualified Data.ByteString.Base64.URL as BS64
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Web.JWT as JWT
import Control.Monad
import Data.Aeson (FromJSON (..), Value, toJSON)
import Data.Aeson.Types (parseMaybe)
import Data.Either.Combinators
import Data.Maybe
import Data.Time.Clock.POSIX (POSIXTime)
import Web.JWT
( Algorithm(HS256)
, JWTClaimsSet(JWTClaimsSet)
, Secret
, claims
, decodeAndVerifySignature
, def
, encodeSigned
, numericDate
, secondsSinceEpoch
, unregisteredClaims
)
class JSONToken a where
toClaims :: a -> JWTClaimsSet
fromClaims :: JWTClaimsSet -> Maybe a
data UserBearerToken = UserBearerToken
{ _bearerUserId :: T.Text
, _bearerAppId :: T.Text
} deriving (Eq, Show)
instance JSONToken UserBearerToken where
toClaims UserBearerToken{ _bearerUserId = uid, _bearerAppId = aid } =
def { unregisteredClaims = M.fromList [ ("userId", toJSON uid)
, ("appId", toJSON aid) ] }
fromClaims JWTClaimsSet{ unregisteredClaims = clms } =
UserBearerToken <$> uid <*> aid
where uid = fromValue =<< M.lookup "userId" clms
aid = fromValue =<< M.lookup "appId" clms
fromValue :: FromJSON a => Value -> Maybe a
fromValue = parseMaybe parseJSON
encodeJWT :: Secret -> JWTClaimsSet -> T.Text
encodeJWT = encodeSigned HS256
decodableToken :: T.Text -> Bool
decodableToken token = isJust $ do
(header : claimsPayload : _) <- return $ T.splitOn "." token
void $ verifyUtf8Base64 header
verifyUtf8Base64 claimsPayload
where
verifyUtf8Base64 base64Str = rightToMaybe $ TE.decodeUtf8' (BS64.decodeLenient $ TE.encodeUtf8 base64Str)
encodeToken :: (JSONToken a) => Secret -> a -> POSIXTime -> T.Text
encodeToken secret token expTime = encodeJWT secret expiringClaims
where baseClaims = toClaims token
expiringClaims = baseClaims { JWT.exp = numericDate expTime }
decodeToken :: (JSONToken a) => Secret -> T.Text -> POSIXTime -> Maybe a
decodeToken secret token currentTime =
fromClaims =<< verifyFresh currentTime =<< decodedClaims
where jwt = if decodableToken token then decodeAndVerifySignature secret token else Nothing
decodedClaims = claims <$> jwt
verifyFresh :: POSIXTime -> JWTClaimsSet -> Maybe JWTClaimsSet
verifyFresh currentTime clms@JWTClaimsSet{ JWT.exp = (Just expirationTime) }
| secondsSinceEpoch expirationTime < currentTime = Nothing
| otherwise = Just clms
verifyFresh _ clms = Just clms