From fc6cf6169868e60c189e4b243330c3717ff159f3 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 26 May 2022 13:58:07 +0200
Subject: ...

---
 overlays/spm/server/Spm/Server/Ctx.hs      | 24 ++++++++++
 overlays/spm/server/Spm/Server/Database.hs | 73 ++++++++++++++++++++++++++++++
 overlays/spm/server/Spm/Server/UI.hs       | 23 ++++++++++
 overlays/spm/server/Spm/Server/Wordlist.hs | 31 +++++++++++++
 4 files changed, 151 insertions(+)
 create mode 100644 overlays/spm/server/Spm/Server/Ctx.hs
 create mode 100644 overlays/spm/server/Spm/Server/Database.hs
 create mode 100644 overlays/spm/server/Spm/Server/UI.hs
 create mode 100644 overlays/spm/server/Spm/Server/Wordlist.hs

(limited to 'overlays/spm/server/Spm/Server')

diff --git a/overlays/spm/server/Spm/Server/Ctx.hs b/overlays/spm/server/Spm/Server/Ctx.hs
new file mode 100644
index 00000000..7b84e3d5
--- /dev/null
+++ b/overlays/spm/server/Spm/Server/Ctx.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Spm.Server.Ctx
+  ( ServerCtx(..)
+  , sctxSqlPool, sctxInstanceId, sctxJwkSet
+  ) where
+
+import Data.UUID (UUID)
+import Crypto.JOSE.JWK (JWKSet)
+import Database.Persist.Postgresql
+import Data.Pool
+import Control.Lens.TH
+
+import Type.Reflection (Typeable)
+import GHC.Generics (Generic)
+
+
+data ServerCtx = ServerCtx
+  { _sctxSqlPool :: Pool SqlBackend
+  , _sctxInstanceId :: UUID
+  , _sctxJwkSet :: JWKSet
+  } deriving (Generic, Typeable)
+makeLenses ''ServerCtx
+
diff --git a/overlays/spm/server/Spm/Server/Database.hs b/overlays/spm/server/Spm/Server/Database.hs
new file mode 100644
index 00000000..cc133e06
--- /dev/null
+++ b/overlays/spm/server/Spm/Server/Database.hs
@@ -0,0 +1,73 @@
+{-# 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
+    UniqueLocalDomain local domain sql=local_domain_unique !force
+|]
diff --git a/overlays/spm/server/Spm/Server/UI.hs b/overlays/spm/server/Spm/Server/UI.hs
new file mode 100644
index 00000000..544e4f54
--- /dev/null
+++ b/overlays/spm/server/Spm/Server/UI.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
+
+module Spm.Server.UI
+  ( uiServer
+  ) where
+
+import Prelude
+
+import Network.Wai
+
+import Network.Wai.Application.Static
+import WaiAppStatic.Types
+
+import Data.FileEmbed
+
+
+uiServer :: Application
+uiServer = staticApp settings
+    { ssLookupFile = \pcs -> ssLookupFile settings pcs >>= \case
+        LRNotFound -> ssLookupFile settings [unsafeToPiece "index.html"]
+        o -> return o
+    }
+  where settings = embeddedSettings $(embedDir "frontend")
diff --git a/overlays/spm/server/Spm/Server/Wordlist.hs b/overlays/spm/server/Spm/Server/Wordlist.hs
new file mode 100644
index 00000000..8109f07b
--- /dev/null
+++ b/overlays/spm/server/Spm/Server/Wordlist.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Spm.Server.Wordlist
+  ( wordlist, consonants
+  ) where
+
+import Prelude
+import Language.Haskell.TH.Syntax
+import Control.Monad.IO.Class
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+import Data.FileEmbed (makeRelativeToProject)
+
+import Instances.TH.Lift ()
+
+
+{-# NOINLINE wordlist #-}
+{-# NOINLINE consonants #-}
+wordlist, consonants :: Vector Text
+wordlist = $( do
+                fPath <- makeRelativeToProject "wordlist.txt"
+                addDependentFile fPath
+                lift . Vector.fromList =<< liftIO (filter (not . Text.null) . Text.words <$> Text.readFile fPath)
+            )
+consonants = Vector.fromList $ map Text.singleton "bcdfghjklmnpqrstvwxz"
-- 
cgit v1.2.3