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