1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.Controller.Permission
    3   ( checkPermission
    4   , checkPermission2
    5   , userCanReadData
    6   , authAccount
    7   , checkMemberADMIN
    8   , checkVerfHeader
    9   , guardVerfHeader
   10   ) where
   11 
   12 import Control.Monad (void, unless, liftM2)
   13 
   14 import Databrary.Has (Has, view, peek, peeks)
   15 import Databrary.Model.Permission
   16 import Databrary.Model.Release
   17 import Databrary.Model.Party
   18 import Databrary.Model.Identity
   19 import Databrary.HTTP.Request
   20 import Databrary.Action
   21 
   22 -- logic inside of checkPermission and checkDataPermission should be inside of model layer
   23 checkPermission :: Has Permission a => Permission -> a -> Handler a  -- TODO: delete this
   24 checkPermission requiredPermissionLevel objectWithCurrentUserPermLevel =
   25   checkPermission2 view requiredPermissionLevel objectWithCurrentUserPermLevel
   26 
   27 checkPermission2 :: (a -> Permission) -> Permission -> a -> Handler a
   28 checkPermission2 getCurrentUserPermLevel requestingAccessAtPermLevel obj = do
   29   unless (getCurrentUserPermLevel obj >= requestingAccessAtPermLevel) $ do
   30     resp <- peeks (\reqCtxt -> forbiddenResponse reqCtxt)
   31     result resp
   32   return obj
   33 
   34 userCanReadData :: (a -> EffectiveRelease) -> (a -> VolumeRolePolicy) -> a -> Handler a
   35 userCanReadData getObjEffectiveRelease getCurrentUserPermLevel obj = do
   36   unless (canReadData2 getObjEffectiveRelease getCurrentUserPermLevel obj) $ do
   37     resp <- peeks (\reqCtxt -> forbiddenResponse reqCtxt)
   38     result resp
   39   return obj
   40 
   41 -- |
   42 -- Pulls the Account out of the Handler context
   43 authAccount :: Handler Account
   44 authAccount = do
   45   ident <- peek
   46   case ident of
   47     NotLoggedIn -> result =<< peeks forbiddenResponse
   48     IdentityNotNeeded -> result =<< peeks forbiddenResponse
   49     Identified s -> return $ view s
   50     ReIdentified u -> return $ view u
   51 
   52 -- newtype Handler a = Handler { unHandler :: ReaderT RequestContext IO a }
   53 -- deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO,
   54 -- MonadBase IO, MonadThrow, MonadReader RequestContext)
   55 
   56 -- A: Handler satisfies a (MonadHas Access) constraint because...
   57 -- 1. it has a MonadReader RequestContext
   58 -- 2. RequestContext satisfies (Has Access)
   59 --
   60 -- B: (A.2) is true because...
   61 -- 1. RequestContext satisfies (Has Identity) by concretely carrying an Identity
   62 --    value
   63 -- 2. It "inherits" the (Has Access) of its Identity
   64 --
   65 -- C: Identity satisfies (Has Access) because...
   66 -- 1. It satisfies (Has SiteAuth) by *building* a SiteAuth in different ways
   67 --     a. Generate a 'nobody'
   68 --     b. Reach into a sub-sub-field, not using the Has mechanism (although it
   69 --        should?)
   70 --     c. 1 constructor has a concrete SiteAuth field
   71 -- 2. It "inherits" the (Has Access) of the SiteAuth
   72 --
   73 -- D: SiteAuth satisfies (Has Access) because it has a concrete Access field.
   74 
   75 -- | (Maybe) tests whether someone is a superadmin?
   76 checkMemberADMIN :: Handler ()
   77 checkMemberADMIN = do
   78   a :: Access <- peek
   79   let admin = accessMember' a
   80   void $ checkPermission PermissionADMIN admin
   81 
   82 checkVerfHeader :: Handler Bool
   83 checkVerfHeader = do
   84   header <- peeks $ lookupRequestHeader "x-csverf"
   85   peeks $ or . liftM2 (==) header . identityVerf
   86 
   87 guardVerfHeader :: Handler ()
   88 guardVerfHeader = do
   89   c <- checkVerfHeader
   90   unless c $ result =<< peeks forbiddenResponse