module Controller.Authorize
( viewAuthorize
, postAuthorize
, deleteAuthorize
, postAuthorizeNotFound
) where
import Control.Applicative ((<|>))
import Control.Monad (when, liftM3, mfilter, forM_)
import Data.Function (on)
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import Data.Time (UTCTime(..), fromGregorian, addGregorianYearsRollOver, Day)
import Network.HTTP.Types (noContent204)
import Ops
import Has (peek, peeks)
import qualified JSON
import Service.DB (MonadDB)
import Service.Mail
import Static.Service
import Model.Audit (MonadAudit)
import Model.Party
import Model.Permission
import Model.Identity
import Model.Notification.Types
import Model.Authorize
import HTTP.Path.Parser
import HTTP.Form.Deform
import Action
import Controller.Paths
import Controller.Form
import Controller.Party
import Controller.Notification
import View.Authorize
viewAuthorize :: ActionRoute (API, PartyTarget, AuthorizeTarget)
viewAuthorize = action GET (pathAPI </>> pathPartyTarget </> pathAuthorizeTarget) $ \(api, i, AuthorizeTarget app oi) -> withAuth $ do
p <- getParty (Just PermissionADMIN) i
o <- maybeAction =<< lookupParty oi
let (child, parent) = if app then (p, o) else (o, p)
(_, c') <- findOrMakeRequest child parent
case api of
JSON -> return $ okResponse [] $ JSON.pairs $ authorizeJSON c'
HTML
| app -> return $ okResponse [] ("" :: T.Text)
| otherwise -> peeks $ blankForm . htmlAuthorizeForm c'
partyDelegates :: (MonadDB c m, MonadHasIdentity c m) => Party -> m [Account]
partyDelegates u = do
l <- deleg u
if null l
then deleg rootParty
else return l
where
deleg p = mapMaybe partyAccount . (p :)
. map (authorizeChild . authorization)
<$> lookupAuthorizedChildren p (Just PermissionADMIN)
removeAuthorizeNotify :: Maybe Authorize -> Handler ()
removeAuthorizeNotify priorAuth =
let noReplacementAuthorization = Nothing
in updateAuthorize priorAuth noReplacementAuthorization
updateAuthorize :: Maybe Authorize -> Maybe Authorize -> Handler ()
updateAuthorize priorAuth newOrUpdatedAuth
| Just priorElseNewCore <- authorization <$> (priorAuth <|> newOrUpdatedAuth :: Maybe Authorize) = do
maybe
(mapM_ removeAuthorize priorAuth)
changeAuthorize
newOrUpdatedAuth
when (on (/=) (foldMap $ authorizeAccess . authorization) newOrUpdatedAuth priorAuth) $ do
let perm = accessSite <$> newOrUpdatedAuth
dl <- partyDelegates $ authorizeParent priorElseNewCore
forM_ dl $ \t ->
createNotification (blankNotification t NoticeAuthorizeChildGranted)
{ notificationParty = Just $ partyRow $ authorizeChild priorElseNewCore
, notificationPermission = perm
}
forM_ (partyAccount $ authorizeChild priorElseNewCore) $ \t ->
createNotification (blankNotification t NoticeAuthorizeGranted)
{ notificationParty = Just $ partyRow $ authorizeParent priorElseNewCore
, notificationPermission = perm
}
updateAuthorizeNotifications priorAuth
$ fromMaybe (Authorize priorElseNewCore{ authorizeAccess = mempty } Nothing) newOrUpdatedAuth
updateAuthorize ~Nothing ~Nothing = return ()
createAuthorize :: (MonadAudit c m) => Authorize -> m ()
createAuthorize = changeAuthorize
data ParentManageAuthorizeRequest =
ParentDeleteAuthorizeRequest Bool
| ParentUpdateOrCreateAuthorizeRequest Permission Permission (Maybe Day)
postAuthorize :: ActionRoute (API, PartyTarget, AuthorizeTarget)
postAuthorize = action POST (pathAPI </>> pathPartyTarget </> pathAuthorizeTarget) $ \arg@(api, i, AuthorizeTarget app oi) -> withAuth $ do
p <- getParty (Just PermissionADMIN) i
o <- maybeAction . mfilter isNobodyParty =<< lookupParty oi
let (child, parent) = if app then (p, o) else (o, p)
(c, c') <- findOrMakeRequest child parent
resultingAuthorize <- if app
then do
when (isNothing c) $ do
createAuthorize c'
dl <- partyDelegates o
forM_ dl $ \t ->
createNotification (blankNotification t NoticeAuthorizeChildRequest)
{ notificationParty = Just $ partyRow o }
forM_ (partyAccount p) $ \t ->
createNotification (blankNotification t NoticeAuthorizeRequest)
{ notificationParty = Just $ partyRow o }
return $ Just c'
else do
su <- peeks identityAdmin
now <- peek
let maxexp = addGregorianYearsRollOver 2 $ utctDay now
minexp = fromGregorian 2000 1 1
a <- runForm ((api == HTML) `thenUse` htmlAuthorizeForm c') $ do
csrfForm
ParentDeleteAuthorizeRequest delete <- ParentDeleteAuthorizeRequest <$> ("delete" .:> deform)
delete `unlessReturn` (do
site <- "site" .:> deform
member <- "member" .:> deform
expires <-
"expires" .:>
(deformCheck "Expiration must be within two years." (all (\e -> su || e > minexp && e <= maxexp))
=<< (<|> (su `unlessUse` maxexp)) <$> deformNonEmpty deform)
let _ = ParentUpdateOrCreateAuthorizeRequest site member expires
return $ makeAuthorize (Access site member) (fmap with1210Utc expires) child parent)
updateAuthorize c a
return a
case api of
JSON -> return $ okResponse [] $ JSON.pairs $ foldMap authorizeJSON resultingAuthorize <> "party" JSON..=: partyJSON o
HTML -> peeks $ otherRouteResponse [] viewAuthorize arg
findOrMakeRequest :: (MonadDB c m) => Party -> Party -> m (Maybe Authorize, Authorize)
findOrMakeRequest child parent = do
c <- lookupAuthorize ActiveAuthorizations child parent
pure (c, mkAuthorizeRequest child parent `fromMaybe` c)
deleteAuthorize :: ActionRoute (API, PartyTarget, AuthorizeTarget)
deleteAuthorize = action DELETE (pathAPI </>> pathPartyTarget </> pathAuthorizeTarget) $ \arg@(api, i, AuthorizeTarget apply oi) -> withAuth $ do
p <- getParty (Just PermissionADMIN) i
(o :: Party) <- do
mAuthorizeTargetParty <- lookupParty oi
maybeAction mAuthorizeTargetParty
let (child, parent) = if apply then (p, o) else (o, p)
mAuth <- lookupAuthorize AllAuthorizations child parent
removeAuthorizeNotify mAuth
case api of
JSON -> return $ okResponse [] $ JSON.pairs $ "party" JSON..=: partyJSON o
HTML -> peeks $ otherRouteResponse [] viewAuthorize arg
data AuthorizeNotFoundRequest =
AuthorizeNotFoundRequest T.Text Permission (Maybe T.Text)
postAuthorizeNotFound :: ActionRoute PartyTarget
postAuthorizeNotFound = action POST (pathJSON >/> pathPartyTarget </< "notfound") $ \i -> withAuth $ do
p <- getParty (Just PermissionADMIN) i
agent <- peeks $ fmap accountEmail . partyAccount
AuthorizeNotFoundRequest name perm info <-
runForm Nothing $ liftM3 AuthorizeNotFoundRequest
("name" .:> deform)
("permission" .:> deform)
("info" .:> deformNonEmpty deform)
authaddr <- peeks staticAuthorizeAddr
title <- peeks $ authorizeSiteTitle perm
sendMail [Left authaddr] []
("Databrary authorization request from " <> partyName (partyRow p))
$ 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"]
return $ emptyResponse noContent204 []
where mbt = maybe "" $ \t -> " (" <> t <> ")"