Actually sanitise function names and handle X-Custom headers

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

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

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]

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"

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}"