surtr: ...

22 files changed, 769 insertions, 37 deletions

diff --git a/hosts/sif/ruleset.nft b/hosts/sif/ruleset.nft
index c453cc7b..363ffbdc 100644
--- a/hosts/sif/ruleset.nft
+++ b/hosts/sif/ruleset.nft
@@ -118,7 +118,7 @@ table inet filter {
     meta l4proto $icmp_protos counter name icmp-rx accept
 
     tcp dport 22 counter name ssh-rx accept
-    udp dport 60001-61000 counter name mosh-rx accept
+    udp dport 60000-61000 counter name mosh-rx accept
 
     tcp dport 8000 counter name quickserve-rx accept
 
@@ -146,7 +146,7 @@ table inet filter {
 
 
     tcp sport 22 counter name ssh-tx
-    udp sport 60001-61000 counter name mosh-tx
+    udp sport 60000-61000 counter name mosh-tx
 
     udp sport 51820-51822 counter name wg-tx
     iifname "yggdrasil-wg-*" meta l4proto gre counter name yggdrasil-gre-tx
diff --git a/hosts/surtr/default.nix b/hosts/surtr/default.nix
index ff93e0e5..c9ecc945 100644
--- a/hosts/surtr/default.nix
+++ b/hosts/surtr/default.nix
@@ -71,12 +71,13 @@
     systemd.network.networks."40-ens3".networkConfig = {
       Domains = lib.mkForce "~.";
       DNS = [ "127.0.0.1:5353" "[::1]:5353" ];
-      DNSSEC = true;
+      # DNSSEC = true;
       # DNS = [ "46.38.225.230" "46.38.252.230" "2a03:4000:0:1::e1e6" "2a03:4000:8000::fce6" ];
     };
 
     services.resolved = {
       llmnr = "false";
+      dnssec = "false"; # unbound does dnssec validation for us
     };
 
     services.ndppd = {
diff --git a/hosts/surtr/email/ca/index.txt b/hosts/surtr/email/ca/index.txt
index 711193b2..40c9605a 100644
--- a/hosts/surtr/email/ca/index.txt
+++ b/hosts/surtr/email/ca/index.txt
@@ -1 +1,2 @@
-V       320502142416Z           02      unknown /CN=gkleen
+V       320513204402Z           03      unknown /CN=gkleen
+V       320515063648Z           04      unknown /CN=nmuehlbauer
diff --git a/hosts/surtr/email/ca/serial b/hosts/surtr/email/ca/serial
index 75016ea3..eeee65ec 100644
--- a/hosts/surtr/email/ca/serial
+++ b/hosts/surtr/email/ca/serial
@@ -1 +1 @@
-03
+05
diff --git a/hosts/surtr/email/default.nix b/hosts/surtr/email/default.nix
index 404e9e4b..947aa328 100644
--- a/hosts/surtr/email/default.nix
+++ b/hosts/surtr/email/default.nix
@@ -21,6 +21,8 @@ let
   };
 
   spmDomains = ["bouncy.email"];
+
+  spm = pkgs.callPackage ./spm {};
 in {
   config = {
     nixpkgs.overlays = [
@@ -115,6 +117,8 @@ in {
           "reject_unknown_recipient_domain"
           "reject_unverified_recipient"
         ];
+        unverified_recipient_reject_code = "550";
+        unverified_recipient_reject_reason = "Recipient address rejected: undeliverable address";
 
         smtpd_relay_restrictions = [
           "permit_mynetworks"
@@ -177,6 +181,9 @@ in {
             "-o" "smtpd_tls_req_ccert=yes"
             "-o" "smtpd_client_restrictions=permit_tls_all_clientcerts,reject"
             "-o" "smtpd_relay_restrictions=permit_tls_all_clientcerts,reject"
+            "-o" "smtpd_sender_restrictions=reject_unknown_sender_domain,reject_unverified_sender"
+            "-o" "unverified_sender_reject_code=550"
+            "-o" "unverified_sender_reject_reason={Sender address rejected: undeliverable address}"
             "-o" "smtpd_recipient_restrictions=reject_unauth_pipelining,reject_non_fqdn_recipient,reject_unknown_recipient_domain,permit_tls_all_clientcerts,reject"
             "-o" "milter_macro_daemon_name=surtr.yggdrasil.li"
             "-o" ''smtpd_milters=${config.services.opendkim.socket}''
@@ -600,24 +607,79 @@ in {
       };
     };
 
-    services.nginx.virtualHosts = listToAttrs (map (domain: nameValuePair "spm.${domain}" {
-      forceSSL = true;
-      sslCertificate = "/run/credentials/nginx.service/spm.${domain}.pem";
-      sslCertificateKey = "/run/credentials/nginx.service/spm.${domain}.key.pem";
-      extraConfig = ''
-        ssl_stapling off;
-        ssl_verify_client on;
-        ssl_client_certificate ${toString ./ca/ca.crt};
-      '';
-      locations."/".extraConfig = ''
-        default_type text/plain;
-        return 200 "$ssl_client_verify $ssl_client_s_dn ${domain}";
-      '';
-    }) spmDomains);
+    services.nginx = {
+      upstreams.spm = {
+        servers = {
+          "unix:/run/spm/server.sock" = {};
+        };
+      };
+
+      virtualHosts = listToAttrs (map (domain: nameValuePair "spm.${domain}" {
+        forceSSL = true;
+        sslCertificate = "/run/credentials/nginx.service/spm.${domain}.pem";
+        sslCertificateKey = "/run/credentials/nginx.service/spm.${domain}.key.pem";
+        extraConfig = ''
+          ssl_stapling off;
+          ssl_verify_client on;
+          ssl_client_certificate ${toString ./ca/ca.crt};
+        '';
+        locations."/" = {
+          proxyPass = "http://spm";
+
+          extraConfig = ''
+            proxy_set_header SSL-CLIENT-VERIFY $ssl_client_verify;
+            proxy_set_header SSL-CLIENT-S-DN $ssl_client_s_dn;
+            proxy_set_header SPM-DOMAIN "${domain}";
+          '';
+        };
+      }) spmDomains);
+    };
 
     systemd.services.nginx.serviceConfig.LoadCredential = concatMap (domain: [
       "spm.${domain}.key.pem:${config.security.acme.certs."spm.${domain}".directory}/key.pem"
       "spm.${domain}.pem:${config.security.acme.certs."spm.${domain}".directory}/fullchain.pem"
     ]) spmDomains;
+
+    systemd.services.spm = {
+      serviceConfig = {
+        Type = "notify";
+        ExecStart = "${spm}/bin/spm-server";
+        User = "spm";
+        Group = "spm";
+
+        Environment = [
+          "SPM_INSTANCE=ed1c0e1d-7be4-4dd5-b51a-291bad3ac9c9"
+          "PGCONNSTR=dbname=email"
+        ];
+
+        LoadCredential = [
+          "spm-keys.json:${config.sops.secrets."spm-keys.json".path}"
+        ];
+      };
+    };
+    systemd.sockets.spm = {
+      wantedBy = [ "nginx.service" ];
+      
+      socketConfig = {
+        ListenStream = "/run/spm/server.sock";
+        SocketUser = "spm";
+        SocketGroup = "spm";
+        SocketMode = 0660;
+      };
+    };
+
+    users.users.spm = {
+      isSystemUser = true;
+      group = "spm";
+    };
+
+    users.groups.spm = {
+      members = [ config.services.nginx.user ];
+    };
+
+    sops.secrets."spm-keys.json" = {
+      format = "binary";
+      sopsFile = ./spm-keys.json;
+    };
   };
 }
diff --git a/hosts/surtr/email/spm-keys.json b/hosts/surtr/email/spm-keys.json
new file mode 100644
index 00000000..cefe27b1
--- /dev/null
+++ b/hosts/surtr/email/spm-keys.json
@@ -0,0 +1,26 @@
+{
+        "data": "ENC[AES256_GCM,data:CC4g1CDj61PeSk9w9OAiKaQkkXS51H+IcodzsZLYTNfLgAkqbuRSLpE7g2Km7vUb5L0/Yb8Ew1C+JMN3AKudJf3YOJRr1A8M1z3hTJVzW4qSEkj3aPIek3DuqE2Wl8KrDNxyQUylPRFkwMCmcAySlLCmztCU4qu/ZdcCg0O1EE9E0AdxhbKtBZXQUX6KrTyRLLek7h1prfre6w8Gi+3Y8N5yMmFBF8XEcC6xOWglVMOR1eBQlS9iPu4rhFbWqM6YQ7ptI08xZcpCyM4sz+S3fqf0Nysm+19KBzw8g3JikQzqnA==,iv:gNH2tGj8VRxCAJgYuFcrznP7/K4tpwD09Wg/o7McpyE=,tag:Bh3JTL1MkKwLG0d120nnig==,type:str]",
+        "sops": {
+                "kms": null,
+                "gcp_kms": null,
+                "azure_kv": null,
+                "hc_vault": null,
+                "age": null,
+                "lastmodified": "2022-05-19T18:42:23Z",
+                "mac": "ENC[AES256_GCM,data:dQAeiVPBGotOd3dnD9P3o1dlDIrOom369SAlzY9VHe4y/Bck8brrx4fUjjxfFB9/Oew83Pdpl1WXbVp6RVrsdY/xTmVD+1bgZJJRJ5KYe0QcoWl4Sv1E6Y1b5jKZVYbeiCU7NI6gITmM5sLNBzEm2WYsYBtRCxWMh3iGV7ZqmAk=,iv:loxamarLwR6NCHaH/K8tq8XQj7Xl+Onbgu3hEYZycKQ=,tag:WojOpPzi/ajmzBAKKJ7g1Q==,type:str]",
+                "pgp": [
+                        {
+                                "created_at": "2022-05-19T18:42:23Z",
+                                "enc": "-----BEGIN PGP MESSAGE-----\n\nhF4DXxoViZlp6dISAQdAy74slNS/OZAJ2BczfZtCWNdIfrCpT9qg3K17zaam930w\nWRVJeL/4JLyaCvDybqNjyoi7TkCxMtKNu5LzWv+c7iTQgAwyH/aRdaLx4HmEnwqW\n0l4BsKAIB+GNBAO/HUrjrxc16euyNPP0zbguiEUxhzNGb3xwngixbcDBIe8d4yXa\nHQ+mhjG35wQbjcPrQFUvZ5YWkwthL3pY1Jx8l/9V8ajTC3SbHlI2akbun6EMuoZo\n=LKNF\n-----END PGP MESSAGE-----\n",
+                                "fp": "30D3453B8CD02FE2A3E7C78C0FB536FB87AE8F51"
+                        },
+                        {
+                                "created_at": "2022-05-19T18:42:23Z",
+                                "enc": "-----BEGIN PGP MESSAGE-----\n\nhF4DyFKFNkTVG5oSAQdAT8dopGD88h4G6EBdFbDWizpUreWer6d7U+ii48YYe2Aw\nh8NZe+WplrMmjIWalVylf/MqQKlAwbOZBj5PpFIxFXKvtRxGGYKZ7mBj7kkFaDKG\n0l4BkYVQRhouZdVFcpTtTPlG7ATVpJQAi8UiBuO0HhQBmxQUGLl5vM9bvb9cY5mH\nBnBOWYzff/f0Jl8gn3tGMr9Sxeg7VRcCm+YGMPMQSimKbEZnXUjGEYuflXzopY09\n=6n0A\n-----END PGP MESSAGE-----\n",
+                                "fp": "7ED22F4AA7BB55728B643DC5471B7D88E4EF66F8"
+                        }
+                ],
+                "unencrypted_suffix": "_unencrypted",
+                "version": "3.7.2"
+        }
+}
\ No newline at end of file
diff --git a/hosts/surtr/email/spm/default.nix b/hosts/surtr/email/spm/default.nix
new file mode 100644
index 00000000..75f99d8d
--- /dev/null
+++ b/hosts/surtr/email/spm/default.nix
@@ -0,0 +1,24 @@
+{ haskell, fetchFromGitHub }:
+
+let
+  # defaultPackages = (import ./stackage.nix {});
+  # haskellPackages = defaultPackages // argumentPackages;
+  # haskellPackages = argumentPackages;
+  haskellPackages = haskell.packages.ghc922.override {
+    overrides = self: super: {
+       warp-systemd = haskell.lib.doJailbreak (super.warp-systemd.overrideAttrs (oldAttrs: { meta = oldAttrs.meta // { broken = false; }; })); 
+       servant-server = super.servant-server.overrideAttrs (oldAttrs: {
+         patches = [];
+       });
+       hpack = super.hpack.overrideAttrs (oldAttrs: rec {
+         version = "0.35.0";
+         src = fetchFromGitHub {
+           owner = "sol";
+           repo = "hpack";
+           rev = "0.35.0";
+           hash = "sha256-DMxCHwz9x2e4kSOIk1/qeW3aDFHw88LNW+4vXxDV9EI=";
+         };
+       });
+    };
+  };
+in 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
new file mode 100644
index 00000000..56cba98a
--- /dev/null
+++ b/hosts/surtr/email/spm/lib/Data/CaseInsensitive/Instances.hs
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.CaseInsensitive.Instances () where
+
+import Prelude
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Servant.API.ContentTypes
+
+import Data.Aeson
+
+
+instance MimeRender PlainText a => MimeRender PlainText (CI a) where
+  mimeRender p = mimeRender p . CI.original
+
+instance ToJSON a => ToJSON (CI a) where
+  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
new file mode 100644
index 00000000..335937d8
--- /dev/null
+++ b/hosts/surtr/email/spm/lib/Data/UUID/Instances.hs
@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.UUID.Instances () where
+
+import Prelude
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import Servant.API.ContentTypes
+
+
+instance MimeRender PlainText UUID where
+  mimeRender p = mimeRender p . UUID.toText
+
+instance MimeRender JSON UUID where
+  mimeRender p = mimeRender p . UUID.toText
+
+instance MimeRender OctetStream UUID where
+  mimeRender p = mimeRender p . UUID.toByteString
diff --git a/hosts/surtr/email/spm/lib/Spm.hs b/hosts/surtr/email/spm/lib/Spm.hs
new file mode 100644
index 00000000..c7f7dfe5
--- /dev/null
+++ b/hosts/surtr/email/spm/lib/Spm.hs
@@ -0,0 +1,5 @@
+module Spm
+  ( module Spm.Api
+  ) where
+
+import Spm.Api
diff --git a/hosts/surtr/email/spm/lib/Spm/Api.hs b/hosts/surtr/email/spm/lib/Spm/Api.hs
new file mode 100644
index 00000000..d9644222
--- /dev/null
+++ b/hosts/surtr/email/spm/lib/Spm/Api.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Spm.Api
+  ( SpmMailbox
+  , SpmApi, spmApi
+  ) where
+
+import Prelude
+
+import Servant.API
+
+import Data.Proxy (Proxy(..))
+
+import Data.Text (Text)
+
+import GHC.Generics (Generic)
+import Type.Reflection (Typeable)
+
+import Control.Lens.TH
+
+import Data.CaseInsensitive (CI)
+import Data.CaseInsensitive.Instances ()
+
+import Crypto.JOSE.JWK (JWKSet)
+
+import Data.UUID (UUID)
+import Data.UUID.Instances ()
+
+
+newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text }
+  deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (MimeRender JSON, MimeRender PlainText)
+makeWrapped ''SpmMailbox
+
+type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
+         :<|> ".well-known" :> "jwks.json" :> Get '[JSON] JWKSet
+         :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID
+
+spmApi :: Proxy SpmApi
+spmApi = Proxy
diff --git a/hosts/surtr/email/spm/package.yaml b/hosts/surtr/email/spm/package.yaml
new file mode 100644
index 00000000..4859e38c
--- /dev/null
+++ b/hosts/surtr/email/spm/package.yaml
@@ -0,0 +1,92 @@
+name: spm
+version: 0.1.0
+
+default-extensions:
+  - NoImplicitPrelude
+  - DerivingStrategies
+  - DeriveAnyClass
+  - DataKinds
+  - RecordWildCards
+  - TypeFamilies
+  - LambdaCase
+other-extensions:
+  - OverloadedStrings
+  - TemplateHaskell
+  - QuasiQuotes
+  - UndecidableInstances
+language: GHC2021
+license: AGPL-3.0-or-later
+ghc-options:
+  - -Wall
+  - -Wmissing-home-modules
+  - -Wredundant-constraints
+  - -Widentities
+  - -Wincomplete-uni-patterns
+  - -Werror
+  - -fwarn-tabs
+  - -j -O
+
+library:
+  dependencies:
+    - base
+    - servant
+    - text
+    - lens
+    - case-insensitive
+    - aeson
+    - jose
+    - uuid
+  source-dirs:
+    - lib
+
+executables:
+  spm-server:
+    dependencies:
+      - spm
+      - base
+      - servant-server
+      - warp-systemd
+      - warp
+      - attoparsec
+      - text
+      - bytestring
+      - wai
+      - wai-extra
+      - lens
+      - case-insensitive
+      - http-types
+      - persistent
+      - persistent-postgresql
+      - uuid
+      - path-pieces
+      - transformers
+      - mtl
+      - resource-pool
+      - monad-logger
+      - mmorph
+      - unliftio-core
+      - http-api-data
+      - exceptions
+      - aeson
+      - filepath
+      - jose
+
+    source-dirs:
+      - server
+
+    main: Spm.Server
+  spm-provision:
+    dependencies:
+      - base
+      - jose
+      - uuid
+      - optparse-applicative
+      - text
+      - aeson
+      - bytestring
+      - lens
+
+    source-dirs:
+      - provision
+
+    main: Spm.Provision
diff --git a/hosts/surtr/email/spm/provision/Spm/Provision.hs b/hosts/surtr/email/spm/provision/Spm/Provision.hs
new file mode 100644
index 00000000..ff18baa0
--- /dev/null
+++ b/hosts/surtr/email/spm/provision/Spm/Provision.hs
@@ -0,0 +1,46 @@
+module Spm.Provision
+  ( main
+  ) where
+
+import Prelude
+import Options.Applicative
+import Control.Monad
+
+import qualified Data.Text.IO as Text
+
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+
+import Crypto.JOSE.JWK
+
+import qualified Data.ByteString.Lazy.Char8 as CLBS
+import qualified Data.Aeson as JSON
+
+import Control.Lens
+
+
+data Command
+  = InstanceId
+  | JwkSet
+  deriving stock (Eq, Ord, Read, Show)
+
+cmdInstanceId :: IO ()
+cmdInstanceId = Text.putStrLn . UUID.toText =<< UUID.nextRandom
+
+cmdJwkSet :: IO ()
+cmdJwkSet = do
+  k' <- genJWK (OKPGenParam Ed25519)
+  kid <- UUID.nextRandom
+  let k = k' & jwkKid ?~ UUID.toText kid
+             & jwkUse ?~ Sig
+             & jwkKeyOps ?~ [Sign, Verify]
+  CLBS.putStrLn . JSON.encode . JWKSet $ pure k
+
+opts :: Parser (IO ())
+opts = subparser $
+     command "instance-id" (info (pure cmdInstanceId) idm)
+  <> command "jwk-set" (info (pure cmdJwkSet) idm)
+
+  
+main :: IO ()
+main = 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
new file mode 100644
index 00000000..44a5cfe0
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Crypto/JOSE/JWK/Instances.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Crypto.JOSE.JWK.Instances () where
+
+import Control.Lens.TH
+import Crypto.JOSE.JWK
+
+makeWrapped ''JWKSet
diff --git a/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs b/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs
new file mode 100644
index 00000000..1f3f7a11
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs
@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.CaseInsensitive.Instances () where
+
+import Prelude
+import Database.Persist
+import Database.Persist.Sql
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+
+import Control.Exception
+
+
+instance PersistField (CI Text) where
+  toPersistValue = PersistLiteralEscaped . Text.encodeUtf8 . CI.original
+  fromPersistValue = \case
+    PersistText t -> Right $ CI.mk t
+    PersistLiteralEscaped bs -> case Text.decodeUtf8' bs of
+      Right t   -> Right $ CI.mk t
+      Left  err -> Left $ "Could not decode PersistLiteral as UTF-8: " <> Text.pack (displayException err)
+    o -> Left $ "Expected PersistText or PersistLiteral but got ‘" <> Text.pack (show o) <> "’"
+
+instance PersistFieldSql (CI Text) where
+  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
new file mode 100644
index 00000000..b2268c96
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Data/UUID/Instances.hs
@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.UUID.Instances () where
+
+import Prelude
+import Database.Persist
+import Database.Persist.Sql
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+
+import qualified Data.ByteString.Char8 as CBS
+import qualified Data.Text as Text
+
+import Web.PathPieces
+  
+
+instance PersistField UUID where
+  toPersistValue = PersistLiteralEscaped . CBS.pack . UUID.toString
+  fromPersistValue (PersistLiteralEscaped uuidB8) =
+    case UUID.fromString $ CBS.unpack uuidB8 of
+      Just uuid -> Right uuid
+      Nothing   -> Left "Invalid UUID"
+  fromPersistValue v = Left $ "Expected PersistLiteral but got ‘" <> Text.pack (show v) <> "’"
+
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"
+
+instance PathPiece UUID where
+  toPathPiece = Text.pack . UUID.toString
+  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
new file mode 100644
index 00000000..7690f51a
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Spm/Server.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
+
+module Spm.Server
+  ( main
+  ) where
+
+import Prelude
+import Spm.Api
+import Servant
+import Servant.Server.Experimental.Auth
+
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.Wai.Handler.Warp.Systemd
+import Network.Wai.Middleware.RequestLogger
+
+import Network.HTTP.Types
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.Attoparsec.Text
+
+import qualified Data.ByteString.Lazy as LBS
+
+import GHC.Generics (Generic)
+import Type.Reflection (Typeable)
+
+import Control.Applicative
+import Control.Monad
+import Control.Arrow
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
+
+import Control.Lens hiding (Context)
+
+import qualified Data.CaseInsensitive as CI
+
+import System.IO
+
+import Spm.Server.Database
+
+import Database.Persist
+import Database.Persist.Postgresql
+import Data.Pool
+
+import Control.Monad.Trans.Reader (ReaderT, runReaderT)
+
+import Control.Monad.Logger
+
+import Control.Monad.Morph
+
+import System.Environment
+
+import Control.Monad.Catch (Exception, MonadThrow(..))
+
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+
+import qualified Data.Aeson as JSON
+
+import System.FilePath ((</>), isRelative)
+
+import Crypto.JOSE.JWK hiding (Context)
+import Crypto.JOSE.JWK.Instances ()
+
+import Data.Maybe
+
+
+hSslClientVerify, hSslClientSDn :: HeaderName
+hSslClientVerify = "SSL-Client-Verify"
+hSslClientSDn = "SSL-Client-S-DN"
+
+
+data SSLClientVerify
+  = SSLClientVerifySuccess
+  | SSLClientVerifyOther Text
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+instance FromHttpApiData SSLClientVerify where
+  parseUrlPiece = (left Text.pack .) . parseOnly $ p <* endOfInput
+    where
+      p :: Parser SSLClientVerify
+      p =   (SSLClientVerifySuccess <$ asciiCI "success")
+        <|> (SSLClientVerifyOther <$> takeText)
+
+type instance AuthServerData (AuthProtect "spm_mailbox") = MailMailbox
+
+type SpmServerApi =    Header' '[Required, Strict] "SPM-Domain" MailDomain
+                    :> AuthProtect "spm_mailbox"
+                    :> SpmApi
+
+spmServerApi :: Proxy SpmServerApi
+spmServerApi = Proxy
+  
+  
+requestMailMailbox :: Request -> Either Text MailMailbox
+requestMailMailbox req = do
+    clientVerify <- getHeader hSslClientVerify
+    clientSDN <- getHeader hSslClientSDn
+
+    case clientVerify of
+      SSLClientVerifySuccess -> return ()
+      o@(SSLClientVerifyOther _) -> Left $ "Expected “SSLClientVerifySuccess”, but got “" <> Text.pack (show o) <> "”"
+    spmMailbox <- left Text.pack $ parseOnly (asciiCI "CN=" *> (CI.mk <$> takeText) <* endOfInput) clientSDN
+
+    return $ _Wrapped # spmMailbox
+  where 
+    getHeader :: forall a. FromHttpApiData a => HeaderName -> Either Text a
+    getHeader hdrName = parseHeader <=< maybeToEither ("Missing “" <> Text.decodeUtf8 (CI.original hdrName) <> "”") . lookup hdrName $ requestHeaders req
+
+    maybeToEither e = maybe (Left e) Right
+
+mailboxAuthHandler :: AuthHandler Request MailMailbox
+mailboxAuthHandler = mkAuthHandler handler
+  where
+    throw401 msg = throwError $ err401 { errBody = LBS.fromStrict $ Text.encodeUtf8 msg }
+    handler = either throw401 return . requestMailMailbox
+
+mkSpmRequestLogger :: MonadIO m => m Middleware
+mkSpmRequestLogger = liftIO $ mkRequestLogger loggerSettings
+  where
+    loggerSettings = defaultRequestLoggerSettings
+      { destination = Handle stderr
+      , outputFormat = ApacheWithSettings $ defaultApacheSettings
+          & setApacheUserGetter (preview (_Right . _Wrapped . to (Text.encodeUtf8. CI.original)) . requestMailMailbox)
+          & setApacheIPAddrSource FromFallback
+      }
+
+data ServerCtx = ServerCtx
+  { _sctxSqlPool :: Pool SqlBackend
+  , _sctxInstanceId :: UUID
+  , _sctxJwkSet :: JWKSet
+  } deriving (Generic, Typeable)
+makeLenses ''ServerCtx
+
+type Handler' = ReaderT ServerCtx (LoggingT Handler)
+type Server' api = ServerT api Handler'
+
+data ServerCtxError
+  = ServerCtxNoInstanceId | ServerCtxInvalidInstanceId
+  | ServerCtxJwkSetCredentialFileNotRelative
+  | ServerCtxNoCredentialsDirectory
+  | ServerCtxJwkSetDecodeError String
+  | ServerCtxJwkSetEmpty
+  deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Exception)
+  
+mkSpmApp :: (MonadUnliftIO m, MonadThrow m) => m Application
+mkSpmApp = do
+  requestLogger <- mkSpmRequestLogger
+
+  connStr <- liftIO $ maybe mempty (Text.encodeUtf8 . Text.pack) <$> lookupEnv "PGCONNSTR"
+  _sctxInstanceId <- maybe (throwM ServerCtxInvalidInstanceId) return . UUID.fromString =<< maybe (throwM ServerCtxNoInstanceId) return =<< liftIO (lookupEnv "SPM_INSTANCE")
+  jwksetCredentialFile <- liftIO $ fromMaybe "spm-keys.json" <$> lookupEnv "SPM_KEYS_CREDENTIAL"
+  unless (isRelative jwksetCredentialFile) $ throwM ServerCtxJwkSetCredentialFileNotRelative
+  credentialsDir <- maybe (throwM ServerCtxNoCredentialsDirectory) return =<< liftIO (lookupEnv "CREDENTIALS_DIRECTORY")
+  _sctxJwkSet@(JWKSet jwks) <- either (throwM . ServerCtxJwkSetDecodeError) return =<< liftIO (JSON.eitherDecodeFileStrict' $ credentialsDir </> jwksetCredentialFile)
+  when (null jwks) $ throwM ServerCtxJwkSetEmpty
+
+  runStderrLoggingT . withPostgresqlPool connStr 1 $ \_sctxSqlPool -> do
+    let
+      spmServerContext :: Context (AuthHandler Request MailMailbox ': '[])
+      spmServerContext = mailboxAuthHandler :. EmptyContext
+
+      spmServer' = spmServer
+
+    logger <- askLoggerIO
+    return $ serveWithContextT spmServerApi spmServerContext ((runReaderT ?? ServerCtx{..}) . hoist (runLoggingT ?? logger)) spmServer'
+      & requestLogger
+
+spmSql :: ReaderT SqlBackend Handler' a -> Handler' a
+spmSql act = do
+  sqlPool <- view sctxSqlPool
+  withResource sqlPool $ runReaderT act
+
+spmServer :: MailDomain -> MailMailbox -> Server' SpmApi
+spmServer _dom mbox = whoami
+                 :<|> jwkSet
+                 :<|> instanceId
+  where
+    whoami = do
+      Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
+      return $ mailboxIdent ^. _Wrapped . re _Wrapped
+
+    jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just)
+  
+    instanceId = view sctxInstanceId
+
+main :: IO ()
+main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
+  where
+    systemdSettings = defaultSystemdSettings
+      & requireSocketActivation .~ True
+    warpSettings = defaultSettings
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
+|]
diff --git a/hosts/surtr/email/spm/spm.nix b/hosts/surtr/email/spm/spm.nix
new file mode 100644
index 00000000..ba7a5f0b
--- /dev/null
+++ b/hosts/surtr/email/spm/spm.nix
@@ -0,0 +1,28 @@
+{ mkDerivation, aeson, attoparsec, base, bytestring
+, case-insensitive, exceptions, filepath, hpack, http-api-data
+, http-types, jose, lens, lib, mmorph, monad-logger, mtl
+, optparse-applicative, path-pieces, persistent
+, persistent-postgresql, resource-pool, servant, servant-server
+, text, transformers, unliftio-core, uuid, wai, wai-extra, warp
+, warp-systemd
+}:
+mkDerivation {
+  pname = "spm";
+  version = "0.1.0";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [
+    aeson base case-insensitive jose lens servant text
+  ];
+  libraryToolDepends = [ hpack ];
+  executableHaskellDepends = [
+    aeson attoparsec base bytestring case-insensitive exceptions
+    filepath http-api-data http-types jose lens mmorph monad-logger mtl
+    optparse-applicative path-pieces persistent persistent-postgresql
+    resource-pool servant-server text transformers unliftio-core uuid
+    wai wai-extra warp warp-systemd
+  ];
+  prePatch = "hpack";
+  license = lib.licenses.agpl3Plus;
+}
diff --git a/hosts/surtr/postgresql.nix b/hosts/surtr/postgresql.nix
index a5e93ecf..66ce60eb 100644
--- a/hosts/surtr/postgresql.nix
+++ b/hosts/surtr/postgresql.nix
@@ -6,20 +6,6 @@ in {
     services.postgresql = {
       enable = true;
       package = pkgs.postgresql_14;
-      initialScript = pkgs.writeText "schema.sql" ''
-        CREATE DATABASE "matrix-synapse" WITH TEMPLATE "template0" ENCODING "UTF8" LOCALE "C";
-        CREATE USER "matrix-synapse";
-        GRANT ALL PRIVILEGES ON DATABASE "matrix-synapse" TO "matrix-synapse";
-        GRANT ALL PRIVILEGES ON ALL TABLES IN SCHEMA public TO "matrix-synapse";
-
-        CREATE DATABASE "email" WITH TEMPLATE "template0" ENCODING "UTF8" LOCALE "C";
-        CREATE USER "postfix";
-        GRANT CONNECT ON DATABASE "email" TO "postfix";
-        ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT SELECT ON TABLES TO "postfix";
-        CREATE USER "dovecot2";
-        GRANT CONNECT ON DATABASE "email" TO "dovecot2";
-        ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT SELECT ON TABLES TO "dovecot2";
-      '';
     };
 
     systemd.services.migrate-postgresql = {
@@ -35,10 +21,46 @@ in {
 
       path = [ config.services.postgresql.package ];
       script = ''
+        psql postgres postgres -eXf ${pkgs.writeText "schema.sql" ''
+          CREATE DATABASE "matrix-synapse" WITH TEMPLATE "template0" ENCODING "UTF8" LOCALE "C";
+          CREATE DATABASE "email" WITH TEMPLATE "template0" ENCODING "UTF8" LOCALE "C";
+        ''}
+
+        psql matrix-synapse postgres -eXf ${pkgs.writeText "matrix-synapse.sql" ''
+          \i ${versioning + "/install.versioning.sql"}
+
+          BEGIN;
+          SELECT _v.register_patch('000-matrix-users', null, null);
+
+          CREATE USER "matrix-synapse";
+          GRANT ALL PRIVILEGES ON DATABASE "matrix-synapse" TO "matrix-synapse";
+          GRANT ALL PRIVILEGES ON ALL TABLES IN SCHEMA public TO "matrix-synapse";
+          COMMIT;
+        ''}
+
         psql email postgres -eXf ${pkgs.writeText "email.sql" ''
           \i ${versioning + "/install.versioning.sql"}
 
           BEGIN;
+          SELECT _v.register_patch('000-users', null, null);
+
+          CREATE USER "postfix";
+          GRANT CONNECT ON DATABASE "email" TO "postfix";
+          ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT SELECT ON TABLES TO "postfix";
+          CREATE USER "dovecot2";
+          GRANT CONNECT ON DATABASE "email" TO "dovecot2";
+          ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT SELECT ON TABLES TO "dovecot2";
+          COMMIT;
+
+          BEGIN;
+          SELECT _v.register_patch('001-spm', null, null);
+
+          CREATE USER "spm";
+          GRANT CONNECT ON DATABASE "email" TO "spm";
+          ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT SELECT ON TABLES to "spm";
+          COMMIT;
+
+          BEGIN;
           SELECT _v.register_patch('000-base', null, null);
 
           CREATE TABLE mailbox (
@@ -109,6 +131,18 @@ in {
           ALTER TABLE mailbox_mapping DROP CONSTRAINT mailbox_mapping_mailbox_fkey;
           ALTER TABLE mailbox_mapping ADD CONSTRAINT mailbox_mapping_mailbox_fkey FOREIGN KEY (mailbox) REFERENCES mailbox(id) ON DELETE CASCADE ON UPDATE RESTRICT;
           COMMIT;
+
+          BEGIN;
+          SELECT _v.register_patch('005-spm', ARRAY['000-base', '002-citext', '003-extensions'], null);
+
+          GRANT INSERT ON "mailbox_mapping" TO "spm";
+          COMMIT;
+
+          BEGIN;
+          SELECT _v.register_patch('006-spm-mailbox', ARRAY['000-base'], null);
+
+          GRANT SELECT ON ALL TABLES IN SCHEMA public TO "spm";
+          COMMIT;
         ''}
       '';
     };
diff --git a/hosts/surtr/ruleset.nft b/hosts/surtr/ruleset.nft
index bfa27d41..51fcd498 100644
--- a/hosts/surtr/ruleset.nft
+++ b/hosts/surtr/ruleset.nft
@@ -159,7 +159,7 @@ table inet filter {
     meta l4proto $icmp_protos counter name icmp-rx accept
 
     tcp dport 22 counter name ssh-rx accept
-    udp dport 60001-61000 counter name mosh-rx accept
+    udp dport 60000-61000 counter name mosh-rx accept
 
     meta protocol ip udp dport 51820 counter name wg-rx accept
     meta protocol ip6 udp dport {51821, 51822} counter name wg-rx accept
@@ -203,7 +203,7 @@ table inet filter {
 
 
     tcp sport 22 counter name ssh-tx
-    udp sport 60001-61000 counter name mosh-tx
+    udp sport 60000-61000 counter name mosh-tx
 
     tcp sport 53 counter name dns-tx
     udp sport 53 counter name dns-tx
diff --git a/hosts/vidhar/network/ruleset.nft b/hosts/vidhar/network/ruleset.nft
index d956cb74..c0da0fa6 100644
--- a/hosts/vidhar/network/ruleset.nft
+++ b/hosts/vidhar/network/ruleset.nft
@@ -163,7 +163,7 @@ table inet filter {
     meta l4proto $icmp_protos counter name icmp-rx accept
 
     iifname { lan, mgmt, dsl, yggdrasil, bifrost } tcp dport 22 counter name ssh-rx accept
-    iifname { lan, mgmt, dsl, yggdrasil, bifrost } udp dport 60001-61000 counter name mosh-rx accept
+    iifname { lan, mgmt, dsl, yggdrasil, bifrost } udp dport 60000-61000 counter name mosh-rx accept
 
     iifname { lan, mgmt, dmz01, yggdrasil } tcp dport 53 counter name dns-rx accept
     iifname { lan, mgmt, dmz01, yggdrasil } udp dport 53 counter name dns-rx accept
@@ -207,7 +207,7 @@ table inet filter {
 
 
     tcp sport 22 counter name ssh-tx
-    udp sport 60001-61000 counter name mosh-tx
+    udp sport 60000-61000 counter name mosh-tx
 
     tcp sport 53 counter name dns-tx
     udp sport 53 counter name dns-tx