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

Merge branch 'shahn/config' into jkarni/config

Browse source
This commit is contained in:
aaron levin 2016-01-10 12:28:48 +01:00
commit 1146d15f52
15 changed files with 490 additions and 499 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

79
CONTRIBUTING.md Normal file
View file

@ -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.

27
README.md
View file

@ -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`

18
servant-client/src/Servant/Client.hs
View file

@ -28,7 +28,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
@ -134,10 +133,10 @@ instance OVERLAPPABLE_
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts ()) where
type Client (Verb method status cts ()) = ExceptT ServantError IO ()
(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 method req baseurl manager
performRequestNoBody method req baseurl manager >> return NoContent
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
@ -155,13 +154,13 @@ instance OVERLAPPING_
instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls ())) where
type Client (Verb method status cts (Headers ls ()))
= ExceptT ServantError IO (Headers ls ())
) => 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
let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req baseurl manager
return $ Headers { getResponse = ()
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs
}
@ -426,7 +425,6 @@ instance ( HasClient api
clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) =
clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager
{- Note [Non-Empty Content Types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Rather than have
@ -439,6 +437,6 @@ It may seem to make more sense to have:
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 turns generally means adding yet another instance (one
more specific. This in turn generally means adding yet another instance (one
for empty and one for non-empty lists).
-}

2
servant-client/src/Servant/Common/Req.hs
View file

@ -156,7 +156,7 @@ performRequest reqMethod req reqHost manager = do
performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> BaseUrl -> Manager
-> ExceptT ServantError IO ([HTTP.Header], result)
-> ExceptT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req reqHost manager = do
let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <-

14
servant-client/test/Servant/ClientSpec.hs
View file

@ -93,7 +93,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api =
"get" :> Get '[JSON] Person
:<|> "deleteEmpty" :> Delete '[JSON] ()
:<|> "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
@ -108,8 +108,7 @@ 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
@ -117,7 +116,7 @@ api = Proxy
server :: Application
server = serve api EmptyConfig (
return alice
:<|> return ()
:<|> return NoContent
:<|> (\ name -> return $ Person name 0)
:<|> return
:<|> (\ name -> case name of
@ -130,7 +129,7 @@ server = serve api EmptyConfig (
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return ()
:<|> return NoContent
)
@ -201,11 +200,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
@ -362,7 +361,6 @@ data WrappedApi where
, Client api ~ ExceptT ServantError IO ()) =>
Proxy api -> WrappedApi
startWaiApp :: Application -> IO (ThreadId, BaseUrl)
startWaiApp app = do
(port, socket) <- openTestSocket

5
servant-js/src/Servant/JS/Vanilla.hs
View file

@ -38,10 +38,13 @@ generateVanillaJSWith opts req = "\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"

2
servant-server/src/Servant/Server.hs
View file

@ -38,7 +38,7 @@ module Servant.Server
-- * Config
, ConfigEntry(..)
, Config(..)
, (.:)
, (.:.)
-- * General Authentication
, AuthHandler(unAuthHandler)

86
servant-server/src/Servant/Server/Internal.hs
View file

@ -23,59 +23,43 @@ module Servant.Server.Internal
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
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 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.Exts (Constraint)
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 GHC.Exts (Constraint)
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 ((:<|>) (..), (:>),
AuthProtect,
BasicAuth, Capture,
Header,
IsSecure (..),
QueryFlag,
QueryParam,
QueryParams, Raw, ReflectMethod (reflectMethod),
RemoteHost,
ReqBody, Vault,
Verb)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..),
AllMime,
canHandleAcceptH)
import Servant.API.ResponseHeaders (GetHeaders,
Headers,
getHeaders,
getResponse)
import Servant.API ((:<|>) (..), (:>), Capture,
Verb, ReflectMethod(reflectMethod),
IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Vault)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..),
AllMime,
canHandleAcceptH)
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
getResponse)
import Servant.Server.Internal.Auth
import Servant.Server.Internal.Config

46
servant-server/src/Servant/Server/Internal/Config.hs
View file

@ -14,9 +14,9 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
#include "overlapping-compat.h"
module Servant.Server.Internal.Config where
import Control.DeepSeq (NFData(rnf))
@ -29,48 +29,34 @@ newtype ConfigEntry tag a = ConfigEntry { unConfigEntry :: a }
deriving ( Eq, Show, Read, Enum, Integral, Fractional, Generic, Typeable
, Num, Ord, Real, Functor, Foldable, Traversable, NFData)
instance Applicative (ConfigEntry tag) where
pure = ConfigEntry
ConfigEntry f <*> ConfigEntry a = ConfigEntry $ f a
instance Monad (ConfigEntry tag) where
return = ConfigEntry
ConfigEntry a >>= f = f a
-- | The entire configuration.
data Config a where
EmptyConfig :: Config '[]
ConsConfig :: x -> Config xs -> Config (x ': xs)
instance Show (Config '[]) where
show EmptyConfig = "EmptyConfig"
instance (Show a, Show (Config as)) => Show (Config (ConfigEntry tag a ': as)) where
showsPrec outerPrecedence (ConsConfig (ConfigEntry a) as) =
showParen (outerPrecedence > 5) $
shows a . showString " .:. " . shows as
instance Eq (Config '[]) where
_ == _ = True
instance (Eq a, Eq (Config as)) => Eq (Config (a ' : as)) where
instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where
ConsConfig x1 y1 == ConsConfig x2 y2 = x1 == x2 && y1 == y2
instance NFData (Config '[]) where
rnf EmptyConfig = ()
instance (NFData a, NFData (Config as)) => NFData (Config (a ': as)) where
rnf (x `ConsConfig` ys) = rnf x `seq` rnf ys
(.:) :: x -> Config xs -> Config (ConfigEntry tag x ': xs)
e .: cfg = ConsConfig (ConfigEntry e) cfg
infixr 4 .:
(.:.) :: x -> Config xs -> Config (ConfigEntry tag x ': xs)
e .:. cfg = ConsConfig (ConfigEntry e) cfg
infixr 5 .:.
class HasConfigEntry (cfg :: [*]) (a :: k) (val :: *) | cfg a -> val where
getConfigEntry :: proxy a -> Config cfg -> val
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
instance OVERLAPPABLE_
HasConfigEntry xs tag val => HasConfigEntry (notIt ': xs) tag val where
getConfigEntry p (ConsConfig _ xs) = getConfigEntry p xs
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
instance OVERLAPPABLE_
HasConfigEntry (ConfigEntry tag val ': xs) tag val where
getConfigEntry _ (ConsConfig x _) = unConfigEntry x

25
servant-server/test/Servant/Server/Internal/ConfigSpec.hs
View file

@ -3,9 +3,10 @@
module Servant.Server.Internal.ConfigSpec (spec) where
import Data.Proxy (Proxy (..))
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec (Spec, describe, it, shouldBe, pending, context)
import Test.ShouldNotTypecheck (shouldNotTypecheck)
import Servant.API
import Servant.Server.Internal.Config
spec :: Spec
@ -15,8 +16,8 @@ spec = do
getConfigEntrySpec :: Spec
getConfigEntrySpec = describe "getConfigEntry" $ do
let cfg1 = 0 .: EmptyConfig :: Config '[ConfigEntry "a" Int]
cfg2 = 1 .: cfg1 :: Config '[ConfigEntry "a" Int, ConfigEntry "a" Int]
let cfg1 = 0 .:. EmptyConfig :: Config '[ConfigEntry "a" Int]
cfg2 = 1 .:. cfg1 :: Config '[ConfigEntry "a" Int, ConfigEntry "a" Int]
it "gets the config if a matching one exists" $ do
@ -26,12 +27,26 @@ getConfigEntrySpec = describe "getConfigEntry" $ do
getConfigEntry (Proxy :: Proxy "a") cfg2 `shouldBe` 1
it "does not typecheck if key does not exist" $ do
it "allows to distinguish between different config entries with the same type by tag" $ do
let cfg = 'a' .:. 'b' .:. EmptyConfig :: Config '[ConfigEntry 1 Char, ConfigEntry 2 Char]
getConfigEntry (Proxy :: Proxy 1) cfg `shouldBe` 'a'
context "Show instance" $ do
let cfg = 1 .:. 2 .:. EmptyConfig
it "has a Show instance" $ do
show cfg `shouldBe` "1 .:. 2 .:. EmptyConfig"
it "bracketing works" $ do
show (Just cfg) `shouldBe` "Just (1 .:. 2 .:. EmptyConfig)"
it "bracketing works with operators" $ do
let cfg = (1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)
show cfg `shouldBe` "(1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)"
it "does not typecheck if key does not exist" $ do
let x = getConfigEntry (Proxy :: Proxy "b") cfg1 :: Int
shouldNotTypecheck x
it "does not typecheck if key maps to a different type" $ do
let x = getConfigEntry (Proxy :: Proxy "a") cfg1 :: String
shouldNotTypecheck x

551
servant-server/test/Servant/ServerSpec.hs
View file

@ -3,8 +3,10 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
@ -14,129 +16,157 @@ module Servant.ServerSpec where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_, when)
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson (FromJSON, ToJSON,
decode', encode)
import Data.ByteString.Conversion ()
import Data.Char (toUpper)
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Network.HTTP.Types (Status (..),
hAccept,
hContentType,
methodDelete,
methodGet,
methodHead,
methodPatch,
methodPost,
methodPut, ok200,
parseQuery)
import Network.Wai (Application,
Request, pathInfo,
queryString,
rawQueryString,
requestHeaders,
responseBuilder,
responseLBS)
import Network.Wai.Internal (Response (ResponseBuilder))
import Network.Wai.Test (defaultRequest,
request,
runSession,
simpleBody)
import Servant.API ((:<|>) (..), (:>),
AuthProtect,
BasicAuth, Capture,
Delete, Get,
Header (..),
Headers,
HttpVersion,
IsSecure (..),
JSON, Patch,
PlainText, Post,
Put, QueryFlag,
QueryParam,
QueryParams, Raw,
RemoteHost,
ReqBody, addHeader)
import Test.Hspec (Spec, context,
describe, it,
shouldBe)
import Test.Hspec.Wai (get, liftIO,
matchHeaders,
matchStatus, post,
request,
shouldRespondWith,
with, (<:>))
import qualified Test.Hspec.Wai as THW
import Control.Monad (forM_, when, unless)
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson (FromJSON, ToJSON, decode', encode)
import Data.ByteString.Conversion ()
import Data.Char (toUpper)
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Network.HTTP.Types (Status (..), hAccept, hContentType,
methodDelete, methodGet,
methodHead, methodPatch,
methodPost, methodPut, ok200,
parseQuery)
import Network.Wai (Application, Request, pathInfo,
queryString, rawQueryString,
responseBuilder, responseLBS)
import Network.Wai.Internal (Response (ResponseBuilder))
import Network.Wai.Test (defaultRequest, request,
runSession, simpleBody,
simpleHeaders, simpleStatus)
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
Get, Header (..),
Headers, HttpVersion,
IsSecure (..), JSON,
NoContent (..), Patch, PlainText,
Post, Put,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody,
StdMethod (..), Verb, addHeader)
import Servant.Server ((.:.), AuthHandler, AuthReturnType,
BasicAuthCheck (BasicAuthCheck),
BasicAuthResult (Authorized, Unauthorized),
Config (EmptyConfig), ServantErr (..),
Server, err404, serve)
import Test.Hspec (Spec, context, describe, it,
shouldBe, shouldContain)
import Test.Hspec.Wai (get, liftIO, matchHeaders,
matchStatus, request,
shouldRespondWith, with, (<:>))
import Servant.Server (AuthHandler,
AuthReturnType, BasicAuthCheck (BasicAuthCheck), BasicAuthResult (Authorized, Unauthorized), Config (EmptyConfig),
ConfigEntry,
ServantErr (..),
Server, err401,
err404,
mkAuthHandler,
serve, (.:))
import Servant.Server.Internal.Router (Router, Router' (LeafRouter),
runRouter,
tweakResponse)
import Servant.Server.Internal.RoutingApplication (RouteResult (..),
toApplication)
import Servant.Server.Internal.RoutingApplication
(toApplication, RouteResult(..))
import Servant.Server.Internal.Router
(tweakResponse, runRouter,
Router, Router'(LeafRouter))
-- * 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
getSpec
headSpec
postSpec
putSpec
patchSpec
queryParamSpec
reqBodySpec
headerSpec
rawSpec
unionSpec
routerSpec
alternativeSpec
responseHeadersSpec
miscReqCombinatorsSpec
routerSpec
miscCombinatorSpec
authSpec
------------------------------------------------------------------------------
-- * 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 EmptyConfig 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
@ -167,68 +197,10 @@ captureSpec = do
it "strips the captured path snippet from pathInfo" $ do
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
type GetApi = Get '[JSON] Person
:<|> "empty" :> Get '[JSON] ()
:<|> "emptyWithHeaders" :> Get '[JSON] (Headers '[Header "H" Int] ())
:<|> "post" :> Post '[JSON] ()
getApi :: Proxy GetApi
getApi = Proxy
getSpec :: Spec
getSpec = do
describe "Servant.API.Get" $ do
let server = return alice
:<|> return ()
:<|> return (addHeader 5 ())
:<|> return ()
with (return $ serve getApi EmptyConfig 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 headers" $ do
get "/emptyWithHeaders" `shouldRespondWith` 200 { matchHeaders = [ "H" <:> "5" ] }
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 (addHeader 5 ())
:<|> return ()
with (return $ serve getApi EmptyConfig 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 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
@ -313,122 +285,41 @@ queryParamSpec = do
name = "Alice"
}
type PostApi =
ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "empty" :> Post '[JSON] ()
-- }}}
------------------------------------------------------------------------------
-- * 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 EmptyConfig 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 = 200
}
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 = 200
}
with (return $ serve reqBodyApi EmptyConfig server) $ do
it "handles trailing '/' gracefully" $ do
post' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
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 "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
it "responds with 415 if the request body media type is unsupported" $ do
Test.Hspec.Wai.request methodPost "/"
[(hContentType, "application/nonsense")] "" `shouldRespondWith` 415
type PutApi =
ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "empty" :> Put '[JSON] ()
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 EmptyConfig 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 "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 '[JSON] ()
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 EmptyConfig 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 "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)
@ -457,12 +348,19 @@ headerSpec = describe "Servant.API.Header" $ do
it "passes the header to the handler (String)" $
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
@ -483,7 +381,10 @@ rawSpec = do
liftIO $ do
simpleBody response `shouldBe` cs (show ["bar" :: String])
-- }}}
------------------------------------------------------------------------------
-- * alternativeSpec {{{
------------------------------------------------------------------------------
type AlternativeApi =
"foo" :> Get '[JSON] Person
:<|> "bar" :> Get '[JSON] Animal
@ -491,11 +392,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"
@ -503,10 +405,10 @@ unionServer =
:<|> return jerry
:<|> return ()
unionSpec :: Spec
unionSpec = do
alternativeSpec :: Spec
alternativeSpec = do
describe "Servant.API.Alternative" $ do
with (return $ serve unionApi EmptyConfig unionServer) $ do
with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do
it "unions endpoints" $ do
response <- get "/foo"
@ -523,7 +425,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)
@ -540,26 +445,29 @@ responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do
let methods = [(methodGet, 200), (methodPost, 200), (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
@ -578,6 +486,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
@ -596,8 +508,8 @@ miscServ = versionHandler
secureHandler NotSecure = return "not secure"
hostHandler = return . show
miscReqCombinatorsSpec :: Spec
miscReqCombinatorsSpec = with (return $ serve miscApi EmptyConfig miscServ) $
miscCombinatorSpec :: Spec
miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $
describe "Misc. combinators for request inspection" $ do
it "Successfully gets the HTTP version specified in the request" $
go "/version" "\"HTTP/1.0\""
@ -610,7 +522,10 @@ miscReqCombinatorsSpec = with (return $ serve miscApi EmptyConfig miscServ) $
where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res
-- }}}
------------------------------------------------------------------------------
-- * authspec {{{
------------------------------------------------------------------------------
type AuthAPI = BasicAuth "basic" "foo" () :> "basic" :> Get '[JSON] Animal
:<|> AuthProtect "auth" :> "auth" :> Get '[JSON] Animal
authApi :: Proxy AuthAPI
@ -634,7 +549,7 @@ authConfig =
then return ()
else throwE err401
)
in basicHandler .: mkAuthHandler authHandler .: EmptyConfig
in basicHandler .:. mkAuthHandler authHandler .:. EmptyConfig
authSpec :: Spec
authSpec = do
@ -652,3 +567,37 @@ authSpec = do
get "/auth" `shouldRespondWith` 401
it "returns 200 with the right header" $ do
THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200
-- }}}
------------------------------------------------------------------------------
-- * 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
-- }}}
>>>>>>> shahn/config

21
servant/src/Servant/API.hs
View file

@ -56,7 +56,7 @@ import Servant.API.Auth (BasicAuth, AuthProtect)
import Servant.API.Capture (Capture)
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON,
MimeRender (..),
MimeRender (..), NoContent (NoContent),
MimeUnrender (..), OctetStream,
PlainText, ToFormUrlEncoded (..))
import Servant.API.Header (Header (..))
@ -74,9 +74,24 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader),
getHeadersHList, getResponse)
import Servant.API.Sub ((:>))
import Servant.API.Vault (Vault)
import Servant.API.Verbs (Delete, Get, Patch, Post, Put,
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)
Verb, StdMethod(..))
import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
URI (..), safeLink)
import Web.HttpApiData (FromHttpApiData (..),

63
servant/src/Servant/API/ContentTypes.hs
View file

@ -16,6 +16,8 @@
#endif
{-# 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
@ -57,6 +59,9 @@ module Servant.API.ContentTypes
, MimeRender(..)
, MimeUnrender(..)
-- * NoContent
, NoContent(..)
-- * Internal
, AcceptHeader(..)
, AllCTRender(..)
@ -75,8 +80,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,
@ -168,10 +172,7 @@ class (AllMime list) => AllCTRender (list :: [*]) a where
-- mimetype).
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
instance OVERLAPPABLE_
(AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy (ct ': cts)
@ -240,11 +241,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)
@ -252,6 +254,18 @@ instance ( MimeRender ctyp a
where pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy (ctyp' ': ctyps)
-- 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
--------------------------------------------------------------------------
@ -275,20 +289,14 @@ instance ( MimeUnrender ctyp a
-- * MimeRender Instances
-- | `encode`
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
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
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
instance OVERLAPPABLE_
ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
@ -312,26 +320,9 @@ instance MimeRender OctetStream ByteString where
instance MimeRender OctetStream BS.ByteString where
mimeRender _ = fromStrict
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender JSON () where
mimeRender _ _ = ""
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender PlainText () where
mimeRender _ _ = ""
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender OctetStream () where
mimeRender _ _ = ""
-- | A type for responses without content-body.
data NoContent = NoContent
deriving (Show, Eq, Read)
--------------------------------------------------------------------------
-- * MimeUnrender Instances

46
servant/src/Servant/API/Verbs.hs
View file

@ -3,16 +3,20 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
module Servant.API.Verbs where
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/methods. For
-- | @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:
--
@ -54,8 +58,7 @@ type Patch contentTypes a = Verb 'PATCH 200 contentTypes a
-- | 'POST' with 201 status code.
--
type Created contentTypes a = Verb 'POST 201 contentTypes a
type PostCreated contentTypes a = Verb 'POST 201 contentTypes a
-- ** 202 Accepted
--
@ -95,40 +98,39 @@ type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a
-- ** 204 No Content
--
-- Indicates that no response body is being returned. Handlers for these must
-- return 'NoContent'.
-- 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 = Verb 'GET 204 contentTypes NoContent
type GetNoContent contentTypes noContent = Verb 'GET 204 contentTypes noContent
-- | 'POST' with 204 status code.
type PostNoContent contentTypes = Verb 'POST 204 contentTypes NoContent
type PostNoContent contentTypes noContent = Verb 'POST 204 contentTypes noContent
-- | 'DELETE' with 204 status code.
type DeleteNoContent contentTypes = Verb 'DELETE 204 contentTypes NoContent
type DeleteNoContent contentTypes noContent = Verb 'DELETE 204 contentTypes noContent
-- | 'PATCH' with 204 status code.
type PatchNoContent contentTypes = Verb 'PATCH 204 contentTypes NoContent
type PatchNoContent contentTypes noContent = Verb 'PATCH 204 contentTypes noContent
-- | 'PUT' with 204 status code.
type PutNoContent contentTypes = Verb 'PUT 204 contentTypes NoContent
type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent
-- ** 205 Reset Content
--
-- Indicates that no response body is being returned. Handlers for these must
-- return 'NoContent'.
-- 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 = Verb 'GET 205 contentTypes NoContent
type GetResetContent contentTypes noContent = Verb 'GET 205 contentTypes noContent
-- | 'POST' with 205 status code.
type PostResetContent contentTypes = Verb 'POST 205 contentTypes NoContent
type PostResetContent contentTypes noContent = Verb 'POST 205 contentTypes noContent
-- | 'DELETE' with 205 status code.
type DeleteResetContent contentTypes = Verb 'DELETE 205 contentTypes NoContent
type DeleteResetContent contentTypes noContent = Verb 'DELETE 205 contentTypes noContent
-- | 'PATCH' with 205 status code.
type PatchResetContent contentTypes = Verb 'PATCH 205 contentTypes NoContent
type PatchResetContent contentTypes noContent = Verb 'PATCH 205 contentTypes noContent
-- | 'PUT' with 205 status code.
type PutResetContent contentTypes = Verb 'PUT 205 contentTypes NoContent
type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noContent
-- ** 206 Partial Content
@ -140,12 +142,10 @@ type PutResetContent contentTypes = Verb 'PUT 205 contentTypes NoContent
-- RFC7233 Section 4.1>
-- | 'GET' with 206 status code.
type GetPartialContent contentTypes = Verb 'GET 205 contentTypes NoContent
data NoContent = NoContent
type GetPartialContent contentTypes noContent = Verb 'GET 206 contentTypes noContent
class ReflectMethod a where
reflectMethod :: proxy a -> Method
reflectMethod :: Proxy a -> Method
instance ReflectMethod 'GET where
reflectMethod _ = methodGet

4
servant/src/Servant/Utils/Links.hs
View file

@ -74,9 +74,7 @@
-- >>> safeLink api bad_link
-- ...
-- Could not deduce (Or
-- (IsElem'
-- (Verb 'Network.HTTP.Types.Method.DELETE 200 '[JSON] ())
-- (Verb 'Network.HTTP.Types.Method.GET 200 '[JSON] Int))
-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int))
-- (IsElem'
-- ("hello" :> Delete '[JSON] ())
-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))