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
|