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