5 files changed, 336 insertions, 0 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
new file mode 100644
index 00000000..44a5cfe0
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Crypto/JOSE/JWK/Instances.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Crypto.JOSE.JWK.Instances () where
+
+import Control.Lens.TH
+import Crypto.JOSE.JWK
+
+makeWrapped ''JWKSet
diff --git a/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs b/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs
new file mode 100644
index 00000000..1f3f7a11
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs
@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.CaseInsensitive.Instances () where
+
+import Prelude
+import Database.Persist
+import Database.Persist.Sql
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+
+import Control.Exception
+
+
+instance PersistField (CI Text) where
+  toPersistValue = PersistLiteralEscaped . Text.encodeUtf8 . CI.original
+  fromPersistValue = \case
+    PersistText t -> Right $ CI.mk t
+    PersistLiteralEscaped bs -> case Text.decodeUtf8' bs of
+      Right t   -> Right $ CI.mk t
+      Left  err -> Left $ "Could not decode PersistLiteral as UTF-8: " <> Text.pack (displayException err)
+    o -> Left $ "Expected PersistText or PersistLiteral but got ‘" <> Text.pack (show o) <> "’"
+
+instance PersistFieldSql (CI Text) where
+  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
new file mode 100644
index 00000000..b2268c96
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Data/UUID/Instances.hs
@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.UUID.Instances () where
+
+import Prelude
+import Database.Persist
+import Database.Persist.Sql
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+
+import qualified Data.ByteString.Char8 as CBS
+import qualified Data.Text as Text
+
+import Web.PathPieces
+  
+
+instance PersistField UUID where
+  toPersistValue = PersistLiteralEscaped . CBS.pack . UUID.toString
+  fromPersistValue (PersistLiteralEscaped uuidB8) =
+    case UUID.fromString $ CBS.unpack uuidB8 of
+      Just uuid -> Right uuid
+      Nothing   -> Left "Invalid UUID"
+  fromPersistValue v = Left $ "Expected PersistLiteral but got ‘" <> Text.pack (show v) <> "’"
+
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"
+
+instance PathPiece UUID where
+  toPathPiece = Text.pack . UUID.toString
+  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
new file mode 100644
index 00000000..7690f51a
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Spm/Server.hs
@@ -0,0 +1,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
diff --git a/hosts/surtr/email/spm/server/Spm/Server/Database.hs b/hosts/surtr/email/spm/server/Spm/Server/Database.hs
new file mode 100644
index 00000000..09b4c67b
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Spm/Server/Database.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, UndecidableInstances #-}
+
+module Spm.Server.Database
+  ( MailMailbox, MailLocal, MailExtension, MailDomain
+  , Mailbox(..), MailboxMapping(..)
+  , Unique(..)
+  ) where
+
+import Prelude
+
+import Database.Persist
+import Database.Persist.Sql
+import Database.Persist.TH
+
+import GHC.Generics (Generic)
+import Type.Reflection (Typeable)
+
+import Data.Text (Text)
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive.Instances ()
+
+import Data.UUID (UUID)
+import Data.UUID.Instances ()
+
+import Data.Int (Int64)
+
+import Control.Lens
+
+import Web.HttpApiData
+
+
+newtype MailMailbox = MailMailbox
+  { unMailMailbox :: CI Text
+  } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
+    deriving newtype (PersistField, PersistFieldSql)
+makeWrapped ''MailMailbox
+newtype MailLocal = MailLocal
+  { unMailLocal :: CI Text
+  } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
+    deriving newtype (PersistField, PersistFieldSql)
+makeWrapped ''MailLocal
+newtype MailExtension = MailExtension
+  { unMailExtension :: CI Text
+  } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
+    deriving newtype (PersistField, PersistFieldSql)
+makeWrapped ''MailExtension
+newtype MailDomain = MailDomain
+  { unMailDomain :: CI Text
+  } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
+    deriving newtype (PersistField, PersistFieldSql)
+makeWrapped ''MailDomain
+
+instance FromHttpApiData MailDomain where
+  parseUrlPiece = fmap (review _Wrapped . CI.mk) . parseUrlPiece
+
+
+share [mkPersist sqlSettings] [persistLowerCase|
+  Mailbox
+    Id UUID sqltype=uuid default=gen_random_uuid()
+    ident MailMailbox sql=mailbox
+    quota Int64 Maybe sql=quota_bytes MigrationOnly
+    UniqueMailbox ident
+    deriving Show
+  MailboxMapping
+    Id UUID sqltype=uuid default=gen_random_uuid()
+    local MailLocal Maybe
+    extension MailExtension Maybe
+    domain MailDomain
+    mailbox MailboxId
+|]