106 lines
2.7 KiB
Haskell
106 lines
2.7 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
module Datarekisteri.Backend.DB where
|
|
|
|
import Data.ByteString (ByteString)
|
|
import Data.Text (Text)
|
|
import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings)
|
|
import Database.Persist (Entity, Key, entityKey, PersistEntity)
|
|
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
|
import Database.Persist.Postgresql.JSON (Value)
|
|
import Datarekisteri.Core.Types
|
|
import Datarekisteri.Backend.Types
|
|
|
|
mkPersist sqlSettings [persistUpperCase|
|
|
DBUser sql=users
|
|
registered Time
|
|
passwordCrypt PasswordHash
|
|
permissions Text
|
|
accepted (Maybe Time)
|
|
memberData Value sqltype=jsonb
|
|
|
|
deriving (Show)
|
|
|
|
DBEmail sql=emails
|
|
uid DBUserId
|
|
email Email sqltype=varchar(320)
|
|
vid (Maybe DBEmailVerificationId) sql=verification
|
|
|
|
UniqueUserVerified uid vid
|
|
-- This enables using persistent functions to get unique verified emails. The real
|
|
-- constraint is stricter and doesn't allow having more than one null and one non-null
|
|
-- verification but it's too complicated for persistent to understand.
|
|
|
|
UniqueEmail email
|
|
UniqueVerification vid
|
|
|
|
DBEmailVerification sql=emailVerifications
|
|
secret Text sqltype=varchar(255)
|
|
expires Time
|
|
|
|
UniqueVerificationSecret secret
|
|
|
|
DBKey sql=keys
|
|
uid DBUserId
|
|
data ByteString
|
|
expires (Maybe Time)
|
|
uploaded Time
|
|
comment Text
|
|
isPrimaryEncryptionKey Bool
|
|
|
|
DBToken sql=tokens
|
|
uid DBUserId
|
|
name (Maybe Text)
|
|
data Text
|
|
comment Text
|
|
issued Time
|
|
expires (Maybe Time)
|
|
permissions Text
|
|
|
|
UniqueNameUid name uid
|
|
UniqueData data
|
|
|]
|
|
|
|
entityToID :: FromDBKey a => Entity (DB a) -> a
|
|
entityToID = fromDBKey . entityKey
|
|
|
|
class PersistEntity (DB a) => FromDBKey a where
|
|
type DB a
|
|
fromDBKey :: Key (DB a) -> a
|
|
|
|
instance FromDBKey UserID where
|
|
type DB UserID = DBUser
|
|
fromDBKey = UserID . fromIntegral . fromSqlKey
|
|
|
|
instance FromDBKey TokenID where
|
|
type DB TokenID = DBToken
|
|
fromDBKey = TokenID . fromIntegral . fromSqlKey
|
|
|
|
instance FromDBKey KeyID where
|
|
type DB KeyID = DBKey
|
|
fromDBKey = KeyID . fromIntegral . fromSqlKey
|
|
|
|
class FromDBKey a => ToDBKey a where
|
|
toDBKey :: a -> Key (DB a)
|
|
|
|
instance ToDBKey UserID where
|
|
toDBKey (UserID x) = toSqlKey $ fromIntegral x
|
|
|
|
instance ToDBKey KeyID where
|
|
toDBKey (KeyID x) = toSqlKey $ fromIntegral x
|
|
|
|
instance ToDBKey TokenID where
|
|
toDBKey (TokenID x) = toSqlKey $ fromIntegral x
|