1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeFamilies #-} 2 module Databrary.Model.Party.Types 3 ( PartyRow(..) 4 , Party(..) 5 , Account(..) 6 , getPartyId 7 , SiteAuth(..) 8 , nobodyParty 9 , rootParty 10 , staffParty 11 , nobodySiteAuth 12 , blankParty 13 , blankAccount 14 ) where 15 16 import qualified Data.ByteString as BS 17 import qualified Data.Text as T 18 import Instances.TH.Lift () 19 import Language.Haskell.TH.Lift (deriveLiftMany) 20 21 import Databrary.Has (Has(..)) 22 import Databrary.Model.URL (URI) 23 import Databrary.Model.Kind 24 import Databrary.Model.Id.Types 25 import Databrary.Model.Permission.Types 26 import Databrary.Model.ORCID 27 28 type instance IdType Party = Int32 29 30 data PartyRow = PartyRow 31 { partyId :: Id Party 32 , partySortName :: T.Text 33 , partyPreName :: Maybe T.Text 34 , partyORCID :: Maybe ORCID 35 , partyAffiliation :: Maybe T.Text 36 , partyURL :: Maybe URI 37 } -- deriving (Show) -- (Eq) 38 39 -- | Represents users, institutions, labs, *and* groups. 40 data Party = Party 41 { partyRow :: !PartyRow 42 , partyAccount :: Maybe Account 43 -- , partySiteAccess :: Access -- site-level access this party is granted under root (currently SiteAuth only) 44 , partyPermission :: Permission -- ^ permission current user has over this party 45 , partyAccess :: Maybe Access -- ^ direct authorization this party has granted to current user 46 } 47 48 data Account = Account 49 { accountEmail :: BS.ByteString 50 , accountParty :: Party 51 } 52 53 instance Has (Id Party) Party where 54 view = getPartyId 55 getPartyId :: Party -> Id Party 56 getPartyId = partyId . partyRow 57 instance Has Party Account where 58 view = accountParty 59 instance Has (Id Party) Account where 60 view = (getPartyId . accountParty) 61 62 instance Has Access Party where 63 view Party{ partyAccess = Just a } = a 64 view _ = mempty 65 66 instance Kinded Party where 67 kindOf _ = "party" 68 69 -- | TODO: clarify. This is not necessarily a session, but... some user (human 70 -- being) who has been granted access to the site. There is a corner case 71 -- indirection because sometimes a job runs a human being. 72 data SiteAuth = SiteAuth 73 { siteAccount :: Account -- ^ maybe should be Party (for nobody) 74 , accountPasswd :: Maybe BS.ByteString 75 , siteAccess :: Access -- ^ Still figuring out what an 'Access' is. 76 } 77 78 instance Has Account SiteAuth where 79 view = siteAccount 80 instance Has Party SiteAuth where 81 view = (view . siteAccount) 82 instance Has (Id Party) SiteAuth where 83 view = (view . siteAccount) 84 instance Has Access SiteAuth where 85 view = siteAccess 86 87 deriveLiftMany [''PartyRow, ''Party, ''Account] 88 89 nobodyParty, rootParty, staffParty :: Party -- TODO: load on startup from service module 90 nobodyParty = 91 Party 92 (PartyRow (Id (-1)) (T.pack "Everybody") Nothing Nothing Nothing Nothing) 93 Nothing 94 PermissionREAD 95 Nothing 96 rootParty = 97 Party 98 (PartyRow (Id 0) (T.pack "Databrary") Nothing Nothing Nothing Nothing) 99 Nothing 100 PermissionSHARED 101 Nothing 102 staffParty = 103 Party 104 (PartyRow (Id 2) (T.pack "Staff") Nothing Nothing (Just (T.pack "Databrary")) Nothing) 105 Nothing 106 PermissionPUBLIC 107 Nothing 108 109 -- this is unfortunate, mainly to avoid untangling Party.SQL 110 nobodySiteAuth :: SiteAuth 111 nobodySiteAuth = SiteAuth 112 { siteAccount = Account 113 { accountEmail = "nobody@databrary.org" 114 , accountParty = Party 115 { partyRow = PartyRow 116 { partyId = Id (-1) 117 , partySortName = "Nobody" 118 , partyPreName = Nothing 119 , partyORCID = Nothing 120 , partyAffiliation = Nothing 121 , partyURL = Nothing 122 } 123 , partyAccount = Nothing 124 , partyPermission = PermissionREAD 125 , partyAccess = Just minBound 126 } 127 } 128 , accountPasswd = Nothing 129 , siteAccess = mempty 130 } 131 132 -- | Uninitialized Party object to be used in creating new parties (and accounts) 133 blankParty :: Party 134 blankParty = Party 135 { partyRow = PartyRow 136 { partyId = error "blankParty" 137 , partySortName = "" 138 , partyPreName = Nothing 139 , partyORCID = Nothing 140 , partyAffiliation = Nothing 141 , partyURL = Nothing 142 } 143 , partyAccount = Nothing 144 , partyPermission = PermissionNONE 145 , partyAccess = Nothing 146 } 147 148 -- | Uninitialized Account object to be used in creating new accounts 149 blankAccount :: Account 150 blankAccount = Account 151 { accountParty = blankParty{ partyAccount = Just blankAccount } 152 , accountEmail = error "blankAccount" 153 }