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