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