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

Merge pull request #57 from haskell-servant/jkarni/pre-0.3

Browse Source 
Last tasks for 0.3
This commit is contained in:
Julian Arni 2015-05-04 17:53:29 +02:00
commit a058cd4bf4
54 changed files with 1319 additions and 317 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -21,3 +21,4 @@ cabal.config
*.prof *.prof
*.aux *.aux
*.hp *.hp
Setup

4
scripts/shell.nix
View File

@ -13,10 +13,8 @@ let modifiedHaskellPackages = haskellngPackages.override {
../servant-jquery {}) "--ghc-options=-Werror"; ../servant-jquery {}) "--ghc-options=-Werror";
servant-docs = appendConfigureFlag (self.callPackage ../servant-docs servant-docs = appendConfigureFlag (self.callPackage ../servant-docs
{}) "--ghc-options=-Werror"; {}) "--ghc-options=-Werror";
servant-examples = appendConfigureFlag (self.callPackage ../servant-examples
{}) "--ghc-options=-Werror";
}; };
}; };
in modifiedHaskellPackages.ghcWithPackages ( p : with p ; [ in modifiedHaskellPackages.ghcWithPackages ( p : with p ; [
servant servant-server servant-client servant-jquery servant-docs servant-examples servant servant-server servant-client servant-jquery servant-docs
]) ])

30
scripts/start-sandbox.sh Executable file
View File

@ -0,0 +1,30 @@
#!/bin/bash -
#===============================================================================
#
# FILE: start-sandbox.sh
#
# USAGE: ./start-sandbox.sh
#
# DESCRIPTION: Create sandbox at top-level and add all packages as add-source
#
# REQUIREMENTS: bash >= 4
#===============================================================================
set -o nounset
set -o errexit
DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
SOURCES_TXT="$( dirname $DIR)/sources.txt"
CABAL=${CABAL:-cabal}
declare -a SOURCES
readarray -t SOURCES < "$SOURCES_TXT"
prepare_sandbox () {
$CABAL sandbox init
for s in ${SOURCES[@]} ; do
(cd "$s" && $CABAL sandbox init --sandbox=../.cabal-sandbox && $CABAL sandbox add-source .)
done
}
prepare_sandbox

30
servant-blaze/LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright (c) 2015, Julian K. Arni
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Julian K. Arni nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
servant-blaze/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

28
servant-blaze/servant-blaze.cabal Normal file
View File

@ -0,0 +1,28 @@
-- Initial servant-blaze.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: servant-blaze
version: 0.1.0.0
synopsis: Blaze-html support for servant
-- description:
homepage: http://haskell-servant.github.io/
license: BSD3
license-file: LICENSE
author: Julian K. Arni
maintainer: jkarni@gmail.com
-- copyright:
category: Web
build-type: Simple
-- extra-source-files:
cabal-version: >=1.10
library
exposed-modules: Servant.HTML.Blaze
-- other-modules:
-- other-extensions:
build-depends: base >=4.7 && <5
, servant
, http-media
, blaze-html
hs-source-dirs: src
default-language: Haskell2010

45
servant-blaze/src/Servant/HTML/Blaze.hs Normal file
View File

@ -0,0 +1,45 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
-- | 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
-- `HTML` datatype.:
--
-- >>> type Eg = Get '[HTML] a
--
-- Will then check that @a@ has a `ToMarkup` instance, or is `Html`.
module Servant.HTML.Blaze where
import Data.Typeable (Typeable)
import qualified Network.HTTP.Media as M
import Servant.API (Accept (..), MimeRender (..))
import Text.Blaze.Html (Html, ToMarkup, toHtml)
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
data HTML deriving Typeable
-- | @text/plain;charset=utf-8@
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
mimeRender _ = renderHtml . toHtml
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender HTML Html where
mimeRender _ = renderHtml

2
servant-client/CHANGELOG.md
View File

@ -7,7 +7,7 @@
* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example) * Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
* Support for PATCH * Support for PATCH
* Make () instances expect No Content status code, and not try to decode body. * Make () instances expect No Content status code, and not try to decode body.
* `Canonicalize` API types before generating client functions for them * Add support for response headers
0.2.2 0.2.2
----- -----

147
servant-client/src/Servant/Client.hs
View File

@ -16,11 +16,13 @@
module Servant.Client module Servant.Client
( client ( client
, HasClient(..) , HasClient(..)
, Client
, ServantError(..) , ServantError(..)
, module Servant.Common.BaseUrl , module Servant.Common.BaseUrl
) where ) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad import Control.Monad
import Control.Monad.Trans.Either import Control.Monad.Trans.Either
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
@ -32,8 +34,8 @@ import GHC.TypeLits
import Network.HTTP.Client (Response) import Network.HTTP.Client (Response)
import Network.HTTP.Media import Network.HTTP.Media
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
import Servant.API import Servant.API
import Servant.API.ContentTypes
import Servant.Common.BaseUrl import Servant.Common.BaseUrl
import Servant.Common.Req import Servant.Common.Req
@ -50,17 +52,16 @@ import Servant.Common.Req
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book] -- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi -- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout client :: HasClient layout => Proxy layout -> Client layout
client p = clientWithRoute (canonicalize p) defReq client p = clientWithRoute p defReq
-- | This class lets us define how each API combinator -- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly -- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'. -- an internal class, you can just use 'client'.
class HasClient layout where class HasClient layout where
type Client' layout :: * type Client layout :: *
clientWithRoute :: Proxy layout -> Req -> Client' layout clientWithRoute :: Proxy layout -> Req -> Client layout
type Client layout = Client' (Canonicalize layout)
-- | A client querying function for @a ':<|>' b@ will actually hand you -- | A client querying function for @a ':<|>' b@ will actually hand you
-- one function for querying @a@ and another one for querying @b@, -- one function for querying @a@ and another one for querying @b@,
@ -76,7 +77,7 @@ type Client layout = Client' (Canonicalize layout)
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi -- > (getAllBooks :<|> postNewBook) = client myApi
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client' (a :<|> b) = Client' a :<|> Client' b type Client (a :<|> b) = Client a :<|> Client b
clientWithRoute Proxy req = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy a) req :<|> clientWithRoute (Proxy :: Proxy a) req :<|>
clientWithRoute (Proxy :: Proxy b) req clientWithRoute (Proxy :: Proxy b) req
@ -103,8 +104,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
instance (KnownSymbol capture, ToText a, HasClient sublayout) instance (KnownSymbol capture, ToText a, HasClient sublayout)
=> HasClient (Capture capture a :> sublayout) where => HasClient (Capture capture a :> sublayout) where
type Client' (Capture capture a :> sublayout) = type Client (Capture capture a :> sublayout) =
a -> Client' sublayout a -> Client sublayout
clientWithRoute Proxy req val = clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout) $
@ -117,7 +118,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
-- and port to send the request to. -- and port to send the request to.
instance HasClient Delete where instance HasClient Delete where
type Client' Delete = BaseUrl -> EitherT ServantError IO () type Client Delete = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
@ -131,21 +132,36 @@ instance
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP status.
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Get (ct ': cts) ()) where HasClient (Get (ct ': cts) ()) where
type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
performRequestNoBody H.methodGet req [204] host performRequestNoBody H.methodGet req [204] host
-- | 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)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] host
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
-- | If you use a 'Header' in one of your endpoints in your API, -- | If you use a 'Header' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'Header', -- an additional argument of the type specified by your 'Header',
@ -174,8 +190,8 @@ instance
instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (Header sym a :> sublayout) where => HasClient (Header sym a :> sublayout) where
type Client' (Header sym a :> sublayout) = type Client (Header sym a :> sublayout) =
Maybe a -> Client' sublayout Maybe a -> Client sublayout
clientWithRoute Proxy req mval = clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout) $
@ -192,10 +208,10 @@ instance
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req uri = clientWithRoute Proxy req uri =
performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -204,10 +220,25 @@ instance
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Post (ct ': cts) ()) where HasClient (Post (ct ': cts) ()) where
type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPost req [204] host void $ performRequestNoBody H.methodPost req [204] host
-- | 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)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] host
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
-- | If you have a 'Put' endpoint in your API, the client -- | If you have a 'Put' endpoint in your API, the client
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
@ -217,10 +248,10 @@ instance
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -229,10 +260,25 @@ instance
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Put (ct ': cts) ()) where HasClient (Put (ct ': cts) ()) where
type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPut req [204] host void $ performRequestNoBody H.methodPut req [204] host
-- | 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)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] host
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
-- | If you have a 'Patch' endpoint in your API, the client -- | If you have a 'Patch' endpoint in your API, the client
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
@ -242,10 +288,10 @@ instance
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -254,10 +300,25 @@ instance
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Patch (ct ': cts) ()) where HasClient (Patch (ct ': cts) ()) where
type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPatch req [204] host void $ performRequestNoBody H.methodPatch req [204] host
-- | 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)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] host
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
-- | If you use a 'QueryParam' in one of your endpoints in your API, -- | If you use a 'QueryParam' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'QueryParam', -- an additional argument of the type specified by your 'QueryParam',
@ -286,8 +347,8 @@ instance
instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParam sym a :> sublayout) where => HasClient (QueryParam sym a :> sublayout) where
type Client' (QueryParam sym a :> sublayout) = type Client (QueryParam sym a :> sublayout) =
Maybe a -> Client' sublayout Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string -- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam = clientWithRoute Proxy req mparam =
@ -328,8 +389,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParams sym a :> sublayout) where => HasClient (QueryParams sym a :> sublayout) where
type Client' (QueryParams sym a :> sublayout) = type Client (QueryParams sym a :> sublayout) =
[a] -> Client' sublayout [a] -> Client sublayout
clientWithRoute Proxy req paramlist = clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout) $
@ -363,8 +424,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, HasClient sublayout) instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (QueryFlag sym :> sublayout) where => HasClient (QueryFlag sym :> sublayout) where
type Client' (QueryFlag sym :> sublayout) = type Client (QueryFlag sym :> sublayout) =
Bool -> Client' sublayout Bool -> Client sublayout
clientWithRoute Proxy req flag = clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout) $
@ -402,8 +463,8 @@ instance (KnownSymbol sym, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (MatrixParam sym a :> sublayout) where => HasClient (MatrixParam sym a :> sublayout) where
type Client' (MatrixParam sym a :> sublayout) = type Client (MatrixParam sym a :> sublayout) =
Maybe a -> Client' sublayout Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string -- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam = clientWithRoute Proxy req mparam =
@ -443,8 +504,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout) instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (MatrixParams sym a :> sublayout) where => HasClient (MatrixParams sym a :> sublayout) where
type Client' (MatrixParams sym a :> sublayout) = type Client (MatrixParams sym a :> sublayout) =
[a] -> Client' sublayout [a] -> Client sublayout
clientWithRoute Proxy req paramlist = clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout) $
@ -478,8 +539,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, HasClient sublayout) instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (MatrixFlag sym :> sublayout) where => HasClient (MatrixFlag sym :> sublayout) where
type Client' (MatrixFlag sym :> sublayout) = type Client (MatrixFlag sym :> sublayout) =
Bool -> Client' sublayout Bool -> Client sublayout
clientWithRoute Proxy req flag = clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout) $
@ -492,9 +553,9 @@ instance (KnownSymbol sym, HasClient sublayout)
-- | Pick a 'Method' and specify where the server you want to query is. You get -- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`. -- back the full `Response`.
instance HasClient Raw where instance HasClient Raw where
type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString) type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client' Raw clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod host = do clientWithRoute Proxy req httpMethod host = do
performRequest httpMethod req (const True) host performRequest httpMethod req (const True) host
@ -519,8 +580,8 @@ instance HasClient Raw where
instance (MimeRender ct a, HasClient sublayout) instance (MimeRender ct a, HasClient sublayout)
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where => HasClient (ReqBody (ct ': cts) a :> sublayout) where
type Client' (ReqBody (ct ': cts) a :> sublayout) = type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client' sublayout a -> Client sublayout
clientWithRoute Proxy req body = clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) $ do clientWithRoute (Proxy :: Proxy sublayout) $ do
@ -529,7 +590,7 @@ instance (MimeRender ct a, HasClient sublayout)
-- | Make the querying function append @path@ to the request path. -- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
type Client' (path :> sublayout) = Client' sublayout type Client (path :> sublayout) = Client sublayout
clientWithRoute Proxy req = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout) $

23
servant-client/src/Servant/Common/Req.hs
View File

@ -22,6 +22,7 @@ import Network.HTTP.Client hiding (Proxy)
import Network.HTTP.Client.TLS import Network.HTTP.Client.TLS
import Network.HTTP.Media import Network.HTTP.Media
import Network.HTTP.Types import Network.HTTP.Types
import qualified Network.HTTP.Types.Header as HTTP
import Network.URI import Network.URI
import Servant.API.ContentTypes import Servant.API.ContentTypes
import Servant.Common.BaseUrl import Servant.Common.BaseUrl
@ -136,7 +137,9 @@ displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString) performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl
-> EitherT ServantError IO ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString)
performRequest reqMethod req isWantedStatus reqHost = do performRequest reqMethod req isWantedStatus reqHost = do
partialRequest <- liftIO $ reqToRequest req reqHost partialRequest <- liftIO $ reqToRequest req reqHost
@ -154,6 +157,7 @@ performRequest reqMethod req isWantedStatus reqHost = do
Right response -> do Right response -> do
let status = Client.responseStatus response let status = Client.responseStatus response
body = Client.responseBody response body = Client.responseBody response
hrds = Client.responseHeaders response
status_code = statusCode status status_code = statusCode status
ct <- case lookup "Content-Type" $ Client.responseHeaders response of ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream" Nothing -> pure $ "application"//"octet-stream"
@ -162,20 +166,19 @@ performRequest reqMethod req isWantedStatus reqHost = do
Just t' -> pure t' Just t' -> pure t'
unless (isWantedStatus status_code) $ unless (isWantedStatus status_code) $
left $ FailureResponse status ct body left $ FailureResponse status ct body
return (status_code, body, ct, response) return (status_code, body, ct, hrds, response)
performRequestCT :: MimeUnrender ct result => performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO result Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req wantedStatus reqHost = do performRequestCT ct reqMethod req wantedStatus reqHost = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, _response) <- (_status, respBody, respCT, hrds, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
unless (matches respCT (acceptCT)) $ unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody
left $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of
either Left err -> left $ DecodeFailure err respCT respBody
(left . (\s -> DecodeFailure s respCT respBody)) Right val -> return (hrds, val)
return
(mimeUnrender ct respBody)
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO () performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
performRequestNoBody reqMethod req wantedStatus reqHost = do performRequestNoBody reqMethod req wantedStatus reqHost = do

45
servant-client/test/Servant/ClientSpec.hs
View File

@ -7,7 +7,7 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fcontext-stack=25 #-} {-# OPTIONS_GHC -fcontext-stack=100 #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.ClientSpec where module Servant.ClientSpec where
@ -28,7 +28,8 @@ import qualified Data.Text as T
import GHC.Generics import GHC.Generics
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
import Network.HTTP.Media import Network.HTTP.Media
import Network.HTTP.Types import Network.HTTP.Types hiding (Header)
import qualified Network.HTTP.Types as HTTP
import Network.Socket import Network.Socket
import Network.Wai hiding (Response) import Network.Wai hiding (Response)
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
@ -74,6 +75,8 @@ instance Eq C.HttpException where
alice :: Person alice :: Person
alice = Person "Alice" 42 alice = Person "Alice" 42
type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api = type Api =
"get" :> Get '[JSON] Person "get" :> Get '[JSON] Person
:<|> "delete" :> Delete :<|> "delete" :> Delete
@ -93,6 +96,7 @@ type Api =
QueryFlag "third" :> QueryFlag "third" :>
ReqBody '[JSON] [(String, [Rational])] :> ReqBody '[JSON] [(String, [Rational])] :>
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
@ -104,19 +108,20 @@ server = serve api (
:<|> return :<|> return
:<|> (\ name -> case name of :<|> (\ name -> case name of
Just "alice" -> return alice Just "alice" -> return alice
Just name -> left (400, name ++ " not found") Just name -> left $ ServantErr 400 (name ++ " not found") "" []
Nothing -> left (400, "missing parameter")) Nothing -> left $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
:<|> return :<|> return
:<|> (\ name -> case name of :<|> (\ name -> case name of
Just "alice" -> return alice Just "alice" -> return alice
Just name -> left (400, name ++ " not found") Just name -> left $ ServantErr 400 (name ++ " not found") "" []
Nothing -> left (400, "missing parameter")) Nothing -> left $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
:<|> return :<|> return
:<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> \ a b c d -> return (a, b, c, d) :<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
) )
withServer :: (BaseUrl -> IO a) -> IO a withServer :: (BaseUrl -> IO a) -> IO a
@ -132,11 +137,14 @@ getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person] getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString) getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString) MediaType, [HTTP.Header], C.Response ByteString)
getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
MediaType, [HTTP.Header], C.Response ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> BaseUrl -> BaseUrl
-> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])]) -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)
( getGet ( getGet
:<|> getDelete :<|> getDelete
:<|> getCapture :<|> getCapture
@ -149,7 +157,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
:<|> getMatrixFlag :<|> getMatrixFlag
:<|> getRawSuccess :<|> getRawSuccess
:<|> getRawFailure :<|> getRawFailure
:<|> getMultiple) :<|> getMultiple
:<|> getRespHeaders)
= client api = client api
type FailApi = type FailApi =
@ -218,7 +227,7 @@ spec = do
res <- runEitherT (getRawSuccess methodGet host) res <- runEitherT (getRawSuccess methodGet host)
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (code, body, ct, response) -> do Right (code, body, ct, _, response) -> do
(code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
C.responseBody response `shouldBe` body C.responseBody response `shouldBe` body
C.responseStatus response `shouldBe` ok200 C.responseStatus response `shouldBe` ok200
@ -227,11 +236,17 @@ spec = do
res <- runEitherT (getRawFailure methodGet host) res <- runEitherT (getRawFailure methodGet host)
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (code, body, ct, response) -> do Right (code, body, ct, _, response) -> do
(code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream") (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
C.responseBody response `shouldBe` body C.responseBody response `shouldBe` body
C.responseStatus response `shouldBe` badRequest400 C.responseStatus response `shouldBe` badRequest400
it "Returns headers appropriately" $ withServer $ \ host -> do
res <- runEitherT (getRespHeaders host)
case res of
Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
modifyMaxSuccess (const 20) $ do modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
@ -246,7 +261,7 @@ spec = do
let test :: (WrappedApi, String) -> Spec let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) = test (WrappedApi api, desc) =
it desc $ it desc $
withWaiDaemon (return (serve api (left (500, "error message")))) $ withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $
\ host -> do \ host -> do
let getResponse :: BaseUrl -> EitherT ServantError IO () let getResponse :: BaseUrl -> EitherT ServantError IO ()
getResponse = client api getResponse = client api
@ -292,8 +307,8 @@ spec = do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where data WrappedApi where
WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a, WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,
HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) => HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
Proxy api -> WrappedApi Proxy api -> WrappedApi

4
servant-docs/CHANGELOG.md
View File

@ -5,7 +5,9 @@
* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15) * Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
* Remove ToJSON superclass from ToSample * Remove ToJSON superclass from ToSample
* Split out Internal module * Split out Internal module
* `Canonicalize` API types before generating the docs for them * Add support for response headers
* Allow `ToSample` to return a different type than it's arguments
* Add Proxy argument to `ToSample`
0.3 0.3
--- ---

11
servant-docs/example/greet.hs
View File

@ -53,14 +53,17 @@ instance ToParam (MatrixParam "lang" String) where
"Get the greeting message selected language. Default is en." "Get the greeting message selected language. Default is en."
Normal Normal
instance ToSample Greet where instance ToSample Greet Greet where
toSample = Just $ Greet "Hello, haskeller!" toSample _ = Just $ Greet "Hello, haskeller!"
toSamples = toSamples _ =
[ ("If you use ?capital=true", Greet "HELLO, HASKELLER") [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
, ("If you use ?capital=false", Greet "Hello, haskeller") , ("If you use ?capital=false", Greet "Hello, haskeller")
] ]
instance ToSample Int Int where
toSample _ = Just 1729
-- We define some introductory sections, these will appear at the top of the -- We define some introductory sections, these will appear at the top of the
-- documentation. -- documentation.
-- --
@ -84,7 +87,7 @@ type TestApi =
-- POST /greet with a Greet as JSON in the request body, -- POST /greet with a Greet as JSON in the request body,
-- returns a Greet as JSON -- returns a Greet as JSON
:<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet)
-- DELETE /greet/:greetid -- DELETE /greet/:greetid
:<|> "greet" :> Capture "greetid" Text :> Delete :<|> "greet" :> Capture "greetid" Text :> Delete

4
servant-docs/servant-docs.cabal
View File

@ -32,8 +32,11 @@ library
build-depends: build-depends:
base >=4.7 && <5 base >=4.7 && <5
, bytestring , bytestring
, bytestring-conversion
, case-insensitive
, hashable , hashable
, http-media >= 0.6 , http-media >= 0.6
, http-types >= 0.7
, lens , lens
, servant >= 0.2.1 , servant >= 0.2.1
, string-conversions , string-conversions
@ -50,6 +53,7 @@ executable greet-docs
build-depends: build-depends:
base base
, aeson , aeson
, bytestring-conversion
, lens , lens
, servant , servant
, servant-docs , servant-docs

6
servant-docs/src/Servant/Docs.hs
View File

@ -77,10 +77,10 @@
-- > "Get the greeting message selected language. Default is en." -- > "Get the greeting message selected language. Default is en."
-- > Normal -- > Normal
-- > -- >
-- > instance ToSample Greet where -- > instance ToSample Greet Greet where
-- > toSample = Just $ Greet "Hello, haskeller!" -- > toSample _ = Just $ Greet "Hello, haskeller!"
-- > -- >
-- > toSamples = -- > toSamples _ =
-- > [ ("If you use ?capital=true", Greet "HELLO, HASKELLER") -- > [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
-- > , ("If you use ?capital=false", Greet "Hello, haskeller") -- > , ("If you use ?capital=false", Greet "Hello, haskeller")
-- > ] -- > ]

185
servant-docs/src/Servant/Docs/Internal.hs
View File

@ -1,17 +1,22 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
module Servant.Docs.Internal where module Servant.Docs.Internal where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -19,6 +24,7 @@ import Control.Applicative
#endif #endif
import Control.Lens import Control.Lens
import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.CaseInsensitive as CI
import Data.Hashable import Data.Hashable
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.List import Data.List
@ -26,6 +32,7 @@ import Data.Maybe
import Data.Monoid import Data.Monoid
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Proxy import Data.Proxy
import Data.ByteString.Conversion (ToByteString, toByteString)
import Data.String.Conversions import Data.String.Conversions
import Data.Text (Text, pack, unpack) import Data.Text (Text, pack, unpack)
import GHC.Exts (Constraint) import GHC.Exts (Constraint)
@ -38,6 +45,7 @@ import Servant.Utils.Links
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T import qualified Data.Text as T
import qualified Network.HTTP.Media as M import qualified Network.HTTP.Media as M
import qualified Network.HTTP.Types as HTTP
-- | Supported HTTP request methods -- | Supported HTTP request methods
data Method = DocDELETE -- ^ the DELETE method data Method = DocDELETE -- ^ the DELETE method
@ -191,9 +199,10 @@ data ParamKind = Normal | List | Flag
-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")] -- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]} -- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
data Response = Response data Response = Response
{ _respStatus :: Int { _respStatus :: Int
, _respTypes :: [M.MediaType] , _respTypes :: [M.MediaType]
, _respBody :: [(Text, M.MediaType, ByteString)] , _respBody :: [(Text, M.MediaType, ByteString)]
, _respHeaders :: [HTTP.Header]
} deriving (Eq, Ord, Show) } deriving (Eq, Ord, Show)
-- | Default response: status code 200, no response body. -- | Default response: status code 200, no response body.
@ -205,7 +214,12 @@ data Response = Response
-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]" -- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
-- > Response {_respStatus = 204, _respBody = Just "[]"} -- > Response {_respStatus = 204, _respBody = Just "[]"}
defResponse :: Response defResponse :: Response
defResponse = Response 200 [] [] defResponse = Response
{ _respStatus = 200
, _respTypes = []
, _respBody = []
, _respHeaders = []
}
-- | A datatype that represents everything that can happen -- | A datatype that represents everything that can happen
-- at an endpoint, with its lenses: -- at an endpoint, with its lenses:
@ -276,8 +290,8 @@ makeLenses ''Action
-- | Generate the docs for a given API that implements 'HasDocs'. This is the -- | Generate the docs for a given API that implements 'HasDocs'. This is the
-- default way to create documentation. -- default way to create documentation.
docs :: HasDocs (Canonicalize layout) => Proxy layout -> API docs :: HasDocs layout => Proxy layout -> API
docs p = docsFor (canonicalize p) (defEndpoint, defAction) docs p = docsFor p (defEndpoint, defAction)
-- | Closed type family, check if endpoint is exactly within API. -- | Closed type family, check if endpoint is exactly within API.
@ -321,11 +335,7 @@ extraInfo p action =
-- 'extraInfo'. -- 'extraInfo'.
-- --
-- If you only want to add an introduction, use 'docsWithIntros'. -- If you only want to add an introduction, use 'docsWithIntros'.
docsWith :: HasDocs (Canonicalize layout) docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
=> [DocIntro]
-> ExtraInfo layout
-> Proxy layout
-> API
docsWith intros (ExtraInfo endpoints) p = docsWith intros (ExtraInfo endpoints) p =
docs p & apiIntros <>~ intros docs p & apiIntros <>~ intros
& apiEndpoints %~ HM.unionWith combineAction endpoints & apiEndpoints %~ HM.unionWith combineAction endpoints
@ -333,7 +343,7 @@ docsWith intros (ExtraInfo endpoints) p =
-- | Generate the docs for a given API that implements 'HasDocs' with with any -- | Generate the docs for a given API that implements 'HasDocs' with with any
-- number of introduction(s) -- number of introduction(s)
docsWithIntros :: HasDocs (Canonicalize layout) => [DocIntro] -> Proxy layout -> API docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
docsWithIntros intros = docsWith intros mempty docsWithIntros intros = docsWith intros mempty
-- | The class that abstracts away the impact of API combinators -- | The class that abstracts away the impact of API combinators
@ -362,8 +372,8 @@ class HasDocs layout where
-- > instance FromJSON Greet -- > instance FromJSON Greet
-- > instance ToJSON Greet -- > instance ToJSON Greet
-- > -- >
-- > instance ToSample Greet where -- > instance ToSample Greet Greet where
-- > toSample = Just g -- > toSample _ = Just g
-- > -- >
-- > where g = Greet "Hello, haskeller!" -- > where g = Greet "Hello, haskeller!"
-- --
@ -371,34 +381,53 @@ class HasDocs layout where
-- 'toSample': it lets you specify different responses along with -- 'toSample': it lets you specify different responses along with
-- some context (as 'Text') that explains when you're supposed to -- some context (as 'Text') that explains when you're supposed to
-- get the corresponding response. -- get the corresponding response.
class ToSample a where class ToSample a b | a -> b where
{-# MINIMAL (toSample | toSamples) #-} {-# MINIMAL (toSample | toSamples) #-}
toSample :: Maybe a toSample :: Proxy a -> Maybe b
toSample = snd <$> listToMaybe samples toSample _ = snd <$> listToMaybe samples
where samples = toSamples :: [(Text, a)] where samples = toSamples (Proxy :: Proxy a)
toSamples :: [(Text, a)] toSamples :: Proxy a -> [(Text, b)]
toSamples = maybe [] (return . ("",)) s toSamples _ = maybe [] (return . ("",)) s
where s = toSample :: Maybe a where s = toSample (Proxy :: Proxy a)
instance ToSample a b => ToSample (Headers ls a) b where
toSample _ = toSample (Proxy :: Proxy a)
toSamples _ = toSamples (Proxy :: Proxy a)
class AllHeaderSamples ls where
allHeaderToSample :: Proxy ls -> [HTTP.Header]
instance AllHeaderSamples '[] where
allHeaderToSample _ = []
instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h)
=> AllHeaderSamples (Header h l ': ls) where
allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :
allHeaderToSample (Proxy :: Proxy ls)
where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
mkHeader (Just x) = (headerName, cs $ toByteString x)
mkHeader Nothing = (headerName, "<no header sample provided>")
-- | Synthesise a sample value of a type, encoded in the specified media types. -- | Synthesise a sample value of a type, encoded in the specified media types.
sampleByteString sampleByteString
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)
=> Proxy ctypes => Proxy ctypes
-> Proxy a -> Proxy a
-> [(M.MediaType, ByteString)] -> [(M.MediaType, ByteString)]
sampleByteString ctypes@Proxy Proxy = sampleByteString ctypes@Proxy Proxy =
maybe [] (allMimeRender ctypes) (toSample :: Maybe a) maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)
-- | Synthesise a list of sample values of a particular type, encoded in the -- | Synthesise a list of sample values of a particular type, encoded in the
-- specified media types. -- specified media types.
sampleByteStrings sampleByteStrings
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)
=> Proxy ctypes => Proxy ctypes
-> Proxy a -> Proxy a
-> [(Text, M.MediaType, ByteString)] -> [(Text, M.MediaType, ByteString)]
sampleByteStrings ctypes@Proxy Proxy = sampleByteStrings ctypes@Proxy Proxy =
let samples = toSamples :: [(Text, a)] let samples = toSamples (Proxy :: Proxy a)
enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
in concatMap enc samples in concatMap enc samples
@ -580,6 +609,7 @@ markdown api = unlines $
"#### Response:" : "#### Response:" :
"" : "" :
("- Status code " ++ show (resp ^. respStatus)) : ("- Status code " ++ show (resp ^. respStatus)) :
("- Headers: " ++ show (resp ^. respHeaders)) :
"" : "" :
formatTypes (resp ^. respTypes) ++ formatTypes (resp ^. respTypes) ++
bodies bodies
@ -630,7 +660,11 @@ instance HasDocs Delete where
action' = action & response.respBody .~ [] action' = action & response.respBody .~ []
& response.respStatus .~ 204 & response.respStatus .~ 204
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLe #-}
#endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
=> HasDocs (Get cts a) where => HasDocs (Get cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
single endpoint' action' single endpoint' action'
@ -641,6 +675,24 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
, AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Get cts (Headers ls a)) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ sampleByteStrings t p
& response.respTypes .~ supportedTypes t
& response.respHeaders .~ hdrs
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs sublayout) instance (KnownSymbol sym, HasDocs sublayout)
=> HasDocs (Header sym a :> sublayout) where => HasDocs (Header sym a :> sublayout) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
@ -650,7 +702,11 @@ instance (KnownSymbol sym, HasDocs sublayout)
action' = over headers (|> headername) action action' = over headers (|> headername) action
headername = pack $ symbolVal (Proxy :: Proxy sym) headername = pack $ symbolVal (Proxy :: Proxy sym)
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
=> HasDocs (Post cts a) where => HasDocs (Post cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
single endpoint' action' single endpoint' action'
@ -662,7 +718,30 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
, AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Post cts (Headers ls a)) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ sampleByteStrings t p
& response.respTypes .~ supportedTypes 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 b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
=> HasDocs (Put cts a) where => HasDocs (Put cts a) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
single endpoint' action' single endpoint' action'
@ -674,6 +753,25 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
, AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Put cts (Headers ls a)) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ sampleByteStrings t p
& response.respTypes .~ supportedTypes t
& response.respStatus .~ 200
& response.respHeaders .~ hdrs
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
=> HasDocs (QueryParam sym a :> sublayout) where => HasDocs (QueryParam sym a :> sublayout) where
@ -756,7 +854,8 @@ instance HasDocs Raw where
-- example data. However, there's no reason to believe that the instances of -- example data. However, there's no reason to believe that the instances of
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type. -- both are even defined) for any particular type.
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout, SupportedTypes cts) instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, HasDocs sublayout
, SupportedTypes cts)
=> HasDocs (ReqBody cts a :> sublayout) where => HasDocs (ReqBody cts a :> sublayout) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =

12
servant-docs/test/Servant/DocsSpec.hs
View File

@ -46,14 +46,14 @@ data Datatype1 = Datatype1 { dt1field1 :: String
instance ToJSON Datatype1 instance ToJSON Datatype1
instance ToSample Datatype1 where instance ToSample Datatype1 Datatype1 where
toSample = Just $ Datatype1 "field 1" 13 toSample _ = Just $ Datatype1 "field 1" 13
instance ToSample String where instance ToSample String String where
toSample = Just "a string" toSample _ = Just "a string"
instance ToSample Int where instance ToSample Int Int where
toSample = Just 17 toSample _ = Just 17
instance MimeRender PlainText Int where instance MimeRender PlainText Int where
mimeRender _ = cs . show mimeRender _ = cs . show

4
servant-examples/auth-combinator/auth-combinator.hs
View File

@ -26,7 +26,7 @@ isGoodCookie = return . (== "good password")
data AuthProtected data AuthProtected
instance HasServer rest => HasServer (AuthProtected :> rest) where instance HasServer rest => HasServer (AuthProtected :> rest) where
type ServerT' (AuthProtected :> rest) m = ServerT' rest m type ServerT (AuthProtected :> rest) m = ServerT rest m
route Proxy a request respond = route Proxy a request respond =
case lookup "Cookie" (requestHeaders request) of case lookup "Cookie" (requestHeaders request) of
@ -75,4 +75,4 @@ $ curl -H "Cookie: good password" http://localhost:8080/private
[{"ssshhh":"this is a secret"}] [{"ssshhh":"this is a secret"}]
$ curl -H "Cookie: bad password" http://localhost:8080/private $ curl -H "Cookie: bad password" http://localhost:8080/private
Invalid cookie. Invalid cookie.
-} -}

7
servant-jquery/src/Servant/JQuery.hs
View File

@ -26,8 +26,8 @@ import Data.Proxy
import Servant.API import Servant.API
import Servant.JQuery.Internal import Servant.JQuery.Internal
jquery :: HasJQ (Canonicalize layout) => Proxy layout -> JQ layout jquery :: HasJQ layout => Proxy layout -> JQ layout
jquery p = jqueryFor (canonicalize p) defReq jquery p = jqueryFor p defReq
-- js codegen -- js codegen
generateJS :: AjaxReq -> String generateJS :: AjaxReq -> String
@ -112,6 +112,5 @@ instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where
-- | Directly generate all the javascript functions for your API -- | Directly generate all the javascript functions for your API
-- from a 'Proxy' for your API type. You can then write it to -- from a 'Proxy' for your API type. You can then write it to
-- a file or integrate it in a page, for example. -- a file or integrate it in a page, for example.
jsForAPI :: (HasJQ (Canonicalize api), GenerateCode (JQ api)) jsForAPI :: (HasJQ api, GenerateCode (JQ api)) => Proxy api -> String
=> Proxy api -> String
jsForAPI p = jsFor (jquery p) jsForAPI p = jsFor (jquery p)

38
servant-jquery/src/Servant/JQuery/Internal.hs
View File

@ -194,14 +194,12 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
Elem a (b ': list) = Elem a list Elem a (b ': list) = Elem a list
class HasJQ (layout :: *) where class HasJQ (layout :: *) where
type JQ' layout :: * type JQ layout :: *
jqueryFor :: Proxy layout -> AjaxReq -> JQ' layout jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
type JQ layout = JQ' (Canonicalize layout)
instance (HasJQ a, HasJQ b) instance (HasJQ a, HasJQ b)
=> HasJQ (a :<|> b) where => HasJQ (a :<|> b) where
type JQ' (a :<|> b) = JQ' a :<|> JQ' b type JQ (a :<|> b) = JQ a :<|> JQ b
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy a) req jqueryFor (Proxy :: Proxy a) req
@ -209,7 +207,7 @@ instance (HasJQ a, HasJQ b)
instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (Capture sym a :> sublayout) where => HasJQ (Capture sym a :> sublayout) where
type JQ' (Capture sym a :> sublayout) = JQ' sublayout type JQ (Capture sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor (Proxy :: Proxy sublayout) $
@ -218,14 +216,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
where str = symbolVal (Proxy :: Proxy sym) where str = symbolVal (Proxy :: Proxy sym)
instance HasJQ Delete where instance HasJQ Delete where
type JQ' Delete = AjaxReq type JQ Delete = AjaxReq
jqueryFor Proxy req = jqueryFor Proxy req =
req & funcName %~ ("delete" <>) req & funcName %~ ("delete" <>)
& reqMethod .~ "DELETE" & reqMethod .~ "DELETE"
instance Elem JSON list => HasJQ (Get list a) where instance Elem JSON list => HasJQ (Get list a) where
type JQ' (Get list a) = AjaxReq type JQ (Get list a) = AjaxReq
jqueryFor Proxy req = jqueryFor Proxy req =
req & funcName %~ ("get" <>) req & funcName %~ ("get" <>)
@ -233,7 +231,7 @@ instance Elem JSON list => HasJQ (Get list a) where
instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (Header sym a :> sublayout) where => HasJQ (Header sym a :> sublayout) where
type JQ' (Header sym a :> sublayout) = JQ' sublayout type JQ (Header sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname]) jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
@ -242,14 +240,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
subP = Proxy :: Proxy sublayout subP = Proxy :: Proxy sublayout
instance Elem JSON list => HasJQ (Post list a) where instance Elem JSON list => HasJQ (Post list a) where
type JQ' (Post list a) = AjaxReq type JQ (Post list a) = AjaxReq
jqueryFor Proxy req = jqueryFor Proxy req =
req & funcName %~ ("post" <>) req & funcName %~ ("post" <>)
& reqMethod .~ "POST" & reqMethod .~ "POST"
instance Elem JSON list => HasJQ (Put list a) where instance Elem JSON list => HasJQ (Put list a) where
type JQ' (Put list a) = AjaxReq type JQ (Put list a) = AjaxReq
jqueryFor Proxy req = jqueryFor Proxy req =
req & funcName %~ ("put" <>) req & funcName %~ ("put" <>)
@ -257,7 +255,7 @@ instance Elem JSON list => HasJQ (Put list a) where
instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (QueryParam sym a :> sublayout) where => HasJQ (QueryParam sym a :> sublayout) where
type JQ' (QueryParam sym a :> sublayout) = JQ' sublayout type JQ (QueryParam sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor (Proxy :: Proxy sublayout) $
@ -267,7 +265,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (QueryParams sym a :> sublayout) where => HasJQ (QueryParams sym a :> sublayout) where
type JQ' (QueryParams sym a :> sublayout) = JQ' sublayout type JQ (QueryParams sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor (Proxy :: Proxy sublayout) $
@ -277,7 +275,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (QueryFlag sym :> sublayout) where => HasJQ (QueryFlag sym :> sublayout) where
type JQ' (QueryFlag sym :> sublayout) = JQ' sublayout type JQ (QueryFlag sym :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor (Proxy :: Proxy sublayout) $
@ -287,7 +285,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (MatrixParam sym a :> sublayout) where => HasJQ (MatrixParam sym a :> sublayout) where
type JQ' (MatrixParam sym a :> sublayout) = JQ' sublayout type JQ (MatrixParam sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor (Proxy :: Proxy sublayout) $
@ -298,7 +296,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (MatrixParams sym a :> sublayout) where => HasJQ (MatrixParams sym a :> sublayout) where
type JQ' (MatrixParams sym a :> sublayout) = JQ' sublayout type JQ (MatrixParams sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor (Proxy :: Proxy sublayout) $
@ -308,7 +306,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (MatrixFlag sym :> sublayout) where => HasJQ (MatrixFlag sym :> sublayout) where
type JQ' (MatrixFlag sym :> sublayout) = JQ' sublayout type JQ (MatrixFlag sym :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor (Proxy :: Proxy sublayout) $
@ -317,14 +315,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
where str = symbolVal (Proxy :: Proxy sym) where str = symbolVal (Proxy :: Proxy sym)
instance HasJQ Raw where instance HasJQ Raw where
type JQ' Raw = Method -> AjaxReq type JQ Raw = Method -> AjaxReq
jqueryFor Proxy req method = jqueryFor Proxy req method =
req & funcName %~ ((toLower <$> method) <>) req & funcName %~ ((toLower <$> method) <>)
& reqMethod .~ method & reqMethod .~ method
instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where
type JQ' (ReqBody list a :> sublayout) = JQ' sublayout type JQ (ReqBody list a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor (Proxy :: Proxy sublayout) $
@ -332,7 +330,7 @@ instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout
instance (KnownSymbol path, HasJQ sublayout) instance (KnownSymbol path, HasJQ sublayout)
=> HasJQ (path :> sublayout) where => HasJQ (path :> sublayout) where
type JQ' (path :> sublayout) = JQ' sublayout type JQ (path :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor (Proxy :: Proxy sublayout) $

6
servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs
View File

@ -22,7 +22,7 @@ data Authorization (sym :: Symbol) a
instance (KnownSymbol sym, HasJQ sublayout) instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (Authorization sym a :> sublayout) where => HasJQ (Authorization sym a :> sublayout) where
type JQ' (Authorization sym a :> sublayout) = JQ' sublayout type JQ (Authorization sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $ req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
@ -35,7 +35,7 @@ data MyLovelyHorse a
instance (HasJQ sublayout) instance (HasJQ sublayout)
=> HasJQ (MyLovelyHorse a :> sublayout) where => HasJQ (MyLovelyHorse a :> sublayout) where
type JQ' (MyLovelyHorse a :> sublayout) = JQ' sublayout type JQ (MyLovelyHorse a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ] req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ]
@ -47,7 +47,7 @@ data WhatsForDinner a
instance (HasJQ sublayout) instance (HasJQ sublayout)
=> HasJQ (WhatsForDinner a :> sublayout) where => HasJQ (WhatsForDinner a :> sublayout) where
type JQ' (WhatsForDinner a :> sublayout) = JQ' sublayout type JQ (WhatsForDinner a :> sublayout) = JQ sublayout
jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $ jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ] req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ]

30
servant-lucid/LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright (c) 2015, Julian K. Arni
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Julian K. Arni nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
servant-lucid/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

28
servant-lucid/servant-lucid.cabal Normal file
View File

@ -0,0 +1,28 @@
-- Initial servant-lucid.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: servant-lucid
version: 0.1.0.0
synopsis: Servant support for lucid
-- description:
homepage: http://haskell-servant.github.io/
license: BSD3
license-file: LICENSE
author: Julian K. Arni
maintainer: jkarni@gmail.com
-- copyright:
category: Web
build-type: Simple
-- extra-source-files:
cabal-version: >=1.10
library
exposed-modules: Servant.HTML.Lucid
-- other-modules:
-- other-extensions:
build-depends: base >=4.7 && <5
, http-media
, lucid
, servant
hs-source-dirs: src
default-language: Haskell2010

43
servant-lucid/src/Servant/HTML/Lucid.hs Normal file
View File

@ -0,0 +1,43 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
-- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s
-- `ToHtml` class and `Html` datatype.
-- You should only need to import this module for it's instances and the
-- `HTML` datatype.:
--
-- >>> type Eg = Get '[HTML] a
--
-- Will then check that @a@ has a `ToHtml` instance, or is `Html`.
module Servant.HTML.Lucid where
import Data.Typeable (Typeable)
import Lucid (Html, ToHtml (..), renderBS)
import qualified Network.HTTP.Media as M
import Servant.API (Accept (..), MimeRender (..))
data HTML deriving Typeable
-- | @text/plain;charset=utf-8@
instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
ToHtml a => MimeRender HTML a where
mimeRender _ = renderBS . toHtml
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender HTML (Html a) where
mimeRender _ = renderBS

4
servant-server/CHANGELOG.md
View File

@ -5,9 +5,11 @@
* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*
* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29) * Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21) * Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
* Canonicalize API types before generating the handler types with `Server`
* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28) * Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
* Add server support for response headers * Add server support for response headers
* Use `ServantErr` instead of `(Int,String)` in `EitherT` handlers
* Add `errXXX` functions for HTTP errors with sensible default reason strings
* Add `enter` function for applying natural transformations to handlers
0.2.4 0.2.4
----- -----

16
servant-server/servant-server.cabal
View File

@ -36,6 +36,8 @@ library
Servant Servant
Servant.Server Servant.Server
Servant.Server.Internal Servant.Server.Internal
Servant.Server.Internal.ServantErr
Servant.Server.Internal.Enter
Servant.Utils.StaticFiles Servant.Utils.StaticFiles
build-depends: build-depends:
base >= 4.7 && < 5 base >= 4.7 && < 5
@ -45,6 +47,8 @@ library
, either >= 4.3 && < 4.4 , either >= 4.3 && < 4.4
, http-types >= 0.8 && < 0.9 , http-types >= 0.8 && < 0.9
, network-uri >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7
, mtl >= 2 && < 3
, mmorph >= 1
, safe >= 0.3 && < 0.4 , safe >= 0.3 && < 0.4
, servant >= 0.2 && < 0.4 , servant >= 0.2 && < 0.4
, split >= 0.2 && < 0.3 , split >= 0.2 && < 0.3
@ -100,6 +104,18 @@ test-suite spec
, temporary , temporary
, text , text
, transformers , transformers
, mtl
, wai , wai
, wai-extra , wai-extra
, warp , warp
test-suite doctests
build-depends: base
, servant
, doctest
, filemanip
type: exitcode-stdio-1.0
main-is: test/Doctests.hs
buildable: True
default-language: Haskell2010
ghc-options: -threaded

104
servant-server/src/Servant/Server.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
-- | This module lets you implement 'Server's for defined APIs. You'll -- | This module lets you implement 'Server's for defined APIs. You'll
-- most likely just need 'serve'. -- most likely just need 'serve'.
@ -14,13 +15,73 @@ module Servant.Server
, -- * Handlers for all standard combinators , -- * Handlers for all standard combinators
HasServer(..) HasServer(..)
, Server , Server
, ServerT
-- * Enter
-- $enterDoc
-- ** Basic functions and datatypes
, enter
, (:~>)(..)
-- ** `Nat` utilities
, liftNat
, runReaderTNat
, evalStateTLNat
, evalStateTSNat
, logWriterTLNat
, logWriterTSNat
#if MIN_VERSION_mtl(2,2,1)
, fromExceptT
#endif
-- ** Functions based on <https://hackage.haskell.org/package/mmorph mmorph>
, hoistNat
, embedNat
, squashNat
, generalizeNat
-- * Default error type
, ServantErr(..)
-- ** 3XX
, err300
, err301
, err302
, err303
, err304
, err305
, err307
-- ** 4XX
, err400
, err401
, err402
, err403
, err404
, err405
, err406
, err407
, err409
, err410
, err411
, err412
, err413
, err414
, err415
, err416
, err417
-- * 5XX
, err500
, err501
, err502
, err503
, err504
, err505
) where ) where
import Data.Proxy (Proxy) import Data.Proxy (Proxy)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.API (Canonicalize, canonicalize) import Servant.Server.Internal
import Servant.Server.Internal import Servant.Server.Internal.Enter
import Servant.Server.Internal.ServantErr
-- * Implementing Servers -- * Implementing Servers
@ -45,5 +106,30 @@ import Servant.Server.Internal
-- > -- >
-- > main :: IO () -- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app -- > main = Network.Wai.Handler.Warp.run 8080 app
serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application --
serve p server = toApplication (route (canonicalize p) server) serve :: HasServer layout => Proxy layout -> Server layout -> Application
serve p server = toApplication (route p server)
-- Documentation
-- $enterDoc
-- Sometimes our cherished `EitherT` monad isn't quite the type you'd like for
-- your handlers. Maybe you want to thread some configuration in a @Reader@
-- monad. Or have your types ensure that your handlers don't do any IO. Enter
-- `enter`.
--
-- With `enter`, you can provide a function, wrapped in the `(:~>)` / `Nat`
-- newtype, to convert any number of endpoints from one type constructor to
-- another. For example
--
-- >>> import Control.Monad.Reader
-- >>> import qualified Control.Category as C
-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String
-- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String)
-- >>> let mainServer = enter (generalizeNat C.. (runReaderTNat "hi")) readerServer :: Server ReaderAPI
--
-- $setup
-- >>> import Servant.API
-- >>> import Servant.Server

137
servant-server/src/Servant/Server/Internal.hs
View File

@ -38,7 +38,7 @@ import Network.Wai (Application, Request, Response,
requestMethod, responseLBS, requestMethod, responseLBS,
strictRequestBody) strictRequestBody)
import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API ((:<|>) (..), (:>), Capture,
Canonicalize, Delete, Get, Header, Delete, Get, Header,
MatrixFlag, MatrixParam, MatrixParams, MatrixFlag, MatrixParam, MatrixParams,
Patch, Post, Put, QueryFlag, Patch, Post, Put, QueryFlag,
QueryParam, QueryParams, Raw, QueryParam, QueryParams, Raw,
@ -46,9 +46,12 @@ import Servant.API ((:<|>) (..), (:>), Capture,
import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..), AllCTRender (..),
AllCTUnrender (..)) AllCTUnrender (..))
import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders) import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
getHeaders)
import Servant.Common.Text (FromText, fromText) import Servant.Common.Text (FromText, fromText)
import Servant.Server.Internal.ServantErr
data ReqBodyState = Uncalled data ReqBodyState = Uncalled
| Called !B.ByteString | Called !B.ByteString
| Done !B.ByteString | Done !B.ByteString
@ -174,13 +177,11 @@ processedPathInfo r =
where pinfo = parsePathInfo r where pinfo = parsePathInfo r
class HasServer layout where class HasServer layout where
type ServerT' layout (m :: * -> *) :: * type ServerT layout (m :: * -> *) :: *
route :: Proxy layout -> Server' layout -> RoutingApplication route :: Proxy layout -> Server layout -> RoutingApplication
type Server layout = Server' (Canonicalize layout) type Server layout = ServerT layout (EitherT ServantErr IO)
type Server' layout = ServerT' layout (EitherT (Int, String) IO)
type ServerT layout m = ServerT' (Canonicalize layout) m
-- * Instances -- * Instances
@ -197,7 +198,7 @@ type ServerT layout m = ServerT' (Canonicalize layout) m
-- > postBook book = ... -- > postBook book = ...
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy (a :<|> b) request respond = route Proxy (a :<|> b) request respond =
route pa a request $ \mResponse -> route pa a request $ \mResponse ->
@ -231,8 +232,8 @@ captured _ = fromText
instance (KnownSymbol capture, FromText a, HasServer sublayout) instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where => HasServer (Capture capture a :> sublayout) where
type ServerT' (Capture capture a :> sublayout) m = type ServerT (Capture capture a :> sublayout) m =
a -> ServerT' sublayout m a -> ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver request respond = case processedPathInfo request of
(first : rest) (first : rest)
@ -259,16 +260,14 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
-- are not met. -- are not met.
instance HasServer Delete where instance HasServer Delete where
type ServerT' Delete m = m () type ServerT Delete m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do | pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action e <- runEitherT action
respond $ succeedWith $ case e of respond $ succeedWith $ case e of
Right () -> Right () -> responseLBS status204 [] ""
responseLBS status204 [] "" Left err -> responseServantErr err
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodDelete = | pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -292,7 +291,7 @@ instance
#endif #endif
( AllCTRender ctypes a ) => HasServer (Get ctypes a) where ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
type ServerT' (Get ctypes a) m = m a type ServerT (Get ctypes a) m = m a
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do | pathIsEmpty request && requestMethod request == methodGet = do
@ -304,8 +303,7 @@ instance
Nothing -> failWith UnsupportedMediaType Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $ Just (contentT, body) -> succeedWith $
responseLBS ok200 [ ("Content-Type" , cs contentT)] body responseLBS ok200 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $ Left err -> succeedWith $ responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet = | pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -317,15 +315,14 @@ instance
#endif #endif
HasServer (Get ctypes ()) where HasServer (Get ctypes ()) where
type ServerT' (Get ctypes ()) m = m () type ServerT (Get ctypes ()) m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do | pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] "" Right () -> responseLBS noContent204 [] ""
Left (status, message) -> Left err -> responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet = | pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -335,9 +332,10 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where ( 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) type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do | pathIsEmpty request && requestMethod request == methodGet = do
@ -350,8 +348,7 @@ instance
Nothing -> failWith UnsupportedMediaType Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $ Just (contentT, body) -> succeedWith $
responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $ Left err -> succeedWith $ responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet = | pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -379,8 +376,8 @@ instance
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where => HasServer (Header sym a :> sublayout) where
type ServerT' (Header sym a :> sublayout) m = type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT' sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
@ -408,7 +405,7 @@ instance
( AllCTRender ctypes a ( AllCTRender ctypes a
) => HasServer (Post ctypes a) where ) => HasServer (Post ctypes a) where
type ServerT' (Post ctypes a) m = m a type ServerT (Post ctypes a) m = m a
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
@ -420,8 +417,7 @@ instance
Nothing -> failWith UnsupportedMediaType Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $ Just (contentT, body) -> succeedWith $
responseLBS status201 [ ("Content-Type" , cs contentT)] body responseLBS status201 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $ Left err -> succeedWith $ responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost = | pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -432,15 +428,14 @@ instance
#endif #endif
HasServer (Post ctypes ()) where HasServer (Post ctypes ()) where
type ServerT' (Post ctypes ()) m = m () type ServerT (Post ctypes ()) m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] "" Right () -> responseLBS noContent204 [] ""
Left (status, message) -> Left err -> responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost = | pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -450,9 +445,10 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where ( 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) type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
@ -465,8 +461,7 @@ instance
Nothing -> failWith UnsupportedMediaType Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $ Just (contentT, body) -> succeedWith $
responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $ Left err -> succeedWith $ responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost = | pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -490,7 +485,7 @@ instance
#endif #endif
( AllCTRender ctypes a) => HasServer (Put ctypes a) where ( AllCTRender ctypes a) => HasServer (Put ctypes a) where
type ServerT' (Put ctypes a) m = m a type ServerT (Put ctypes a) m = m a
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
@ -502,8 +497,7 @@ instance
Nothing -> failWith UnsupportedMediaType Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $ Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $ Left err -> succeedWith $ responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut = | pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -514,15 +508,14 @@ instance
#endif #endif
HasServer (Put ctypes ()) where HasServer (Put ctypes ()) where
type ServerT' (Put ctypes ()) m = m () type ServerT (Put ctypes ()) m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] "" Right () -> responseLBS noContent204 [] ""
Left (status, message) -> Left err -> responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut = | pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -532,9 +525,10 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where ( 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) type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
@ -547,8 +541,7 @@ instance
Nothing -> failWith UnsupportedMediaType Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $ Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $ Left err -> succeedWith $ responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut = | pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -570,7 +563,7 @@ instance
#endif #endif
( AllCTRender ctypes a) => HasServer (Patch ctypes a) where ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
type ServerT' (Patch ctypes a) m = m a type ServerT (Patch ctypes a) m = m a
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do | pathIsEmpty request && requestMethod request == methodPatch = do
@ -582,8 +575,7 @@ instance
Nothing -> failWith UnsupportedMediaType Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $ Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $ Left err -> succeedWith $ responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPatch = | pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -594,15 +586,14 @@ instance
#endif #endif
HasServer (Patch ctypes ()) where HasServer (Patch ctypes ()) where
type ServerT' (Patch ctypes ()) m = m () type ServerT (Patch ctypes ()) m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do | pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] "" Right () -> responseLBS noContent204 [] ""
Left (status, message) -> Left err -> responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPatch = | pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -612,9 +603,10 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where ( 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) type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do | pathIsEmpty request && requestMethod request == methodPatch = do
@ -627,8 +619,7 @@ instance
Nothing -> failWith UnsupportedMediaType Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $ Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $ Left err -> succeedWith $ responseServantErr err
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPatch = | pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -657,8 +648,8 @@ instance
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where => HasServer (QueryParam sym a :> sublayout) where
type ServerT' (QueryParam sym a :> sublayout) m = type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT' sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -695,8 +686,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where => HasServer (QueryParams sym a :> sublayout) where
type ServerT' (QueryParams sym a :> sublayout) m = type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT' sublayout m [a] -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -728,8 +719,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where => HasServer (QueryFlag sym :> sublayout) where
type ServerT' (QueryFlag sym :> sublayout) m = type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT' sublayout m Bool -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -771,8 +762,8 @@ parseMatrixText = parseQueryText
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParam sym a :> sublayout) where => HasServer (MatrixParam sym a :> sublayout) where
type ServerT' (MatrixParam sym a :> sublayout) m = type ServerT (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT' sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -809,8 +800,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParams sym a :> sublayout) where => HasServer (MatrixParams sym a :> sublayout) where
type ServerT' (MatrixParams sym a :> sublayout) m = type ServerT (MatrixParams sym a :> sublayout) m =
[a] -> ServerT' sublayout m [a] -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -843,8 +834,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (MatrixFlag sym :> sublayout) where => HasServer (MatrixFlag sym :> sublayout) where
type ServerT' (MatrixFlag sym :> sublayout) m = type ServerT (MatrixFlag sym :> sublayout) m =
Bool -> ServerT' sublayout m Bool -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -872,7 +863,7 @@ instance (KnownSymbol sym, HasServer sublayout)
-- > server = serveDirectory "/var/www/images" -- > server = serveDirectory "/var/www/images"
instance HasServer Raw where instance HasServer Raw where
type ServerT' Raw m = Application type ServerT Raw m = Application
route Proxy rawApplication request respond = route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith) rawApplication request (respond . succeedWith)
@ -900,8 +891,8 @@ instance HasServer Raw where
instance ( AllCTUnrender list a, HasServer sublayout instance ( AllCTUnrender list a, HasServer sublayout
) => HasServer (ReqBody list a :> sublayout) where ) => HasServer (ReqBody list a :> sublayout) where
type ServerT' (ReqBody list a :> sublayout) m = type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT' sublayout m a -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
-- See HTTP RFC 2616, section 7.2.1 -- See HTTP RFC 2616, section 7.2.1
@ -921,7 +912,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
-- pass the rest of the request path to @sublayout@. -- pass the rest of the request path to @sublayout@.
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type ServerT' (path :> sublayout) m = ServerT' sublayout m type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver request respond = case processedPathInfo request of
(first : rest) (first : rest)

105
servant-server/src/Servant/Server/Internal/Enter.hs Normal file
View File

@ -0,0 +1,105 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.Server.Internal.Enter where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import qualified Control.Category as C
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except
#endif
import Control.Monad.Identity
import Control.Monad.Morph
import Control.Monad.Reader
import qualified Control.Monad.State.Lazy as LState
import qualified Control.Monad.State.Strict as SState
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Trans.Either
#endif
import qualified Control.Monad.Writer.Lazy as LWriter
import qualified Control.Monad.Writer.Strict as SWriter
import Data.Typeable
import Servant.API
class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
enter :: arg -> typ -> ret
-- ** Servant combinators
instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
, arg1 ~ arg2
) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where
enter e (a :<|> b) = enter e a :<|> enter e b
instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
enter arg f a = enter arg (f a)
-- ** Useful instances
-- | A natural transformation from @m@ to @n@. Used to `enter` particular
-- datatypes.
newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable
instance C.Category (:~>) where
id = Nat id
Nat f . Nat g = Nat (f . g)
instance Enter (m a) (m :~> n) (n a) where
enter (Nat f) = f
-- | Like `lift`.
liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m
liftNat = Nat Control.Monad.Morph.lift
runReaderTNat :: r -> (ReaderT r m :~> m)
runReaderTNat a = Nat (`runReaderT` a)
evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)
evalStateTLNat a = Nat (`LState.evalStateT` a)
evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)
evalStateTSNat a = Nat (`SState.evalStateT` a)
-- | Log the contents of `SWriter.WriterT` with the function provided as the
-- first argument, and return the value of the @WriterT@ computation
logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)
logWriterTSNat logger = Nat $ \x -> do
(a, w) <- SWriter.runWriterT x
liftIO $ logger w
return a
-- | Like `logWriterTSNat`, but for strict @WriterT@.
logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)
logWriterTLNat logger = Nat $ \x -> do
(a, w) <- LWriter.runWriterT x
liftIO $ logger w
return a
#if MIN_VERSION_mtl(2,2,1)
fromExceptT :: ExceptT e m :~> EitherT e m
fromExceptT = Nat $ \x -> EitherT $ runExceptT x
#endif
-- | Like @mmorph@'s `hoist`.
hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)
hoistNat (Nat n) = Nat $ hoist n
-- | Like @mmorph@'s `embed`.
embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)
embedNat (Nat n) = Nat $ embed n
-- | Like @mmorph@'s `squash`.
squashNat :: (Monad m, MMonad t) => t (t m) :~> t m
squashNat = Nat squash
-- | Like @mmorph@'s `generalize`.
generalizeNat :: Applicative m => Identity :~> m
generalizeNat = Nat (pure . runIdentity)

229
servant-server/src/Servant/Server/Internal/ServantErr.hs Normal file
View File

@ -0,0 +1,229 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Servant.Server.Internal.ServantErr where
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Network.HTTP.Types as HTTP
import Network.Wai (responseLBS, Response)
data ServantErr = ServantErr { errHTTPCode :: Int
, errReasonPhrase :: String
, errBody :: LBS.ByteString
, errHeaders :: [HTTP.Header]
} deriving (Show, Eq)
responseServantErr :: ServantErr -> Response
responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
where
status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)
err300 :: ServantErr
err300 = ServantErr { errHTTPCode = 300
, errReasonPhrase = "Multiple Choices"
, errBody = ""
, errHeaders = []
}
err301 :: ServantErr
err301 = ServantErr { errHTTPCode = 301
, errReasonPhrase = "Moved Permanently"
, errBody = ""
, errHeaders = []
}
err302 :: ServantErr
err302 = ServantErr { errHTTPCode = 302
, errReasonPhrase = "Found"
, errBody = ""
, errHeaders = []
}
err303 :: ServantErr
err303 = ServantErr { errHTTPCode = 303
, errReasonPhrase = "See Other"
, errBody = ""
, errHeaders = []
}
err304 :: ServantErr
err304 = ServantErr { errHTTPCode = 304
, errReasonPhrase = "Not Modified"
, errBody = ""
, errHeaders = []
}
err305 :: ServantErr
err305 = ServantErr { errHTTPCode = 305
, errReasonPhrase = "Use Proxy"
, errBody = ""
, errHeaders = []
}
err307 :: ServantErr
err307 = ServantErr { errHTTPCode = 307
, errReasonPhrase = "Temporary Redirect"
, errBody = ""
, errHeaders = []
}
err400 :: ServantErr
err400 = ServantErr { errHTTPCode = 400
, errReasonPhrase = "Bad Request"
, errBody = ""
, errHeaders = []
}
err401 :: ServantErr
err401 = ServantErr { errHTTPCode = 401
, errReasonPhrase = "Unauthorized"
, errBody = ""
, errHeaders = []
}
err402 :: ServantErr
err402 = ServantErr { errHTTPCode = 402
, errReasonPhrase = "Payment Required"
, errBody = ""
, errHeaders = []
}
err403 :: ServantErr
err403 = ServantErr { errHTTPCode = 403
, errReasonPhrase = "Forbidden"
, errBody = ""
, errHeaders = []
}
err404 :: ServantErr
err404 = ServantErr { errHTTPCode = 404
, errReasonPhrase = "Not Found"
, errBody = ""
, errHeaders = []
}
err405 :: ServantErr
err405 = ServantErr { errHTTPCode = 405
, errReasonPhrase = "Method Not Allowed"
, errBody = ""
, errHeaders = []
}
err406 :: ServantErr
err406 = ServantErr { errHTTPCode = 406
, errReasonPhrase = "Not Acceptable"
, errBody = ""
, errHeaders = []
}
err407 :: ServantErr
err407 = ServantErr { errHTTPCode = 407
, errReasonPhrase = "Proxy Authentication Required"
, errBody = ""
, errHeaders = []
}
err409 :: ServantErr
err409 = ServantErr { errHTTPCode = 409
, errReasonPhrase = "Conflict"
, errBody = ""
, errHeaders = []
}
err410 :: ServantErr
err410 = ServantErr { errHTTPCode = 410
, errReasonPhrase = "Gone"
, errBody = ""
, errHeaders = []
}
err411 :: ServantErr
err411 = ServantErr { errHTTPCode = 411
, errReasonPhrase = "Length Required"
, errBody = ""
, errHeaders = []
}
err412 :: ServantErr
err412 = ServantErr { errHTTPCode = 412
, errReasonPhrase = "Precondition Failed"
, errBody = ""
, errHeaders = []
}
err413 :: ServantErr
err413 = ServantErr { errHTTPCode = 413
, errReasonPhrase = "Request Entity Too Large"
, errBody = ""
, errHeaders = []
}
err414 :: ServantErr
err414 = ServantErr { errHTTPCode = 414
, errReasonPhrase = "Request-URI Too Large"
, errBody = ""
, errHeaders = []
}
err415 :: ServantErr
err415 = ServantErr { errHTTPCode = 415
, errReasonPhrase = "Unsupported Media Type"
, errBody = ""
, errHeaders = []
}
err416 :: ServantErr
err416 = ServantErr { errHTTPCode = 416
, errReasonPhrase = "Request range not satisfiable"
, errBody = ""
, errHeaders = []
}
err417 :: ServantErr
err417 = ServantErr { errHTTPCode = 417
, errReasonPhrase = "Expectation Failed"
, errBody = ""
, errHeaders = []
}
err500 :: ServantErr
err500 = ServantErr { errHTTPCode = 500
, errReasonPhrase = "Internal Server Error"
, errBody = ""
, errHeaders = []
}
err501 :: ServantErr
err501 = ServantErr { errHTTPCode = 501
, errReasonPhrase = "Not Implemented"
, errBody = ""
, errHeaders = []
}
err502 :: ServantErr
err502 = ServantErr { errHTTPCode = 502
, errReasonPhrase = "Bad Gateway"
, errBody = ""
, errHeaders = []
}
err503 :: ServantErr
err503 = ServantErr { errHTTPCode = 503
, errReasonPhrase = "Service Unavailable"
, errBody = ""
, errHeaders = []
}
err504 :: ServantErr
err504 = ServantErr { errHTTPCode = 504
, errReasonPhrase = "Gateway Time-out"
, errBody = ""
, errHeaders = []
}
err505 :: ServantErr
err505 = ServantErr { errHTTPCode = 505
, errReasonPhrase = "HTTP Version not supported"
, errBody = ""
, errHeaders = []
}

18
servant-server/test/Doctests.hs Normal file
View File

@ -0,0 +1,18 @@
module Main where
import System.FilePath.Find
import Test.DocTest
main :: IO ()
main = do
files <- find always (extension ==? ".hs") "src"
doctest $ [ "-isrc"
, "-optP-include"
, "-optPdist/build/autogen/cabal_macros.h"
, "-XOverloadedStrings"
, "-XFlexibleInstances"
, "-XMultiParamTypeClasses"
, "-XDataKinds"
, "-XTypeOperators"
] ++ files

59
servant-server/test/Servant/Server/Internal/EnterSpec.hs Normal file
View File

@ -0,0 +1,59 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.Internal.EnterSpec where
import qualified Control.Category as C
import Control.Monad.Reader
import Control.Monad.Trans.Either
import Data.Proxy
import Servant.API
import Servant.Server
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Wai (get, matchStatus, post,
shouldRespondWith, with)
spec :: Spec
spec = describe "module Servant.Server.Enter" $ do
enterSpec
type ReaderAPI = "int" :> Get '[JSON] Int
:<|> "string" :> Post '[JSON] String
type IdentityAPI = "bool" :> Get '[JSON] Bool
type CombinedAPI = ReaderAPI :<|> IdentityAPI
readerAPI :: Proxy ReaderAPI
readerAPI = Proxy
combinedAPI :: Proxy CombinedAPI
combinedAPI = Proxy
readerServer' :: ServerT ReaderAPI (Reader String)
readerServer' = return 1797 :<|> ask
fReader :: Reader String :~> EitherT ServantErr IO
fReader = generalizeNat C.. (runReaderTNat "hi")
readerServer :: Server ReaderAPI
readerServer = enter fReader readerServer'
combinedReaderServer' :: ServerT CombinedAPI (Reader String)
combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True)
combinedReaderServer :: Server CombinedAPI
combinedReaderServer = enter fReader combinedReaderServer'
enterSpec :: Spec
enterSpec = describe "Enter" $ do
with (return (serve readerAPI readerServer)) $ do
it "allows running arbitrary monads" $ do
get "int" `shouldRespondWith` "1797"
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 }
with (return (serve combinedAPI combinedReaderServer)) $ do
it "allows combnation of enters" $ do
get "bool" `shouldRespondWith` "true"

12
servant-server/test/Servant/ServerSpec.hs
View File

@ -35,13 +35,13 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders,
shouldRespondWith, with, (<:>)) shouldRespondWith, with, (<:>))
import Servant.API ((:<|>) (..), (:>), import Servant.API ((:<|>) (..), (:>),
AddHeader (addHeader), Capture, addHeader, Capture,
Delete, Get, Header (..), Headers, Delete, Get, Header (..), Headers,
JSON, MatrixFlag, MatrixParam, JSON, MatrixFlag, MatrixParam,
MatrixParams, Patch, PlainText, MatrixParams, Patch, PlainText,
Post, Put, QueryFlag, QueryParam, Post, Put, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody) QueryParams, Raw, ReqBody)
import Servant.Server (Server, serve) import Servant.Server (Server, serve, ServantErr(..), err404)
import Servant.Server.Internal (RouteMismatch (..)) import Servant.Server.Internal (RouteMismatch (..))
@ -96,11 +96,11 @@ spec = do
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
captureApi :: Proxy CaptureApi captureApi :: Proxy CaptureApi
captureApi = Proxy captureApi = Proxy
captureServer :: Integer -> EitherT (Int, String) IO Animal captureServer :: Integer -> EitherT ServantErr IO Animal
captureServer legs = case legs of captureServer legs = case legs of
4 -> return jerry 4 -> return jerry
2 -> return tweety 2 -> return tweety
_ -> left (404, "not found") _ -> left err404
captureSpec :: Spec captureSpec :: Spec
captureSpec = do captureSpec = do
@ -450,11 +450,11 @@ headerApi = Proxy
headerSpec :: Spec headerSpec :: Spec
headerSpec = describe "Servant.API.Header" $ do headerSpec = describe "Servant.API.Header" $ do
let expectsInt :: Maybe Int -> EitherT (Int,String) IO () let expectsInt :: Maybe Int -> EitherT ServantErr IO ()
expectsInt (Just x) = when (x /= 5) $ error "Expected 5" expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
expectsInt Nothing = error "Expected an int" expectsInt Nothing = error "Expected an int"
let expectsString :: Maybe String -> EitherT (Int,String) IO () let expectsString :: Maybe String -> EitherT ServantErr IO ()
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
expectsString Nothing = error "Expected a string" expectsString Nothing = error "Expected a string"

1
servant/CHANGELOG.md
View File

@ -1,6 +1,5 @@
0.3 0.3
--- ---
* Add a `Canonicalize` type family that distributes all `:>`s inside `:<|>`s to get to the canonical type of an API -- which is then used in all other packages to avoid weird handler types in *servant-server*.
* Multiple content-type/accept support for all the relevant combinators * Multiple content-type/accept support for all the relevant combinators
* Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box * Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box
* Type-safe link generation to API endpoints * Type-safe link generation to API endpoints

2
servant/shell.nix Normal file
View File

@ -0,0 +1,2 @@
with (import <nixpkgs> {}).pkgs;
(haskellngPackages.callPackage ./. {}).env

50
servant/src/Servant/API.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Servant.API ( module Servant.API (
@ -49,26 +49,21 @@ module Servant.API (
module Servant.Common.Text, module Servant.Common.Text,
-- | Classes and instances for types that can be converted to and from @Text@ -- | Classes and instances for types that can be converted to and from @Text@
-- * Canonicalizing (flattening) API types
Canonicalize,
canonicalize,
-- * Utilities -- * Utilities
module Servant.Utils.Links, module Servant.Utils.Links,
-- | Type-safe internal URIs -- | Type-safe internal URIs
) where ) where
import Data.Proxy (Proxy (..))
import Servant.API.Alternative ((:<|>) (..)) import Servant.API.Alternative ((:<|>) (..))
import Servant.API.Capture (Capture) import Servant.API.Capture (Capture)
import Servant.API.ContentTypes (FormUrlEncoded, import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON, FromFormUrlEncoded (..), JSON,
MimeRender (..), MimeRender (..),
MimeUnrender (..), OctetStream, MimeUnrender (..), OctetStream,
PlainText, ToFormUrlEncoded (..)) PlainText, ToFormUrlEncoded (..))
import Servant.API.Delete (Delete) import Servant.API.Delete (Delete)
import Servant.API.Get (Get) import Servant.API.Get (Get)
import Servant.API.Header (Header(..)) import Servant.API.Header (Header (..))
import Servant.API.MatrixParam (MatrixFlag, MatrixParam, import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
MatrixParams) MatrixParams)
import Servant.API.Patch (Patch) import Servant.API.Patch (Patch)
@ -78,40 +73,13 @@ import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams) QueryParams)
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
import Servant.API.ReqBody (ReqBody) import Servant.API.ReqBody (ReqBody)
import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse import Servant.API.ResponseHeaders (AddHeader (addHeader),
, AddHeader(addHeader) ) BuildHeadersTo (buildHeadersTo),
GetHeaders (getHeaders),
HList (..), Headers (..),
getHeadersHList, getResponse)
import Servant.API.Sub ((:>)) import Servant.API.Sub ((:>))
import Servant.Common.Text (FromText (..), ToText (..)) import Servant.Common.Text (FromText (..), ToText (..))
import Servant.Utils.Links (HasLink (..), IsElem, IsElem', import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
URI (..), safeLink) URI (..), safeLink)
-- | Turn an API type into its canonical form.
--
-- The canonical form of an API type is basically the all-flattened form
-- of the original type. More formally, it takes a type as input and hands you
-- back an /equivalent/ type formed of toplevel `:<|>`-separated chains of `:>`s,
-- i.e with all `:>`s distributed inside the `:<|>`s.
--
-- It basically turns:
--
-- > "hello" :> (Get Hello :<|> ReqBody Hello :> Put Hello)
--
-- into
--
-- > ("hello" :> Get Hello) :<|> ("hello" :> ReqBody Hello :> Put Hello)
--
-- i.e distributing all ':>'-separated bits into the subsequent ':<|>'s.
type family Canonicalize api :: * where
-- requires UndecidableInstances
Canonicalize (a :> (b :<|> c)) = a :> Canonicalize b :<|> a :> Canonicalize c
Canonicalize ((a :<|> b) :> c) = a :> Canonicalize c :<|> b :> Canonicalize c
Canonicalize (a :> b) = Redex b (Canonicalize b) a
Canonicalize (a :<|> b) = Canonicalize a :<|> Canonicalize b
Canonicalize a = a
type family Redex a b c :: * where
Redex a a first = Canonicalize first :> a
Redex a b first = Canonicalize (first :> b)
canonicalize :: Proxy layout -> Proxy (Canonicalize layout)
canonicalize Proxy = Proxy

1
servant/src/Servant/API/Alternative.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Alternative ((:<|>)(..)) where module Servant.API.Alternative ((:<|>)(..)) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)

1
servant/src/Servant/API/Capture.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Capture (Capture) where module Servant.API.Capture (Capture) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/ContentTypes.hs
View File

@ -10,6 +10,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | A collection of basic Content-Types (also known as Internet Media -- | A collection of basic Content-Types (also known as Internet Media
-- Types, or MIME types). Additionally, this module provides classes that -- Types, or MIME types). Additionally, this module provides classes that

1
servant/src/Servant/API/Delete.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Delete (Delete) where module Servant.API.Delete (Delete) where
import Data.Typeable ( Typeable ) import Data.Typeable ( Typeable )

1
servant/src/Servant/API/Get.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Get (Get) where module Servant.API.Get (Get) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

11
servant/src/Servant/API/Header.hs
View File

@ -1,10 +1,13 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Header where module Servant.API.Header where
import Data.Typeable (Typeable) import Data.ByteString (ByteString)
import GHC.TypeLits (Symbol) import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
-- | Extract the given header's value as a value of type @a@. -- | Extract the given header's value as a value of type @a@.
-- --
-- Example: -- Example:
@ -14,7 +17,9 @@ import GHC.TypeLits (Symbol)
-- >>> -- GET /view-my-referer -- >>> -- GET /view-my-referer
-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
data Header (sym :: Symbol) a = Header a data Header (sym :: Symbol) a = Header a
deriving Typeable | MissingHeader
| UndecodableHeader ByteString
deriving (Typeable, Eq, Show, Functor)
-- $setup -- $setup
-- >>> import Servant.API -- >>> import Servant.API

1
servant/src/Servant/API/MatrixParam.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/Patch.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Patch (Patch) where module Servant.API.Patch (Patch) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/Post.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Post (Post) where module Servant.API.Post (Post) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

5
servant/src/Servant/API/Put.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Put (Put) where module Servant.API.Put (Put) where
import Data.Typeable ( Typeable ) import Data.Typeable ( Typeable )

1
servant/src/Servant/API/QueryParam.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/Raw.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Raw where module Servant.API.Raw where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/API/ReqBody.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.ReqBody where module Servant.API.ReqBody where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

131
servant/src/Servant/API/ResponseHeaders.hs
View File

@ -9,11 +9,13 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverlappingInstances #-}
#endif #endif
{-# OPTIONS_HADDOCK not-home #-}
-- | This module provides facilities for adding headers to a response. -- | This module provides facilities for adding headers to a response.
-- --
@ -22,14 +24,20 @@
-- The value is added to the header specified by the type (@Location@ in the -- The value is added to the header specified by the type (@Location@ in the
-- example above). -- example above).
module Servant.API.ResponseHeaders module Servant.API.ResponseHeaders
( Headers ( Headers(..)
, getResponse
, getHeaders
, AddHeader(addHeader) , AddHeader(addHeader)
, BuildHeadersTo(buildHeadersTo)
, GetHeaders(getHeaders)
, HeaderValMap
, HList(..)
) where ) where
import Data.ByteString.Char8 (pack) #if !MIN_VERSION_base(4,8,0)
import Data.ByteString.Conversion (ToByteString, toByteString') import Control.Applicative ((<$>))
#endif
import Data.ByteString.Char8 as BS (pack, unlines, init)
import Data.ByteString.Conversion (ToByteString, toByteString',
FromByteString, fromByteString)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.Proxy import Data.Proxy
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
@ -41,27 +49,102 @@ import Servant.API.Header (Header (..))
-- Instead, use 'addHeader'. -- Instead, use 'addHeader'.
data Headers ls a = Headers { getResponse :: a data Headers ls a = Headers { getResponse :: a
-- ^ The underlying value of a 'Headers' -- ^ The underlying value of a 'Headers'
, getHeaders :: [HTTP.Header] , getHeadersHList :: HList ls
-- ^ The list of header values of a 'Headers'. -- ^ HList of headers.
-- These are guaranteed to correspond with the } deriving (Functor)
-- first type of @Headers@ if constructed with
-- 'addHeader'.
} deriving (Eq, Show, Functor)
-- We need all these fundeps to save type inference data HList a where
class AddHeader h v orig new HNil :: HList '[]
| h v orig -> new, new -> h, new -> v, new -> orig where HCons :: Header h x -> HList xs -> HList (Header h x ': xs)
addHeader :: v -> orig -> new
type family HeaderValMap (f :: * -> *) (xs :: [*]) where
HeaderValMap f '[] = '[]
HeaderValMap f (Header h x ': xs) = Header h (f x) ': (HeaderValMap f xs)
class BuildHeadersTo hs where
buildHeadersTo :: [HTTP.Header] -> HList hs
-- ^ Note: if there are multiple occurences of a header in the argument,
-- the values are interspersed with commas before deserialization (see
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
( KnownSymbol h, ToByteString v BuildHeadersTo '[] where
) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where buildHeadersTo _ = HNil
addHeader a (Headers resp heads) = Headers resp ((headerName, toByteString' a) : heads)
where instance
headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) #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
buildHeadersTo headers =
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers
in case matching of
[] -> MissingHeader `HCons` buildHeadersTo headers
xs -> case fromByteString (BS.init $ BS.unlines xs) of
Nothing -> UndecodableHeader (BS.init $ BS.unlines xs)
`HCons` buildHeadersTo headers
Just h -> Header h `HCons` buildHeadersTo headers
-- * Getting
class GetHeaders ls where
getHeaders :: ls -> [HTTP.Header]
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
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
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
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
getHeaders hs = getHeaders $ getHeadersHList hs
-- * Adding
-- We need all these fundeps to save type inference
class AddHeader h v orig new
| h v orig -> new, new -> h, new -> v, new -> orig where
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
addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -70,10 +153,12 @@ instance
( KnownSymbol h, ToByteString v ( KnownSymbol h, ToByteString v
, new ~ (Headers '[Header h v] a) , new ~ (Headers '[Header h v] a)
) => AddHeader h v a new where ) => AddHeader h v a new where
addHeader a resp = Headers resp [(headerName, toByteString' a)] addHeader a resp = Headers resp (HCons (Header a) HNil)
where
headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
type family Contains x xs where
Contains x ((Header x a) ': xs) = 'True
Contains x ((Header y a) ': xs) = Contains x xs
Contains x '[] = 'False
-- $setup -- $setup
-- >>> import Servant.API -- >>> import Servant.API

1
servant/src/Servant/API/Sub.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Sub ((:>)) where module Servant.API.Sub ((:>)) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)

1
servant/src/Servant/Utils/Links.hs
View File

@ -8,6 +8,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | Type safe generation of internal links. -- | Type safe generation of internal links.
-- --

2
sources.txt
View File

@ -4,3 +4,5 @@ servant-docs
servant-jquery servant-jquery
servant-server servant-server
servant-examples servant-examples
servant-blaze
servant-lucid