diff --git a/CHANGELOG-draft.md b/CHANGELOG-draft.md index a54edb4366..44b6e5874c 100644 --- a/CHANGELOG-draft.md +++ b/CHANGELOG-draft.md @@ -25,3 +25,4 @@ THIS FILE ACCUMULATES THE RELEASE NOTES FOR THE UPCOMING RELEASE. ## Federation changes * Ensure clients only receive messages meant for them in remote convs (#1739) +* Federator CA store and client credentials are now automatically reloaded (#1730) diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index 30ce16ef3d..ade0ac7332 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: aef5b26595440dc41b2afea5b58468827dd4bdc290b406e49e8e2263ad2a81ad +-- hash: 9a181e3a92130220d845ad959ca6e02a217b07a38602513bff4c9376a4ffe145 name: federator version: 1.0.0 @@ -40,6 +40,8 @@ library Federator.Env Federator.ExternalServer Federator.InternalServer + Federator.Monitor + Federator.Monitor.Internal Federator.Options Federator.Remote Federator.Run @@ -59,12 +61,15 @@ library , base , bilge , bytestring + , containers , data-default , dns , dns-util , either , exceptions , extended + , filepath + , hinotify , http-client , http-client-openssl , http-types @@ -90,6 +95,7 @@ library , tinylog , tls , types-common + , unix , unliftio , uri-bytestring , uuid @@ -119,6 +125,7 @@ executable federator , base , bilge , bytestring + , containers , data-default , dns , dns-util @@ -126,6 +133,8 @@ executable federator , exceptions , extended , federator + , filepath + , hinotify , http-client , http-client-openssl , http-types @@ -151,6 +160,7 @@ executable federator , tinylog , tls , types-common + , unix , unliftio , uri-bytestring , uuid @@ -184,6 +194,7 @@ executable federator-integration , base , bilge , bytestring + , containers , cryptonite , data-default , dns @@ -192,6 +203,8 @@ executable federator-integration , exceptions , extended , federator + , filepath + , hinotify , hspec , http-client , http-client-openssl @@ -222,6 +235,7 @@ executable federator-integration , tinylog , tls , types-common + , unix , unliftio , uri-bytestring , uuid @@ -243,6 +257,7 @@ test-suite federator-tests other-modules: Test.Federator.ExternalServer Test.Federator.InternalServer + Test.Federator.Monitor Test.Federator.Options Test.Federator.Remote Test.Federator.Validation @@ -258,13 +273,17 @@ test-suite federator-tests , base , bilge , bytestring + , containers , data-default + , directory , dns , dns-util , either , exceptions , extended , federator + , filepath + , hinotify , http-client , http-client-openssl , http-types @@ -291,10 +310,14 @@ test-suite federator-tests , string-conversions , tasty , tasty-hunit + , tasty-quickcheck + , temporary , text , tinylog , tls + , transformers , types-common + , unix , unliftio , uri-bytestring , uuid diff --git a/services/federator/federator.integration.yaml b/services/federator/federator.integration.yaml index 5e450f0efc..76077df2b8 100644 --- a/services/federator/federator.integration.yaml +++ b/services/federator/federator.integration.yaml @@ -31,7 +31,7 @@ optSettings: # - wire.com # - example.com - useSystemCAStore: true + useSystemCAStore: false clientCertificate: "test/resources/integration-leaf.pem" clientPrivateKey: "test/resources/integration-leaf-key.pem" diff --git a/services/federator/package.yaml b/services/federator/package.yaml index ceff6710be..8db0783a9d 100644 --- a/services/federator/package.yaml +++ b/services/federator/package.yaml @@ -14,12 +14,15 @@ dependencies: - base - bilge - bytestring +- containers - data-default - dns - dns-util - either - exceptions - extended +- filepath +- hinotify - HsOpenSSL - HsOpenSSL-x509-system - http2-client @@ -47,6 +50,7 @@ dependencies: - tinylog - tls - types-common +- unix - unliftio - uri-bytestring - uuid @@ -100,12 +104,16 @@ tests: - -with-rtsopts=-N dependencies: - bytestring + - directory - federator - interpolate - polysemy-mocks - streaming-commons - tasty + - tasty-quickcheck - tasty-hunit + - temporary + - transformers - wai - warp - warp-tls diff --git a/services/federator/src/Federator/Env.hs b/services/federator/src/Federator/Env.hs index 71d1f17817..b17a3b5659 100644 --- a/services/federator/src/Federator/Env.hs +++ b/services/federator/src/Federator/Env.hs @@ -26,6 +26,7 @@ import Control.Lens (makeLenses) import Data.Metrics (Metrics) import Data.X509.CertificateStore import Federator.Options (RunSettings) +import Imports import Network.DNS.Resolver (Resolver) import qualified Network.HTTP.Client as HTTP import qualified Network.TLS as TLS @@ -45,7 +46,7 @@ data Env = Env _runSettings :: RunSettings, _service :: Component -> RPC.Request, _httpManager :: HTTP.Manager, - _tls :: TLSSettings + _tls :: IORef TLSSettings } makeLenses ''TLSSettings diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index 49d77c860b..9dd4a64b34 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -41,6 +41,7 @@ import qualified Mu.Server as Mu import Polysemy import qualified Polysemy.Error as Polysemy import Polysemy.IO (embedToMonadIO) +import qualified Polysemy.Input as Polysemy import qualified Polysemy.Reader as Polysemy import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log @@ -102,9 +103,9 @@ serveOutward env port = do TinyLog, DNSLookup, Polysemy.Error ServerError, - Embed IO, Polysemy.Reader RunSettings, - Polysemy.Reader TLSSettings, + Polysemy.Input TLSSettings, + Embed IO, Embed Federator ] a -> @@ -112,9 +113,9 @@ serveOutward env port = do transformer action = runAppT env . runM -- Embed Federator - . Polysemy.runReader (view tls env) -- Reader TLSSettings - . Polysemy.runReader (view runSettings env) -- Reader RunSettings . embedToMonadIO @Federator -- Embed IO + . Polysemy.runInputSem (embed @IO (readIORef (view tls env))) -- Input TLSSettings + . Polysemy.runReader (view runSettings env) -- Reader RunSettings . absorbServerError . Lookup.runDNSLookupWithResolver (view dnsResolver env) . Log.runTinyLog (view applog env) diff --git a/services/federator/src/Federator/Monitor.hs b/services/federator/src/Federator/Monitor.hs new file mode 100644 index 0000000000..9e3c5e0744 --- /dev/null +++ b/services/federator/src/Federator/Monitor.hs @@ -0,0 +1,53 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Federator.Monitor + ( withMonitor, + mkTLSSettingsOrThrow, + FederationSetupError (..), + ) +where + +import Control.Exception (bracket, throw) +import Federator.Env (TLSSettings (..)) +import Federator.Monitor.Internal +import Federator.Options (RunSettings (..)) +import Imports +import qualified Polysemy +import qualified Polysemy.Error as Polysemy +import System.Logger (Logger) + +mkTLSSettingsOrThrow :: RunSettings -> IO TLSSettings +mkTLSSettingsOrThrow = + Polysemy.runM + . (either (Polysemy.embed @IO . throw) pure =<<) + . Polysemy.runError @FederationSetupError + . mkTLSSettings + +withMonitor :: Logger -> IORef TLSSettings -> RunSettings -> IO a -> IO a +withMonitor logger tlsVar rs action = + bracket + ( runSemDefault + logger + ( mkMonitor + (runSemDefault logger . logAndIgnoreErrors) + tlsVar + rs + ) + ) + (runSemDefault logger . delMonitor) + (const action) diff --git a/services/federator/src/Federator/Monitor/Internal.hs b/services/federator/src/Federator/Monitor/Internal.hs new file mode 100644 index 0000000000..28351d384d --- /dev/null +++ b/services/federator/src/Federator/Monitor/Internal.hs @@ -0,0 +1,372 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Federator.Monitor.Internal where + +import Control.Exception (try) +import Data.ByteString (packCStringLen) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import qualified Data.X509 as X509 +import Data.X509.CertificateStore +import Federator.Env (TLSSettings (..)) +import Federator.Options (RunSettings (..)) +import GHC.Foreign (withCStringLen) +import GHC.IO.Encoding (getFileSystemEncoding) +import Imports +import qualified Network.TLS as TLS +import Polysemy (Embed, Member, Members, Sem, embed) +import qualified Polysemy +import qualified Polysemy.Error as Polysemy +import qualified Polysemy.Resource as Polysemy +import Polysemy.TinyLog (TinyLog) +import qualified Polysemy.TinyLog as Log +import System.FilePath +import System.INotify +import System.Logger (Logger) +import qualified System.Logger.Message as Log +import System.Posix.ByteString (RawFilePath) +import System.Posix.Files +import System.X509 +import Wire.API.Arbitrary + +data Monitor = Monitor + { monINotify :: INotify, + monTLS :: IORef TLSSettings, + monWatches :: IORef Watches, + monSettings :: RunSettings, + monHandler :: WatchedPath -> Event -> IO (), + monLock :: MVar () + } + +-- This is needed because the normal Posix file system API uses strings, while +-- the inotify API uses bytestrings. +-- /Note/: File paths are strings obtained using the "file system encoding", +-- which is the same as the locale encoding, but uses some escaping tricks to +-- be able to represent arbitrary data as strings. +rawPath :: FilePath -> IO RawFilePath +rawPath path = do + encoding <- getFileSystemEncoding + withCStringLen encoding path packCStringLen + +data WatchedPath + = WatchedFile RawFilePath + | WatchedDir RawFilePath (Set RawFilePath) + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via (GenericUniform WatchedPath) + +mergePaths :: [WatchedPath] -> (Set WatchedPath) +mergePaths = Set.fromList . merge . sort + where + merge [] = [] + merge [w] = [w] + merge (w1 : w2 : ws) = case (w1, w2) of + (_, WatchedFile _) -> w1 : w2 : merge ws + (WatchedDir dir1 paths1, WatchedDir dir2 paths2) + | dir1 == dir2 -> merge (WatchedDir dir1 (paths1 <> paths2) : ws) + _ -> w1 : merge (w2 : ws) + +watchedPath :: WatchedPath -> RawFilePath +watchedPath (WatchedFile path) = path +watchedPath (WatchedDir dir _) = dir + +watchPathEvents :: WatchedPath -> [EventVariety] +watchPathEvents (WatchedFile _) = [CloseWrite] +watchPathEvents (WatchedDir _ _) = [MoveIn, Create] + +-- Since we are watching a filesystem path, and not an inode, we need to replace a +-- file watch when the file gets overwritten. +-- This type is a map of paths to watches used to keep track of both file and +-- directory watches as they get deleted and recreated. +type Watches = Map RawFilePath (WatchDescriptor, WatchedPath) + +runSemDefault :: Logger -> Sem '[TinyLog, Embed IO] a -> IO a +runSemDefault logger = Polysemy.runM . Log.runTinyLog logger + +logErrors :: + Members '[TinyLog, Polysemy.Error FederationSetupError] r => + Sem r a -> + Sem r a +logErrors action = Polysemy.catch action $ \err -> do + Log.err $ + Log.msg ("federation setup error while updating certificates" :: Text) + . Log.field "error" (showFederationSetupError err) + Polysemy.throw err + +logAndIgnoreErrors :: + Member TinyLog r => + Sem (Polysemy.Error FederationSetupError ': r) () -> + Sem r () +logAndIgnoreErrors = void . Polysemy.runError . logErrors + +delMonitor :: + (Members '[TinyLog, Embed IO] r) => + Monitor -> + Sem r () +delMonitor monitor = Polysemy.resourceToIO $ + Polysemy.bracket + (takeMVar (monLock monitor)) + (putMVar (monLock monitor)) + . const + $ do + watches <- readIORef (monWatches monitor) + traverse_ stop watches + where + stop (wd, _) = do + -- ignore exceptions when removing watches + embed . void . try @IOException $ removeWatch wd + Log.debug $ + Log.msg ("stopped watching file" :: Text) + . Log.field "descriptor" (show wd) + +mkMonitor :: + ( Members '[TinyLog, Embed IO] r, + Members '[TinyLog, Embed IO, Polysemy.Error FederationSetupError] r1 + ) => + (Sem r1 () -> IO ()) -> + IORef TLSSettings -> + RunSettings -> + Sem r Monitor +mkMonitor runSem tlsVar rs = do + inotify <- embed initINotify + Log.debug $ + Log.msg ("inotify initialized" :: Text) + . Log.field "inotify" (show inotify) + + lock <- embed @IO $ newMVar () + watchesVar <- embed @IO $ newIORef mempty + + let monitor = + Monitor + { monINotify = inotify, + monTLS = tlsVar, + monWatches = watchesVar, + monSettings = rs, + monHandler = handleEvent runSem monitor, + monLock = lock + } + + paths <- embed $ certificateWatchPaths rs + traverse_ (addWatchedFile monitor) (toList paths) + pure monitor + +data Action = ReplaceWatch RawFilePath | ReloadSettings + deriving (Eq, Ord, Show) + +handleEvent :: + Members '[TinyLog, Embed IO, Polysemy.Error FederationSetupError] r => + (Sem r () -> IO ()) -> + Monitor -> + WatchedPath -> + Event -> + IO () +handleEvent runSem monitor wpath e = do + let actions = getActions wpath e + -- only use runSem when there are some actions + -- this makes it possible to use a special runSem in the tests that is able + -- to detect when some action has taken place + unless (null actions) $ + -- we take the lock here, so that handlers never execute concurrently + withMVar (monLock monitor) $ \_ -> + runSem $ traverse_ (applyAction monitor) actions + +-- Note: it is important that the watch is replaced *before* settings are +-- reloaded, otherwise there is a window of time (after reloading settings, +-- but before the new watch is set) where changes to the settings can go +-- undetected +getActions :: WatchedPath -> Event -> [Action] +getActions (WatchedFile path) (Closed _ mpath True) + | maybe True (== path) mpath = [ReloadSettings] +getActions (WatchedDir dir paths) (MovedIn _ path _) + | Set.member path paths = [ReplaceWatch (dir <> "/" <> path), ReloadSettings] +getActions (WatchedDir dir paths) (Created _ path) + | Set.member path paths = [ReplaceWatch (dir <> "/" <> path), ReloadSettings] +getActions _ _ = [] + +applyAction :: + (Members '[TinyLog, Embed IO, Polysemy.Error FederationSetupError] r) => + Monitor -> + Action -> + Sem r () +applyAction monitor ReloadSettings = do + tls' <- mkTLSSettings (monSettings monitor) + Log.info $ Log.msg ("updating TLS settings" :: Text) + embed @IO $ atomicWriteIORef (monTLS monitor) tls' +applyAction monitor (ReplaceWatch path) = do + watches <- readIORef (monWatches monitor) + case Map.lookup path watches of + Nothing -> pure () + Just (_, wpath) -> do + addWatchedFile monitor wpath + case wpath of + WatchedDir dir paths -> + traverse_ (applyAction monitor . ReplaceWatch . ((dir <> "/") <>)) paths + WatchedFile _ -> pure () + +addWatchedFile :: + Members '[TinyLog, Embed IO] r => + Monitor -> + WatchedPath -> + Sem r () +addWatchedFile monitor wpath = do + r <- + embed . try @SomeException $ + addWatchAndSave + (monINotify monitor) + (watchPathEvents wpath) + (monWatches monitor) + wpath + (monHandler monitor wpath) + let pathText = Text.decodeUtf8With Text.lenientDecode (watchedPath wpath) + case r of + Right w -> + Log.debug $ + Log.msg ("watching file" :: Text) + . Log.field "descriptor" (show w) + . Log.field "path" pathText + Left e -> do + Log.err $ + Log.msg ("error while try to add file watch" :: Text) + . Log.field "path" pathText + . Log.field "error" (displayException e) + +addWatchAndSave :: + INotify -> + [EventVariety] -> + IORef Watches -> + WatchedPath -> + (Event -> IO ()) -> + IO WatchDescriptor +addWatchAndSave inotify events watchesVar wpath handler = do + let path = watchedPath wpath + -- create a new watch + w' <- addWatch inotify events path handler + -- atomically save it in the map, and return the old one + mw <- + atomicModifyIORef watchesVar $ + swap . Map.alterF (,Just (w', wpath)) path + -- remove the old watch + case mw of + Nothing -> pure () + Just (w, _) -> void . try @IOException $ removeWatch w + pure w' + +certificatePaths :: RunSettings -> [FilePath] +certificatePaths rs = + maybeToList (remoteCAStore rs) + ++ [ clientCertificate rs, + clientPrivateKey rs + ] + +certificateWatchPaths :: RunSettings -> IO (Set WatchedPath) +certificateWatchPaths = + fmap (mergePaths . concat) + . traverse (watchedPaths resolveSymlink) + . certificatePaths + +resolveSymlink :: FilePath -> IO (Maybe FilePath) +resolveSymlink path' = do + let path = dropTrailingPathSeparator path' + status <- getSymbolicLinkStatus path + if isSymbolicLink status + then do + target <- readSymbolicLink path + pure . Just $ + if isRelative target + then takeDirectory path target + else target + else pure Nothing + +watchedPaths :: (FilePath -> IO (Maybe FilePath)) -> FilePath -> IO [WatchedPath] +watchedPaths resolve path' = do + path <- makeAbsolute path' + rpath <- rawPath path + dirs <- watchedDirs resolve path + pure $ WatchedFile rpath : dirs + +watchedDirs :: (FilePath -> IO (Maybe FilePath)) -> FilePath -> IO [WatchedPath] +watchedDirs resolve path = do + dirs0 <- resolve path >>= maybe (pure []) (watchedDirs resolve) + let (dir, base) = splitFileName (dropTrailingPathSeparator path) + dirs1 <- + if dir == path + then pure [] -- base case: root directory + else do + wds <- watchedDirs resolve dir + rdir <- rawPath (dropTrailingPathSeparator dir) + rbase <- rawPath base + pure $ WatchedDir rdir (Set.singleton rbase) : wds + pure (dirs0 ++ dirs1) + +data FederationSetupError + = InvalidCAStore FilePath + | InvalidClientCertificate String + deriving (Show) + +instance Exception FederationSetupError + +showFederationSetupError :: FederationSetupError -> Text +showFederationSetupError (InvalidCAStore path) = "invalid CA store: " <> Text.pack path +showFederationSetupError (InvalidClientCertificate msg) = Text.pack msg + +mkTLSSettings :: + Members '[Embed IO, Polysemy.Error FederationSetupError] r => + RunSettings -> + Sem r TLSSettings +mkTLSSettings settings = + TLSSettings + <$> mkCAStore settings + <*> mkCreds settings + +mkCAStore :: + Members '[Embed IO, Polysemy.Error FederationSetupError] r => + RunSettings -> + Sem r CertificateStore +mkCAStore settings = do + customCAStore <- fmap (fromRight mempty) . Polysemy.runError @() $ do + path <- maybe (Polysemy.throw ()) pure $ remoteCAStore settings + embed (readCertificateStore path) + >>= maybe (Polysemy.throw (InvalidCAStore path)) pure + systemCAStore <- + if useSystemCAStore settings + then embed getSystemCertificateStore + else pure mempty + pure (customCAStore <> systemCAStore) + +mkCreds :: + Members '[Embed IO, Polysemy.Error FederationSetupError] r => + RunSettings -> + Sem r TLS.Credential +mkCreds settings = do + creds <- + Polysemy.fromExceptionVia + @SomeException + (InvalidClientCertificate . displayException) + $ TLS.credentialLoadX509 + (clientCertificate settings) + (clientPrivateKey settings) + case creds of + Left e -> Polysemy.throw (InvalidClientCertificate e) + Right (X509.CertificateChain [], _) -> + Polysemy.throw + ( InvalidClientCertificate + "could not read client certificate" + ) + Right x -> pure x diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 13ea7d5c7c..38e6a143f9 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -46,6 +46,7 @@ import Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS import Polysemy import qualified Polysemy.Error as Polysemy +import qualified Polysemy.Input as Polysemy import qualified Polysemy.Reader as Polysemy import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log @@ -71,7 +72,7 @@ interpretRemote :: DiscoverFederator, TinyLog, Polysemy.Reader RunSettings, - Polysemy.Reader TLSSettings + Polysemy.Input TLSSettings ] r => Sem (Remote ': r) a -> @@ -116,7 +117,7 @@ mkGrpcClient :: Members '[ Embed IO, Polysemy.Error RemoteError, - Polysemy.Reader TLSSettings + Polysemy.Input TLSSettings ] r => SrvTarget -> @@ -127,7 +128,7 @@ mkGrpcClient target@(SrvTarget host port) = do -- let cfg = grpcClientConfigSimple (cs host) (fromInteger $ toInteger port) True - settings <- Polysemy.ask + settings <- Polysemy.input let tlsConfig = (defaultParamsClient (cs host) (cs $ show port)) diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs index ddae51d8f1..bd0e786eee 100644 --- a/services/federator/src/Federator/Run.hs +++ b/services/federator/src/Federator/Run.hs @@ -26,33 +26,29 @@ module Federator.Run -- * App Environment newEnv, - mkTLSSettings, - FederationSetupError (..), closeEnv, + + -- * Re-exports + mkTLSSettingsOrThrow, + FederationSetupError (..), ) where import qualified Bilge as RPC -import Control.Exception (handle, throw) import Control.Lens ((^.)) import Data.Default (def) import qualified Data.Metrics.Middleware as Metrics import Data.Text.Encoding (encodeUtf8) -import qualified Data.X509 as X509 -import Data.X509.CertificateStore import Federator.Env import Federator.ExternalServer (serveInward) import Federator.InternalServer (serveOutward) +import Federator.Monitor import Federator.Options as Opt import Imports import qualified Network.DNS as DNS import qualified Network.HTTP.Client as HTTP -import qualified Network.TLS as TLS -import qualified Polysemy -import qualified Polysemy.Error as Polysemy import qualified System.Logger.Class as Log import qualified System.Logger.Extended as LogExt -import System.X509 import UnliftIO (bracket) import UnliftIO.Async (async, waitAnyCancel) import Util.Options @@ -74,9 +70,10 @@ run opts = do bracket (newEnv opts res) closeEnv $ \env -> do let externalServer = serveInward env portExternal internalServer = serveOutward env portInternal - internalServerThread <- async internalServer - externalServerThread <- async externalServer - void $ waitAnyCancel [internalServerThread, externalServerThread] + withMonitor (env ^. applog) (env ^. tls) (optSettings opts) $ do + internalServerThread <- async internalServer + externalServerThread <- async externalServer + void $ waitAnyCancel [internalServerThread, externalServerThread] where endpointInternal = federatorInternal opts portInternal = fromIntegral $ endpointInternal ^. epPort @@ -96,13 +93,6 @@ run opts = do ------------------------------------------------------------------------------- -- Environment -data FederationSetupError - = InvalidCAStore FilePath - | InvalidClientCertificate String - deriving (Show) - -instance Exception FederationSetupError - newEnv :: Opts -> DNS.Resolver -> IO Env newEnv o _dnsResolver = do _metrics <- Metrics.metrics @@ -112,41 +102,11 @@ newEnv o _dnsResolver = do let _service Brig = mkEndpoint (Opt.brig o) _service Galley = mkEndpoint (Opt.galley o) _httpManager <- initHttpManager - _tls <- mkTLSSettings _runSettings + _tls <- mkTLSSettingsOrThrow _runSettings >>= newIORef return Env {..} where mkEndpoint s = RPC.host (encodeUtf8 (s ^. epHost)) . RPC.port (s ^. epPort) $ RPC.empty -mkCAStore :: RunSettings -> IO CertificateStore -mkCAStore settings = do - customCAStore <- fmap (fromRight mempty) . Polysemy.runM . Polysemy.runError @() $ do - path <- maybe (Polysemy.throw ()) pure $ remoteCAStore settings - Polysemy.embed $ readCertificateStore path >>= maybe (throw $ InvalidCAStore path) pure - systemCAStore <- - if useSystemCAStore settings - then getSystemCertificateStore - else pure mempty - pure (customCAStore <> systemCAStore) - -mkCreds :: RunSettings -> IO TLS.Credential -mkCreds settings = - handle h $ - TLS.credentialLoadX509 (clientCertificate settings) (clientPrivateKey settings) - >>= \case - Left e -> throw (InvalidClientCertificate e) - Right (X509.CertificateChain [], _) -> - throw (InvalidClientCertificate "could not read client certificate") - Right x -> pure x - where - h :: IOException -> IO a - h = throw . InvalidClientCertificate . show - -mkTLSSettings :: RunSettings -> IO TLSSettings -mkTLSSettings settings = - TLSSettings - <$> mkCAStore settings - <*> mkCreds settings - closeEnv :: Env -> IO () closeEnv e = do Log.flush $ e ^. applog diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 5d0fe91845..8d87ff53fa 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -36,6 +36,7 @@ import Network.GRPC.Client.Helpers (_grpcClientConfigTLS) import qualified Network.TLS as TLS import qualified Polysemy import qualified Polysemy.Error as Polysemy +import qualified Polysemy.Input as Polysemy import qualified Polysemy.Reader as Polysemy import Polysemy.TinyLog (discardLogs) import Test.Federator.Util @@ -108,7 +109,7 @@ inwardBrigCallViaIngress requestPath payload = do . Polysemy.runM . Polysemy.runError @RemoteError . discardLogs - . Polysemy.runReader tlsSettings + . Polysemy.runInputConst tlsSettings . Polysemy.runReader runSettings $ mkGrpcClient target client <- case c of diff --git a/services/federator/test/integration/Test/Federator/Util.hs b/services/federator/test/integration/Test/Federator/Util.hs index fd052265cf..bf7835bcda 100644 --- a/services/federator/test/integration/Test/Federator/Util.hs +++ b/services/federator/test/integration/Test/Federator/Util.hs @@ -45,7 +45,7 @@ import qualified Data.UUID.V4 as UUID import qualified Data.Yaml as Yaml import Federator.Env (TLSSettings (..)) import Federator.Options -import Federator.Run (mkTLSSettings) +import Federator.Run (mkTLSSettingsOrThrow) import Imports import Mu.GRpc.Client.TyApps import qualified Options.Applicative as OPA @@ -144,7 +144,7 @@ mkEnv :: HasCallStack => IntegrationConfig -> Opts -> IO TestEnv mkEnv _teTstOpts _teOpts = do _teMgr :: Manager <- newManager defaultManagerSettings let _teBrig = endpointToReq (cfgBrig _teTstOpts) - _teTLSSettings <- mkTLSSettings (optSettings _teOpts) + _teTLSSettings <- mkTLSSettingsOrThrow (optSettings _teOpts) pure TestEnv {..} destroyEnv :: HasCallStack => TestEnv -> IO () diff --git a/services/federator/test/unit/Main.hs b/services/federator/test/unit/Main.hs index 65efc215a7..7cd09476a6 100644 --- a/services/federator/test/unit/Main.hs +++ b/services/federator/test/unit/Main.hs @@ -23,6 +23,7 @@ where import Imports import qualified Test.Federator.ExternalServer import qualified Test.Federator.InternalServer +import qualified Test.Federator.Monitor import qualified Test.Federator.Options import qualified Test.Federator.Remote import qualified Test.Federator.Validation as Validation @@ -37,5 +38,6 @@ main = Validation.tests, Test.Federator.InternalServer.tests, Test.Federator.ExternalServer.tests, + Test.Federator.Monitor.tests, Test.Federator.Remote.tests ] diff --git a/services/federator/test/unit/Test/Federator/Monitor.hs b/services/federator/test/unit/Test/Federator/Monitor.hs new file mode 100644 index 0000000000..8abf5f5c14 --- /dev/null +++ b/services/federator/test/unit/Test/Federator/Monitor.hs @@ -0,0 +1,437 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Federator.Monitor (tests) where + +import Control.Concurrent.Chan +import Control.Exception (bracket) +import Control.Lens (view) +import Control.Monad.Trans.Cont +import qualified Data.Set as Set +import Data.X509 (CertificateChain (..)) +import Federator.Env (TLSSettings (..), creds) +import Federator.Monitor +import Federator.Monitor.Internal +import Federator.Options +import Imports +import qualified Polysemy +import qualified Polysemy.Error as Polysemy +import qualified Polysemy.TinyLog as Polysemy +import System.FilePath +import System.IO.Temp +import System.Posix (createSymbolicLink, getWorkingDirectory) +import System.Timeout +import Test.Federator.Options (defRunSettings) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +timeoutMicroseconds :: Int +timeoutMicroseconds = 1000000 + +tests :: TestTree +tests = + testGroup + "Federator.Monitor" + [ testMonitorChangeUpdate, + testMonitorReplacedChangeUpdate, + testMonitorOverwriteUpdate, + testMonitorSymlinkUpdate, + testMonitorNestedUpdate, + testMonitorKubernetesUpdate, + testMonitorDeepUpdate, + testMonitorError, + testMergeWatchedPaths, + testDirectoryTraversal + ] + +tempFile :: FilePath -> String -> ContT r IO FilePath +tempFile dir template = + ContT $ \k -> withTempFile dir template (const . k) + +withSettings :: ContT r IO RunSettings +withSettings = do + dir <- liftIO getCanonicalTemporaryDirectory + cert <- tempFile dir "cert.pem" + liftIO $ copyFile "test/resources/unit/localhost.pem" cert + key <- tempFile dir "key.pem" + liftIO $ copyFile "test/resources/unit/localhost-key.pem" key + pure $ defRunSettings cert key + +withSymlinkSettings :: ContT r IO RunSettings +withSymlinkSettings = do + settings <- withSettings + dir <- ContT $ withSystemTempDirectory "conf" + liftIO $ createSymbolicLink (clientCertificate settings) (dir "cert.pem") + liftIO $ createSymbolicLink (clientPrivateKey settings) (dir "key.pem") + pure $ + settings + { clientCertificate = dir "cert.pem", + clientPrivateKey = dir "key.pem" + } + +withNestedSettings :: Int -> ContT r IO RunSettings +withNestedSettings n = do + root <- ContT $ withSystemTempDirectory "conf" + liftIO $ do + forM_ [1 .. n] $ \i -> do + let path = concat ["d" ++ show j ++ "/" | j <- [1 .. i]] + createDirectory (root path) + let dir = root concat ["d" ++ show j ++ "/" | j <- [1 .. n]] + cert = dir "cert.pem" + key = dir "key.pem" + copyFile "test/resources/unit/localhost.pem" cert + copyFile "test/resources/unit/localhost-key.pem" key + pure $ defRunSettings cert key + +withKubernetesSettings :: ContT r IO RunSettings +withKubernetesSettings = do + root <- ContT $ withSystemTempDirectory "secrets" + liftIO $ do + createDirectory (root "..foo") + copyFile "test/resources/unit/localhost.pem" (root "..foo/cert.pem") + copyFile "test/resources/unit/localhost-key.pem" (root "..foo/key.pem") + + createSymbolicLink (root "..foo") (root "..data") + createSymbolicLink (root "..data/cert.pem") (root "cert.pem") + createSymbolicLink (root "..data/key.pem") (root "key.pem") + pure $ defRunSettings (root "cert.pem") (root "key.pem") + +withSilentMonitor :: + Chan (Maybe FederationSetupError) -> + RunSettings -> + ContT r IO (IORef TLSSettings) +withSilentMonitor reloads settings = do + tlsVar <- liftIO $ newIORef (error "TLSSettings not updated before being read") + void . ContT $ + bracket + (runSem (mkMonitor runSemE tlsVar settings)) + (runSem . delMonitor) + pure tlsVar + where + runSem = Polysemy.runM . Polysemy.discardLogs + runSemE action = do + r <- runSem (Polysemy.runError @FederationSetupError action) + writeChan reloads (either Just (const Nothing) r) + +testMonitorChangeUpdate :: TestTree +testMonitorChangeUpdate = + testCase "monitor updates settings on file change" $ do + reloads <- newChan + evalContT $ do + settings <- withSettings + tlsVar <- withSilentMonitor reloads settings + liftIO $ do + appendFile (clientCertificate settings) "" + result <- timeout timeoutMicroseconds (readChan reloads) + case result of + Nothing -> assertFailure "certificate not updated within the allotted time" + Just (Just err) -> + assertFailure + ("unexpected exception " <> displayException err) + _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () + +testMonitorReplacedChangeUpdate :: TestTree +testMonitorReplacedChangeUpdate = + testCase "monitor updates settings on file changed after being replaced" $ do + reloads <- newChan + evalContT $ do + settings <- withSettings + tlsVar <- withSilentMonitor reloads settings + liftIO $ do + -- first replace file with a different one + copyFile + "test/resources/unit/localhost-dot.pem" + (clientCertificate settings) + result1 <- timeout timeoutMicroseconds (readChan reloads) + case result1 of + Nothing -> + assertFailure + "certificate not updated once within the allotted time" + Just (Just err) -> + assertFailure + ("unexpected exception " <> displayException err) + _ -> pure () + -- now modify the replaced file + appendFile (clientCertificate settings) "" + result2 <- timeout timeoutMicroseconds (readChan reloads) + case result2 of + Nothing -> + assertFailure + "certificate not updated twice within the allotted time" + Just (Just err) -> + assertFailure + ("unexpected exception " <> displayException err) + _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () + +testMonitorOverwriteUpdate :: TestTree +testMonitorOverwriteUpdate = + testCase "monitor updates settings on file being replaced" $ do + reloads <- newChan + evalContT $ do + settings <- withSettings + tlsVar <- withSilentMonitor reloads settings + liftIO $ do + copyFile + "test/resources/unit/localhost-dot.pem" + (clientCertificate settings) + result <- timeout timeoutMicroseconds (readChan reloads) + case result of + Nothing -> assertFailure "certificate not updated within the allotted time" + Just (Just err) -> + assertFailure + ("unexpected exception " <> displayException err) + _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () + +testMonitorSymlinkUpdate :: TestTree +testMonitorSymlinkUpdate = + testCase "monitor updates settings symlink swap" $ do + reloads <- newChan + evalContT $ do + settings <- withSymlinkSettings + tlsVar <- withSilentMonitor reloads settings + liftIO $ do + removeFile (clientCertificate settings) + wd <- getWorkingDirectory + createSymbolicLink + (wd "test/resources/unit/localhost-dot.pem") + (clientCertificate settings) + result <- timeout timeoutMicroseconds (readChan reloads) + case result of + Nothing -> assertFailure "certificate not updated within the allotted time" + Just (Just err) -> + assertFailure + ("unexpected exception " <> displayException err) + _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () + +testMonitorNestedUpdate :: TestTree +testMonitorNestedUpdate = + testCase "monitor updates when parent directory is replaced" $ do + reloads <- newChan + evalContT $ do + settings <- withNestedSettings 1 + tlsVar <- withSilentMonitor reloads settings + liftIO $ do + -- make a new directory with other credentials + let parent = takeDirectory (clientCertificate settings) + root = takeDirectory parent + createDirectory (root "a1") + let cert = root "a1/cert.pem" + key = root "a1/key.pem" + copyFile "test/resources/unit/localhost-dot.pem" cert + copyFile "test/resources/unit/localhost-dot-key.pem" key + + -- replace the old directory with the new one + renameDirectory (root "d1") (root "b1") + renameDirectory (root "a1") (root "d1") + + result <- timeout timeoutMicroseconds (readChan reloads) + case result of + Nothing -> assertFailure "certificate not updated within the allotted time" + Just (Just err) -> + assertFailure + ("unexpected exception " <> displayException err) + _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () + +testMonitorDeepUpdate :: TestTree +testMonitorDeepUpdate = + testCase "monitor updates when grandparent directory is replaced" $ do + reloads <- newChan + evalContT $ do + settings <- withNestedSettings 2 + tlsVar <- withSilentMonitor reloads settings + liftIO $ do + -- make a new directory with other credentials + let root = takeDirectory (takeDirectory (takeDirectory (clientCertificate settings))) + createDirectory (root "a1") + createDirectory (root "a1/d2") + let cert = root "a1/d2/cert.pem" + key = root "a1/d2/key.pem" + copyFile "test/resources/unit/localhost-dot.pem" cert + copyFile "test/resources/unit/localhost-dot-key.pem" key + + -- replace the old directory with the new one + renameDirectory (root "d1") (root "b1") + renameDirectory (root "a1") (root "d1") + + timeout timeoutMicroseconds (readChan reloads) >>= \case + Nothing -> assertFailure "certificate not updated once within the allotted time" + Just (Just err) -> + assertFailure + ("unexpected exception " <> displayException err) + _ -> pure () + + -- test that further changes are seen + appendFile (clientCertificate settings) "" + timeout timeoutMicroseconds (readChan reloads) >>= \case + Nothing -> assertFailure "certificate not updated twice within the allotted time" + Just (Just err) -> + assertFailure + ("unexpected exception " <> displayException err) + _ -> pure () + + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () + +testMonitorKubernetesUpdate :: TestTree +testMonitorKubernetesUpdate = do + testCase "monitor updates on a kubernetes secret mount" $ do + reloads <- newChan + evalContT $ do + settings <- withKubernetesSettings + tlsVar <- withSilentMonitor reloads settings + liftIO $ do + let root = takeDirectory (clientCertificate settings) + createDirectory (root "..foo2") + copyFile "test/resources/unit/localhost-dot.pem" (root "..foo2/cert.pem") + copyFile "test/resources/unit/localhost-dot-key.pem" (root "..foo2/key.pem") + + removeFile (root "..data") + createSymbolicLink (root "..foo2") (root "..data") + + timeout timeoutMicroseconds (readChan reloads) >>= \case + Nothing -> assertFailure "certificate not updated once within the allotted time" + Just (Just err) -> + assertFailure + ("unexpected exception " <> displayException err) + _ -> pure () + + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () + +testMonitorError :: TestTree +testMonitorError = + testCase "monitor returns an error when settings cannot be updated" $ do + reloads <- newChan + evalContT $ do + settings <- withSettings + _ <- withSilentMonitor reloads settings + liftIO $ do + writeFile (clientCertificate settings) "not a certificate" + result <- timeout timeoutMicroseconds (readChan reloads) + case result of + Nothing -> assertFailure "no error returned within the allotted time" + Just Nothing -> assertFailure "unexpected success" + _ -> pure () + +testMergeWatchedPaths :: TestTree +testMergeWatchedPaths = + testGroup + "merged paths" + [ testProperty "contain the same files" $ \(wpaths :: [WatchedPath]) -> + let f (WatchedFile path) = [path] + f (WatchedDir _ _) = [] + mergedFiles = Set.fromList (Set.toList (mergePaths wpaths) >>= f) + origFiles = Set.fromList (wpaths >>= f) + in mergedFiles == origFiles, + testProperty "contain the same directories" $ \(wpaths :: [WatchedPath]) -> + let f (WatchedFile _) = [] + f (WatchedDir dir _) = [dir] + mergedDirs = Set.fromList (Set.toList (mergePaths wpaths) >>= f) + origDirs = Set.fromList (wpaths >>= f) + in mergedDirs == origDirs, + testProperty "has no duplicated directories" $ \(wpaths :: [WatchedPath]) -> + let f (WatchedFile _) = [] + f (WatchedDir dir _) = [dir] + mergedDirList = Set.toList (mergePaths wpaths) >>= f + mergedDirs = Set.fromList mergedDirList + in Set.size mergedDirs == length mergedDirList, + testProperty "has lower total count" $ \(wpaths :: [WatchedPath]) -> + let f (WatchedFile _) = 1 + f (WatchedDir _ files) = Set.size files + mergedCount = sum $ map f (Set.toList (mergePaths wpaths)) + origCount = sum (map f wpaths) + in mergedCount <= origCount, + testProperty "has the same paths" $ \(wpaths :: [WatchedPath]) -> + let f (WatchedFile path) = [path] + f (WatchedDir dir files) = map (dir <>) (Set.toList files) + mergedPaths = Set.fromList (Set.toList (mergePaths wpaths) >>= f) + origPaths = Set.fromList (wpaths >>= f) + in mergedPaths == origPaths + ] + +newtype Path = Path {getPath :: FilePath} + +instance Show Path where + show = show . getPath + +instance Arbitrary Path where + arbitrary = Path . intercalate "/" <$> listOf (listOf1 ch) + where + ch = arbitrary `suchThat` (/= '/') + +trivialResolve :: FilePath -> IO (Maybe FilePath) +trivialResolve _ = pure Nothing + +testDirectoryTraversal :: TestTree +testDirectoryTraversal = + testGroup + "directory traversal" + [ testProperty "the number of entries is the same as the number of path components" $ + \(path' :: Path) -> ioProperty $ do + path <- makeAbsolute ("/" <> getPath path') + wpaths <- watchedPaths trivialResolve path + pure (length wpaths == length (splitPath path)), + testProperty "relative paths are resolved correctly" $ + \(path' :: Path) -> ioProperty $ do + dir <- getWorkingDirectory + let path = getPath path' + wpaths <- watchedPaths trivialResolve path + wpaths' <- watchedPaths trivialResolve (dir path) + pure $ wpaths == wpaths', + testCase "symlinked paths are resolved" $ + evalContT $ do + settings <- withKubernetesSettings + liftIO $ do + rroot <- rawPath $ takeDirectory (clientCertificate settings) + wpaths <- mergePaths <$> watchedPaths resolveSymlink (clientCertificate settings) + assertBool "symlink targets should be watched" $ + Set.member + (WatchedDir rroot (Set.fromList ["cert.pem", "..data", "..foo"])) + wpaths + ] diff --git a/services/federator/test/unit/Test/Federator/Options.hs b/services/federator/test/unit/Test/Federator/Options.hs index 6e23016abf..3bf5930a2d 100644 --- a/services/federator/test/unit/Test/Federator/Options.hs +++ b/services/federator/test/unit/Test/Federator/Options.hs @@ -131,7 +131,7 @@ testSettings = allowAll: null clientCertificate: test/resources/unit/localhost.pem clientPrivateKey: test/resources/unit/localhost-key.pem|] - void (mkTLSSettings settings), + void (mkTLSSettingsOrThrow settings), testCase "fail on missing client credentials" $ assertParseFailure @RunSettings . B8.pack $ [QQ.i| @@ -161,7 +161,7 @@ testSettings = allowAll: null clientCertificate: non-existent clientPrivateKey: non-existent|] - try @FederationSetupError (mkTLSSettings settings) >>= \case + try @FederationSetupError (mkTLSSettingsOrThrow settings) >>= \case Left (InvalidClientCertificate _) -> pure () Left e -> assertFailure $ @@ -183,7 +183,7 @@ testSettings = allowAll: null clientCertificate: test/resources/unit/invalid.pem clientPrivateKey: test/resources/unit/localhost-key.pem|] - try @FederationSetupError (mkTLSSettings settings) >>= \case + try @FederationSetupError (mkTLSSettingsOrThrow settings) >>= \case Left (InvalidClientCertificate _) -> pure () Left e -> assertFailure $ @@ -205,7 +205,7 @@ testSettings = allowAll: null clientCertificate: test/resources/unit/localhost.pem clientPrivateKey: test/resources/unit/invalid.pem|] - try @FederationSetupError (mkTLSSettings settings) >>= \case + try @FederationSetupError (mkTLSSettingsOrThrow settings) >>= \case Left (InvalidClientCertificate _) -> pure () Left e -> assertFailure $ diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index abdc59039e..618c78dc85 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -1,11 +1,28 @@ {-# LANGUAGE NumericUnderscores #-} +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + module Test.Federator.Remote where import Data.Streaming.Network (bindRandomPortTCP) import Federator.Options import Federator.Remote -import Federator.Run (mkTLSSettings) +import Federator.Run (mkTLSSettingsOrThrow) import Imports import Network.HTTP.Types (status200) import Network.Wai @@ -13,7 +30,7 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WarpTLS as WarpTLS import Polysemy import qualified Polysemy.Error as Polysemy -import qualified Polysemy.Reader as Polysemy +import qualified Polysemy.Input as Polysemy import Test.Federator.Options (defRunSettings) import Test.Tasty import Test.Tasty.HUnit @@ -58,20 +75,20 @@ testValidatesCertificateSuccess = "can get response with valid certificate" [ testCase "when hostname=localhost and certificate-for=localhost" $ do bracket (startMockServer certForLocalhost) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do - tlsSettings <- mkTLSSettings settings - void . Polysemy.runM . assertNoError @RemoteError . Polysemy.runReader tlsSettings $ mkGrpcClient (SrvTarget "localhost" (fromIntegral port)), + tlsSettings <- mkTLSSettingsOrThrow settings + void . Polysemy.runM . assertNoError @RemoteError . Polysemy.runInputConst tlsSettings $ mkGrpcClient (SrvTarget "localhost" (fromIntegral port)), testCase "when hostname=localhost. and certificate-for=localhost" $ do bracket (startMockServer certForLocalhost) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do - tlsSettings <- mkTLSSettings settings - void . Polysemy.runM . assertNoError @RemoteError . Polysemy.runReader tlsSettings $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)), + tlsSettings <- mkTLSSettingsOrThrow settings + void . Polysemy.runM . assertNoError @RemoteError . Polysemy.runInputConst tlsSettings $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)), -- This is a limitation of the TLS library, this test just exists to document that. testCase "when hostname=localhost. and certificate-for=localhost." $ do bracket (startMockServer certForLocalhostDot) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do - tlsSettings <- mkTLSSettings settings + tlsSettings <- mkTLSSettingsOrThrow settings eitherClient <- Polysemy.runM . Polysemy.runError @RemoteError - . Polysemy.runReader tlsSettings + . Polysemy.runInputConst tlsSettings $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) case eitherClient of Left _ -> pure () @@ -84,11 +101,11 @@ testValidatesCertificateWrongHostname = "refuses to connect with server" [ testCase "when the server's certificate doesn't match the hostname" $ bracket (startMockServer certForWrongDomain) (Async.cancel . fst) $ \(_, port) -> do - tlsSettings <- mkTLSSettings settings + tlsSettings <- mkTLSSettingsOrThrow settings eitherClient <- Polysemy.runM . Polysemy.runError - . Polysemy.runReader tlsSettings + . Polysemy.runInputConst tlsSettings $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) case eitherClient of Left (RemoteErrorTLSException _ _) -> pure () @@ -117,7 +134,7 @@ startMockServer tlsSettings = liftIO $ do app _req respond = respond $ responseLBS status200 [] "dragons be here" serverThread <- Async.async $ WarpTLS.runTLSSocket tlsSettings wsettings sock app - serverStartedSignal <- timeout 10_000_000 (takeMVar serverStarted) + serverStartedSignal <- timeout 10_000_000 (readMVar serverStarted) case serverStartedSignal of Nothing -> do maybeException <- Async.poll serverThread diff --git a/stack.yaml b/stack.yaml index e39daebbcc..6a3b6f8b11 100644 --- a/stack.yaml +++ b/stack.yaml @@ -243,6 +243,12 @@ extra-deps: - git: https://github.com/wireapp/snappy commit: b0e5c08af48911caecffa4fa6a3e74872018b258 # master (Sep 03, 2021) +# Error handling fix: https://github.com/vincenthz/hs-certificate/pull/125 +- git: https://github.com/wireapp/hs-certificate + commit: e3ea2e1166f0569982a85aad9bc9de8f5b2994c1 # master (Aug 31, 2021) + subdirs: + - x509-store + ############################################################ # Development tools ############################################################ diff --git a/stack.yaml.lock b/stack.yaml.lock index e17149372d..ba806b6b8c 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -520,10 +520,10 @@ packages: original: hackage: tls-1.5.5 - completed: - hackage: cryptonite-0.28@sha256:b6c75e62b4c655d4cb1bcbb80d01430d136aac32bd6962c86c84738935cc8f9d,18195 + hackage: cryptonite-0.28@sha256:edf00c7b00b9a1c07a178c0fe446c6ebe462637d498590757c8eac2075bb0b43,18215 pantry-tree: size: 23132 - sha256: d80d7be9b1d0799a8e401ca5d4f4f424e0d8c42d4a30cc37bf6f82970232bfcf + sha256: 3737ee32d6629b4b915c01911fdb9dc0e255b96233799479c29420d986634726 original: hackage: cryptonite-0.28 - completed: @@ -796,6 +796,19 @@ packages: original: git: https://github.com/wireapp/snappy commit: b0e5c08af48911caecffa4fa6a3e74872018b258 +- completed: + subdir: x509-store + name: x509-store + version: 1.6.7 + git: https://github.com/wireapp/hs-certificate + pantry-tree: + size: 398 + sha256: 96deca9a5358118057cd145f198b5be06d88019eae46b263bee86c76b2fc574d + commit: e3ea2e1166f0569982a85aad9bc9de8f5b2994c1 + original: + subdir: x509-store + git: https://github.com/wireapp/hs-certificate + commit: e3ea2e1166f0569982a85aad9bc9de8f5b2994c1 - completed: hackage: ormolu-0.1.4.1@sha256:ed404eac6e4eb64da1ca5fb749e0f99907431a9633e6ba34e44d260e7d7728ba,6499 pantry-tree: