tokenRestrict & documentation

src/Model/Token.hs

@@ -3,6 +3,7 @@
 module Model.Token
   ( BearerToken(..)
   , _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
+  , tokenRestrict
   , bearerToken
   , encodeToken, BearerTokenException(..), decodeToken, jwtEncoding
   , tokenToJSON, tokenParseJSON, tokenParseJSON'
@@ -47,13 +48,20 @@ import Control.Monad.Random (MonadRandom(..))
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
--- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to _whoever_ presents the token
+-- | 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
-  , tokenAuthority    :: AuthId site -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
+    -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
-  , tokenRoutes       :: Maybe (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
+  , tokenAuthority    :: AuthId site
-  , 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.
+    -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
-  , 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, ...)
+  , 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, ...)
+    --
+    -- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
   , tokenIssuedAt     :: UTCTime
   , tokenIssuedBy     :: InstanceId
   , tokenExpiresAt
@@ -69,13 +77,20 @@ 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
 --
--- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` instead
+-- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` or `tokenRestrict` instead
 _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
 
+tokenRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
+-- ^ Add a restriction to a `BearerToken`
+--
+-- If a restriction already exists for the targeted route, it's silently overwritten
+tokenRestrict route (toJSON -> resVal) = over _tokenRestrictions $ HashMap.insert route resVal
+
+
 
 tokenToJSON :: forall m.
                ( MonadHandler m
@@ -163,7 +178,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`
+-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
 bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
   tokenIdentifier <- liftIO getRandom
   tokenIssuedAt <- liftIO getCurrentTime