From fc6cf6169868e60c189e4b243330c3717ff159f3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 May 2022 13:58:07 +0200 Subject: ... --- hosts/surtr/email/spm/server/Spm/Server.hs | 194 ----------------------------- 1 file changed, 194 deletions(-) delete mode 100644 hosts/surtr/email/spm/server/Spm/Server.hs (limited to 'hosts/surtr/email/spm/server/Spm/Server.hs') 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 @@ -{-# 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 -- cgit v1.2.3