diff --git a/servant-jquery.cabal b/servant-jquery.cabal index 5a71b4cc..de237791 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 + build-depends: base >=4.5 && <5 + , charset + , lens >= 4 + , servant >= 0.2.1 + , text hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -65,8 +69,10 @@ test-suite spec main-is: Spec.hs build-depends: base == 4.* + , lens , servant-jquery , servant , hspec >= 2.0 + , hspec-expectations , language-ecmascript == 0.16.* default-language: Haskell2010 diff --git a/src/Servant/JQuery.hs b/src/Servant/JQuery.hs index b6453ecf..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"++) hs + ++ map (toValidFunctionName . (<>) "header" . headerArgName) hs ++ ["onSuccess", "onError"] captures = map captureArg @@ -67,10 +67,12 @@ generateJS req = "\n" <> reqheaders = if null hs then "" - else "\n , headers: { " ++ headersStr ++ " } }\n" + else "\n , headers: { " ++ headersStr ++ " }\n" where headersStr = intercalate ", " $ map headerStr hs - headerStr hname = "\"" ++ hname ++ "\": header" ++ hname + 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 32c06ce5..c8f583ca 100644 --- a/src/Servant/JQuery/Internal.hs +++ b/src/Servant/JQuery/Internal.hs @@ -9,8 +9,12 @@ 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 +import qualified Data.Text as T import GHC.TypeLits import Servant.API @@ -53,7 +57,57 @@ data QueryArg = QueryArg , _argType :: ArgType } deriving (Eq, Show) -type HeaderArg = String +data HeaderArg = HeaderArg + { headerArgName :: String + } + | ReplaceHeaderArg + { headerArgName :: String + , headerPattern :: String + } deriving (Eq) + +instance Show HeaderArg where + show (HeaderArg n) = toValidFunctionName ("header" <> n) + show (ReplaceHeaderArg n p) + | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\"" + | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv + | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) + <> "\"" + | otherwise = p + where + pv = toValidFunctionName ("header" <> n) + pn = "{" <> n <> "}" + rp = replace pn "" p + -- Use replace method from Data.Text + replace old new = T.unpack . + T.replace (T.pack old) (T.pack new) . + T.pack + +-- | 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 @@ -144,7 +198,7 @@ instance (KnownSymbol sym, HasJQ sublayout) type JQ (Header sym a :> sublayout) = JQ sublayout jqueryFor Proxy req = - jqueryFor subP (req & reqHeaders <>~ [hname]) + jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname]) where hname = symbolVal (Proxy :: Proxy sym) subP = Proxy :: Proxy sublayout diff --git a/test/Servant/JQuerySpec.hs b/test/Servant/JQuerySpec.hs index 5ba2f681..fdc9331f 100644 --- a/test/Servant/JQuerySpec.hs +++ b/test/Servant/JQuerySpec.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.JQuerySpec where @@ -11,6 +14,7 @@ import Test.Hspec import Servant.API import Servant.JQuery +import Servant.JQuerySpec.CustomHeaders type TestAPI = [sitemap| POST /simple String -> Bool @@ -20,6 +24,30 @@ GET /has.extension Bool type TopLevelRawAPI = "something" :> Get Int :<|> Raw +type HeaderHandlingAPI = "something" :> Header "Foo" String + :> Get Int + +type CustomAuthAPI = "something" :> Authorization "Basic" String + :> Get Int + +type CustomHeaderAPI = "something" :> MyLovelyHorse String + :> Get Int + +type CustomHeaderAPI2 = "something" :> WhatsForDinner String + :> Get Int + +headerHandlingProxy :: Proxy HeaderHandlingAPI +headerHandlingProxy = Proxy + +customAuthProxy :: Proxy CustomAuthAPI +customAuthProxy = Proxy + +customHeaderProxy :: Proxy CustomHeaderAPI +customHeaderProxy = Proxy + +customHeaderProxy2 :: Proxy CustomHeaderAPI2 +customHeaderProxy2 = Proxy + spec :: Spec spec = describe "Servant.JQuery" generateJSSpec @@ -37,3 +65,30 @@ generateJSSpec = describe "generateJS" $ do print $ generateJS $ topLevel "GET" parseFromString (generateJS $ topLevel "GET") `shouldSatisfy` isRight + it "should handle simple HTTP headers" $ do + let jsText = generateJS $ jquery headerHandlingProxy + print jsText + parseFromString jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerFoo" + jsText `shouldContain` "headers: { \"Foo\": headerFoo }\n" + + it "should handle complex HTTP headers" $ do + let jsText = generateJS $ jquery customAuthProxy + print jsText + parseFromString jsText `shouldSatisfy` isRight + 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" + + it "should handle complex, custom HTTP headers (template replacement)" $ do + let jsText = generateJS $ jquery customHeaderProxy2 + print jsText + parseFromString jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerXWhatsForDinner" + jsText `shouldContain` "headers: { \"X-WhatsForDinner\": \"I would like \" + headerXWhatsForDinner + \" with a cherry on top.\" }\n" diff --git a/test/Servant/JQuerySpec/CustomHeaders.hs b/test/Servant/JQuerySpec/CustomHeaders.hs new file mode 100644 index 00000000..4480d44c --- /dev/null +++ b/test/Servant/JQuerySpec/CustomHeaders.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.JQuerySpec.CustomHeaders where + +import Control.Lens +import Data.Monoid +import Data.Proxy +import GHC.TypeLits +import Servant.API +import Servant.JQuery + +-- | This is a hypothetical combinator that fetches an Authorization header. +-- The symbol in the header denotes what kind of authentication we are +-- using -- Basic, Digest, whatever. +data Authorization (sym :: Symbol) a + +instance (KnownSymbol sym, HasJQ sublayout) + => 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)) ] + 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}" + +-- | This is a combinator that fetches an X-WhatsForDinner header. +data WhatsForDinner a + +instance (HasJQ sublayout) + => HasJQ (WhatsForDinner a :> sublayout) where + type JQ (WhatsForDinner a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ] + where + tpl = "I would like {X-WhatsForDinner} with a cherry on top."