1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, UndecidableInstances #-}
module Spm.Server.Database
( MailMailbox, MailLocal, MailExtension, MailDomain
, Mailbox(..), MailboxMapping(..)
, Key(..), EntityField(..), Unique(..)
) where
import Prelude
import Database.Persist
import Database.Persist.Sql
import Database.Persist.TH
import GHC.Generics (Generic)
import Type.Reflection (Typeable)
import Data.Text (Text)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive.Instances ()
import Data.UUID (UUID)
import Data.UUID.Instances ()
import Data.Int (Int64)
import Control.Lens
import Web.HttpApiData
newtype MailMailbox = MailMailbox
{ unMailMailbox :: CI Text
} deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (PersistField, PersistFieldSql)
makeWrapped ''MailMailbox
newtype MailLocal = MailLocal
{ unMailLocal :: CI Text
} deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (PersistField, PersistFieldSql)
makeWrapped ''MailLocal
newtype MailExtension = MailExtension
{ unMailExtension :: CI Text
} deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (PersistField, PersistFieldSql)
makeWrapped ''MailExtension
newtype MailDomain = MailDomain
{ unMailDomain :: CI Text
} deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (PersistField, PersistFieldSql)
makeWrapped ''MailDomain
instance FromHttpApiData MailDomain where
parseUrlPiece = fmap (review _Wrapped . CI.mk) . parseUrlPiece
share [mkPersist sqlSettings] [persistLowerCase|
Mailbox
Id UUID sqltype=uuid default=gen_random_uuid()
ident MailMailbox sql=mailbox
quota Int64 Maybe sql=quota_bytes MigrationOnly
UniqueMailbox ident
deriving Show
MailboxMapping
Id UUID sqltype=uuid default=gen_random_uuid()
local MailLocal Maybe
extension MailExtension Maybe
domain MailDomain
mailbox MailboxId
reject Bool
UniqueDomain domain sql=domain_unique !force
UniqueLocalDomain local domain sql=local_domain_unique !force
UniqueLocalExtensionDomain local extension domain sql=local_extension_domain_unique !force
|]
|
