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   }