1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.VolumeAccess 3 (-- viewVolumeAccess 4 postVolumeAccess 5 ) where 6 7 -- import Control.Monad.IO.Class (liftIO) 8 import Control.Monad (when, forM_) 9 import Data.Function (on) 10 import Data.Int (Int16) 11 12 -- import Ops 13 import Has 14 import qualified JSON 15 import Model.Id 16 import Model.Permission 17 import Model.Identity 18 import Model.Volume 19 import Model.VolumeAccess 20 import Model.Party 21 import Model.Notification.Types 22 import HTTP.Form (FormDatum(..)) 23 import HTTP.Form.Deform 24 import HTTP.Path.Parser 25 import Action 26 import Controller.Paths 27 import Controller.Form 28 import Controller.Volume 29 import Controller.Notification 30 -- import View.VolumeAccess 31 import View.Form (FormHtml) 32 33 {- obsolete 34 viewVolumeAccess :: ActionRoute (Id Volume, VolumeAccessTarget) 35 viewVolumeAccess = action GET (pathHTML >/> pathId </> pathVolumeAccessTarget) $ \(vi, VolumeAccessTarget ap) -> withAuth $ do 36 v <- getVolume PermissionADMIN vi 37 a <- maybeAction =<< lookupVolumeAccessParty v ap 38 peeks $ blankForm . htmlVolumeAccessForm a 39 -} 40 41 data ManageVolumeAccessRequest = 42 DeleteVolumeAccessRequest Bool 43 | CreateOrUpdateVolumeAccessRequest Permission Permission (Maybe Int16) (Maybe Bool) 44 45 postVolumeAccess :: ActionRoute (Id Volume, VolumeAccessTarget) 46 postVolumeAccess = action POST (pathJSON >/> pathId </> pathVolumeAccessTarget) $ \(vi, VolumeAccessTarget ap) -> withAuth $ do 47 v <- getVolume (if ap == partyId (partyRow staffParty) then PermissionEDIT else PermissionADMIN) vi 48 a <- maybeAction =<< lookupVolumeAccessParty v ap 49 u <- peek 50 let su = identityAdmin u 51 ru = unId ap > 0 52 a' <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do 53 csrfForm 54 DeleteVolumeAccessRequest delete <- DeleteVolumeAccessRequest <$> ("delete" .:> deform) 55 let del 56 | delete = return PermissionNONE 57 | otherwise = deform 58 individual <- "individual" .:> (del 59 >>= deformCheck "Cannot share full access." ((||) ru . (PermissionSHARED >=)) 60 >>= deformCheck "Cannot remove your ownership." ((||) (su || not (volumeAccessProvidesADMIN a)) . (PermissionADMIN <=))) 61 children <- "children" .:> (del 62 >>= deformCheck "Inherited access must not exceed individual." (individual >=) 63 >>= deformCheck "You are not authorized to share data." ((||) (ru || accessSite u >= PermissionEDIT) . (PermissionNONE ==))) 64 sort <- "sort" .:> deformNonEmpty deform 65 mShareFull <- 66 if (ap, individual) `elem` [(getPartyId nobodyParty, PermissionPUBLIC), (getPartyId rootParty, PermissionSHARED)] 67 then do 68 _ <- "share_full" .:> (deformCheck "Required" (not . (== FormDatumNone)) =<< deform) -- convulated way of requiring 69 Just <$> ("share_full" .:> deform) 70 else pure Nothing 71 let _ = CreateOrUpdateVolumeAccessRequest individual children sort mShareFull 72 return a 73 { volumeAccessIndividual = individual 74 , volumeAccessChildren = children 75 , volumeAccessSort = sort 76 , volumeAccessShareFull = mShareFull 77 } 78 -- liftIO $ print ("vol access full", volumeAccessShareFull a') 79 r <- changeVolumeAccess a' 80 if ap == partyId (partyRow rootParty) && on (/=) volumeAccessChildren a' a 81 then do 82 createVolumeNotification v $ \n -> (n NoticeVolumeSharing) 83 { notificationPermission = Just $ volumeAccessChildren a' 84 } 85 broadcastNotification (volumeAccessChildren a' >= PermissionSHARED) $ \n -> (n NoticeSharedVolume) 86 { notificationVolume = Just $ volumeRow v 87 } 88 else when (ru && on (/=) volumeAccessIndividual a' a) $ do 89 createVolumeNotification v $ \n -> (n NoticeVolumeAccessOther) 90 { notificationParty = Just $ partyRow $ volumeAccessParty a' 91 , notificationPermission = Just $ volumeAccessIndividual a' 92 } 93 when (ap /= view u) $ forM_ (partyAccount (volumeAccessParty a')) $ \t -> 94 createNotification (blankNotification t NoticeVolumeAccess) 95 { notificationVolume = Just $ volumeRow v 96 , notificationPermission = Just $ volumeAccessIndividual a' 97 } 98 return $ okResponse [] $ JSON.pairs $ volumeAccessPartyJSON (if r then a' else a) 99 -- HTML -> peeks $ otherRouteResponse [] viewVolumeAccess arg