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