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