servant-client-core: patch a security issue leaking authorization header
This commit is contained in:
parent
e10e7e68e9
commit
f1682a7f12
@ -517,9 +517,9 @@ self: super: builtins.intersectAttrs super {
|
|||||||
# https://github.com/plow-technologies/servant-streaming/issues/12
|
# https://github.com/plow-technologies/servant-streaming/issues/12
|
||||||
servant-streaming-server = dontCheck super.servant-streaming-server;
|
servant-streaming-server = dontCheck super.servant-streaming-server;
|
||||||
|
|
||||||
# https://github.com/haskell-servant/servant/pull/1128
|
# https://github.com/haskell-servant/servant/pull/1238
|
||||||
servant-client-core = if (pkgs.lib.getVersion super.servant-client-core) == "0.15" then
|
servant-client-core = if (pkgs.lib.getVersion super.servant-client-core) == "0.16" then
|
||||||
appendPatch super.servant-client-core ./patches/servant-client-core-streamBody.patch
|
appendPatch super.servant-client-core ./patches/servant-client-core-redact-auth-header.patch
|
||||||
else
|
else
|
||||||
super.servant-client-core;
|
super.servant-client-core;
|
||||||
|
|
||||||
|
@ -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
|
@ -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
|
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user