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

@@ -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

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

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

test/Servant/JQuerySpec.hs

@@ -1,5 +1,8 @@
 {-# 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"
+