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