From e16f90f107923e5b968a1be05391606131e3c0cf Mon Sep 17 00:00:00 2001 From: Geoffrey Roberts Date: Wed, 21 Jan 2015 18:27:25 +1100 Subject: [PATCH 1/6] Extended HeaderArg to allow header arguments to replace the contents of a template, allowing specially composed headers to create specially formatted headers --- servant-jquery.cabal | 3 ++- src/Servant/JQuery.hs | 6 +++--- src/Servant/JQuery/Internal.hs | 24 ++++++++++++++++++++++-- test/Servant/JQuerySpec.hs | 22 +++++++++++++++++++--- 4 files changed, 46 insertions(+), 9 deletions(-) diff --git a/servant-jquery.cabal b/servant-jquery.cabal index 5a71b4cc..ee6d19ee 100644 --- a/servant-jquery.cabal +++ b/servant-jquery.cabal @@ -31,7 +31,7 @@ flag example library exposed-modules: Servant.JQuery other-modules: Servant.JQuery.Internal - build-depends: base >=4.5 && <5, servant >= 0.2.1, lens >= 4 + build-depends: base >=4.5 && <5, servant >= 0.2.1, lens >= 4, MissingH hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -68,5 +68,6 @@ test-suite spec , servant-jquery , servant , hspec >= 2.0 + , hspec-expectations , language-ecmascript == 0.16.* default-language: Haskell2010 diff --git a/src/Servant/JQuery.hs b/src/Servant/JQuery.hs index b6453ecf..e4bc3be4 100644 --- a/src/Servant/JQuery.hs +++ b/src/Servant/JQuery.hs @@ -44,7 +44,7 @@ generateJS req = "\n" <> args = captures ++ map (view argName) queryparams ++ body - ++ map ("header"++) hs + ++ map ((<>) "header" . headerArgName) hs ++ ["onSuccess", "onError"] captures = map captureArg @@ -67,10 +67,10 @@ generateJS req = "\n" <> reqheaders = if null hs then "" - else "\n , headers: { " ++ headersStr ++ " } }\n" + else "\n , headers: { " ++ headersStr ++ " }\n" where headersStr = intercalate ", " $ map headerStr hs - headerStr hname = "\"" ++ hname ++ "\": header" ++ hname + headerStr header = "\"" ++ headerArgName header ++ "\": " ++ show header fname = req ^. funcName method = req ^. reqMethod diff --git a/src/Servant/JQuery/Internal.hs b/src/Servant/JQuery/Internal.hs index 32c06ce5..31c059ca 100644 --- a/src/Servant/JQuery/Internal.hs +++ b/src/Servant/JQuery/Internal.hs @@ -9,8 +9,10 @@ module Servant.JQuery.Internal where import Control.Applicative import Control.Lens import Data.Char (toLower) +import Data.List import Data.Monoid import Data.Proxy +import Data.String.Utils import GHC.TypeLits import Servant.API @@ -53,7 +55,25 @@ data QueryArg = QueryArg , _argType :: ArgType } deriving (Eq, Show) -type HeaderArg = String +data HeaderArg = HeaderArg + { headerArgName :: String + } + | ReplaceHeaderArg + { headerArgName :: String + , headerPattern :: String + } deriving (Eq) + +instance Show HeaderArg where + show (HeaderArg n) = "header" <> n + show (ReplaceHeaderArg n p) + | pn `startswith` p = pv <> " + \"" <> rp <> "\"" + | pn `endswith` p = "\"" <> rp <> "\" + " <> pv + | pn `isInfixOf` p = "\"" <> replace pn ("\"" <> pv <> "\"") p <> "\"" + | otherwise = p + where + pv = "header" <> n + pn = "{header" <> n <> "}" + rp = replace pn "" p data Url = Url { _path :: Path @@ -144,7 +164,7 @@ instance (KnownSymbol sym, HasJQ sublayout) type JQ (Header sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = - jqueryFor subP (req & reqHeaders <>~ [hname]) + jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname]) where hname = symbolVal (Proxy :: Proxy sym) subP = Proxy :: Proxy sublayout diff --git a/test/Servant/JQuerySpec.hs b/test/Servant/JQuerySpec.hs index 5ba2f681..83135701 100644 --- a/test/Servant/JQuerySpec.hs +++ b/test/Servant/JQuerySpec.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.JQuerySpec where @@ -20,6 +23,12 @@ GET /has.extension Bool type TopLevelRawAPI = "something" :> Get Int :<|> Raw +type HeaderHandlingAPI = "something" :> Header "Foo" String + :> Get Int + +headerHandlingProxy :: Proxy HeaderHandlingAPI +headerHandlingProxy = Proxy + spec :: Spec spec = describe "Servant.JQuery" generateJSSpec @@ -37,3 +46,10 @@ generateJSSpec = describe "generateJS" $ do print $ generateJS $ topLevel "GET" parseFromString (generateJS $ topLevel "GET") `shouldSatisfy` isRight + it "should handle simple HTTP headers" $ do + let jsText = generateJS $ jquery headerHandlingProxy + print jsText + parseFromString jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerFoo" + jsText `shouldContain` "headers: { \"Foo\": headerFoo }\n" + From 158eab51571dcab54e770de5d046ec072a6765a1 Mon Sep 17 00:00:00 2001 From: Geoffrey Roberts Date: Wed, 21 Jan 2015 18:47:23 +1100 Subject: [PATCH 2/6] Changed template for ReplaceHeaderArg. Got tests working. --- servant-jquery.cabal | 1 + src/Servant/JQuery/Internal.hs | 2 +- test/Servant/JQuerySpec.hs | 14 +++++++++++ test/Servant/JQuerySpec/CustomHeaders.hs | 31 ++++++++++++++++++++++++ 4 files changed, 47 insertions(+), 1 deletion(-) create mode 100644 test/Servant/JQuerySpec/CustomHeaders.hs diff --git a/servant-jquery.cabal b/servant-jquery.cabal index ee6d19ee..6767f6be 100644 --- a/servant-jquery.cabal +++ b/servant-jquery.cabal @@ -65,6 +65,7 @@ test-suite spec main-is: Spec.hs build-depends: base == 4.* + , lens , servant-jquery , servant , hspec >= 2.0 diff --git a/src/Servant/JQuery/Internal.hs b/src/Servant/JQuery/Internal.hs index 31c059ca..3ff0ae5d 100644 --- a/src/Servant/JQuery/Internal.hs +++ b/src/Servant/JQuery/Internal.hs @@ -72,7 +72,7 @@ instance Show HeaderArg where | otherwise = p where pv = "header" <> n - pn = "{header" <> n <> "}" + pn = "{" <> n <> "}" rp = replace pn "" p data Url = Url diff --git a/test/Servant/JQuerySpec.hs b/test/Servant/JQuerySpec.hs index 83135701..db3f1146 100644 --- a/test/Servant/JQuerySpec.hs +++ b/test/Servant/JQuerySpec.hs @@ -14,6 +14,7 @@ import Test.Hspec import Servant.API import Servant.JQuery +import Servant.JQuerySpec.CustomHeaders type TestAPI = [sitemap| POST /simple String -> Bool @@ -26,9 +27,15 @@ type TopLevelRawAPI = "something" :> Get Int type HeaderHandlingAPI = "something" :> Header "Foo" String :> Get Int +type CustomAuthAPI = "something" :> Authorization "Basic" String + :> Get Int + headerHandlingProxy :: Proxy HeaderHandlingAPI headerHandlingProxy = Proxy +customAuthProxy :: Proxy CustomAuthAPI +customAuthProxy = Proxy + spec :: Spec spec = describe "Servant.JQuery" generateJSSpec @@ -53,3 +60,10 @@ generateJSSpec = describe "generateJS" $ do jsText `shouldContain` "headerFoo" jsText `shouldContain` "headers: { \"Foo\": headerFoo }\n" + it "should handle complex HTTP headers" $ do + let jsText = generateJS $ jquery customAuthProxy + print jsText + parseFromString jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerAuthorization" + jsText `shouldContain` "headers: { \"Authorization\": \"Basic \" + headerAuthorization }\n" + diff --git a/test/Servant/JQuerySpec/CustomHeaders.hs b/test/Servant/JQuerySpec/CustomHeaders.hs new file mode 100644 index 00000000..d70bb076 --- /dev/null +++ b/test/Servant/JQuerySpec/CustomHeaders.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.JQuerySpec.CustomHeaders where + +import Control.Lens +import Data.Monoid +import Data.Proxy +import GHC.TypeLits +import Servant.API +import Servant.JQuery + +-- | This is a hypothetical combinator that fetches an Authorization header. +-- The symbol in the header denotes what kind of authentication we are +-- using -- Basic, Digest, whatever. +data Authorization (sym :: Symbol) a + +instance (KnownSymbol sym, HasJQ sublayout) + => HasJQ (Authorization sym a :> sublayout) where + type JQ (Authorization sym a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $ + tokenType (symbolVal (Proxy :: Proxy sym)) ] + where + tokenType t = t <> " {Authorization}" From 745dbd09a9093a30fdbe11f5eab1d24bcd0900ef Mon Sep 17 00:00:00 2001 From: Geoffrey Roberts Date: Wed, 21 Jan 2015 19:32:06 +1100 Subject: [PATCH 3/6] Actually sanitise function names and handle X-Custom headers --- servant-jquery.cabal | 6 +++- src/Servant/JQuery.hs | 6 ++-- src/Servant/JQuery/Internal.hs | 35 ++++++++++++++++++++++-- test/Servant/JQuerySpec.hs | 12 ++++++++ test/Servant/JQuerySpec/CustomHeaders.hs | 18 ++++++++++-- 5 files changed, 68 insertions(+), 9 deletions(-) diff --git a/servant-jquery.cabal b/servant-jquery.cabal index 6767f6be..b15a6f6c 100644 --- a/servant-jquery.cabal +++ b/servant-jquery.cabal @@ -31,7 +31,11 @@ flag example library exposed-modules: Servant.JQuery other-modules: Servant.JQuery.Internal - build-depends: base >=4.5 && <5, servant >= 0.2.1, lens >= 4, MissingH + build-depends: base >=4.5 && <5 + , servant >= 0.2.1 + , lens >= 4 + , MissingH + , charset hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Servant/JQuery.hs b/src/Servant/JQuery.hs index e4bc3be4..38ff92d8 100644 --- a/src/Servant/JQuery.hs +++ b/src/Servant/JQuery.hs @@ -44,7 +44,7 @@ generateJS req = "\n" <> args = captures ++ map (view argName) queryparams ++ body - ++ map ((<>) "header" . headerArgName) hs + ++ map (toValidFunctionName . (<>) "header" . headerArgName) hs ++ ["onSuccess", "onError"] captures = map captureArg @@ -70,7 +70,9 @@ generateJS req = "\n" <> else "\n , headers: { " ++ headersStr ++ " }\n" where headersStr = intercalate ", " $ map headerStr hs - headerStr header = "\"" ++ headerArgName header ++ "\": " ++ show header + headerStr header = "\"" ++ + headerArgName header ++ + "\": " ++ show header fname = req ^. funcName method = req ^. reqMethod diff --git a/src/Servant/JQuery/Internal.hs b/src/Servant/JQuery/Internal.hs index 3ff0ae5d..1fc16d80 100644 --- a/src/Servant/JQuery/Internal.hs +++ b/src/Servant/JQuery/Internal.hs @@ -9,6 +9,8 @@ module Servant.JQuery.Internal where import Control.Applicative import Control.Lens import Data.Char (toLower) +import qualified Data.CharSet as Set +import qualified Data.CharSet.Unicode.Category as Set import Data.List import Data.Monoid import Data.Proxy @@ -64,17 +66,44 @@ data HeaderArg = HeaderArg } deriving (Eq) instance Show HeaderArg where - show (HeaderArg n) = "header" <> n + show (HeaderArg n) = toValidFunctionName ("header" <> n) show (ReplaceHeaderArg n p) | pn `startswith` p = pv <> " + \"" <> rp <> "\"" | pn `endswith` p = "\"" <> rp <> "\" + " <> pv - | pn `isInfixOf` p = "\"" <> replace pn ("\"" <> pv <> "\"") p <> "\"" + | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) <> "\"" | otherwise = p where - pv = "header" <> n + pv = toValidFunctionName ("header" <> n) pn = "{" <> n <> "}" rp = replace pn "" p +-- | Attempts to reduce the function name provided to that allowed by JS. +-- https://mathiasbynens.be/notes/javascript-identifiers +-- Couldn't work out how to handle zero-width characters. +-- @TODO: specify better default function name, or throw error? +toValidFunctionName :: String -> String +toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs + where + setFirstChar c = if firstChar c + then c + else '_' + firstChar c = (prefixOK c) || (or . map (Set.member c) $ firstLetterOK) + remainder c = (prefixOK c) || (or . map (Set.member c) $ remainderOK) + -- Valid prefixes + prefixOK c = c `elem` ['$','_'] + -- Unicode character sets + firstLetterOK = [ Set.lowercaseLetter + , Set.uppercaseLetter + , Set.titlecaseLetter + , Set.modifierLetter + , Set.otherLetter + , Set.letterNumber ] + remainderOK = firstLetterOK <> [ Set.nonSpacingMark + , Set.spacingCombiningMark + , Set.decimalNumber + , Set.connectorPunctuation ] +toValidFunctionName [] = "_" + data Url = Url { _path :: Path , _queryStr :: [QueryArg] diff --git a/test/Servant/JQuerySpec.hs b/test/Servant/JQuerySpec.hs index db3f1146..ada56d27 100644 --- a/test/Servant/JQuerySpec.hs +++ b/test/Servant/JQuerySpec.hs @@ -30,12 +30,18 @@ type HeaderHandlingAPI = "something" :> Header "Foo" String type CustomAuthAPI = "something" :> Authorization "Basic" String :> Get Int +type CustomHeaderAPI = "something" :> MyLovelyHorse String + :> Get Int + headerHandlingProxy :: Proxy HeaderHandlingAPI headerHandlingProxy = Proxy customAuthProxy :: Proxy CustomAuthAPI customAuthProxy = Proxy +customHeaderProxy :: Proxy CustomHeaderAPI +customHeaderProxy = Proxy + spec :: Spec spec = describe "Servant.JQuery" generateJSSpec @@ -67,3 +73,9 @@ generateJSSpec = describe "generateJS" $ do jsText `shouldContain` "headerAuthorization" jsText `shouldContain` "headers: { \"Authorization\": \"Basic \" + headerAuthorization }\n" + it "should handle complex, custom HTTP headers" $ do + let jsText = generateJS $ jquery customHeaderProxy + print jsText + parseFromString jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerXMyLovelyHorse" + jsText `shouldContain` "headers: { \"X-MyLovelyHorse\": \"I am good friends with \" + headerXMyLovelyHorse }\n" diff --git a/test/Servant/JQuerySpec/CustomHeaders.hs b/test/Servant/JQuerySpec/CustomHeaders.hs index d70bb076..4bb378d9 100644 --- a/test/Servant/JQuerySpec/CustomHeaders.hs +++ b/test/Servant/JQuerySpec/CustomHeaders.hs @@ -21,11 +21,23 @@ import Servant.JQuery data Authorization (sym :: Symbol) a instance (KnownSymbol sym, HasJQ sublayout) - => HasJQ (Authorization sym a :> sublayout) where + => HasJQ (Authorization sym a :> sublayout) where type JQ (Authorization sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $ - tokenType (symbolVal (Proxy :: Proxy sym)) ] + tokenType (symbolVal (Proxy :: Proxy sym)) ] where - tokenType t = t <> " {Authorization}" + tokenType t = t <> " {Authorization}" + +-- | This is a combinator that fetches an X-MyLovelyHorse header. +data MyLovelyHorse a + +instance (HasJQ sublayout) + => HasJQ (MyLovelyHorse a :> sublayout) where + type JQ (MyLovelyHorse a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ] + where + tpl = "I am good friends with {X-MyLovelyHorse}" From 21e9c9f5c95dabd60090fdc39c58ddf3dd578a2f Mon Sep 17 00:00:00 2001 From: Geoffrey Roberts Date: Thu, 22 Jan 2015 11:24:36 +1100 Subject: [PATCH 4/6] Switched out MissingH for an implementation using split --- servant-jquery.cabal | 6 +++--- src/Servant/JQuery/Internal.hs | 11 +++++++---- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/servant-jquery.cabal b/servant-jquery.cabal index b15a6f6c..b2d77cad 100644 --- a/servant-jquery.cabal +++ b/servant-jquery.cabal @@ -32,10 +32,10 @@ library exposed-modules: Servant.JQuery other-modules: Servant.JQuery.Internal build-depends: base >=4.5 && <5 - , servant >= 0.2.1 - , lens >= 4 - , MissingH , charset + , lens >= 4 + , servant >= 0.2.1 + , split hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Servant/JQuery/Internal.hs b/src/Servant/JQuery/Internal.hs index 1fc16d80..350bec56 100644 --- a/src/Servant/JQuery/Internal.hs +++ b/src/Servant/JQuery/Internal.hs @@ -12,9 +12,9 @@ import Data.Char (toLower) import qualified Data.CharSet as Set import qualified Data.CharSet.Unicode.Category as Set import Data.List +import Data.List.Split import Data.Monoid import Data.Proxy -import Data.String.Utils import GHC.TypeLits import Servant.API @@ -68,14 +68,17 @@ data HeaderArg = HeaderArg instance Show HeaderArg where show (HeaderArg n) = toValidFunctionName ("header" <> n) show (ReplaceHeaderArg n p) - | pn `startswith` p = pv <> " + \"" <> rp <> "\"" - | pn `endswith` p = "\"" <> rp <> "\" + " <> pv - | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) <> "\"" + | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\"" + | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv + | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) + <> "\"" | otherwise = p where pv = toValidFunctionName ("header" <> n) pn = "{" <> n <> "}" rp = replace pn "" p + -- Nicked from Data.String.Utils, works on lists + replace old new l = intercalate new . splitOn old $ l -- | Attempts to reduce the function name provided to that allowed by JS. -- https://mathiasbynens.be/notes/javascript-identifiers From 8aa5ce504eb6266607982a600443a88417fc8a3a Mon Sep 17 00:00:00 2001 From: Geoffrey Roberts Date: Thu, 22 Jan 2015 11:33:19 +1100 Subject: [PATCH 5/6] Switched again to Text because it made more sense given the dependency structure --- servant-jquery.cabal | 2 +- src/Servant/JQuery/Internal.hs | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/servant-jquery.cabal b/servant-jquery.cabal index b2d77cad..de237791 100644 --- a/servant-jquery.cabal +++ b/servant-jquery.cabal @@ -35,7 +35,7 @@ library , charset , lens >= 4 , servant >= 0.2.1 - , split + , text hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Servant/JQuery/Internal.hs b/src/Servant/JQuery/Internal.hs index 350bec56..c8f583ca 100644 --- a/src/Servant/JQuery/Internal.hs +++ b/src/Servant/JQuery/Internal.hs @@ -12,9 +12,9 @@ import Data.Char (toLower) import qualified Data.CharSet as Set import qualified Data.CharSet.Unicode.Category as Set import Data.List -import Data.List.Split import Data.Monoid import Data.Proxy +import qualified Data.Text as T import GHC.TypeLits import Servant.API @@ -77,8 +77,10 @@ instance Show HeaderArg where pv = toValidFunctionName ("header" <> n) pn = "{" <> n <> "}" rp = replace pn "" p - -- Nicked from Data.String.Utils, works on lists - replace old new l = intercalate new . splitOn old $ l + -- Use replace method from Data.Text + replace old new = T.unpack . + T.replace (T.pack old) (T.pack new) . + T.pack -- | Attempts to reduce the function name provided to that allowed by JS. -- https://mathiasbynens.be/notes/javascript-identifiers From d7f9e30fc8ee081d8e1059011fe685c157b341ec Mon Sep 17 00:00:00 2001 From: Geoffrey Roberts Date: Thu, 22 Jan 2015 11:41:06 +1100 Subject: [PATCH 6/6] Add a test to explicitly cover header variable template replacement --- test/Servant/JQuerySpec.hs | 13 +++++++++++++ test/Servant/JQuerySpec/CustomHeaders.hs | 12 ++++++++++++ 2 files changed, 25 insertions(+) diff --git a/test/Servant/JQuerySpec.hs b/test/Servant/JQuerySpec.hs index ada56d27..fdc9331f 100644 --- a/test/Servant/JQuerySpec.hs +++ b/test/Servant/JQuerySpec.hs @@ -33,6 +33,9 @@ type CustomAuthAPI = "something" :> Authorization "Basic" String type CustomHeaderAPI = "something" :> MyLovelyHorse String :> Get Int +type CustomHeaderAPI2 = "something" :> WhatsForDinner String + :> Get Int + headerHandlingProxy :: Proxy HeaderHandlingAPI headerHandlingProxy = Proxy @@ -42,6 +45,9 @@ customAuthProxy = Proxy customHeaderProxy :: Proxy CustomHeaderAPI customHeaderProxy = Proxy +customHeaderProxy2 :: Proxy CustomHeaderAPI2 +customHeaderProxy2 = Proxy + spec :: Spec spec = describe "Servant.JQuery" generateJSSpec @@ -79,3 +85,10 @@ generateJSSpec = describe "generateJS" $ do parseFromString jsText `shouldSatisfy` isRight jsText `shouldContain` "headerXMyLovelyHorse" jsText `shouldContain` "headers: { \"X-MyLovelyHorse\": \"I am good friends with \" + headerXMyLovelyHorse }\n" + + it "should handle complex, custom HTTP headers (template replacement)" $ do + let jsText = generateJS $ jquery customHeaderProxy2 + print jsText + parseFromString jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerXWhatsForDinner" + jsText `shouldContain` "headers: { \"X-WhatsForDinner\": \"I would like \" + headerXWhatsForDinner + \" with a cherry on top.\" }\n" diff --git a/test/Servant/JQuerySpec/CustomHeaders.hs b/test/Servant/JQuerySpec/CustomHeaders.hs index 4bb378d9..4480d44c 100644 --- a/test/Servant/JQuerySpec/CustomHeaders.hs +++ b/test/Servant/JQuerySpec/CustomHeaders.hs @@ -41,3 +41,15 @@ instance (HasJQ sublayout) req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ] where tpl = "I am good friends with {X-MyLovelyHorse}" + +-- | This is a combinator that fetches an X-WhatsForDinner header. +data WhatsForDinner a + +instance (HasJQ sublayout) + => HasJQ (WhatsForDinner a :> sublayout) where + type JQ (WhatsForDinner a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ] + where + tpl = "I would like {X-WhatsForDinner} with a cherry on top."