f62bb79 · servant · git.iko.soy

git.iko.soy/servant

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

Extend HeaderArg to support advanced HTTP Header handling

commitf62bb79da148f9a5815b6ead7af03398946272bb authorAlp Mestanogullari <alpmestan@gmail.com> dateThu 22 Jan 2015, 02:01 (12 years ago) parent3dc9424 d7f9e30

5 files changed+181−9

compare with master

unifiedsplit

servant-jquery.cabal+7−1 src/Servant/JQuery.hs+5−3 src/Servant/JQuery/Internal.hs+56−2 test/Servant/JQuerySpec.hs+58−3 test/Servant/JQuerySpec/CustomHeaders.hs+55

servant-jquery.cabal+7−1

@@ -31,7 +31,11 @@ flag example

3131library

3232 exposed-modules: Servant.JQuery

3333 other-modules: Servant.JQuery.Internal

34− build-depends: base >=4.5 && <5, servant >= 0.2.1, lens >= 4

34+ build-depends: base >=4.5 && <5

35+ , charset

36+ , lens >= 4

37+ , servant >= 0.2.1

38+ , text

3539 hs-source-dirs: src

3640 default-language: Haskell2010

3741 ghc-options: -Wall

@@ -65,8 +69,10 @@ test-suite spec

6569 main-is: Spec.hs

6670 build-depends:

6771 base == 4.*

72+ , lens

6873 , servant-jquery

6974 , servant

7075 , hspec >= 2.0

76+ , hspec-expectations

7177 , language-ecmascript == 0.16.*

7278 default-language: Haskell2010

src/Servant/JQuery.hs+5−3

@@ -44,7 +44,7 @@ generateJS req = "\n" <>

4444 args = captures

4545 ++ map (view argName) queryparams

4646 ++ body

47− ++ map ("header"++) hs

47+ ++ map (toValidFunctionName . (<>) "header" . headerArgName) hs

4848 ++ ["onSuccess", "onError"]

4949

5050 captures = map captureArg

@@ -67,10 +67,12 @@ generateJS req = "\n" <>

6767 reqheaders =

6868 if null hs

6969 then ""

70− else "\n , headers: { " ++ headersStr ++ " } }\n"

70+ else "\n , headers: { " ++ headersStr ++ " }\n"

7171

7272 where headersStr = intercalate ", " $ map headerStr hs

73− headerStr hname = "\"" ++ hname ++ "\": header" ++ hname

73+ headerStr header = "\"" ++

74+ headerArgName header ++

75+ "\": " ++ show header

7476

7577 fname = req ^. funcName

7678 method = req ^. reqMethod

src/Servant/JQuery/Internal.hs+56−2

@@ -9,8 +9,12 @@ module Servant.JQuery.Internal where

99import Control.Applicative

1010import Control.Lens

1111import Data.Char (toLower)

12+import qualified Data.CharSet as Set

13+import qualified Data.CharSet.Unicode.Category as Set

14+import Data.List

1215import Data.Monoid

1316import Data.Proxy

17+import qualified Data.Text as T

1418import GHC.TypeLits

1519import Servant.API

1620

@@ -53,7 +57,57 @@ data QueryArg = QueryArg

5357 , _argType :: ArgType

5458 } deriving (Eq, Show)

5559

56−type HeaderArg = String

60+data HeaderArg = HeaderArg

61+ { headerArgName :: String

62+ }

63+ | ReplaceHeaderArg

64+ { headerArgName :: String

65+ , headerPattern :: String

66+ } deriving (Eq)

67+

68+instance Show HeaderArg where

69+ show (HeaderArg n) = toValidFunctionName ("header" <> n)

70+ show (ReplaceHeaderArg n p)

71+ | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\""

72+ | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv

73+ | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p)

74+ <> "\""

75+ | otherwise = p

76+ where

77+ pv = toValidFunctionName ("header" <> n)

78+ pn = "{" <> n <> "}"

79+ rp = replace pn "" p

80+ -- Use replace method from Data.Text

81+ replace old new = T.unpack .

82+ T.replace (T.pack old) (T.pack new) .

83+ T.pack

84+

85+-- | Attempts to reduce the function name provided to that allowed by JS.

86+-- https://mathiasbynens.be/notes/javascript-identifiers

87+-- Couldn't work out how to handle zero-width characters.

88+-- @TODO: specify better default function name, or throw error?

89+toValidFunctionName :: String -> String

90+toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs

91+ where

92+ setFirstChar c = if firstChar c

93+ then c

94+ else '_'

95+ firstChar c = (prefixOK c) || (or . map (Set.member c) $ firstLetterOK)

96+ remainder c = (prefixOK c) || (or . map (Set.member c) $ remainderOK)

97+ -- Valid prefixes

98+ prefixOK c = c `elem` ['$','_']

99+ -- Unicode character sets

100+ firstLetterOK = [ Set.lowercaseLetter

101+ , Set.uppercaseLetter

102+ , Set.titlecaseLetter

103+ , Set.modifierLetter

104+ , Set.otherLetter

105+ , Set.letterNumber ]

106+ remainderOK = firstLetterOK <> [ Set.nonSpacingMark

107+ , Set.spacingCombiningMark

108+ , Set.decimalNumber

109+ , Set.connectorPunctuation ]

110+toValidFunctionName [] = "_"

57111

58112data Url = Url

59113 { _path :: Path

@@ -144,7 +198,7 @@ instance (KnownSymbol sym, HasJQ sublayout)

144198 type JQ (Header sym a :> sublayout) = JQ sublayout

145199

146200 jqueryFor Proxy req =

147− jqueryFor subP (req & reqHeaders <>~ [hname])

201+ jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])

148202

149203 where hname = symbolVal (Proxy :: Proxy sym)

150204 subP = Proxy :: Proxy sublayout

test/Servant/JQuerySpec.hs+58−3

@@ -1,6 +1,9 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE QuasiQuotes #-}

3−{-# LANGUAGE TypeOperators #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE QuasiQuotes #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE TypeOperators #-}

47{-# OPTIONS_GHC -fno-warn-orphans #-}

58module Servant.JQuerySpec where

@@ -11,6 +14,7 @@ import Test.Hspec

1114

1215import Servant.API

1316import Servant.JQuery

17+import Servant.JQuerySpec.CustomHeaders

1418

1519type TestAPI = [sitemap|

1620POST /simple String -> Bool

@@ -20,6 +24,30 @@ GET /has.extension Bool

2024type TopLevelRawAPI = "something" :> Get Int

2125 :<|> Raw

2226

27+type HeaderHandlingAPI = "something" :> Header "Foo" String

28+ :> Get Int

29+

30+type CustomAuthAPI = "something" :> Authorization "Basic" String

31+ :> Get Int

32+

33+type CustomHeaderAPI = "something" :> MyLovelyHorse String

34+ :> Get Int

35+

36+type CustomHeaderAPI2 = "something" :> WhatsForDinner String

37+ :> Get Int

38+

39+headerHandlingProxy :: Proxy HeaderHandlingAPI

40+headerHandlingProxy = Proxy

41+

42+customAuthProxy :: Proxy CustomAuthAPI

43+customAuthProxy = Proxy

44+

45+customHeaderProxy :: Proxy CustomHeaderAPI

46+customHeaderProxy = Proxy

47+

48+customHeaderProxy2 :: Proxy CustomHeaderAPI2

49+customHeaderProxy2 = Proxy

50+

2351spec :: Spec

2452spec = describe "Servant.JQuery"

2553 generateJSSpec

@@ -37,3 +65,30 @@ generateJSSpec = describe "generateJS" $ do

3765 print $ generateJS $ topLevel "GET"

3866 parseFromString (generateJS $ topLevel "GET") `shouldSatisfy` isRight

3967

68+ it "should handle simple HTTP headers" $ do

69+ let jsText = generateJS $ jquery headerHandlingProxy

70+ print jsText

71+ parseFromString jsText `shouldSatisfy` isRight

72+ jsText `shouldContain` "headerFoo"

73+ jsText `shouldContain` "headers: { \"Foo\": headerFoo }\n"

74+

75+ it "should handle complex HTTP headers" $ do

76+ let jsText = generateJS $ jquery customAuthProxy

77+ print jsText

78+ parseFromString jsText `shouldSatisfy` isRight

79+ jsText `shouldContain` "headerAuthorization"

80+ jsText `shouldContain` "headers: { \"Authorization\": \"Basic \" + headerAuthorization }\n"

81+

82+ it "should handle complex, custom HTTP headers" $ do

83+ let jsText = generateJS $ jquery customHeaderProxy

84+ print jsText

85+ parseFromString jsText `shouldSatisfy` isRight

86+ jsText `shouldContain` "headerXMyLovelyHorse"

87+ jsText `shouldContain` "headers: { \"X-MyLovelyHorse\": \"I am good friends with \" + headerXMyLovelyHorse }\n"

88+

89+ it "should handle complex, custom HTTP headers (template replacement)" $ do

90+ let jsText = generateJS $ jquery customHeaderProxy2

91+ print jsText

92+ parseFromString jsText `shouldSatisfy` isRight

93+ jsText `shouldContain` "headerXWhatsForDinner"

94+ jsText `shouldContain` "headers: { \"X-WhatsForDinner\": \"I would like \" + headerXWhatsForDinner + \" with a cherry on top.\" }\n"

test/Servant/JQuerySpec/CustomHeaders.hsnew file+55

@@ -0,0 +1,55 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeOperators #-}

9+module Servant.JQuerySpec.CustomHeaders where

10+

11+import Control.Lens

12+import Data.Monoid

13+import Data.Proxy

14+import GHC.TypeLits

15+import Servant.API

16+import Servant.JQuery

17+

18+-- | This is a hypothetical combinator that fetches an Authorization header.

19+-- The symbol in the header denotes what kind of authentication we are

20+-- using -- Basic, Digest, whatever.

21+data Authorization (sym :: Symbol) a

22+

23+instance (KnownSymbol sym, HasJQ sublayout)

24+ => HasJQ (Authorization sym a :> sublayout) where

25+ type JQ (Authorization sym a :> sublayout) = JQ sublayout

26+

27+ jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $

28+ req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $

29+ tokenType (symbolVal (Proxy :: Proxy sym)) ]

30+ where

31+ tokenType t = t <> " {Authorization}"

32+

33+-- | This is a combinator that fetches an X-MyLovelyHorse header.

34+data MyLovelyHorse a

35+

36+instance (HasJQ sublayout)

37+ => HasJQ (MyLovelyHorse a :> sublayout) where

38+ type JQ (MyLovelyHorse a :> sublayout) = JQ sublayout

39+

40+ jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $

41+ req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ]

42+ where

43+ tpl = "I am good friends with {X-MyLovelyHorse}"

44+

45+-- | This is a combinator that fetches an X-WhatsForDinner header.

46+data WhatsForDinner a

47+

48+instance (HasJQ sublayout)

49+ => HasJQ (WhatsForDinner a :> sublayout) where

50+ type JQ (WhatsForDinner a :> sublayout) = JQ sublayout

51+

52+ jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $

53+ req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ]

54+ where

55+ tpl = "I would like {X-WhatsForDinner} with a cherry on top."