1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
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
|
