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 (Id Party) Identity where
   46   view = view . (view :: Identity -> SiteAuth)
   47 instance Has Access Identity where
   48   view = view . (view :: Identity -> SiteAuth)
   49 
   50 -- | Used by an action that will reference the actor's identity in order to authorize the action being performed.
   51 -- In some cases, this identity simply hasn't been established or was not resolved because the
   52 -- context indicated that an identity wasn't needed.
   53 type MonadHasIdentity c m = (MonadHas Identity c m, Has SiteAuth c, Has Party c, Has (Id Party) c, Has Access c)
   54 
   55 -- | Extract a value from part of a session for Identified, otherwise use the default value
   56 extractFromIdentifiedSessOrDefault :: a -> (Session -> a) -> Identity -> a
   57 extractFromIdentifiedSessOrDefault z f = \case
   58     Identified sess -> f sess
   59     NotLoggedIn -> z
   60     IdentityNotNeeded -> z
   61     ReIdentified _ -> z
   62 
   63 -- | Extract the secure token for state changing action, only available for logged in session identity
   64 identityVerf :: Identity -> Maybe BS.ByteString
   65 identityVerf = extractFromIdentifiedSessOrDefault Nothing (Just . sessionVerf)
   66 
   67 identitySuperuserFor :: (Access -> Permission) -> Identity -> Bool           
   68 identitySuperuserFor f (Identified t) = sessionSuperuser t && f (view t) == PermissionADMIN
   69 identitySuperuserFor _ (ReIdentified _) = True
   70 identitySuperuserFor _ _ = False
   71 
   72 identityAdmin :: Identity -> Bool
   73 identityAdmin = identitySuperuserFor accessMember
   74 
   75 identitySuperuser :: Identity -> Bool           
   76 identitySuperuser = identitySuperuserFor accessPermission
   77 ERROR: ("",8,Loc 77 1,[],[(Loc 78 1,Loc 78 57,TopLevelDecl False 1),(Loc 78 1,Loc 78 57,IsTicked),(Loc 78 21,Loc 78 57,IsTicked),(Loc 78 42,Loc 78 57,NotTicked)])