servant-foreign 0.7.1 → 0.16.1
raw patch · 9 files changed
Files
- CHANGELOG.md +151/−0
- LICENSE +1/−1
- Setup.hs +1/−1
- include/overlapping-compat.h +0/−8
- servant-foreign.cabal +45/−47
- src/Servant/Foreign.hs +26/−21
- src/Servant/Foreign/Inflections.hs +27/−18
- src/Servant/Foreign/Internal.hs +328/−140
- test/Servant/ForeignSpec.hs +64/−19
CHANGELOG.md view
@@ -1,3 +1,154 @@+[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md)+[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)++0.16+----++- WithResource combinator for Servant-managed resources [#1630](https://github.com/haskell-servant/servant/pull/1630)++ For servant-foreign, this meant the addition of `HasForeign` instances.++0.15.4+------++### Significant changes++- Documentation improvements.++### Other changes++- Support GHC-9.0.1.+- Bump `lens` and `hspec` dependencies.++0.15.3+------++### Significant changes++- Support `Fragment` combinator.++0.15.2+------++* Support `servant-0.18`.++0.15.1+------++* Support `servant-0.17`++0.15+----++- *servant-foreign* Add support so `HasForeign` can be implemented for+ `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart)+ [#1035](https://github.com/haskell-servant/servant/pull/1035)++- Drop support for GHC older than 8.0+ [#1008](https://github.com/haskell-servant/servant/pull/1008)+ [#1009](https://github.com/haskell-servant/servant/pull/1009)+++0.11.1+------++- Add missing `Semigroup` instances++0.11+----++### Breaking changes++- *servant* Add `Servant.API.Modifiers`+ ([#873](https://github.com/haskell-servant/servant/pull/873))+- Make foreign client Header arguments have the representation of 'Maybe' in those languages+ ([#843](https://github.com/haskell-servant/servant/pull/843))++0.10.2+------++### Changes++* Add instances for `Description` and `Summary` combinators+ ([#767](https://github.com/haskell-servant/servant/pull/767))+* Derive Data for all types+ ([#809](https://github.com/haskell-servant/servant/pull/809))++0.10.1+------++### Changes++* Don't drop samples in `HasDocs ReqBody` instance+ ([#755](https://github.com/haskell-servant/servant/pull/755/files)).+ *Breaking change in an `Internal` module*.++0.10+----++### Breaking changes++* Do not apply JavaScript specific mangling to the names.+ ([#191](https://github.com/haskell-servant/servant/issues/191))++0.7.1+-----++* Support GHC 8.0+0.15+----++- *servant-foreign* Add support so `HasForeign` can be implemented for+ `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart)+ [#1035](https://github.com/haskell-servant/servant/pull/1035)++- Drop support for GHC older than 8.0+ [#1008](https://github.com/haskell-servant/servant/pull/1008)+ [#1009](https://github.com/haskell-servant/servant/pull/1009)+++0.11.1+------++- Add missing `Semigroup` instances++0.11+----++### Breaking changes++- *servant* Add `Servant.API.Modifiers`+ ([#873](https://github.com/haskell-servant/servant/pull/873))+- Make foreign client Header arguments have the representation of 'Maybe' in those languages+ ([#843](https://github.com/haskell-servant/servant/pull/843))++0.10.2+------++### Changes++* Add instances for `Description` and `Summary` combinators+ ([#767](https://github.com/haskell-servant/servant/pull/767))+* Derive Data for all types+ ([#809](https://github.com/haskell-servant/servant/pull/809))++0.10.1+------++### Changes++* Don't drop samples in `HasDocs ReqBody` instance+ ([#755](https://github.com/haskell-servant/servant/pull/755/files)).+ *Breaking change in an `Internal` module*.++0.10+----++### Breaking changes++* Do not apply JavaScript specific mangling to the names.+ ([#191](https://github.com/haskell-servant/servant/issues/191))+ 0.7.1 -----
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
servant-foreign.cabal view
@@ -1,6 +1,9 @@+cabal-version: 2.2 name: servant-foreign-version: 0.7.1+version: 0.16.1+ synopsis: Helpers for generating clients for servant APIs in any programming language+category: Servant, Web description: Helper types and functions for generating client functions for servant APIs in any programming language .@@ -9,18 +12,21 @@ See the servant-js package for an example . <https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>-license: BSD3++homepage: http://docs.servant.dev/+bug-reports: http://github.com/haskell-servant/servant/issues+license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com-copyright: 2015-2016 Servant Contributors-category: Web+copyright: 2015-2019 Servant Contributors build-type: Simple-cabal-version: >=1.10+tested-with: GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.8, GHC ==9.4.8, GHC ==9.6.4, GHC ==9.8.2, GHC ==9.10.1+ extra-source-files:- include/*.h CHANGELOG.md README.md+ source-repository head type: git location: http://github.com/haskell-servant/servant.git@@ -29,54 +35,46 @@ exposed-modules: Servant.Foreign , Servant.Foreign.Internal , Servant.Foreign.Inflections- build-depends: base == 4.*- , lens == 4.*- , servant == 0.7.*- , text >= 1.2 && < 1.3- , http-types++ -- Bundled with GHC: Lower bound to not force re-installs+ -- text and mtl are bundled starting with GHC-8.4+ --+ -- note: mtl lower bound is so low because of GHC-7.8+ build-depends:+ base >= 4.14 && < 4.21+ , text >= 1.2.3.0 && < 2.2++ -- Servant dependencies+ build-depends:+ servant >=0.20.2 && <0.21++ -- Other dependencies: Lower bound around what is in the latest Stackage LTS.+ -- Here can be exceptions if we really need features from the newer versions.+ build-depends:+ base-compat >= 0.10.5 && < 0.15+ , lens >= 4.17 && < 5.4+ , http-types >= 0.12.2 && < 0.13+ hs-source-dirs: src default-language: Haskell2010- ghc-options: -Wall- if impl(ghc >= 8.0)- ghc-options: -Wno-redundant-constraints- include-dirs: include- default-extensions: CPP- , ConstraintKinds- , DataKinds- , FlexibleContexts- , FlexibleInstances- , GeneralizedNewtypeDeriving- , MultiParamTypeClasses- , ScopedTypeVariables- , StandaloneDeriving- , TemplateHaskell- , TypeFamilies- , TypeOperators- , UndecidableInstances- , OverloadedStrings- , PolyKinds-+ ghc-options: -Wall -Wno-redundant-constraints test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: test ghc-options: -Wall- include-dirs: include main-is: Spec.hs other-modules: Servant.ForeignSpec- build-depends: base- , hspec >= 2.1.8- , servant-foreign++ -- Dependencies inherited from the library. No need to specify bounds.+ build-depends:+ base+ , servant+ , servant-foreign++ -- Additional dependencies+ build-depends:+ hspec >= 2.6.0 && <2.12+ build-tool-depends:+ hspec-discover:hspec-discover >=2.6.0 && <2.12 default-language: Haskell2010- default-extensions: ConstraintKinds- , DataKinds- , FlexibleContexts- , FlexibleInstances- , GeneralizedNewtypeDeriving- , MultiParamTypeClasses- , ScopedTypeVariables- , TypeFamilies- , TypeOperators- , UndecidableInstances- , OverloadedStrings- , PolyKinds
src/Servant/Foreign.hs view
@@ -1,19 +1,32 @@ -- | Generalizes all the data needed to make code generation work with -- arbitrary programming languages.+--+-- See documentation of 'HasForeignType' for a simple example. 'listFromAPI' returns a list of all your endpoints and their foreign types, given a mapping from Haskell types to foreign types (conventionally called `ftypes` below). module Servant.Foreign- ( ArgType(..)- , HeaderArg(..)- , QueryArg(..)+ (+ -- * Main API+ listFromAPI , Req(..)- , Segment(..)- , SegmentType(..)+ , defReq+ , HasForeignType(..)+ , GenerateList(..)+ , HasForeign(..)+ , NoTypes+ -- * Subtypes of 'Req' , Url(..)- -- aliases , Path+ , Segment(..)+ , SegmentType(..)+ , isCapture+ , captureArg+ , QueryArg(..)+ , ArgType(..)+ , HeaderArg(..) , Arg(..) , FunctionName(..)+ , ReqBodyContentType(..) , PathSegment(..)- -- lenses+ -- * Lenses , argName , argType , argPath@@ -21,6 +34,7 @@ , reqMethod , reqHeaders , reqBody+ , reqBodyContentType , reqReturnType , reqFuncName , path@@ -28,7 +42,7 @@ , queryArgName , queryArgType , headerArg- -- prisms+ -- * Prisms , _PathSegment , _HeaderArg , _ReplaceHeaderArg@@ -37,20 +51,11 @@ , _Normal , _Flag , _List- -- rest of it- , HasForeign(..)- , HasForeignType(..)- , GenerateList(..)- , NoTypes- , captureArg- , isCapture- , defReq- , listFromAPI- -- re-exports+ -- * Re-exports , module Servant.API , module Servant.Foreign.Inflections ) where -import Servant.API-import Servant.Foreign.Internal-import Servant.Foreign.Inflections+import Servant.API+import Servant.Foreign.Inflections+import Servant.Foreign.Internal
src/Servant/Foreign/Inflections.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module Servant.Foreign.Inflections ( concatCase , snakeCase@@ -9,37 +10,45 @@ ) 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 Control.Lens hiding+ (cons)+import qualified Data.Char as C+import Data.Text hiding+ (map)+import Prelude hiding+ (head, tail) import Servant.Foreign.Internal +-- | Simply concat each part of the FunctionName together.+--+-- @[ "get", "documents", "by", "id" ] → "getdocumentsbyid"@+concatCase :: FunctionName -> Text+concatCase = view concatCaseL+ concatCaseL :: Getter FunctionName Text concatCaseL = _FunctionName . to mconcat --- | Function name builder that simply concat each part together-concatCase :: FunctionName -> Text-concatCase = view concatCaseL+-- | Use the snake_case convention.+-- Each part is separated by a single underscore character.+--+-- @[ "get", "documents", "by", "id" ] → "get_documents_by_id"@+snakeCase :: FunctionName -> Text+snakeCase = view snakeCaseL 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+-- | Use the camelCase convention.+-- The first part is lower case, every other part starts with an upper case character.+--+-- @[ "get", "documents", "by", "id" ] → "getDocumentsById"@+camelCase :: FunctionName -> Text+camelCase = view camelCaseL camelCaseL :: Getter FunctionName Text-camelCaseL = _FunctionName . to (convert . map (replace "-" ""))+camelCaseL = _FunctionName . to convert 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
src/Servant/Foreign/Internal.hs view
@@ -1,148 +1,235 @@-{-# LANGUAGE CPP #-}-#if !MIN_VERSION_base(4,8,0)-{-# LANGUAGE NullaryTypeClasses #-}-#endif+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} --- | Generalizes all the data needed to make code generation work with--- arbitrary programming languages. module Servant.Foreign.Internal where -import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),- (.~))-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-#endif+import Prelude ()+import Prelude.Compat++import Control.Lens+ (Getter, makeLenses, makePrisms, (%~), (&), (.~), (<>~))+import Data.Data+ (Data)+import Data.Kind+ (Type) import Data.Proxy import Data.String import Data.Text-import Data.Text.Encoding (decodeUtf8)-import GHC.Exts (Constraint)+import Data.Text.Encoding+ (decodeUtf8)+import Data.Typeable+ (Typeable) import GHC.TypeLits-import qualified Network.HTTP.Types as HTTP-import Prelude hiding (concat)+import qualified Network.HTTP.Types as HTTP import Servant.API-+import Servant.API.Modifiers+ (RequiredArgument)+import Servant.API.TypeLevel +-- | Canonical name of the endpoint, can be used to generate a function name.+--+-- You can use the functions in "Servant.Foreign.Inflections", like 'Servant.Foreign.Inflections.camelCase' to transform to `Text`. newtype FunctionName = FunctionName { unFunctionName :: [Text] }- deriving (Show, Eq, Monoid)+ deriving (Data, Show, Eq, Semigroup, Monoid, Typeable) makePrisms ''FunctionName +-- | See documentation of 'Arg' newtype PathSegment = PathSegment { unPathSegment :: Text }- deriving (Show, Eq, IsString, Monoid)+ deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable) makePrisms ''PathSegment -data Arg f = Arg+-- | Maps a name to the foreign type that belongs to the annotated value.+--+-- Used for header args, query args, and capture args.+data Arg ftype = Arg { _argName :: PathSegment- , _argType :: f }--deriving instance Eq f => Eq (Arg f)-deriving instance Show f => Show (Arg f)+ -- ^ The name to be captured.+ --+ -- Only for capture args it really denotes a path segment.+ , _argType :: ftype+ -- ^ Foreign type the associated value will have+ }+ deriving (Data, Eq, Show, Typeable) makeLenses ''Arg -argPath :: Getter (Arg f) Text+argPath :: Getter (Arg ftype) Text argPath = argName . _PathSegment -data SegmentType f+data SegmentType ftype = Static PathSegment- -- ^ a static path segment. like "/foo"- | Cap (Arg f)- -- ^ a capture. like "/:userid"--deriving instance Eq f => Eq (SegmentType f)-deriving instance Show f => Show (SegmentType f)+ -- ^ Static path segment.+ --+ -- @"foo\/bar\/baz"@+ --+ -- contains the static segments @"foo"@, @"bar"@ and @"baz"@.+ | Cap (Arg ftype)+ -- ^ A capture.+ --+ -- @"user\/{userid}\/name"@+ --+ -- would capture the arg @userid@ with type @ftype@.+ deriving (Data, Eq, Show, Typeable) makePrisms ''SegmentType -newtype Segment f = Segment { unSegment :: SegmentType f }--deriving instance Eq f => Eq (Segment f)-deriving instance Show f => Show (Segment f)+-- | A part of the Url’s path.+newtype Segment ftype = Segment { unSegment :: SegmentType ftype }+ deriving (Data, Eq, Show, Typeable) makePrisms ''Segment -isCapture :: Segment f -> Bool+-- | Whether a segment is a 'Cap'.+isCapture :: Segment ftype -> Bool isCapture (Segment (Cap _)) = True isCapture _ = False -captureArg :: Segment f -> Arg f+-- | Crashing Arg extraction from segment, TODO: remove+captureArg :: Segment ftype -> Arg ftype captureArg (Segment (Cap s)) = s captureArg _ = error "captureArg called on non capture" -type Path f = [Segment f]+-- TODO: remove, unnecessary indirection+type Path ftype = [Segment ftype] +-- | Type of a 'QueryArg'. data ArgType = Normal | Flag | List- deriving (Eq, Show)+ deriving (Data, Eq, Show, Typeable) makePrisms ''ArgType -data QueryArg f = QueryArg- { _queryArgName :: Arg f+-- | Url Query argument.+--+-- Urls can contain query arguments, which is a list of key-value pairs.+-- In a typical url, query arguments look like this:+--+-- @?foo=bar&alist[]=el1&alist[]=el2&aflag@+--+-- Each pair can be+--+-- * @?foo=bar@: a plain key-val pair, either optional or required ('QueryParam')+-- * @?aflag@: a flag (no value, implicitly Bool with default `false` if it’s missing) ('QueryFlag')+-- * @?alist[]=el1&alist[]=el2@: list of values ('QueryParams')+--+-- @_queryArgType@ will be set accordingly.+--+-- For the plain key-val pairs ('QueryParam'), @_queryArgName@’s @ftype@ will be wrapped in a @Maybe@ if the argument is optional.+data QueryArg ftype = QueryArg+ { _queryArgName :: Arg ftype+ -- ^ Name and foreign type of the argument. Will be wrapped in `Maybe` if the query is optional and in a `[]` if the query is a list , _queryArgType :: ArgType+ -- ^ one of normal/plain, list or flag }--deriving instance Eq f => Eq (QueryArg f)-deriving instance Show f => Show (QueryArg f)+ deriving (Data, Eq, Show, Typeable) makeLenses ''QueryArg -data HeaderArg f = HeaderArg- { _headerArg :: Arg f }+data HeaderArg ftype =+ -- | The name of the header and the foreign type of its value.+ HeaderArg+ { _headerArg :: Arg ftype }+ -- | Unused, will never be set.+ --+ -- TODO: remove | ReplaceHeaderArg- { _headerArg :: Arg f+ { _headerArg :: Arg ftype , _headerPattern :: Text }--deriving instance Eq f => Eq (HeaderArg f)-deriving instance Show f => Show (HeaderArg f)+ deriving (Data, Eq, Show, Typeable) makeLenses ''HeaderArg makePrisms ''HeaderArg -data Url f = Url- { _path :: Path f- , _queryStr :: [QueryArg f]+-- | Full endpoint url, with all captures and parameters+data Url ftype = Url+ { _path :: Path ftype+ -- ^ Url path, list of either static segments or captures+ --+ -- @"foo\/{id}\/bar"@+ , _queryStr :: [QueryArg ftype]+ -- ^ List of query args+ --+ -- @"?foo=bar&a=b"@+ , _frag :: Maybe ftype+ -- ^ Url fragment.+ --+ -- Not sent to the HTTP server, so only useful for frontend matters (e.g. inter-page linking).+ --+ -- @#fragmentText@ }--deriving instance Eq f => Eq (Url f)-deriving instance Show f => Show (Url f)+ deriving (Data, Eq, Show, Typeable) -defUrl :: Url f-defUrl = Url [] []+defUrl :: Url ftype+defUrl = Url [] [] Nothing makeLenses ''Url -data Req f = Req- { _reqUrl :: Url f- , _reqMethod :: HTTP.Method- , _reqHeaders :: [HeaderArg f]- , _reqBody :: Maybe f- , _reqReturnType :: Maybe f- , _reqFuncName :: FunctionName- }+-- | See documentation of '_reqBodyContentType'+data ReqBodyContentType = ReqBodyJSON | ReqBodyMultipart+ deriving (Data, Eq, Show, Read) -deriving instance Eq f => Eq (Req f)-deriving instance Show f => Show (Req f)+-- | Full description of an endpoint in your API, generated by 'listFromAPI'. It should give you all the information needed to generate foreign language bindings.+--+-- Every field containing @ftype@ will use the foreign type mapping specified via 'HasForeignType' (see its docstring on how to set that up).+--+-- See https://docs.servant.dev/en/stable/tutorial/ApiType.html for accessible documentation of the possible content of an endpoint.+data Req ftype = Req+ { _reqUrl :: Url ftype+ -- ^ Full list of URL segments, including captures+ , _reqMethod :: HTTP.Method+ -- ^ @\"GET\"@\/@\"POST\"@\/@\"PUT\"@\/…+ , _reqHeaders :: [HeaderArg ftype]+ -- ^ Headers required by this endpoint, with their type+ , _reqBody :: Maybe ftype+ -- ^ Foreign type of the expected request body ('ReqBody'), if any+ , _reqReturnType :: Maybe ftype+ -- ^ The foreign type of the response, if any+ , _reqFuncName :: FunctionName+ -- ^ The URL segments rendered in a way that they can be easily concatenated into a canonical function name+ , _reqBodyContentType :: ReqBodyContentType+ -- ^ The content type the request body is transferred as.+ --+ -- This is a severe limitation of @servant-foreign@ currently,+ -- as we only allow the content type to be `JSON`+ -- no user-defined content types. ('ReqBodyMultipart' is not+ -- actually implemented.)+ --+ -- Thus, any routes looking like this will work:+ --+ -- @"foo" :> Get '[JSON] Foo@+ --+ -- while routes like+ --+ -- @"foo" :> Get '[MyFancyContentType] Foo@+ --+ -- will fail with an error like+ --+ -- @• JSON expected in list '[MyFancyContentType]@+ }+ deriving (Data, Eq, Show, Typeable) makeLenses ''Req defReq :: Req ftype-defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName [])---- | To be used exclusively as a "negative" return type/constraint--- by @'Elem`@ type family.-class NotFound--type family Elem (a :: *) (ls::[*]) :: Constraint where- Elem a '[] = NotFound- Elem a (a ': list) = ()- Elem a (b ': list) = Elem a list+defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON -- | 'HasForeignType' maps Haskell types with types in the target -- language of your backend. For example, let's say you're@@ -159,7 +246,7 @@ -- > -- > -- Or for example in case of lists -- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where--- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)+-- > typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a) -- -- Finally to generate list of information about all the endpoints for -- an API you create a function of a form:@@ -169,24 +256,29 @@ -- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy Text) api -- -- > -- If language __X__ is dynamically typed then you can use--- > -- a predefined NoTypes parameter with the () output type:+-- > -- a predefined NoTypes parameter with the NoContent output type: ----- > getEndpoints :: (HasForeign NoTypes () api, GenerateList Text (Foreign () api))--- > => Proxy api -> [Req ()]--- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) api+-- > getEndpoints :: (HasForeign NoTypes NoContent api, GenerateList Text (Foreign NoContent api))+-- > => Proxy api -> [Req NoContent]+-- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy NoContent) api -- > -- class HasForeignType lang ftype a where typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype +-- | The language definition without any foreign types. It can be used for dynamic languages which do not /do/ type annotations. data NoTypes -instance HasForeignType NoTypes () ftype where- typeFor _ _ _ = ()+-- | Use if the foreign language does not have any types.+instance HasForeignType NoTypes NoContent a where+ typeFor _ _ _ = NoContent -class HasForeign lang ftype (layout :: *) where- type Foreign ftype layout :: *- foreignFor :: Proxy lang -> Proxy ftype -> Proxy layout -> Req ftype -> Foreign ftype layout+-- | Implementation of the Servant framework types.+--+-- Relevant instances: Everything containing 'HasForeignType'.+class HasForeign lang ftype (api :: Type) where+ type Foreign ftype api :: Type+ foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api instance (HasForeign lang ftype a, HasForeign lang ftype b) => HasForeign lang ftype (a :<|> b) where@@ -196,12 +288,19 @@ foreignFor lang ftype (Proxy :: Proxy a) req :<|> foreignFor lang ftype (Proxy :: Proxy b) req -instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype sublayout)- => HasForeign lang ftype (Capture sym t :> sublayout) where- type Foreign ftype (Capture sym a :> sublayout) = Foreign ftype sublayout+data EmptyForeignAPI = EmptyForeignAPI +instance HasForeign lang ftype EmptyAPI where+ type Foreign ftype EmptyAPI = EmptyForeignAPI++ foreignFor Proxy Proxy Proxy _ = EmptyForeignAPI++instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype api)+ => HasForeign lang ftype (Capture' mods sym t :> api) where+ type Foreign ftype (Capture' mods sym t :> api) = Foreign ftype api+ foreignFor lang Proxy Proxy req =- foreignFor lang Proxy (Proxy :: Proxy sublayout) $+ foreignFor lang Proxy (Proxy :: Proxy api) $ req & reqUrl . path <>~ [Segment (Cap arg)] & reqFuncName . _FunctionName %~ (++ ["by", str]) where@@ -211,6 +310,21 @@ { _argName = PathSegment str , _argType = ftype } +instance (KnownSymbol sym, HasForeignType lang ftype [t], HasForeign lang ftype sublayout)+ => HasForeign lang ftype (CaptureAll sym t :> sublayout) where+ type Foreign ftype (CaptureAll sym t :> sublayout) = Foreign ftype sublayout++ foreignFor lang Proxy Proxy req =+ foreignFor lang Proxy (Proxy :: Proxy sublayout) $+ req & reqUrl . path <>~ [Segment (Cap arg)]+ & reqFuncName . _FunctionName %~ (++ ["by", str])+ where+ str = pack . symbolVal $ (Proxy :: Proxy sym)+ ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [t])+ arg = Arg+ { _argName = PathSegment str+ , _argType = ftype }+ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method) => HasForeign lang ftype (Verb method status list a) where type Foreign ftype (Verb method status list a) = Req ftype@@ -224,38 +338,65 @@ method = reflectMethod (Proxy :: Proxy method) methodLC = toLower $ decodeUtf8 method -instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout)- => HasForeign lang ftype (Header sym a :> sublayout) where- type Foreign ftype (Header sym a :> sublayout) = Foreign ftype sublayout+instance (HasForeignType lang ftype NoContent, ReflectMethod method)+ => HasForeign lang ftype (NoContentVerb method) where+ type Foreign ftype (NoContentVerb method) = Req ftype foreignFor lang Proxy Proxy req =+ req & reqFuncName . _FunctionName %~ (methodLC :)+ & reqMethod .~ method+ & reqReturnType .~ Just retType+ where+ retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy NoContent)+ method = reflectMethod (Proxy :: Proxy method)+ methodLC = toLower $ decodeUtf8 method++-- | TODO: doesn't taking framing into account.+instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)+ => HasForeign lang ftype (Stream method status framing ct a) where+ type Foreign ftype (Stream method status framing ct a) = Req ftype++ foreignFor lang Proxy Proxy req =+ req & reqFuncName . _FunctionName %~ (methodLC :)+ & reqMethod .~ method+ & reqReturnType .~ Just retType+ where+ retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a)+ method = reflectMethod (Proxy :: Proxy method)+ methodLC = toLower $ decodeUtf8 method++instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)+ => HasForeign lang ftype (Header' mods sym a :> api) where+ type Foreign ftype (Header' mods sym a :> api) = Foreign ftype api++ foreignFor lang Proxy Proxy req = foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg] where hname = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg { _argName = PathSegment hname- , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }- subP = Proxy :: Proxy sublayout+ , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (RequiredArgument mods a)) }+ subP = Proxy :: Proxy api -instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout)- => HasForeign lang ftype (QueryParam sym a :> sublayout) where- type Foreign ftype (QueryParam sym a :> sublayout) = Foreign ftype sublayout+instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)+ => HasForeign lang ftype (QueryParam' mods sym a :> api) where+ type Foreign ftype (QueryParam' mods sym a :> api) = Foreign ftype api foreignFor lang Proxy Proxy req =- foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $+ foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $ req & reqUrl.queryStr <>~ [QueryArg arg Normal] where str = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg { _argName = PathSegment str- , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }+ , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (RequiredArgument mods a)) } instance- (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype sublayout)- => HasForeign lang ftype (QueryParams sym a :> sublayout) where- type Foreign ftype (QueryParams sym a :> sublayout) = Foreign ftype sublayout+ (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api)+ => HasForeign lang ftype (QueryParams sym a :> api) where+ type Foreign ftype (QueryParams sym a :> api) = Foreign ftype api foreignFor lang Proxy Proxy req =- foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $+ foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $ req & reqUrl.queryStr <>~ [QueryArg arg List] where str = pack . symbolVal $ (Proxy :: Proxy sym)@@ -264,12 +405,12 @@ , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) } instance- (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype sublayout)- => HasForeign lang ftype (QueryFlag sym :> sublayout) where- type Foreign ftype (QueryFlag sym :> sublayout) = Foreign ftype sublayout+ (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype api)+ => HasForeign lang ftype (QueryFlag sym :> api) where+ type Foreign ftype (QueryFlag sym :> api) = Foreign ftype api foreignFor lang ftype Proxy req =- foreignFor lang ftype (Proxy :: Proxy sublayout) $+ foreignFor lang ftype (Proxy :: Proxy api) $ req & reqUrl.queryStr <>~ [QueryArg arg Flag] where str = pack . symbolVal $ (Proxy :: Proxy sym)@@ -277,6 +418,16 @@ { _argName = PathSegment str , _argType = typeFor lang ftype (Proxy :: Proxy Bool) } +instance+ (HasForeignType lang ftype (Maybe a), HasForeign lang ftype api)+ => HasForeign lang ftype (Fragment a :> api) where+ type Foreign ftype (Fragment a :> api) = Foreign ftype api+ foreignFor lang Proxy Proxy req =+ foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $+ req & reqUrl . frag .~ Just argT+ where+ argT = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a))+ instance HasForeign lang ftype Raw where type Foreign ftype Raw = HTTP.Method -> Req ftype @@ -284,66 +435,103 @@ req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :) & reqMethod .~ method -instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype sublayout)- => HasForeign lang ftype (ReqBody list a :> sublayout) where- type Foreign ftype (ReqBody list a :> sublayout) = Foreign ftype sublayout+instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api)+ => HasForeign lang ftype (ReqBody' mods list a :> api) where+ type Foreign ftype (ReqBody' mods list a :> api) = Foreign ftype api foreignFor lang ftype Proxy req =- foreignFor lang ftype (Proxy :: Proxy sublayout) $+ foreignFor lang ftype (Proxy :: Proxy api) $ req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a)) -instance (KnownSymbol path, HasForeign lang ftype sublayout)- => HasForeign lang ftype (path :> sublayout) where- type Foreign ftype (path :> sublayout) = Foreign ftype sublayout+instance+ ( HasForeign lang ftype api+ ) => HasForeign lang ftype (StreamBody' mods framing ctype a :> api)+ where+ type Foreign ftype (StreamBody' mods framing ctype a :> api) = Foreign ftype api + foreignFor _lang Proxy Proxy _req = error "HasForeign @StreamBody"++instance (KnownSymbol path, HasForeign lang ftype api)+ => HasForeign lang ftype (path :> api) where+ type Foreign ftype (path :> api) = Foreign ftype api+ foreignFor lang ftype Proxy req =- foreignFor lang ftype (Proxy :: Proxy sublayout) $+ foreignFor lang ftype (Proxy :: Proxy api) $ req & reqUrl . path <>~ [Segment (Static (PathSegment str))] & reqFuncName . _FunctionName %~ (++ [str]) where- str =- Data.Text.map (\c -> if c == '.' then '_' else c)- . pack . symbolVal $ (Proxy :: Proxy path)+ str = pack . symbolVal $ (Proxy :: Proxy path) -instance HasForeign lang ftype sublayout- => HasForeign lang ftype (RemoteHost :> sublayout) where- type Foreign ftype (RemoteHost :> sublayout) = Foreign ftype sublayout+instance HasForeign lang ftype api+ => HasForeign lang ftype (RemoteHost :> api) where+ type Foreign ftype (RemoteHost :> api) = Foreign ftype api foreignFor lang ftype Proxy req =- foreignFor lang ftype (Proxy :: Proxy sublayout) req+ foreignFor lang ftype (Proxy :: Proxy api) req -instance HasForeign lang ftype sublayout- => HasForeign lang ftype (IsSecure :> sublayout) where- type Foreign ftype (IsSecure :> sublayout) = Foreign ftype sublayout+instance HasForeign lang ftype api+ => HasForeign lang ftype (IsSecure :> api) where+ type Foreign ftype (IsSecure :> api) = Foreign ftype api foreignFor lang ftype Proxy req =- foreignFor lang ftype (Proxy :: Proxy sublayout) req+ foreignFor lang ftype (Proxy :: Proxy api) req -instance HasForeign lang ftype sublayout => HasForeign lang ftype (Vault :> sublayout) where- type Foreign ftype (Vault :> sublayout) = Foreign ftype sublayout+instance HasForeign lang ftype api => HasForeign lang ftype (Vault :> api) where+ type Foreign ftype (Vault :> api) = Foreign ftype api foreignFor lang ftype Proxy req =- foreignFor lang ftype (Proxy :: Proxy sublayout) req+ foreignFor lang ftype (Proxy :: Proxy api) req -instance HasForeign lang ftype sublayout =>- HasForeign lang ftype (WithNamedContext name context sublayout) where+instance HasForeign lang ftype api =>+ HasForeign lang ftype (WithNamedContext name context api) where - type Foreign ftype (WithNamedContext name context sublayout) = Foreign ftype sublayout+ type Foreign ftype (WithNamedContext name context api) = Foreign ftype api - foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy sublayout)+ foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api) -instance HasForeign lang ftype sublayout- => HasForeign lang ftype (HttpVersion :> sublayout) where- type Foreign ftype (HttpVersion :> sublayout) = Foreign ftype sublayout+instance HasForeign lang ftype api =>+ HasForeign lang ftype (WithResource res :> api) where + type Foreign ftype (WithResource res :> api) = Foreign ftype api++ foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)++instance HasForeign lang ftype api+ => HasForeign lang ftype (HttpVersion :> api) where+ type Foreign ftype (HttpVersion :> api) = Foreign ftype api+ foreignFor lang ftype Proxy req =- foreignFor lang ftype (Proxy :: Proxy sublayout) req+ foreignFor lang ftype (Proxy :: Proxy api) req +instance HasForeign lang ftype api+ => HasForeign lang ftype (Summary desc :> api) where+ type Foreign ftype (Summary desc :> api) = Foreign ftype api++ foreignFor lang ftype Proxy req =+ foreignFor lang ftype (Proxy :: Proxy api) req++instance HasForeign lang ftype api+ => HasForeign lang ftype (Description desc :> api) where+ type Foreign ftype (Description desc :> api) = Foreign ftype api++ foreignFor lang ftype Proxy req =+ foreignFor lang ftype (Proxy :: Proxy api) req++instance HasForeign lang ftype (ToServantApi r) => HasForeign lang ftype (NamedRoutes r) where+ type Foreign ftype (NamedRoutes r) = Foreign ftype (ToServantApi r)++ foreignFor lang ftype Proxy req =+ foreignFor lang ftype (Proxy :: Proxy (ToServantApi r)) req++ -- | Utility class used by 'listFromAPI' which computes -- the data needed to generate a function for each endpoint -- and hands it all back in a list. class GenerateList ftype reqs where generateList :: reqs -> [Req ftype]++instance GenerateList ftype EmptyForeignAPI where+ generateList _ = [] instance GenerateList ftype (Req ftype) where generateList r = [r]
test/Servant/ForeignSpec.hs view
@@ -1,14 +1,25 @@-{-# LANGUAGE CPP #-}-#include "overlapping-compat.h"+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Servant.ForeignSpec where -import Data.Monoid ((<>))-import Data.Proxy-import Servant.Foreign+import Data.Proxy+import Servant.Foreign+import Servant.Test.ComprehensiveAPI+import Servant.Types.SourceT+ (SourceT) -import Test.Hspec+import Test.Hspec + spec :: Spec spec = describe "Servant.Foreign" $ do camelCaseSpec@@ -20,50 +31,67 @@ camelCase (FunctionName ["post", "counter", "inc"]) `shouldBe` "postCounterInc" camelCase (FunctionName ["get", "hyphen-ated", "counter"])- `shouldBe` "getHyphenatedCounter"+ `shouldBe` "getHyphen-atedCounter" ---------------------------------------------------------------------- +-- This declaration simply checks that all instances are in place.+_ = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) comprehensiveAPIWithoutRaw++----------------------------------------------------------------------+ data LangX -instance HasForeignType LangX String () where+instance HasForeignType LangX String NoContent where typeFor _ _ _ = "voidX" +instance HasForeignType LangX String (Headers ctyps NoContent) where+ typeFor _ _ _ = "voidX"+ instance HasForeignType LangX String Int where typeFor _ _ _ = "intX" +instance HasForeignType LangX String (SourceT m a) where+ typeFor _ _ _ = "streamTX"+ instance HasForeignType LangX String Bool where typeFor _ _ _ = "boolX" -instance OVERLAPPING_ HasForeignType LangX String String where+instance {-# OVERLAPPING #-} HasForeignType LangX String String where typeFor _ _ _ = "stringX" -instance OVERLAPPABLE_ HasForeignType LangX String a => HasForeignType LangX String [a] where+instance {-# OVERLAPPABLE #-} HasForeignType LangX String a => HasForeignType LangX String [a] where typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a) +instance (HasForeignType LangX String a) => HasForeignType LangX String (Maybe a) where+ typeFor lang ftype _ = "maybe " <> typeFor lang ftype (Proxy :: Proxy a)+ type TestApi = "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int- :<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] ()- :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] ()- :<|> "test" :> Capture "id" Int :> Delete '[JSON] ()+ :<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent+ :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent+ :<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent+ :<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int]+ :<|> "test" :> EmptyAPI testApi :: [Req String] testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi) listFromAPISpec :: Spec listFromAPISpec = describe "listFromAPI" $ do- it "generates 4 endpoints for TestApi" $ do- length testApi `shouldBe` 4+ it "generates 5 endpoints for TestApi" $ do+ length testApi `shouldBe` 5 - let [getReq, postReq, putReq, deleteReq] = testApi+ let [getReq, postReq, putReq, deleteReq, captureAllReq] = testApi it "collects all info for get request" $ do shouldBe getReq $ defReq { _reqUrl = Url [ Segment $ Static "test" ] [ QueryArg (Arg "flag" "boolX") Flag ]+ Nothing , _reqMethod = "GET"- , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"]+ , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"] , _reqBody = Nothing , _reqReturnType = Just "intX" , _reqFuncName = FunctionName ["get", "test"]@@ -73,7 +101,8 @@ shouldBe postReq $ defReq { _reqUrl = Url [ Segment $ Static "test" ]- [ QueryArg (Arg "param" "intX") Normal ]+ [ QueryArg (Arg "param" "maybe intX") Normal ]+ Nothing , _reqMethod = "POST" , _reqHeaders = [] , _reqBody = Just "listX of stringX"@@ -85,8 +114,9 @@ shouldBe putReq $ defReq { _reqUrl = Url [ Segment $ Static "test" ]- -- Shoud this be |intX| or |listX of intX| ?+ -- Should this be |intX| or |listX of intX| ? [ QueryArg (Arg "params" "listX of intX") List ]+ Nothing , _reqMethod = "PUT" , _reqHeaders = [] , _reqBody = Just "stringX"@@ -100,9 +130,24 @@ [ Segment $ Static "test" , Segment $ Cap (Arg "id" "intX") ] []+ Nothing , _reqMethod = "DELETE" , _reqHeaders = [] , _reqBody = Nothing , _reqReturnType = Just "voidX" , _reqFuncName = FunctionName ["delete", "test", "by", "id"]+ }++ it "collects all info for capture all request" $ do+ shouldBe captureAllReq $ defReq+ { _reqUrl = Url+ [ Segment $ Static "test"+ , Segment $ Cap (Arg "ids" "listX of intX") ]+ []+ Nothing+ , _reqMethod = "GET"+ , _reqHeaders = []+ , _reqBody = Nothing+ , _reqReturnType = Just "listX of intX"+ , _reqFuncName = FunctionName ["get", "test", "by", "ids"] }