e5635a0 · servant · git.iko.soy

git.iko.soy/servant

use newtypes in servant-foreign

commite5635a044eafa3f8d7ad514b8738ee134ef2f286 authorDenis Redozubov <denis.redozubov@gmail.com> dateThu 18 Feb 2016, 00:47 (11 years ago) parent16e7234

11 files changed+245−138

compare with master

unifiedsplit

servant-foreign/servant-foreign.cabal+30−3 servant-foreign/src/Servant/Foreign.hs+13−7 servant-foreign/src/Servant/Foreign/Inflections.hs+45 servant-foreign/src/Servant/Foreign/Internal.hs+64−65 servant-foreign/test/Servant/ForeignSpec.hs+15−22 servant-js/src/Servant/JS/Angular.hs+12−8 servant-js/src/Servant/JS/Axios.hs+11−7 servant-js/src/Servant/JS/Internal.hs+27−8 servant-js/src/Servant/JS/JQuery.hs+12−7 servant-js/src/Servant/JS/Vanilla.hs+11−7 servant-js/test/Servant/JSSpec/CustomHeaders.hs+5−4

servant-foreign/servant-foreign.cabal+30−3

@@ -26,7 +26,9 @@ source-repository head

2626 location: http://github.com/haskell-servant/servant.git

2727

2828library

29− exposed-modules: Servant.Foreign, Servant.Foreign.Internal

29+ exposed-modules: Servant.Foreign

30+ , Servant.Foreign.Internal

31+ , Servant.Foreign.Inflections

3032 build-depends: base == 4.*

3133 , lens == 4.*

3234 , servant == 0.5.*

@@ -36,6 +38,20 @@ library

3638 default-language: Haskell2010

3739 ghc-options: -Wall

3840 include-dirs: include

41+ default-extensions: CPP

42+ , ConstraintKinds

43+ , DataKinds

44+ , FlexibleContexts

45+ , FlexibleInstances

46+ , GeneralizedNewtypeDeriving

47+ , MultiParamTypeClasses

48+ , ScopedTypeVariables

49+ , TemplateHaskell

50+ , TypeFamilies

51+ , TypeOperators

52+ , UndecidableInstances

53+ , OverloadedStrings

54+ , PolyKinds

3955

4056

4157test-suite spec

@@ -44,9 +60,20 @@ test-suite spec

4460 ghc-options: -Wall

4561 include-dirs: include

4662 main-is: Spec.hs

47− other-modules:

48− Servant.ForeignSpec

63+ other-modules: Servant.ForeignSpec

4964 build-depends: base

5065 , hspec >= 2.1.8

5166 , servant-foreign

5267 default-language: Haskell2010

68+ default-extensions: ConstraintKinds

69+ , DataKinds

70+ , FlexibleContexts

71+ , FlexibleInstances

72+ , GeneralizedNewtypeDeriving

73+ , MultiParamTypeClasses

74+ , ScopedTypeVariables

75+ , TypeFamilies

76+ , TypeOperators

77+ , UndecidableInstances

78+ , OverloadedStrings

79+ , PolyKinds

servant-foreign/src/Servant/Foreign.hs+13−7

@@ -10,10 +10,14 @@ module Servant.Foreign

1010 , Url(..)

1111 -- aliases

1212 , Path

13− , ForeignType

14− , Arg

15− , FunctionName

13+ , ForeignType(..)

14+ , Arg(..)

15+ , FunctionName(..)

16+ , PathSegment(..)

1617 -- lenses

18+ , aName

19+ , aType

20+ , aPath

1721 , reqUrl

1822 , reqMethod

1923 , reqHeaders

@@ -24,7 +28,10 @@ module Servant.Foreign

2428 , queryStr

2529 , argName

2630 , argType

31+ , headerArg

2732 -- prisms

33+ , _PathSegment

34+ , _ForeignType

2835 , _HeaderArg

2936 , _ReplaceHeaderArg

3037 , _Static

@@ -40,14 +47,13 @@ module Servant.Foreign

4047 , NoTypes

4148 , captureArg

4249 , isCapture

43− , concatCase

44− , snakeCase

45− , camelCase

4650 , defReq

4751 , listFromAPI

48− -- re-exports

52+ -- re-exports

4953 , module Servant.API

54+ , module Servant.Foreign.Inflections

5055 ) where

5156

5257import Servant.API

5358import Servant.Foreign.Internal

59+import Servant.Foreign.Inflections

servant-foreign/src/Servant/Foreign/Inflections.hsnew file+45

@@ -0,0 +1,45 @@

1+module Servant.Foreign.Inflections

2+ ( concatCase

3+ , snakeCase

4+ , camelCase

5+ -- lenses

6+ , concatCaseL

7+ , snakeCaseL

8+ , camelCaseL

9+ ) where

10+

11+

12+import Control.Lens hiding (cons)

13+import qualified Data.Char as C

14+import Data.Monoid

15+import Data.Text hiding (map)

16+import Prelude hiding (head, tail)

17+import Servant.Foreign.Internal

18+

19+concatCaseL :: Getter FunctionName Text

20+concatCaseL = _FunctionName . to mconcat

21+

22+-- | Function name builder that simply concat each part together

23+concatCase :: FunctionName -> Text

24+concatCase = view concatCaseL

25+

26+snakeCaseL :: Getter FunctionName Text

27+snakeCaseL = _FunctionName . to (intercalate "_")

28+

29+-- | Function name builder using the snake_case convention.

30+-- each part is separated by a single underscore character.

31+snakeCase :: FunctionName -> Text

32+snakeCase = view snakeCaseL

33+

34+camelCaseL :: Getter FunctionName Text

35+camelCaseL = _FunctionName . to (convert . map (replace "-" ""))

36+ where

37+ convert [] = ""

38+ convert (p:ps) = mconcat $ p : map capitalize ps

39+ capitalize "" = ""

40+ capitalize name = C.toUpper (head name) `cons` tail name

41+

42+-- | Function name builder using the CamelCase convention.

43+-- each part begins with an upper case character.

44+camelCase :: FunctionName -> Text

45+camelCase = view camelCaseL

servant-foreign/src/Servant/Foreign/Internal.hs+64−65

@@ -1,27 +1,15 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

1+{-# LANGUAGE CPP #-}

62#if !MIN_VERSION_base(4,8,0)

7−{-# LANGUAGE NullaryTypeClasses #-}

3+{-# LANGUAGE NullaryTypeClasses #-}

84#endif

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TemplateHaskell #-}

12−{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE UndecidableInstances #-}

15−{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE PolyKinds #-}

175

186-- | Generalizes all the data needed to make code generation work with

197-- arbitrary programming languages.

208module Servant.Foreign.Internal where

219

22−import Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~))

23−import qualified Data.Char as C

10+import Control.Lens hiding (cons)

2411import Data.Proxy

12+import Data.String

2513import Data.Text

2614import Data.Text.Encoding (decodeUtf8)

2715import GHC.Exts (Constraint)

@@ -30,36 +18,38 @@ import qualified Network.HTTP.Types as HTTP

3018import Prelude hiding (concat)

3119import Servant.API

3220

33−type FunctionName = [Text]

3421

35−-- | Function name builder that simply concat each part together

36−concatCase :: FunctionName -> Text

37−concatCase = concat

22+newtype FunctionName = FunctionName { unFunctionName :: [Text] }

23+ deriving (Show, Eq, Monoid)

3824

39−-- | Function name builder using the snake_case convention.

40−-- each part is separated by a single underscore character.

41−snakeCase :: FunctionName -> Text

42−snakeCase = intercalate "_"

25+makePrisms ''FunctionName

4326

44−-- | Function name builder using the CamelCase convention.

45−-- each part begins with an upper case character.

46−camelCase :: FunctionName -> Text

47−camelCase = camelCase' . Prelude.map (replace "-" "")

48− where camelCase' [] = ""

49− camelCase' (p:ps) = concat $ p : Prelude.map capitalize ps

50− capitalize "" = ""

51− capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name

27+newtype ForeignType = ForeignType { unForeignType :: Text }

28+ deriving (Show, Eq, IsString, Monoid)

5229

53−type ForeignType = Text

30+makePrisms ''ForeignType

5431

55−type Arg = (Text, ForeignType)

32+newtype PathSegment = PathSegment { unPathSegment :: Text }

33+ deriving (Show, Eq, IsString, Monoid)

34+

35+makePrisms ''PathSegment

36+

37+data Arg = Arg

38+ { _aName :: PathSegment

39+ , _aType :: ForeignType }

40+ deriving (Show, Eq)

41+

42+makeLenses ''Arg

43+

44+aPath :: Getter Arg Text

45+aPath = aName . _PathSegment

5646

5747data SegmentType

58− = Static Text

48+ = Static PathSegment

5949 -- ^ a static path segment. like "/foo"

6050 | Cap Arg

6151 -- ^ a capture. like "/:userid"

62− deriving (Eq, Show)

52+ deriving (Show, Eq)

6353

6454makePrisms ''SegmentType

6555

@@ -68,6 +58,14 @@ newtype Segment = Segment { unSegment :: SegmentType }

6858

6959makePrisms ''Segment

7060

61+isCapture :: Segment -> Bool

62+isCapture (Segment (Cap _)) = True

63+isCapture _ = False

64+

65+captureArg :: Segment -> Arg

66+captureArg (Segment (Cap s)) = s

67+captureArg _ = error "captureArg called on non capture"

68+

7169type Path = [Segment]

7270

7371data ArgType

@@ -86,10 +84,10 @@ data QueryArg = QueryArg

8684makeLenses ''QueryArg

8785

8886data HeaderArg = HeaderArg

89− { headerArg :: Arg }

87+ { _headerArg :: Arg }

9088 | ReplaceHeaderArg

91− { headerArg :: Arg

92− , headerPattern :: Text

89+ { _headerArg :: Arg

90+ , _headerPattern :: Text

9391 } deriving (Eq, Show)

9492

9593makeLenses ''HeaderArg

@@ -117,16 +115,8 @@ data Req = Req

117115

118116makeLenses ''Req

119117

120−isCapture :: Segment -> Bool

121−isCapture (Segment (Cap _)) = True

122−isCapture _ = False

123−

124−captureArg :: Segment -> Arg

125−captureArg (Segment (Cap s)) = s

126−captureArg _ = error "captureArg called on non capture"

127−

128118defReq :: Req

129−defReq = Req defUrl "GET" [] Nothing "" []

119+defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName [])

130120

131121-- | To be used exclusively as a "negative" return type/constraint

132122-- by @'Elem`@ type family.

@@ -173,7 +163,7 @@ class HasForeignType lang a where

173163data NoTypes

174164

175165instance HasForeignType NoTypes ftype where

176− typeFor _ _ = empty

166+ typeFor _ _ = ForeignType empty

177167

178168type HasNoForeignType = HasForeignType NoTypes

179169

@@ -195,18 +185,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout)

195185

196186 foreignFor lang Proxy req =

197187 foreignFor lang (Proxy :: Proxy sublayout) $

198− req & reqUrl.path <>~ [Segment (Cap arg)]

199− & reqFuncName %~ (++ ["by", str])

188+ req & reqUrl . path <>~ [Segment (Cap arg)]

189+ & reqFuncName . _FunctionName %~ (++ ["by", str])

200190 where

201− str = pack . symbolVal $ (Proxy :: Proxy sym)

202− arg = (str, typeFor lang (Proxy :: Proxy ftype))

191+ str = pack . symbolVal $ (Proxy :: Proxy sym)

192+ ftype = typeFor lang (Proxy :: Proxy ftype)

193+ arg = Arg

194+ { _aName = PathSegment str

195+ , _aType = ftype }

203196

204197instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)

205198 => HasForeign lang (Verb method status list a) where

206199 type Foreign (Verb method status list a) = Req

207200

208201 foreignFor lang Proxy req =

209− req & reqFuncName %~ (methodLC :)

202+ req & reqFuncName . _FunctionName %~ (methodLC :)

210203 & reqMethod .~ method

211204 & reqReturnType .~ retType

212205 where

@@ -219,12 +212,13 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)

219212 type Foreign (Header sym a :> sublayout) = Foreign sublayout

220213

221214 foreignFor lang Proxy req =

222− foreignFor lang subP $ req

223− & reqHeaders <>~ [HeaderArg arg]

215+ foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg]

224216 where

225217 hname = pack . symbolVal $ (Proxy :: Proxy sym)

226− arg = (hname, typeFor lang (Proxy :: Proxy a))

227− subP = Proxy :: Proxy sublayout

218+ arg = Arg

219+ { _aName = PathSegment hname

220+ , _aType = typeFor lang (Proxy :: Proxy a) }

221+ subP = Proxy :: Proxy sublayout

228222

229223instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)

230224 => HasForeign lang (QueryParam sym a :> sublayout) where

@@ -233,10 +227,11 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)

233227 foreignFor lang Proxy req =

234228 foreignFor lang (Proxy :: Proxy sublayout) $

235229 req & reqUrl.queryStr <>~ [QueryArg arg Normal]

236−

237230 where

238231 str = pack . symbolVal $ (Proxy :: Proxy sym)

239− arg = (str, typeFor lang (Proxy :: Proxy a))

232+ arg = Arg

233+ { _aName = PathSegment str

234+ , _aType = typeFor lang (Proxy :: Proxy a) }

240235

241236instance

242237 (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)

@@ -247,7 +242,9 @@ instance

247242 req & reqUrl.queryStr <>~ [QueryArg arg List]

248243 where

249244 str = pack . symbolVal $ (Proxy :: Proxy sym)

250− arg = (str, typeFor lang (Proxy :: Proxy [a]))

245+ arg = Arg

246+ { _aName = PathSegment str

247+ , _aType = typeFor lang (Proxy :: Proxy [a]) }

251248

252249instance

253250 (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout)

@@ -259,13 +256,15 @@ instance

259256 req & reqUrl.queryStr <>~ [QueryArg arg Flag]

260257 where

261258 str = pack . symbolVal $ (Proxy :: Proxy sym)

262− arg = (str, typeFor lang (Proxy :: Proxy Bool))

259+ arg = Arg

260+ { _aName = PathSegment str

261+ , _aType = typeFor lang (Proxy :: Proxy Bool) }

263262

264263instance HasForeign lang Raw where

265264 type Foreign Raw = HTTP.Method -> Req

266265

267266 foreignFor _ Proxy req method =

268− req & reqFuncName %~ ((toLower $ decodeUtf8 method) :)

267+ req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)

269268 & reqMethod .~ method

270269

271270instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)

@@ -282,8 +281,8 @@ instance (KnownSymbol path, HasForeign lang sublayout)

282281

283282 foreignFor lang Proxy req =

284283 foreignFor lang (Proxy :: Proxy sublayout) $

285− req & reqUrl.path <>~ [Segment (Static str)]

286− & reqFuncName %~ (++ [str])

284+ req & reqUrl . path <>~ [Segment (Static (PathSegment str))]

285+ & reqFuncName . _FunctionName %~ (++ [str])

287286 where

288287 str =

289288 Data.Text.map (\c -> if c == '.' then '_' else c)

servant-foreign/test/Servant/ForeignSpec.hs+15−22

@@ -1,13 +1,4 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE FlexibleInstances #-}

7−{-# LANGUAGE TypeSynonymInstances #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE CPP #-}

10−

1+{-# LANGUAGE CPP #-}

112#include "overlapping-compat.h"

123

134module Servant.ForeignSpec where

@@ -26,15 +17,17 @@ spec = describe "Servant.Foreign" $ do

2617camelCaseSpec :: Spec

2718camelCaseSpec = describe "camelCase" $ do

2819 it "converts FunctionNames to camelCase" $ do

29− camelCase ["post", "counter", "inc"] `shouldBe` "postCounterInc"

30− camelCase ["get", "hyphen-ated", "counter"] `shouldBe` "getHyphenatedCounter"

20+ camelCase (FunctionName ["post", "counter", "inc"])

21+ `shouldBe` "postCounterInc"

22+ camelCase (FunctionName ["get", "hyphen-ated", "counter"])

23+ `shouldBe` "getHyphenatedCounter"

3124

3225----------------------------------------------------------------------

3326

3427data LangX

3528

3629instance HasForeignType LangX () where

37− typeFor _ _ = "voidX"

30+ typeFor _ _ = ForeignType "voidX"

3831

3932instance HasForeignType LangX Int where

4033 typeFor _ _ = "intX"

@@ -68,24 +61,24 @@ listFromAPISpec = describe "listFromAPI" $ do

6861 shouldBe getReq $ defReq

6962 { _reqUrl = Url

7063 [ Segment $ Static "test" ]

71− [ QueryArg ("flag", "boolX") Flag ]

64+ [ QueryArg (Arg "flag" "boolX") Flag ]

7265 , _reqMethod = "GET"

73− , _reqHeaders = [HeaderArg ("header", "listX of stringX")]

66+ , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"]

7467 , _reqBody = Nothing

7568 , _reqReturnType = "intX"

76− , _reqFuncName = ["get", "test"]

69+ , _reqFuncName = FunctionName ["get", "test"]

7770 }

7871

7972 it "collects all info for post request" $ do

8073 shouldBe postReq $ defReq

8174 { _reqUrl = Url

8275 [ Segment $ Static "test" ]

83− [ QueryArg ("param", "intX") Normal ]

76+ [ QueryArg (Arg "param" "intX") Normal ]

8477 , _reqMethod = "POST"

8578 , _reqHeaders = []

8679 , _reqBody = Just "listX of stringX"

8780 , _reqReturnType = "voidX"

88− , _reqFuncName = ["post", "test"]

81+ , _reqFuncName = FunctionName ["post", "test"]

8982 }

9083

9184 it "collects all info for put request" $ do

@@ -93,23 +86,23 @@ listFromAPISpec = describe "listFromAPI" $ do

9386 { _reqUrl = Url

9487 [ Segment $ Static "test" ]

9588 -- Shoud this be |intX| or |listX of intX| ?

96− [ QueryArg ("params", "listX of intX") List ]

89+ [ QueryArg (Arg "params" "listX of intX") List ]

9790 , _reqMethod = "PUT"

9891 , _reqHeaders = []

9992 , _reqBody = Just "stringX"

10093 , _reqReturnType = "voidX"

101− , _reqFuncName = ["put", "test"]

94+ , _reqFuncName = FunctionName ["put", "test"]

10295 }

10396

10497 it "collects all info for delete request" $ do

10598 shouldBe deleteReq $ defReq

10699 { _reqUrl = Url

107100 [ Segment $ Static "test"

108− , Segment $ Cap ("id", "intX") ]

101+ , Segment $ Cap (Arg "id" "intX") ]

109102 []

110103 , _reqMethod = "DELETE"

111104 , _reqHeaders = []

112105 , _reqBody = Nothing

113106 , _reqReturnType = "voidX"

114− , _reqFuncName = ["delete", "test", "by", "id"]

107+ , _reqFuncName = FunctionName ["delete", "test", "by", "id"]

115108 }

servant-js/src/Servant/JS/Angular.hs+12−8

@@ -76,9 +76,12 @@ generateAngularJSWith ngOptions opts req = "\n" <>

7676 where argsStr = T.intercalate ", " args

7777 args = http

7878 ++ captures

79− ++ map (view $ argName._1) queryparams

79+ ++ map (view $ argName . aPath) queryparams

8080 ++ body

81− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs

81+ ++ map ( toValidFunctionName

82+ . (<>) "header"

83+ . view (headerArg . aPath)

84+ ) hs

8285

8386 -- If we want to generate Top Level Function, they must depend on

8487 -- the $http service, if we generate a service, the functions will

@@ -87,9 +90,9 @@ generateAngularJSWith ngOptions opts req = "\n" <>

8790 0 -> ["$http"]

8891 _ -> []

8992

90− captures = map (fst . captureArg)

93+ captures = map (view aPath . captureArg)

9194 . filter isCapture

92− $ req ^. reqUrl.path

95+ $ req ^. reqUrl . path

9396

9497 hs = req ^. reqHeaders

9598

@@ -110,10 +113,11 @@ generateAngularJSWith ngOptions opts req = "\n" <>

110113 then ""

111114 else " , headers: { " <> headersStr <> " }\n"

112115

113− where headersStr = T.intercalate ", " $ map headerStr hs

114− headerStr header = "\"" <>

115− fst (headerArg header) <>

116− "\": " <> toJSHeader header

116+ where

117+ headersStr = T.intercalate ", " $ map headerStr hs

118+ headerStr header = "\"" <>

119+ header ^. headerArg . aPath <>

120+ "\": " <> toJSHeader header

117121

118122 namespace =

119123 if hasService

servant-js/src/Servant/JS/Axios.hs+11−7

@@ -62,11 +62,14 @@ generateAxiosJSWith aopts opts req = "\n" <>

6262

6363 where argsStr = T.intercalate ", " args

6464 args = captures

65− ++ map (view $ argName._1) queryparams

65+ ++ map (view $ argName . aPath) queryparams

6666 ++ body

67− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs

67+ ++ map ( toValidFunctionName

68+ . (<>) "header"

69+ . view (headerArg . aPath)

70+ ) hs

6871

69− captures = map (fst . captureArg)

72+ captures = map (view aPath . captureArg)

7073 . filter isCapture

7174 $ req ^. reqUrl.path

7275

@@ -104,10 +107,11 @@ generateAxiosJSWith aopts opts req = "\n" <>

104107 then ""

105108 else " , headers: { " <> headersStr <> " }\n"

106109

107− where headersStr = T.intercalate ", " $ map headerStr hs

108− headerStr header = "\"" <>

109− fst (headerArg header) <>

110− "\": " <> toJSHeader header

110+ where

111+ headersStr = T.intercalate ", " $ map headerStr hs

112+ headerStr header = "\"" <>

113+ header ^. headerArg . aPath <>

114+ "\": " <> toJSHeader header

111115

112116 namespace =

113117 if hasNoModule

servant-js/src/Servant/JS/Internal.hs+27−8

@@ -1,4 +1,6 @@

1−{-#LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE ViewPatterns #-}

24module Servant.JS.Internal

35 ( JavaScriptGenerator

46 , CommonGeneratorOptions(..)

@@ -19,7 +21,22 @@ module Servant.JS.Internal

1921 , reqHeaders

2022 , HasForeign(..)

2123 , HasForeignType(..)

24+ , HasNoForeignType

25+ , GenerateList(..)

26+ , NoTypes

27+ , HeaderArg

28+ , ArgType(..)

2229 , HeaderArg(..)

30+ , QueryArg(..)

31+ , Req(..)

32+ , Segment(..)

33+ , SegmentType(..)

34+ , Url(..)

35+ , Path

36+ , ForeignType(..)

37+ , Arg(..)

38+ , FunctionName(..)

39+ , PathSegment(..)

2340 , concatCase

2441 , snakeCase

2542 , camelCase

@@ -32,7 +49,7 @@ module Servant.JS.Internal

3249 , Header

3350 ) where

3451

35−import Control.Lens ((^.), _1)

52+import Control.Lens

3653import qualified Data.CharSet as Set

3754import qualified Data.CharSet.Unicode.Category as Set

3855import Data.Monoid

@@ -123,7 +140,8 @@ toValidFunctionName t =

123140 ]

124141

125142toJSHeader :: HeaderArg -> Text

126−toJSHeader (HeaderArg n) = toValidFunctionName ("header" <> fst n)

143+toJSHeader (HeaderArg n)

144+ = toValidFunctionName ("header" <> n ^. aName . _PathSegment)

127145toJSHeader (ReplaceHeaderArg n p)

128146 | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\""

129147 | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv

@@ -131,8 +149,8 @@ toJSHeader (ReplaceHeaderArg n p)

131149 <> "\""

132150 | otherwise = p

133151 where

134− pv = toValidFunctionName ("header" <> fst n)

135− pn = "{" <> fst n <> "}"

152+ pv = toValidFunctionName ("header" <> n ^. aName . _PathSegment)

153+ pn = "{" <> n ^. aName . _PathSegment <> "}"

136154 rp = T.replace pn "" p

137155

138156jsSegments :: [Segment] -> Text

@@ -145,8 +163,9 @@ segmentToStr (Segment st) notTheEnd =

145163 segmentTypeToStr st <> if notTheEnd then "" else "'"

146164

147165segmentTypeToStr :: SegmentType -> Text

148−segmentTypeToStr (Static s) = s

149−segmentTypeToStr (Cap s) = "' + encodeURIComponent(" <> fst s <> ") + '"

166+segmentTypeToStr (Static s) = s ^. _PathSegment

167+segmentTypeToStr (Cap s) =

168+ "' + encodeURIComponent(" <> s ^. aName . _PathSegment <> ") + '"

150169

151170jsGParams :: Text -> [QueryArg] -> Text

152171jsGParams _ [] = ""

@@ -168,4 +187,4 @@ paramToStr qarg notTheEnd =

168187 <> "[]=' + encodeURIComponent("

169188 <> name

170189 <> if notTheEnd then ") + '" else ")"

171− where name = qarg ^. argName . _1

190+ where name = qarg ^. argName . aName . _PathSegment

servant-js/src/Servant/JS/JQuery.hs+12−7

@@ -10,6 +10,7 @@ import Data.Text.Encoding (decodeUtf8)

1010import Servant.Foreign

1111import Servant.JS.Internal

1212

13+

1314-- | Generate javascript functions that use the /jQuery/ library

1415-- to make the AJAX calls. Uses 'defCommonGeneratorOptions'

1516-- for the generator options.

@@ -42,12 +43,15 @@ generateJQueryJSWith opts req = "\n" <>

4243

4344 where argsStr = T.intercalate ", " args

4445 args = captures

45− ++ map (view $ argName._1) queryparams

46+ ++ map (view $ argName . aPath) queryparams

4647 ++ body

47− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs

48+ ++ map (toValidFunctionName

49+ . (<>) "header"

50+ . view (headerArg . aPath)

51+ ) hs

4852 ++ [onSuccess, onError]

4953

50− captures = map (fst . captureArg)

54+ captures = map (view aPath . captureArg)

5155 . filter isCapture

5256 $ req ^. reqUrl.path

5357

@@ -73,10 +77,11 @@ generateJQueryJSWith opts req = "\n" <>

7377 then ""

7478 else " , headers: { " <> headersStr <> " }\n"

7579

76− where headersStr = T.intercalate ", " $ map headerStr hs

77− headerStr header = "\"" <>

78− fst (headerArg header) <>

79− "\": " <> toJSHeader header

80+ where

81+ headersStr = T.intercalate ", " $ map headerStr hs

82+ headerStr header = "\"" <>

83+ header ^. headerArg . aPath <>

84+ "\": " <> toJSHeader header

8085

8186 namespace = if (moduleName opts) == ""

8287 then "var "

servant-js/src/Servant/JS/Vanilla.hs+11−7

@@ -54,12 +54,15 @@ generateVanillaJSWith opts req = "\n" <>

5454

5555 where argsStr = T.intercalate ", " args

5656 args = captures

57− ++ map (view $ argName._1) queryparams

57+ ++ map (view $ argName . aPath) queryparams

5858 ++ body

59− ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs

59+ ++ map ( toValidFunctionName

60+ . (<>) "header"

61+ . view (headerArg . aPath)

62+ ) hs

6063 ++ [onSuccess, onError]

6164

62− captures = map (fst . captureArg)

65+ captures = map (view aPath . captureArg)

6366 . filter isCapture

6467 $ req ^. reqUrl.path

6568

@@ -85,10 +88,11 @@ generateVanillaJSWith opts req = "\n" <>

8588 then ""

8689 else headersStr <> "\n"

8790

88− where headersStr = T.intercalate "\n" $ map headerStr hs

89− headerStr header = " xhr.setRequestHeader(\"" <>

90− fst (headerArg header) <>

91− "\", " <> toJSHeader header <> ");"

91+ where

92+ headersStr = T.intercalate "\n" $ map headerStr hs

93+ headerStr header = " xhr.setRequestHeader(\"" <>

94+ header ^. headerArg . aPath <>

95+ "\", " <> toJSHeader header <> ");"

9296

9397 namespace = if moduleName opts == ""

9498 then "var "

servant-js/test/Servant/JSSpec/CustomHeaders.hs+5−4

@@ -27,8 +27,9 @@ instance (KnownSymbol sym, HasForeign lang sublayout)

2727 type Foreign (Authorization sym a :> sublayout) = Foreign sublayout

2828

2929 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $

30− req & reqHeaders <>~ [ ReplaceHeaderArg ("Authorization", "") $

31− tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ]

30+ req & reqHeaders <>~

31+ [ ReplaceHeaderArg (Arg "Authorization" "")

32+ $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ]

3233 where

3334 tokenType t = t <> " {Authorization}"

3435

@@ -40,7 +41,7 @@ instance (HasForeign lang sublayout)

4041 type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout

4142

4243 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $

43− req & reqHeaders <>~ [ ReplaceHeaderArg ("X-MyLovelyHorse", "") tpl ]

44+ req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" "") tpl ]

4445 where

4546 tpl = "I am good friends with {X-MyLovelyHorse}"

4647

@@ -52,6 +53,6 @@ instance (HasForeign lang sublayout)

5253 type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout

5354

5455 foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $

55− req & reqHeaders <>~ [ ReplaceHeaderArg ("X-WhatsForDinner", "") tpl ]

56+ req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" "") tpl ]

5657 where

5758 tpl = "I would like {X-WhatsForDinner} with a cherry on top."