mirror of
https://github.com/ilyakooo0/nixpkgs.git
synced 2024-12-26 04:43:09 +03:00
servant-client-core: patch a security issue leaking authorization header
This commit is contained in:
Domen Kožar
parent
e10e7e68e9
commit
f1682a7f12
@ -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;
|
||||
|
||||
|
||||
@ -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