git.iko.soy/servant
on master help sign in
Actually sanitise function names and handle X-Custom headers
commit745dbd09a9093a30fdbe11f5eab1d24bcd0900ef authorGeoffrey Roberts <groberts@anchor.net.au> dateWed 21 Jan 2015, 19:32 (12 years ago) parent158eab5
5 files changed+68−9
compare with master
unifiedsplit
servant-jquery.cabal+5−1 src/Servant/JQuery.hs+4−2 src/Servant/JQuery/Internal.hs+32−3 test/Servant/JQuerySpec.hs+12 test/Servant/JQuerySpec/CustomHeaders.hs+15−3
servant-jquery.cabal+5−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, MissingH
34+ build-depends: base >=4.5 && <5
35+ , servant >= 0.2.1
36+ , lens >= 4
37+ , MissingH
38+ , charset
3539 hs-source-dirs: src
3640 default-language: Haskell2010
3741 ghc-options: -Wall
src/Servant/JQuery.hs+4−2
@@ -44,7 +44,7 @@ generateJS req = "\n" <>
4444 args = captures
4545 ++ map (view argName) queryparams
4646 ++ body
47− ++ map ((<>) "header" . headerArgName) hs
47+ ++ map (toValidFunctionName . (<>) "header" . headerArgName) hs
4848 ++ ["onSuccess", "onError"]
4949
5050 captures = map captureArg
@@ -70,7 +70,9 @@ generateJS req = "\n" <>
7070 else "\n , headers: { " ++ headersStr ++ " }\n"
7171
7272 where headersStr = intercalate ", " $ map headerStr hs
73− headerStr header = "\"" ++ headerArgName header ++ "\": " ++ show header
73+ headerStr header = "\"" ++
74+ headerArgName header ++
75+ "\": " ++ show header
7476
7577 fname = req ^. funcName
7678 method = req ^. reqMethod
src/Servant/JQuery/Internal.hs+32−3
@@ -9,6 +9,8 @@ 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
1214import Data.List
1315import Data.Monoid
1416import Data.Proxy
@@ -64,17 +66,44 @@ data HeaderArg = HeaderArg
6466 } deriving (Eq)
6567
6668instance Show HeaderArg where
67− show (HeaderArg n) = "header" <> n
69+ show (HeaderArg n) = toValidFunctionName ("header" <> n)
6870 show (ReplaceHeaderArg n p)
6971 | pn `startswith` p = pv <> " + \"" <> rp <> "\""
7072 | pn `endswith` p = "\"" <> rp <> "\" + " <> pv
71− | pn `isInfixOf` p = "\"" <> replace pn ("\"" <> pv <> "\"") p <> "\""
73+ | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) <> "\""
7274 | otherwise = p
7375 where
74− pv = "header" <> n
76+ pv = toValidFunctionName ("header" <> n)
7577 pn = "{" <> n <> "}"
7678 rp = replace pn "" p
7779
80+-- | Attempts to reduce the function name provided to that allowed by JS.
81+-- https://mathiasbynens.be/notes/javascript-identifiers
82+-- Couldn't work out how to handle zero-width characters.
83+-- @TODO: specify better default function name, or throw error?
84+toValidFunctionName :: String -> String
85+toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs
86+ where
87+ setFirstChar c = if firstChar c
88+ then c
89+ else '_'
90+ firstChar c = (prefixOK c) || (or . map (Set.member c) $ firstLetterOK)
91+ remainder c = (prefixOK c) || (or . map (Set.member c) $ remainderOK)
92+ -- Valid prefixes
93+ prefixOK c = c `elem` ['$','_']
94+ -- Unicode character sets
95+ firstLetterOK = [ Set.lowercaseLetter
96+ , Set.uppercaseLetter
97+ , Set.titlecaseLetter
98+ , Set.modifierLetter
99+ , Set.otherLetter
100+ , Set.letterNumber ]
101+ remainderOK = firstLetterOK <> [ Set.nonSpacingMark
102+ , Set.spacingCombiningMark
103+ , Set.decimalNumber
104+ , Set.connectorPunctuation ]
105+toValidFunctionName [] = "_"
106+
78107data Url = Url
79108 { _path :: Path
80109 , _queryStr :: [QueryArg]
test/Servant/JQuerySpec.hs+12
@@ -30,12 +30,18 @@ type HeaderHandlingAPI = "something" :> Header "Foo" String
3030type CustomAuthAPI = "something" :> Authorization "Basic" String
3131 :> Get Int
3232
33+type CustomHeaderAPI = "something" :> MyLovelyHorse String
34+ :> Get Int
35+
3336headerHandlingProxy :: Proxy HeaderHandlingAPI
3437headerHandlingProxy = Proxy
3538
3639customAuthProxy :: Proxy CustomAuthAPI
3740customAuthProxy = Proxy
3841
42+customHeaderProxy :: Proxy CustomHeaderAPI
43+customHeaderProxy = Proxy
44+
3945spec :: Spec
4046spec = describe "Servant.JQuery"
4147 generateJSSpec
@@ -67,3 +73,9 @@ generateJSSpec = describe "generateJS" $ do
6773 jsText `shouldContain` "headerAuthorization"
6874 jsText `shouldContain` "headers: { \"Authorization\": \"Basic \" + headerAuthorization }\n"
6975
76+ it "should handle complex, custom HTTP headers" $ do
77+ let jsText = generateJS $ jquery customHeaderProxy
78+ print jsText
79+ parseFromString jsText `shouldSatisfy` isRight
80+ jsText `shouldContain` "headerXMyLovelyHorse"
81+ jsText `shouldContain` "headers: { \"X-MyLovelyHorse\": \"I am good friends with \" + headerXMyLovelyHorse }\n"
test/Servant/JQuerySpec/CustomHeaders.hs+15−3
@@ -21,11 +21,23 @@ import Servant.JQuery
2121data Authorization (sym :: Symbol) a
2222
2323instance (KnownSymbol sym, HasJQ sublayout)
24− => HasJQ (Authorization sym a :> sublayout) where
24+ => HasJQ (Authorization sym a :> sublayout) where
2525 type JQ (Authorization sym a :> sublayout) = JQ sublayout
2626
2727 jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
2828 req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
29− tokenType (symbolVal (Proxy :: Proxy sym)) ]
29+ tokenType (symbolVal (Proxy :: Proxy sym)) ]
3030 where
31− tokenType t = t <> " {Authorization}"
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}"