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