From 84f2affd66a0ff3947b91a30308cb8e6a8ff7594 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 19 May 2022 22:05:02 +0200 Subject: surtr: ... --- hosts/surtr/default.nix | 3 +- hosts/surtr/email/ca/index.txt | 3 +- hosts/surtr/email/ca/serial | 2 +- hosts/surtr/email/default.nix | 90 ++++++++-- hosts/surtr/email/spm-keys.json | 26 +++ hosts/surtr/email/spm/default.nix | 24 +++ .../spm/lib/Data/CaseInsensitive/Instances.hs | 19 ++ hosts/surtr/email/spm/lib/Data/UUID/Instances.hs | 18 ++ hosts/surtr/email/spm/lib/Spm.hs | 5 + hosts/surtr/email/spm/lib/Spm/Api.hs | 40 +++++ hosts/surtr/email/spm/package.yaml | 92 ++++++++++ hosts/surtr/email/spm/provision/Spm/Provision.hs | 46 +++++ .../email/spm/server/Crypto/JOSE/JWK/Instances.hs | 9 + .../spm/server/Data/CaseInsensitive/Instances.hs | 30 ++++ .../surtr/email/spm/server/Data/UUID/Instances.hs | 31 ++++ hosts/surtr/email/spm/server/Spm/Server.hs | 194 +++++++++++++++++++++ .../surtr/email/spm/server/Spm/Server/Database.hs | 72 ++++++++ hosts/surtr/email/spm/spm.nix | 28 +++ hosts/surtr/postgresql.nix | 62 +++++-- hosts/surtr/ruleset.nft | 4 +- 20 files changed, 765 insertions(+), 33 deletions(-) create mode 100644 hosts/surtr/email/spm-keys.json create mode 100644 hosts/surtr/email/spm/default.nix create mode 100644 hosts/surtr/email/spm/lib/Data/CaseInsensitive/Instances.hs create mode 100644 hosts/surtr/email/spm/lib/Data/UUID/Instances.hs create mode 100644 hosts/surtr/email/spm/lib/Spm.hs create mode 100644 hosts/surtr/email/spm/lib/Spm/Api.hs create mode 100644 hosts/surtr/email/spm/package.yaml create mode 100644 hosts/surtr/email/spm/provision/Spm/Provision.hs create mode 100644 hosts/surtr/email/spm/server/Crypto/JOSE/JWK/Instances.hs create mode 100644 hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs create mode 100644 hosts/surtr/email/spm/server/Data/UUID/Instances.hs create mode 100644 hosts/surtr/email/spm/server/Spm/Server.hs create mode 100644 hosts/surtr/email/spm/server/Spm/Server/Database.hs create mode 100644 hosts/surtr/email/spm/spm.nix (limited to 'hosts/surtr') 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,9 +21,45 @@ 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); @@ -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 -- cgit v1.2.3