From 745dbd09a9093a30fdbe11f5eab1d24bcd0900ef Mon Sep 17 00:00:00 2001 From: Geoffrey Roberts Date: Wed, 21 Jan 2015 19:32:06 +1100 Subject: [PATCH] Actually sanitise function names and handle X-Custom headers --- servant-jquery.cabal | 6 +++- src/Servant/JQuery.hs | 6 ++-- src/Servant/JQuery/Internal.hs | 35 ++++++++++++++++++++++-- test/Servant/JQuerySpec.hs | 12 ++++++++ test/Servant/JQuerySpec/CustomHeaders.hs | 18 ++++++++++-- 5 files changed, 68 insertions(+), 9 deletions(-) diff --git a/servant-jquery.cabal b/servant-jquery.cabal index 6767f6be..b15a6f6c 100644 --- a/servant-jquery.cabal +++ b/servant-jquery.cabal @@ -31,7 +31,11 @@ flag example library exposed-modules: Servant.JQuery other-modules: Servant.JQuery.Internal - build-depends: base >=4.5 && <5, servant >= 0.2.1, lens >= 4, MissingH + build-depends: base >=4.5 && <5 + , servant >= 0.2.1 + , lens >= 4 + , MissingH + , charset hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Servant/JQuery.hs b/src/Servant/JQuery.hs index e4bc3be4..38ff92d8 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" . headerArgName) hs + ++ map (toValidFunctionName . (<>) "header" . headerArgName) hs ++ ["onSuccess", "onError"] captures = map captureArg @@ -70,7 +70,9 @@ generateJS req = "\n" <> else "\n , headers: { " ++ headersStr ++ " }\n" where headersStr = intercalate ", " $ map headerStr hs - headerStr header = "\"" ++ headerArgName header ++ "\": " ++ show header + 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 3ff0ae5d..1fc16d80 100644 --- a/src/Servant/JQuery/Internal.hs +++ b/src/Servant/JQuery/Internal.hs @@ -9,6 +9,8 @@ module Servant.JQuery.Internal where import Control.Applicative import Control.Lens import Data.Char (toLower) +import qualified Data.CharSet as Set +import qualified Data.CharSet.Unicode.Category as Set import Data.List import Data.Monoid import Data.Proxy @@ -64,17 +66,44 @@ data HeaderArg = HeaderArg } deriving (Eq) instance Show HeaderArg where - show (HeaderArg n) = "header" <> n + show (HeaderArg n) = toValidFunctionName ("header" <> n) show (ReplaceHeaderArg n p) | pn `startswith` p = pv <> " + \"" <> rp <> "\"" | pn `endswith` p = "\"" <> rp <> "\" + " <> pv - | pn `isInfixOf` p = "\"" <> replace pn ("\"" <> pv <> "\"") p <> "\"" + | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) <> "\"" | otherwise = p where - pv = "header" <> n + pv = toValidFunctionName ("header" <> n) pn = "{" <> n <> "}" rp = replace pn "" p +-- | Attempts to reduce the function name provided to that allowed by JS. +-- https://mathiasbynens.be/notes/javascript-identifiers +-- Couldn't work out how to handle zero-width characters. +-- @TODO: specify better default function name, or throw error? +toValidFunctionName :: String -> String +toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs + where + setFirstChar c = if firstChar c + then c + else '_' + firstChar c = (prefixOK c) || (or . map (Set.member c) $ firstLetterOK) + remainder c = (prefixOK c) || (or . map (Set.member c) $ remainderOK) + -- Valid prefixes + prefixOK c = c `elem` ['$','_'] + -- Unicode character sets + firstLetterOK = [ Set.lowercaseLetter + , Set.uppercaseLetter + , Set.titlecaseLetter + , Set.modifierLetter + , Set.otherLetter + , Set.letterNumber ] + remainderOK = firstLetterOK <> [ Set.nonSpacingMark + , Set.spacingCombiningMark + , Set.decimalNumber + , Set.connectorPunctuation ] +toValidFunctionName [] = "_" + data Url = Url { _path :: Path , _queryStr :: [QueryArg] diff --git a/test/Servant/JQuerySpec.hs b/test/Servant/JQuerySpec.hs index db3f1146..ada56d27 100644 --- a/test/Servant/JQuerySpec.hs +++ b/test/Servant/JQuerySpec.hs @@ -30,12 +30,18 @@ type HeaderHandlingAPI = "something" :> Header "Foo" String type CustomAuthAPI = "something" :> Authorization "Basic" String :> Get Int +type CustomHeaderAPI = "something" :> MyLovelyHorse String + :> Get Int + headerHandlingProxy :: Proxy HeaderHandlingAPI headerHandlingProxy = Proxy customAuthProxy :: Proxy CustomAuthAPI customAuthProxy = Proxy +customHeaderProxy :: Proxy CustomHeaderAPI +customHeaderProxy = Proxy + spec :: Spec spec = describe "Servant.JQuery" generateJSSpec @@ -67,3 +73,9 @@ generateJSSpec = describe "generateJS" $ do jsText `shouldContain` "headerAuthorization" jsText `shouldContain` "headers: { \"Authorization\": \"Basic \" + headerAuthorization }\n" + it "should handle complex, custom HTTP headers" $ do + let jsText = generateJS $ jquery customHeaderProxy + print jsText + parseFromString jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerXMyLovelyHorse" + jsText `shouldContain` "headers: { \"X-MyLovelyHorse\": \"I am good friends with \" + headerXMyLovelyHorse }\n" diff --git a/test/Servant/JQuerySpec/CustomHeaders.hs b/test/Servant/JQuerySpec/CustomHeaders.hs index d70bb076..4bb378d9 100644 --- a/test/Servant/JQuerySpec/CustomHeaders.hs +++ b/test/Servant/JQuerySpec/CustomHeaders.hs @@ -21,11 +21,23 @@ import Servant.JQuery data Authorization (sym :: Symbol) a instance (KnownSymbol sym, HasJQ sublayout) - => HasJQ (Authorization sym a :> sublayout) where + => HasJQ (Authorization sym a :> sublayout) where type JQ (Authorization sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $ - tokenType (symbolVal (Proxy :: Proxy sym)) ] + tokenType (symbolVal (Proxy :: Proxy sym)) ] where - tokenType t = t <> " {Authorization}" + tokenType t = t <> " {Authorization}" + +-- | This is a combinator that fetches an X-MyLovelyHorse header. +data MyLovelyHorse a + +instance (HasJQ sublayout) + => HasJQ (MyLovelyHorse a :> sublayout) where + type JQ (MyLovelyHorse a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ] + where + tpl = "I am good friends with {X-MyLovelyHorse}"