diff options
Diffstat (limited to 'hosts/surtr/email/spm')
-rw-r--r-- | hosts/surtr/email/spm/default.nix | 24 | ||||
-rw-r--r-- | hosts/surtr/email/spm/lib/Data/CaseInsensitive/Instances.hs | 19 | ||||
-rw-r--r-- | hosts/surtr/email/spm/lib/Data/UUID/Instances.hs | 18 | ||||
-rw-r--r-- | hosts/surtr/email/spm/lib/Spm.hs | 5 | ||||
-rw-r--r-- | hosts/surtr/email/spm/lib/Spm/Api.hs | 40 | ||||
-rw-r--r-- | hosts/surtr/email/spm/package.yaml | 92 | ||||
-rw-r--r-- | hosts/surtr/email/spm/provision/Spm/Provision.hs | 46 | ||||
-rw-r--r-- | hosts/surtr/email/spm/server/Crypto/JOSE/JWK/Instances.hs | 9 | ||||
-rw-r--r-- | hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs | 30 | ||||
-rw-r--r-- | hosts/surtr/email/spm/server/Data/UUID/Instances.hs | 31 | ||||
-rw-r--r-- | hosts/surtr/email/spm/server/Spm/Server.hs | 194 | ||||
-rw-r--r-- | hosts/surtr/email/spm/server/Spm/Server/Database.hs | 72 | ||||
-rw-r--r-- | hosts/surtr/email/spm/spm.nix | 28 |
13 files changed, 608 insertions, 0 deletions
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 @@ | |||
1 | { haskell, fetchFromGitHub }: | ||
2 | |||
3 | let | ||
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 | }; | ||
24 | 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 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
2 | |||
3 | module Data.CaseInsensitive.Instances () where | ||
4 | |||
5 | import Prelude | ||
6 | |||
7 | import Data.CaseInsensitive (CI) | ||
8 | import qualified Data.CaseInsensitive as CI | ||
9 | |||
10 | import Servant.API.ContentTypes | ||
11 | |||
12 | import Data.Aeson | ||
13 | |||
14 | |||
15 | instance MimeRender PlainText a => MimeRender PlainText (CI a) where | ||
16 | mimeRender p = mimeRender p . CI.original | ||
17 | |||
18 | instance 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 new file mode 100644 index 00000000..335937d8 --- /dev/null +++ b/hosts/surtr/email/spm/lib/Data/UUID/Instances.hs | |||
@@ -0,0 +1,18 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
2 | |||
3 | module Data.UUID.Instances () where | ||
4 | |||
5 | import Prelude | ||
6 | import Data.UUID (UUID) | ||
7 | import qualified Data.UUID as UUID | ||
8 | import Servant.API.ContentTypes | ||
9 | |||
10 | |||
11 | instance MimeRender PlainText UUID where | ||
12 | mimeRender p = mimeRender p . UUID.toText | ||
13 | |||
14 | instance MimeRender JSON UUID where | ||
15 | mimeRender p = mimeRender p . UUID.toText | ||
16 | |||
17 | instance 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 new file mode 100644 index 00000000..c7f7dfe5 --- /dev/null +++ b/hosts/surtr/email/spm/lib/Spm.hs | |||
@@ -0,0 +1,5 @@ | |||
1 | module Spm | ||
2 | ( module Spm.Api | ||
3 | ) where | ||
4 | |||
5 | 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 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | ||
2 | |||
3 | module Spm.Api | ||
4 | ( SpmMailbox | ||
5 | , SpmApi, spmApi | ||
6 | ) where | ||
7 | |||
8 | import Prelude | ||
9 | |||
10 | import Servant.API | ||
11 | |||
12 | import Data.Proxy (Proxy(..)) | ||
13 | |||
14 | import Data.Text (Text) | ||
15 | |||
16 | import GHC.Generics (Generic) | ||
17 | import Type.Reflection (Typeable) | ||
18 | |||
19 | import Control.Lens.TH | ||
20 | |||
21 | import Data.CaseInsensitive (CI) | ||
22 | import Data.CaseInsensitive.Instances () | ||
23 | |||
24 | import Crypto.JOSE.JWK (JWKSet) | ||
25 | |||
26 | import Data.UUID (UUID) | ||
27 | import Data.UUID.Instances () | ||
28 | |||
29 | |||
30 | newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text } | ||
31 | deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
32 | deriving newtype (MimeRender JSON, MimeRender PlainText) | ||
33 | makeWrapped ''SpmMailbox | ||
34 | |||
35 | type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox | ||
36 | :<|> ".well-known" :> "jwks.json" :> Get '[JSON] JWKSet | ||
37 | :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID | ||
38 | |||
39 | spmApi :: Proxy SpmApi | ||
40 | 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 @@ | |||
1 | name: spm | ||
2 | version: 0.1.0 | ||
3 | |||
4 | default-extensions: | ||
5 | - NoImplicitPrelude | ||
6 | - DerivingStrategies | ||
7 | - DeriveAnyClass | ||
8 | - DataKinds | ||
9 | - RecordWildCards | ||
10 | - TypeFamilies | ||
11 | - LambdaCase | ||
12 | other-extensions: | ||
13 | - OverloadedStrings | ||
14 | - TemplateHaskell | ||
15 | - QuasiQuotes | ||
16 | - UndecidableInstances | ||
17 | language: GHC2021 | ||
18 | license: AGPL-3.0-or-later | ||
19 | ghc-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 | |||
29 | library: | ||
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 | |||
42 | executables: | ||
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 new file mode 100644 index 00000000..ff18baa0 --- /dev/null +++ b/hosts/surtr/email/spm/provision/Spm/Provision.hs | |||
@@ -0,0 +1,46 @@ | |||
1 | module Spm.Provision | ||
2 | ( main | ||
3 | ) where | ||
4 | |||
5 | import Prelude | ||
6 | import Options.Applicative | ||
7 | import Control.Monad | ||
8 | |||
9 | import qualified Data.Text.IO as Text | ||
10 | |||
11 | import qualified Data.UUID as UUID | ||
12 | import qualified Data.UUID.V4 as UUID | ||
13 | |||
14 | import Crypto.JOSE.JWK | ||
15 | |||
16 | import qualified Data.ByteString.Lazy.Char8 as CLBS | ||
17 | import qualified Data.Aeson as JSON | ||
18 | |||
19 | import Control.Lens | ||
20 | |||
21 | |||
22 | data Command | ||
23 | = InstanceId | ||
24 | | JwkSet | ||
25 | deriving stock (Eq, Ord, Read, Show) | ||
26 | |||
27 | cmdInstanceId :: IO () | ||
28 | cmdInstanceId = Text.putStrLn . UUID.toText =<< UUID.nextRandom | ||
29 | |||
30 | cmdJwkSet :: IO () | ||
31 | cmdJwkSet = 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 | |||
39 | opts :: Parser (IO ()) | ||
40 | opts = subparser $ | ||
41 | command "instance-id" (info (pure cmdInstanceId) idm) | ||
42 | <> command "jwk-set" (info (pure cmdJwkSet) idm) | ||
43 | |||
44 | |||
45 | main :: IO () | ||
46 | 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 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | ||
2 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
3 | |||
4 | module Crypto.JOSE.JWK.Instances () where | ||
5 | |||
6 | import Control.Lens.TH | ||
7 | import Crypto.JOSE.JWK | ||
8 | |||
9 | 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 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | |||
4 | module Data.CaseInsensitive.Instances () where | ||
5 | |||
6 | import Prelude | ||
7 | import Database.Persist | ||
8 | import Database.Persist.Sql | ||
9 | |||
10 | import Data.CaseInsensitive (CI) | ||
11 | import qualified Data.CaseInsensitive as CI | ||
12 | |||
13 | import Data.Text (Text) | ||
14 | import qualified Data.Text as Text | ||
15 | import qualified Data.Text.Encoding as Text | ||
16 | |||
17 | import Control.Exception | ||
18 | |||
19 | |||
20 | instance 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 | |||
29 | instance 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 new file mode 100644 index 00000000..b2268c96 --- /dev/null +++ b/hosts/surtr/email/spm/server/Data/UUID/Instances.hs | |||
@@ -0,0 +1,31 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | |||
4 | module Data.UUID.Instances () where | ||
5 | |||
6 | import Prelude | ||
7 | import Database.Persist | ||
8 | import Database.Persist.Sql | ||
9 | import Data.UUID (UUID) | ||
10 | import qualified Data.UUID as UUID | ||
11 | |||
12 | import qualified Data.ByteString.Char8 as CBS | ||
13 | import qualified Data.Text as Text | ||
14 | |||
15 | import Web.PathPieces | ||
16 | |||
17 | |||
18 | instance 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 | |||
26 | instance PersistFieldSql UUID where | ||
27 | sqlType _ = SqlOther "uuid" | ||
28 | |||
29 | instance 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 new file mode 100644 index 00000000..7690f51a --- /dev/null +++ b/hosts/surtr/email/spm/server/Spm/Server.hs | |||
@@ -0,0 +1,194 @@ | |||
1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell #-} | ||
2 | |||
3 | module Spm.Server | ||
4 | ( main | ||
5 | ) where | ||
6 | |||
7 | import Prelude | ||
8 | import Spm.Api | ||
9 | import Servant | ||
10 | import Servant.Server.Experimental.Auth | ||
11 | |||
12 | import Network.Wai | ||
13 | import Network.Wai.Handler.Warp | ||
14 | import Network.Wai.Handler.Warp.Systemd | ||
15 | import Network.Wai.Middleware.RequestLogger | ||
16 | |||
17 | import Network.HTTP.Types | ||
18 | |||
19 | import Data.Text (Text) | ||
20 | import qualified Data.Text as Text | ||
21 | import qualified Data.Text.Encoding as Text | ||
22 | import Data.Attoparsec.Text | ||
23 | |||
24 | import qualified Data.ByteString.Lazy as LBS | ||
25 | |||
26 | import GHC.Generics (Generic) | ||
27 | import Type.Reflection (Typeable) | ||
28 | |||
29 | import Control.Applicative | ||
30 | import Control.Monad | ||
31 | import Control.Arrow | ||
32 | import Control.Monad.IO.Class | ||
33 | import Control.Monad.IO.Unlift | ||
34 | |||
35 | import Control.Lens hiding (Context) | ||
36 | |||
37 | import qualified Data.CaseInsensitive as CI | ||
38 | |||
39 | import System.IO | ||
40 | |||
41 | import Spm.Server.Database | ||
42 | |||
43 | import Database.Persist | ||
44 | import Database.Persist.Postgresql | ||
45 | import Data.Pool | ||
46 | |||
47 | import Control.Monad.Trans.Reader (ReaderT, runReaderT) | ||
48 | |||
49 | import Control.Monad.Logger | ||
50 | |||
51 | import Control.Monad.Morph | ||
52 | |||
53 | import System.Environment | ||
54 | |||
55 | import Control.Monad.Catch (Exception, MonadThrow(..)) | ||
56 | |||
57 | import Data.UUID (UUID) | ||
58 | import qualified Data.UUID as UUID | ||
59 | |||
60 | import qualified Data.Aeson as JSON | ||
61 | |||
62 | import System.FilePath ((</>), isRelative) | ||
63 | |||
64 | import Crypto.JOSE.JWK hiding (Context) | ||
65 | import Crypto.JOSE.JWK.Instances () | ||
66 | |||
67 | import Data.Maybe | ||
68 | |||
69 | |||
70 | hSslClientVerify, hSslClientSDn :: HeaderName | ||
71 | hSslClientVerify = "SSL-Client-Verify" | ||
72 | hSslClientSDn = "SSL-Client-S-DN" | ||
73 | |||
74 | |||
75 | data SSLClientVerify | ||
76 | = SSLClientVerifySuccess | ||
77 | | SSLClientVerifyOther Text | ||
78 | deriving (Eq, Ord, Read, Show, Generic, Typeable) | ||
79 | instance 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 | |||
86 | type instance AuthServerData (AuthProtect "spm_mailbox") = MailMailbox | ||
87 | |||
88 | type SpmServerApi = Header' '[Required, Strict] "SPM-Domain" MailDomain | ||
89 | :> AuthProtect "spm_mailbox" | ||
90 | :> SpmApi | ||
91 | |||
92 | spmServerApi :: Proxy SpmServerApi | ||
93 | spmServerApi = Proxy | ||
94 | |||
95 | |||
96 | requestMailMailbox :: Request -> Either Text MailMailbox | ||
97 | requestMailMailbox 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 | |||
113 | mailboxAuthHandler :: AuthHandler Request MailMailbox | ||
114 | mailboxAuthHandler = mkAuthHandler handler | ||
115 | where | ||
116 | throw401 msg = throwError $ err401 { errBody = LBS.fromStrict $ Text.encodeUtf8 msg } | ||
117 | handler = either throw401 return . requestMailMailbox | ||
118 | |||
119 | mkSpmRequestLogger :: MonadIO m => m Middleware | ||
120 | mkSpmRequestLogger = 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 | |||
129 | data ServerCtx = ServerCtx | ||
130 | { _sctxSqlPool :: Pool SqlBackend | ||
131 | , _sctxInstanceId :: UUID | ||
132 | , _sctxJwkSet :: JWKSet | ||
133 | } deriving (Generic, Typeable) | ||
134 | makeLenses ''ServerCtx | ||
135 | |||
136 | type Handler' = ReaderT ServerCtx (LoggingT Handler) | ||
137 | type Server' api = ServerT api Handler' | ||
138 | |||
139 | data 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 | |||
148 | mkSpmApp :: (MonadUnliftIO m, MonadThrow m) => m Application | ||
149 | mkSpmApp = 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 | |||
171 | spmSql :: ReaderT SqlBackend Handler' a -> Handler' a | ||
172 | spmSql act = do | ||
173 | sqlPool <- view sctxSqlPool | ||
174 | withResource sqlPool $ runReaderT act | ||
175 | |||
176 | spmServer :: MailDomain -> MailMailbox -> Server' SpmApi | ||
177 | spmServer _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 | |||
189 | main :: IO () | ||
190 | main = 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 new file mode 100644 index 00000000..09b4c67b --- /dev/null +++ b/hosts/surtr/email/spm/server/Spm/Server/Database.hs | |||
@@ -0,0 +1,72 @@ | |||
1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, UndecidableInstances #-} | ||
2 | |||
3 | module Spm.Server.Database | ||
4 | ( MailMailbox, MailLocal, MailExtension, MailDomain | ||
5 | , Mailbox(..), MailboxMapping(..) | ||
6 | , Unique(..) | ||
7 | ) where | ||
8 | |||
9 | import Prelude | ||
10 | |||
11 | import Database.Persist | ||
12 | import Database.Persist.Sql | ||
13 | import Database.Persist.TH | ||
14 | |||
15 | import GHC.Generics (Generic) | ||
16 | import Type.Reflection (Typeable) | ||
17 | |||
18 | import Data.Text (Text) | ||
19 | |||
20 | import Data.CaseInsensitive (CI) | ||
21 | import qualified Data.CaseInsensitive as CI | ||
22 | import Data.CaseInsensitive.Instances () | ||
23 | |||
24 | import Data.UUID (UUID) | ||
25 | import Data.UUID.Instances () | ||
26 | |||
27 | import Data.Int (Int64) | ||
28 | |||
29 | import Control.Lens | ||
30 | |||
31 | import Web.HttpApiData | ||
32 | |||
33 | |||
34 | newtype MailMailbox = MailMailbox | ||
35 | { unMailMailbox :: CI Text | ||
36 | } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
37 | deriving newtype (PersistField, PersistFieldSql) | ||
38 | makeWrapped ''MailMailbox | ||
39 | newtype MailLocal = MailLocal | ||
40 | { unMailLocal :: CI Text | ||
41 | } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
42 | deriving newtype (PersistField, PersistFieldSql) | ||
43 | makeWrapped ''MailLocal | ||
44 | newtype MailExtension = MailExtension | ||
45 | { unMailExtension :: CI Text | ||
46 | } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
47 | deriving newtype (PersistField, PersistFieldSql) | ||
48 | makeWrapped ''MailExtension | ||
49 | newtype MailDomain = MailDomain | ||
50 | { unMailDomain :: CI Text | ||
51 | } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
52 | deriving newtype (PersistField, PersistFieldSql) | ||
53 | makeWrapped ''MailDomain | ||
54 | |||
55 | instance FromHttpApiData MailDomain where | ||
56 | parseUrlPiece = fmap (review _Wrapped . CI.mk) . parseUrlPiece | ||
57 | |||
58 | |||
59 | share [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 new file mode 100644 index 00000000..ba7a5f0b --- /dev/null +++ b/hosts/surtr/email/spm/spm.nix | |||
@@ -0,0 +1,28 @@ | |||
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 | }: | ||
9 | mkDerivation { | ||
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 | } | ||