From f1682a7f126d4d56dfbb96bb8c8c5582abb22828 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Domen=20Ko=C5=BEar?= Date: Tue, 12 Nov 2019 12:48:05 +0100 Subject: [PATCH] servant-client-core: patch a security issue leaking authorization header --- .../haskell-modules/configuration-nix.nix | 6 +- ...rvant-client-core-redact-auth-header.patch | 75 +++++++++++++++++ .../servant-client-core-streamBody.patch | 82 ------------------- 3 files changed, 78 insertions(+), 85 deletions(-) create mode 100644 pkgs/development/haskell-modules/patches/servant-client-core-redact-auth-header.patch delete mode 100644 pkgs/development/haskell-modules/patches/servant-client-core-streamBody.patch diff --git a/pkgs/development/haskell-modules/configuration-nix.nix b/pkgs/development/haskell-modules/configuration-nix.nix index f729c3c8373d..5308296c8332 100644 --- a/pkgs/development/haskell-modules/configuration-nix.nix +++ b/pkgs/development/haskell-modules/configuration-nix.nix @@ -517,9 +517,9 @@ self: super: builtins.intersectAttrs super { # https://github.com/plow-technologies/servant-streaming/issues/12 servant-streaming-server = dontCheck super.servant-streaming-server; - # https://github.com/haskell-servant/servant/pull/1128 - servant-client-core = if (pkgs.lib.getVersion super.servant-client-core) == "0.15" then - appendPatch super.servant-client-core ./patches/servant-client-core-streamBody.patch + # https://github.com/haskell-servant/servant/pull/1238 + servant-client-core = if (pkgs.lib.getVersion super.servant-client-core) == "0.16" then + appendPatch super.servant-client-core ./patches/servant-client-core-redact-auth-header.patch else super.servant-client-core; diff --git a/pkgs/development/haskell-modules/patches/servant-client-core-redact-auth-header.patch b/pkgs/development/haskell-modules/patches/servant-client-core-redact-auth-header.patch new file mode 100644 index 000000000000..0f6a34f4f265 --- /dev/null +++ b/pkgs/development/haskell-modules/patches/servant-client-core-redact-auth-header.patch @@ -0,0 +1,75 @@ +diff --git a/servant-client-core.cabal b/servant-client-core.cabal +index 5789da601..3faf65bb4 100644 +--- a/servant-client-core.cabal ++++ b/servant-client-core.cabal +@@ -96,6 +96,7 @@ test-suite spec + main-is: Spec.hs + other-modules: + Servant.Client.Core.Internal.BaseUrlSpec ++ Servant.Client.Core.RequestSpec + + -- Dependencies inherited from the library. No need to specify bounds. + build-depends: +diff --git a/src/Servant/Client/Core/Request.hs b/src/Servant/Client/Core/Request.hs +index 73756e702..0276d46f8 100644 +--- a/src/Servant/Client/Core/Request.hs ++++ b/src/Servant/Client/Core/Request.hs +@@ -64,8 +64,32 @@ data RequestF body path = Request + , requestHeaders :: Seq.Seq Header + , requestHttpVersion :: HttpVersion + , requestMethod :: Method +- } deriving (Generic, Typeable, Eq, Show, Functor, Foldable, Traversable) ++ } deriving (Generic, Typeable, Eq, Functor, Foldable, Traversable) + ++instance (Show a, Show b) => ++ Show (Servant.Client.Core.Request.RequestF a b) where ++ showsPrec p req ++ = showParen ++ (p >= 11) ++ ( showString "Request {requestPath = " ++ . showsPrec 0 (requestPath req) ++ . showString ", requestQueryString = " ++ . showsPrec 0 (requestQueryString req) ++ . showString ", requestBody = " ++ . showsPrec 0 (requestBody req) ++ . showString ", requestAccept = " ++ . showsPrec 0 (requestAccept req) ++ . showString ", requestHeaders = " ++ . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)) ++ . showString ", requestHttpVersion = " ++ . showsPrec 0 (requestHttpVersion req) ++ . showString ", requestMethod = " ++ . showsPrec 0 (requestMethod req) ++ . showString "}" ++ where ++ redactSensitiveHeader :: Header -> Header ++ redactSensitiveHeader ("Authorization", _) = ("Authorization", "") ++ redactSensitiveHeader h = h + instance Bifunctor RequestF where bimap = bimapDefault + instance Bifoldable RequestF where bifoldMap = bifoldMapDefault + instance Bitraversable RequestF where +diff --git a/test/Servant/Client/Core/RequestSpec.hs b/test/Servant/Client/Core/RequestSpec.hs +new file mode 100644 +index 000000000..99a1db7d3 +--- /dev/null ++++ b/test/Servant/Client/Core/RequestSpec.hs +@@ -0,0 +1,19 @@ ++{-# OPTIONS_GHC -fno-warn-orphans #-} ++{-# LANGUAGE OverloadedStrings #-} ++module Servant.Client.Core.RequestSpec (spec) where ++ ++ ++import Prelude () ++import Prelude.Compat ++import Control.Monad ++import Data.List (isInfixOf) ++import Servant.Client.Core.Request ++import Test.Hspec ++ ++spec :: Spec ++spec = do ++ describe "Request" $ do ++ describe "show" $ do ++ it "redacts the authorization header" $ do ++ let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") } ++ isInfixOf "secret" (show request) `shouldBe` False diff --git a/pkgs/development/haskell-modules/patches/servant-client-core-streamBody.patch b/pkgs/development/haskell-modules/patches/servant-client-core-streamBody.patch deleted file mode 100644 index ebadd215cb76..000000000000 --- a/pkgs/development/haskell-modules/patches/servant-client-core-streamBody.patch +++ /dev/null @@ -1,82 +0,0 @@ -diff --git a/src/Servant/Client/Core/Internal/HasClient.hs b/src/Servant/Client/Core/Internal/HasClient.hs -index 712007006..6be92ec6d 100644 ---- a/src/Servant/Client/Core/Internal/HasClient.hs -+++ b/src/Servant/Client/Core/Internal/HasClient.hs -@@ -16,6 +16,8 @@ module Servant.Client.Core.Internal.HasClient where - import Prelude () - import Prelude.Compat - -+import Control.Concurrent.MVar -+ (modifyMVar, newMVar) - import qualified Data.ByteString as BS - import qualified Data.ByteString.Lazy as BL - import Data.Foldable -@@ -36,13 +38,14 @@ import qualified Network.HTTP.Types as H - import Servant.API - ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, - BuildHeadersTo (..), Capture', CaptureAll, Description, -- EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header', -- Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender), -+ EmptyAPI, FramingRender (..), FramingUnrender (..), -+ FromSourceIO (..), Header', Headers (..), HttpVersion, -+ IsSecure, MimeRender (mimeRender), - MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, - QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, - ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, -- Vault, Verb, WithNamedContext, contentType, getHeadersHList, -- getResponse, toQueryParam, toUrlPiece) -+ ToSourceIO (..), Vault, Verb, WithNamedContext, contentType, -+ getHeadersHList, getResponse, toQueryParam, toUrlPiece) - import Servant.API.ContentTypes - (contentTypes) - import Servant.API.Modifiers -@@ -538,7 +541,7 @@ instance (MimeRender ct a, HasClient m api) - hoistClientMonad pm (Proxy :: Proxy api) f (cl a) - - instance -- ( HasClient m api -+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a - ) => HasClient m (StreamBody' mods framing ctype a :> api) - where - -@@ -547,7 +550,39 @@ instance - hoistClientMonad pm _ f cl = \a -> - hoistClientMonad pm (Proxy :: Proxy api) f (cl a) - -- clientWithRoute _pm Proxy _req _body = error "HasClient @StreamBody" -+ clientWithRoute pm Proxy req body -+ = clientWithRoute pm (Proxy :: Proxy api) -+ $ setRequestBody (RequestBodyStreamChunked givesPopper) (contentType ctypeP) req -+ where -+ ctypeP = Proxy :: Proxy ctype -+ framingP = Proxy :: Proxy framing -+ -+ sourceIO = framingRender -+ framingP -+ (mimeRender ctypeP :: chunk -> BL.ByteString) -+ (toSourceIO body) -+ -+ -- not pretty. -+ givesPopper :: (IO BS.ByteString -> IO ()) -> IO () -+ givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do -+ ref <- newMVar step0 -+ -+ -- Note sure we need locking, but it's feels safer. -+ let popper :: IO BS.ByteString -+ popper = modifyMVar ref nextBs -+ -+ needsPopper popper -+ -+ nextBs S.Stop = return (S.Stop, BS.empty) -+ nextBs (S.Error err) = fail err -+ nextBs (S.Skip s) = nextBs s -+ nextBs (S.Effect ms) = ms >>= nextBs -+ nextBs (S.Yield lbs s) = case BL.toChunks lbs of -+ [] -> nextBs s -+ (x:xs) | BS.null x -> nextBs step' -+ | otherwise -> return (step', x) -+ where -+ step' = S.Yield (BL.fromChunks xs) s - - -