1 {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 {-# OPTIONS_GHC -fno-warn-orphans #-} 3 module Model.Permission 4 ( module Model.Permission.Types 5 -- , permissionVIEW 6 , permissionPRIVATE 7 , readPermission 8 , readRelease 9 , dataPermission4 10 , canReadData2 11 , accessJSON 12 -- * Checking permissioned objects 13 , checkPermission 14 , PermissionResponse (..) 15 -- * New 16 , requestAccess 17 , Permissioned 18 , mkPermissioned 19 ) where 20 21 import Data.Monoid ((<>)) 22 23 import qualified JSON 24 import Model.Release.Types 25 import Model.Permission.Types 26 27 -- | Represents a permissioned object. The constructor is not exported: use 28 -- 'mkPermissioned' and 'requestAccess' instead. 29 data Permissioned a = Permissioned 30 { unsafeAccess :: a 31 , grantedPermission :: Permission 32 } 33 34 -- | Smart constructor for Permissioned. 35 -- 36 -- As one can tell from the first argument, this assumes that objects already 37 -- have some way of being mapped to the permissions granted on them. This is 38 -- generally true because of how the existing code works. It might change in the 39 -- future, for example if database queries return a 'Permissioned' value 40 -- directly, obsoleting this function. 41 mkPermissioned :: (a -> Permission) -> a -> Permissioned a 42 mkPermissioned getPerm o = Permissioned o (getPerm o) 43 44 -- | How to get access to a permissioned object. It's not a great design, but it 45 -- makes a concrete concept out of an existing pattern in the codebase. A better 46 -- design could perhaps couple the access request to the action that needs the 47 -- access. 48 requestAccess 49 :: Permission 50 -- ^ Requested permission 51 -> Permissioned a 52 -- ^ object 53 -> Maybe a 54 -- ^ Maybe the unwrapped object 55 requestAccess requestedPerm obj = 56 if requestedPerm <= grantedPermission obj 57 then Just (unsafeAccess obj) 58 else Nothing 59 60 -- |Level at which things become visible. ; TODO: use this somewhere? 61 -- permissionVIEW :: Permission 62 -- permissionVIEW = PermissionPUBLIC 63 64 -- |Alias for READ. Grants full access to private data, bypassing consent permissions. 65 permissionPRIVATE :: Permission 66 permissionPRIVATE = PermissionREAD 67 68 -- |The necessary permission level to read a data object with the given release. 69 -- Equivalent to the SQL function read_permission. 70 readPermission :: Release -> Permission 71 readPermission ReleasePUBLIC = PermissionPUBLIC 72 readPermission ReleaseSHARED = PermissionSHARED 73 readPermission ReleaseEXCERPTS = PermissionSHARED 74 readPermission ReleasePRIVATE = permissionPRIVATE 75 76 -- |The most restrictive data release level that the current user may access under the given permission. 77 -- Equivalent to the SQL function read_release. Inverse of 'readPermission' module meaning of @Nothing@. 78 readRelease :: Permission -> Maybe Release 79 readRelease PermissionNONE = Nothing 80 readRelease PermissionPUBLIC = Just ReleasePUBLIC 81 readRelease PermissionSHARED = Just ReleaseSHARED 82 readRelease _ = Just ReleasePRIVATE 83 84 -- |The effective permission for data objects with the given attributes, effectively collapsing ineffective permissions NONE. 85 releasePermission :: Release -> Permission -> Permission 86 releasePermission effectiveReleaseOnData currentUserAllowedPermissionOnVolume 87 | currentUserAllowedPermissionOnVolume >= readPermission effectiveReleaseOnData = currentUserAllowedPermissionOnVolume 88 | otherwise = PermissionNONE 89 90 dataPermission4 :: (a -> EffectiveRelease) -> (a -> VolumeRolePolicy) -> a -> Permission 91 dataPermission4 getObjEffectiveRelease getCurrentUserVolumeRole obj = 92 let 93 effRelease = getObjEffectiveRelease obj 94 in 95 case getCurrentUserVolumeRole obj of 96 RolePublicViewer PublicRestrictedPolicy -> 97 releasePermission (effRelPrivate effRelease) PermissionPUBLIC 98 RoleSharedViewer SharedRestrictedPolicy -> 99 releasePermission (effRelPrivate effRelease) PermissionSHARED 100 -- other levels that behave more like private (options: none, shared, read, edit, admin) ? 101 rp -> 102 releasePermission (effRelPublic effRelease) (extractPermissionIgnorePolicy rp) 103 104 canReadData2 :: (a -> EffectiveRelease) -> (a -> VolumeRolePolicy) -> a -> Bool 105 canReadData2 getObjEffectiveRelease getCurrentUserVolumeRole obj = 106 dataPermission4 getObjEffectiveRelease getCurrentUserVolumeRole obj > PermissionNONE 107 108 accessJSON :: JSON.ToObject o => Access -> o 109 accessJSON Access{..} = 110 "site" JSON..= accessSite' 111 <> "member" JSON..= accessMember' 112 113 -- | Responses to 'checkPermission' 114 data PermissionResponse a 115 = PermissionGranted a 116 -- ^ Whatever you wanted, you got it! 117 | PermissionDenied 118 -- ^ No. 119 120 -- | Decorate some permissioned object with a permission response 121 -- TODO: Maybe replace with requestAccess 122 checkPermission 123 :: (a -> Permission) -- ^ Extract the object's permission rules 124 -> a -- ^ The object in question 125 -> Permission -- ^ The requested permission 126 -> PermissionResponse a 127 -- ^ The object decorated with the permission response 128 checkPermission getGrantedPerms obj requestedPerms = 129 case compare (getGrantedPerms obj) requestedPerms of 130 LT -> PermissionDenied 131 GT -> PermissionGranted obj 132 EQ -> PermissionGranted obj