summaryrefslogtreecommitdiff
path: root/overlays/spm/server/Spm/Server.hs
blob: e6a876cbc72145bd49c91ab64385d4184a5ba6a3 (plain)
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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
{-# LANGUAGE OverloadedStrings #-}

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 qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID

import qualified Data.Aeson as JSON
import Data.Aeson.Lens (_JSON)

import System.FilePath ((</>), isRelative)

import Crypto.JOSE.JWK hiding (Context)
import Crypto.JOSE.JWK.Instances ()

import Crypto.Random.Instances ()
import qualified Crypto.Random as Crypto
import Control.Monad.Trans.Random.Strict
import Control.Monad.Random.Class

import Data.Maybe
import Data.List (sortOn)

import Spm.Server.Wordlist

import qualified Data.Vector as Vector

import Data.Foldable
import Crypto.JWT hiding (Context)
import qualified Crypto.JWT as JWT

import Data.Time.Clock

import Control.Monad.Trans.Except

import Data.Monoid (First(..))

import Numeric.Natural

import Spm.Server.Ctx
import Spm.Server.UI


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
               :<|>    "ui" :> Raw
               :<|>    GetNoContent

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
      }

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
              :<|> Tagged uiServer
              :<|> uiRedirect

    logger <- askLoggerIO
    return $ serveWithContextT spmServerApi spmServerContext ((runReaderT ?? ServerCtx{..}) . hoist (runLoggingT ?? logger)) spmServer'
      & requestLogger

  where
    uiRedirect = throwError err302 { errHeaders = [("Location", "/ui")] }

spmSql :: ReaderT SqlBackend Handler' a -> Handler' a
spmSql act = do
  sqlPool <- view sctxSqlPool
  withResource sqlPool $ runReaderT act

spmJWT :: forall error a. Show error => ServerError -> ExceptT error IO a -> Handler' a
spmJWT errTemplate = either (\err -> throwError errTemplate{ errBody = LBS.fromStrict . Text.encodeUtf8 . Text.pack $ show err }) return <=< liftIO . runExceptT

generateLocal :: MonadIO m => SpmStyle -> m MailLocal
generateLocal SpmWords = fmap (review _Wrapped . CI.mk) . liftIO $ do
  csprng <- Crypto.drgNew
  fmap (Text.intercalate ".") . (evalRandT ?? csprng) $
    replicateM 2 $ (wordlist Vector.!) <$> getRandomR (0, pred $ Vector.length wordlist)
generateLocal SpmConsonants = fmap (review _Wrapped . CI.mk) . liftIO $ do
  csprng <- Crypto.drgNew
  fmap fold . (evalRandT ?? csprng) $
    replicateM 5 $ (consonants Vector.!) <$> getRandomR (0, pred $ Vector.length consonants)

spmServer :: MailDomain -> MailMailbox -> Server' SpmApi
spmServer dom mbox = whoami
                :<|> domain
                :<|> jwkSet
                :<|> instanceId
                :<|> generate
                :<|> claim
                :<|> listMappings
                :<|> getMapping
                :<|> patchMapping
                :<|> putMapping
                :<|> deleteMapping
  where
    whoami = do
      Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
      return $ mailboxIdent ^. _Wrapped . re _Wrapped

    domain = return $ dom ^. _Wrapped . re _Wrapped

    jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just)

    instanceId = view sctxInstanceId

    generate (fromMaybe SpmWords -> style) = do
      local <- spmSql $
        let
          go :: Natural -> ReaderT SqlBackend Handler' MailLocal
          go tries
            | tries <= 0 = throwError err500{ errBody = "Could not find unused local part" }
            | otherwise = do
                local <- generateLocal style
                doesExist <- exists
                  [ MailboxMappingDomain ==. dom
                  , MailboxMappingLocal ==. Just local
                  ]
                if | doesExist -> go $ pred tries
                   | otherwise -> return local
         in go 100
      t <- liftIO getCurrentTime
      instanceId' <- view sctxInstanceId
      jwks <- view $ sctxJwkSet . _Wrapped
      tokenId <- liftIO UUID.nextRandom
      let claimsSet = emptyClaimsSet
            & claimIss ?~ (JWT.string # UUID.toText instanceId')
            & claimAud ?~ Audience (pure $ dom ^. _Wrapped . to CI.original . re JWT.string)
            & claimNbf ?~ NumericDate t
            & claimIat ?~ NumericDate t
            & claimExp ?~ NumericDate (600 `addUTCTime` t)
            & claimJti ?~ UUID.toText tokenId
            & unregisteredClaims . at "local" ?~ view (_Wrapped . re _JSON) local
      spmJWT @JWT.Error err500 $ do
        (jwsAlg, selectedJwk) <- withExceptT (fromMaybe JWT.NoUsableKeys . getFirst) . asum $ map (\jwk' -> (, jwk') <$> withExceptT (First . Just) (bestJWSAlg jwk')) jwks
        signClaims selectedJwk (newJWSHeader ((), jwsAlg)) claimsSet

    claim jwt = do
      jwks <- view sctxJwkSet
      let validationSettings' = defaultJWTValidationSettings ((== Just dom) . fmap (review _Wrapped . CI.mk) . preview JWT.string)
            & jwtValidationSettingsAllowedSkew .~ 5
      claims <- spmJWT @JWT.JWTError err403 $ verifyClaims validationSettings' jwks jwt
      mailboxMappingLocal <- maybe (throwError err400{ errBody = "Claim ‘local’ missing" }) (return . Just) $ claims ^? unregisteredClaims . ix "local" . _JSON . to CI.mk . re _Wrapped

      spmSql $ do
        Entity mailboxMappingMailbox _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
        insert_ MailboxMapping{mailboxMappingExtension = Nothing, mailboxMappingDomain = dom, mailboxMappingReject = False, ..}

      return NoContent

    listMappings = spmSql $ do
      Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
      mappings <- selectList [ MailboxMappingMailbox ==. mailboxId, MailboxMappingDomain ==. dom ] []
      return $ mappings
        & fmap (\(Entity _ MailboxMapping{..}) -> SpmMappingListingItem
                 { smlMapping = SpmMapping
                   { spmMappingLocal = view (_Wrapped . _Unwrapped) <$> mailboxMappingLocal
                   , spmMappingExtension = view (_Wrapped . _Unwrapped) <$> mailboxMappingExtension
                   }
                 , smlState = _SpmMappingStateReject # mailboxMappingReject
                 }
               )
        & sortOn (spmMappingLocal . smlMapping &&& spmMappingExtension . smlMapping)
        & SpmMappingListing

    getUniqueMapping SpmMapping{..} = do
      Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
      candidateMappings <- selectList
        [ MailboxMappingMailbox ==. mailboxId
        , MailboxMappingLocal ==. (spmMappingLocal <&> view (_Wrapped . _Unwrapped))
        , MailboxMappingExtension ==. (spmMappingExtension <&> view (_Wrapped . _Unwrapped))
        , MailboxMappingDomain ==. dom
        ]
        [ LimitTo 1
        ]
      case candidateMappings of
        [mMapping] -> return mMapping
        _other -> throwError err404

    getMapping spmMapping = spmSql $ do
      Entity _ MailboxMapping{..} <- getUniqueMapping spmMapping
      return $ _SpmMappingStateReject # mailboxMappingReject

    patchMapping spmMapping mappingState = spmSql $ do
      Entity mmId MailboxMapping{} <- getUniqueMapping spmMapping
      update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ]
      return NoContent

    assertAuthorizedAncestor spmMapping = do
      Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox

      let go [] = throwError err403
          go (SpmMapping{..} : ancestors) = do
            candidate <- selectList
              [ MailboxMappingLocal ==. (spmMappingLocal <&> view (_Wrapped . _Unwrapped))
              , MailboxMappingExtension ==. (spmMappingExtension <&> view (_Wrapped . _Unwrapped))
              , MailboxMappingDomain ==. dom
              ]
              [ LimitTo 1
              ]
            case candidate of
              [Entity _ MailboxMapping{..}] ->
                unless (mailboxMappingMailbox == mailboxId) $
                  throwError err403
              [] -> go ancestors
              _other -> throwError err500
       in go $ spmMappingAncestors spmMapping

    putMapping spmMapping mappingState = spmSql $ do
      Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox

      existing <- selectList
        [ MailboxMappingLocal ==. (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
        , MailboxMappingExtension ==. (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
        , MailboxMappingDomain ==. dom
        ]
        [ LimitTo 1
        ]
      unless (null existing) $
        throwError err409

      assertAuthorizedAncestor spmMapping

      insert_ MailboxMapping
        { mailboxMappingLocal = (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
        , mailboxMappingExtension = (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
        , mailboxMappingDomain = dom
        , mailboxMappingMailbox = mailboxId
        , mailboxMappingReject = view _SpmMappingStateReject mappingState
        }
      return NoContent

    deleteMapping spmMapping = spmSql $ do
      Entity mmId MailboxMapping{} <- getUniqueMapping spmMapping
      assertAuthorizedAncestor spmMapping

      delete mmId
      return NoContent

main :: IO ()
main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
  where
    systemdSettings = defaultSystemdSettings
      & requireSocketActivation .~ True
    warpSettings = defaultSettings