module Model.Party.Types
( PartyRow(..)
, Party(..)
, Loaded(..)
, loadedToMaybe
, Account(..)
, getPartyId
, SiteAuth(..)
, nobodyParty
, rootParty
, staffParty
, nobodySiteAuth
, blankParty
, blankAccount
) where
import qualified Data.ByteString as BS
import qualified Data.Text as T
import Instances.TH.Lift ()
import Language.Haskell.TH.Lift (deriveLiftMany)
import Has (Has(..))
import Model.URL (URI)
import Model.Kind
import Model.Id.Types
import Model.Permission.Types
import Model.ORCID
type instance IdType Party = Int32
data PartyRow = PartyRow
{ partyId :: Id Party
, partySortName :: T.Text
, partyPreName :: Maybe T.Text
, partyORCID :: Maybe ORCID
, partyAffiliation :: Maybe T.Text
, partyURL :: Maybe URI
}
data Party = Party
{ partyRow :: !PartyRow
, partyAccount :: Maybe Account
, partySiteAccess :: !(Loaded Permission)
, partyPermission :: Permission
, partyAccess :: Maybe Access
}
data Loaded a =
Loaded a
| NotLoaded
loadedToMaybe :: Loaded a -> Maybe a
loadedToMaybe (Loaded v) = Just v
loadedToMaybe NotLoaded = Nothing
data Account = Account
{ accountEmail :: BS.ByteString
, accountParty :: Party
}
instance Has (Id Party) Party where
view = getPartyId
getPartyId :: Party -> Id Party
getPartyId = partyId . partyRow
instance Has Party Account where
view = accountParty
instance Has (Id Party) Account where
view = getPartyId . accountParty
instance Has Access Party where
view Party{ partyAccess = Just a } = a
view _ = mempty
instance Kinded Party where
kindOf _ = "party"
data SiteAuth = SiteAuth
{ siteAccount :: Account
, accountPasswd :: Maybe BS.ByteString
, siteAccess :: Access
}
instance Has Account SiteAuth where
view = siteAccount
instance Has Party SiteAuth where
view = view . siteAccount
instance Has (Id Party) SiteAuth where
view = view . siteAccount
instance Has Access SiteAuth where
view = siteAccess
deriveLiftMany [''PartyRow, ''Party, ''Account, ''Loaded]
nobodyParty, rootParty, staffParty :: Party
nobodyParty =
Party
(PartyRow (Id (1)) (T.pack "Everybody") Nothing Nothing Nothing Nothing)
Nothing
NotLoaded
PermissionREAD
Nothing
rootParty =
Party
(PartyRow (Id 0) (T.pack "Databrary") Nothing Nothing Nothing Nothing)
Nothing
NotLoaded
PermissionSHARED
Nothing
staffParty =
Party
(PartyRow (Id 2) (T.pack "Staff") Nothing Nothing (Just (T.pack "Databrary")) Nothing)
Nothing
NotLoaded
PermissionPUBLIC
Nothing
nobodySiteAuth :: SiteAuth
nobodySiteAuth = SiteAuth
{ siteAccount = Account
{ accountEmail = "nobody@databrary.org"
, accountParty = Party
{ partyRow = PartyRow
{ partyId = Id (1)
, partySortName = "Nobody"
, partyPreName = Nothing
, partyORCID = Nothing
, partyAffiliation = Nothing
, partyURL = Nothing
}
, partyAccount = Nothing
, partySiteAccess = NotLoaded
, partyPermission = PermissionREAD
, partyAccess = Just minBound
}
}
, accountPasswd = Nothing
, siteAccess = mempty
}
blankParty :: Party
blankParty = Party
{ partyRow = PartyRow
{ partyId = error "blankParty"
, partySortName = ""
, partyPreName = Nothing
, partyORCID = Nothing
, partyAffiliation = Nothing
, partyURL = Nothing
}
, partyAccount = Nothing
, partySiteAccess = NotLoaded
, partyPermission = PermissionNONE
, partyAccess = Nothing
}
blankAccount :: Account
blankAccount = Account
{ accountParty = blankParty{ partyAccount = Just blankAccount }
, accountEmail = error "blankAccount"
}