diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ----- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h deleted file mode 100644 --- a/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-foreign.cabal b/servant-foreign.cabal --- a/servant-foreign.cabal +++ b/servant-foreign.cabal @@ -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 . -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 diff --git a/src/Servant/Foreign.hs b/src/Servant/Foreign.hs --- a/src/Servant/Foreign.hs +++ b/src/Servant/Foreign.hs @@ -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 diff --git a/src/Servant/Foreign/Inflections.hs b/src/Servant/Foreign/Inflections.hs --- a/src/Servant/Foreign/Inflections.hs +++ b/src/Servant/Foreign/Inflections.hs @@ -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 diff --git a/src/Servant/Foreign/Internal.hs b/src/Servant/Foreign/Internal.hs --- a/src/Servant/Foreign/Internal.hs +++ b/src/Servant/Foreign/Internal.hs @@ -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] diff --git a/test/Servant/ForeignSpec.hs b/test/Servant/ForeignSpec.hs --- a/test/Servant/ForeignSpec.hs +++ b/test/Servant/ForeignSpec.hs @@ -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"] }