diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 00000000..335f6094 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,79 @@ +# Contributing Guidelines + +Contributions are very welcome! To hack on the github version, clone the +repository. You can use `cabal`: + +```shell +./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages +./scripts/test-all.sh # Run all the tests +``` + +`stack`: + +```shell +stack build # Install and build packages +stack test # Run all the tests +``` + +Or `nix`: +```shell +./scripts/generate-nix-files.sh # Get up-to-date shell.nix files +``` + + +## General + +Some things we like: + +- Explicit imports +- Upper and lower bounds for packages +- Few dependencies +- -Werror-compatible (for both 7.8 and 7.10) + +Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs` +files in the repository provide a good baseline for consistency. + +Please include a description of the changes in your PR in the `CHANGELOG.md` of +the packages you've changed. And of course, write tests! + +## PR process + +We try to give timely reviews to PRs that pass CI. If CI for your PR fails, we +may close the PR if it has been open for too long (though you should feel free +to reopen when the issues have been fixed). + +We require two +1 from the maintainers of the repo. If you feel like there has +not been a timely response to a PR, you can ping the Maintainers group (with +`@Maintainers`). + +## New combinators + +We encourage people to experiment with new combinators and instances - it is +one of the most powerful ways of using `servant`, and a wonderful way of +getting to know it better. If you do write a new combinator, we would love to +know about it! Either hop on #servant on freenode and let us know, or open an +issue with the `news` tag (which we will close when we read it). + +As for adding them to the main repo: maintaining combinators can be expensive, +since official combinators must have instances for all classes (and new classes +come along fairly frequently). We therefore have to be quite selective about +those that we accept. If you're considering writing a new combinator, open an +issue to discuss it first! (You could release your combinator as a separate +package, of course.) + + +## New classes + +The main benefit of having a new class and package in the main servant repo is +that we get to see via CI whether changes to other packages break the build. +Open an issue to discuss whether a package should be added to the main repo. If +we decide that it can, you can still keep maintainership over it. + +Whether or not you want your package to be in the repo, create an issue with +the `news` label if you make a new package so we can know about it! + +## Release policy + +We are currently moving to a more aggresive release policy, so that you can get +what you contribute from Hackage fairly soon. However, note that prior to major +releases it may take some time in between releases. diff --git a/README.md b/README.md index 0f13f495..3cf786ea 100644 --- a/README.md +++ b/README.md @@ -17,29 +17,4 @@ list](https://groups.google.com/forum/#!forum/haskell-servant). ## Contributing -Contributions are very welcome! To hack on the github version, clone the -repository. You can use `cabal`: - -```shell -./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages -./scripts/test-all.sh # Run all the tests -``` - -`stack`: - -```shell -stack build # Install and build packages -stack test # Run all the tests -``` - -Or `nix`: -```shell -./scripts/generate-nix-files.sh # Get up-to-date shell.nix files -``` - -Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs` -files in the repository provide a good baseline for consistency. - -Please include a description of the changes in your PR in the `CHANGELOG.md` of -the packages you've changed. And of course, write tests! - +See `CONTRIBUTING.md` diff --git a/scripts/bump-versions.sh b/scripts/bump-versions.sh index e1e735f4..2e39cea3 100755 --- a/scripts/bump-versions.sh +++ b/scripts/bump-versions.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: bump-versions.sh diff --git a/scripts/clear-sandbox.sh b/scripts/clear-sandbox.sh index 440e603c..5e70e14f 100755 --- a/scripts/clear-sandbox.sh +++ b/scripts/clear-sandbox.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: clear-sandbox.sh diff --git a/scripts/generate-nix-files.sh b/scripts/generate-nix-files.sh index e72d772a..5865e02f 100755 --- a/scripts/generate-nix-files.sh +++ b/scripts/generate-nix-files.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: generate-nix-files.sh diff --git a/scripts/start-sandbox.sh b/scripts/start-sandbox.sh index b6e88759..5808f072 100755 --- a/scripts/start-sandbox.sh +++ b/scripts/start-sandbox.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: start-sandbox.sh diff --git a/scripts/test-all.sh b/scripts/test-all.sh index 04fd012b..59d24a97 100755 --- a/scripts/test-all.sh +++ b/scripts/test-all.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: test-all.sh diff --git a/scripts/upload.sh b/scripts/upload.sh index 91f0b665..344b8e4a 100755 --- a/scripts/upload.sh +++ b/scripts/upload.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: upload.sh diff --git a/servant-blaze/include/overlapping-compat.h b/servant-blaze/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-blaze/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index 08b27e24..cc4ea34d 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/servant-blaze/servant-blaze.cabal @@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com -- copyright: category: Web build-type: Simple --- extra-source-files: +extra-source-files: include/*.h cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant/issues source-repository head @@ -30,3 +30,4 @@ library , blaze-html hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-blaze/src/Servant/HTML/Blaze.hs b/servant-blaze/src/Servant/HTML/Blaze.hs index 7870022d..822a7ae9 100644 --- a/servant-blaze/src/Servant/HTML/Blaze.hs +++ b/servant-blaze/src/Servant/HTML/Blaze.hs @@ -3,10 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif +#include "overlapping-compat.h" -- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s -- `ToMarkup` class and `Html` datatype. -- You should only need to import this module for it's instances and the @@ -29,17 +27,9 @@ data HTML deriving Typeable instance Accept HTML where contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ToMarkup a => MimeRender HTML a where +instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where mimeRender _ = renderHtml . toHtml -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender HTML Html where +instance OVERLAPPING_ MimeRender HTML Html where mimeRender _ = renderHtml diff --git a/servant-cassava/include/overlapping-compat.h b/servant-cassava/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-cassava/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index 4d74612a..e2e7c964 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com -- copyright: -- category: build-type: Simple --- extra-source-files: +extra-source-files: include/*.h cabal-version: >=1.10 library @@ -27,3 +27,4 @@ library , vector hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-cassava/src/Servant/CSV/Cassava.hs b/servant-cassava/src/Servant/CSV/Cassava.hs index 5bd5a374..625007e7 100644 --- a/servant-cassava/src/Servant/CSV/Cassava.hs +++ b/servant-cassava/src/Servant/CSV/Cassava.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -16,10 +17,13 @@ -- >>> type EgDefault = Get '[CSV] [(Int, String)] module Servant.CSV.Cassava where +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif import Data.Csv import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) -import Data.Vector (Vector) +import Data.Vector (Vector, toList) import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Servant.API (Accept (..), MimeRender (..), @@ -50,6 +54,18 @@ instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) where p = Proxy :: Proxy opt +-- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining +-- the order of headers and fields. +instance ( ToNamedRecord a, EncodeOpts opt + ) => MimeRender (CSV', opt) (Header, Vector a) where + mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals) + where p = Proxy :: Proxy opt + +-- | Encode with 'encodeDefaultOrderedByNameWith' +instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt + ) => MimeRender (CSV', opt) (Vector a) where + mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList + where p = Proxy :: Proxy opt -- ** Encode Options @@ -66,6 +82,17 @@ instance EncodeOpts DefaultEncodeOpts where -- ** Instances -- | Decode with 'decodeByNameWith' +instance ( FromNamedRecord a, DecodeOpts opt + ) => MimeUnrender (CSV', opt) (Header, [a]) where + mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs + where p = Proxy :: Proxy opt + +-- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. +instance ( FromRecord a, DecodeOpts opt + ) => MimeUnrender (CSV', opt) [a] where + mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs + where p = Proxy :: Proxy opt + instance ( FromNamedRecord a, DecodeOpts opt ) => MimeUnrender (CSV', opt) (Header, Vector a) where mimeUnrender _ = decodeByNameWith (decodeOpts p) diff --git a/servant-client/include/overlapping-compat.h b/servant-client/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-client/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 7fe69521..087920dc 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -15,6 +15,7 @@ maintainer: alpmestan@gmail.com copyright: 2014 Zalora South East Asia Pte Ltd category: Web build-type: Simple +extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/ @@ -49,6 +50,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include test-suite spec type: exitcode-stdio-1.0 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 987a2bd4..e9bab748 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -4,13 +4,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" -- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. @@ -24,7 +24,6 @@ module Servant.Client #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad import Control.Monad.Trans.Except import Data.ByteString.Lazy (ByteString) import Data.List @@ -45,7 +44,7 @@ import Servant.Common.Req -- | 'client' allows you to produce operations to query an API from a client. -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy @@ -119,80 +118,48 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) where p = unpack (toUrlPiece val) --- | If you have a 'Delete' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where - type Client (Delete cts' a) = ExceptT ServantError IO a +instance OVERLAPPABLE_ + -- Note [Non-Empty Content Types] + (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient (Verb method status cts' a) where + type Client (Verb method status cts' a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager + snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager + where method = reflectMethod (Proxy :: Proxy method) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Delete cts ()) where - type Client (Delete cts ()) = ExceptT ServantError IO () +instance OVERLAPPING_ + (ReflectMethod method) => HasClient (Verb method status cts NoContent) where + type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodDelete req baseurl manager + performRequestNoBody method req baseurl manager >> return NoContent + where method = reflectMethod (Proxy :: Proxy method) --- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) - ) => HasClient (Delete cts' (Headers ls a)) where - type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) +instance OVERLAPPING_ + -- Note [Non-Empty Content Types] + ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient (Verb method status cts' (Headers ls a)) where + type Client (Verb method status cts' (Headers ls a)) + = ExceptT ServantError IO (Headers ls a) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager + let method = reflectMethod (Proxy :: Proxy method) + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } --- | If you have a 'Get' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where - type Client (Get (ct ': cts) result) = ExceptT ServantError IO result - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Get (ct ': cts) ()) where - type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - performRequestNoBody H.methodGet req baseurl manager - --- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Get (ct ': cts) (Headers ls a)) where - type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) +instance OVERLAPPING_ + ( BuildHeadersTo ls, ReflectMethod method + ) => HasClient (Verb method status cts (Headers ls NoContent)) where + type Client (Verb method status cts (Headers ls NoContent)) + = ExceptT ServantError IO (Headers ls NoContent) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager - return $ Headers { getResponse = resp + let method = reflectMethod (Proxy :: Proxy method) + hdrs <- performRequestNoBody method req baseurl manager + return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } + -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'Header', @@ -236,117 +203,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) where hname = symbolVal (Proxy :: Proxy sym) --- | If you have a 'Post' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where - type Client (Post (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Post (ct ': cts) ()) where - type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPost req baseurl manager - --- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Post (ct ': cts) (Headers ls a)) where - type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - --- | If you have a 'Put' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where - type Client (Put (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Put (ct ': cts) ()) where - type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPut req baseurl manager - --- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Put (ct ': cts) (Headers ls a)) where - type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager= do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - --- | If you have a 'Patch' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where - type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Patch (ct ': cts) ()) where - type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPatch req baseurl manager - --- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Patch (ct ': cts) (Headers ls a)) where - type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'QueryParam', @@ -549,3 +405,20 @@ instance HasClient api => HasClient (IsSecure :> api) where clientWithRoute Proxy req baseurl manager = clientWithRoute (Proxy :: Proxy api) req baseurl manager + + +{- Note [Non-Empty Content Types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather than have + + instance (..., cts' ~ (ct ': cts)) => ... cts' ... + +It may seem to make more sense to have: + + instance (...) => ... (ct ': cts) ... + +But this means that if another instance exists that does *not* require +non-empty lists, but is otherwise more specific, no instance will be overall +more specific. This in turn generally means adding yet another instance (one +for empty and one for non-empty lists). +-} diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 38aa39b5..3d72acd9 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -142,7 +142,7 @@ performRequest reqMethod req reqHost manager = do Right response -> do let status = Client.responseStatus response body = Client.responseBody response - hrds = Client.responseHeaders response + hdrs = Client.responseHeaders response status_code = statusCode status ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" @@ -151,23 +151,26 @@ performRequest reqMethod req reqHost manager = do Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ throwE $ FailureResponse status ct body - return (status_code, body, ct, hrds, response) + return (status_code, body, ct, hdrs, response) performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result) + Proxy ct -> Method -> Req -> BaseUrl -> Manager + -> ExceptT ServantError IO ([HTTP.Header], result) performRequestCT ct reqMethod req reqHost manager = do let acceptCT = contentType ct - (_status, respBody, respCT, hrds, _response) <- + (_status, respBody, respCT, hdrs, _response) <- performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of Left err -> throwE $ DecodeFailure err respCT respBody - Right val -> return (hrds, val) + Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO () -performRequestNoBody reqMethod req reqHost manager = - void $ performRequest reqMethod req reqHost manager +performRequestNoBody :: Method -> Req -> BaseUrl -> Manager + -> ExceptT ServantError IO [HTTP.Header] +performRequestNoBody reqMethod req reqHost manager = do + (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager + return hdrs catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError action = diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index fc3cdcfb..245a7216 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -6,9 +6,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} @@ -20,6 +17,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#include "overlapping-compat.h" module Servant.ClientSpec where #if !MIN_VERSION_base(4,8,0) @@ -92,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type Api = "get" :> Get '[JSON] Person - :<|> "deleteEmpty" :> Delete '[] () + :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person @@ -107,14 +105,14 @@ type Api = ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) - :<|> "deleteContentType" :> Delete '[JSON] () + :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent api :: Proxy Api api = Proxy server :: Application server = serve api ( return alice - :<|> return () + :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> return :<|> (\ name -> case name of @@ -127,7 +125,7 @@ server = serve api ( :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) - :<|> return () + :<|> return NoContent ) @@ -159,11 +157,11 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager - (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right () + (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do let getDeleteContentType = getLast $ client api baseUrl manager - (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right () + (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager @@ -285,7 +283,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where - WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a, + WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a, HasClient api, Client api ~ ExceptT ServantError IO ()) => Proxy api -> WrappedApi @@ -323,33 +321,21 @@ pathGen = fmap NonEmpty path class GetNth (n :: Nat) a b | n a -> b where getNth :: Proxy n -> a -> b -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ GetNth 0 (x :<|> y) x where getNth _ (x :<|> _) = x -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x class GetLast a b | a -> b where getLast :: a -> b -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (GetLast b c) => GetLast (a :<|> b) c where getLast (_ :<|> b) = getLast b -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ GetLast a a where getLast a = a diff --git a/servant-docs/README.md b/servant-docs/README.md index 2c81b2a5..2ac1c335 100644 --- a/servant-docs/README.md +++ b/servant-docs/README.md @@ -6,7 +6,7 @@ Generate API docs for your *servant* webservice. Feel free to also take a look a ## Example -See [here](https://github.com/haskell-servant/servant/tree/master/servant-docs/blob/master/example/greet.md) for the output of the following program. +See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program. ``` haskell {-# LANGUAGE DataKinds #-} diff --git a/servant-docs/include/overlapping-compat.h b/servant-docs/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-docs/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index ee6f71bf..b1be264d 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -19,6 +19,7 @@ tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head @@ -29,8 +30,11 @@ library exposed-modules: Servant.Docs , Servant.Docs.Internal + , Servant.Docs.Internal.Pretty build-depends: base >=4.7 && <5 + , aeson + , aeson-pretty , bytestring , bytestring-conversion , case-insensitive @@ -46,6 +50,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable greet-docs main-is: greet.hs diff --git a/servant-docs/src/Servant/Docs.hs b/servant-docs/src/Servant/Docs.hs index 2f081127..9805285f 100644 --- a/servant-docs/src/Servant/Docs.hs +++ b/servant-docs/src/Servant/Docs.hs @@ -23,7 +23,7 @@ -- See example/greet.hs for an example. module Servant.Docs ( -- * 'HasDocs' class and key functions - HasDocs(..), docs, markdown + HasDocs(..), docs, pretty, markdown -- * Generating docs with extra information , docsWith, docsWithIntros, docsWithOptions , ExtraInfo(..), extraInfo @@ -41,8 +41,7 @@ module Servant.Docs , ToCapture(..) , -- * ADTs to represent an 'API' - Method(..) - , Endpoint, path, method, defEndpoint + Endpoint, path, method, defEndpoint , API, apiIntros, apiEndpoints, emptyAPI , DocCapture(..), capSymbol, capDesc , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind @@ -53,4 +52,5 @@ module Servant.Docs , single ) where -import Servant.Docs.Internal +import Servant.Docs.Internal +import Servant.Docs.Internal.Pretty diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 33cb86a0..0c3e30ac 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -16,9 +16,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.Docs.Internal where import Control.Applicative @@ -37,7 +36,7 @@ import Data.Monoid import Data.Ord (comparing) import Data.Proxy (Proxy(Proxy)) import Data.String.Conversions (cs) -import Data.Text (Text, pack, unpack) +import Data.Text (Text, unpack) import GHC.Exts (Constraint) import GHC.Generics import GHC.TypeLits @@ -50,21 +49,6 @@ import qualified Data.Text as T import qualified Network.HTTP.Media as M import qualified Network.HTTP.Types as HTTP --- | Supported HTTP request methods -data Method = DocDELETE -- ^ the DELETE method - | DocGET -- ^ the GET method - | DocPOST -- ^ the POST method - | DocPUT -- ^ the PUT method - deriving (Eq, Ord, Generic) - -instance Show Method where - show DocGET = "GET" - show DocPOST = "POST" - show DocDELETE = "DELETE" - show DocPUT = "PUT" - -instance Hashable Method - -- | An 'Endpoint' type that holds the 'path' and the 'method'. -- -- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint' @@ -76,12 +60,12 @@ instance Hashable Method -- GET / -- λ> 'defEndpoint' & 'path' '<>~' ["foo"] -- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST' +-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' -- POST /foo -- @ data Endpoint = Endpoint - { _path :: [String] -- type collected - , _method :: Method -- type collected + { _path :: [String] -- type collected + , _method :: HTTP.Method -- type collected } deriving (Eq, Ord, Generic) instance Show Endpoint where @@ -95,7 +79,7 @@ showPath :: [String] -> String showPath [] = "/" showPath ps = concatMap ('/' :) ps --- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET' +-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@ -- -- Here's how you can modify it: -- @@ -104,11 +88,11 @@ showPath ps = concatMap ('/' :) ps -- GET / -- λ> 'defEndpoint' & 'path' '<>~' ["foo"] -- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST' +-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' -- POST /foo -- @ defEndpoint :: Endpoint -defEndpoint = Endpoint [] DocGET +defEndpoint = Endpoint [] HTTP.methodGet instance Hashable Endpoint @@ -477,8 +461,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h) -- | Synthesise a sample value of a type, encoded in the specified media types. sampleByteString - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) - => Proxy ctypes + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(M.MediaType, ByteString)] sampleByteString ctypes@Proxy Proxy = @@ -487,8 +471,8 @@ sampleByteString ctypes@Proxy Proxy = -- | Synthesise a list of sample values of a particular type, encoded in the -- specified media types. sampleByteStrings - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) - => Proxy ctypes + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(Text, M.MediaType, ByteString)] sampleByteStrings ctypes@Proxy Proxy = @@ -661,10 +645,7 @@ markdown api = unlines $ -- | The generated docs for @a ':<|>' b@ just appends the docs -- for @a@ with the docs for @b@. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (HasDocs layout1, HasDocs layout2) => HasDocs (layout1 :<|> layout2) where @@ -692,149 +673,38 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) symP = Proxy :: Proxy sym -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Delete cts a) where +instance OVERLAPPABLE_ + (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status + , ReflectMethod method) + => HasDocs (Verb method status (ct ': cts) a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' - where endpoint' = endpoint & method .~ DocDELETE + where endpoint' = endpoint & method .~ method' action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t - t = Proxy :: Proxy cts + & response.respStatus .~ status + t = Proxy :: Proxy (ct ': cts) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Delete cts (Headers ls a)) where +instance OVERLAPPING_ + (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status + , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls)) + => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocDELETE + where endpoint' = endpoint & method .~ method' action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t + & response.respStatus .~ status & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Get cts a) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Get cts (Headers ls a)) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance (KnownSymbol sym, HasDocs sublayout) - => HasDocs (Header sym a :> sublayout) where - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') - - where sublayoutP = Proxy :: Proxy sublayout - action' = over headers (|> headername) action - headername = pack $ symbolVal (Proxy :: Proxy sym) - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Post cts a) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocPOST - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 201 - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Post cts (Headers ls a)) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocPOST - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 201 - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Put cts a) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocPUT - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 200 - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( ToSample a, IsNonEmpty cts, AllMimeRender cts a, - AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Put cts (Headers ls a)) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocPUT - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 200 - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) + hdrs = allHeaderToSample (Proxy :: Proxy ls) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) @@ -877,8 +747,8 @@ instance HasDocs Raw where -- example data. However, there's no reason to believe that the instances of -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- both are even defined) for any particular type. -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) - => HasDocs (ReqBody cts a :> sublayout) where +instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout) + => HasDocs (ReqBody (ct ': cts) a :> sublayout) where docsFor Proxy (endpoint, action) = docsFor sublayoutP (endpoint, action') @@ -886,7 +756,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) where sublayoutP = Proxy :: Proxy sublayout action' = action & rqbody .~ sampleByteString t p & rqtypes .~ allMime t - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where diff --git a/servant-docs/src/Servant/Docs/Internal/Pretty.hs b/servant-docs/src/Servant/Docs/Internal/Pretty.hs new file mode 100644 index 00000000..13275467 --- /dev/null +++ b/servant-docs/src/Servant/Docs/Internal/Pretty.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Docs.Internal.Pretty where + +import Data.Aeson (ToJSON(..)) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Proxy (Proxy(Proxy)) +import Network.HTTP.Media ((//)) +import Servant.API + +-- | PrettyJSON content type. +data PrettyJSON + +instance Accept PrettyJSON where + contentType _ = "application" // "json" + +instance ToJSON a => MimeRender PrettyJSON a where + mimeRender _ = encodePretty + +-- | Prettify generated JSON documentation. +-- +-- @ +-- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI)) +-- @ +pretty :: Proxy layout -> Proxy (Pretty layout) +pretty Proxy = Proxy + +-- | Replace all JSON content types with PrettyJSON. +-- Kind-polymorphic so it can operate on kinds @*@ and @[*]@. +type family Pretty (layout :: k) :: k where + Pretty (x :<|> y) = Pretty x :<|> Pretty y + Pretty (x :> y) = Pretty x :> Pretty y + Pretty (Get cs r) = Get (Pretty cs) r + Pretty (Post cs r) = Post (Pretty cs) r + Pretty (Put cs r) = Put (Pretty cs) r + Pretty (Delete cs r) = Delete (Pretty cs) r + Pretty (Patch cs r) = Patch (Pretty cs) r + Pretty (ReqBody cs r) = ReqBody (Pretty cs) r + Pretty (JSON ': xs) = PrettyJSON ': xs + Pretty (x ': xs) = x ': Pretty xs + Pretty x = x diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 5375b0c3..d37f78c9 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -71,7 +71,6 @@ spec = describe "Servant.Docs" $ do it "mentions status codes" $ do md `shouldContain` "Status code 200" - md `shouldContain` "Status code 201" it "mentions methods" $ do md `shouldContain` "POST" diff --git a/servant-examples/include/overlapping-compat.h b/servant-examples/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-examples/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-foreign/include/overlapping-compat.h b/servant-foreign/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-foreign/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 0ec296ae..ca92b43a 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -18,6 +18,7 @@ category: Web build-type: Simple cabal-version: >=1.10 extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head @@ -26,19 +27,22 @@ source-repository head library exposed-modules: Servant.Foreign, Servant.Foreign.Internal - build-depends: base == 4.* - , lens == 4.* - , servant == 0.5.* - , text >= 1.2 && < 1.3 + build-depends: base == 4.* + , lens == 4.* + , servant == 0.5.* + , text >= 1.2 && < 1.3 + , http-types hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include 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 diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 27f0e411..ae199202 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -13,18 +13,21 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} -- | Generalizes all the data needed to make code generation work with -- arbitrary programming languages. module Servant.Foreign.Internal where -import Control.Lens (makeLenses, (%~), (&), (.~), (<>~)) -import qualified Data.Char as C +import Control.Lens (makeLenses, (%~), (&), (.~), (<>~)) +import qualified Data.Char as C import Data.Proxy import Data.Text -import GHC.Exts (Constraint) +import Data.Text.Encoding (decodeUtf8) +import GHC.Exts (Constraint) import GHC.TypeLits -import Prelude hiding (concat) +import qualified Network.HTTP.Types as HTTP +import Prelude hiding (concat) import Servant.API -- | Function name builder that simply concat each part together @@ -86,11 +89,10 @@ defUrl :: Url defUrl = Url [] [] type FunctionName = [Text] -type Method = Text data Req = Req { _reqUrl :: Url - , _reqMethod :: Method + , _reqMethod :: HTTP.Method , _reqHeaders :: [HeaderArg] , _reqBody :: Maybe ForeignType , _reqReturnType :: ForeignType @@ -185,27 +187,18 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) str = pack . symbolVal $ (Proxy :: Proxy sym) arg = (str, typeFor lang (Proxy :: Proxy a)) -instance (Elem JSON list, HasForeignType lang a) - => HasForeign lang (Delete list a) where - type Foreign (Delete list a) = Req +instance (Elem JSON list, HasForeignType lang a, ReflectMethod method) + => HasForeign lang (Verb method status list a) where + type Foreign (Verb method status list a) = Req foreignFor lang Proxy req = - req & funcName %~ ("delete" :) - & reqMethod .~ "DELETE" + req & funcName %~ (methodLC :) + & reqMethod .~ method & reqReturnType .~ retType where - retType = typeFor lang (Proxy :: Proxy a) - -instance (Elem JSON list, HasForeignType lang a) - => HasForeign lang (Get list a) where - type Foreign (Get list a) = Req - - foreignFor lang Proxy req = - req & funcName %~ ("get" :) - & reqMethod .~ "GET" - & reqReturnType .~ retType - where - retType = typeFor lang (Proxy :: Proxy a) + retType = typeFor lang (Proxy :: Proxy a) + method = reflectMethod (Proxy :: Proxy method) + methodLC = toLower $ decodeUtf8 method instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) => HasForeign lang (Header sym a :> sublayout) where @@ -220,28 +213,6 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) arg = (hname, typeFor lang (Proxy :: Proxy a)) subP = Proxy :: Proxy sublayout -instance (Elem JSON list, HasForeignType lang a) - => HasForeign lang (Post list a) where - type Foreign (Post list a) = Req - - foreignFor lang Proxy req = - req & funcName %~ ("post" :) - & reqMethod .~ "POST" - & reqReturnType .~ retType - where - retType = typeFor lang (Proxy :: Proxy a) - -instance (Elem JSON list, HasForeignType lang a) - => HasForeign lang (Put list a) where - type Foreign (Put list a) = Req - - foreignFor lang Proxy req = - req & funcName %~ ("put" :) - & reqMethod .~ "PUT" - & reqReturnType .~ retType - where - retType = typeFor lang (Proxy :: Proxy a) - instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) => HasForeign lang (QueryParam sym a :> sublayout) where type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout @@ -279,10 +250,10 @@ instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang subl arg = (str, typeFor lang (Proxy :: Proxy a)) instance HasForeign lang Raw where - type Foreign Raw = Method -> Req + type Foreign Raw = HTTP.Method -> Req foreignFor _ Proxy req method = - req & funcName %~ ((toLower method) :) + req & funcName %~ ((toLower $ decodeUtf8 method) :) & reqMethod .~ method instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout) @@ -346,4 +317,3 @@ instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> res -- describing one endpoint from your API type. listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req] listFromAPI lang p = generateList (foreignFor lang p defReq) - diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index a5bad431..06e722cc 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -7,9 +7,8 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.ForeignSpec where @@ -41,9 +40,9 @@ instance HasForeignType LangX Int where typeFor _ _ = "intX" instance HasForeignType LangX Bool where typeFor _ _ = "boolX" -instance {-# Overlapping #-} HasForeignType LangX String where +instance OVERLAPPING_ HasForeignType LangX String where typeFor _ _ = "stringX" -instance {-# Overlappable #-} HasForeignType LangX a => HasForeignType LangX [a] where +instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) type TestApi diff --git a/servant-js/include/overlapping-compat.h b/servant-js/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-js/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 53a74e9d..28005e60 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -22,6 +22,7 @@ cabal-version: >=1.10 homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head @@ -49,6 +50,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable counter main-is: counter.hs diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 2f1b42fb..8530b03f 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -6,6 +6,7 @@ import Data.Maybe (isJust) import Data.Monoid import qualified Data.Text as T import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) import Servant.Foreign import Servant.JS.Internal @@ -68,7 +69,7 @@ generateAngularJSWith ngOptions opts req = "\n" <> <> " { url: " <> url <> "\n" <> dataBody <> reqheaders - <> " , method: '" <> method <> "'\n" + <> " , method: '" <> decodeUtf8 method <> "'\n" <> " });\n" <> "}\n" diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index 50bed9eb..25e92df3 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -5,6 +5,7 @@ import Control.Lens import Data.Maybe (isJust) import Data.Monoid import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) import qualified Data.Text as T import Servant.Foreign import Servant.JS.Internal @@ -117,7 +118,7 @@ generateAxiosJSWith aopts opts req = "\n" <> fname = namespace <> (functionNameBuilder opts $ req ^. funcName) - method = T.toLower $ req ^. reqMethod + method = T.toLower . decodeUtf8 $ req ^. reqMethod url = if url' == "'" then "'/'" else url' url' = "'" <> urlPrefix opts diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index 722d9c07..71147006 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -6,6 +6,7 @@ import Data.Maybe (isJust) import Data.Monoid import qualified Data.Text as T import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) import Servant.Foreign import Servant.JS.Internal @@ -35,7 +36,7 @@ generateJQueryJSWith opts req = "\n" <> <> dataBody <> reqheaders <> " , error: " <> onError <> "\n" - <> " , type: '" <> method <> "'\n" + <> " , type: '" <> decodeUtf8 method <> "'\n" <> " });\n" <> "}\n" diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index 7313f540..f623e2a6 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -4,6 +4,7 @@ module Servant.JS.Vanilla where import Control.Lens import Data.Maybe (isJust) import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) import qualified Data.Text as T import Data.Monoid import Servant.Foreign @@ -31,14 +32,19 @@ generateVanillaJSWith opts req = "\n" <> fname <> " = function(" <> argsStr <> ")\n" <> "{\n" <> " var xhr = new XMLHttpRequest();\n" - <> " xhr.open('" <> method <> "', " <> url <> ", true);\n" + <> " xhr.open('" <> decodeUtf8 method <> "', " <> url <> ", true);\n" <> reqheaders + <> " xhr.setRequestHeader(\"Accept\",\"application/json\");\n" + <> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "") <> " xhr.onreadystatechange = function (e) {\n" <> " if (xhr.readyState == 4) {\n" + <> " if (xhr.status == 204 || xhr.status == 205) {\n" + <> " onSuccess();\n" + <> " } else if (xhr.status >= 200 && xhr.status < 300) {\n" <> " var value = JSON.parse(xhr.responseText);\n" - <> " if (xhr.status == 200 || xhr.status == 201) {\n" <> " onSuccess(value);\n" <> " } else {\n" + <> " var value = JSON.parse(xhr.responseText);\n" <> " onError(value);\n" <> " }\n" <> " }\n" diff --git a/servant-lucid/include/overlapping-compat.h b/servant-lucid/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-lucid/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index 77cf3ee1..f2be1eb5 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/servant-lucid/servant-lucid.cabal @@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com -- copyright: category: Web build-type: Simple --- extra-source-files: +extra-source-files: include/*.h cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant/issues source-repository head @@ -30,3 +30,4 @@ library , servant == 0.5.* hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-lucid/src/Servant/HTML/Lucid.hs b/servant-lucid/src/Servant/HTML/Lucid.hs index f222c6ac..ec62a21c 100644 --- a/servant-lucid/src/Servant/HTML/Lucid.hs +++ b/servant-lucid/src/Servant/HTML/Lucid.hs @@ -3,9 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" -- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s -- `ToHtml` class and `Html` datatype. @@ -28,16 +27,10 @@ data HTML deriving Typeable instance Accept HTML where contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ToHtml a => MimeRender HTML a where mimeRender _ = renderBS . toHtml -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ MimeRender HTML (Html a) where mimeRender _ = renderBS diff --git a/servant-mock/include/overlapping-compat.h b/servant-mock/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-mock/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 0bb605db..7d8589d0 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -13,6 +13,7 @@ maintainer: alpmestan@gmail.com copyright: 2015 Alp Mestanogullari category: Web build-type: Simple +extra-source-files: include/*.h cabal-version: >=1.10 flag example @@ -31,9 +32,10 @@ library servant-server >= 0.4, transformers >= 0.3 && <0.5, QuickCheck >= 2.7 && <2.9, - wai >= 3.0 && <3.1 + wai >= 3.0 && <3.3 hs-source-dirs: src default-language: Haskell2010 + include-dirs: include executable mock-app main-is: main.hs diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 3fa5d077..e4437fba 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -139,19 +139,8 @@ instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where mock _ = \_ -> mock (Proxy :: Proxy rest) -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where - mock _ = mockArbitrary - -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Get ctypes a) where - mock _ = mockArbitrary - -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Patch ctypes a) where - mock _ = mockArbitrary - -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Post ctypes a) where - mock _ = mockArbitrary - -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Put ctypes a) where +instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) + => HasMock (Verb method status ctypes a) where mock _ = mockArbitrary instance HasMock Raw where diff --git a/servant-server/include/overlapping-compat.h b/servant-server/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-server/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index b572635d..b2b5a8d4 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -23,6 +23,7 @@ build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 extra-source-files: + include/*.h CHANGELOG.md README.md bug-reports: http://github.com/haskell-servant/servant/issues @@ -62,14 +63,15 @@ library , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.5 , transformers-compat>= 0.4 - , wai >= 3.0 && < 3.1 + , wai >= 3.0 && < 3.3 , wai-app-static >= 3.0 && < 3.2 - , warp >= 3.0 && < 3.2 + , warp >= 3.0 && < 3.3 , time >= 1.4 && < 1.6 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable greet main-is: greet.hs @@ -136,3 +138,4 @@ test-suite doctests buildable: True default-language: Haskell2010 ghc-options: -threaded + include-dirs: include diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index bc8b0732..eeef4cd5 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -8,9 +8,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.Server.Internal ( module Servant.Server.Internal @@ -22,26 +21,33 @@ module Servant.Server.Internal #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Except (ExceptT) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.String (fromString) -import Data.String.Conversions (ConvertibleStrings, cs, (<>)) -import Data.Text (Text) +import Control.Monad.Trans.Except (ExceptT) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.String (fromString) +import Data.String.Conversions (cs, (<>)) +import Data.Text (Text) import Data.Typeable -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.HTTP.Types hiding (Header, ResponseHeaders) -import Network.Socket (SockAddr) -import Network.Wai (Application, lazyRequestBody, - rawQueryString, requestHeaders, - requestMethod, responseLBS, remoteHost, - isSecure, vault, httpVersion, Response, - Request, pathInfo) +import GHC.TypeLits (KnownNat, KnownSymbol, natVal, + symbolVal) +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Socket (SockAddr) +import Network.Wai (Application, Request, Response, + httpVersion, isSecure, + lazyRequestBody, pathInfo, + rawQueryString, remoteHost, + requestHeaders, requestMethod, + responseLBS, vault) +import Web.HttpApiData (FromHttpApiData) +import Web.HttpApiData.Internal (parseHeaderMaybe, + parseQueryParamMaybe, + parseUrlPieceMaybe) + import Servant.API ((:<|>) (..), (:>), Capture, - Delete, Get, Header, - IsSecure(..), Patch, Post, Put, + Verb, ReflectMethod(reflectMethod), + IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, Vault) import Servant.API.ContentTypes (AcceptHeader (..), @@ -56,8 +62,6 @@ import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -import Web.HttpApiData (FromHttpApiData) -import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe) class HasServer layout where @@ -132,8 +136,7 @@ allowedMethodHead method request = method == methodGet && requestMethod request allowedMethod :: Method -> Request -> Bool allowedMethod method request = allowedMethodHead method request || requestMethod request == method -processMethodRouter :: forall a. ConvertibleStrings a B.ByteString - => Maybe (a, BL.ByteString) -> Status -> Method +processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method -> Maybe [(HeaderName, B.ByteString)] -> Request -> RouteResult Response processMethodRouter handleA status method headers request = case handleA of @@ -163,7 +166,7 @@ methodRouter method proxy status action = LeafRouter route' | pathIsEmpty request = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH + `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request @@ -179,113 +182,33 @@ methodRouterHeaders method proxy status action = LeafRouter route' | pathIsEmpty request = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH + `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request | otherwise = respond $ Fail err404 -methodRouterEmpty :: Method - -> Delayed (ExceptT ServantErr IO ()) - -> Router -methodRouterEmpty method action = LeafRouter route' - where - route' request respond - | pathIsEmpty request = do - runAction (addMethodCheck action (methodCheck method request)) respond $ \ () -> - Route $! responseLBS noContent204 [] "" - | otherwise = respond $ Fail err404 +instance OVERLAPPABLE_ + ( AllCTRender ctypes a, ReflectMethod method, KnownNat status + ) => HasServer (Verb method status ctypes a) where --- | If you have a 'Delete' endpoint in your API, --- the handler for this endpoint is meant to delete --- a resource. --- --- The code of the handler will, just like --- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and --- 'Servant.API.Put.Put', run in @ExceptT ServantErr IO ()@. --- The 'Int' represents the status code and the 'String' a message --- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to --- painlessly error out if the conditions for a successful deletion --- are not met. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a - ) => HasServer (Delete ctypes a) where + type ServerT (Verb method status ctypes a) m = m a - type ServerT (Delete ctypes a) m = m a + route Proxy = methodRouter method (Proxy :: Proxy ctypes) status + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) - route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 +instance OVERLAPPING_ + ( AllCTRender ctypes a, ReflectMethod method, KnownNat status + , GetHeaders (Headers h a) + ) => HasServer (Verb method status ctypes (Headers h a)) where -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Delete ctypes ()) where + type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) - type ServerT (Delete ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodDelete - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Delete ctypes (Headers h v)) where - - type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 - --- | When implementing the handler for a 'Get' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 200). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where - - type ServerT (Get ctypes a) m = m a - - route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 - --- '()' ==> 204 No Content -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Get ctypes ()) where - - type ServerT (Get ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodGet - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Get ctypes (Headers h v)) where - - type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200 + route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -318,140 +241,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) --- | When implementing the handler for a 'Post' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 201). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a - ) => HasServer (Post ctypes a) where - - type ServerT (Post ctypes a) m = m a - - route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Post ctypes ()) where - - type ServerT (Post ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPost - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Post ctypes (Headers h v)) where - - type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201 - --- | When implementing the handler for a 'Put' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Post.Post', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 200). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a) => HasServer (Put ctypes a) where - - type ServerT (Put ctypes a) m = m a - - route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Put ctypes ()) where - - type ServerT (Put ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPut - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Put ctypes (Headers h v)) where - - type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200 - --- | When implementing the handler for a 'Patch' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we just require that its type has --- a 'ToJSON' instance and servant takes care of encoding it for you, --- yielding status code 200 along the way. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where - - type ServerT (Patch ctypes a) m = m a - - route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Patch ctypes ()) where - - type ServerT (Patch ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPatch - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Patch ctypes (Headers h v)) where - - type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200 - -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. diff --git a/servant-server/test/Doctests.hs b/servant-server/test/Doctests.hs index 572461aa..663f8768 100644 --- a/servant-server/test/Doctests.hs +++ b/servant-server/test/Doctests.hs @@ -10,7 +10,7 @@ main :: IO () main = do files <- find always (extension ==? ".hs") "src" mCabalMacrosFile <- getCabalMacrosFile - doctest $ "-isrc" : + doctest $ "-isrc" : "-Iinclude" : (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++ "-XOverloadedStrings" : "-XFlexibleInstances" : diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 2e93cc2a..500a0069 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -162,7 +162,7 @@ errorRetrySpec = describe "Handler search" it "should continue when URLs don't match" $ do request methodPost "" [jsonCT, jsonAccept] jsonBody - `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) } + `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) } it "should continue when methods don't match" $ do request methodGet "a" [jsonCT, jsonAccept] jsonBody diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 973e1f89..8b450377 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" - post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 } + post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } with (return (serve combinedAPI combinedReaderServer)) $ do it "allows combnation of enters" $ do diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 1ebaadd2..952c8ca8 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -3,8 +3,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,7 +15,7 @@ module Servant.ServerSpec where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad (forM_, when) +import Control.Monad (forM_, when, unless) import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) import Data.ByteString.Conversion () @@ -23,30 +25,37 @@ import Data.String (fromString) import Data.String.Conversions (cs) import qualified Data.Text as T import GHC.Generics (Generic) -import Network.HTTP.Types (hAccept, hContentType, - methodDelete, methodGet, methodHead, - methodPatch, methodPost, methodPut, - ok200, parseQuery, Status(..)) +import Network.HTTP.Types (Status (..), hAccept, hContentType, + methodDelete, methodGet, + methodHead, methodPatch, + methodPost, methodPut, ok200, + parseQuery) import Network.Wai (Application, Request, pathInfo, queryString, rawQueryString, - responseLBS, responseBuilder) -import Network.Wai.Internal (Response(ResponseBuilder)) + responseBuilder, responseLBS) +import Network.Wai.Internal (Response (ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, - runSession, simpleBody) + runSession, simpleBody, + simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), Capture, Delete, - FTime(..), - Get, Header (..), Headers, - HttpVersion, IsSecure (..), JSON, - Patch, PlainText, Post, Put, + Get, FTime(..), Header (..), + Headers, HttpVersion, + IsSecure (..), JSON, + NoContent (..), Patch, PlainText, + Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, - addHeader) -import Servant.Server (Server, serve, ServantErr(..), err404) -import Test.Hspec (Spec, describe, it, shouldBe) + StdMethod (..), Verb, addHeader) +import Servant.Server (ServantErr (..), Server, err404, + serve) +import Test.Hspec (Spec, context, describe, it, + shouldBe, shouldContain) import Test.Hspec.Wai (get, liftIO, matchHeaders, - matchStatus, post, request, + matchStatus, request, shouldRespondWith, with, (<:>)) -import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..)) + +import Servant.Server.Internal.RoutingApplication + (toApplication, RouteResult(..)) import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) @@ -55,55 +64,109 @@ import Data.Time.LocalTime (LocalTime(..), hoursToTimeZone, localTimeToUTC, makeTimeOfDayValid) import Data.Time.Clock (UTCTime) import Data.ByteString.Lazy (ByteString) --- * test data types - -data Person = Person { - name :: String, - age :: Integer - } - deriving (Eq, Show, Generic) - -instance ToJSON Person -instance FromJSON Person - -alice :: Person -alice = Person "Alice" 42 - -data Animal = Animal { - species :: String, - numberOfLegs :: Integer - } - deriving (Eq, Show, Generic) - -instance ToJSON Animal -instance FromJSON Animal - -jerry :: Animal -jerry = Animal "Mouse" 4 - -tweety :: Animal -tweety = Animal "Bird" 2 - - --- * specs +-- *Specs spec :: Spec spec = do + verbSpec captureSpec captureTimeSpec - getSpec - headSpec - postSpec - putSpec - patchSpec queryParamSpec + reqBodySpec headerSpec rawSpec - unionSpec - routerSpec + alternativeSpec responseHeadersSpec - miscReqCombinatorsSpec + routerSpec + miscCombinatorSpec +------------------------------------------------------------------------------ +-- * verbSpec {{{ +------------------------------------------------------------------------------ + +type VerbApi method status + = Verb method status '[JSON] Person + :<|> "noContent" :> Verb method status '[JSON] NoContent + :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) + :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) + +verbSpec :: Spec +verbSpec = describe "Servant.API.Verb" $ do + let server :: Server (VerbApi method status) + server = return alice + :<|> return NoContent + :<|> return (addHeader 5 alice) + :<|> return (addHeader 10 NoContent) + get200 = Proxy :: Proxy (VerbApi 'GET 200) + post210 = Proxy :: Proxy (VerbApi 'POST 210) + put203 = Proxy :: Proxy (VerbApi 'PUT 203) + delete280 = Proxy :: Proxy (VerbApi 'DELETE 280) + patch214 = Proxy :: Proxy (VerbApi 'PATCH 214) + wrongMethod m = if m == methodPatch then methodPost else methodPatch + test desc api method (status :: Int) = context desc $ + + with (return $ serve api server) $ do + + -- HEAD and 214/215 need not return bodies + unless (status `elem` [214, 215] || method == methodHead) $ + it "returns the person" $ do + response <- Test.Hspec.Wai.request method "/" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + + it "returns no content on NoContent" $ do + response <- Test.Hspec.Wai.request method "/noContent" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "" + + -- HEAD should not return body + when (method == methodHead) $ + it "HEAD returns no content body" $ do + response <- Test.Hspec.Wai.request method "/" [] "" + liftIO $ simpleBody response `shouldBe` "" + + it "throws 405 on wrong method " $ do + Test.Hspec.Wai.request (wrongMethod method) "/" [] "" + `shouldRespondWith` 405 + + it "returns headers" $ do + response1 <- Test.Hspec.Wai.request method "/header" [] "" + liftIO $ statusCode (simpleStatus response1) `shouldBe` status + liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")] + + response2 <- Test.Hspec.Wai.request method "/header" [] "" + liftIO $ statusCode (simpleStatus response2) `shouldBe` status + liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")] + + it "handles trailing '/' gracefully" $ do + response <- Test.Hspec.Wai.request method "/headerNC/" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + + it "returns 406 if the Accept header is not supported" $ do + Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" + `shouldRespondWith` 406 + + it "responds if the Accept header is supported" $ do + response <- Test.Hspec.Wai.request method "" + [(hAccept, "application/json")] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + + it "sets the Content-Type header" $ do + response <- Test.Hspec.Wai.request method "" [] "" + liftIO $ simpleHeaders response `shouldContain` + [("Content-Type", "application/json")] + + test "GET 200" get200 methodGet 200 + test "POST 210" post210 methodPost 210 + test "PUT 203" put203 methodPut 203 + test "DELETE 280" delete280 methodDelete 280 + test "PATCH 214" patch214 methodPatch 214 + test "GET 200 with HEAD" get200 methodHead 200 + +-- }}} +------------------------------------------------------------------------------ +-- * captureSpec {{{ +------------------------------------------------------------------------------ type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi @@ -133,6 +196,11 @@ captureSpec = do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) +-- }}} +------------------------------------------------------------------------------ +-- * timeCaptureSpec {{{ +------------------------------------------------------------------------------ + type TimeFormatWSpace = "%Y-%m-%d %H:%M:%S%Z" type CaptureTimeApi = (Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[PlainText] String) @@ -177,64 +245,10 @@ captureTimeSpec = do it "strips the captured path snippet from pathInfo" $ do get "/2015-12-02%2012:34:56+1000/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) - - -type GetApi = Get '[JSON] Person - :<|> "empty" :> Get '[] () - :<|> "post" :> Post '[] () -getApi :: Proxy GetApi -getApi = Proxy - -getSpec :: Spec -getSpec = do - describe "Servant.API.Get" $ do - let server = return alice :<|> return () :<|> return () - with (return $ serve getApi server) $ do - - it "allows to GET a Person" $ do - response <- get "/" - return response `shouldRespondWith` 200 - liftIO $ decode' (simpleBody response) `shouldBe` Just alice - - it "throws 405 (wrong method) on POSTs" $ do - post "/" "" `shouldRespondWith` 405 - post "/empty" "" `shouldRespondWith` 405 - - it "returns 204 if the type is '()'" $ do - get "/empty" `shouldRespondWith` ""{ matchStatus = 204 } - - it "returns 406 if the Accept header is not supported" $ do - Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 406 - - -headSpec :: Spec -headSpec = do - describe "Servant.API.Head" $ do - let server = return alice :<|> return () :<|> return () - with (return $ serve getApi server) $ do - - it "allows to GET a Person" $ do - response <- Test.Hspec.Wai.request methodHead "/" [] "" - return response `shouldRespondWith` 200 - liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person) - - it "does not allow HEAD to POST route" $ do - response <- Test.Hspec.Wai.request methodHead "/post" [] "" - return response `shouldRespondWith` 405 - - it "throws 405 (wrong method) on POSTs" $ do - post "/" "" `shouldRespondWith` 405 - post "/empty" "" `shouldRespondWith` 405 - - it "returns 204 if the type is '()'" $ do - response <- Test.Hspec.Wai.request methodHead "/empty" [] "" - return response `shouldRespondWith` ""{ matchStatus = 204 } - - it "returns 406 if the Accept header is not supported" $ do - Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 406 - +-- }}} +------------------------------------------------------------------------------ +-- * queryParamSpec {{{ +------------------------------------------------------------------------------ type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person @@ -319,131 +333,41 @@ queryParamSpec = do name = "Alice" } -type PostApi = - ReqBody '[JSON] Person :> Post '[JSON] Integer - :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer - :<|> "empty" :> Post '[] () +-- }}} +------------------------------------------------------------------------------ +-- * reqBodySpec {{{ +------------------------------------------------------------------------------ +type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person + :<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer -postApi :: Proxy PostApi -postApi = Proxy +reqBodyApi :: Proxy ReqBodyApi +reqBodyApi = Proxy -postSpec :: Spec -postSpec = do - describe "Servant.API.Post and .ReqBody" $ do - let server = return . age :<|> return . age :<|> return () - with (return $ serve postApi server) $ do - let post' x = Test.Hspec.Wai.request methodPost x [(hContentType - , "application/json;charset=utf-8")] +reqBodySpec :: Spec +reqBodySpec = describe "Servant.API.ReqBody" $ do - it "allows to POST a Person" $ do - post' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 - } + let server :: Server ReqBodyApi + server = return :<|> return . age + mkReq method x = Test.Hspec.Wai.request method x + [(hContentType, "application/json;charset=utf-8")] - it "allows alternative routes if all have request bodies" $ do - post' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 - } + with (return $ serve reqBodyApi server) $ do - it "handles trailing '/' gracefully" $ do - post' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 - } + it "passes the argument to the handler" $ do + response <- mkReq methodPost "" (encode alice) + liftIO $ decode' (simpleBody response) `shouldBe` Just alice - it "correctly rejects invalid request bodies with status 400" $ do - post' "/" "some invalid body" `shouldRespondWith` 400 + it "rejects invalid request bodies with status 400" $ do + mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400 - it "returns 204 if the type is '()'" $ do - post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } + it "responds with 415 if the request body media type is unsupported" $ do + Test.Hspec.Wai.request methodPost "/" + [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415 - it "responds with 415 if the request body media type is unsupported" $ do - let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType - , "application/nonsense")] - post'' "/" "anything at all" `shouldRespondWith` 415 - -type PutApi = - ReqBody '[JSON] Person :> Put '[JSON] Integer - :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer - :<|> "empty" :> Put '[] () - -putApi :: Proxy PutApi -putApi = Proxy - -putSpec :: Spec -putSpec = do - describe "Servant.API.Put and .ReqBody" $ do - let server = return . age :<|> return . age :<|> return () - with (return $ serve putApi server) $ do - let put' x = Test.Hspec.Wai.request methodPut x [(hContentType - , "application/json;charset=utf-8")] - - it "allows to put a Person" $ do - put' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "allows alternative routes if all have request bodies" $ do - put' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "handles trailing '/' gracefully" $ do - put' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "correctly rejects invalid request bodies with status 400" $ do - put' "/" "some invalid body" `shouldRespondWith` 400 - - it "returns 204 if the type is '()'" $ do - put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - - it "responds with 415 if the request body media type is unsupported" $ do - let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType - , "application/nonsense")] - put'' "/" "anything at all" `shouldRespondWith` 415 - -type PatchApi = - ReqBody '[JSON] Person :> Patch '[JSON] Integer - :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer - :<|> "empty" :> Patch '[] () - -patchApi :: Proxy PatchApi -patchApi = Proxy - -patchSpec :: Spec -patchSpec = do - describe "Servant.API.Patch and .ReqBody" $ do - let server = return . age :<|> return . age :<|> return () - with (return $ serve patchApi server) $ do - let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType - , "application/json;charset=utf-8")] - - it "allows to patch a Person" $ do - patch' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "allows alternative routes if all have request bodies" $ do - patch' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "handles trailing '/' gracefully" $ do - patch' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "correctly rejects invalid request bodies with status 400" $ do - patch' "/" "some invalid body" `shouldRespondWith` 400 - - it "returns 204 if the type is '()'" $ do - patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - - it "responds with 415 if the request body media type is unsupported" $ do - let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType - , "application/nonsense")] - patch'' "/" "anything at all" `shouldRespondWith` 415 +-- }}} +------------------------------------------------------------------------------ +-- * headerSpec {{{ +------------------------------------------------------------------------------ type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] () headerApi :: Proxy (HeaderApi a) @@ -461,23 +385,30 @@ headerSpec = describe "Servant.API.Header" $ do expectsString Nothing = error "Expected a string" with (return (serve headerApi expectsInt)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")] + let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ - delete' "/" "" `shouldRespondWith` 204 + delete' "/" "" `shouldRespondWith` 200 with (return (serve headerApi expectsString)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")] + let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ - delete' "/" "" `shouldRespondWith` 204 + delete' "/" "" `shouldRespondWith` 200 +-- }}} +------------------------------------------------------------------------------ +-- * rawSpec {{{ +------------------------------------------------------------------------------ type RawApi = "foo" :> Raw + rawApi :: Proxy RawApi rawApi = Proxy + rawApplication :: Show a => (Request -> a) -> Application -rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_) +rawApplication f request_ respond = respond $ responseLBS ok200 [] + (cs $ show $ f request_) rawSpec :: Spec rawSpec = do @@ -498,7 +429,10 @@ rawSpec = do liftIO $ do simpleBody response `shouldBe` cs (show ["bar" :: String]) - +-- }}} +------------------------------------------------------------------------------ +-- * alternativeSpec {{{ +------------------------------------------------------------------------------ type AlternativeApi = "foo" :> Get '[JSON] Person :<|> "bar" :> Get '[JSON] Animal @@ -506,11 +440,12 @@ type AlternativeApi = :<|> "bar" :> Post '[JSON] Animal :<|> "bar" :> Put '[JSON] Animal :<|> "bar" :> Delete '[JSON] () -unionApi :: Proxy AlternativeApi -unionApi = Proxy -unionServer :: Server AlternativeApi -unionServer = +alternativeApi :: Proxy AlternativeApi +alternativeApi = Proxy + +alternativeServer :: Server AlternativeApi +alternativeServer = return alice :<|> return jerry :<|> return "a string" @@ -518,10 +453,10 @@ unionServer = :<|> return jerry :<|> return () -unionSpec :: Spec -unionSpec = do +alternativeSpec :: Spec +alternativeSpec = do describe "Servant.API.Alternative" $ do - with (return $ serve unionApi unionServer) $ do + with (return $ serve alternativeApi alternativeServer) $ do it "unions endpoints" $ do response <- get "/foo" @@ -538,7 +473,10 @@ unionSpec = do it "returns 404 if the path does not exist" $ do get "/nonexistent" `shouldRespondWith` 404 - +-- }}} +------------------------------------------------------------------------------ +-- * responseHeaderSpec {{{ +------------------------------------------------------------------------------ type ResponseHeadersApi = Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) :<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) @@ -555,26 +493,29 @@ responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do - let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)] + let methods = [methodGet, methodPost, methodPut, methodPatch] it "includes the headers in the response" $ - forM_ methods $ \(method, expected) -> + forM_ methods $ \method -> Test.Hspec.Wai.request method "/" [] "" `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"] - , matchStatus = expected + , matchStatus = 200 } it "responds with not found for non-existent endpoints" $ - forM_ methods $ \(method,_) -> + forM_ methods $ \method -> Test.Hspec.Wai.request method "blahblah" [] "" `shouldRespondWith` 404 it "returns 406 if the Accept header is not supported" $ - forM_ methods $ \(method,_) -> + forM_ methods $ \method -> Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 - +-- }}} +------------------------------------------------------------------------------ +-- * routerSpec {{{ +------------------------------------------------------------------------------ routerSpec :: Spec routerSpec = do describe "Servant.Server.Internal.Router" $ do @@ -593,6 +534,10 @@ routerSpec = do it "calls f on route result" $ do get "" `shouldRespondWith` 202 +-- }}} +------------------------------------------------------------------------------ +-- * miscCombinatorSpec {{{ +------------------------------------------------------------------------------ type MiscCombinatorsAPI = "version" :> HttpVersion :> Get '[JSON] String :<|> "secure" :> IsSecure :> Get '[JSON] String @@ -611,8 +556,8 @@ miscServ = versionHandler secureHandler NotSecure = return "not secure" hostHandler = return . show -miscReqCombinatorsSpec :: Spec -miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $ +miscCombinatorSpec :: Spec +miscCombinatorSpec = with (return $ serve miscApi miscServ) $ describe "Misc. combinators for request inspection" $ do it "Successfully gets the HTTP version specified in the request" $ go "/version" "\"HTTP/1.0\"" @@ -624,3 +569,35 @@ miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $ go "/host" "\"0.0.0.0:0\"" where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res +-- }}} +------------------------------------------------------------------------------ +-- * Test data types {{{ +------------------------------------------------------------------------------ + +data Person = Person { + name :: String, + age :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Person +instance FromJSON Person + +alice :: Person +alice = Person "Alice" 42 + +data Animal = Animal { + species :: String, + numberOfLegs :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Animal +instance FromJSON Animal + +jerry :: Animal +jerry = Animal "Mouse" 4 + +tweety :: Animal +tweety = Animal "Bird" 2 +-- }}} diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index 3630b313..94c63f18 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) -import Servant.API (JSON) -import Servant.API.Alternative ((:<|>) ((:<|>))) -import Servant.API.Capture (Capture) -import Servant.API.Get (Get) -import Servant.API.Raw (Raw) -import Servant.API.Sub ((:>)) +import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) import Servant.Server (Server, serve) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectory) diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index ddbe1a90..7890e0f1 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -7,6 +7,8 @@ HEAD * Use `http-api-data` instead of `Servant.Common.Text` * Remove matrix params. * Add PlainText String MimeRender and MimeUnrender instances. +* Add new `Verbs` combinator, and make all existing and new verb combinators +type synonyms of it. 0.4.2 ----- diff --git a/servant/include/overlapping-compat.h b/servant/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant/servant.cabal b/servant/servant.cabal index 263ac232..3af6680a 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -16,6 +16,7 @@ maintainer: alpmestan@gmail.com copyright: 2014 Zalora South East Asia Pte Ltd category: Web build-type: Simple +extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 source-repository head @@ -28,14 +29,9 @@ library Servant.API.Alternative Servant.API.Capture Servant.API.ContentTypes - Servant.API.Delete - Servant.API.Get Servant.API.Header Servant.API.HttpVersion Servant.API.IsSecure - Servant.API.Patch - Servant.API.Post - Servant.API.Put Servant.API.QueryParam Servant.API.Raw Servant.API.RemoteHost @@ -44,6 +40,7 @@ library Servant.API.Sub Servant.API.Times Servant.API.Vault + Servant.API.Verbs Servant.Utils.Links build-depends: base >=4.7 && <5 @@ -87,6 +84,7 @@ library , TypeSynonymInstances , UndecidableInstances ghc-options: -Wall + include-dirs: include test-suite spec type: exitcode-stdio-1.0 @@ -107,7 +105,6 @@ test-suite spec , hspec == 2.* , QuickCheck , quickcheck-instances - , parsec , servant , string-conversions , text @@ -125,3 +122,4 @@ test-suite doctests buildable: True default-language: Haskell2010 ghc-options: -threaded + include-dirs: include diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 695471b0..f71ebe5c 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -29,16 +29,7 @@ module Servant.API ( -- * Actual endpoints, distinguished by HTTP method - module Servant.API.Get, - -- | @GET@ requests - module Servant.API.Post, - -- | @POST@ requests - module Servant.API.Delete, - -- | @DELETE@ requests - module Servant.API.Put, - -- | @PUT@ requests - module Servant.API.Patch, - -- | @PATCH@ requests + module Servant.API.Verbs, -- * Content Types module Servant.API.ContentTypes, @@ -65,17 +56,12 @@ import Servant.API.Alternative ((:<|>) (..)) import Servant.API.Capture (Capture) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON, - MimeRender (..), + MimeRender (..), NoContent (NoContent), MimeUnrender (..), OctetStream, PlainText, ToFormUrlEncoded (..)) -import Servant.API.Delete (Delete) -import Servant.API.Get (Get) import Servant.API.Header (Header (..)) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) -import Servant.API.Patch (Patch) -import Servant.API.Post (Post) -import Servant.API.Put (Put) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.Raw (Raw) @@ -89,7 +75,25 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), import Servant.API.Sub ((:>)) import Servant.API.Times (FTime(..), toProxy, getFormat, renderTime, parseTime) import Servant.API.Vault (Vault) -import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) +import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted, + DeleteNoContent, + DeleteNonAuthoritative, Get, + GetAccepted, GetNoContent, + GetNonAuthoritative, + GetPartialContent, + GetResetContent, + Patch, + PatchAccepted, PatchNoContent, + PatchNoContent, + PatchNonAuthoritative, Post, + PostAccepted, PostNoContent, + PostNonAuthoritative, + PostResetContent, Put, + PutAccepted, PutNoContent, + PutNoContent, PutNonAuthoritative, + ReflectMethod (reflectMethod), + Verb, StdMethod(..)) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) - +import Web.HttpApiData (FromHttpApiData (..), + ToHttpApiData (..)) diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index ab857ce2..61bf1ce9 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -12,6 +13,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} +#include "overlapping-compat.h" + -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that -- encapsulate how to serialize or deserialize values to or from @@ -19,7 +22,7 @@ -- -- Content-Types are used in `ReqBody` and the method combinators: -- --- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book +-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book -- -- Meaning the endpoint accepts requests of Content-Type @application/json@ -- or @text/plain;charset-utf8@, and returns data in either one of those @@ -53,6 +56,9 @@ module Servant.API.ContentTypes , MimeRender(..) , MimeUnrender(..) + -- * NoContent + , NoContent(..) + -- * Internal , AcceptHeader(..) , AllCTRender(..) @@ -62,7 +68,6 @@ module Servant.API.ContentTypes , AllMimeUnrender(..) , FromFormUrlEncoded(..) , ToFormUrlEncoded(..) - , IsNonEmpty , eitherDecodeLenient , canHandleAcceptH ) where @@ -72,8 +77,7 @@ import Control.Applicative ((*>), (<*)) #endif import Control.Arrow (left) import Control.Monad -import Data.Aeson (FromJSON, ToJSON, encode, - parseJSON) +import Data.Aeson (FromJSON(..), ToJSON(..), encode) import Data.Aeson.Parser (value) import Data.Aeson.Types (parseEither) import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, @@ -91,7 +95,7 @@ import qualified Data.Text.Encoding as TextS import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable -import GHC.Exts (Constraint) +import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Network.URI (escapeURIString, isUnreserved, unEscapeString) @@ -137,7 +141,7 @@ instance Accept OctetStream where contentType _ = "application" M.// "octet-stream" newtype AcceptHeader = AcceptHeader BS.ByteString - deriving (Eq, Show) + deriving (Eq, Show, Read, Typeable, Generic) -- * Render (serializing) @@ -159,19 +163,19 @@ newtype AcceptHeader = AcceptHeader BS.ByteString class Accept ctype => MimeRender ctype a where mimeRender :: Proxy ctype -> a -> ByteString -class (AllMimeRender list a) => AllCTRender (list :: [*]) a where +class (AllMime list) => AllCTRender (list :: [*]) a where -- If the Accept header can be matched, returns (Just) a tuple of the -- Content-Type and response (serialization of @a@ into the appropriate -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where +instance OVERLAPPABLE_ + (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept - where pctyps = Proxy :: Proxy ctyps + where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs - -------------------------------------------------------------------------- -- * Unrender @@ -199,14 +203,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a -class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where +class AllCTUnrender (list :: [*]) a where handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) -instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps - ) => AllCTUnrender ctyps a where +instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body @@ -235,11 +238,12 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where -> a -- value to serialize -> [(M.MediaType, ByteString)] -- content-types/response pairs -instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where +instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)] where pctyp = Proxy :: Proxy ctyp -instance ( MimeRender ctyp a +instance OVERLAPPABLE_ + ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where allMimeRender _ a = (contentType pctyp, mimeRender pctyp a) @@ -248,8 +252,17 @@ instance ( MimeRender ctyp a pctyps = Proxy :: Proxy (ctyp' ': ctyps) -instance AllMimeRender '[] a where - allMimeRender _ _ = [] +-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and +-- then this would be taken care of. However there is no more specific instance +-- between that and 'MimeRender JSON a', so we do this instead +instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where + allMimeRender _ _ = [(contentType pctyp, "")] + where pctyp = Proxy :: Proxy ctyp + +instance OVERLAPPING_ + ( AllMime (ctyp ': ctyp' ': ctyps) + ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where + allMimeRender p _ = zip (allMime p) (repeat "") -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender @@ -270,21 +283,19 @@ instance ( MimeUnrender ctyp a where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps -type family IsNonEmpty (list :: [*]) :: Constraint where - IsNonEmpty (x ': xs) = () - - -------------------------------------------------------------------------- -- * MimeRender Instances -- | `encode` -instance ToJSON a => MimeRender JSON a where +instance OVERLAPPABLE_ + ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) -instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where +instance OVERLAPPABLE_ + ToFormUrlEncoded a => MimeRender FormUrlEncoded a where mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded -- | `TextL.encodeUtf8` @@ -307,6 +318,10 @@ instance MimeRender OctetStream ByteString where instance MimeRender OctetStream BS.ByteString where mimeRender _ = fromStrict +-- | A type for responses without content-body. +data NoContent = NoContent + deriving (Show, Eq, Read) + -------------------------------------------------------------------------- -- * MimeUnrender Instances diff --git a/servant/src/Servant/API/Delete.hs b/servant/src/Servant/API/Delete.hs deleted file mode 100644 index de792a28..00000000 --- a/servant/src/Servant/API/Delete.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Delete (Delete) where - -import Data.Typeable (Typeable) - --- | Combinator for DELETE requests. --- --- Example: --- --- >>> -- DELETE /books/:isbn --- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete '[] () -data Delete (contentTypes :: [*]) a - deriving Typeable - - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Get.hs b/servant/src/Servant/API/Get.hs deleted file mode 100644 index 073bfda6..00000000 --- a/servant/src/Servant/API/Get.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Get (Get) where - -import Data.Typeable (Typeable) - --- | Endpoint for simple GET requests. Serves the result as JSON. --- --- Example: --- --- >>> type MyApi = "books" :> Get '[JSON] [Book] -data Get (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Patch.hs b/servant/src/Servant/API/Patch.hs deleted file mode 100644 index 715cf905..00000000 --- a/servant/src/Servant/API/Patch.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Patch (Patch) where - -import Data.Typeable (Typeable) - --- | Endpoint for PATCH requests. The type variable represents the type of the --- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for --- that). --- --- If the HTTP response is empty, only () is supported. --- --- Example: --- --- >>> -- PATCH /books --- >>> -- with a JSON encoded Book as the request body --- >>> -- returning the just-created Book --- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book -data Patch (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Post.hs b/servant/src/Servant/API/Post.hs deleted file mode 100644 index 72bc59cc..00000000 --- a/servant/src/Servant/API/Post.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Post (Post) where - -import Data.Typeable (Typeable) - --- | Endpoint for POST requests. The type variable represents the type of the --- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for --- that). --- --- Example: --- --- >>> -- POST /books --- >>> -- with a JSON encoded Book as the request body --- >>> -- returning the just-created Book --- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -data Post (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Put.hs b/servant/src/Servant/API/Put.hs deleted file mode 100644 index 0b09d961..00000000 --- a/servant/src/Servant/API/Put.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Put (Put) where - -import Data.Typeable (Typeable) - --- | Endpoint for PUT requests, usually used to update a ressource. --- The type @a@ is the type of the response body that's returned. --- --- Example: --- --- >>> -- PUT /books/:isbn --- >>> -- with a Book as request body, returning the updated Book --- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book -data Put (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 1fcbd035..dc73a8e0 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -12,11 +12,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# OPTIONS_HADDOCK not-home #-} +#include "overlapping-compat.h" -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int @@ -68,19 +66,12 @@ class BuildHeadersTo hs where -- the values are interspersed with commas before deserialization (see -- ) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - BuildHeadersTo '[] where +instance OVERLAPPING_ BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False - ) => BuildHeadersTo ((Header h v) ': xs) where +instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h + , Contains h xs ~ 'False) + => BuildHeadersTo ((Header h v) ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers @@ -96,38 +87,22 @@ instance class GetHeaders ls where getHeaders :: ls -> [HTTP.Header] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetHeaders (HList '[]) where +instance OVERLAPPING_ GetHeaders (HList '[]) where getHeaders _ = [] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) - ) => GetHeaders (HList (Header h x ': xs)) where +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) + => GetHeaders (HList (Header h x ': xs)) where getHeaders hdrs = case hdrs of Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest MissingHeader `HCons` rest -> getHeaders rest where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetHeaders (Headers '[] a) where +instance OVERLAPPING_ GetHeaders (Headers '[] a) where getHeaders _ = [] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, GetHeaders (HList rest), ToByteString v - ) => GetHeaders (Headers (Header h v ': rest) a) where +instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v) + => GetHeaders (Headers (Header h v ': rest) a) where getHeaders hs = getHeaders $ getHeadersHList hs -- * Adding @@ -138,21 +113,13 @@ class AddHeader h v orig new addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False - ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where +instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False) + => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, ToByteString v - , new ~ (Headers '[Header h v] a) - ) => AddHeader h v a new where +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v + , new ~ (Headers '[Header h v] a)) + => AddHeader h v a new where addHeader a resp = Headers resp (HCons (Header a) HNil) type family Contains x xs where diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs new file mode 100644 index 00000000..4915fdaf --- /dev/null +++ b/servant/src/Servant/API/Verbs.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +module Servant.API.Verbs + ( module Servant.API.Verbs + , StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH) + ) where + +import Data.Typeable (Typeable) +import Data.Proxy (Proxy) +import GHC.Generics (Generic) +import GHC.TypeLits (Nat) +import Network.HTTP.Types.Method (Method, StdMethod (..), + methodDelete, methodGet, methodHead, + methodPatch, methodPost, methodPut) + +-- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For +-- convenience, type synonyms for each verb with a 200 response code are +-- provided, but you are free to define your own: +-- +-- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a +data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a + deriving (Typeable, Generic) + +-- * 200 responses +-- +-- The 200 response is the workhorse of web servers, but also fairly generic. +-- When appropriate, you should prefer the more specific success combinators. +-- More information about the definitions of status codes can be found in +-- and +-- ; +-- the relevant information is summarily presented here. + +-- | 'GET' with 200 status code. +type Get contentTypes a = Verb 'GET 200 contentTypes a +-- | 'POST' with 200 status code. +type Post contentTypes a = Verb 'POST 200 contentTypes a +-- | 'PUT' with 200 status code. +type Put contentTypes a = Verb 'PUT 200 contentTypes a +-- | 'DELETE' with 200 status code. +type Delete contentTypes a = Verb 'DELETE 200 contentTypes a +-- | 'PATCH' with 200 status code. +type Patch contentTypes a = Verb 'PATCH 200 contentTypes a + +-- * Other responses + +-- ** 201 Created +-- +-- Indicates that a new resource has been created. The URI corresponding to the +-- resource should be given in the @Location@ header field. +-- +-- If the resource cannot be created immediately, use 'PostAccepted'. +-- +-- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header +-- field. + +-- | 'POST' with 201 status code. +-- +type PostCreated contentTypes a = Verb 'POST 201 contentTypes a + + +-- ** 202 Accepted +-- +-- Indicates that the request has been accepted for processing, but the +-- processing has not yet completed. The status of the processing should be +-- included, as well as either a link to a status monitoring endpoint or an +-- estimate of when the processing will be finished. + +-- | 'GET' with 202 status code. +type GetAccepted contentTypes a = Verb 'GET 202 contentTypes a +-- | 'POST' with 202 status code. +type PostAccepted contentTypes a = Verb 'POST 202 contentTypes a +-- | 'DELETE' with 202 status code. +type DeleteAccepted contentTypes a = Verb 'DELETE 202 contentTypes a +-- | 'PATCH' with 202 status code. +type PatchAccepted contentTypes a = Verb 'PATCH 202 contentTypes a +-- | 'PUT' with 202 status code. +type PutAccepted contentTypes a = Verb 'PUT 202 contentTypes a + + +-- ** 203 Non-Authoritative Information +-- +-- Indicates that the request has been successfully processed, but the +-- information may come from a third-party. + +-- | 'GET' with 203 status code. +type GetNonAuthoritative contentTypes a = Verb 'GET 203 contentTypes a +-- | 'POST' with 203 status code. +type PostNonAuthoritative contentTypes a = Verb 'POST 203 contentTypes a +-- | 'DELETE' with 203 status code. +type DeleteNonAuthoritative contentTypes a = Verb 'DELETE 203 contentTypes a +-- | 'PATCH' with 203 status code. +type PatchNonAuthoritative contentTypes a = Verb 'PATCH 203 contentTypes a +-- | 'PUT' with 203 status code. +type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a + + +-- ** 204 No Content +-- +-- Indicates that no response body is being returned. Handlers for these should +-- return 'NoContent', possibly with headers. +-- +-- If the document view should be reset, use @205 Reset Content@. + +-- | 'GET' with 204 status code. +type GetNoContent contentTypes noContent = Verb 'GET 204 contentTypes noContent +-- | 'POST' with 204 status code. +type PostNoContent contentTypes noContent = Verb 'POST 204 contentTypes noContent +-- | 'DELETE' with 204 status code. +type DeleteNoContent contentTypes noContent = Verb 'DELETE 204 contentTypes noContent +-- | 'PATCH' with 204 status code. +type PatchNoContent contentTypes noContent = Verb 'PATCH 204 contentTypes noContent +-- | 'PUT' with 204 status code. +type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent + + +-- ** 205 Reset Content +-- +-- Indicates that no response body is being returned. Handlers for these should +-- return 'NoContent', possibly with Headers. +-- +-- If the document view should not be reset, use @204 No Content@. + +-- | 'GET' with 205 status code. +type GetResetContent contentTypes noContent = Verb 'GET 205 contentTypes noContent +-- | 'POST' with 205 status code. +type PostResetContent contentTypes noContent = Verb 'POST 205 contentTypes noContent +-- | 'DELETE' with 205 status code. +type DeleteResetContent contentTypes noContent = Verb 'DELETE 205 contentTypes noContent +-- | 'PATCH' with 205 status code. +type PatchResetContent contentTypes noContent = Verb 'PATCH 205 contentTypes noContent +-- | 'PUT' with 205 status code. +type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noContent + + +-- ** 206 Partial Content +-- +-- Indicates that the server is delivering part of the resource due to a range +-- header in the request. +-- +-- For more information, see + +-- | 'GET' with 206 status code. +type GetPartialContent contentTypes noContent = Verb 'GET 206 contentTypes noContent + + +class ReflectMethod a where + reflectMethod :: Proxy a -> Method + +instance ReflectMethod 'GET where + reflectMethod _ = methodGet + +instance ReflectMethod 'POST where + reflectMethod _ = methodPost + +instance ReflectMethod 'PUT where + reflectMethod _ = methodPut + +instance ReflectMethod 'DELETE where + reflectMethod _ = methodDelete + +instance ReflectMethod 'PATCH where + reflectMethod _ = methodPatch + +instance ReflectMethod 'HEAD where + reflectMethod _ = methodHead diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index b83d1178..d83ffc7e 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -74,7 +74,7 @@ -- >>> safeLink api bad_link -- ... -- Could not deduce (Or --- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int)) +-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int)) -- (IsElem' -- ("hello" :> Delete '[JSON] ()) -- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) @@ -103,7 +103,8 @@ module Servant.Utils.Links ( import Data.List import Data.Proxy ( Proxy(..) ) -import Data.Text (Text, unpack) +import qualified Data.Text as Text +import qualified Data.ByteString.Char8 as BSC #if !MIN_VERSION_base(4,8,0) import Data.Monoid ( Monoid(..), (<>) ) #else @@ -118,11 +119,7 @@ import Servant.API.Capture ( Capture ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.Header ( Header ) -import Servant.API.Get ( Get ) -import Servant.API.Post ( Post ) -import Servant.API.Put ( Put ) -import Servant.API.Patch ( Patch ) -import Servant.API.Delete ( Delete ) +import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) import Servant.API.Alternative ( type (:<|>) ) @@ -135,6 +132,10 @@ data Link = Link , _queryParams :: [Param Query] } deriving Show +instance ToHttpApiData Link where + toUrlPiece = Text.pack . show + toHeader = BSC.pack . show + -- | If either a or b produce an empty constraint, produce an empty constraint. type family Or (a :: Constraint) (b :: Constraint) :: Constraint where -- This works because of: @@ -172,28 +173,26 @@ type family IsElem endpoint api :: Constraint where IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb - IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct' - IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct' - IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct' - IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct' - IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct' + IsElem (Verb m s ct typ) (Verb m s ct' typ) + = IsSubList ct ct' IsElem e e = () IsElem e a = IsElem' e a - type family IsSubList a b :: Constraint where IsSubList '[] b = () - IsSubList '[x] (x ': xs) = () - IsSubList '[x] (y ': ys) = IsSubList '[x] ys - IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y + IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y + +type family Elem e es :: Constraint where + Elem x (x ': xs) = () + Elem y (x ': xs) = Elem y xs -- Phantom types for Param data Query -- | Query param data Param a - = SingleParam String Text - | ArrayElemParam String Text + = SingleParam String Text.Text + | ArrayElemParam String Text.Text | FlagParam String deriving Show @@ -217,8 +216,8 @@ linkURI (Link segments q_params) = "?" <> intercalate "&" (fmap makeQuery xs) makeQuery :: Param Query -> String - makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (unpack v) - makeQuery (SingleParam k v) = escape k <> "=" <> escape (unpack v) + makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (Text.unpack v) + makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) makeQuery (FlagParam k) = escape k escape :: String -> String @@ -290,31 +289,15 @@ instance (ToHttpApiData v, HasLink sub) type MkLink (Capture sym v :> sub) = v -> MkLink sub toLink _ l v = toLink (Proxy :: Proxy sub) $ - addSegment (escape . unpack $ toUrlPiece v) l + addSegment (escape . Text.unpack $ toUrlPiece v) l instance HasLink sub => HasLink (Header sym a :> sub) where type MkLink (Header sym a :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) -- Verb (terminal) instances -instance HasLink (Get y r) where - type MkLink (Get y r) = URI - toLink _ = linkURI - -instance HasLink (Post y r) where - type MkLink (Post y r) = URI - toLink _ = linkURI - -instance HasLink (Put y r) where - type MkLink (Put y r) = URI - toLink _ = linkURI - -instance HasLink (Patch y r) where - type MkLink (Patch y r) = URI - toLink _ = linkURI - -instance HasLink (Delete y r) where - type MkLink (Delete y r) = URI +instance HasLink (Verb m s ct a) where + type MkLink (Verb m s ct a) = URI toLink _ = linkURI instance HasLink Raw where diff --git a/servant/test/Doctests.hs b/servant/test/Doctests.hs index 4e528dd5..d9116823 100644 --- a/servant/test/Doctests.hs +++ b/servant/test/Doctests.hs @@ -9,13 +9,14 @@ import Test.DocTest main :: IO () main = do files <- find always (extension ==? ".hs") "src" + tfiles <- find always (extension ==? ".hs") "test/Servant" mCabalMacrosFile <- getCabalMacrosFile - doctest $ "-isrc" : + doctest $ "-isrc" : "-Iinclude" : (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++ "-XOverloadedStrings" : "-XFlexibleInstances" : "-XMultiParamTypeClasses" : - files + (files ++ tfiles) getCabalMacrosFile :: IO (Maybe FilePath) getCabalMacrosFile = do diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index c25cccb9..07e0b068 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} module Servant.Utils.LinksSpec where -import Test.Hspec ( Spec, it, describe, shouldBe, Expectation ) -import Data.Proxy ( Proxy(..) ) +import Data.Proxy (Proxy (..)) +import Test.Hspec (Expectation, Spec, describe, it, + shouldBe) -import Servant.API +import Servant.API type TestApi = -- Capture and query params @@ -24,18 +24,6 @@ type TestApi = :<|> "delete" :> Header "ponies" String :> Delete '[JSON] () :<|> "raw" :> Raw -type TestLink = "hello" :> "hi" :> Get '[JSON] Bool -type TestLink2 = "greet" :> ReqBody '[JSON] [Int] :> Post '[PlainText] Bool -type TestLink3 = "parent" :> "child" :> Get '[JSON] String - -type BadTestLink = "hallo" :> "hi" :> Get '[JSON] Bool -type BadTestLink2 = "greet" :> Get '[PlainText] Bool - -type BadTestLink' = "hello" :> "hi" :> Get '[OctetStream] Bool -type BadTestLink'2 = "greet" :> Get '[OctetStream] Bool - -type NotALink = "hello" :> Capture "x" Bool :> Get '[JSON] Bool -type NotALink2 = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool apiLink :: (IsElem endpoint TestApi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint @@ -49,7 +37,7 @@ shouldBeURI link expected = spec :: Spec spec = describe "Servant.Utils.Links" $ do - it "Generates correct links for capture query params" $ do + it "generates correct links for capture query params" $ do let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] ()) apiLink l1 "hi" `shouldBeURI` "hello/hi" @@ -59,15 +47,55 @@ spec = describe "Servant.Utils.Links" $ do apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true" - it "Generates correct links for query flags" $ do + it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] ()) apiLink l1 True True `shouldBeURI` "balls?bouncy&fast" apiLink l1 False True `shouldBeURI` "balls?fast" - it "Generates correct links for all of the verbs" $ do + it "generates correct links for all of the verbs" $ do apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get" apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put" apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post" apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete" apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw" + + +-- | +-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed, +-- we'll just use doctest +-- +-- >>> apiLink (Proxy :: Proxy WrongPath) +-- ... +-- Could not deduce ... +-- ... +-- +-- >>> apiLink (Proxy :: Proxy WrongReturnType) +-- ... +-- Could not deduce ... +-- ... +-- +-- >>> apiLink (Proxy :: Proxy WrongContentType) +-- ... +-- Could not deduce ... +-- ... +-- +-- >>> apiLink (Proxy :: Proxy WrongMethod) +-- ... +-- Could not deduce ... +-- ... +-- +-- >>> apiLink (Proxy :: Proxy NotALink) +-- ... +-- Could not deduce ... +-- ... +-- +-- sanity check +-- >>> apiLink (Proxy :: Proxy AllGood) +-- get +type WrongPath = "getTypo" :> Get '[JSON] () +type WrongReturnType = "get" :> Get '[JSON] Bool +type WrongContentType = "get" :> Get '[OctetStream] () +type WrongMethod = "get" :> Post '[JSON] () +type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool +type AllGood = "get" :> Get '[JSON] ()