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