git.iko.soy/servant
on master help sign in
Merge pull request #6 from rtrvrtg/wip-header-value-templates
f62bb79Alp Mestanogullari
servant-jquery.cabal+7−1
compare with master
unifiedsplit
@@ -31,7 +31,11 @@ flag example
31library
31library
32 exposed-modules: Servant.JQuery
32 exposed-modules: Servant.JQuery
33 other-modules: Servant.JQuery.Internal
33 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
35 hs-source-dirs: src
39 hs-source-dirs: src
36 default-language: Haskell2010
40 default-language: Haskell2010
37 ghc-options: -Wall
41 ghc-options: -Wall
@@ -65,8 +69,10 @@ test-suite spec
65 main-is: Spec.hs
69 main-is: Spec.hs
66 build-depends:
70 build-depends:
67 base == 4.*
71 base == 4.*
72+ , lens
68 , servant-jquery
73 , servant-jquery
69 , servant
74 , servant
70 , hspec >= 2.0
75 , hspec >= 2.0
76+ , hspec-expectations
71 , language-ecmascript == 0.16.*
77 , language-ecmascript == 0.16.*
72 default-language: Haskell2010
78 default-language: Haskell2010
src/Servant/JQuery.hs+5−3
@@ -44,7 +44,7 @@ generateJS req = "\n" <>
44 args = captures
44 args = captures
45 ++ map (view argName) queryparams
45 ++ map (view argName) queryparams
46 ++ body
46 ++ body
47− ++ map ("header"++) hs
47+ ++ map (toValidFunctionName . (<>) "header" . headerArgName) hs
48 ++ ["onSuccess", "onError"]
48 ++ ["onSuccess", "onError"]
49
49
50 captures = map captureArg
50 captures = map captureArg
@@ -67,10 +67,12 @@ generateJS req = "\n" <>
67 reqheaders =
67 reqheaders =
68 if null hs
68 if null hs
69 then ""
69 then ""
70− else "\n , headers: { " ++ headersStr ++ " } }\n"
70+ else "\n , headers: { " ++ headersStr ++ " }\n"
71
71
72 where headersStr = intercalate ", " $ map headerStr hs
72 where headersStr = intercalate ", " $ map headerStr hs
73− headerStr hname = "\"" ++ hname ++ "\": header" ++ hname
73+ headerStr header = "\"" ++
74+ headerArgName header ++
75+ "\": " ++ show header
74
76
75 fname = req ^. funcName
77 fname = req ^. funcName
76 method = req ^. reqMethod
78 method = req ^. reqMethod
src/Servant/JQuery/Internal.hs+56−2
@@ -9,8 +9,12 @@ module Servant.JQuery.Internal where
9import Control.Applicative
9import Control.Applicative
10import Control.Lens
10import Control.Lens
11import Data.Char (toLower)
11import Data.Char (toLower)
12+import qualified Data.CharSet as Set
13+import qualified Data.CharSet.Unicode.Category as Set
14+import Data.List
12import Data.Monoid
15import Data.Monoid
13import Data.Proxy
16import Data.Proxy
17+import qualified Data.Text as T
14import GHC.TypeLits
18import GHC.TypeLits
15import Servant.API
19import Servant.API
16
20
@@ -53,7 +57,57 @@ data QueryArg = QueryArg
53 , _argType :: ArgType
57 , _argType :: ArgType
54 } deriving (Eq, Show)
58 } deriving (Eq, Show)
55
59
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 [] = "_"
57
111
58data Url = Url
112data Url = Url
59 { _path :: Path
113 { _path :: Path
@@ -144,7 +198,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
144 type JQ (Header sym a :> sublayout) = JQ sublayout
198 type JQ (Header sym a :> sublayout) = JQ sublayout
145
199
146 jqueryFor Proxy req =
200 jqueryFor Proxy req =
147− jqueryFor subP (req & reqHeaders <>~ [hname])
201+ jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
148
202
149 where hname = symbolVal (Proxy :: Proxy sym)
203 where hname = symbolVal (Proxy :: Proxy sym)
150 subP = Proxy :: Proxy sublayout
204 subP = Proxy :: Proxy sublayout
test/Servant/JQuerySpec.hs+58−3
@@ -1,6 +1,9 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE QuasiQuotes #-}
3+{-# LANGUAGE QuasiQuotes #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE TypeOperators #-}
4{-# OPTIONS_GHC -fno-warn-orphans #-}
7{-# OPTIONS_GHC -fno-warn-orphans #-}
5module Servant.JQuerySpec where
8module Servant.JQuerySpec where
6
9
@@ -11,6 +14,7 @@ import Test.Hspec
11
14
12import Servant.API
15import Servant.API
13import Servant.JQuery
16import Servant.JQuery
17+import Servant.JQuerySpec.CustomHeaders
14
18
15type TestAPI = [sitemap|
19type TestAPI = [sitemap|
16POST /simple String -> Bool
20POST /simple String -> Bool
@@ -20,6 +24,30 @@ GET /has.extension Bool
20type TopLevelRawAPI = "something" :> Get Int
24type TopLevelRawAPI = "something" :> Get Int
21 :<|> Raw
25 :<|> Raw
22
26
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+
23spec :: Spec
51spec :: Spec
24spec = describe "Servant.JQuery"
52spec = describe "Servant.JQuery"
25 generateJSSpec
53 generateJSSpec
@@ -37,3 +65,30 @@ generateJSSpec = describe "generateJS" $ do
37 print $ generateJS $ topLevel "GET"
65 print $ generateJS $ topLevel "GET"
38 parseFromString (generateJS $ topLevel "GET") `shouldSatisfy` isRight
66 parseFromString (generateJS $ topLevel "GET") `shouldSatisfy` isRight
39
67
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 #-}
8+
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."