summaryrefslogtreecommitdiff
path: root/hosts/surtr/email/spm/server/Spm/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to 'hosts/surtr/email/spm/server/Spm/Server.hs')
-rw-r--r--hosts/surtr/email/spm/server/Spm/Server.hs194
1 files changed, 0 insertions, 194 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-11 03:51:10 +0000