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