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