96 lines
2.3 KiB
Haskell
96 lines
2.3 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 Server.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 Server.Types
|
|
|
|
mkPersist sqlSettings [persistUpperCase|
|
|
DBUser sql=users
|
|
email (Maybe Email) sqltype=varchar(255)
|
|
pendingEmail (Maybe Email) sqltype=varchar(255)
|
|
emailVerificationSecret (Maybe Text)
|
|
registered Time
|
|
passwordCrypt PasswordHash
|
|
permissions Text
|
|
accepted (Maybe Time)
|
|
rejected (Maybe Time)
|
|
seceded (Maybe Time)
|
|
toBeDeleted (Maybe Time)
|
|
memberData Value sqltype=jsonb
|
|
|
|
UniqueEmail email
|
|
UniquePendingEmail pendingEmail
|
|
UniqueVerification emailVerificationSecret
|
|
|
|
deriving (Show)
|
|
|
|
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 . fromSqlKey
|
|
|
|
instance FromDBKey TokenID where
|
|
type DB TokenID = DBToken
|
|
fromDBKey = TokenID . fromSqlKey
|
|
|
|
instance FromDBKey KeyID where
|
|
type DB KeyID = DBKey
|
|
fromDBKey = KeyID . fromSqlKey
|
|
|
|
class FromDBKey a => ToDBKey a where
|
|
toDBKey :: a -> Key (DB a)
|
|
|
|
instance ToDBKey UserID where
|
|
toDBKey (UserID x) = toSqlKey x
|
|
|
|
instance ToDBKey KeyID where
|
|
toDBKey (KeyID x) = toSqlKey x
|
|
|
|
instance ToDBKey TokenID where
|
|
toDBKey (TokenID x) = toSqlKey x
|