Extended HeaderArg to allow header arguments to replace the contents of a template, allowing specially composed headers to create specially formatted headers
This commit is contained in:
parent
3dc9424765
commit
e16f90f107
4 changed files with 46 additions and 9 deletions
|
@ -31,7 +31,7 @@ flag example
|
||||||
library
|
library
|
||||||
exposed-modules: Servant.JQuery
|
exposed-modules: Servant.JQuery
|
||||||
other-modules: Servant.JQuery.Internal
|
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
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
@ -68,5 +68,6 @@ test-suite spec
|
||||||
, servant-jquery
|
, servant-jquery
|
||||||
, servant
|
, servant
|
||||||
, hspec >= 2.0
|
, hspec >= 2.0
|
||||||
|
, hspec-expectations
|
||||||
, language-ecmascript == 0.16.*
|
, language-ecmascript == 0.16.*
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
@ -44,7 +44,7 @@ generateJS req = "\n" <>
|
||||||
args = captures
|
args = captures
|
||||||
++ map (view argName) queryparams
|
++ map (view argName) queryparams
|
||||||
++ body
|
++ body
|
||||||
++ map ("header"++) hs
|
++ map ((<>) "header" . headerArgName) hs
|
||||||
++ ["onSuccess", "onError"]
|
++ ["onSuccess", "onError"]
|
||||||
|
|
||||||
captures = map captureArg
|
captures = map captureArg
|
||||||
|
@ -67,10 +67,10 @@ generateJS req = "\n" <>
|
||||||
reqheaders =
|
reqheaders =
|
||||||
if null hs
|
if null hs
|
||||||
then ""
|
then ""
|
||||||
else "\n , headers: { " ++ headersStr ++ " } }\n"
|
else "\n , headers: { " ++ headersStr ++ " }\n"
|
||||||
|
|
||||||
where headersStr = intercalate ", " $ map headerStr hs
|
where headersStr = intercalate ", " $ map headerStr hs
|
||||||
headerStr hname = "\"" ++ hname ++ "\": header" ++ hname
|
headerStr header = "\"" ++ headerArgName header ++ "\": " ++ show header
|
||||||
|
|
||||||
fname = req ^. funcName
|
fname = req ^. funcName
|
||||||
method = req ^. reqMethod
|
method = req ^. reqMethod
|
||||||
|
|
|
@ -9,8 +9,10 @@ module Servant.JQuery.Internal where
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Data.Char (toLower)
|
import Data.Char (toLower)
|
||||||
|
import Data.List
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
|
import Data.String.Utils
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
import Servant.API
|
import Servant.API
|
||||||
|
|
||||||
|
@ -53,7 +55,25 @@ data QueryArg = QueryArg
|
||||||
, _argType :: ArgType
|
, _argType :: ArgType
|
||||||
} deriving (Eq, Show)
|
} 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
|
data Url = Url
|
||||||
{ _path :: Path
|
{ _path :: Path
|
||||||
|
@ -144,7 +164,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
|
||||||
type JQ (Header sym a :> sublayout) = JQ sublayout
|
type JQ (Header sym a :> sublayout) = JQ sublayout
|
||||||
|
|
||||||
jqueryFor Proxy req =
|
jqueryFor Proxy req =
|
||||||
jqueryFor subP (req & reqHeaders <>~ [hname])
|
jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
|
||||||
|
|
||||||
where hname = symbolVal (Proxy :: Proxy sym)
|
where hname = symbolVal (Proxy :: Proxy sym)
|
||||||
subP = Proxy :: Proxy sublayout
|
subP = Proxy :: Proxy sublayout
|
||||||
|
|
|
@ -1,6 +1,9 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
module Servant.JQuerySpec where
|
module Servant.JQuerySpec where
|
||||||
|
|
||||||
|
@ -20,6 +23,12 @@ GET /has.extension Bool
|
||||||
type TopLevelRawAPI = "something" :> Get Int
|
type TopLevelRawAPI = "something" :> Get Int
|
||||||
:<|> Raw
|
:<|> Raw
|
||||||
|
|
||||||
|
type HeaderHandlingAPI = "something" :> Header "Foo" String
|
||||||
|
:> Get Int
|
||||||
|
|
||||||
|
headerHandlingProxy :: Proxy HeaderHandlingAPI
|
||||||
|
headerHandlingProxy = Proxy
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = describe "Servant.JQuery"
|
spec = describe "Servant.JQuery"
|
||||||
generateJSSpec
|
generateJSSpec
|
||||||
|
@ -37,3 +46,10 @@ generateJSSpec = describe "generateJS" $ do
|
||||||
print $ generateJS $ topLevel "GET"
|
print $ generateJS $ topLevel "GET"
|
||||||
parseFromString (generateJS $ topLevel "GET") `shouldSatisfy` isRight
|
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"
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue