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