Confusing `Headers` behavior in client with repeatable headers

[zlondrej]

So I've been tinkering with Set-Cookie headers with type level names (e.g data NamedCookie (name :: Symbol) a).
And this works quite nicely for server side. But when it comes to client side, the experience with Set-Cookie headers is actually quite confusing and problematic on multiple levels.

One part of the issue is that the client really expects unique header names, but there can be multiple of Set-Cookie headers (and maybe other). The client simply tries to parse first Set-Cookie header and goes with the result, regardless if the name actually matches or not. If server send more Set-Cookie headers (e.g. due to authentication layer), the client handling break. This would require a different interface than FromHttpApiData's parseHeader, that would allow rejecting the cookie value when the name mismatches, but would not immediately result in UndecodableHeader.

On the other hand, client shouldn't really handle Set-Cookies header directly but use some kind of cookie jar interface. Thus the client request should not even represent the Set-Cookie headers in the response type.

This situation can result in unreliable interface when reusing an API type for both server and client code when Set-Cookies or other repeatable headers are involved.

Demo app

Output:

Named cookies are not present

Expected HList should ideally contain 2 MissingHeaders.

Case: Matching 'Set-Cookie' headers are missing:
  SetCookie { name = "non-matching-cookie1", value = "value" } Left "Expected cookie name: my-cookie, but got: non-matching-cookie1"
  SetCookie { name = "non-matching-cookie1", value = "value" } Left "Expected cookie name: other-cookie, but got: non-matching-cookie1"
HList (UndecodableHeader "non-matching-cookie1=value", UndecodableHeader "non-matching-cookie1=value")

Named cookies are present in switched order

Expected HList should ideally contain properly decoded headers.

Case: Matching 'Set-Cookie' headers are present, but not in expected order:
  SetCookie { name = "other-cookie", value = "my-cookie-follows" } Left "Expected cookie name: my-cookie, but got: other-cookie"
  SetCookie { name = "my-cookie", value = "other-cookie-precedes" } Left "Expected cookie name: other-cookie, but got: my-cookie"
HList (UndecodableHeader "other-cookie=my-cookie-follows", UndecodableHeader "my-cookie=other-cookie-precedes")

Named cookies are present in matching order

This works correctly.

Case: Matching 'Set-Cookie' headers are present, and in expected order:
  SetCookie { name = "my-cookie", value = "my-value" } Right (NamedCookie "my-cookie" "my-value")
  SetCookie { name = "other-cookie", value = "other-value" } Right (NamedCookie "other-cookie" "other-value")
HList (Header (NamedCookie "my-cookie" "my-value"), Header (NamedCookie "other-cookie" "other-value"))

Demo app:

{- stack script
  --resolver lts-23.25
  --package aeson
  --package bytestring
  --package cookie
  --package deepseq
  --package exceptions
  --package http-client
  --package http-types
  --package mtl
  --package optics
  --package servant
  --package servant-client
  --package servant-client-core
  --package servant-server
  --package string-conversions
  --package text
  --package time
  --package wai
  --package warp
-}

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Main where

import Control.DeepSeq
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.Kind
import Data.Proxy
import Data.Text as T
import Data.Time.Clock
import GHC.Generics
import GHC.TypeLits
import Network.HTTP.Client hiding (Proxy, Request)
import Network.Wai
import Network.Wai.Handler.Warp
import Servant.API
import Servant.API.ResponseHeaders
import Servant.API.TypeLevel
import Servant.Client
import Servant.Client.Core hiding (Request, addHeader)
import Servant.Server
import Web.Cookie hiding (Cookies)

import Debug.Trace

data NamedCookie (name :: Symbol) a = NamedCookie a
  deriving (Eq)

instance (NFData a) => NFData (NamedCookie name a) where
  rnf (NamedCookie value) = rnf value

toSetCookie :: forall name a. (KnownSymbol name, ToHttpApiData a) => NamedCookie name a -> SetCookie
toSetCookie (NamedCookie value) =
  defaultSetCookie
    { setCookieName = BS8.pack $ symbolVal (Proxy @name)
    , setCookieValue = toHeader value
    }

fromSetCookieDiscardName :: (KnownSymbol name, Show a, FromHttpApiData a) => SetCookie -> Either Text (NamedCookie name a)
fromSetCookieDiscardName = fmap NamedCookie . parseHeader . setCookieValue

fromSetCookieMatchingName :: forall name a. (KnownSymbol name, Show a, FromHttpApiData a) => SetCookie -> Either Text (NamedCookie name a)
fromSetCookieMatchingName cookie =
  let expectedName = symbolVal (Proxy @name)
      cookieName = BS8.unpack $ setCookieName cookie
      showSetCookie c = "SetCookie { name = " <> show (setCookieName c) <> ", value = " <> show (setCookieValue c) <> " }"
   in traceWith ((("  " <> showSetCookie cookie <> " ") <>) . show) $
        if cookieName == expectedName
          then fromSetCookieDiscardName cookie
          else Left $ "Expected cookie name: " <> T.pack expectedName <> ", but got: " <> T.pack cookieName

instance (KnownSymbol name, Show a) => Show (NamedCookie name a) where
  showsPrec d (NamedCookie value) =
    showParen (d > 10) $
      showString "NamedCookie "
        . shows (symbolVal (Proxy @name))
        . showString " "
        . showsPrec 10 value

type ClientRoute = Get '[JSON] (Headers '[Header "Set-Cookie" (NamedCookie "my-cookie" Text), Header "Set-Cookie" (NamedCookie "other-cookie" Text)] NoContent)
type ServerRoute = Get '[JSON] (Headers '[Header "Set-Cookie" Text, Header "Set-Cookie" Text] NoContent)

instance (KnownSymbol name) => ToHttpApiData (NamedCookie name Text) where
  toUrlPiece = toUrlPiece . toSetCookie
  toEncodedUrlPiece = toEncodedUrlPiece . toSetCookie
  toHeader = toHeader . toSetCookie
  toQueryParam = toQueryParam . toSetCookie
  toEncodedQueryParam = toEncodedQueryParam . toSetCookie

instance (KnownSymbol name, Show a, FromHttpApiData a) => FromHttpApiData (NamedCookie name a) where
  parseUrlPiece = fromSetCookieMatchingName <=< parseUrlPiece
  parseHeader = fromSetCookieMatchingName <=< parseHeader
  parseQueryParam = fromSetCookieMatchingName <=< parseQueryParam

class HListShow ls where
  hListShow :: HList ls -> String

instance HListShow '[] where
  hListShow HNil = ""

instance (Show (ResponseHeader name a), HListShow hs) => HListShow (Header' mods name a ': hs) where
  hListShow = \case
    HCons header HNil -> show header
    HCons header hs -> show header ++ ", " ++ hListShow hs

instance (HListShow ls) => Show (HList ls) where
  show hlist = "HList (" <> hListShow hlist <> ")"

main :: IO ()
main = do
  putStrLn "Case: Matching 'Set-Cookie' headers are missing:"
  testClient "non-matching-cookie1=value" "non-matching-cookie1=value"
  putStrLn "----"
  putStrLn "Case: Matching 'Set-Cookie' headers are present, but not in expected order:"
  testClient "other-cookie=my-cookie-follows" "my-cookie=other-cookie-precedes"
  putStrLn "----"
  putStrLn "Case: Matching 'Set-Cookie' headers are present, and in expected order:"
  testClient "my-cookie=my-value" "other-cookie=other-value"

testClient :: Text -> Text -> IO ()
testClient responseHeader1 responseHeader2 =
  testWithApplication (pure (servantApp responseHeader1 responseHeader2)) $ \port -> do
    httpManager <- newManager defaultManagerSettings
    let clientEnv = mkClientEnv httpManager (BaseUrl Http "localhost" port "")
    runClientM (client $ Proxy @(ClientRoute)) clientEnv >>= \case
      Left err -> putStrLn $ "Client error: " ++ show err
      Right responseWithHeaders ->
        let headers = getHeadersHList responseWithHeaders
         in -- Deep evaluation of headers so we don't mix the print with debug traces from parsing
            headers `deepseq` print headers

servantApp :: Text -> Text -> Application
servantApp responseHeader1 responseHeader2 =
  serve
    (Proxy @ServerRoute)
    ( pure
        . addHeader @"Set-Cookie" responseHeader1
        . addHeader @"Set-Cookie" responseHeader2
        $ NoContent
    )

[tchoutri]

@zlondrej Thanks for opening this ticket, I'm sure you're not the only one who is facing such issues.

We certainly need a better design for this usecase.

[alpmestan]

It feels like there should be a better way to handle all that stuff indeed.

Focusing strictly on the cookies situation (as opposed to headers in general), servant could probably provide two different things:

• "static cookies", i.e the fully explicit thing that we already have, but with a dedicated API combinator (StaticCookies?) and some clean up and improvements, e.g having some sort of set/multiset at the typelevel in the internals to store the cookies so that the order doesn't matter. Handlers and client functions would be affected, taking suitable arguments, preserving the information about which cookies should be there.
• dynamic cookies, which could just be a naked, parameter-less Cookies combinator, which would merely have the effect of adding a CookieJar (or whatever the name is) argument to handlers (and client functions if desired), with no static information about what should be there.

This seems to overall be in the spirit of servant, offering options and leaving the choice to the user, depending on their needs with the situation at hand.