Merge pull request #378 from haskell-servant/textly-typed
Utilize newtypes in servant-foreign
This commit is contained in:
Denis Redozubov
commit
e34003e9af
11 changed files with 248 additions and 138 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
, module Servant.API
|
||||
, module Servant.Foreign.Inflections
|
||||
) where
|
||||
|
||||
import Servant.API
|
||||
import Servant.Foreign.Internal
|
||||
import Servant.Foreign.Inflections
|
||||
|
|
|
|||
45
servant-foreign/src/Servant/Foreign/Inflections.hs
Normal file
45
servant-foreign/src/Servant/Foreign/Inflections.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -1,27 +1,18 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
{-# 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
|
||||
|
||||
|
|
@ -196,17 +189,20 @@ 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])
|
||||
& reqFuncName . _FunctionName %~ (++ ["by", str])
|
||||
where
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy ftype))
|
||||
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,11 +215,12 @@ 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))
|
||||
arg = Arg
|
||||
{ _aName = PathSegment hname
|
||||
, _aType = typeFor lang (Proxy :: Proxy a) }
|
||||
subP = Proxy :: Proxy sublayout
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,13 +1,4 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# 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"]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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,7 +90,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
|
|||
0 -> ["$http"]
|
||||
_ -> []
|
||||
|
||||
captures = map (fst . captureArg)
|
||||
captures = map (view aPath . captureArg)
|
||||
. filter isCapture
|
||||
$ req ^. reqUrl . path
|
||||
|
||||
|
|
@ -110,9 +113,10 @@ generateAngularJSWith ngOptions opts req = "\n" <>
|
|||
then ""
|
||||
else " , headers: { " <> headersStr <> " }\n"
|
||||
|
||||
where headersStr = T.intercalate ", " $ map headerStr hs
|
||||
where
|
||||
headersStr = T.intercalate ", " $ map headerStr hs
|
||||
headerStr header = "\"" <>
|
||||
fst (headerArg header) <>
|
||||
header ^. headerArg . aPath <>
|
||||
"\": " <> toJSHeader header
|
||||
|
||||
namespace =
|
||||
|
|
|
|||
|
|
@ -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,9 +107,10 @@ generateAxiosJSWith aopts opts req = "\n" <>
|
|||
then ""
|
||||
else " , headers: { " <> headersStr <> " }\n"
|
||||
|
||||
where headersStr = T.intercalate ", " $ map headerStr hs
|
||||
where
|
||||
headersStr = T.intercalate ", " $ map headerStr hs
|
||||
headerStr header = "\"" <>
|
||||
fst (headerArg header) <>
|
||||
header ^. headerArg . aPath <>
|
||||
"\": " <> toJSHeader header
|
||||
|
||||
namespace =
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
{-# 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
|
||||
|
|
|
|||
|
|
@ -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,9 +77,10 @@ generateJQueryJSWith opts req = "\n" <>
|
|||
then ""
|
||||
else " , headers: { " <> headersStr <> " }\n"
|
||||
|
||||
where headersStr = T.intercalate ", " $ map headerStr hs
|
||||
where
|
||||
headersStr = T.intercalate ", " $ map headerStr hs
|
||||
headerStr header = "\"" <>
|
||||
fst (headerArg header) <>
|
||||
header ^. headerArg . aPath <>
|
||||
"\": " <> toJSHeader header
|
||||
|
||||
namespace = if (moduleName opts) == ""
|
||||
|
|
|
|||
|
|
@ -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,9 +88,10 @@ generateVanillaJSWith opts req = "\n" <>
|
|||
then ""
|
||||
else headersStr <> "\n"
|
||||
|
||||
where headersStr = T.intercalate "\n" $ map headerStr hs
|
||||
where
|
||||
headersStr = T.intercalate "\n" $ map headerStr hs
|
||||
headerStr header = " xhr.setRequestHeader(\"" <>
|
||||
fst (headerArg header) <>
|
||||
header ^. headerArg . aPath <>
|
||||
"\", " <> toJSHeader header <> ");"
|
||||
|
||||
namespace = if moduleName opts == ""
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
Loading…
Reference in a new issue