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