servant-client-core: patch a security issue leaking authorization header

This commit is contained in:
Domen Kožar 2019-11-12 12:48:05 +01:00
parent e10e7e68e9
commit f1682a7f12
No known key found for this signature in database
GPG key ID: C2FFBCAFD2C24246
3 changed files with 78 additions and 85 deletions

View file

@ -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;

View file

@ -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", "<REDACTED>")
+ 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

View file

@ -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