@@ -1,5 +1,6 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE LambdaCase #-}
34{-# LANGUAGE OverloadedStrings #-}
45{-# LANGUAGE RankNTypes #-}
56{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -77,14 +78,11 @@ spec = do
7778 NoReqBody
7879 jsonResponse
7980 (header "Foo" "bar" <> header "Baz" "quux")
80− stripFunnyHeaders (responseBody r)
81+ stripFunnyHeaders' (responseBody r)
8182 `shouldBe` object
82− [ "headers"
83− .= object
84− [ "Accept-Encoding" .= ("gzip" :: Text),
85− "Foo" .= ("bar" :: Text),
86− "Baz" .= ("quux" :: Text)
87− ]
83+ [ "Accept-Encoding" .= ("gzip" :: Text),
84+ "Foo" .= ("bar" :: Text),
85+ "Baz" .= ("quux" :: Text)
8886 ]
8987 responseStatusCode r `shouldBe` 200
9088 responseStatusMessage r `shouldBe` "OK"
@@ -383,19 +381,36 @@ stripOrigin value = value
383381
384382-- | Remove funny headers that might break the tests.
385383stripFunnyHeaders :: Value -> Value
386−stripFunnyHeaders (Object m) =
387− let f (Object p) = Object $ Aeson.KeyMap.filterWithKey (\k _ -> k `elem` hs) p
388− f value = value
389− hs =
390− [ "Content-Type",
391− "Accept-Encoding",
392− "Host",
393− "Content-Length",
394− "Foo",
395− "Baz"
396− ]
397− in Object (runIdentity (Aeson.KeyMap.alterF (pure . fmap f) "headers" m))
398−stripFunnyHeaders value = value
384+stripFunnyHeaders = \case
385+ Object m ->
386+ Object
387+ ( runIdentity
388+ ( Aeson.KeyMap.alterF
389+ (pure . fmap stripFunnyHeaders')
390+ "headers"
391+ m
392+ )
393+ )
394+ value -> value
395+
396+-- | Similar to 'stripFunnyHeaders', but acts directly on the argument
397+-- without trying to access its "headers" field.
398+stripFunnyHeaders' :: Value -> Value
399+stripFunnyHeaders' = \case
400+ Object p ->
401+ Object $
402+ Aeson.KeyMap.filterWithKey
403+ (\k _ -> k `elem` whitelistedHeaders)
404+ p
405+ value -> value
406+ where
407+ whitelistedHeaders =
408+ [ "Content-Type",
409+ "Accept-Encoding",
410+ "Content-Length",
411+ "Foo",
412+ "Baz"
413+ ]
399414
400415-- | This is a complete test case that makes use of <https://httpbun.org> to
401416-- get various response status codes.