summaryrefslogtreecommitdiff
path: root/hosts
diff options
context:
space:
mode:
Diffstat (limited to 'hosts')
-rw-r--r--hosts/sif/default.nix4
-rw-r--r--hosts/surtr/email/default.nix13
-rw-r--r--hosts/surtr/email/spm/default.nix24
-rw-r--r--hosts/surtr/email/spm/lib/Data/CaseInsensitive/Instances.hs19
-rw-r--r--hosts/surtr/email/spm/lib/Data/UUID/Instances.hs18
-rw-r--r--hosts/surtr/email/spm/lib/Spm.hs5
-rw-r--r--hosts/surtr/email/spm/lib/Spm/Api.hs40
-rw-r--r--hosts/surtr/email/spm/package.yaml92
-rw-r--r--hosts/surtr/email/spm/provision/Spm/Provision.hs46
-rw-r--r--hosts/surtr/email/spm/server/Crypto/JOSE/JWK/Instances.hs9
-rw-r--r--hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs30
-rw-r--r--hosts/surtr/email/spm/server/Data/UUID/Instances.hs31
-rw-r--r--hosts/surtr/email/spm/server/Spm/Server.hs194
-rw-r--r--hosts/surtr/email/spm/server/Spm/Server/Database.hs72
-rw-r--r--hosts/surtr/email/spm/spm.nix28
15 files changed, 11 insertions, 614 deletions
diff --git a/hosts/sif/default.nix b/hosts/sif/default.nix
index a1220005..a79cfaa7 100644
--- a/hosts/sif/default.nix
+++ b/hosts/sif/default.nix
@@ -31,8 +31,8 @@ in {
31 nvm0 = { device = "/dev/disk/by-uuid/fe641e81-0812-4181-a5f6-382ebba509bb"; bypassWorkqueues = true; }; 31 nvm0 = { device = "/dev/disk/by-uuid/fe641e81-0812-4181-a5f6-382ebba509bb"; bypassWorkqueues = true; };
32 nvm1 = { device = "/dev/disk/by-uuid/43df1ba8-1728-4193-8855-920a82d4494a"; bypassWorkqueues = true; }; 32 nvm1 = { device = "/dev/disk/by-uuid/43df1ba8-1728-4193-8855-920a82d4494a"; bypassWorkqueues = true; };
33 }; 33 };
34 availableKernelModules = [ "drbg" "nvme" "xhci_pci" "usb_storage" "sd_mod" "rtsx_pci_sdmmc" ]; 34 availableKernelModules = [ "drbg" "nvme" "xhci_pci" "usb_storage" "sd_mod" "sr_mod" "rtsx_pci_sdmmc" ];
35 kernelModules = [ "dm-raid" "dm-integrity" "dm-snapshot" "dm-thin-pool" ]; 35 kernelModules = [ "dm-raid" "dm-integrity" "dm-snapshot" "dm-thin-pool" "dm-mod" "dm-crypt" ];
36 }; 36 };
37 37
38 blacklistedKernelModules = [ "nouveau" ]; 38 blacklistedKernelModules = [ "nouveau" ];
diff --git a/hosts/surtr/email/default.nix b/hosts/surtr/email/default.nix
index 947aa328..b952070b 100644
--- a/hosts/surtr/email/default.nix
+++ b/hosts/surtr/email/default.nix
@@ -21,8 +21,6 @@ let
21 }; 21 };
22 22
23 spmDomains = ["bouncy.email"]; 23 spmDomains = ["bouncy.email"];
24
25 spm = pkgs.callPackage ./spm {};
26in { 24in {
27 config = { 25 config = {
28 nixpkgs.overlays = [ 26 nixpkgs.overlays = [
@@ -118,7 +116,14 @@ in {
118 "reject_unverified_recipient" 116 "reject_unverified_recipient"
119 ]; 117 ];
120 unverified_recipient_reject_code = "550"; 118 unverified_recipient_reject_code = "550";
121 unverified_recipient_reject_reason = "Recipient address rejected: undeliverable address"; 119 unverified_recipient_reject_reason = "Recipient address lookup failed";
120 address_verify_map = "internal:address_verify_map";
121 address_verify_positive_expire_time = "1h";
122 address_verify_positive_refresh_time = "15m";
123 address_verify_negative_expire_time = "15s";
124 address_verify_negative_refresh_time = "5s";
125 address_verify_cache_cleanup_interval = "5s";
126 address_verify_poll_delay = "1s";
122 127
123 smtpd_relay_restrictions = [ 128 smtpd_relay_restrictions = [
124 "permit_mynetworks" 129 "permit_mynetworks"
@@ -643,7 +648,7 @@ in {
643 systemd.services.spm = { 648 systemd.services.spm = {
644 serviceConfig = { 649 serviceConfig = {
645 Type = "notify"; 650 Type = "notify";
646 ExecStart = "${spm}/bin/spm-server"; 651 ExecStart = "${pkgs.spm}/bin/spm-server";
647 User = "spm"; 652 User = "spm";
648 Group = "spm"; 653 Group = "spm";
649 654
diff --git a/hosts/surtr/email/spm/default.nix b/hosts/surtr/email/spm/default.nix
deleted file mode 100644
index 75f99d8d..00000000
--- a/hosts/surtr/email/spm/default.nix
+++ /dev/null
@@ -1,24 +0,0 @@
1{ haskell, fetchFromGitHub }:
2
3let
4 # defaultPackages = (import ./stackage.nix {});
5 # haskellPackages = defaultPackages // argumentPackages;
6 # haskellPackages = argumentPackages;
7 haskellPackages = haskell.packages.ghc922.override {
8 overrides = self: super: {
9 warp-systemd = haskell.lib.doJailbreak (super.warp-systemd.overrideAttrs (oldAttrs: { meta = oldAttrs.meta // { broken = false; }; }));
10 servant-server = super.servant-server.overrideAttrs (oldAttrs: {
11 patches = [];
12 });
13 hpack = super.hpack.overrideAttrs (oldAttrs: rec {
14 version = "0.35.0";
15 src = fetchFromGitHub {
16 owner = "sol";
17 repo = "hpack";
18 rev = "0.35.0";
19 hash = "sha256-DMxCHwz9x2e4kSOIk1/qeW3aDFHw88LNW+4vXxDV9EI=";
20 };
21 });
22 };
23 };
24in haskellPackages.callPackage ./spm.nix {}
diff --git a/hosts/surtr/email/spm/lib/Data/CaseInsensitive/Instances.hs b/hosts/surtr/email/spm/lib/Data/CaseInsensitive/Instances.hs
deleted file mode 100644
index 56cba98a..00000000
--- a/hosts/surtr/email/spm/lib/Data/CaseInsensitive/Instances.hs
+++ /dev/null
@@ -1,19 +0,0 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2
3module Data.CaseInsensitive.Instances () where
4
5import Prelude
6
7import Data.CaseInsensitive (CI)
8import qualified Data.CaseInsensitive as CI
9
10import Servant.API.ContentTypes
11
12import Data.Aeson
13
14
15instance MimeRender PlainText a => MimeRender PlainText (CI a) where
16 mimeRender p = mimeRender p . CI.original
17
18instance ToJSON a => ToJSON (CI a) where
19 toJSON = toJSON . CI.original
diff --git a/hosts/surtr/email/spm/lib/Data/UUID/Instances.hs b/hosts/surtr/email/spm/lib/Data/UUID/Instances.hs
deleted file mode 100644
index 335937d8..00000000
--- a/hosts/surtr/email/spm/lib/Data/UUID/Instances.hs
+++ /dev/null
@@ -1,18 +0,0 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2
3module Data.UUID.Instances () where
4
5import Prelude
6import Data.UUID (UUID)
7import qualified Data.UUID as UUID
8import Servant.API.ContentTypes
9
10
11instance MimeRender PlainText UUID where
12 mimeRender p = mimeRender p . UUID.toText
13
14instance MimeRender JSON UUID where
15 mimeRender p = mimeRender p . UUID.toText
16
17instance MimeRender OctetStream UUID where
18 mimeRender p = mimeRender p . UUID.toByteString
diff --git a/hosts/surtr/email/spm/lib/Spm.hs b/hosts/surtr/email/spm/lib/Spm.hs
deleted file mode 100644
index c7f7dfe5..00000000
--- a/hosts/surtr/email/spm/lib/Spm.hs
+++ /dev/null
@@ -1,5 +0,0 @@
1module Spm
2 ( module Spm.Api
3 ) where
4
5import Spm.Api
diff --git a/hosts/surtr/email/spm/lib/Spm/Api.hs b/hosts/surtr/email/spm/lib/Spm/Api.hs
deleted file mode 100644
index d9644222..00000000
--- a/hosts/surtr/email/spm/lib/Spm/Api.hs
+++ /dev/null
@@ -1,40 +0,0 @@
1{-# LANGUAGE TemplateHaskell #-}
2
3module Spm.Api
4 ( SpmMailbox
5 , SpmApi, spmApi
6 ) where
7
8import Prelude
9
10import Servant.API
11
12import Data.Proxy (Proxy(..))
13
14import Data.Text (Text)
15
16import GHC.Generics (Generic)
17import Type.Reflection (Typeable)
18
19import Control.Lens.TH
20
21import Data.CaseInsensitive (CI)
22import Data.CaseInsensitive.Instances ()
23
24import Crypto.JOSE.JWK (JWKSet)
25
26import Data.UUID (UUID)
27import Data.UUID.Instances ()
28
29
30newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text }
31 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
32 deriving newtype (MimeRender JSON, MimeRender PlainText)
33makeWrapped ''SpmMailbox
34
35type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
36 :<|> ".well-known" :> "jwks.json" :> Get '[JSON] JWKSet
37 :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID
38
39spmApi :: Proxy SpmApi
40spmApi = Proxy
diff --git a/hosts/surtr/email/spm/package.yaml b/hosts/surtr/email/spm/package.yaml
deleted file mode 100644
index 4859e38c..00000000
--- a/hosts/surtr/email/spm/package.yaml
+++ /dev/null
@@ -1,92 +0,0 @@
1name: spm
2version: 0.1.0
3
4default-extensions:
5 - NoImplicitPrelude
6 - DerivingStrategies
7 - DeriveAnyClass
8 - DataKinds
9 - RecordWildCards
10 - TypeFamilies
11 - LambdaCase
12other-extensions:
13 - OverloadedStrings
14 - TemplateHaskell
15 - QuasiQuotes
16 - UndecidableInstances
17language: GHC2021
18license: AGPL-3.0-or-later
19ghc-options:
20 - -Wall
21 - -Wmissing-home-modules
22 - -Wredundant-constraints
23 - -Widentities
24 - -Wincomplete-uni-patterns
25 - -Werror
26 - -fwarn-tabs
27 - -j -O
28
29library:
30 dependencies:
31 - base
32 - servant
33 - text
34 - lens
35 - case-insensitive
36 - aeson
37 - jose
38 - uuid
39 source-dirs:
40 - lib
41
42executables:
43 spm-server:
44 dependencies:
45 - spm
46 - base
47 - servant-server
48 - warp-systemd
49 - warp
50 - attoparsec
51 - text
52 - bytestring
53 - wai
54 - wai-extra
55 - lens
56 - case-insensitive
57 - http-types
58 - persistent
59 - persistent-postgresql
60 - uuid
61 - path-pieces
62 - transformers
63 - mtl
64 - resource-pool
65 - monad-logger
66 - mmorph
67 - unliftio-core
68 - http-api-data
69 - exceptions
70 - aeson
71 - filepath
72 - jose
73
74 source-dirs:
75 - server
76
77 main: Spm.Server
78 spm-provision:
79 dependencies:
80 - base
81 - jose
82 - uuid
83 - optparse-applicative
84 - text
85 - aeson
86 - bytestring
87 - lens
88
89 source-dirs:
90 - provision
91
92 main: Spm.Provision
diff --git a/hosts/surtr/email/spm/provision/Spm/Provision.hs b/hosts/surtr/email/spm/provision/Spm/Provision.hs
deleted file mode 100644
index ff18baa0..00000000
--- a/hosts/surtr/email/spm/provision/Spm/Provision.hs
+++ /dev/null
@@ -1,46 +0,0 @@
1module Spm.Provision
2 ( main
3 ) where
4
5import Prelude
6import Options.Applicative
7import Control.Monad
8
9import qualified Data.Text.IO as Text
10
11import qualified Data.UUID as UUID
12import qualified Data.UUID.V4 as UUID
13
14import Crypto.JOSE.JWK
15
16import qualified Data.ByteString.Lazy.Char8 as CLBS
17import qualified Data.Aeson as JSON
18
19import Control.Lens
20
21
22data Command
23 = InstanceId
24 | JwkSet
25 deriving stock (Eq, Ord, Read, Show)
26
27cmdInstanceId :: IO ()
28cmdInstanceId = Text.putStrLn . UUID.toText =<< UUID.nextRandom
29
30cmdJwkSet :: IO ()
31cmdJwkSet = do
32 k' <- genJWK (OKPGenParam Ed25519)
33 kid <- UUID.nextRandom
34 let k = k' & jwkKid ?~ UUID.toText kid
35 & jwkUse ?~ Sig
36 & jwkKeyOps ?~ [Sign, Verify]
37 CLBS.putStrLn . JSON.encode . JWKSet $ pure k
38
39opts :: Parser (IO ())
40opts = subparser $
41 command "instance-id" (info (pure cmdInstanceId) idm)
42 <> command "jwk-set" (info (pure cmdJwkSet) idm)
43
44
45main :: IO ()
46main = join $ execParser (info opts idm)
diff --git a/hosts/surtr/email/spm/server/Crypto/JOSE/JWK/Instances.hs b/hosts/surtr/email/spm/server/Crypto/JOSE/JWK/Instances.hs
deleted file mode 100644
index 44a5cfe0..00000000
--- a/hosts/surtr/email/spm/server/Crypto/JOSE/JWK/Instances.hs
+++ /dev/null
@@ -1,9 +0,0 @@
1{-# LANGUAGE TemplateHaskell #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3
4module Crypto.JOSE.JWK.Instances () where
5
6import Control.Lens.TH
7import Crypto.JOSE.JWK
8
9makeWrapped ''JWKSet
diff --git a/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs b/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs
deleted file mode 100644
index 1f3f7a11..00000000
--- a/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs
+++ /dev/null
@@ -1,30 +0,0 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE OverloadedStrings #-}
3
4module Data.CaseInsensitive.Instances () where
5
6import Prelude
7import Database.Persist
8import Database.Persist.Sql
9
10import Data.CaseInsensitive (CI)
11import qualified Data.CaseInsensitive as CI
12
13import Data.Text (Text)
14import qualified Data.Text as Text
15import qualified Data.Text.Encoding as Text
16
17import Control.Exception
18
19
20instance PersistField (CI Text) where
21 toPersistValue = PersistLiteralEscaped . Text.encodeUtf8 . CI.original
22 fromPersistValue = \case
23 PersistText t -> Right $ CI.mk t
24 PersistLiteralEscaped bs -> case Text.decodeUtf8' bs of
25 Right t -> Right $ CI.mk t
26 Left err -> Left $ "Could not decode PersistLiteral as UTF-8: " <> Text.pack (displayException err)
27 o -> Left $ "Expected PersistText or PersistLiteral but got ‘" <> Text.pack (show o) <> "’"
28
29instance PersistFieldSql (CI Text) where
30 sqlType _ = SqlOther "citext"
diff --git a/hosts/surtr/email/spm/server/Data/UUID/Instances.hs b/hosts/surtr/email/spm/server/Data/UUID/Instances.hs
deleted file mode 100644
index b2268c96..00000000
--- a/hosts/surtr/email/spm/server/Data/UUID/Instances.hs
+++ /dev/null
@@ -1,31 +0,0 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE OverloadedStrings #-}
3
4module Data.UUID.Instances () where
5
6import Prelude
7import Database.Persist
8import Database.Persist.Sql
9import Data.UUID (UUID)
10import qualified Data.UUID as UUID
11
12import qualified Data.ByteString.Char8 as CBS
13import qualified Data.Text as Text
14
15import Web.PathPieces
16
17
18instance PersistField UUID where
19 toPersistValue = PersistLiteralEscaped . CBS.pack . UUID.toString
20 fromPersistValue (PersistLiteralEscaped uuidB8) =
21 case UUID.fromString $ CBS.unpack uuidB8 of
22 Just uuid -> Right uuid
23 Nothing -> Left "Invalid UUID"
24 fromPersistValue v = Left $ "Expected PersistLiteral but got ‘" <> Text.pack (show v) <> "’"
25
26instance PersistFieldSql UUID where
27 sqlType _ = SqlOther "uuid"
28
29instance PathPiece UUID where
30 toPathPiece = Text.pack . UUID.toString
31 fromPathPiece = UUID.fromString . Text.unpack
diff --git a/hosts/surtr/email/spm/server/Spm/Server.hs b/hosts/surtr/email/spm/server/Spm/Server.hs
deleted file mode 100644
index 7690f51a..00000000
--- a/hosts/surtr/email/spm/server/Spm/Server.hs
+++ /dev/null
@@ -1,194 +0,0 @@
1{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
2
3module Spm.Server
4 ( main
5 ) where
6
7import Prelude
8import Spm.Api
9import Servant
10import Servant.Server.Experimental.Auth
11
12import Network.Wai
13import Network.Wai.Handler.Warp
14import Network.Wai.Handler.Warp.Systemd
15import Network.Wai.Middleware.RequestLogger
16
17import Network.HTTP.Types
18
19import Data.Text (Text)
20import qualified Data.Text as Text
21import qualified Data.Text.Encoding as Text
22import Data.Attoparsec.Text
23
24import qualified Data.ByteString.Lazy as LBS
25
26import GHC.Generics (Generic)
27import Type.Reflection (Typeable)
28
29import Control.Applicative
30import Control.Monad
31import Control.Arrow
32import Control.Monad.IO.Class
33import Control.Monad.IO.Unlift
34
35import Control.Lens hiding (Context)
36
37import qualified Data.CaseInsensitive as CI
38
39import System.IO
40
41import Spm.Server.Database
42
43import Database.Persist
44import Database.Persist.Postgresql
45import Data.Pool
46
47import Control.Monad.Trans.Reader (ReaderT, runReaderT)
48
49import Control.Monad.Logger
50
51import Control.Monad.Morph
52
53import System.Environment
54
55import Control.Monad.Catch (Exception, MonadThrow(..))
56
57import Data.UUID (UUID)
58import qualified Data.UUID as UUID
59
60import qualified Data.Aeson as JSON
61
62import System.FilePath ((</>), isRelative)
63
64import Crypto.JOSE.JWK hiding (Context)
65import Crypto.JOSE.JWK.Instances ()
66
67import Data.Maybe
68
69
70hSslClientVerify, hSslClientSDn :: HeaderName
71hSslClientVerify = "SSL-Client-Verify"
72hSslClientSDn = "SSL-Client-S-DN"
73
74
75data SSLClientVerify
76 = SSLClientVerifySuccess
77 | SSLClientVerifyOther Text
78 deriving (Eq, Ord, Read, Show, Generic, Typeable)
79instance FromHttpApiData SSLClientVerify where
80 parseUrlPiece = (left Text.pack .) . parseOnly $ p <* endOfInput
81 where
82 p :: Parser SSLClientVerify
83 p = (SSLClientVerifySuccess <$ asciiCI "success")
84 <|> (SSLClientVerifyOther <$> takeText)
85
86type instance AuthServerData (AuthProtect "spm_mailbox") = MailMailbox
87
88type SpmServerApi = Header' '[Required, Strict] "SPM-Domain" MailDomain
89 :> AuthProtect "spm_mailbox"
90 :> SpmApi
91
92spmServerApi :: Proxy SpmServerApi
93spmServerApi = Proxy
94
95
96requestMailMailbox :: Request -> Either Text MailMailbox
97requestMailMailbox req = do
98 clientVerify <- getHeader hSslClientVerify
99 clientSDN <- getHeader hSslClientSDn
100
101 case clientVerify of
102 SSLClientVerifySuccess -> return ()
103 o@(SSLClientVerifyOther _) -> Left $ "Expected “SSLClientVerifySuccess”, but got “" <> Text.pack (show o) <> "”"
104 spmMailbox <- left Text.pack $ parseOnly (asciiCI "CN=" *> (CI.mk <$> takeText) <* endOfInput) clientSDN
105
106 return $ _Wrapped # spmMailbox
107 where
108 getHeader :: forall a. FromHttpApiData a => HeaderName -> Either Text a
109 getHeader hdrName = parseHeader <=< maybeToEither ("Missing “" <> Text.decodeUtf8 (CI.original hdrName) <> "”") . lookup hdrName $ requestHeaders req
110
111 maybeToEither e = maybe (Left e) Right
112
113mailboxAuthHandler :: AuthHandler Request MailMailbox
114mailboxAuthHandler = mkAuthHandler handler
115 where
116 throw401 msg = throwError $ err401 { errBody = LBS.fromStrict $ Text.encodeUtf8 msg }
117 handler = either throw401 return . requestMailMailbox
118
119mkSpmRequestLogger :: MonadIO m => m Middleware
120mkSpmRequestLogger = liftIO $ mkRequestLogger loggerSettings
121 where
122 loggerSettings = defaultRequestLoggerSettings
123 { destination = Handle stderr
124 , outputFormat = ApacheWithSettings $ defaultApacheSettings
125 & setApacheUserGetter (preview (_Right . _Wrapped . to (Text.encodeUtf8. CI.original)) . requestMailMailbox)
126 & setApacheIPAddrSource FromFallback
127 }
128
129data ServerCtx = ServerCtx
130 { _sctxSqlPool :: Pool SqlBackend
131 , _sctxInstanceId :: UUID
132 , _sctxJwkSet :: JWKSet
133 } deriving (Generic, Typeable)
134makeLenses ''ServerCtx
135
136type Handler' = ReaderT ServerCtx (LoggingT Handler)
137type Server' api = ServerT api Handler'
138
139data ServerCtxError
140 = ServerCtxNoInstanceId | ServerCtxInvalidInstanceId
141 | ServerCtxJwkSetCredentialFileNotRelative
142 | ServerCtxNoCredentialsDirectory
143 | ServerCtxJwkSetDecodeError String
144 | ServerCtxJwkSetEmpty
145 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
146 deriving anyclass (Exception)
147
148mkSpmApp :: (MonadUnliftIO m, MonadThrow m) => m Application
149mkSpmApp = do
150 requestLogger <- mkSpmRequestLogger
151
152 connStr <- liftIO $ maybe mempty (Text.encodeUtf8 . Text.pack) <$> lookupEnv "PGCONNSTR"
153 _sctxInstanceId <- maybe (throwM ServerCtxInvalidInstanceId) return . UUID.fromString =<< maybe (throwM ServerCtxNoInstanceId) return =<< liftIO (lookupEnv "SPM_INSTANCE")
154 jwksetCredentialFile <- liftIO $ fromMaybe "spm-keys.json" <$> lookupEnv "SPM_KEYS_CREDENTIAL"
155 unless (isRelative jwksetCredentialFile) $ throwM ServerCtxJwkSetCredentialFileNotRelative
156 credentialsDir <- maybe (throwM ServerCtxNoCredentialsDirectory) return =<< liftIO (lookupEnv "CREDENTIALS_DIRECTORY")
157 _sctxJwkSet@(JWKSet jwks) <- either (throwM . ServerCtxJwkSetDecodeError) return =<< liftIO (JSON.eitherDecodeFileStrict' $ credentialsDir </> jwksetCredentialFile)
158 when (null jwks) $ throwM ServerCtxJwkSetEmpty
159
160 runStderrLoggingT . withPostgresqlPool connStr 1 $ \_sctxSqlPool -> do
161 let
162 spmServerContext :: Context (AuthHandler Request MailMailbox ': '[])
163 spmServerContext = mailboxAuthHandler :. EmptyContext
164
165 spmServer' = spmServer
166
167 logger <- askLoggerIO
168 return $ serveWithContextT spmServerApi spmServerContext ((runReaderT ?? ServerCtx{..}) . hoist (runLoggingT ?? logger)) spmServer'
169 & requestLogger
170
171spmSql :: ReaderT SqlBackend Handler' a -> Handler' a
172spmSql act = do
173 sqlPool <- view sctxSqlPool
174 withResource sqlPool $ runReaderT act
175
176spmServer :: MailDomain -> MailMailbox -> Server' SpmApi
177spmServer _dom mbox = whoami
178 :<|> jwkSet
179 :<|> instanceId
180 where
181 whoami = do
182 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
183 return $ mailboxIdent ^. _Wrapped . re _Wrapped
184
185 jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just)
186
187 instanceId = view sctxInstanceId
188
189main :: IO ()
190main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
191 where
192 systemdSettings = defaultSystemdSettings
193 & requireSocketActivation .~ True
194 warpSettings = defaultSettings
diff --git a/hosts/surtr/email/spm/server/Spm/Server/Database.hs b/hosts/surtr/email/spm/server/Spm/Server/Database.hs
deleted file mode 100644
index 09b4c67b..00000000
--- a/hosts/surtr/email/spm/server/Spm/Server/Database.hs
+++ /dev/null
@@ -1,72 +0,0 @@
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|]
diff --git a/hosts/surtr/email/spm/spm.nix b/hosts/surtr/email/spm/spm.nix
deleted file mode 100644
index ba7a5f0b..00000000
--- a/hosts/surtr/email/spm/spm.nix
+++ /dev/null
@@ -1,28 +0,0 @@
1{ mkDerivation, aeson, attoparsec, base, bytestring
2, case-insensitive, exceptions, filepath, hpack, http-api-data
3, http-types, jose, lens, lib, mmorph, monad-logger, mtl
4, optparse-applicative, path-pieces, persistent
5, persistent-postgresql, resource-pool, servant, servant-server
6, text, transformers, unliftio-core, uuid, wai, wai-extra, warp
7, warp-systemd
8}:
9mkDerivation {
10 pname = "spm";
11 version = "0.1.0";
12 src = ./.;
13 isLibrary = true;
14 isExecutable = true;
15 libraryHaskellDepends = [
16 aeson base case-insensitive jose lens servant text
17 ];
18 libraryToolDepends = [ hpack ];
19 executableHaskellDepends = [
20 aeson attoparsec base bytestring case-insensitive exceptions
21 filepath http-api-data http-types jose lens mmorph monad-logger mtl
22 optparse-applicative path-pieces persistent persistent-postgresql
23 resource-pool servant-server text transformers unliftio-core uuid
24 wai wai-extra warp warp-systemd
25 ];
26 prePatch = "hpack";
27 license = lib.licenses.agpl3Plus;
28}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-16 07:06:19 +0000