1 {-# LANGUAGE OverloadedStrings #-}
    2 module Controller.Permission
    3   ( checkPermissionOld
    4   , checkPermission
    5   , userCanReadData
    6   , authAccount
    7   , checkMemberADMIN
    8   , checkVerfHeader
    9   , guardVerfHeader
   10   ) where
   11 
   12 import Control.Monad (void, unless, liftM2)
   13 
   14 import Has (Has, view, peek, peeks)
   15 import Model.Permission hiding (checkPermission)
   16 import Model.Release
   17 import Model.Party
   18 import Model.Identity
   19 import HTTP.Request
   20 import Action
   21 
   22 -- TODO: use Model.checkPermission everywhere instead
   23 {-# DEPRECATED checkPermissionOld "Use checkPermission instead" #-}
   24 checkPermissionOld :: Has Permission a => Permission -> a -> Handler a
   25 checkPermissionOld requiredPermissionLevel objectWithCurrentUserPermLevel =
   26   checkPermission view requiredPermissionLevel objectWithCurrentUserPermLevel
   27 
   28 -- | Determine if the requested permission is granted, or throw an HTTP 403.
   29 --
   30 -- This function is probably due for another 3 or 4 rewrites: it's a bit
   31 -- abstract, serving mostly as a description for its arguments.
   32 -- TODO: Maybe replace with requestAccess
   33 checkPermission
   34     :: (a -> Permission)
   35     -- ^ How to extract the granted permission for current user
   36     -> Permission
   37     -- ^ Requested permission permission
   38     -> a
   39     -- ^ Object under scrutiny
   40     -> Handler a
   41     -- ^ Just returns the 3rd arg, unless it short-circuits with a 403.
   42 checkPermission getCurrentUserPermLevel requestingAccessAtPermLevel obj = do
   43   unless (getCurrentUserPermLevel obj >= requestingAccessAtPermLevel) $ do
   44     resp <- peeks forbiddenResponse
   45     result resp
   46   return obj
   47 
   48 userCanReadData :: (a -> EffectiveRelease) -> (a -> VolumeRolePolicy) -> a -> Handler a
   49 userCanReadData getObjEffectiveRelease getCurrentUserPermLevel obj = do
   50   unless (canReadData2 getObjEffectiveRelease getCurrentUserPermLevel obj) $ do
   51     resp <- peeks forbiddenResponse
   52     result resp
   53   return obj
   54 
   55 -- |
   56 -- Pulls the Account out of the Handler context
   57 authAccount :: Handler Account
   58 authAccount = do
   59   ident <- peek
   60   case ident of
   61     NotLoggedIn -> result =<< peeks forbiddenResponse
   62     IdentityNotNeeded -> result =<< peeks forbiddenResponse
   63     Identified s -> return $ view s
   64     ReIdentified u -> return $ view u
   65 
   66 -- newtype Handler a = Handler { unHandler :: ReaderT RequestContext IO a }
   67 -- deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO,
   68 -- MonadBase IO, MonadThrow, MonadReader RequestContext)
   69 
   70 -- A: Handler satisfies a (MonadHas Access) constraint because...
   71 -- 1. it has a MonadReader RequestContext
   72 -- 2. RequestContext satisfies (Has Access)
   73 --
   74 -- B: (A.2) is true because...
   75 -- 1. RequestContext satisfies (Has Identity) by concretely carrying an Identity
   76 --    value
   77 -- 2. It "inherits" the (Has Access) of its Identity
   78 --
   79 -- C: Identity satisfies (Has Access) because...
   80 -- 1. It satisfies (Has SiteAuth) by *building* a SiteAuth in different ways
   81 --     a. Generate a 'nobody'
   82 --     b. Reach into a sub-sub-field, not using the Has mechanism (although it
   83 --        should?)
   84 --     c. 1 constructor has a concrete SiteAuth field
   85 -- 2. It "inherits" the (Has Access) of the SiteAuth
   86 --
   87 -- D: SiteAuth satisfies (Has Access) because it has a concrete Access field.
   88 
   89 -- | (Maybe) tests whether someone is a superadmin?
   90 checkMemberADMIN :: Handler ()
   91 checkMemberADMIN = do
   92   a :: Access <- peek
   93   let admin = accessMember' a
   94   void $ checkPermissionOld PermissionADMIN admin
   95 
   96 checkVerfHeader :: Handler Bool
   97 checkVerfHeader = do
   98   header <- peeks $ lookupRequestHeader "x-csverf"
   99   peeks $ or . liftM2 (==) header . identityVerf
  100 
  101 guardVerfHeader :: Handler ()
  102 guardVerfHeader = do
  103   c <- checkVerfHeader
  104   unless c $ result =<< peeks forbiddenResponse