tokenRestrictions and documentation
This commit is contained in:
Gregor Kleen
parent
1532518943
commit
1eb076cc93
@ -119,6 +119,7 @@ dependencies:
|
||||
- semigroupoids
|
||||
- jose-jwt
|
||||
- mono-traversable
|
||||
- lens-aeson
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
@ -2,8 +2,9 @@
|
||||
|
||||
module Model.Token
|
||||
( BearerToken(..)
|
||||
, _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
|
||||
, bearerToken
|
||||
, encodeToken, BearerTokenException(..), decodeToken
|
||||
, encodeToken, BearerTokenException(..), decodeToken, jwtEncoding
|
||||
, tokenToJSON, tokenParseJSON, tokenParseJSON'
|
||||
, askJwt
|
||||
) where
|
||||
@ -11,8 +12,9 @@ module Model.Token
|
||||
import ClassyPrelude.Yesod
|
||||
import Model
|
||||
import Settings
|
||||
import Utils (NTop(..), hoistMaybe)
|
||||
import Utils (NTop(..), hoistMaybe, assertM')
|
||||
import Utils.Lens hiding ((.=))
|
||||
import Data.Aeson.Lens (AsJSON(..))
|
||||
import Utils.Parameters
|
||||
|
||||
import Yesod.Auth (AuthId)
|
||||
@ -29,7 +31,7 @@ import Data.HashSet (HashSet)
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Data.Aeson.Types (Parser, (.:?), (.:))
|
||||
import Data.Aeson.Types (Parser, (.:?), (.:), (.!=))
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Types as JSON
|
||||
import qualified Data.Aeson.Parser as JSON
|
||||
@ -45,26 +47,42 @@ import Control.Monad.Random (MonadRandom(..))
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
|
||||
-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to _whoever_ presents the token
|
||||
data BearerToken site = BearerToken
|
||||
{ tokenIdentifier :: TokenId -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
|
||||
, tokenAuthority :: AuthId site -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
|
||||
, tokenRoutes :: Maybe (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
|
||||
, tokenAddAuth :: Maybe AuthDNF -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
|
||||
, tokenIssuedAt :: UTCTime
|
||||
, tokenIssuedBy :: InstanceId
|
||||
{ tokenIdentifier :: TokenId -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
|
||||
, tokenAuthority :: AuthId site -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
|
||||
, tokenRoutes :: Maybe (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
|
||||
, tokenAddAuth :: Maybe AuthDNF -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
|
||||
, tokenRestrictions :: HashMap (Route site) Value -- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
|
||||
, tokenIssuedAt :: UTCTime
|
||||
, tokenIssuedBy :: InstanceId
|
||||
, tokenExpiresAt
|
||||
, tokenStartsAt :: Maybe UTCTime
|
||||
, tokenStartsAt :: Maybe UTCTime
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
|
||||
deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
|
||||
deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
|
||||
|
||||
makeLenses_ ''BearerToken
|
||||
|
||||
_tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
|
||||
-- ^ Focus a singular restriction (by route) if it exists
|
||||
_tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
|
||||
|
||||
_tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
|
||||
-- ^ Focus a singular restriction (by route) whether it exists, or not
|
||||
_tokenRestrictionAt route = _tokenRestrictions . at route . maybePrism _JSON
|
||||
|
||||
|
||||
tokenToJSON :: forall m.
|
||||
( MonadHandler m
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) m
|
||||
, RenderRoute (HandlerSite m)
|
||||
) => BearerToken (HandlerSite m) -> m Value
|
||||
-- ^ Encode a `BearerToken` analogously to `toJSON`
|
||||
--
|
||||
-- Monadic context is needed because `AuthId`s are encrypted during encoding
|
||||
tokenToJSON BearerToken{..} = do
|
||||
cID <- encrypt tokenAuthority :: m (CryptoUUID (AuthId (HandlerSite m)))
|
||||
let stdPayload = Jose.JwtClaims
|
||||
@ -80,6 +98,7 @@ tokenToJSON BearerToken{..} = do
|
||||
catMaybes [ Just $ "authority" .= cID
|
||||
, ("routes" .=) <$> tokenRoutes
|
||||
, ("add-auth" .=) <$> tokenAddAuth
|
||||
, ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
|
||||
]
|
||||
++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
|
||||
|
||||
@ -90,12 +109,18 @@ tokenParseJSON :: forall site.
|
||||
)
|
||||
=> Value
|
||||
-> ReaderT CryptoIDKey Parser (BearerToken site)
|
||||
-- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
|
||||
--
|
||||
-- Monadic context is needed because `AuthId`s are encrypted during encoding
|
||||
--
|
||||
-- It's usually easier to use `tokenParseJSON'`
|
||||
tokenParseJSON v@(Object o) = do
|
||||
tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
|
||||
tokenAuthority <- decrypt tokenAuthority'
|
||||
|
||||
tokenRoutes <- lift $ o .:? "routes"
|
||||
tokenAddAuth <- lift $ o .:? "add-auth"
|
||||
tokenRoutes <- lift $ o .:? "routes"
|
||||
tokenAddAuth <- lift $ o .:? "add-auth"
|
||||
tokenRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
|
||||
Jose.JwtClaims{..} <- lift $ parseJSON v
|
||||
|
||||
let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
|
||||
@ -118,6 +143,7 @@ tokenParseJSON' :: forall m.
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
)
|
||||
=> m (Value -> Parser (BearerToken (HandlerSite m)))
|
||||
-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
|
||||
tokenParseJSON' = do
|
||||
cidKey <- cryptoIDKey return
|
||||
return $ flip runReaderT cidKey . tokenParseJSON
|
||||
@ -135,6 +161,7 @@ bearerToken :: forall m.
|
||||
-> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
|
||||
-> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
|
||||
-> m (BearerToken (HandlerSite m))
|
||||
-- ^ Smart constructor for `Bearertoken`, does not set route restrictions (due to polymorphism), use `_tokenRestrictionAt`
|
||||
bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
|
||||
tokenIdentifier <- liftIO getRandom
|
||||
tokenIssuedAt <- liftIO getCurrentTime
|
||||
@ -149,11 +176,13 @@ bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsA
|
||||
= Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
|
||||
| otherwise
|
||||
= Nothing
|
||||
tokenRestrictions = HashMap.empty
|
||||
|
||||
return BearerToken{..}
|
||||
|
||||
|
||||
jwtEncoding :: Jose.JwtEncoding
|
||||
-- ^ How should `Jwt`s be signed and/or encrypted?
|
||||
jwtEncoding = Jose.JwsEncoding Jose.HS256
|
||||
|
||||
|
||||
@ -165,6 +194,7 @@ encodeToken :: forall m.
|
||||
, RenderRoute (HandlerSite m)
|
||||
)
|
||||
=> BearerToken (HandlerSite m) -> m Jwt
|
||||
-- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `jwtEncoding`
|
||||
encodeToken token = do
|
||||
payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
|
||||
JwkSet jwks <- getsYesod $ view jsonWebKeySet
|
||||
@ -172,9 +202,9 @@ encodeToken token = do
|
||||
|
||||
|
||||
data BearerTokenException
|
||||
= BearerTokenJwtError Jose.JwtError
|
||||
| BearerTokenUnsecured
|
||||
| BearerTokenInvalidFormat String
|
||||
= BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
|
||||
| BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
|
||||
| BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken`
|
||||
| BearerTokenExpired | BearerTokenNotStarted
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
|
||||
@ -191,6 +221,7 @@ decodeToken :: forall m.
|
||||
, Hashable (Route (HandlerSite m))
|
||||
)
|
||||
=> Jwt -> m (BearerToken (HandlerSite m))
|
||||
-- ^ Decode a `Jwt` according to `jwtEncoding` and call `tokenParseJSON`
|
||||
decodeToken (Jwt bs) = do
|
||||
JwkSet jwks <- getsYesod $ view jsonWebKeySet
|
||||
content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
|
||||
@ -208,11 +239,9 @@ decodeToken (Jwt bs) = do
|
||||
return token
|
||||
|
||||
|
||||
askJwt :: forall m.
|
||||
( MonadHandler m
|
||||
)
|
||||
askJwt :: forall m. ( MonadHandler m )
|
||||
=> m (Maybe Jwt)
|
||||
-- | Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
|
||||
-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
|
||||
askJwt = runMaybeT $ asum
|
||||
[ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
|
||||
, MaybeT $ lookupGlobalPostParam PostBearer
|
||||
|
||||
Loading…
Reference in New Issue
Block a user