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