From 051339f3dcaca17844b923fe0b83ea46efbd0fc0 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:05:57 +0530 Subject: [PATCH 01/12] Add test code for HTTP headers properties --- yesod-core/test/YesodCoreTest/Header.hs | 62 +++++++++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 yesod-core/test/YesodCoreTest/Header.hs diff --git a/yesod-core/test/YesodCoreTest/Header.hs b/yesod-core/test/YesodCoreTest/Header.hs new file mode 100644 index 00000000..4a9f11dc --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Header.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, + TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} + +module YesodCoreTest.Header + ( headerTest + , Widget + , resourcesApp + ) where + +import Data.ByteString.Lazy (ByteString) +import qualified Data.Map as Map +import Data.Text (Text) +import Network.HTTP.Types (decodePathSegments, status200) +import Network.Wai +import Network.Wai.Test +import Test.Hspec +import Yesod.Core +import Yesod.Core.Handler + +data App = + App + +mkYesod + "App" + [parseRoutes| +/header1 Header1R GET +/header2 Header2R GET +|] + +instance Yesod App + +getHeader1R :: Handler RepPlain +getHeader1R = do + addHeader "hello" "world" + return $ RepPlain $ toContent ("header test" :: Text) + +getHeader2R :: Handler RepPlain +getHeader2R = do + addHeader "hello" "world" + replaceOrAddHeader "hello" "sibi" + return $ RepPlain $ toContent ("header test" :: Text) + +runner :: Session () -> IO () +runner f = toWaiApp App >>= runSession f + +addHeaderTest :: IO () +addHeaderTest = + runner $ do + res <- request defaultRequest {pathInfo = decodePathSegments "/header1"} + assertHeader "hello" "world" res + +multipleHeaderTest :: IO () +multipleHeaderTest = + runner $ do + res <- request defaultRequest {pathInfo = decodePathSegments "/header2"} + assertHeader "hello" "sibi" res + +headerTest :: Spec +headerTest = + describe "Test.Header" $ do + it "addHeader" addHeaderTest + it "multiple header" multipleHeaderTest From 301f4bc63027530a78eddbae9d27c153333cd3c4 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:07:13 +0530 Subject: [PATCH 02/12] Expose YesodCoreTest.Header module --- yesod-core/yesod-core.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index ae9569f3..7702a336 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -150,6 +150,7 @@ test-suite tests YesodCoreTest.Auth YesodCoreTest.Cache YesodCoreTest.CleanPath + YesodCoreTest.Header YesodCoreTest.Csrf YesodCoreTest.ErrorHandling YesodCoreTest.Exceptions From 839b56b032c388a92b0f07b80c07b13de7a8701c Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:10:54 +0530 Subject: [PATCH 03/12] Implement replaceOrAddHeader function --- yesod-core/Yesod/Core/Handler.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 0afced9a..4b580cc9 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -114,6 +114,7 @@ module Yesod.Core.Handler , deleteCookie , addHeader , setHeader + , replaceOrAddHeader , setLanguage -- ** Content caching and expiration , cacheSeconds @@ -787,6 +788,23 @@ setHeader :: MonadHandler m => Text -> Text -> m () setHeader = addHeader {-# DEPRECATED setHeader "Please use addHeader instead" #-} +replaceOrAddHeader :: MonadHandler m => Text -> Text -> m () +replaceOrAddHeader a b = + let header = Header (encodeUtf8 a) (encodeUtf8 b) + in modify $ \g -> g {ghsHeaders = replaceHeader header (ghsHeaders g)} + where + sameHeaderName :: Header -> Header -> Bool + sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2 + sameHeaderName _ _ = False + + replaceHeader :: Header -> Endo [Header] -> Endo [Header] + replaceHeader header endo = + let allHeaders :: [Header] = appEndo endo [] + in Endo + (\y -> + (header : y) ++ + filter (\x -> not (sameHeaderName x header)) allHeaders) + -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. cacheSeconds :: MonadHandler m => Int -> m () From 4e0b084df2119a90574b4e4a970835c696ead5ed Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:16:47 +0530 Subject: [PATCH 04/12] Enable test in YesodCoreTest --- yesod-core/test/YesodCoreTest.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 7c0db6fa..ebe1eef6 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -6,6 +6,7 @@ import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media import YesodCoreTest.Links +import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling @@ -27,6 +28,7 @@ import Test.Hspec specs :: Spec specs = do + headerTest cleanPathTest exceptionsTest widgetTest From 3cec499c85c297cf6452d75d9286047028f2c5b8 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:17:03 +0530 Subject: [PATCH 05/12] ScopedTypeVariables is also needed --- yesod-core/Yesod/Core/Handler.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 4b580cc9..9e6c1333 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------- -- -- Module : Yesod.Handler From a31c27089322fb683088cc81ec2f32acd9ad32a8 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:24:57 +0530 Subject: [PATCH 06/12] Update Changelog and do verion bump of the package --- yesod-core/ChangeLog.md | 4 ++++ yesod-core/yesod-core.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 3904cfa9..1b5e4882 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.36 + +* Add `replaceOrAddHeader` function in Yesod.Core.Handler module. [1416](https://github.com/yesodweb/yesod/issues/1416) + ## 1.4.35 * Contexts can be included in generated TH instances. [1365](https://github.com/yesodweb/yesod/issues/1365) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 7702a336..e5c8bba2 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.35 +version: 1.4.36 license: MIT license-file: LICENSE author: Michael Snoyman From 8416bb65695a8e5581440275dd76ac17dc08f1a3 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:27:03 +0530 Subject: [PATCH 07/12] Add Haddock documentation for the added function --- yesod-core/Yesod/Core/Handler.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 9e6c1333..70f6d1e4 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -789,6 +789,13 @@ setHeader :: MonadHandler m => Text -> Text -> m () setHeader = addHeader {-# DEPRECATED setHeader "Please use addHeader instead" #-} +-- | Replace an existing header with a new value or add a new header +-- if not present. +-- +-- Note that, while the data type used here is 'Text', you must provide only +-- ASCII value to be HTTP compliant. +-- +-- @since 1.4.36 replaceOrAddHeader :: MonadHandler m => Text -> Text -> m () replaceOrAddHeader a b = let header = Header (encodeUtf8 a) (encodeUtf8 b) From 18951b0de7fdc4e99559ba75b34fc330a1eebd56 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 12:42:30 +0530 Subject: [PATCH 08/12] Update the replace logic to obey proper ordering --- yesod-core/Yesod/Core/Handler.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 70f6d1e4..e98fee17 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -809,9 +809,8 @@ replaceOrAddHeader a b = replaceHeader header endo = let allHeaders :: [Header] = appEndo endo [] in Endo - (\y -> - (header : y) ++ - filter (\x -> not (sameHeaderName x header)) allHeaders) + (\rest -> + header : filter (\x -> not (sameHeaderName x header)) allHeaders ++ rest) -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. From f3ed12ed81ecf9c13e0d3c05d7e990834835a56b Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 12:43:16 +0530 Subject: [PATCH 09/12] Add additional test to make sure that header value is not lost --- yesod-core/test/YesodCoreTest/Header.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/yesod-core/test/YesodCoreTest/Header.hs b/yesod-core/test/YesodCoreTest/Header.hs index 4a9f11dc..aaf74a3a 100644 --- a/yesod-core/test/YesodCoreTest/Header.hs +++ b/yesod-core/test/YesodCoreTest/Header.hs @@ -25,6 +25,7 @@ mkYesod [parseRoutes| /header1 Header1R GET /header2 Header2R GET +/header3 Header3R GET |] instance Yesod App @@ -40,6 +41,14 @@ getHeader2R = do replaceOrAddHeader "hello" "sibi" return $ RepPlain $ toContent ("header test" :: Text) +getHeader3R :: Handler RepPlain +getHeader3R = do + addHeader "hello" "world" + addHeader "michael" "snoyman" + addHeader "yesod" "framework" + replaceOrAddHeader "yesod" "book" + return $ RepPlain $ toContent ("header test" :: Text) + runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f @@ -55,8 +64,17 @@ multipleHeaderTest = res <- request defaultRequest {pathInfo = decodePathSegments "/header2"} assertHeader "hello" "sibi" res +header3Test :: IO () +header3Test = do + runner $ do + res <- request defaultRequest { pathInfo = decodePathSegments "/header3"} + assertHeader "hello" "world" res + assertHeader "michael" "snoyman" res + assertHeader "yesod" "book" res + headerTest :: Spec headerTest = describe "Test.Header" $ do it "addHeader" addHeaderTest it "multiple header" multipleHeaderTest + it "persist headers" header3Test From 89fc6c46e2b558783b642752352ff55a0965e1f4 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 16:29:08 +0530 Subject: [PATCH 10/12] Fix ordering logic in replaceHeader function --- yesod-core/Yesod/Core/Handler.hs | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index e98fee17..1bda5fc6 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -798,19 +798,30 @@ setHeader = addHeader -- @since 1.4.36 replaceOrAddHeader :: MonadHandler m => Text -> Text -> m () replaceOrAddHeader a b = - let header = Header (encodeUtf8 a) (encodeUtf8 b) - in modify $ \g -> g {ghsHeaders = replaceHeader header (ghsHeaders g)} + modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)} where + repHeader = Header (encodeUtf8 a) (encodeUtf8 b) + sameHeaderName :: Header -> Header -> Bool sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2 sameHeaderName _ _ = False - replaceHeader :: Header -> Endo [Header] -> Endo [Header] - replaceHeader header endo = + replaceIndividualHeader :: [Header] -> [Header] + replaceIndividualHeader [] = [repHeader] + replaceIndividualHeader xs = aux xs [] + where + aux [] acc = acc ++ [repHeader] + aux (x:xs') acc = + if sameHeaderName repHeader x + then acc ++ + [repHeader] ++ + (filter (\header -> not (sameHeaderName header repHeader)) xs') + else aux xs' (acc ++ [x]) + + replaceHeader :: Endo [Header] -> Endo [Header] + replaceHeader endo = let allHeaders :: [Header] = appEndo endo [] - in Endo - (\rest -> - header : filter (\x -> not (sameHeaderName x header)) allHeaders ++ rest) + in Endo (\rest -> replaceIndividualHeader allHeaders ++ rest) -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. From 617591aa4e04a3f2745c8e3cb8beacd917b4d39b Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 14 Jul 2017 13:44:21 +0530 Subject: [PATCH 11/12] Do case insensitive equality on header name --- yesod-core/Yesod/Core/Handler.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 1bda5fc6..3b1b50ed 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -208,7 +208,7 @@ import Control.Monad.Trans.Class (lift) import Data.Aeson (ToJSON(..)) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8, decodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL import Text.Blaze.Html.Renderer.Utf8 (renderHtml) @@ -803,7 +803,7 @@ replaceOrAddHeader a b = repHeader = Header (encodeUtf8 a) (encodeUtf8 b) sameHeaderName :: Header -> Header -> Bool - sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2 + sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2) sameHeaderName _ _ = False replaceIndividualHeader :: [Header] -> [Header] From 19ff5c2006469ec82206bc6c4b7ac62f6ec2cb23 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 28 Jul 2017 16:58:11 +0530 Subject: [PATCH 12/12] Fix warning in test code --- yesod-core/test/YesodCoreTest/Header.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/yesod-core/test/YesodCoreTest/Header.hs b/yesod-core/test/YesodCoreTest/Header.hs index aaf74a3a..75d038c8 100644 --- a/yesod-core/test/YesodCoreTest/Header.hs +++ b/yesod-core/test/YesodCoreTest/Header.hs @@ -7,15 +7,12 @@ module YesodCoreTest.Header , resourcesApp ) where -import Data.ByteString.Lazy (ByteString) -import qualified Data.Map as Map import Data.Text (Text) -import Network.HTTP.Types (decodePathSegments, status200) +import Network.HTTP.Types (decodePathSegments) import Network.Wai import Network.Wai.Test import Test.Hspec import Yesod.Core -import Yesod.Core.Handler data App = App @@ -67,11 +64,11 @@ multipleHeaderTest = header3Test :: IO () header3Test = do runner $ do - res <- request defaultRequest { pathInfo = decodePathSegments "/header3"} + res <- request defaultRequest {pathInfo = decodePathSegments "/header3"} assertHeader "hello" "world" res assertHeader "michael" "snoyman" res assertHeader "yesod" "book" res - + headerTest :: Spec headerTest = describe "Test.Header" $ do