diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 1efda5c3..4188a5a9 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -26,7 +26,9 @@ source-repository head location: http://github.com/haskell-servant/servant.git library - exposed-modules: Servant.Foreign, Servant.Foreign.Internal + exposed-modules: Servant.Foreign + , Servant.Foreign.Internal + , Servant.Foreign.Inflections build-depends: base == 4.* , lens == 4.* , servant == 0.5.* @@ -36,6 +38,20 @@ library default-language: Haskell2010 ghc-options: -Wall include-dirs: include + default-extensions: CPP + , ConstraintKinds + , DataKinds + , FlexibleContexts + , FlexibleInstances + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , ScopedTypeVariables + , TemplateHaskell + , TypeFamilies + , TypeOperators + , UndecidableInstances + , OverloadedStrings + , PolyKinds test-suite spec @@ -44,9 +60,20 @@ test-suite spec ghc-options: -Wall include-dirs: include main-is: Spec.hs - other-modules: - Servant.ForeignSpec + other-modules: Servant.ForeignSpec build-depends: base , hspec >= 2.1.8 , servant-foreign default-language: Haskell2010 + default-extensions: ConstraintKinds + , DataKinds + , FlexibleContexts + , FlexibleInstances + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , ScopedTypeVariables + , TypeFamilies + , TypeOperators + , UndecidableInstances + , OverloadedStrings + , PolyKinds diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 33ac2732..3850ad37 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -10,10 +10,14 @@ module Servant.Foreign , Url(..) -- aliases , Path - , ForeignType - , Arg - , FunctionName + , ForeignType(..) + , Arg(..) + , FunctionName(..) + , PathSegment(..) -- lenses + , aName + , aType + , aPath , reqUrl , reqMethod , reqHeaders @@ -24,7 +28,10 @@ module Servant.Foreign , queryStr , argName , argType + , headerArg -- prisms + , _PathSegment + , _ForeignType , _HeaderArg , _ReplaceHeaderArg , _Static @@ -40,14 +47,13 @@ module Servant.Foreign , NoTypes , captureArg , isCapture - , concatCase - , snakeCase - , camelCase , defReq , listFromAPI - -- re-exports + -- re-exports , module Servant.API + , module Servant.Foreign.Inflections ) where import Servant.API import Servant.Foreign.Internal +import Servant.Foreign.Inflections diff --git a/servant-foreign/src/Servant/Foreign/Inflections.hs b/servant-foreign/src/Servant/Foreign/Inflections.hs new file mode 100644 index 00000000..759d04a0 --- /dev/null +++ b/servant-foreign/src/Servant/Foreign/Inflections.hs @@ -0,0 +1,45 @@ +module Servant.Foreign.Inflections + ( concatCase + , snakeCase + , camelCase + -- lenses + , concatCaseL + , snakeCaseL + , camelCaseL + ) where + + +import Control.Lens hiding (cons) +import qualified Data.Char as C +import Data.Monoid +import Data.Text hiding (map) +import Prelude hiding (head, tail) +import Servant.Foreign.Internal + +concatCaseL :: Getter FunctionName Text +concatCaseL = _FunctionName . to mconcat + +-- | Function name builder that simply concat each part together +concatCase :: FunctionName -> Text +concatCase = view concatCaseL + +snakeCaseL :: Getter FunctionName Text +snakeCaseL = _FunctionName . to (intercalate "_") + +-- | Function name builder using the snake_case convention. +-- each part is separated by a single underscore character. +snakeCase :: FunctionName -> Text +snakeCase = view snakeCaseL + +camelCaseL :: Getter FunctionName Text +camelCaseL = _FunctionName . to (convert . map (replace "-" "")) + where + convert [] = "" + convert (p:ps) = mconcat $ p : map capitalize ps + capitalize "" = "" + capitalize name = C.toUpper (head name) `cons` tail name + +-- | Function name builder using the CamelCase convention. +-- each part begins with an upper case character. +camelCase :: FunctionName -> Text +camelCase = view camelCaseL diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index cb37f6b7..b22a0716 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -1,27 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} #if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE NullaryTypeClasses #-} +{-# LANGUAGE NullaryTypeClasses #-} #endif -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -- | Generalizes all the data needed to make code generation work with -- arbitrary programming languages. module Servant.Foreign.Internal where -import Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~)) -import qualified Data.Char as C +import Control.Lens hiding (cons, List) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif import Data.Proxy +import Data.String import Data.Text import Data.Text.Encoding (decodeUtf8) import GHC.Exts (Constraint) @@ -30,36 +21,38 @@ import qualified Network.HTTP.Types as HTTP import Prelude hiding (concat) import Servant.API -type FunctionName = [Text] --- | Function name builder that simply concat each part together -concatCase :: FunctionName -> Text -concatCase = concat +newtype FunctionName = FunctionName { unFunctionName :: [Text] } + deriving (Show, Eq, Monoid) --- | Function name builder using the snake_case convention. --- each part is separated by a single underscore character. -snakeCase :: FunctionName -> Text -snakeCase = intercalate "_" +makePrisms ''FunctionName --- | Function name builder using the CamelCase convention. --- each part begins with an upper case character. -camelCase :: FunctionName -> Text -camelCase = camelCase' . Prelude.map (replace "-" "") - where camelCase' [] = "" - camelCase' (p:ps) = concat $ p : Prelude.map capitalize ps - capitalize "" = "" - capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name +newtype ForeignType = ForeignType { unForeignType :: Text } + deriving (Show, Eq, IsString, Monoid) -type ForeignType = Text +makePrisms ''ForeignType -type Arg = (Text, ForeignType) +newtype PathSegment = PathSegment { unPathSegment :: Text } + deriving (Show, Eq, IsString, Monoid) + +makePrisms ''PathSegment + +data Arg = Arg + { _aName :: PathSegment + , _aType :: ForeignType } + deriving (Show, Eq) + +makeLenses ''Arg + +aPath :: Getter Arg Text +aPath = aName . _PathSegment data SegmentType - = Static Text + = Static PathSegment -- ^ a static path segment. like "/foo" | Cap Arg -- ^ a capture. like "/:userid" - deriving (Eq, Show) + deriving (Show, Eq) makePrisms ''SegmentType @@ -68,6 +61,14 @@ newtype Segment = Segment { unSegment :: SegmentType } makePrisms ''Segment +isCapture :: Segment -> Bool +isCapture (Segment (Cap _)) = True +isCapture _ = False + +captureArg :: Segment -> Arg +captureArg (Segment (Cap s)) = s +captureArg _ = error "captureArg called on non capture" + type Path = [Segment] data ArgType @@ -86,10 +87,10 @@ data QueryArg = QueryArg makeLenses ''QueryArg data HeaderArg = HeaderArg - { headerArg :: Arg } + { _headerArg :: Arg } | ReplaceHeaderArg - { headerArg :: Arg - , headerPattern :: Text + { _headerArg :: Arg + , _headerPattern :: Text } deriving (Eq, Show) makeLenses ''HeaderArg @@ -117,16 +118,8 @@ data Req = Req makeLenses ''Req -isCapture :: Segment -> Bool -isCapture (Segment (Cap _)) = True -isCapture _ = False - -captureArg :: Segment -> Arg -captureArg (Segment (Cap s)) = s -captureArg _ = error "captureArg called on non capture" - defReq :: Req -defReq = Req defUrl "GET" [] Nothing "" [] +defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName []) -- | To be used exclusively as a "negative" return type/constraint -- by @'Elem`@ type family. @@ -173,7 +166,7 @@ class HasForeignType lang a where data NoTypes instance HasForeignType NoTypes ftype where - typeFor _ _ = empty + typeFor _ _ = ForeignType empty type HasNoForeignType = HasForeignType NoTypes @@ -195,18 +188,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout) foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqUrl.path <>~ [Segment (Cap arg)] - & reqFuncName %~ (++ ["by", str]) + req & reqUrl . path <>~ [Segment (Cap arg)] + & reqFuncName . _FunctionName %~ (++ ["by", str]) where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy ftype)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + ftype = typeFor lang (Proxy :: Proxy ftype) + arg = Arg + { _aName = PathSegment str + , _aType = ftype } instance (Elem JSON list, HasForeignType lang a, ReflectMethod method) => HasForeign lang (Verb method status list a) where type Foreign (Verb method status list a) = Req foreignFor lang Proxy req = - req & reqFuncName %~ (methodLC :) + req & reqFuncName . _FunctionName %~ (methodLC :) & reqMethod .~ method & reqReturnType .~ retType where @@ -219,12 +215,13 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) type Foreign (Header sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = - foreignFor lang subP $ req - & reqHeaders <>~ [HeaderArg arg] + foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg] where hname = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (hname, typeFor lang (Proxy :: Proxy a)) - subP = Proxy :: Proxy sublayout + arg = Arg + { _aName = PathSegment hname + , _aType = typeFor lang (Proxy :: Proxy a) } + subP = Proxy :: Proxy sublayout instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) => HasForeign lang (QueryParam sym a :> sublayout) where @@ -233,10 +230,11 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg Normal] - where str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + arg = Arg + { _aName = PathSegment str + , _aType = typeFor lang (Proxy :: Proxy a) } instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) @@ -247,7 +245,9 @@ instance req & reqUrl.queryStr <>~ [QueryArg arg List] where str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy [a])) + arg = Arg + { _aName = PathSegment str + , _aType = typeFor lang (Proxy :: Proxy [a]) } instance (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout) @@ -259,13 +259,15 @@ instance req & reqUrl.queryStr <>~ [QueryArg arg Flag] where str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy Bool)) + arg = Arg + { _aName = PathSegment str + , _aType = typeFor lang (Proxy :: Proxy Bool) } instance HasForeign lang Raw where type Foreign Raw = HTTP.Method -> Req foreignFor _ Proxy req method = - req & reqFuncName %~ ((toLower $ decodeUtf8 method) :) + req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :) & reqMethod .~ method instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout) @@ -282,8 +284,8 @@ instance (KnownSymbol path, HasForeign lang sublayout) foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqUrl.path <>~ [Segment (Static str)] - & reqFuncName %~ (++ [str]) + req & reqUrl . path <>~ [Segment (Static (PathSegment str))] + & reqFuncName . _FunctionName %~ (++ [str]) where str = Data.Text.map (\c -> if c == '.' then '_' else c) diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 0e279994..c70a96af 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -1,13 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - +{-# LANGUAGE CPP #-} #include "overlapping-compat.h" module Servant.ForeignSpec where @@ -26,15 +17,17 @@ spec = describe "Servant.Foreign" $ do camelCaseSpec :: Spec camelCaseSpec = describe "camelCase" $ do it "converts FunctionNames to camelCase" $ do - camelCase ["post", "counter", "inc"] `shouldBe` "postCounterInc" - camelCase ["get", "hyphen-ated", "counter"] `shouldBe` "getHyphenatedCounter" + camelCase (FunctionName ["post", "counter", "inc"]) + `shouldBe` "postCounterInc" + camelCase (FunctionName ["get", "hyphen-ated", "counter"]) + `shouldBe` "getHyphenatedCounter" ---------------------------------------------------------------------- data LangX instance HasForeignType LangX () where - typeFor _ _ = "voidX" + typeFor _ _ = ForeignType "voidX" instance HasForeignType LangX Int where typeFor _ _ = "intX" @@ -68,24 +61,24 @@ listFromAPISpec = describe "listFromAPI" $ do shouldBe getReq $ defReq { _reqUrl = Url [ Segment $ Static "test" ] - [ QueryArg ("flag", "boolX") Flag ] + [ QueryArg (Arg "flag" "boolX") Flag ] , _reqMethod = "GET" - , _reqHeaders = [HeaderArg ("header", "listX of stringX")] + , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"] , _reqBody = Nothing , _reqReturnType = "intX" - , _reqFuncName = ["get", "test"] + , _reqFuncName = FunctionName ["get", "test"] } it "collects all info for post request" $ do shouldBe postReq $ defReq { _reqUrl = Url [ Segment $ Static "test" ] - [ QueryArg ("param", "intX") Normal ] + [ QueryArg (Arg "param" "intX") Normal ] , _reqMethod = "POST" , _reqHeaders = [] , _reqBody = Just "listX of stringX" , _reqReturnType = "voidX" - , _reqFuncName = ["post", "test"] + , _reqFuncName = FunctionName ["post", "test"] } it "collects all info for put request" $ do @@ -93,23 +86,23 @@ listFromAPISpec = describe "listFromAPI" $ do { _reqUrl = Url [ Segment $ Static "test" ] -- Shoud this be |intX| or |listX of intX| ? - [ QueryArg ("params", "listX of intX") List ] + [ QueryArg (Arg "params" "listX of intX") List ] , _reqMethod = "PUT" , _reqHeaders = [] , _reqBody = Just "stringX" , _reqReturnType = "voidX" - , _reqFuncName = ["put", "test"] + , _reqFuncName = FunctionName ["put", "test"] } it "collects all info for delete request" $ do shouldBe deleteReq $ defReq { _reqUrl = Url [ Segment $ Static "test" - , Segment $ Cap ("id", "intX") ] + , Segment $ Cap (Arg "id" "intX") ] [] , _reqMethod = "DELETE" , _reqHeaders = [] , _reqBody = Nothing , _reqReturnType = "voidX" - , _reqFuncName = ["delete", "test", "by", "id"] + , _reqFuncName = FunctionName ["delete", "test", "by", "id"] } diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 4d647225..ea5a4764 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -76,9 +76,12 @@ generateAngularJSWith ngOptions opts req = "\n" <> where argsStr = T.intercalate ", " args args = http ++ captures - ++ map (view $ argName._1) queryparams + ++ map (view $ argName . aPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . aPath) + ) hs -- If we want to generate Top Level Function, they must depend on -- the $http service, if we generate a service, the functions will @@ -87,9 +90,9 @@ generateAngularJSWith ngOptions opts req = "\n" <> 0 -> ["$http"] _ -> [] - captures = map (fst . captureArg) + captures = map (view aPath . captureArg) . filter isCapture - $ req ^. reqUrl.path + $ req ^. reqUrl . path hs = req ^. reqHeaders @@ -110,10 +113,11 @@ generateAngularJSWith ngOptions opts req = "\n" <> then "" else " , headers: { " <> headersStr <> " }\n" - where headersStr = T.intercalate ", " $ map headerStr hs - headerStr header = "\"" <> - fst (headerArg header) <> - "\": " <> toJSHeader header + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . aPath <> + "\": " <> toJSHeader header namespace = if hasService diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index c8540efe..6047ccc8 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -62,11 +62,14 @@ generateAxiosJSWith aopts opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName._1) queryparams + ++ map (view $ argName . aPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . aPath) + ) hs - captures = map (fst . captureArg) + captures = map (view aPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -104,10 +107,11 @@ generateAxiosJSWith aopts opts req = "\n" <> then "" else " , headers: { " <> headersStr <> " }\n" - where headersStr = T.intercalate ", " $ map headerStr hs - headerStr header = "\"" <> - fst (headerArg header) <> - "\": " <> toJSHeader header + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . aPath <> + "\": " <> toJSHeader header namespace = if hasNoModule diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 61c33e0f..b55819ba 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -1,4 +1,6 @@ -{-#LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + module Servant.JS.Internal ( JavaScriptGenerator , CommonGeneratorOptions(..) @@ -19,7 +21,22 @@ module Servant.JS.Internal , reqHeaders , HasForeign(..) , HasForeignType(..) + , HasNoForeignType + , GenerateList(..) + , NoTypes + , HeaderArg + , ArgType(..) , HeaderArg(..) + , QueryArg(..) + , Req(..) + , Segment(..) + , SegmentType(..) + , Url(..) + , Path + , ForeignType(..) + , Arg(..) + , FunctionName(..) + , PathSegment(..) , concatCase , snakeCase , camelCase @@ -32,7 +49,7 @@ module Servant.JS.Internal , Header ) where -import Control.Lens ((^.), _1) +import Control.Lens hiding (List) import qualified Data.CharSet as Set import qualified Data.CharSet.Unicode.Category as Set import Data.Monoid @@ -123,7 +140,8 @@ toValidFunctionName t = ] toJSHeader :: HeaderArg -> Text -toJSHeader (HeaderArg n) = toValidFunctionName ("header" <> fst n) +toJSHeader (HeaderArg n) + = toValidFunctionName ("header" <> n ^. aName . _PathSegment) toJSHeader (ReplaceHeaderArg n p) | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\"" | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv @@ -131,8 +149,8 @@ toJSHeader (ReplaceHeaderArg n p) <> "\"" | otherwise = p where - pv = toValidFunctionName ("header" <> fst n) - pn = "{" <> fst n <> "}" + pv = toValidFunctionName ("header" <> n ^. aName . _PathSegment) + pn = "{" <> n ^. aName . _PathSegment <> "}" rp = T.replace pn "" p jsSegments :: [Segment] -> Text @@ -145,8 +163,9 @@ segmentToStr (Segment st) notTheEnd = segmentTypeToStr st <> if notTheEnd then "" else "'" segmentTypeToStr :: SegmentType -> Text -segmentTypeToStr (Static s) = s -segmentTypeToStr (Cap s) = "' + encodeURIComponent(" <> fst s <> ") + '" +segmentTypeToStr (Static s) = s ^. _PathSegment +segmentTypeToStr (Cap s) = + "' + encodeURIComponent(" <> s ^. aName . _PathSegment <> ") + '" jsGParams :: Text -> [QueryArg] -> Text jsGParams _ [] = "" @@ -168,4 +187,4 @@ paramToStr qarg notTheEnd = <> "[]=' + encodeURIComponent(" <> name <> if notTheEnd then ") + '" else ")" - where name = qarg ^. argName . _1 + where name = qarg ^. argName . aName . _PathSegment diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index dfd3ddc0..d4471122 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -10,6 +10,7 @@ import Data.Text.Encoding (decodeUtf8) import Servant.Foreign import Servant.JS.Internal + -- | Generate javascript functions that use the /jQuery/ library -- to make the AJAX calls. Uses 'defCommonGeneratorOptions' -- for the generator options. @@ -42,12 +43,15 @@ generateJQueryJSWith opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName._1) queryparams + ++ map (view $ argName . aPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map (toValidFunctionName + . (<>) "header" + . view (headerArg . aPath) + ) hs ++ [onSuccess, onError] - captures = map (fst . captureArg) + captures = map (view aPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -73,10 +77,11 @@ generateJQueryJSWith opts req = "\n" <> then "" else " , headers: { " <> headersStr <> " }\n" - where headersStr = T.intercalate ", " $ map headerStr hs - headerStr header = "\"" <> - fst (headerArg header) <> - "\": " <> toJSHeader header + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . aPath <> + "\": " <> toJSHeader header namespace = if (moduleName opts) == "" then "var " diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index 386a0d2e..41b4dc30 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -54,12 +54,15 @@ generateVanillaJSWith opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName._1) queryparams + ++ map (view $ argName . aPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . aPath) + ) hs ++ [onSuccess, onError] - captures = map (fst . captureArg) + captures = map (view aPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -85,10 +88,11 @@ generateVanillaJSWith opts req = "\n" <> then "" else headersStr <> "\n" - where headersStr = T.intercalate "\n" $ map headerStr hs - headerStr header = " xhr.setRequestHeader(\"" <> - fst (headerArg header) <> - "\", " <> toJSHeader header <> ");" + where + headersStr = T.intercalate "\n" $ map headerStr hs + headerStr header = " xhr.setRequestHeader(\"" <> + header ^. headerArg . aPath <> + "\", " <> toJSHeader header <> ");" namespace = if moduleName opts == "" then "var " diff --git a/servant-js/test/Servant/JSSpec/CustomHeaders.hs b/servant-js/test/Servant/JSSpec/CustomHeaders.hs index 150436e3..4e4e3311 100644 --- a/servant-js/test/Servant/JSSpec/CustomHeaders.hs +++ b/servant-js/test/Servant/JSSpec/CustomHeaders.hs @@ -27,8 +27,9 @@ instance (KnownSymbol sym, HasForeign lang sublayout) type Foreign (Authorization sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("Authorization", "") $ - tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] + req & reqHeaders <>~ + [ ReplaceHeaderArg (Arg "Authorization" "") + $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] where tokenType t = t <> " {Authorization}" @@ -40,7 +41,7 @@ instance (HasForeign lang sublayout) type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("X-MyLovelyHorse", "") tpl ] + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" "") tpl ] where tpl = "I am good friends with {X-MyLovelyHorse}" @@ -52,6 +53,6 @@ instance (HasForeign lang sublayout) type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("X-WhatsForDinner", "") tpl ] + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" "") tpl ] where tpl = "I would like {X-WhatsForDinner} with a cherry on top."