1 {-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, ScopedTypeVariables, DataKinds #-} 2 module Databrary.Model.Authorize 3 ( module Databrary.Model.Authorize.Types 4 , selfAuthorize 5 , lookupAuthorizedChildren 6 , lookupAuthorizedParents 7 , AuthorizeFilter(..) 8 , lookupAuthorize 9 , lookupAuthorizeParent 10 , lookupAuthorization 11 , changeAuthorize 12 , removeAuthorize 13 , authorizeExpired 14 , authorizeActive 15 , authorizeJSON 16 , lookupAuthorizeActivity 17 , makeAuthorize 18 ) where 19 20 -- import Control.Monad.IO.Class (liftIO) 21 import Control.Monad (when) 22 import Data.Int (Int64) 23 import Data.Maybe (fromMaybe) 24 import Data.Monoid ((<>)) 25 26 import Databrary.Has (peek) 27 import qualified Databrary.JSON as JSON 28 import Databrary.Service.DB 29 import Databrary.Model.SQL 30 import Databrary.Model.Time 31 import Databrary.Model.Id 32 import Databrary.Model.Audit 33 import Databrary.Model.Permission 34 import Databrary.Model.Party 35 import Databrary.Model.Identity.Types 36 import Databrary.Model.Authorize.Types 37 import Databrary.Model.Authorize.SQL 38 39 selfAuthorize :: Party -> Authorize 40 selfAuthorize p = 41 Authorize (Authorization (if partyId (partyRow p) == partyId (partyRow nobodyParty) then minBound else maxBound) p p) Nothing 42 43 -- | Get authorizations where the given party is the child. When the permission argument has a value, 44 -- then only provide active, approved authorizations, filtering out authorizations lower than the 45 -- provided level. 46 lookupAuthorizedParents :: (MonadDB c m, MonadHasIdentity c m) => Party -> Maybe Permission -> m [Authorize] 47 lookupAuthorizedParents child perm = do 48 -- TODO: specialize the argument to be AuthorizeFilter for this and Children function below 49 ident <- peek 50 dbQuery $ maybe 51 $(selectQuery (selectAuthorizeParent 'child 'ident) "$") 52 (\p -> $(selectQuery (selectAuthorizeParent 'child 'ident) "$WHERE (expires IS NULL OR expires > CURRENT_TIMESTAMP) AND site >= ${p} AND member >= ${p} AND (site <> 'NONE' OR member <> 'NONE')")) 53 perm 54 55 -- | Get authorizations where the given party is the parent. When the permission argument has a value, 56 -- then only provide active, approved authorizations, filtering out authorizations lower than the 57 -- provided level. 58 lookupAuthorizedChildren :: (MonadDB c m, MonadHasIdentity c m) => Party -> Maybe Permission -> m [Authorize] 59 lookupAuthorizedChildren parent perm = do 60 ident <- peek 61 dbQuery $ maybe 62 $(selectQuery (selectAuthorizeChild 'parent 'ident) "$") 63 (\p -> $(selectQuery (selectAuthorizeChild 'parent 'ident) "$WHERE (expires IS NULL OR expires > CURRENT_TIMESTAMP) AND site >= ${p} AND member >= ${p} AND (site <> 'NONE' OR member <> 'NONE')")) 64 perm 65 66 -- TODO: add combinators above expressing why the filters are being used, probably in authorize controller 67 data AuthorizeFilter = AllAuthorizations | ActiveAuthorizations deriving (Eq, Show) 68 69 -- | Attempt to find an authorization request or grant from the child party to the granting parent party. 70 -- If authorize filter is ForPartyViewer, filter out expired authorizations. 71 lookupAuthorize :: MonadDB c m => AuthorizeFilter -> Party -> Party -> m (Maybe Authorize) 72 lookupAuthorize aFilter child parent = 73 dbQuery1 $ 74 (\mkAuthorize' -> mkAuthorize' child parent) 75 <$> case aFilter of 76 ActiveAuthorizations -> 77 $(selectQuery 78 authorizeRow 79 "$WHERE authorize.child = ${partyId $ partyRow child} AND authorize.parent = ${partyId $ partyRow parent} AND (expires IS NULL OR expires > CURRENT_TIMESTAMP)") 80 AllAuthorizations -> 81 $(selectQuery 82 authorizeRow 83 "$WHERE authorize.child = ${partyId $ partyRow child} AND authorize.parent = ${partyId $ partyRow parent}") 84 85 -- | Find an active authorization request or approval from child to parent. 86 lookupAuthorizeParent :: (MonadDB c m, MonadHasIdentity c m) => Party -> Id Party -> m (Maybe Authorize) 87 lookupAuthorizeParent child parent = do 88 ident <- peek 89 dbQuery1 $ $(selectQuery (selectAuthorizeParent 'child 'ident) "$WHERE authorize.parent = ${parent} AND (expires IS NULL OR expires > CURRENT_TIMESTAMP)") 90 91 -- | Get the core active authorization entry between a child and parent, after inheritance has been applied. 92 -- Override authorize_view for the corner case of nobody as both parent and child. 93 lookupAuthorization :: (MonadDB c m, MonadHasIdentity c m) => Party -> Party -> m Authorization 94 lookupAuthorization child parent 95 | partyId (partyRow child) == partyId (partyRow parent) = return $ authorization $ selfAuthorize child 96 | otherwise = do 97 auth <- peek 98 if ((getPartyId . accountParty . siteAccount) auth) == partyId (partyRow child) && partyId (partyRow parent) == partyId (partyRow rootParty) 99 then return $ Authorization (siteAccess auth) child parent -- short circuit to get already fetched value in siteauthx 100 else fromMaybe (Authorization mempty child parent) <$> -- if not valid entry found, assume no access 101 dbQuery1 ((\a -> a child parent) <$> $(selectQuery authorizationRow "!$WHERE authorize_view.child = ${partyId $ partyRow child} AND authorize_view.parent = ${partyId $ partyRow parent}")) 102 103 -- | Update or insert the authorization object. Use the request and identity context to log the change in the 104 -- corresponding audit table as well. 105 changeAuthorize :: (MonadAudit c m) => Authorize -> m () 106 changeAuthorize auth = do 107 ident <- getAuditIdentity 108 (r, _) <- updateOrInsert 109 $(updateAuthorize 'ident 'auth) 110 $(insertAuthorize 'ident 'auth) 111 when (r /= 1) $ fail $ "changeAuthorize: " ++ show r ++ " rows" 112 113 removeAuthorize :: (MonadAudit c m) => Authorize -> m Bool 114 removeAuthorize auth = do 115 ident <- getAuditIdentity 116 dbExecute1 $(deleteAuthorize 'ident 'auth) 117 118 authorizationActive :: Authorization -> Bool 119 authorizationActive Authorization{ authorizeAccess = a } = a /= mempty 120 121 authorizeExpired :: Authorize -> Timestamp -> Bool 122 authorizeExpired Authorize{ authorizeExpires = Just e } = (e <) 123 authorizeExpired _ = const False 124 125 authorizeActive :: Authorize -> Timestamp -> Bool 126 authorizeActive a t = authorizationActive (authorization a) && not (authorizeExpired a t) 127 128 authorizeJSON :: JSON.ToObject o => Authorize -> o 129 authorizeJSON Authorize{..} = accessJSON (authorizeAccess authorization) 130 <> "expires" `JSON.kvObjectOrEmpty` authorizeExpires 131 132 lookupAuthorizeActivity :: (MonadDB c m, MonadHasIdentity c m) => Int -> m [(Timestamp, Party)] 133 lookupAuthorizeActivity limit = do 134 ident :: Identity <- peek 135 dbQuery $(selectQuery (selectAuthorizeActivity 'ident) "$JOIN authorize_view ON audit.parent = authorize_view.child AND authorize_view.parent = 0 WHERE audit.audit_action IN ('add','change') AND audit.site >= 'EDIT' AND authorize_view.site > 'EDIT' ORDER BY audit.audit_time DESC LIMIT ${fromIntegral limit :: Int64}")