From 1eb076cc93b2b8d608668ea190b5a33731c18108 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 10 Apr 2019 10:39:03 +0200 Subject: [PATCH] tokenRestrictions and documentation --- package.yaml | 1 + src/Model/Token.hs | 67 +++++++++++++++++++++++++++++++++------------- 2 files changed, 49 insertions(+), 19 deletions(-) diff --git a/package.yaml b/package.yaml index 94235a3c1..f6d487376 100644 --- a/package.yaml +++ b/package.yaml @@ -119,6 +119,7 @@ dependencies: - semigroupoids - jose-jwt - mono-traversable + - lens-aeson other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Model/Token.hs b/src/Model/Token.hs index f84fc970a..5b67782a5 100644 --- a/src/Model/Token.hs +++ b/src/Model/Token.hs @@ -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