Disallow crlf headers #92

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 ()

Web/Scotty/Action.hs

@@ -7,6 +7,7 @@
 {-# language ScopedTypeVariables #-}
 module Web.Scotty.Action
     ( addHeader
+    , addHeader1
     , body
     , bodyReader
     , file
@@ -45,6 +46,7 @@
     , request
     , rescue
     , setHeader
+    , setHeader1
     , status
     , stream
     , text
@@ -92,7 +94,7 @@
 import           Numeric.Natural
 
 import           Web.Scotty.Internal.Types
 import           Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient)
 import           UnliftIO.Exception (Handler(..), catch, catches, throwIO)
 
 import Network.Wai.Internal (ResponseReceived(..))
@@ -119,7 +121,7 @@
 -- | Catches 'StatusError' and produces an appropriate HTTP response.
 statusErrorHandler :: MonadIO m => ErrorHandler m
 statusErrorHandler = Handler $ \case
   StatusError s e -> do
     status s
     let code = T.pack $ show $ statusCode s
     let msg = decodeUtf8Lenient $ statusMessage s
@@ -186,7 +188,7 @@
 --
 -- Uncaught exceptions turn into HTTP responses corresponding to the given status.
 raiseStatus :: Monad m => Status -> T.Text -> ActionT m a
 raiseStatus s = E.throw . StatusError s
 {-# DEPRECATED raiseStatus "Use status, text, and finish instead" #-}
 
 -- | Throw an exception which can be caught within the scope of the current Action with 'catch'.
@@ -539,14 +541,38 @@
 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.

Web/Scotty/Cookie.hs

@@ -45,6 +45,9 @@
     -- * Set cookie
       setCookie
     , setSimpleCookie
+    -- ** Sanitized values
+    , setCookie1
+    , setSimpleCookie1
     -- * Get cookie(s)
     , getCookie
     , getCookies
@@ -79,7 +82,7 @@
 -- 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,19 +94,44 @@
 setCookie :: (MonadIO m)
           => SetCookie
           -> ActionT m ()
-setCookie c = addHeader "Set-Cookie"
+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')
+--
+-- 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
                 -> 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' (#92)
+setSimpleCookie1 :: (MonadIO m)
+                 => Text -- ^ name
+                 -> Text -- ^ value
+                 -> ActionT m ()
+setSimpleCookie1 n v = setCookie1 $ makeSimpleCookie n v
 
 -- | Lookup one cookie name
 getCookie :: (Monad m)

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 }
 

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

Web/Scotty/Trans/Lazy.hs

@@ -16,14 +16,14 @@
 raise :: (MonadIO m) =>
          T.Text -- ^ Error text
       -> ActionT m a
 raise  = Base.raise . T.toStrict
 {-# DEPRECATED raise "Throw an exception instead" #-}
 
 -- | Throw a 'StatusError' exception that has an associated HTTP error code and can be caught with 'rescue'.
 --
 -- Uncaught exceptions turn into HTTP responses corresponding to the given status.
 raiseStatus :: Monad m => Status -> T.Text -> ActionT m a
 raiseStatus s = Base.raiseStatus s . T.toStrict
 {-# DEPRECATED raiseStatus "Use status, text, and finish instead" #-}
 
 -- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect
@@ -47,12 +47,25 @@
 
 -- | 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.
+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

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` (#92)
+* add `setCookie1`, `setSimpleCookie1` (#92)
+
+Breaking:
+
+* `setCookie` uses `setHeader` rather than `addHeader` (as it should)
 
 ## 0.20.1 [2023.10.03]
 

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 (#92)" $ 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 (#92)" $ 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