module LuminescentDreams.Orizentic (
ResourceName(..), Permissions(..), Issuer(..), TTL(..), Username(..)
, OrizenticCtx(..), HasOrizenticCtx(..)
, newOrizenticCtx
, validateToken, checkAuthorizations
, createClaims, revokeClaims, revokeByUUID, replaceClaims
, listClaims, findClaims, encodeClaims, hasPermission, permissions
) where
import Prelude ( Bool(..), Either(..), Eq(..), Show(..)
, ($), (.), (<), (>>=)
, filter, fmap, id
, error
)
import Control.Applicative ((<$>), pure)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader(..))
import Data.Aeson (ToJSON(..), Result(..), fromJSON)
import Data.IORef (IORef, newIORef, modifyIORef, readIORef, writeIORef)
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe (Maybe(..), listToMaybe)
import Data.Text (Text)
import Data.Time (NominalDiffTime, addUTCTime, getCurrentTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Data.UUID (toText)
import System.Random (randomIO)
import Web.JWT
newtype ResourceName = ResourceName Text deriving (Eq, Show)
newtype Permissions = Permissions [Text] deriving Show
newtype Issuer = Issuer Text deriving Show
newtype TTL = TTL NominalDiffTime deriving Show
newtype Username = Username Text deriving Show
instance Eq (JWT VerifiedJWT) where
j1 == j2 = claims j1 == claims j2
newtype ClaimsStore = ClaimsStore (IORef [JWTClaimsSet])
data OrizenticCtx = OrizenticCtx Secret ClaimsStore
class HasOrizenticCtx ctx where
hasOrizenticCtx :: ctx -> OrizenticCtx
instance HasOrizenticCtx OrizenticCtx where
hasOrizenticCtx = id
type OrizenticM m r = (MonadIO m, MonadReader r m, HasOrizenticCtx r)
newOrizenticCtx :: MonadIO m => Secret -> [JWTClaimsSet] -> m OrizenticCtx
newOrizenticCtx s initialClaims = do
st <- liftIO $ ClaimsStore <$> newIORef initialClaims
pure $ OrizenticCtx s st
validateToken :: OrizenticM m r => JWT UnverifiedJWT -> m (Maybe (JWT VerifiedJWT))
validateToken jwt = do
now <- utcTimeToPOSIXSeconds <$> liftIO getCurrentTime
(OrizenticCtx s _) <- hasOrizenticCtx <$> ask
case verify s jwt of
Nothing -> pure Nothing
Just vjwt -> if isExpired now (claims jwt)
then pure Nothing
else do lst <- listClaims
if claims jwt `L.elem` lst
then pure $ Just vjwt
else pure Nothing
where
isExpired now claimsSet =
case secondsSinceEpoch <$> exp claimsSet of
Nothing -> False
Just expiration -> expiration < now
checkAuthorizations :: (ResourceName -> Permissions -> Bool) -> JWT VerifiedJWT -> Bool
checkAuthorizations fn token =
let claimsSet = claims token
rn = ResourceName . stringOrURIToText <$> sub claimsSet
in case rn of
Nothing -> False
Just rn_ -> fn rn_ (permissions claimsSet)
createClaims :: OrizenticM m r => Issuer -> Maybe TTL -> ResourceName -> Username -> Permissions -> m JWTClaimsSet
createClaims (Issuer issuer) ttl (ResourceName resourceName) (Username name) (Permissions perms) =
let ttl_ = (\(TTL val) -> val) <$> ttl
in do
(OrizenticCtx _ (ClaimsStore store)) <- hasOrizenticCtx <$> ask
now <- liftIO getCurrentTime
uuid <- liftIO randomIO
let tok = JWTClaimsSet { iss = stringOrURI issuer
, sub = stringOrURI resourceName
, aud = Left <$> stringOrURI name
, exp = (utcTimeToPOSIXSeconds . (`addUTCTime` now) <$> ttl_) >>= numericDate
, nbf = Nothing
, iat = numericDate $ utcTimeToPOSIXSeconds now
, jti = stringOrURI $ toText uuid
, unregisteredClaims = M.fromList [("perms", toJSON perms)]
}
liftIO $ modifyIORef store ((:) tok)
pure tok
revokeClaims :: OrizenticM m r => JWTClaimsSet -> m ()
revokeClaims tok = do
(OrizenticCtx _ (ClaimsStore store)) <- hasOrizenticCtx <$> ask
liftIO $ modifyIORef store (L.delete tok)
pure ()
revokeByUUID :: OrizenticM m r => Text -> m ()
revokeByUUID uuid = do
(OrizenticCtx _ (ClaimsStore store)) <- hasOrizenticCtx <$> ask
liftIO $ modifyIORef store (filter (\c -> getUUID c /= Just uuid))
where
getUUID = fmap stringOrURIToText . jti
replaceClaims :: OrizenticM m r => [JWTClaimsSet] -> m ()
replaceClaims newClaims = do
(OrizenticCtx _ (ClaimsStore store)) <- hasOrizenticCtx <$> ask
liftIO $ writeIORef store newClaims
listClaims :: OrizenticM m r => m [JWTClaimsSet]
listClaims = do
(OrizenticCtx _ (ClaimsStore store)) <- hasOrizenticCtx <$> ask
liftIO $ readIORef store
findClaims :: OrizenticM m r => Text -> m (Maybe JWTClaimsSet)
findClaims uuid = do
lst <- listClaims
pure $ listToMaybe $ filter (\c -> getUUID c == Just uuid) lst
where
getUUID = fmap stringOrURIToText . jti
encodeClaims :: OrizenticM m r => JWTClaimsSet -> m Text
encodeClaims token = do
(OrizenticCtx s _) <- hasOrizenticCtx <$> ask
pure $ encodeSigned HS256 s token
hasPermission :: Permissions -> Text -> Bool
hasPermission (Permissions perms) p = p `L.elem` perms
permissions :: JWTClaimsSet -> Permissions
permissions claimsSet =
case M.lookup "perms" $ unregisteredClaims claimsSet of
Nothing -> Permissions []
Just claimsPermissions -> case fromJSON claimsPermissions of
Error err -> error $ show err
Success s -> Permissions s