From fc6cf6169868e60c189e4b243330c3717ff159f3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 May 2022 13:58:07 +0200 Subject: ... --- overlays/spm/server/Crypto/JOSE/JWK/Instances.hs | 9 + overlays/spm/server/Crypto/Random/Instances.hs | 27 ++ .../spm/server/Data/CaseInsensitive/Instances.hs | 30 +++ overlays/spm/server/Data/UUID/Instances.hs | 31 +++ overlays/spm/server/Spm/Server.hs | 271 +++++++++++++++++++++ overlays/spm/server/Spm/Server/Ctx.hs | 24 ++ overlays/spm/server/Spm/Server/Database.hs | 73 ++++++ overlays/spm/server/Spm/Server/UI.hs | 23 ++ overlays/spm/server/Spm/Server/Wordlist.hs | 31 +++ 9 files changed, 519 insertions(+) create mode 100644 overlays/spm/server/Crypto/JOSE/JWK/Instances.hs create mode 100644 overlays/spm/server/Crypto/Random/Instances.hs create mode 100644 overlays/spm/server/Data/CaseInsensitive/Instances.hs create mode 100644 overlays/spm/server/Data/UUID/Instances.hs create mode 100644 overlays/spm/server/Spm/Server.hs create mode 100644 overlays/spm/server/Spm/Server/Ctx.hs create mode 100644 overlays/spm/server/Spm/Server/Database.hs create mode 100644 overlays/spm/server/Spm/Server/UI.hs create mode 100644 overlays/spm/server/Spm/Server/Wordlist.hs (limited to 'overlays/spm/server') 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" -- cgit v1.2.3