1 -- | A collection of access request methods.
    2 module Model.Access
    3     ( accessSlot
    4     , accessVolume
    5     , AccessResult (..)
    6     ) where
    7 
    8 import Model.Container.Types
    9 import Model.Id.Types
   10 import Model.Identity.Types
   11 import Model.Permission
   12 import Model.Slot
   13 import Model.Volume
   14 import Service.DB
   15 
   16 -- | Captures possible request responses.
   17 -- NOTE: This was designed to mimic existing code and responses. LookupFailed
   18 -- does NOT mean "does not exist". It means that 'lookupVolume' (for example)
   19 -- returned Nothing. This could mean either the id is a valid id, or the user
   20 -- doesn't have access to the volume.
   21 --
   22 -- TODO: Monad Transformer?
   23 data AccessResult a
   24     = LookupFailed
   25     | AccessDenied
   26     | AccessResult a
   27 
   28 -- | Lookup a Slot by its Id, requesting the given permission.
   29 accessSlot
   30     :: (MonadDB c m, MonadHasIdentity c m)
   31     => Permission
   32     -> Id Slot
   33     -> m (AccessResult Slot)
   34 accessSlot requestedPerm = accessPermissionedObject
   35     lookupSlot
   36     (extractPermissionIgnorePolicy
   37     . volumeRolePolicy
   38     . containerVolume
   39     . slotContainer
   40     )
   41     requestedPerm
   42 
   43 -- | Lookup a Volume by its Id, requesting the given permission.
   44 accessVolume
   45     :: (MonadDB c m, MonadHasIdentity c m)
   46     => Permission
   47     -> Id Volume
   48     -> m (AccessResult Volume)
   49 accessVolume requestedPerm = accessPermissionedObject
   50     lookupVolume
   51     (extractPermissionIgnorePolicy . volumeRolePolicy)
   52     requestedPerm
   53 
   54 -- | Internal, generic version for accessing a permissioned object. Used as the
   55 -- basis for the exported accessors.
   56 accessPermissionedObject
   57     :: MonadDB c m
   58     => (Id a -> m (Maybe a))
   59     -- ^ How to get the object from the database
   60     -> (a -> Permission)
   61     -- ^ Map the object to the permissions granted on it
   62     -> Permission
   63     -- ^ Requested access level to the object
   64     -> Id a
   65     -- ^ Id of the object to access
   66     -> m (AccessResult a)
   67     -- ^ Access response
   68 accessPermissionedObject lookupObj getPermission requestedPerm =
   69     fmap (maybe LookupFailed mkRequest) . lookupObjP
   70   where
   71     mkRequest =
   72         maybe AccessDenied AccessResult . requestAccess requestedPerm
   73     lookupObjP = fmap (fmap (mkPermissioned getPermission)) . lookupObj