Merge pull request #6 from rtrvrtg/wip-header-value-templates

Extend HeaderArg to support advanced HTTP Header handling

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
+  build-depends:       base >=4.5 && <5
+                     , charset
+                     , lens >= 4
+                     , servant >= 0.2.1
+                     , text
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall
@@ -65,8 +69,10 @@ test-suite spec
   main-is:           Spec.hs
   build-depends:
       base == 4.*
+    , lens
     , 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 (toValidFunctionName . (<>) "header" . headerArgName) hs
             ++ ["onSuccess", "onError"]
         
         captures = map captureArg
@@ -67,10 +67,12 @@ 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,12 @@ 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
+import qualified Data.Text as T
 import GHC.TypeLits
 import Servant.API
 
@@ -53,7 +57,57 @@ 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)          = toValidFunctionName ("header" <> n)
+    show (ReplaceHeaderArg n 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
+        -- 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
+-- 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
@@ -144,7 +198,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
@@ -11,6 +14,7 @@ import Test.Hspec
 
 import Servant.API
 import Servant.JQuery
+import Servant.JQuerySpec.CustomHeaders
 
 type TestAPI = [sitemap|
 POST    /simple                  String -> Bool
@@ -20,6 +24,30 @@ GET     /has.extension           Bool
 type TopLevelRawAPI = "something" :> Get Int
                   :<|> Raw
 
+type HeaderHandlingAPI = "something" :> Header "Foo" String
+                                     :> Get Int
+
+type CustomAuthAPI = "something" :> Authorization "Basic" String
+                                 :> Get Int
+
+type CustomHeaderAPI = "something" :> MyLovelyHorse String
+                                   :> Get Int
+
+type CustomHeaderAPI2 = "something" :> WhatsForDinner String
+                                    :> Get Int
+
+headerHandlingProxy :: Proxy HeaderHandlingAPI
+headerHandlingProxy = Proxy
+
+customAuthProxy :: Proxy CustomAuthAPI
+customAuthProxy = Proxy
+
+customHeaderProxy :: Proxy CustomHeaderAPI
+customHeaderProxy = Proxy
+
+customHeaderProxy2 :: Proxy CustomHeaderAPI2
+customHeaderProxy2 = Proxy
+
 spec :: Spec
 spec = describe "Servant.JQuery"
     generateJSSpec
@@ -37,3 +65,30 @@ 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"
+
+    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"
+
+    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"
+
+    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"

test/Servant/JQuerySpec/CustomHeaders.hs

@@ -0,0 +1,55 @@
+{-# 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}"
+
+-- | 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}"
+
+-- | 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."