surtr: ...

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 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, UndecidableInstances #-}
+
+module Spm.Server.Database
+  ( MailMailbox, MailLocal, MailExtension, MailDomain
+  , Mailbox(..), MailboxMapping(..)
+  , 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
+|]