1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.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)
   18 import Network.HTTP.Types (noContent204)
   19 
   20 import Databrary.Ops
   21 import Databrary.Has (peek, peeks)
   22 import qualified Databrary.JSON as JSON
   23 import Databrary.Service.DB (MonadDB)
   24 import Databrary.Service.Mail
   25 import Databrary.Static.Service
   26 import Databrary.Model.Audit (MonadAudit)
   27 -- import Databrary.Model.Id.Types
   28 import Databrary.Model.Party
   29 import Databrary.Model.Permission
   30 import Databrary.Model.Identity
   31 import Databrary.Model.Notification.Types
   32 import Databrary.Model.Authorize
   33 import Databrary.HTTP.Path.Parser
   34 import Databrary.HTTP.Form.Deform
   35 import Databrary.Action
   36 import Databrary.Controller.Paths
   37 import Databrary.Controller.Form
   38 import Databrary.Controller.Party
   39 import Databrary.Controller.Notification
   40 import Databrary.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 -- | Either create a new authorization request from PartyTarget child to a parent or
  106 -- update/create/reject with validation errors an authorization request to the PartyTarget parent from a child
  107 postAuthorize :: ActionRoute (API, PartyTarget, AuthorizeTarget)
  108 postAuthorize = action POST (pathAPI </>> pathPartyTarget </> pathAuthorizeTarget) $ \arg@(api, i, AuthorizeTarget app oi) -> withAuth $ do
  109   p <- getParty (Just PermissionADMIN) i
  110   o <- maybeAction . mfilter isNobodyParty =<< lookupParty oi -- Don't allow applying to or authorization request from nobody
  111   let (child, parent) = if app then (p, o) else (o, p)
  112   (c, c') <- findOrMakeRequest child parent
  113   resultingAuthorize <- if app
  114     -- The request involves a child party applying for authorization from a parent party
  115     then do
  116       when (isNothing c) $ do -- if there is no pending request or existing authorization
  117         createAuthorize c'
  118         dl <- partyDelegates o
  119         forM_ dl $ \t ->
  120           createNotification (blankNotification t NoticeAuthorizeChildRequest)
  121             { notificationParty = Just $ partyRow o }
  122         forM_ (partyAccount p) $ \t ->
  123           createNotification (blankNotification t NoticeAuthorizeRequest)
  124             { notificationParty = Just $ partyRow o }
  125       -- make either the newly created request or the existing found request the result value
  126       -- of this block
  127       return $ Just c'
  128     -- The request involves a parent party either creating or acting upon an existing authorization request from a child party
  129     else do
  130       su <- peeks identityAdmin
  131       now <- peek
  132       let maxexp = addGregorianYearsRollOver 2 $ utctDay now -- TODO: use timestamp from actioncontext instead of now?
  133           minexp = fromGregorian 2000 1 1
  134       -- the new version of this authorization (possibly first) should either be ...
  135       a <- runForm ((api == HTML) `thenUse` (htmlAuthorizeForm c')) $ do
  136         csrfForm
  137         delete <- "delete" .:> deform
  138         -- 1. Nothing (causing deletion if there was a request or old auth)
  139         delete `unlessReturn` (do
  140           site <- "site" .:> deform
  141           member <- "member" .:> deform
  142           expires <-
  143             "expires" .:>
  144               (deformCheck "Expiration must be within two years." (all (\e -> su || e > minexp && e <= maxexp))
  145                =<< (<|> (su `unlessUse` maxexp)) <$> deformNonEmpty deform)
  146           -- 2. A Just with the new or updated approved authorization
  147           return $ makeAuthorize (Access site member) (fmap with1210Utc expires) child parent)
  148       -- Perform the indicated change decided above in the value of "a"
  149       updateAuthorize c a
  150       return a
  151   case api of
  152     -- respond with a copy of the updated authorization, if any
  153     JSON -> return $ okResponse [] $ JSON.pairs $ foldMap authorizeJSON resultingAuthorize <> "party" JSON..=: partyJSON o
  154     HTML -> peeks $ otherRouteResponse [] viewAuthorize arg
  155 
  156 -- | Find an active authorization request or approval between child and parent parties.
  157 -- Also, build an authorization request or present the current authorization value.
  158 findOrMakeRequest :: (MonadDB c m) => Party -> Party -> m (Maybe Authorize, Authorize)
  159 findOrMakeRequest child parent = do
  160   c <- lookupAuthorize ActiveAuthorizations child parent -- TODO: conditionally use ActiveAuth based on permissionParty?
  161   pure (c, mkAuthorizeRequest child parent `fromMaybe` c)
  162 
  163 -- | If present, delete either a prior request for authorization. The authorization to delete can be specified
  164 -- from the child perspective (child party is pathPartyTarget) or the parent perspective (parent party is pathPartyTarget).
  165 -- Inform all relevant parties that the authorization has been deleted.
  166 deleteAuthorize :: ActionRoute (API, PartyTarget, AuthorizeTarget)
  167 deleteAuthorize = action DELETE (pathAPI </>> pathPartyTarget </> pathAuthorizeTarget) $ \arg@(api, i, AuthorizeTarget apply oi) -> withAuth $ do
  168   p <- getParty (Just PermissionADMIN) i
  169   (o :: Party) <- do
  170       mAuthorizeTargetParty <- lookupParty oi
  171       maybeAction mAuthorizeTargetParty
  172   let (child, parent) = if apply then (p, o) else (o, p)
  173   mAuth <- lookupAuthorize AllAuthorizations child parent
  174   removeAuthorizeNotify mAuth
  175   case api of
  176     JSON -> return $ okResponse [] $ JSON.pairs $ "party" JSON..=: partyJSON o
  177     HTML -> peeks $ otherRouteResponse [] viewAuthorize arg
  178 
  179 -- | During registration and when requesting additional sponsors, if the target parent party doesn't exist in
  180 -- Databrary yet, this route enables a user to submit some information on which target parent (AI or institution)
  181 -- they are seeking, to trigger an email to the Databrary site admins, with the hope that the site admins are able
  182 -- to manually get the intended parties into Databrary.
  183 postAuthorizeNotFound :: ActionRoute (PartyTarget)
  184 postAuthorizeNotFound = action POST (pathJSON >/> pathPartyTarget </< "notfound") $ \i -> withAuth $ do
  185   p <- getParty (Just PermissionADMIN) i
  186   agent <- peeks $ fmap accountEmail . partyAccount
  187   (name, perm, info) <- runForm Nothing $ liftM3 (,,)
  188     ("name" .:> deform)
  189     ("permission" .:> deform)
  190     ("info" .:> deformNonEmpty deform)
  191   authaddr <- peeks staticAuthorizeAddr
  192   title <- peeks $ authorizeSiteTitle perm
  193   sendMail [Left authaddr] []
  194     ("Databrary authorization request from " <> partyName (partyRow p))
  195     $ 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"]
  196   return $ emptyResponse noContent204 []
  197   where mbt = maybe "" $ \t -> " (" <> t <> ")"