summaryrefslogtreecommitdiff
path: root/overlays/spm/server/Spm/Server
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2022-05-26 13:58:07 +0200
committerGregor Kleen <gkleen@yggdrasil.li>2022-05-26 13:58:07 +0200
commitfc6cf6169868e60c189e4b243330c3717ff159f3 (patch)
tree3f6dea9c1420e23756257b5abea27ec9ed92d58a /overlays/spm/server/Spm/Server
parent84f2affd66a0ff3947b91a30308cb8e6a8ff7594 (diff)
downloadnixos-fc6cf6169868e60c189e4b243330c3717ff159f3.tar
nixos-fc6cf6169868e60c189e4b243330c3717ff159f3.tar.gz
nixos-fc6cf6169868e60c189e4b243330c3717ff159f3.tar.bz2
nixos-fc6cf6169868e60c189e4b243330c3717ff159f3.tar.xz
nixos-fc6cf6169868e60c189e4b243330c3717ff159f3.zip
...
Diffstat (limited to 'overlays/spm/server/Spm/Server')
-rw-r--r--overlays/spm/server/Spm/Server/Ctx.hs24
-rw-r--r--overlays/spm/server/Spm/Server/Database.hs73
-rw-r--r--overlays/spm/server/Spm/Server/UI.hs23
-rw-r--r--overlays/spm/server/Spm/Server/Wordlist.hs31
4 files changed, 151 insertions, 0 deletions
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 @@
1{-# LANGUAGE TemplateHaskell #-}
2
3module Spm.Server.Ctx
4 ( ServerCtx(..)
5 , sctxSqlPool, sctxInstanceId, sctxJwkSet
6 ) where
7
8import Data.UUID (UUID)
9import Crypto.JOSE.JWK (JWKSet)
10import Database.Persist.Postgresql
11import Data.Pool
12import Control.Lens.TH
13
14import Type.Reflection (Typeable)
15import GHC.Generics (Generic)
16
17
18data ServerCtx = ServerCtx
19 { _sctxSqlPool :: Pool SqlBackend
20 , _sctxInstanceId :: UUID
21 , _sctxJwkSet :: JWKSet
22 } deriving (Generic, Typeable)
23makeLenses ''ServerCtx
24
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 @@
1{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, UndecidableInstances #-}
2
3module Spm.Server.Database
4 ( MailMailbox, MailLocal, MailExtension, MailDomain
5 , Mailbox(..), MailboxMapping(..)
6 , Key(..), EntityField(..), 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 UniqueLocalDomain local domain sql=local_domain_unique !force
73|]
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 @@
1{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
2
3module Spm.Server.UI
4 ( uiServer
5 ) where
6
7import Prelude
8
9import Network.Wai
10
11import Network.Wai.Application.Static
12import WaiAppStatic.Types
13
14import Data.FileEmbed
15
16
17uiServer :: Application
18uiServer = staticApp settings
19 { ssLookupFile = \pcs -> ssLookupFile settings pcs >>= \case
20 LRNotFound -> ssLookupFile settings [unsafeToPiece "index.html"]
21 o -> return o
22 }
23 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 @@
1{-# LANGUAGE TemplateHaskell #-}
2
3module Spm.Server.Wordlist
4 ( wordlist, consonants
5 ) where
6
7import Prelude
8import Language.Haskell.TH.Syntax
9import Control.Monad.IO.Class
10
11import Data.Text (Text)
12import qualified Data.Text as Text
13import qualified Data.Text.IO as Text
14
15import Data.Vector (Vector)
16import qualified Data.Vector as Vector
17
18import Data.FileEmbed (makeRelativeToProject)
19
20import Instances.TH.Lift ()
21
22
23{-# NOINLINE wordlist #-}
24{-# NOINLINE consonants #-}
25wordlist, consonants :: Vector Text
26wordlist = $( do
27 fPath <- makeRelativeToProject "wordlist.txt"
28 addDependentFile fPath
29 lift . Vector.fromList =<< liftIO (filter (not . Text.null) . Text.words <$> Text.readFile fPath)
30 )
31consonants = Vector.fromList $ map Text.singleton "bcdfghjklmnpqrstvwxz"