Actually sanitise function names and handle X-Custom headers

This commit is contained in:
Geoffrey Roberts 2015-01-21 19:32:06 +11:00
parent 158eab5157
commit 745dbd09a9
5 changed files with 68 additions and 9 deletions

View file

@ -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

View file

@ -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

View file

@ -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]

View file

@ -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"

View file

@ -29,3 +29,15 @@ instance (KnownSymbol sym, HasJQ sublayout)
tokenType (symbolVal (Proxy :: Proxy sym)) ]
where
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}"