9 files changed, 519 insertions, 0 deletions

diff --git a/overlays/spm/server/Crypto/JOSE/JWK/Instances.hs b/overlays/spm/server/Crypto/JOSE/JWK/Instances.hs
new file mode 100644
index 00000000..44a5cfe0
--- /dev/null
+++ b/overlays/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/overlays/spm/server/Crypto/Random/Instances.hs b/overlays/spm/server/Crypto/Random/Instances.hs
new file mode 100644
index 00000000..6b0890be
--- /dev/null
+++ b/overlays/spm/server/Crypto/Random/Instances.hs
@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Crypto.Random.Instances () where
+
+import Prelude
+import Crypto.Random
+import System.Random
+
+import qualified Data.ByteString as BS
+
+import Data.Bits
+
+
+instance RandomGen ChaChaDRG where
+  split = flip withDRG drgNew
+
+  genWord64 g = withRandomBytes g 8 $ \case
+    (map fromIntegral . BS.unpack -> [b1, b2, b3, b4, b5, b6, b7, b8])
+      ->     b1 `shiftL` 56
+         .|. b2 `shiftL` 48
+         .|. b3 `shiftL` 40
+         .|. b4 `shiftL` 32
+         .|. b5 `shiftL` 24
+         .|. b6 `shiftL` 16
+         .|. b7 `shiftL` 8
+         .|. b8
+    _other -> error "withRandomBytes did not return correct number of bytes"
diff --git a/overlays/spm/server/Data/CaseInsensitive/Instances.hs b/overlays/spm/server/Data/CaseInsensitive/Instances.hs
new file mode 100644
index 00000000..1f3f7a11
--- /dev/null
+++ b/overlays/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/overlays/spm/server/Data/UUID/Instances.hs b/overlays/spm/server/Data/UUID/Instances.hs
new file mode 100644
index 00000000..b2268c96
--- /dev/null
+++ b/overlays/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/overlays/spm/server/Spm/Server.hs b/overlays/spm/server/Spm/Server.hs
new file mode 100644
index 00000000..1f785999
--- /dev/null
+++ b/overlays/spm/server/Spm/Server.hs
@@ -0,0 +1,271 @@
+{-# 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 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
+
+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
+
+    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
+
+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
+                 :<|> jwkSet
+                 :<|> instanceId
+                 :<|> generate
+                 :<|> claim
+  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
+
+    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
+        maybe (throwError err400{ errBody = "Address already claimed" }) (const $ return NoContent) =<< insertUnique MailboxMapping{mailboxMappingExtension = Nothing, mailboxMappingDomain = dom, ..}
+
+main :: IO ()
+main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
+  where
+    systemdSettings = defaultSystemdSettings
+      & requireSocketActivation .~ True
+    warpSettings = defaultSettings
diff --git a/overlays/spm/server/Spm/Server/Ctx.hs b/overlays/spm/server/Spm/Server/Ctx.hs
new file mode 100644
index 00000000..7b84e3d5
--- /dev/null
+++ b/overlays/spm/server/Spm/Server/Ctx.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Spm.Server.Ctx
+  ( ServerCtx(..)
+  , sctxSqlPool, sctxInstanceId, sctxJwkSet
+  ) where
+
+import Data.UUID (UUID)
+import Crypto.JOSE.JWK (JWKSet)
+import Database.Persist.Postgresql
+import Data.Pool
+import Control.Lens.TH
+
+import Type.Reflection (Typeable)
+import GHC.Generics (Generic)
+
+
+data ServerCtx = ServerCtx
+  { _sctxSqlPool :: Pool SqlBackend
+  , _sctxInstanceId :: UUID
+  , _sctxJwkSet :: JWKSet
+  } deriving (Generic, Typeable)
+makeLenses ''ServerCtx
+
diff --git a/overlays/spm/server/Spm/Server/Database.hs b/overlays/spm/server/Spm/Server/Database.hs
new file mode 100644
index 00000000..cc133e06
--- /dev/null
+++ b/overlays/spm/server/Spm/Server/Database.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, UndecidableInstances #-}
+
+module Spm.Server.Database
+  ( MailMailbox, MailLocal, MailExtension, MailDomain
+  , Mailbox(..), MailboxMapping(..)
+  , Key(..), EntityField(..), 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
+    UniqueLocalDomain local domain sql=local_domain_unique !force
+|]
diff --git a/overlays/spm/server/Spm/Server/UI.hs b/overlays/spm/server/Spm/Server/UI.hs
new file mode 100644
index 00000000..544e4f54
--- /dev/null
+++ b/overlays/spm/server/Spm/Server/UI.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
+
+module Spm.Server.UI
+  ( uiServer
+  ) where
+
+import Prelude
+
+import Network.Wai
+
+import Network.Wai.Application.Static
+import WaiAppStatic.Types
+
+import Data.FileEmbed
+
+
+uiServer :: Application
+uiServer = staticApp settings
+    { ssLookupFile = \pcs -> ssLookupFile settings pcs >>= \case
+        LRNotFound -> ssLookupFile settings [unsafeToPiece "index.html"]
+        o -> return o
+    }
+  where settings = embeddedSettings $(embedDir "frontend")
diff --git a/overlays/spm/server/Spm/Server/Wordlist.hs b/overlays/spm/server/Spm/Server/Wordlist.hs
new file mode 100644
index 00000000..8109f07b
--- /dev/null
+++ b/overlays/spm/server/Spm/Server/Wordlist.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Spm.Server.Wordlist
+  ( wordlist, consonants
+  ) where
+
+import Prelude
+import Language.Haskell.TH.Syntax
+import Control.Monad.IO.Class
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+import Data.FileEmbed (makeRelativeToProject)
+
+import Instances.TH.Lift ()
+
+
+{-# NOINLINE wordlist #-}
+{-# NOINLINE consonants #-}
+wordlist, consonants :: Vector Text
+wordlist = $( do
+                fPath <- makeRelativeToProject "wordlist.txt"
+                addDependentFile fPath
+                lift . Vector.fromList =<< liftIO (filter (not . Text.null) . Text.words <$> Text.readFile fPath)
+            )
+consonants = Vector.fromList $ map Text.singleton "bcdfghjklmnpqrstvwxz"