eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge pull request #351 from purcell/variable-foreign-types

Browse Source 
servant-foreign: don't constrain ForeignType to Text
This commit is contained in:
Denis Redozubov 2016-03-15 09:40:53 +03:00
commit f5fe9a060c
12 changed files with 244 additions and 233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
servant-foreign/servant-foreign.cabal
View File

@ -46,6 +46,7 @@ library
, GeneralizedNewtypeDeriving , GeneralizedNewtypeDeriving
, MultiParamTypeClasses , MultiParamTypeClasses
, ScopedTypeVariables , ScopedTypeVariables
, StandaloneDeriving
, TemplateHaskell , TemplateHaskell
, TypeFamilies , TypeFamilies
, TypeOperators , TypeOperators

13
servant-foreign/src/Servant/Foreign.hs
View File

@ -10,14 +10,13 @@ module Servant.Foreign
, Url(..) , Url(..)
-- aliases -- aliases
, Path , Path
, ForeignType(..)
, Arg(..) , Arg(..)
, FunctionName(..) , FunctionName(..)
, PathSegment(..) , PathSegment(..)
-- lenses -- lenses
, aName , argName
, aType , argType
, aPath , argPath
, reqUrl , reqUrl
, reqMethod , reqMethod
, reqHeaders , reqHeaders
@ -26,12 +25,11 @@ module Servant.Foreign
, reqFuncName , reqFuncName
, path , path
, queryStr , queryStr
, argName , queryArgName
, argType , queryArgType
, headerArg , headerArg
-- prisms -- prisms
, _PathSegment , _PathSegment
, _ForeignType
, _HeaderArg , _HeaderArg
, _ReplaceHeaderArg , _ReplaceHeaderArg
, _Static , _Static
@ -42,7 +40,6 @@ module Servant.Foreign
-- rest of it -- rest of it
, HasForeign(..) , HasForeign(..)
, HasForeignType(..) , HasForeignType(..)
, HasNoForeignType
, GenerateList(..) , GenerateList(..)
, NoTypes , NoTypes
, captureArg , captureArg

322
servant-foreign/src/Servant/Foreign/Internal.hs
View File

@ -27,49 +27,50 @@ newtype FunctionName = FunctionName { unFunctionName :: [Text] }
makePrisms ''FunctionName makePrisms ''FunctionName
newtype ForeignType = ForeignType { unForeignType :: Text }
deriving (Show, Eq, IsString, Monoid)
makePrisms ''ForeignType
newtype PathSegment = PathSegment { unPathSegment :: Text } newtype PathSegment = PathSegment { unPathSegment :: Text }
deriving (Show, Eq, IsString, Monoid) deriving (Show, Eq, IsString, Monoid)
makePrisms ''PathSegment makePrisms ''PathSegment
data Arg = Arg data Arg f = Arg
{ _aName :: PathSegment { _argName :: PathSegment
, _aType :: ForeignType } , _argType :: f }
deriving (Show, Eq)
deriving instance Eq f => Eq (Arg f)
deriving instance Show f => Show (Arg f)
makeLenses ''Arg makeLenses ''Arg
aPath :: Getter Arg Text argPath :: Getter (Arg f) Text
aPath = aName . _PathSegment argPath = argName . _PathSegment
data SegmentType data SegmentType f
= Static PathSegment = Static PathSegment
-- ^ a static path segment. like "/foo" -- ^ a static path segment. like "/foo"
| Cap Arg | Cap (Arg f)
-- ^ a capture. like "/:userid" -- ^ a capture. like "/:userid"
deriving (Show, Eq)
deriving instance Eq f => Eq (SegmentType f)
deriving instance Show f => Show (SegmentType f)
makePrisms ''SegmentType makePrisms ''SegmentType
newtype Segment = Segment { unSegment :: SegmentType } newtype Segment f = Segment { unSegment :: SegmentType f }
deriving (Eq, Show)
deriving instance Eq f => Eq (Segment f)
deriving instance Show f => Show (Segment f)
makePrisms ''Segment makePrisms ''Segment
isCapture :: Segment -> Bool isCapture :: Segment f -> Bool
isCapture (Segment (Cap _)) = True isCapture (Segment (Cap _)) = True
isCapture _ = False isCapture _ = False
captureArg :: Segment -> Arg captureArg :: Segment f -> Arg f
captureArg (Segment (Cap s)) = s captureArg (Segment (Cap s)) = s
captureArg _ = error "captureArg called on non capture" captureArg _ = error "captureArg called on non capture"
type Path = [Segment] type Path f = [Segment f]
data ArgType data ArgType
= Normal = Normal
@ -79,47 +80,59 @@ data ArgType
makePrisms ''ArgType makePrisms ''ArgType
data QueryArg = QueryArg data QueryArg f = QueryArg
{ _argName :: Arg { _queryArgName :: Arg f
, _argType :: ArgType , _queryArgType :: ArgType
} deriving (Eq, Show) }
deriving instance Eq f => Eq (QueryArg f)
deriving instance Show f => Show (QueryArg f)
makeLenses ''QueryArg makeLenses ''QueryArg
data HeaderArg = HeaderArg data HeaderArg f = HeaderArg
{ _headerArg :: Arg } { _headerArg :: Arg f }
| ReplaceHeaderArg | ReplaceHeaderArg
{ _headerArg :: Arg { _headerArg :: Arg f
, _headerPattern :: Text , _headerPattern :: Text
} deriving (Eq, Show) }
deriving instance Eq f => Eq (HeaderArg f)
deriving instance Show f => Show (HeaderArg f)
makeLenses ''HeaderArg makeLenses ''HeaderArg
makePrisms ''HeaderArg makePrisms ''HeaderArg
data Url = Url data Url f = Url
{ _path :: Path { _path :: Path f
, _queryStr :: [QueryArg] , _queryStr :: [QueryArg f]
} deriving (Eq, Show) }
defUrl :: Url deriving instance Eq f => Eq (Url f)
deriving instance Show f => Show (Url f)
defUrl :: Url f
defUrl = Url [] [] defUrl = Url [] []
makeLenses ''Url makeLenses ''Url
data Req = Req data Req f = Req
{ _reqUrl :: Url { _reqUrl :: Url f
, _reqMethod :: HTTP.Method , _reqMethod :: HTTP.Method
, _reqHeaders :: [HeaderArg] , _reqHeaders :: [HeaderArg f]
, _reqBody :: Maybe ForeignType , _reqBody :: Maybe f
, _reqReturnType :: ForeignType , _reqReturnType :: Maybe f
, _reqFuncName :: FunctionName , _reqFuncName :: FunctionName
} deriving (Eq, Show) }
deriving instance Eq f => Eq (Req f)
deriving instance Show f => Show (Req f)
makeLenses ''Req makeLenses ''Req
defReq :: Req defReq :: Req ftype
defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName []) defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName [])
-- | To be used exclusively as a "negative" return type/constraint -- | To be used exclusively as a "negative" return type/constraint
-- by @'Elem`@ type family. -- by @'Elem`@ type family.
@ -132,158 +145,158 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
-- | 'HasForeignType' maps Haskell types with types in the target -- | 'HasForeignType' maps Haskell types with types in the target
-- language of your backend. For example, let's say you're -- language of your backend. For example, let's say you're
-- implementing a backend to some language __X__: -- implementing a backend to some language __X__, and you want
-- a Text representation of each input/output type mentioned in the API:
-- --
-- > -- First you need to create a dummy type to parametrize your -- > -- First you need to create a dummy type to parametrize your
-- > -- instances. -- > -- instances.
-- > data LangX -- > data LangX
-- > -- >
-- > -- Otherwise you define instances for the types you need -- > -- Otherwise you define instances for the types you need
-- > instance HasForeignType LangX Int where -- > instance HasForeignType LangX Text Int where
-- > typeFor _ _ = "intX" -- > typeFor _ _ _ = "intX"
-- > -- >
-- > -- Or for example in case of lists -- > -- Or for example in case of lists
-- > instance HasForeignType LangX a => HasForeignType LangX [a] where -- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where
-- > typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) -- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
-- --
-- Finally to generate list of information about all the endpoints for -- Finally to generate list of information about all the endpoints for
-- an API you create a function of a form: -- an API you create a function of a form:
-- --
-- > getEndpoints :: (HasForeign LangX api, GenerateList (Foreign api)) -- > getEndpoints :: (HasForeign LangX Text api, GenerateList Text (Foreign Text api))
-- > => Proxy api -> [Req] -- > => Proxy api -> [Req Text]
-- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) api -- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy Text) api
-- --
-- > -- If language __X__ is dynamically typed then you can use -- > -- If language __X__ is dynamically typed then you can use
-- > -- a predefined NoTypes parameter -- > -- a predefined NoTypes parameter with the () output type:
-- > getEndpoints :: (HasForeign NoTypes api, GenerateList (Foreign api)) --
-- > => Proxy api -> [Req] -- > getEndpoints :: (HasForeign NoTypes () api, GenerateList Text (Foreign () api))
-- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) api -- > => Proxy api -> [Req ()]
-- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) api
-- > -- >
-- --
class HasForeignType lang a where class HasForeignType lang ftype a where
typeFor :: Proxy lang -> Proxy a -> ForeignType typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype
data NoTypes data NoTypes
instance HasForeignType NoTypes ftype where instance HasForeignType NoTypes () ftype where
typeFor _ _ = ForeignType empty typeFor _ _ _ = ()
type HasNoForeignType = HasForeignType NoTypes class HasForeign lang ftype (layout :: *) where
type Foreign ftype layout :: *
foreignFor :: Proxy lang -> Proxy ftype -> Proxy layout -> Req ftype -> Foreign ftype layout
class HasForeign lang (layout :: *) where instance (HasForeign lang ftype a, HasForeign lang ftype b)
type Foreign layout :: * => HasForeign lang ftype (a :<|> b) where
foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout type Foreign ftype (a :<|> b) = Foreign ftype a :<|> Foreign ftype b
instance (HasForeign lang a, HasForeign lang b) foreignFor lang ftype Proxy req =
=> HasForeign lang (a :<|> b) where foreignFor lang ftype (Proxy :: Proxy a) req
type Foreign (a :<|> b) = Foreign a :<|> Foreign b :<|> foreignFor lang ftype (Proxy :: Proxy b) req
foreignFor lang Proxy req = instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype sublayout)
foreignFor lang (Proxy :: Proxy a) req => HasForeign lang ftype (Capture sym t :> sublayout) where
:<|> foreignFor lang (Proxy :: Proxy b) req type Foreign ftype (Capture sym a :> sublayout) = Foreign ftype sublayout
instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout) foreignFor lang Proxy Proxy req =
=> HasForeign lang (Capture sym ftype :> sublayout) where foreignFor lang Proxy (Proxy :: Proxy sublayout) $
type Foreign (Capture sym a :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl . path <>~ [Segment (Cap arg)] req & reqUrl . path <>~ [Segment (Cap arg)]
& reqFuncName . _FunctionName %~ (++ ["by", str]) & reqFuncName . _FunctionName %~ (++ ["by", str])
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) str = pack . symbolVal $ (Proxy :: Proxy sym)
ftype = typeFor lang (Proxy :: Proxy ftype) ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy t)
arg = Arg arg = Arg
{ _aName = PathSegment str { _argName = PathSegment str
, _aType = ftype } , _argType = ftype }
instance (Elem JSON list, HasForeignType lang a, ReflectMethod method) instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
=> HasForeign lang (Verb method status list a) where => HasForeign lang ftype (Verb method status list a) where
type Foreign (Verb method status list a) = Req type Foreign ftype (Verb method status list a) = Req ftype
foreignFor lang Proxy req = foreignFor lang Proxy Proxy req =
req & reqFuncName . _FunctionName %~ (methodLC :) req & reqFuncName . _FunctionName %~ (methodLC :)
& reqMethod .~ method & reqMethod .~ method
& reqReturnType .~ retType & reqReturnType .~ Just retType
where where
retType = typeFor lang (Proxy :: Proxy a) retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a)
method = reflectMethod (Proxy :: Proxy method) method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method methodLC = toLower $ decodeUtf8 method
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout)
=> HasForeign lang (Header sym a :> sublayout) where => HasForeign lang ftype (Header sym a :> sublayout) where
type Foreign (Header sym a :> sublayout) = Foreign sublayout type Foreign ftype (Header sym a :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang Proxy Proxy req =
foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg] foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg]
where where
hname = pack . symbolVal $ (Proxy :: Proxy sym) hname = pack . symbolVal $ (Proxy :: Proxy sym)
arg = Arg arg = Arg
{ _aName = PathSegment hname { _argName = PathSegment hname
, _aType = typeFor lang (Proxy :: Proxy a) } , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }
subP = Proxy :: Proxy sublayout subP = Proxy :: Proxy sublayout
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout)
=> HasForeign lang (QueryParam sym a :> sublayout) where => HasForeign lang ftype (QueryParam sym a :> sublayout) where
type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout type Foreign ftype (QueryParam sym a :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang Proxy Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg arg Normal] req & reqUrl.queryStr <>~ [QueryArg arg Normal]
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = Arg arg = Arg
{ _aName = PathSegment str { _argName = PathSegment str
, _aType = typeFor lang (Proxy :: Proxy a) } , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }
instance instance
(KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype sublayout)
=> HasForeign lang (QueryParams sym a :> sublayout) where => HasForeign lang ftype (QueryParams sym a :> sublayout) where
type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout type Foreign ftype (QueryParams sym a :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang Proxy Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg arg List] req & reqUrl.queryStr <>~ [QueryArg arg List]
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = Arg arg = Arg
{ _aName = PathSegment str { _argName = PathSegment str
, _aType = typeFor lang (Proxy :: Proxy [a]) } , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) }
instance instance
(KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout) (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype sublayout)
=> HasForeign lang (QueryFlag sym :> sublayout) where => HasForeign lang ftype (QueryFlag sym :> sublayout) where
type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout type Foreign ftype (QueryFlag sym :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang ftype (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg arg Flag] req & reqUrl.queryStr <>~ [QueryArg arg Flag]
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = Arg arg = Arg
{ _aName = PathSegment str { _argName = PathSegment str
, _aType = typeFor lang (Proxy :: Proxy Bool) } , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }
instance HasForeign lang Raw where instance HasForeign lang ftype Raw where
type Foreign Raw = HTTP.Method -> Req type Foreign ftype Raw = HTTP.Method -> Req ftype
foreignFor _ Proxy req method = foreignFor _ Proxy Proxy req method =
req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :) req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
& reqMethod .~ method & reqMethod .~ method
instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout) instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype sublayout)
=> HasForeign lang (ReqBody list a :> sublayout) where => HasForeign lang ftype (ReqBody list a :> sublayout) where
type Foreign (ReqBody list a :> sublayout) = Foreign sublayout type Foreign ftype (ReqBody list a :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang ftype (Proxy :: Proxy sublayout) $
req & reqBody .~ (Just $ typeFor lang (Proxy :: Proxy a)) req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))
instance (KnownSymbol path, HasForeign lang sublayout) instance (KnownSymbol path, HasForeign lang ftype sublayout)
=> HasForeign lang (path :> sublayout) where => HasForeign lang ftype (path :> sublayout) where
type Foreign (path :> sublayout) = Foreign sublayout type Foreign ftype (path :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang ftype (Proxy :: Proxy sublayout) $
req & reqUrl . path <>~ [Segment (Static (PathSegment str))] req & reqUrl . path <>~ [Segment (Static (PathSegment str))]
& reqFuncName . _FunctionName %~ (++ [str]) & reqFuncName . _FunctionName %~ (++ [str])
where where
@ -291,58 +304,59 @@ instance (KnownSymbol path, HasForeign lang sublayout)
Data.Text.map (\c -> if c == '.' then '_' else c) Data.Text.map (\c -> if c == '.' then '_' else c)
. pack . symbolVal $ (Proxy :: Proxy path) . pack . symbolVal $ (Proxy :: Proxy path)
instance HasForeign lang sublayout instance HasForeign lang ftype sublayout
=> HasForeign lang (RemoteHost :> sublayout) where => HasForeign lang ftype (RemoteHost :> sublayout) where
type Foreign (RemoteHost :> sublayout) = Foreign sublayout type Foreign ftype (RemoteHost :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req foreignFor lang ftype (Proxy :: Proxy sublayout) req
instance HasForeign lang sublayout instance HasForeign lang ftype sublayout
=> HasForeign lang (IsSecure :> sublayout) where => HasForeign lang ftype (IsSecure :> sublayout) where
type Foreign (IsSecure :> sublayout) = Foreign sublayout type Foreign ftype (IsSecure :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req foreignFor lang ftype (Proxy :: Proxy sublayout) req
instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where instance HasForeign lang ftype sublayout => HasForeign lang ftype (Vault :> sublayout) where
type Foreign (Vault :> sublayout) = Foreign sublayout type Foreign ftype (Vault :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req foreignFor lang ftype (Proxy :: Proxy sublayout) req
instance HasForeign lang sublayout => instance HasForeign lang ftype sublayout =>
HasForeign lang (WithNamedContext name context sublayout) where HasForeign lang ftype (WithNamedContext name context sublayout) where
type Foreign (WithNamedContext name context sublayout) = Foreign sublayout type Foreign ftype (WithNamedContext name context sublayout) = Foreign ftype sublayout
foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout) foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy sublayout)
instance HasForeign lang sublayout instance HasForeign lang ftype sublayout
=> HasForeign lang (HttpVersion :> sublayout) where => HasForeign lang ftype (HttpVersion :> sublayout) where
type Foreign (HttpVersion :> sublayout) = Foreign sublayout type Foreign ftype (HttpVersion :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req foreignFor lang ftype (Proxy :: Proxy sublayout) req
-- | Utility class used by 'listFromAPI' which computes -- | Utility class used by 'listFromAPI' which computes
-- the data needed to generate a function for each endpoint -- the data needed to generate a function for each endpoint
-- and hands it all back in a list. -- and hands it all back in a list.
class GenerateList reqs where class GenerateList ftype reqs where
generateList :: reqs -> [Req] generateList :: reqs -> [Req ftype]
instance GenerateList Req where instance GenerateList ftype (Req ftype) where
generateList r = [r] generateList r = [r]
instance (GenerateList start, GenerateList rest) instance (GenerateList ftype start, GenerateList ftype rest)
=> GenerateList (start :<|> rest) where => GenerateList ftype (start :<|> rest) where
generateList (start :<|> rest) = (generateList start) ++ (generateList rest) generateList (start :<|> rest) = (generateList start) ++ (generateList rest)
-- | Generate the necessary data for codegen as a list, each 'Req' -- | Generate the necessary data for codegen as a list, each 'Req'
-- describing one endpoint from your API type. -- describing one endpoint from your API type.
listFromAPI listFromAPI
:: (HasForeign lang api, GenerateList (Foreign api)) :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api))
=> Proxy lang => Proxy lang
-> Proxy ftype
-> Proxy api -> Proxy api
-> [Req] -> [Req ftype]
listFromAPI lang p = generateList (foreignFor lang p defReq) listFromAPI lang ftype p = generateList (foreignFor lang ftype p defReq)

32
servant-foreign/test/Servant/ForeignSpec.hs
View File

@ -26,20 +26,20 @@ camelCaseSpec = describe "camelCase" $ do
data LangX data LangX
instance HasForeignType LangX () where instance HasForeignType LangX String () where
typeFor _ _ = ForeignType "voidX" typeFor _ _ _ = "voidX"
instance HasForeignType LangX Int where instance HasForeignType LangX String Int where
typeFor _ _ = "intX" typeFor _ _ _ = "intX"
instance HasForeignType LangX Bool where instance HasForeignType LangX String Bool where
typeFor _ _ = "boolX" typeFor _ _ _ = "boolX"
instance OVERLAPPING_ HasForeignType LangX String where instance OVERLAPPING_ HasForeignType LangX String String where
typeFor _ _ = "stringX" typeFor _ _ _ = "stringX"
instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where instance OVERLAPPABLE_ HasForeignType LangX String a => HasForeignType LangX String [a] where
typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
type TestApi type TestApi
= "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int = "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int
@ -47,8 +47,8 @@ type TestApi
:<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] () :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] ()
:<|> "test" :> Capture "id" Int :> Delete '[JSON] () :<|> "test" :> Capture "id" Int :> Delete '[JSON] ()
testApi :: [Req] testApi :: [Req String]
testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi) testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi)
listFromAPISpec :: Spec listFromAPISpec :: Spec
listFromAPISpec = describe "listFromAPI" $ do listFromAPISpec = describe "listFromAPI" $ do
@ -65,7 +65,7 @@ listFromAPISpec = describe "listFromAPI" $ do
, _reqMethod = "GET" , _reqMethod = "GET"
, _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"] , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"]
, _reqBody = Nothing , _reqBody = Nothing
, _reqReturnType = "intX" , _reqReturnType = Just "intX"
, _reqFuncName = FunctionName ["get", "test"] , _reqFuncName = FunctionName ["get", "test"]
} }
@ -77,7 +77,7 @@ listFromAPISpec = describe "listFromAPI" $ do
, _reqMethod = "POST" , _reqMethod = "POST"
, _reqHeaders = [] , _reqHeaders = []
, _reqBody = Just "listX of stringX" , _reqBody = Just "listX of stringX"
, _reqReturnType = "voidX" , _reqReturnType = Just "voidX"
, _reqFuncName = FunctionName ["post", "test"] , _reqFuncName = FunctionName ["post", "test"]
} }
@ -90,7 +90,7 @@ listFromAPISpec = describe "listFromAPI" $ do
, _reqMethod = "PUT" , _reqMethod = "PUT"
, _reqHeaders = [] , _reqHeaders = []
, _reqBody = Just "stringX" , _reqBody = Just "stringX"
, _reqReturnType = "voidX" , _reqReturnType = Just "voidX"
, _reqFuncName = FunctionName ["put", "test"] , _reqFuncName = FunctionName ["put", "test"]
} }
@ -103,6 +103,6 @@ listFromAPISpec = describe "listFromAPI" $ do
, _reqMethod = "DELETE" , _reqMethod = "DELETE"
, _reqHeaders = [] , _reqHeaders = []
, _reqBody = Nothing , _reqBody = Nothing
, _reqReturnType = "voidX" , _reqReturnType = Just "voidX"
, _reqFuncName = FunctionName ["delete", "test", "by", "id"] , _reqFuncName = FunctionName ["delete", "test", "by", "id"]
} }

10
servant-js/src/Servant/JS.hs
View File

@ -128,22 +128,22 @@ import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes)
-- | Generate the data necessary to generate javascript code -- | Generate the data necessary to generate javascript code
-- for all the endpoints of an API, as ':<|>'-separated values -- for all the endpoints of an API, as ':<|>'-separated values
-- of type 'AjaxReq'. -- of type 'AjaxReq'.
javascript :: HasForeign NoTypes layout => Proxy layout -> Foreign layout javascript :: HasForeign NoTypes () layout => Proxy layout -> Foreign () layout
javascript p = foreignFor (Proxy :: Proxy NoTypes) p defReq javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) p defReq
-- | Directly generate all the javascript functions for your API -- | Directly generate all the javascript functions for your API
-- from a 'Proxy' for your API type. You can then write it to -- from a 'Proxy' for your API type. You can then write it to
-- a file or integrate it in a page, for example. -- a file or integrate it in a page, for example.
jsForAPI :: (HasForeign NoTypes api, GenerateList (Foreign api)) jsForAPI :: (HasForeign NoTypes () api, GenerateList () (Foreign () api))
=> Proxy api -- ^ proxy for your API type => Proxy api -- ^ proxy for your API type
-> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others)
-> Text -- ^ a text that you can embed in your pages or write to a file -> Text -- ^ a text that you can embed in your pages or write to a file
jsForAPI p gen = gen (listFromAPI (Proxy :: Proxy NoTypes) p) jsForAPI p gen = gen (listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) p)
-- | Directly generate all the javascript functions for your API -- | Directly generate all the javascript functions for your API
-- from a 'Proxy' for your API type using the given generator -- from a 'Proxy' for your API type using the given generator
-- and write the resulting code to a file at the given path. -- and write the resulting code to a file at the given path.
writeJSForAPI :: (HasForeign NoTypes api, GenerateList (Foreign api)) writeJSForAPI :: (HasForeign NoTypes () api, GenerateList () (Foreign () api))
=> Proxy api -- ^ proxy for your API type => Proxy api -- ^ proxy for your API type
-> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others)
-> FilePath -- ^ path to the file you want to write the resulting javascript code into -> FilePath -- ^ path to the file you want to write the resulting javascript code into

8
servant-js/src/Servant/JS/Angular.hs
View File

@ -76,11 +76,11 @@ generateAngularJSWith ngOptions opts req = "\n" <>
where argsStr = T.intercalate ", " args where argsStr = T.intercalate ", " args
args = http args = http
++ captures ++ captures
++ map (view $ argName . aPath) queryparams ++ map (view $ queryArgName . argPath) queryparams
++ body ++ body
++ map ( toValidFunctionName ++ map ( toValidFunctionName
. (<>) "header" . (<>) "header"
. view (headerArg . aPath) . view (headerArg . argPath)
) hs ) hs
-- If we want to generate Top Level Function, they must depend on -- If we want to generate Top Level Function, they must depend on
@ -90,7 +90,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
0 -> ["$http"] 0 -> ["$http"]
_ -> [] _ -> []
captures = map (view aPath . captureArg) captures = map (view argPath . captureArg)
. filter isCapture . filter isCapture
$ req ^. reqUrl . path $ req ^. reqUrl . path
@ -116,7 +116,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
where where
headersStr = T.intercalate ", " $ map headerStr hs headersStr = T.intercalate ", " $ map headerStr hs
headerStr header = "\"" <> headerStr header = "\"" <>
header ^. headerArg . aPath <> header ^. headerArg . argPath <>
"\": " <> toJSHeader header "\": " <> toJSHeader header
namespace = namespace =

8
servant-js/src/Servant/JS/Axios.hs
View File

@ -62,14 +62,14 @@ generateAxiosJSWith aopts opts req = "\n" <>
where argsStr = T.intercalate ", " args where argsStr = T.intercalate ", " args
args = captures args = captures
++ map (view $ argName . aPath) queryparams ++ map (view $ queryArgName . argPath) queryparams
++ body ++ body
++ map ( toValidFunctionName ++ map ( toValidFunctionName
. (<>) "header" . (<>) "header"
. view (headerArg . aPath) . view (headerArg . argPath)
) hs ) hs
captures = map (view aPath . captureArg) captures = map (view argPath . captureArg)
. filter isCapture . filter isCapture
$ req ^. reqUrl.path $ req ^. reqUrl.path
@ -110,7 +110,7 @@ generateAxiosJSWith aopts opts req = "\n" <>
where where
headersStr = T.intercalate ", " $ map headerStr hs headersStr = T.intercalate ", " $ map headerStr hs
headerStr header = "\"" <> headerStr header = "\"" <>
header ^. headerArg . aPath <> header ^. headerArg . argPath <>
"\": " <> toJSHeader header "\": " <> toJSHeader header
namespace = namespace =

32
servant-js/src/Servant/JS/Internal.hs
View File

@ -21,7 +21,6 @@ module Servant.JS.Internal
, reqHeaders , reqHeaders
, HasForeign(..) , HasForeign(..)
, HasForeignType(..) , HasForeignType(..)
, HasNoForeignType
, GenerateList(..) , GenerateList(..)
, NoTypes , NoTypes
, HeaderArg , HeaderArg
@ -33,7 +32,6 @@ module Servant.JS.Internal
, SegmentType(..) , SegmentType(..)
, Url(..) , Url(..)
, Path , Path
, ForeignType(..)
, Arg(..) , Arg(..)
, FunctionName(..) , FunctionName(..)
, PathSegment(..) , PathSegment(..)
@ -57,12 +55,12 @@ import qualified Data.Text as T
import Data.Text (Text) import Data.Text (Text)
import Servant.Foreign import Servant.Foreign
type AjaxReq = Req type AjaxReq = Req ()
-- A 'JavascriptGenerator' just takes the data found in the API type -- A 'JavascriptGenerator' just takes the data found in the API type
-- for each endpoint and generates Javascript code in a Text. Several -- for each endpoint and generates Javascript code in a Text. Several
-- generators are available in this package. -- generators are available in this package.
type JavaScriptGenerator = [Req] -> Text type JavaScriptGenerator = [Req ()] -> Text
-- | This structure is used by specific implementations to let you -- | This structure is used by specific implementations to let you
-- customize the output -- customize the output
@ -139,9 +137,9 @@ toValidFunctionName t =
, Set.connectorPunctuation , Set.connectorPunctuation
] ]
toJSHeader :: HeaderArg -> Text toJSHeader :: HeaderArg f -> Text
toJSHeader (HeaderArg n) toJSHeader (HeaderArg n)
= toValidFunctionName ("header" <> n ^. aName . _PathSegment) = toValidFunctionName ("header" <> n ^. argName . _PathSegment)
toJSHeader (ReplaceHeaderArg n p) toJSHeader (ReplaceHeaderArg n p)
| pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\"" | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\""
| pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv
@ -149,35 +147,35 @@ toJSHeader (ReplaceHeaderArg n p)
<> "\"" <> "\""
| otherwise = p | otherwise = p
where where
pv = toValidFunctionName ("header" <> n ^. aName . _PathSegment) pv = toValidFunctionName ("header" <> n ^. argName . _PathSegment)
pn = "{" <> n ^. aName . _PathSegment <> "}" pn = "{" <> n ^. argName . _PathSegment <> "}"
rp = T.replace pn "" p rp = T.replace pn "" p
jsSegments :: [Segment] -> Text jsSegments :: [Segment f] -> Text
jsSegments [] = "" jsSegments [] = ""
jsSegments [x] = "/" <> segmentToStr x False jsSegments [x] = "/" <> segmentToStr x False
jsSegments (x:xs) = "/" <> segmentToStr x True <> jsSegments xs jsSegments (x:xs) = "/" <> segmentToStr x True <> jsSegments xs
segmentToStr :: Segment -> Bool -> Text segmentToStr :: Segment f -> Bool -> Text
segmentToStr (Segment st) notTheEnd = segmentToStr (Segment st) notTheEnd =
segmentTypeToStr st <> if notTheEnd then "" else "'" segmentTypeToStr st <> if notTheEnd then "" else "'"
segmentTypeToStr :: SegmentType -> Text segmentTypeToStr :: SegmentType f -> Text
segmentTypeToStr (Static s) = s ^. _PathSegment segmentTypeToStr (Static s) = s ^. _PathSegment
segmentTypeToStr (Cap s) = segmentTypeToStr (Cap s) =
"' + encodeURIComponent(" <> s ^. aName . _PathSegment <> ") + '" "' + encodeURIComponent(" <> s ^. argName . _PathSegment <> ") + '"
jsGParams :: Text -> [QueryArg] -> Text jsGParams :: Text -> [QueryArg f] -> Text
jsGParams _ [] = "" jsGParams _ [] = ""
jsGParams _ [x] = paramToStr x False jsGParams _ [x] = paramToStr x False
jsGParams s (x:xs) = paramToStr x True <> s <> jsGParams s xs jsGParams s (x:xs) = paramToStr x True <> s <> jsGParams s xs
jsParams :: [QueryArg] -> Text jsParams :: [QueryArg f] -> Text
jsParams = jsGParams "&" jsParams = jsGParams "&"
paramToStr :: QueryArg -> Bool -> Text paramToStr :: QueryArg f -> Bool -> Text
paramToStr qarg notTheEnd = paramToStr qarg notTheEnd =
case qarg ^. argType of case qarg ^. queryArgType of
Normal -> name Normal -> name
<> "=' + encodeURIComponent(" <> "=' + encodeURIComponent("
<> name <> name
@ -187,4 +185,4 @@ paramToStr qarg notTheEnd =
<> "[]=' + encodeURIComponent(" <> "[]=' + encodeURIComponent("
<> name <> name
<> if notTheEnd then ") + '" else ")" <> if notTheEnd then ") + '" else ")"
where name = qarg ^. argName . aName . _PathSegment where name = qarg ^. queryArgName . argName . _PathSegment

8
servant-js/src/Servant/JS/JQuery.hs
View File

@ -43,15 +43,15 @@ generateJQueryJSWith opts req = "\n" <>
where argsStr = T.intercalate ", " args where argsStr = T.intercalate ", " args
args = captures args = captures
++ map (view $ argName . aPath) queryparams ++ map (view $ queryArgName . argPath) queryparams
++ body ++ body
++ map (toValidFunctionName ++ map (toValidFunctionName
. (<>) "header" . (<>) "header"
. view (headerArg . aPath) . view (headerArg . argPath)
) hs ) hs
++ [onSuccess, onError] ++ [onSuccess, onError]
captures = map (view aPath . captureArg) captures = map (view argPath . captureArg)
. filter isCapture . filter isCapture
$ req ^. reqUrl.path $ req ^. reqUrl.path
@ -80,7 +80,7 @@ generateJQueryJSWith opts req = "\n" <>
where where
headersStr = T.intercalate ", " $ map headerStr hs headersStr = T.intercalate ", " $ map headerStr hs
headerStr header = "\"" <> headerStr header = "\"" <>
header ^. headerArg . aPath <> header ^. headerArg . argPath <>
"\": " <> toJSHeader header "\": " <> toJSHeader header
namespace = if (moduleName opts) == "" namespace = if (moduleName opts) == ""

8
servant-js/src/Servant/JS/Vanilla.hs
View File

@ -54,15 +54,15 @@ generateVanillaJSWith opts req = "\n" <>
where argsStr = T.intercalate ", " args where argsStr = T.intercalate ", " args
args = captures args = captures
++ map (view $ argName . aPath) queryparams ++ map (view $ queryArgName . argPath) queryparams
++ body ++ body
++ map ( toValidFunctionName ++ map ( toValidFunctionName
. (<>) "header" . (<>) "header"
. view (headerArg . aPath) . view (headerArg . argPath)
) hs ) hs
++ [onSuccess, onError] ++ [onSuccess, onError]
captures = map (view aPath . captureArg) captures = map (view argPath . captureArg)
. filter isCapture . filter isCapture
$ req ^. reqUrl.path $ req ^. reqUrl.path
@ -91,7 +91,7 @@ generateVanillaJSWith opts req = "\n" <>
where where
headersStr = T.intercalate "\n" $ map headerStr hs headersStr = T.intercalate "\n" $ map headerStr hs
headerStr header = " xhr.setRequestHeader(\"" <> headerStr header = " xhr.setRequestHeader(\"" <>
header ^. headerArg . aPath <> header ^. headerArg . argPath <>
"\", " <> toJSHeader header <> ");" "\", " <> toJSHeader header <> ");"
namespace = if moduleName opts == "" namespace = if moduleName opts == ""

4
servant-js/test/Servant/JSSpec.hs
View File

@ -106,7 +106,7 @@ a `shouldNotContain` b = shouldNotSatisfy a (T.isInfixOf b)
axiosSpec :: Spec axiosSpec :: Spec
axiosSpec = describe specLabel $ do axiosSpec = describe specLabel $ do
let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy TestAPI) let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) (Proxy :: Proxy TestAPI)
it "should add withCredentials when needed" $ do it "should add withCredentials when needed" $ do
let jsText = genJS withCredOpts $ reqList let jsText = genJS withCredOpts $ reqList
output jsText output jsText
@ -130,7 +130,7 @@ axiosSpec = describe specLabel $ do
angularSpec :: TestNames -> Spec angularSpec :: TestNames -> Spec
angularSpec test = describe specLabel $ do angularSpec test = describe specLabel $ do
let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy TestAPI) let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) (Proxy :: Proxy TestAPI)
it "should implement a service globally" $ do it "should implement a service globally" $ do
let jsText = genJS reqList let jsText = genJS reqList
output jsText output jsText

31
servant-js/test/Servant/JSSpec/CustomHeaders.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
@ -22,13 +23,13 @@ import Servant.JS.Internal
-- using -- Basic, Digest, whatever. -- using -- Basic, Digest, whatever.
data Authorization (sym :: Symbol) a data Authorization (sym :: Symbol) a
instance (KnownSymbol sym, HasForeign lang sublayout) instance (KnownSymbol sym, HasForeign lang () sublayout)
=> HasForeign lang (Authorization sym a :> sublayout) where => HasForeign lang () (Authorization sym a :> sublayout) where
type Foreign (Authorization sym a :> sublayout) = Foreign sublayout type Foreign () (Authorization sym a :> sublayout) = Foreign () sublayout
foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $
req & reqHeaders <>~ req & reqHeaders <>~
[ ReplaceHeaderArg (Arg "Authorization" "") [ ReplaceHeaderArg (Arg "Authorization" ())
$ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ]
where where
tokenType t = t <> " {Authorization}" tokenType t = t <> " {Authorization}"
@ -36,23 +37,23 @@ instance (KnownSymbol sym, HasForeign lang sublayout)
-- | This is a combinator that fetches an X-MyLovelyHorse header. -- | This is a combinator that fetches an X-MyLovelyHorse header.
data MyLovelyHorse a data MyLovelyHorse a
instance (HasForeign lang sublayout) instance (HasForeign lang () sublayout)
=> HasForeign lang (MyLovelyHorse a :> sublayout) where => HasForeign lang () (MyLovelyHorse a :> sublayout) where
type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout type Foreign () (MyLovelyHorse a :> sublayout) = Foreign () sublayout
foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $
req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" "") tpl ] req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" ()) tpl ]
where where
tpl = "I am good friends with {X-MyLovelyHorse}" tpl = "I am good friends with {X-MyLovelyHorse}"
-- | This is a combinator that fetches an X-WhatsForDinner header. -- | This is a combinator that fetches an X-WhatsForDinner header.
data WhatsForDinner a data WhatsForDinner a
instance (HasForeign lang sublayout) instance (HasForeign lang () sublayout)
=> HasForeign lang (WhatsForDinner a :> sublayout) where => HasForeign lang () (WhatsForDinner a :> sublayout) where
type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout type Foreign () (WhatsForDinner a :> sublayout) = Foreign () sublayout
foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $
req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" "") tpl ] req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" ()) tpl ]
where where
tpl = "I would like {X-WhatsForDinner} with a cherry on top." tpl = "I would like {X-WhatsForDinner} with a cherry on top."