module Model.Party.SQL
( selectPartyRow
, selectParty
, selectPartyAuthorization
, selectAuthParty
, selectAccount
, selectUserAccount
, selectSiteAuth
, updateParty
, updateAccount
, insertParty
, insertAccount
, deleteParty
, deleteAccount
, makeSiteAuth
, makeUserAccount
, makeAccount
, makePartyAuthorization
, permissionParty
, makeParty
, makeParty2
) where
import qualified Data.ByteString as BS
import Data.Foldable (fold)
import Data.Monoid ((<>))
import qualified Language.Haskell.TH as TH
import Has (Has, view)
import Model.SQL.Select
import Model.Audit.SQL
import Model.Permission.Types
import Model.Permission.SQL
import Model.Id.Types
import Model.Identity.Types
import Model.Party.Types
selectPartyRow :: Selector
selectPartyRow = selectColumns 'PartyRow "party" ["id", "name", "prename", "orcid", "affiliation", "url"]
accountRow :: Selector
accountRow = selectColumns 'Account "account" ["email"]
makeParty :: PartyRow -> Maybe (Party -> Account) -> Permission -> Maybe Access -> Party
makeParty pr mMkAcct perm mAccess = makeParty2 pr mMkAcct NotLoaded perm mAccess
makeParty2 :: PartyRow -> Maybe (Party -> Account) -> Loaded Permission -> Permission -> Maybe Access -> Party
makeParty2 pr mMkAcct lSiteAccess perm mAccess =
p
where
p = Party pr (fmap (\mkAcct -> mkAcct p) mMkAcct) lSiteAccess perm mAccess
selectPermissionParty :: Selector
selectPermissionParty = selectJoin 'makeParty
[ selectPartyRow
, maybeJoinUsing ["id"] accountRow
]
permissionParty
:: Has (Id Party) a
=> (Permission -> Maybe Access -> a)
-> Maybe Access
-> Identity
-> a
permissionParty mkPartyOrAcct mGrantedAccessFromPartyToViewer viewingIdent =
p
where
p = mkPartyOrAcct maxPermission mAccessDeduced
maxPermission :: Permission
maxPermission =
case mAccessDeduced of
Nothing -> maxDefaultDerivedFromActor
Just accessDeduced -> max (accessPermission' accessDeduced) maxDefaultDerivedFromActor
maxDefaultDerivedFromActor :: Permission
maxDefaultDerivedFromActor =
max PermissionPUBLIC
$ min PermissionREAD
$ accessSite' generalSiteAccessForViewer
mAccessDeduced :: Maybe Access
mAccessDeduced
| extractFromIdentifiedSessOrDefault
False
(\viewingSess -> (view p :: Id Party) == (view viewingSess :: Id Party))
viewingIdent =
Just maxBound
| identityAdmin viewingIdent =
Just
(case mGrantedAccessFromPartyToViewer of
Nothing -> generalSiteAccessForViewer
Just granted -> granted <> generalSiteAccessForViewer)
| otherwise =
mGrantedAccessFromPartyToViewer
generalSiteAccessForViewer :: Access
generalSiteAccessForViewer = view viewingIdent
selectParty :: TH.Name
-> Selector
selectParty ident = selectMap ((`TH.AppE` TH.VarE ident) . (`TH.AppE` TH.ConE 'Nothing) . (TH.VarE 'permissionParty `TH.AppE`))
selectPermissionParty
makePartyAuthorization :: Party -> Maybe Access -> (Party, Maybe Permission)
makePartyAuthorization p a = (p, accessSite <$> a)
selectPartyAuthorization :: TH.Name
-> Selector
selectPartyAuthorization ident = selectJoin 'makePartyAuthorization
[ selectParty ident
, maybeJoinOn "party.id = authorize_view.child AND authorize_view.parent = 0"
$ accessRow "authorize_view"
]
selectAuthParty :: TH.Name
-> Selector
selectAuthParty ident = selectMap (`TH.AppE` TH.VarE ident) $ selectJoin 'permissionParty
[ selectPermissionParty
, maybeJoinOn ("party.id = authorize_valid.parent AND authorize_valid.child = ${view " ++ nameRef ident ++ " :: Id Party}")
$ accessRow "authorize_valid"
]
makeAccount :: PartyRow -> (Party -> Account) -> Permission -> Maybe Access -> Account
makeAccount pr ac perm ma = a where
a = ac $ Party pr (Just a) NotLoaded perm ma
selectPermissionAccount :: Selector
selectPermissionAccount = selectJoin 'makeAccount
[ selectPartyRow
, joinUsing ["id"] accountRow
]
selectAccount :: TH.Name
-> Selector
selectAccount ident = selectMap ((`TH.AppE` TH.VarE ident) . (`TH.AppE` TH.ConE 'Nothing) . (TH.VarE 'permissionParty `TH.AppE`))
selectPermissionAccount
makeUserAccount :: (Permission -> Maybe Access -> Account) -> Account
makeUserAccount mkAcc = mkAcc maxBound (Just maxBound)
selectUserAccount :: Selector
selectUserAccount = selectMap (TH.VarE 'makeUserAccount `TH.AppE`) selectPermissionAccount
makeSiteAuth :: Account -> Maybe BS.ByteString -> Maybe Access -> SiteAuth
makeSiteAuth account mPassword mAccess = SiteAuth account mPassword (fold mAccess)
selectSiteAuth :: Selector
selectSiteAuth = selectJoin 'makeSiteAuth
[ selectUserAccount
, Selector (SelectColumn "account" "password") "" ""
, maybeJoinOn "account.id = authorize_view.child AND authorize_view.parent = 0"
$ accessRow "authorize_view"
]
partyKeys :: String
-> [(String, String)]
partyKeys p =
[ ("id", "${partyId $ partyRow " ++ p ++ "}") ]
accountKeys :: String
-> [(String, String)]
accountKeys a = partyKeys $ "(accountParty " ++ a ++ ")"
partySets :: String
-> [(String, String)]
partySets p =
[ ("name", "${partySortName $ partyRow " ++ p ++ "}")
, ("prename", "${partyPreName $ partyRow " ++ p ++ "}")
, ("affiliation", "${partyAffiliation $ partyRow " ++ p ++ "}")
, ("url", "${partyURL $ partyRow " ++ p ++ "}")
]
accountSets :: String
-> [(String, String)]
accountSets a =
[ ("email", "${accountEmail " ++ a ++ "}")
]
updateParty :: TH.Name
-> TH.Name
-> TH.ExpQ
updateParty ident p = auditUpdate ident "party"
(partySets ps)
(whereEq $ partyKeys ps)
Nothing
where ps = nameRef p
updateAccount :: TH.Name
-> TH.Name
-> TH.ExpQ
updateAccount ident a = auditUpdate ident "account"
(accountSets as ++ [("password", "${accountPasswd " ++ us ++ "}")])
(whereEq $ accountKeys as)
Nothing
where
as = "(siteAccount " ++ us ++ ")"
us = nameRef a
insertParty :: TH.Name
-> TH.Name
-> TH.ExpQ
insertParty ident p = auditInsert ident "party"
(partySets ps)
(Just $ selectOutput selectPartyRow)
where ps = nameRef p
insertAccount :: TH.Name
-> TH.Name
-> TH.ExpQ
insertAccount ident a = auditInsert ident "account"
(accountKeys as ++ accountSets as)
Nothing
where as = nameRef a
deleteParty :: TH.Name
-> TH.Name
-> TH.ExpQ
deleteParty ident p = auditDelete ident "party"
(whereEq $ partyKeys (nameRef p))
Nothing
deleteAccount :: TH.Name
-> TH.Name
-> TH.ExpQ
deleteAccount ident p = auditDelete ident "account"
(whereEq $ partyKeys (nameRef p))
Nothing