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   }