tokenRestrictions and documentation

package.yaml

@@ -119,6 +119,7 @@ dependencies:
   - semigroupoids
   - jose-jwt
   - mono-traversable
+  - lens-aeson
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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
+  { 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`)
+  , 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
+  , 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.
+  , 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
+  , 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, ...)
-  , tokenIssuedBy   :: InstanceId
+  , 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"
+  tokenRoutes        <- lift $ o .:? "routes"
-  tokenAddAuth   <- lift $ o .:? "add-auth"
+  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
+  = BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
-  | BearerTokenUnsecured
+  | BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
-  | BearerTokenInvalidFormat String
+  | 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.
+askJwt :: forall m. ( MonadHandler 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