summaryrefslogtreecommitdiff
path: root/hosts/surtr/email/spm/server/Spm/Server/Database.hs
diff options
context:
space:
mode:
Diffstat (limited to 'hosts/surtr/email/spm/server/Spm/Server/Database.hs')
-rw-r--r--hosts/surtr/email/spm/server/Spm/Server/Database.hs72
1 files changed, 72 insertions, 0 deletions
diff --git a/hosts/surtr/email/spm/server/Spm/Server/Database.hs b/hosts/surtr/email/spm/server/Spm/Server/Database.hs
new file mode 100644
index 00000000..09b4c67b
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Spm/Server/Database.hs
@@ -0,0 +1,72 @@
1{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, UndecidableInstances #-}
2
3module Spm.Server.Database
4 ( MailMailbox, MailLocal, MailExtension, MailDomain
5 , Mailbox(..), MailboxMapping(..)
6 , Unique(..)
7 ) where
8
9import Prelude
10
11import Database.Persist
12import Database.Persist.Sql
13import Database.Persist.TH
14
15import GHC.Generics (Generic)
16import Type.Reflection (Typeable)
17
18import Data.Text (Text)
19
20import Data.CaseInsensitive (CI)
21import qualified Data.CaseInsensitive as CI
22import Data.CaseInsensitive.Instances ()
23
24import Data.UUID (UUID)
25import Data.UUID.Instances ()
26
27import Data.Int (Int64)
28
29import Control.Lens
30
31import Web.HttpApiData
32
33
34newtype MailMailbox = MailMailbox
35 { unMailMailbox :: CI Text
36 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
37 deriving newtype (PersistField, PersistFieldSql)
38makeWrapped ''MailMailbox
39newtype MailLocal = MailLocal
40 { unMailLocal :: CI Text
41 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
42 deriving newtype (PersistField, PersistFieldSql)
43makeWrapped ''MailLocal
44newtype MailExtension = MailExtension
45 { unMailExtension :: CI Text
46 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
47 deriving newtype (PersistField, PersistFieldSql)
48makeWrapped ''MailExtension
49newtype MailDomain = MailDomain
50 { unMailDomain :: CI Text
51 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
52 deriving newtype (PersistField, PersistFieldSql)
53makeWrapped ''MailDomain
54
55instance FromHttpApiData MailDomain where
56 parseUrlPiece = fmap (review _Wrapped . CI.mk) . parseUrlPiece
57
58
59share [mkPersist sqlSettings] [persistLowerCase|
60 Mailbox
61 Id UUID sqltype=uuid default=gen_random_uuid()
62 ident MailMailbox sql=mailbox
63 quota Int64 Maybe sql=quota_bytes MigrationOnly
64 UniqueMailbox ident
65 deriving Show
66 MailboxMapping
67 Id UUID sqltype=uuid default=gen_random_uuid()
68 local MailLocal Maybe
69 extension MailExtension Maybe
70 domain MailDomain
71 mailbox MailboxId
72|]