From 3401e42be4bddc77ba19f4c2217b6c2da46e9da5 Mon Sep 17 00:00:00 2001
From: Marco Zocca <marco.zocca@unfoldml.com>
Date: Sat, 16 Dec 2023 17:39:15 +0100
Subject: [PATCH 1/3] add setHeader, setHeader1 tests

---
 Web/Scotty.hs                | 21 ++++++++++++++++++++-
 Web/Scotty/Action.hs         | 26 ++++++++++++++++++++++++++
 Web/Scotty/Internal/Types.hs |  9 +++++++++
 Web/Scotty/Trans.hs          |  7 ++++++-
 Web/Scotty/Trans/Lazy.hs     | 11 +++++++++++
 test/Web/ScottySpec.hs       | 27 +++++++++++++++++++++++++++
 6 files changed, 99 insertions(+), 2 deletions(-)

diff --git a/Web/Scotty.hs b/Web/Scotty.hs
index 5317f085..eb084837 100644
--- a/Web/Scotty.hs
+++ b/Web/Scotty.hs
@@ -24,7 +24,12 @@ module Web.Scotty
     , pathParams, captureParams, formParams, queryParams
     , jsonData, files
       -- ** Modifying the Response and Redirecting
-    , status, addHeader, setHeader, redirect
+      -- *** Status
+    , status
+      -- *** Headers
+    , addHeader, setHeader
+    , addHeader1, setHeader1
+    , redirect
       -- ** Setting Response Body
       --
       -- | Note: only one of these should be present in any given route
@@ -358,6 +363,20 @@ addHeader = Trans.addHeader
 setHeader :: Text -> Text -> ActionM ()
 setHeader = Trans.setHeader
 
+-- | Add to the response headers. Header names are case-insensitive.
+addHeader1 :: Text -- ^ Header name
+           -> Text -- ^ Header value. Only the first characters before a newline or carrier return are kept
+           -> ActionM ()
+addHeader1 = Trans.addHeader1
+
+-- | Set one of the response headers. Will override any previously set value for that header.
+-- Header names are case-insensitive.
+setHeader1 :: Text -- ^ Header name
+           -> Text -- ^ Header value. Only the first characters before a newline or carrier return are kept
+           -> ActionM ()
+setHeader1 = Trans.setHeader1
+
+
 -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\"
 -- header to \"text/plain; charset=utf-8\" if it has not already been set.
 text :: Text -> ActionM ()
diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs
index b73e691a..add94ea2 100644
--- a/Web/Scotty/Action.hs
+++ b/Web/Scotty/Action.hs
@@ -7,6 +7,7 @@
 {-# language ScopedTypeVariables #-}
 module Web.Scotty.Action
     ( addHeader
+    , addHeader1
     , body
     , bodyReader
     , file
@@ -45,6 +46,7 @@ module Web.Scotty.Action
     , request
     , rescue
     , setHeader
+    , setHeader1
     , status
     , stream
     , text
@@ -539,14 +541,38 @@ changeHeader :: MonadIO m
 changeHeader f k =
   modifyResponse . setHeaderWith . f (CI.mk $ encodeUtf8 k) . encodeUtf8
 
+-- like 'changeHeader' but chops off all header values after the first CR or LF
+changeHeader1 :: MonadIO m =>
+                 (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)])
+              -> T.Text -> T.Text -> ActionT m ()
+changeHeader1 f k v0 = case splitAtCRLF (encodeUtf8 v0) of
+  Nothing -> pure ()
+  Just v -> modifyResponse $ setHeaderWith $ f (CI.mk $ encodeUtf8 k) v
+
+-- | Add to the response headers. Header names are case-insensitive.
+addHeader1 :: MonadIO m => T.Text -- ^ Header name
+           -> T.Text -- ^ Header value. Only the first characters before a newline or carrier return are kept
+           -> ActionT m ()
+addHeader1 = changeHeader1 add
+
+-- | Set one of the response headers. Will override any previously set value for that header.
+-- Header names are case-insensitive.
+setHeader1 :: MonadIO m => T.Text -- ^ Header name
+           -> T.Text -- ^ Header value. Only the first characters before a newline or carrier return are kept
+           -> ActionT m ()
+setHeader1 = changeHeader1 replace
+
+
 -- | Add to the response headers. Header names are case-insensitive.
 addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
 addHeader = changeHeader add
+{-# DEPRECATED addHeader "this function does not validate header values and can potentially lead to security problems (e.g. response splitting attacks). Please use addHeader1 instead (#92)" #-}
 
 -- | Set one of the response headers. Will override any previously set value for that header.
 -- Header names are case-insensitive.
 setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
 setHeader = changeHeader replace
+{-# DEPRECATED setHeader "this function does not validate header values and can potentially lead to security problems (e.g. response splitting attacks). Please use setHeader1 instead (#92)" #-}
 
 -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
 -- header to \"text/plain; charset=utf-8\" if it has not already been set.
diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs
index 4de097c4..088f0e60 100644
--- a/Web/Scotty/Internal/Types.hs
+++ b/Web/Scotty/Internal/Types.hs
@@ -27,8 +27,10 @@ import           Control.Monad.Trans.Class (MonadTrans(..))
 import           Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl)
 
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8 (splitWith)
 import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString)
 import           Data.Default.Class (Default, def)
+import Data.Maybe (listToMaybe)
 import           Data.String (IsString(..))
 import           Data.Text (Text, pack)
 import           Data.Typeable (Typeable)
@@ -207,6 +209,13 @@ setContent c sr = sr { srContent = c }
 setHeaderWith :: ([(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]) -> ScottyResponse -> ScottyResponse
 setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) }
 
+-- | Take the first characters before either a Carrier Return ('\r') or Line Feed ('\n').
+-- This can be used to sanitize headers.
+splitAtCRLF :: BS.ByteString -> Maybe BS.ByteString
+splitAtCRLF = listToMaybe . BS8.splitWith (\c -> c == '\n' ||
+                                                 c == '\r'
+                                          )
+
 setStatus :: Status -> ScottyResponse -> ScottyResponse
 setStatus s sr = sr { srStatus = s }
 
diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs
index 117accad..1dda5065 100644
--- a/Web/Scotty/Trans.hs
+++ b/Web/Scotty/Trans.hs
@@ -29,7 +29,12 @@ module Web.Scotty.Trans
     , pathParams, captureParams, formParams, queryParams
     , jsonData, files
       -- ** Modifying the Response and Redirecting
-    , status, Lazy.addHeader, Lazy.setHeader, Lazy.redirect
+      -- *** Status
+    , status
+      -- *** Headers
+    , Lazy.addHeader, Lazy.setHeader
+    , Lazy.addHeader1, Lazy.setHeader1
+    , Lazy.redirect
       -- ** Setting Response Body
       --
       -- | Note: only one of these should be present in any given route
diff --git a/Web/Scotty/Trans/Lazy.hs b/Web/Scotty/Trans/Lazy.hs
index 484cbbcc..a774b978 100644
--- a/Web/Scotty/Trans/Lazy.hs
+++ b/Web/Scotty/Trans/Lazy.hs
@@ -54,6 +54,17 @@ addHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v)
 setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
 setHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v)
 
+
+-- | Add to the response headers. Header names are case-insensitive.
+addHeader1 :: MonadIO m => T.Text -> T.Text -> ActionT m ()
+addHeader1 k v = Base.addHeader1 (T.toStrict k) (T.toStrict v)
+
+-- | Set one of the response headers. Will override any previously set value for that header.
+-- Header names are case-insensitive.
+setHeader1 :: MonadIO m => T.Text -> T.Text -> ActionT m ()
+setHeader1 k v = Base.addHeader1 (T.toStrict k) (T.toStrict v)
+
+
 text :: (MonadIO m) => T.Text -> ActionT m ()
 text = Base.textLazy
 
diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs
index af577d39..e1704467 100644
--- a/test/Web/ScottySpec.hs
+++ b/test/Web/ScottySpec.hs
@@ -325,6 +325,33 @@ spec = do
         it "stops the execution of an action" $ do
           get "/scotty" `shouldRespondWith` 400
 
+    describe "setHeader" $ do
+      withApp (Scotty.get "/" $ setHeader "foo" "bar") $ do
+          it "sets a header" $ do
+            get "/" `shouldRespondWith` 200 {matchHeaders = ["foo" <:> "bar"]}
+      context "disregards CR and/or LF which could lead to security issues (#94)" $ do
+        withApp (Scotty.get "/" $ setHeader "X-Foo" "Hey\r\nContent-Type: bla") $ do
+          it "is vulnerable" $ do
+            get "/" `shouldRespondWith` 200 {
+              matchHeaders = [
+                  "X-Foo" <:> "Hey\r\nContent-Type: bla"
+                  ]
+              }
+
+    describe "setHeader1" $ do
+      withApp (Scotty.get "/" $ setHeader1 "foo" "bar") $ do
+          it "sets a header" $ do
+            get "/" `shouldRespondWith` 200 {matchHeaders = ["foo" <:> "bar"]}
+      context "strips CR and/or LF from header values (#94)" $ do
+        withApp (Scotty.get "/" $ setHeader1 "X-Foo" "Hey\r\nContent-Type: bla") $ do
+          it "is not vulnerable" $ do
+            get "/" `shouldRespondWith` 200 {
+              matchHeaders = [
+                  "X-Foo" <:> "Hey"
+                  ]
+              }
+
+
     describe "setSimpleCookie" $ do
       withApp (Scotty.get "/scotty" $ SC.setSimpleCookie "foo" "bar") $ do
         it "responds with a Set-Cookie header" $ do

From 42043a5a2698c0252dcc60b02f29d7bd71bd7ecb Mon Sep 17 00:00:00 2001
From: Marco Zocca <marco.zocca@unfoldml.com>
Date: Sat, 16 Dec 2023 17:53:19 +0100
Subject: [PATCH 2/3] setSimpleCookie1, changelog

---
 Web/Scotty/Cookie.hs | 32 +++++++++++++++++++++++++++++---
 changelog.md         |  6 ++++++
 2 files changed, 35 insertions(+), 3 deletions(-)

diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs
index b22af9e9..7b3a7e1c 100644
--- a/Web/Scotty/Cookie.hs
+++ b/Web/Scotty/Cookie.hs
@@ -45,6 +45,9 @@ module Web.Scotty.Cookie (
     -- * Set cookie
       setCookie
     , setSimpleCookie
+    -- ** Sanitized values
+    , setCookie1
+    , setSimpleCookie1
     -- * Get cookie(s)
     , getCookie
     , getCookies
@@ -79,7 +82,7 @@ import qualified Data.ByteString.Lazy as BSL (toStrict)
 -- cookie
 import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax)
 -- scotty
-import Web.Scotty.Action (ActionT, addHeader, header)
+import Web.Scotty.Action (ActionT, addHeader, header, addHeader1, setHeader, setHeader1)
 -- time
 import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
 -- text
@@ -91,13 +94,27 @@ import Web.Scotty.Util (decodeUtf8Lenient)
 setCookie :: (MonadIO m)
           => SetCookie
           -> ActionT m ()
-setCookie c = addHeader "Set-Cookie"
+setCookie = setCookieWith setHeader
+
+-- | Set a cookie, with full access to its options (see 'SetCookie')
+--
+-- NB : sanitizes the cookie value by keeping only the first characters before '\r' or '\n'
+setCookie1 :: MonadIO m
+           => SetCookie
+           -> ActionT m ()
+setCookie1 = setCookieWith setHeader1
+
+-- | Set a cookie, with full access to its options (see 'SetCookie')
+setCookieWith :: MonadIO m
+              => (Text -> Text -> ActionT m ())
+              -> SetCookie
+              -> ActionT m ()
+setCookieWith f c = f "Set-Cookie"
   $ decodeUtf8Lenient
   $ BSL.toStrict
   $ toLazyByteString
   $ renderSetCookie c
 
-
 -- | 'makeSimpleCookie' and 'setCookie' combined.
 setSimpleCookie :: (MonadIO m)
                 => Text -- ^ name
@@ -105,6 +122,15 @@ setSimpleCookie :: (MonadIO m)
                 -> ActionT m ()
 setSimpleCookie n v = setCookie $ makeSimpleCookie n v
 
+-- | 'makeSimpleCookie' and 'setCookie1' combined.
+--
+-- NB : sanitizes the cookie value by keeping only the first characters before '\r' or '\n'
+setSimpleCookie1 :: (MonadIO m)
+                 => Text -- ^ name
+                 -> Text -- ^ value
+                 -> ActionT m ()
+setSimpleCookie1 n v = setCookie1 $ makeSimpleCookie n v
+
 -- | Lookup one cookie name
 getCookie :: (Monad m)
           => Text -- ^ name
diff --git a/changelog.md b/changelog.md
index 93413636..284d80e7 100644
--- a/changelog.md
+++ b/changelog.md
@@ -11,6 +11,12 @@
 * Deprecate `StatusError`, `raise` and `raiseStatus` (#351)
 * Add doctest, refactor some inline examples into doctests (#353)
 * document "`defaultHandler` only applies to endpoints defined after it" (#237)
+* add `setHeader1`, `addHeader1`, deprecate `setHeader`, `addHeader` (#94)
+* add `setCookie1`, `setSimpleCookie1` (#94)
+
+Breaking:
+
+* `setCookie` uses `setHeader` rather than `addHeader` (as it should)
 
 ## 0.20.1 [2023.10.03]
 

From b5feb7a2798c1c11b520623abcfa6d406ed26604 Mon Sep 17 00:00:00 2001
From: Marco Zocca <marco.zocca@unfoldml.com>
Date: Sat, 16 Dec 2023 17:59:56 +0100
Subject: [PATCH 3/3] add deprecation notices

---
 Web/Scotty/Cookie.hs     | 4 +++-
 Web/Scotty/Trans/Lazy.hs | 2 ++
 changelog.md             | 4 ++--
 test/Web/ScottySpec.hs   | 4 ++--
 4 files changed, 9 insertions(+), 5 deletions(-)

diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs
index 7b3a7e1c..134332e7 100644
--- a/Web/Scotty/Cookie.hs
+++ b/Web/Scotty/Cookie.hs
@@ -95,6 +95,7 @@ setCookie :: (MonadIO m)
           => SetCookie
           -> ActionT m ()
 setCookie = setCookieWith setHeader
+{-# DEPRECATED setCookie "uses setHeader which is unsafe (#92). Please use setCookie1 instead"#-}
 
 -- | Set a cookie, with full access to its options (see 'SetCookie')
 --
@@ -121,10 +122,11 @@ setSimpleCookie :: (MonadIO m)
                 -> Text -- ^ value
                 -> ActionT m ()
 setSimpleCookie n v = setCookie $ makeSimpleCookie n v
+{-# DEPRECATED setSimpleCookie "uses setHeader which is unsafe (#92). Please use setSimpleCookie1 instead"#-}
 
 -- | 'makeSimpleCookie' and 'setCookie1' combined.
 --
--- NB : sanitizes the cookie value by keeping only the first characters before '\r' or '\n'
+-- NB : sanitizes the cookie value by keeping only the first characters before '\r' or '\n' (#92)
 setSimpleCookie1 :: (MonadIO m)
                  => Text -- ^ name
                  -> Text -- ^ value
diff --git a/Web/Scotty/Trans/Lazy.hs b/Web/Scotty/Trans/Lazy.hs
index a774b978..4fb5d1f8 100644
--- a/Web/Scotty/Trans/Lazy.hs
+++ b/Web/Scotty/Trans/Lazy.hs
@@ -48,11 +48,13 @@ headers = map (join bimap T.fromStrict) <$> Base.headers
 -- | Add to the response headers. Header names are case-insensitive.
 addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
 addHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v)
+{-# DEPRECATED addHeader "does not validate header values which is potentially unsafe (#92). Please use addHeader1 instead"#-}
 
 -- | Set one of the response headers. Will override any previously set value for that header.
 -- Header names are case-insensitive.
 setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
 setHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v)
+{-# DEPRECATED setHeader "does not validate header values which is potentially unsafe (#92). Please use setHeader1 instead"#-}
 
 
 -- | Add to the response headers. Header names are case-insensitive.
diff --git a/changelog.md b/changelog.md
index 284d80e7..0c931b4c 100644
--- a/changelog.md
+++ b/changelog.md
@@ -11,8 +11,8 @@
 * Deprecate `StatusError`, `raise` and `raiseStatus` (#351)
 * Add doctest, refactor some inline examples into doctests (#353)
 * document "`defaultHandler` only applies to endpoints defined after it" (#237)
-* add `setHeader1`, `addHeader1`, deprecate `setHeader`, `addHeader` (#94)
-* add `setCookie1`, `setSimpleCookie1` (#94)
+* add `setHeader1`, `addHeader1`, deprecate `setHeader`, `addHeader` (#92)
+* add `setCookie1`, `setSimpleCookie1` (#92)
 
 Breaking:
 
diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs
index e1704467..e816f20c 100644
--- a/test/Web/ScottySpec.hs
+++ b/test/Web/ScottySpec.hs
@@ -329,7 +329,7 @@ spec = do
       withApp (Scotty.get "/" $ setHeader "foo" "bar") $ do
           it "sets a header" $ do
             get "/" `shouldRespondWith` 200 {matchHeaders = ["foo" <:> "bar"]}
-      context "disregards CR and/or LF which could lead to security issues (#94)" $ do
+      context "disregards CR and/or LF which could lead to security issues (#92)" $ do
         withApp (Scotty.get "/" $ setHeader "X-Foo" "Hey\r\nContent-Type: bla") $ do
           it "is vulnerable" $ do
             get "/" `shouldRespondWith` 200 {
@@ -342,7 +342,7 @@ spec = do
       withApp (Scotty.get "/" $ setHeader1 "foo" "bar") $ do
           it "sets a header" $ do
             get "/" `shouldRespondWith` 200 {matchHeaders = ["foo" <:> "bar"]}
-      context "strips CR and/or LF from header values (#94)" $ do
+      context "strips CR and/or LF from header values (#92)" $ do
         withApp (Scotty.get "/" $ setHeader1 "X-Foo" "Hey\r\nContent-Type: bla") $ do
           it "is not vulnerable" $ do
             get "/" `shouldRespondWith` 200 {