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 <> ")"