1 {-# LANGUAGE TemplateHaskell #-}
    2 module Databrary.Model.Identity.Types
    3   ( Identity(..)
    4   , MonadHasIdentity
    5   , extractFromIdentifiedSessOrDefault
    6   , identityVerf
    7   , identityAdmin
    8   , identitySuperuser
    9   ) where
   10 
   11 import qualified Data.ByteString as BS
   12 
   13 import Databrary.Has (Has(..), MonadHas)
   14 import Databrary.Model.Id.Types
   15 import Databrary.Model.Permission.Types
   16 import Databrary.Model.Party.Types
   17 import Databrary.Model.Token.Types
   18 
   19 -- | Who is making the request that we are handling?
   20 data Identity
   21   = NotLoggedIn
   22   -- ^ User may have an identity, but they have not established it yet
   23   | IdentityNotNeeded
   24   -- ^ We don't care what the user's identity is.
   25   -- Used mainly for BackgroundContext, but also used when
   26   -- running unprotected routes
   27   | Identified Session
   28   -- ^ An actual human user on a web browser. One of the other two return values
   29   -- for 'determineIdentity'.
   30   | ReIdentified SiteAuth
   31   -- ^ Speculation: used in video conversion when sending results from the
   32   -- compute cluster back to the system. Used as a 'su' to run actions as the
   33   -- account who created the upload asset, instead of the anonymous account submitting the result?
   34 
   35 -- | Get the SiteAuth for the Identity, which corresponds to what privileges the Identity has
   36 -- within the site as well which Party/Account the Identity is
   37 instance Has SiteAuth Identity where
   38   view (Identified Session{ sessionAccountToken = AccountToken{ tokenAccount = t } }) = t
   39   view (ReIdentified a) = a
   40   view IdentityNotNeeded = nobodySiteAuth
   41   view NotLoggedIn = nobodySiteAuth
   42 
   43 instance Has Party Identity where
   44   view = view . (view :: Identity -> SiteAuth)
   45 instance Has Account Identity where
   46   view = view . (view :: Identity -> SiteAuth)
   47 instance Has (Id Party) Identity where
   48   view = view . (view :: Identity -> SiteAuth)
   49 instance Has Access Identity where
   50   view = view . (view :: Identity -> SiteAuth)
   51 
   52 -- | Used by an action that will reference the actor's identity in order to authorize the action being performed.
   53 -- In some cases, this identity simply hasn't been established or was not resolved because the
   54 -- context indicated that an identity wasn't needed.
   55 type MonadHasIdentity c m = (MonadHas Identity c m, Has SiteAuth c, Has Party c, Has (Id Party) c, Has Access c)
   56 
   57 -- | Extract a value from part of a session for Identified, otherwise use the default value
   58 extractFromIdentifiedSessOrDefault :: a -> (Session -> a) -> Identity -> a
   59 extractFromIdentifiedSessOrDefault z f = \case
   60     Identified sess -> f sess
   61     NotLoggedIn -> z
   62     IdentityNotNeeded -> z
   63     ReIdentified _ -> z
   64 
   65 -- | Extract the secure token for state changing action, only available for logged in session identity
   66 identityVerf :: Identity -> Maybe BS.ByteString
   67 identityVerf = extractFromIdentifiedSessOrDefault Nothing (Just . sessionVerf)
   68 
   69 identitySuperuserFor :: (Access -> Permission) -> Identity -> Bool
   70 identitySuperuserFor f (Identified t) = sessionSuperuser t && f (view t) == PermissionADMIN
   71 identitySuperuserFor _ (ReIdentified _) = True
   72 identitySuperuserFor _ _ = False
   73 
   74 identityAdmin :: Identity -> Bool
   75 identityAdmin = identitySuperuserFor accessMember
   76 
   77 identitySuperuser :: Identity -> Bool
   78 identitySuperuser = identitySuperuserFor accessPermission