1 {-# LANGUAGE OverloadedStrings #-}
    2 module Controller.Authorize
    3   ( viewAuthorize
    4   , postAuthorize
    5   , deleteAuthorize
    6   , postAuthorizeNotFound
    7   ) where
    8 
    9 import Control.Applicative ((<|>))
   10 import Control.Monad (when, liftM3, mfilter, forM_)
   11 import Data.Function (on)
   12 import Data.Maybe (fromMaybe, isNothing, mapMaybe)
   13 import Data.Monoid ((<>))
   14 import qualified Data.Text as T
   15 import qualified Data.Text.Encoding as TE
   16 import qualified Data.Text.Lazy as TL
   17 import Data.Time (UTCTime(..), fromGregorian, addGregorianYearsRollOver, Day)
   18 import Network.HTTP.Types (noContent204)
   19 
   20 import Ops
   21 import Has (peek, peeks)
   22 import qualified JSON
   23 import Service.DB (MonadDB)
   24 import Service.Mail
   25 import Static.Service
   26 import Model.Audit (MonadAudit)
   27 -- import Model.Id.Types
   28 import Model.Party
   29 import Model.Permission
   30 import Model.Identity
   31 import Model.Notification.Types
   32 import Model.Authorize
   33 import HTTP.Path.Parser
   34 import HTTP.Form.Deform
   35 import Action
   36 import Controller.Paths
   37 import Controller.Form
   38 import Controller.Party
   39 import Controller.Notification
   40 import View.Authorize
   41 
   42 -- Every route in this module asserts the requesting user has ADMIN permissions over the primary (first) party
   43 --  referenced in the request. The requesting user must have ADMIN permissions because they are viewing/editing
   44 --  the primary party's authorization relationships. Typically the requesting user will be the primary party,
   45 --  but the requesting user can also be an admin that the primary party has delegated control to.
   46 
   47 viewAuthorize :: ActionRoute (API, PartyTarget, AuthorizeTarget)
   48 viewAuthorize = action GET (pathAPI </>> pathPartyTarget </> pathAuthorizeTarget) $ \(api, i, AuthorizeTarget app oi) -> withAuth $ do
   49   p <- getParty (Just PermissionADMIN) i
   50   o <- maybeAction =<< lookupParty oi
   51   let (child, parent) = if app then (p, o) else (o, p)
   52   (_, c') <- findOrMakeRequest child parent
   53   case api of
   54     JSON -> return $ okResponse [] $ JSON.pairs $ authorizeJSON c'
   55     HTML
   56       | app -> return $ okResponse [] ("" :: T.Text) -- TODO
   57       -- If the request is viewing an authorize from parent to child, then present edit form
   58       | otherwise -> peeks $ blankForm . htmlAuthorizeForm c'
   59 
   60 partyDelegates :: (MonadDB c m, MonadHasIdentity c m) => Party -> m [Account]
   61 partyDelegates u = do
   62   l <- deleg u
   63   if null l
   64     then deleg rootParty
   65     else return l
   66   where
   67   deleg p = mapMaybe partyAccount . (p :)
   68     . map (authorizeChild . authorization)
   69     <$> lookupAuthorizedChildren p (Just PermissionADMIN)
   70 
   71 removeAuthorizeNotify :: Maybe Authorize -> Handler ()
   72 removeAuthorizeNotify priorAuth =
   73     let noReplacementAuthorization = Nothing
   74     in updateAuthorize priorAuth noReplacementAuthorization
   75 
   76 -- | Remove (when only first argument provided) or create/swap in new version of authorization, triggering notifications.
   77 -- Do nothing when neither an old or new auth has been provided.
   78 updateAuthorize :: Maybe Authorize -> Maybe Authorize -> Handler ()
   79 updateAuthorize priorAuth newOrUpdatedAuth
   80   | Just priorElseNewCore <- authorization <$> (priorAuth <|> newOrUpdatedAuth :: Maybe Authorize) = do
   81   maybe
   82     (mapM_ removeAuthorize priorAuth)
   83     changeAuthorize
   84     newOrUpdatedAuth
   85   when (on (/=) (foldMap $ authorizeAccess . authorization) newOrUpdatedAuth priorAuth) $ do
   86     let perm = accessSite <$> newOrUpdatedAuth
   87     dl <- partyDelegates $ authorizeParent priorElseNewCore
   88     forM_ dl $ \t ->
   89       createNotification (blankNotification t NoticeAuthorizeChildGranted)
   90         { notificationParty = Just $ partyRow $ authorizeChild priorElseNewCore
   91         , notificationPermission = perm
   92         }
   93     forM_ (partyAccount $ authorizeChild priorElseNewCore) $ \t ->
   94       createNotification (blankNotification t NoticeAuthorizeGranted)
   95         { notificationParty = Just $ partyRow $ authorizeParent priorElseNewCore
   96         , notificationPermission = perm
   97         }
   98   updateAuthorizeNotifications priorAuth
   99       $ fromMaybe (Authorize priorElseNewCore{ authorizeAccess = mempty } Nothing) newOrUpdatedAuth
  100 updateAuthorize ~Nothing ~Nothing = return ()
  101 
  102 createAuthorize :: (MonadAudit c m) => Authorize -> m ()
  103 createAuthorize = changeAuthorize
  104 
  105 data ParentManageAuthorizeRequest =
  106       ParentDeleteAuthorizeRequest Bool
  107     | ParentUpdateOrCreateAuthorizeRequest Permission Permission (Maybe Day)
  108 
  109 -- | Either create a new authorization request from PartyTarget child to a parent or
  110 -- update/create/reject with validation errors an authorization request to the PartyTarget parent from a child
  111 postAuthorize :: ActionRoute (API, PartyTarget, AuthorizeTarget)
  112 postAuthorize = action POST (pathAPI </>> pathPartyTarget </> pathAuthorizeTarget) $ \arg@(api, i, AuthorizeTarget app oi) -> withAuth $ do
  113   p <- getParty (Just PermissionADMIN) i
  114   o <- maybeAction . mfilter isNobodyParty =<< lookupParty oi -- Don't allow applying to or authorization request from nobody
  115   let (child, parent) = if app then (p, o) else (o, p)
  116   (c, c') <- findOrMakeRequest child parent
  117   resultingAuthorize <- if app
  118     -- The request involves a child party applying for authorization from a parent party
  119     then do
  120       when (isNothing c) $ do -- if there is no pending request or existing authorization
  121         createAuthorize c'
  122         dl <- partyDelegates o
  123         forM_ dl $ \t ->
  124           createNotification (blankNotification t NoticeAuthorizeChildRequest)
  125             { notificationParty = Just $ partyRow o }
  126         forM_ (partyAccount p) $ \t ->
  127           createNotification (blankNotification t NoticeAuthorizeRequest)
  128             { notificationParty = Just $ partyRow o }
  129       -- make either the newly created request or the existing found request the result value
  130       -- of this block
  131       return $ Just c'
  132     -- The request involves a parent party either creating or acting upon an existing authorization request from a child party
  133     else do
  134       su <- peeks identityAdmin
  135       now <- peek
  136       let maxexp = addGregorianYearsRollOver 2 $ utctDay now -- TODO: use timestamp from actioncontext instead of now?
  137           minexp = fromGregorian 2000 1 1
  138       -- the new version of this authorization (possibly first) should either be ...
  139       a <- runForm ((api == HTML) `thenUse` htmlAuthorizeForm c') $ do
  140         csrfForm
  141         ParentDeleteAuthorizeRequest delete <- ParentDeleteAuthorizeRequest <$> ("delete" .:> deform)
  142         -- 1. Nothing (causing deletion if there was a request or old auth)
  143         delete `unlessReturn` (do
  144           site <- "site" .:> deform
  145           member <- "member" .:> deform
  146           expires <-
  147             "expires" .:>
  148               (deformCheck "Expiration must be within two years." (all (\e -> su || e > minexp && e <= maxexp))
  149                =<< (<|> (su `unlessUse` maxexp)) <$> deformNonEmpty deform)
  150           let _ = ParentUpdateOrCreateAuthorizeRequest site member expires
  151           -- 2. A Just with the new or updated approved authorization
  152           return $ makeAuthorize (Access site member) (fmap with1210Utc expires) child parent)
  153       -- Perform the indicated change decided above in the value of "a"
  154       updateAuthorize c a
  155       return a
  156   case api of
  157     -- respond with a copy of the updated authorization, if any
  158     JSON -> return $ okResponse [] $ JSON.pairs $ foldMap authorizeJSON resultingAuthorize <> "party" JSON..=: partyJSON o
  159     HTML -> peeks $ otherRouteResponse [] viewAuthorize arg
  160 
  161 -- | Find an active authorization request or approval between child and parent parties.
  162 -- Also, build an authorization request or present the current authorization value.
  163 findOrMakeRequest :: (MonadDB c m) => Party -> Party -> m (Maybe Authorize, Authorize)
  164 findOrMakeRequest child parent = do
  165   c <- lookupAuthorize ActiveAuthorizations child parent -- TODO: conditionally use ActiveAuth based on permissionParty?
  166   pure (c, mkAuthorizeRequest child parent `fromMaybe` c)
  167 
  168 -- | If present, delete either a prior request for authorization. The authorization to delete can be specified
  169 -- from the child perspective (child party is pathPartyTarget) or the parent perspective (parent party is pathPartyTarget).
  170 -- Inform all relevant parties that the authorization has been deleted.
  171 deleteAuthorize :: ActionRoute (API, PartyTarget, AuthorizeTarget)
  172 deleteAuthorize = action DELETE (pathAPI </>> pathPartyTarget </> pathAuthorizeTarget) $ \arg@(api, i, AuthorizeTarget apply oi) -> withAuth $ do
  173   p <- getParty (Just PermissionADMIN) i
  174   (o :: Party) <- do
  175       mAuthorizeTargetParty <- lookupParty oi
  176       maybeAction mAuthorizeTargetParty
  177   let (child, parent) = if apply then (p, o) else (o, p)
  178   mAuth <- lookupAuthorize AllAuthorizations child parent
  179   removeAuthorizeNotify mAuth
  180   case api of
  181     JSON -> return $ okResponse [] $ JSON.pairs $ "party" JSON..=: partyJSON o
  182     HTML -> peeks $ otherRouteResponse [] viewAuthorize arg
  183 
  184 data AuthorizeNotFoundRequest =
  185     AuthorizeNotFoundRequest T.Text Permission (Maybe T.Text)
  186 
  187 -- | During registration and when requesting additional sponsors, if the target parent party doesn't exist in
  188 -- Databrary yet, this route enables a user to submit some information on which target parent (AI or institution)
  189 -- they are seeking, to trigger an email to the Databrary site admins, with the hope that the site admins are able
  190 -- to manually get the intended parties into Databrary.
  191 postAuthorizeNotFound :: ActionRoute PartyTarget
  192 postAuthorizeNotFound = action POST (pathJSON >/> pathPartyTarget </< "notfound") $ \i -> withAuth $ do
  193   p <- getParty (Just PermissionADMIN) i
  194   agent <- peeks $ fmap accountEmail . partyAccount
  195   AuthorizeNotFoundRequest name perm info <-
  196     runForm Nothing $ liftM3 AuthorizeNotFoundRequest
  197       ("name" .:> deform)
  198       ("permission" .:> deform)
  199       ("info" .:> deformNonEmpty deform)
  200   authaddr <- peeks staticAuthorizeAddr
  201   title <- peeks $ authorizeSiteTitle perm
  202   sendMail [Left authaddr] []
  203     ("Databrary authorization request from " <> partyName (partyRow p))
  204     $ TL.fromChunks [partyName $ partyRow p, " <", foldMap TE.decodeLatin1 agent, ">", mbt $ partyAffiliation $ partyRow p, " has requested to be authorized as an ", title, " by ", name, mbt info, ".\n"]
  205   return $ emptyResponse noContent204 []
  206   where mbt = maybe "" $ \t -> " (" <> t <> ")"