summaryrefslogtreecommitdiff
path: root/hosts/surtr/email/spm/server
diff options
context:
space:
mode:
Diffstat (limited to 'hosts/surtr/email/spm/server')
-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
5 files changed, 0 insertions, 336 deletions
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|]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-16 11:30:35 +0000