1 {-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
    2 module Databrary.Model.Party.SQL
    3   ( selectPartyRow
    4   , selectParty
    5   , selectPartyAuthorization
    6   , selectAuthParty
    7   , selectAccount
    8   , selectUserAccount
    9   , selectSiteAuth
   10   , updateParty
   11   , updateAccount
   12   , insertParty
   13   , insertAccount
   14   , deleteParty
   15   , deleteAccount
   16   -- for expanded queries
   17   , makeSiteAuth
   18   , makeUserAccount
   19   , makeAccount
   20   , makePartyAuthorization
   21   , permissionParty
   22   , makeParty
   23   ) where
   24 
   25 import qualified Data.ByteString as BS
   26 import Data.Foldable (fold)
   27 import Data.Monoid ((<>))
   28 import qualified Language.Haskell.TH as TH
   29 
   30 import Databrary.Has (Has, view)
   31 import Databrary.Model.SQL.Select
   32 import Databrary.Model.Audit.SQL
   33 import Databrary.Model.Permission.Types
   34 import Databrary.Model.Permission.SQL
   35 import Databrary.Model.Id.Types
   36 import Databrary.Model.Identity.Types
   37 import Databrary.Model.Party.Types
   38 
   39 selectPartyRow :: Selector -- ^ @'PartyRow'@
   40 selectPartyRow = selectColumns 'PartyRow "party" ["id", "name", "prename", "orcid", "affiliation", "url"]
   41 
   42 accountRow :: Selector -- ^ @'Party' -> 'Account'@
   43 accountRow = selectColumns 'Account "account" ["email"]
   44 
   45 -- | Build party, with a circular connection to an account if an account creation function is provided
   46 makeParty :: PartyRow -> Maybe (Party -> Account) -> Permission -> Maybe Access -> Party
   47 makeParty pr mMkAcct perm mAccess =
   48     p
   49   where
   50     p = Party pr (fmap (\mkAcct -> mkAcct p) mMkAcct) perm mAccess
   51 
   52 selectPermissionParty :: Selector -- ^ @'Permission' -> Maybe 'Access' -> 'Party'@
   53 selectPermissionParty = selectJoin 'makeParty
   54   [ selectPartyRow
   55   , maybeJoinUsing ["id"] accountRow
   56   ]
   57 
   58 -- | Build an account or party, based on calling context.
   59 -- Compute permission and access by coalescing authorization granted directly and generally
   60 permissionParty
   61   :: Has (Id Party) a
   62   => (Permission -> Maybe Access -> a) -- ^ Partially applied makeParty, ready to build full account or party
   63   -> Maybe Access -- ^ The direct authorization that the party/account being built may have authorized to the
   64                   -- viewing identity/user. This is only used by lookupAuthParty, which is only used in the
   65                   -- context of retreiving a party for editing/viewing in isolation by the party controller actions
   66   -> Identity -- ^ The viewing identity / user which is trying to view or edit the party being retrieved.
   67   -> a -- ^ account or party
   68 permissionParty mkPartyOrAcct mGrantedAccessFromPartyToViewer viewingIdent =
   69     p
   70   where
   71     p = mkPartyOrAcct maxPermission mAccessDeduced
   72     maxPermission :: Permission
   73     maxPermission =
   74         case mAccessDeduced of
   75             -- if there is no Identity associated Access, then use the viewing actors bounded permission
   76             Nothing -> maxDefaultDerivedFromActor
   77             -- if there is an Identity Access, then max with identity's lowest access perm
   78             Just accessDeduced -> max (accessPermission' accessDeduced) maxDefaultDerivedFromActor
   79     -- | Push the viewingIdent's site access permission to the highest value within Public ... Read
   80     -- This default value is derived from the viewingIdent's granted databrary wide site access.
   81     maxDefaultDerivedFromActor :: Permission
   82     maxDefaultDerivedFromActor =
   83         max PermissionPUBLIC  -- then, lower bound with public
   84           $ min PermissionREAD  -- upper bound with read (just because you have higher privileges on site doesn't mean
   85                                 -- you can edit any party's data)
   86             -- accessSite means extract Access from the identity, then extract site field of that Access record
   87             -- for NotLoggedIn and IdentityNotNeeded, the access is (None,None) via nobodySiteAuth
   88             -- for Identified, the access is the levels granted to the user on the databrary site via it's parent
   89             $ accessSite' generalSiteAccessForViewer
   90     mAccessDeduced :: Maybe Access
   91     mAccessDeduced
   92       -- if the viewing identity is Identified, and the viewer is the same as the party being retrieved,
   93       --  then allow unbounded permission on the retrieved party (self)
   94       | extractFromIdentifiedSessOrDefault
   95               False
   96               (\viewingSess -> (view p :: Id Party) == (view viewingSess :: Id Party))
   97               viewingIdent =
   98             Just maxBound
   99       -- if the viewing user is a sitewide admin
  100       | identityAdmin viewingIdent =
  101             Just
  102                 (case mGrantedAccessFromPartyToViewer of
  103                     Nothing -> generalSiteAccessForViewer -- get access via siteauth
  104                      -- max elements between granted access and access via siteauth
  105                     Just granted -> granted <> generalSiteAccessForViewer)
  106       -- the viewing user is normal and someone isn't trying to edit/view themselves
  107       | otherwise =
  108             mGrantedAccessFromPartyToViewer
  109     generalSiteAccessForViewer :: Access
  110     generalSiteAccessForViewer = view viewingIdent
  111 
  112 selectParty :: TH.Name -- ^ 'Identity'
  113   -> Selector -- ^ @'Party'@
  114 selectParty ident = selectMap ((`TH.AppE` TH.VarE ident) . (`TH.AppE` (TH.ConE 'Nothing)) . (TH.VarE 'permissionParty `TH.AppE`)) $
  115   selectPermissionParty
  116 
  117 makePartyAuthorization :: Party -> Maybe Access -> (Party, Maybe Permission)
  118 makePartyAuthorization p a = (p, accessSite <$> a)
  119 
  120 selectPartyAuthorization :: TH.Name -- ^ 'Identity'
  121   -> Selector -- ^ @('Party', Maybe 'Permission')@
  122 selectPartyAuthorization ident = selectJoin 'makePartyAuthorization
  123   [ selectParty ident
  124   , maybeJoinOn "party.id = authorize_view.child AND authorize_view.parent = 0"
  125     $ accessRow "authorize_view"
  126   ]
  127 
  128 selectAuthParty :: TH.Name -- ^ 'Identity`
  129   -> Selector -- ^ @'Party'@
  130 selectAuthParty ident = selectMap (`TH.AppE` TH.VarE ident) $ selectJoin 'permissionParty
  131   [ selectPermissionParty
  132   , maybeJoinOn ("party.id = authorize_valid.parent AND authorize_valid.child = ${view " ++ nameRef ident ++ " :: Id Party}")
  133     $ accessRow "authorize_valid" -- optimization, should be authorize_view if we used site
  134   ]
  135 
  136 -- | Used by 'makeUserAccount' and 'selectPermissionAccount'. This finishes building the circular Party and Account structure.
  137 makeAccount :: PartyRow -> (Party -> Account) -> Permission -> Maybe Access -> Account
  138 makeAccount pr ac perm ma = a where
  139   a = ac $ Party pr (Just a) perm ma
  140 
  141 selectPermissionAccount :: Selector -- ^ @'Permission' -> Maybe 'Access' -> 'Account'@
  142 selectPermissionAccount = selectJoin 'makeAccount
  143   [ selectPartyRow
  144   , joinUsing ["id"] accountRow
  145   ]
  146 
  147 selectAccount :: TH.Name -- ^ 'Identity'
  148   -> Selector -- ^ @'Account'@
  149 selectAccount ident = selectMap ((`TH.AppE` TH.VarE ident) . (`TH.AppE` (TH.ConE 'Nothing)) . (TH.VarE 'permissionParty `TH.AppE`)) $
  150   selectPermissionAccount
  151 
  152 -- | Build an account, using ADMIN permission and (ADMIN,ADMIN) access object.
  153 -- Essentially a user has full permissions over themselves and the access object
  154 -- nested within the account party has max privileges.
  155 -- I suspect that the access object within a Party, when nested inside of a SiteAuth
  156 -- is almost never used, as the Has instances all retrieve siteAccess, not (partyAccess . accountParty . siteAccount)
  157 makeUserAccount :: (Permission -> Maybe Access -> Account) -> Account
  158 makeUserAccount mkAcc = mkAcc maxBound (Just maxBound)
  159 
  160 selectUserAccount :: Selector -- @'Account'
  161 selectUserAccount = selectMap (TH.VarE 'makeUserAccount `TH.AppE`) selectPermissionAccount
  162 
  163 -- | Build a SiteAuth object using the provided Account, possible password, and possible access object.
  164 -- If no access object is provided, then use (None, None) for the access object.
  165 makeSiteAuth :: Account -> Maybe BS.ByteString -> Maybe Access -> SiteAuth
  166 makeSiteAuth account mPassword mAccess = SiteAuth account mPassword (fold mAccess)
  167 
  168 selectSiteAuth :: Selector -- @'SiteAuth'@
  169 selectSiteAuth = selectJoin 'makeSiteAuth
  170   [ selectUserAccount
  171   , Selector (SelectColumn "account" "password") "" ""
  172   , maybeJoinOn "account.id = authorize_view.child AND authorize_view.parent = 0"
  173     $ accessRow "authorize_view"
  174   ]
  175 
  176 partyKeys :: String -- ^ @'Party'@
  177   -> [(String, String)]
  178 partyKeys p =
  179   [ ("id", "${partyId $ partyRow " ++ p ++ "}") ]
  180 
  181 accountKeys :: String -- ^ @'Account'@
  182   -> [(String, String)]
  183 accountKeys a = partyKeys $ "(accountParty " ++ a ++ ")"
  184 
  185 partySets :: String -- ^ @'Party'@
  186   -> [(String, String)]
  187 partySets p =
  188   [ ("name",        "${partySortName $ partyRow "    ++ p ++ "}")
  189   , ("prename",     "${partyPreName $ partyRow "     ++ p ++ "}")
  190   , ("affiliation", "${partyAffiliation $ partyRow " ++ p ++ "}")
  191   , ("url",         "${partyURL $ partyRow "         ++ p ++ "}")
  192   ]
  193 
  194 accountSets :: String -- ^ @'Account'@
  195   -> [(String, String)]
  196 accountSets a =
  197   [ ("email", "${accountEmail " ++ a ++ "}")
  198   ]
  199 
  200 updateParty :: TH.Name -- ^ @'AuditIdentity'
  201   -> TH.Name -- ^ @'Party'@
  202   -> TH.ExpQ -- ()
  203 updateParty ident p = auditUpdate ident "party"
  204   (partySets ps)
  205   (whereEq $ partyKeys ps)
  206   Nothing
  207   where ps = nameRef p
  208 
  209 updateAccount :: TH.Name -- ^ @'AuditIdentity'
  210   -> TH.Name -- ^ @'Account'@
  211   -> TH.ExpQ -- ()
  212 updateAccount ident a = auditUpdate ident "account"
  213   (accountSets as ++ [("password", "${accountPasswd " ++ us ++ "}")])
  214   (whereEq $ accountKeys as)
  215   Nothing
  216   where
  217   as = "(siteAccount " ++ us ++ ")"
  218   us = nameRef a
  219 
  220 insertParty :: TH.Name -- ^ @'AuditIdentity'
  221   -> TH.Name -- ^ @'Party'@
  222   -> TH.ExpQ -- ^ @'PartyRow'@
  223 insertParty ident p = auditInsert ident "party"
  224   (partySets ps)
  225   (Just $ selectOutput selectPartyRow)
  226   where ps = nameRef p
  227 
  228 insertAccount :: TH.Name -- ^ @'AuditIdentity'
  229   -> TH.Name -- ^ @'Account'@
  230   -> TH.ExpQ
  231 insertAccount ident a = auditInsert ident "account"
  232   (accountKeys as ++ accountSets as)
  233   Nothing
  234   where as = nameRef a
  235 
  236 deleteParty :: TH.Name -- ^ @'AuditIdentity'
  237   -> TH.Name -- ^ @'Party'@
  238   -> TH.ExpQ -- ^ @()@
  239 deleteParty ident p = auditDelete ident "party"
  240   (whereEq $ partyKeys (nameRef p))
  241   Nothing
  242 
  243 deleteAccount :: TH.Name -- ^ @'AuditIdentity'
  244   -> TH.Name -- ^ @'Party'@
  245   -> TH.ExpQ -- ^ @()@
  246 deleteAccount ident p = auditDelete ident "account"
  247   (whereEq $ partyKeys (nameRef p))
  248   Nothing