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
*.aux
*.hp
Setup

4
scripts/shell.nix
View file

@ -13,10 +13,8 @@ let modifiedHaskellPackages = haskellngPackages.override {
../servant-jquery {}) "--ghc-options=-Werror";
servant-docs = appendConfigureFlag (self.callPackage ../servant-docs
{}) "--ghc-options=-Werror";
servant-examples = appendConfigureFlag (self.callPackage ../servant-examples
{}) "--ghc-options=-Werror";
};
};
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)
* Support for PATCH
* 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
-----

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

@ -16,11 +16,13 @@
module Servant.Client
( client
, HasClient(..)
, Client
, ServantError(..)
, module Servant.Common.BaseUrl
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad
import Control.Monad.Trans.Either
import Data.ByteString.Lazy (ByteString)
@ -32,8 +34,8 @@ import GHC.TypeLits
import Network.HTTP.Client (Response)
import Network.HTTP.Media
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
import Servant.API
import Servant.API.ContentTypes
import Servant.Common.BaseUrl
import Servant.Common.Req
@ -50,17 +52,16 @@ import Servant.Common.Req
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
client p = clientWithRoute (canonicalize p) defReq
client :: HasClient layout => Proxy layout -> Client layout
client p = clientWithRoute p defReq
-- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'.
class HasClient layout where
type Client' layout :: *
clientWithRoute :: Proxy layout -> Req -> Client' layout
type 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
-- 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
-- > (getAllBooks :<|> postNewBook) = client myApi
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 :: Proxy a) 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)
=> HasClient (Capture capture a :> sublayout) where
type Client' (Capture capture a :> sublayout) =
a -> Client' sublayout
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req val =
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
-- and port to send the request to.
instance HasClient Delete where
type Client' Delete = BaseUrl -> EitherT ServantError IO ()
type Client Delete = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host =
void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
@ -131,21 +132,36 @@ instance
{-# OVERLAPPABLE #-}
#endif
(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 =
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
-- HTTP header.
-- HTTP status.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
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 =
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,
-- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'Header',
@ -174,8 +190,8 @@ instance
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (Header sym a :> sublayout) where
type Client' (Header sym a :> sublayout) =
Maybe a -> Client' sublayout
type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout
clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -192,10 +208,10 @@ instance
{-# OVERLAPPABLE #-}
#endif
(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 =
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
-- HTTP header.
@ -204,10 +220,25 @@ instance
{-# OVERLAPPING #-}
#endif
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 =
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
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
@ -217,10 +248,10 @@ instance
{-# OVERLAPPABLE #-}
#endif
(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 =
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
-- HTTP header.
@ -229,10 +260,25 @@ instance
{-# OVERLAPPING #-}
#endif
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 =
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
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
@ -242,10 +288,10 @@ instance
{-# OVERLAPPABLE #-}
#endif
(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 =
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
-- HTTP header.
@ -254,10 +300,25 @@ instance
{-# OVERLAPPING #-}
#endif
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 =
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,
-- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'QueryParam',
@ -286,8 +347,8 @@ instance
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParam sym a :> sublayout) where
type Client' (QueryParam sym a :> sublayout) =
Maybe a -> Client' sublayout
type Client (QueryParam sym a :> sublayout) =
Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
@ -328,8 +389,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParams sym a :> sublayout) where
type Client' (QueryParams sym a :> sublayout) =
[a] -> Client' sublayout
type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -363,8 +424,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (QueryFlag sym :> sublayout) where
type Client' (QueryFlag sym :> sublayout) =
Bool -> Client' sublayout
type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout
clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -402,8 +463,8 @@ instance (KnownSymbol sym, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (MatrixParam sym a :> sublayout) where
type Client' (MatrixParam sym a :> sublayout) =
Maybe a -> Client' sublayout
type Client (MatrixParam sym a :> sublayout) =
Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
@ -443,8 +504,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (MatrixParams sym a :> sublayout) where
type Client' (MatrixParams sym a :> sublayout) =
[a] -> Client' sublayout
type Client (MatrixParams sym a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -478,8 +539,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (MatrixFlag sym :> sublayout) where
type Client' (MatrixFlag sym :> sublayout) =
Bool -> Client' sublayout
type Client (MatrixFlag sym :> sublayout) =
Bool -> Client sublayout
clientWithRoute Proxy req flag =
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
-- back the full `Response`.
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
performRequest httpMethod req (const True) host
@ -519,8 +580,8 @@ instance HasClient Raw where
instance (MimeRender ct a, HasClient sublayout)
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where
type Client' (ReqBody (ct ': cts) a :> sublayout) =
a -> Client' sublayout
type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req body =
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.
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 :: 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.Media
import Network.HTTP.Types
import qualified Network.HTTP.Types.Header as HTTP
import Network.URI
import Servant.API.ContentTypes
import Servant.Common.BaseUrl
@ -136,7 +137,9 @@ displayHttpRequest :: Method -> String
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
partialRequest <- liftIO $ reqToRequest req reqHost
@ -154,6 +157,7 @@ performRequest reqMethod req isWantedStatus reqHost = do
Right response -> do
let status = Client.responseStatus response
body = Client.responseBody response
hrds = Client.responseHeaders response
status_code = statusCode status
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream"
@ -162,20 +166,19 @@ performRequest reqMethod req isWantedStatus reqHost = do
Just t' -> pure t'
unless (isWantedStatus status_code) $
left $ FailureResponse status ct body
return (status_code, body, ct, response)
return (status_code, body, ct, hrds, response)
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
let acceptCT = contentType ct
(_status, respBody, respCT, _response) <-
(_status, respBody, respCT, hrds, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
unless (matches respCT (acceptCT)) $
left $ UnsupportedContentType respCT respBody
either
(left . (\s -> DecodeFailure s respCT respBody))
return
(mimeUnrender ct respBody)
unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> left $ DecodeFailure err respCT respBody
Right val -> return (hrds, val)
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
performRequestNoBody reqMethod req wantedStatus reqHost = do

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

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

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."
Normal
instance ToSample Greet where
toSample = Just $ Greet "Hello, haskeller!"
instance ToSample Greet Greet where
toSample _ = Just $ Greet "Hello, haskeller!"
toSamples =
toSamples _ =
[ ("If you use ?capital=true", 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
-- documentation.
--
@ -84,7 +87,7 @@ type TestApi =
-- POST /greet with a Greet as JSON in the request body,
-- 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
:<|> "greet" :> Capture "greetid" Text :> Delete

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

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

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

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

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

@ -26,7 +26,7 @@ isGoodCookie = return . (== "good password")
data AuthProtected
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 =
case lookup "Cookie" (requestHeaders request) of
@ -75,4 +75,4 @@ $ curl -H "Cookie: good password" http://localhost:8080/private
[{"ssshhh":"this is a secret"}]
$ curl -H "Cookie: bad password" http://localhost:8080/private
Invalid cookie.
-}
-}

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

@ -26,8 +26,8 @@ import Data.Proxy
import Servant.API
import Servant.JQuery.Internal
jquery :: HasJQ (Canonicalize layout) => Proxy layout -> JQ layout
jquery p = jqueryFor (canonicalize p) defReq
jquery :: HasJQ layout => Proxy layout -> JQ layout
jquery p = jqueryFor p defReq
-- js codegen
generateJS :: AjaxReq -> String
@ -112,6 +112,5 @@ instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where
-- | Directly generate all the javascript functions for your API
-- from a 'Proxy' for your API type. You can then write it to
-- a file or integrate it in a page, for example.
jsForAPI :: (HasJQ (Canonicalize api), GenerateCode (JQ api))
=> Proxy api -> String
jsForAPI :: (HasJQ api, GenerateCode (JQ api)) => Proxy api -> String
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
class HasJQ (layout :: *) where
type JQ' layout :: *
jqueryFor :: Proxy layout -> AjaxReq -> JQ' layout
type JQ layout = JQ' (Canonicalize layout)
type JQ layout :: *
jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
instance (HasJQ a, HasJQ b)
=> 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 :: Proxy a) req
@ -209,7 +207,7 @@ instance (HasJQ a, HasJQ b)
instance (KnownSymbol sym, HasJQ sublayout)
=> 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 :: Proxy sublayout) $
@ -218,14 +216,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
where str = symbolVal (Proxy :: Proxy sym)
instance HasJQ Delete where
type JQ' Delete = AjaxReq
type JQ Delete = AjaxReq
jqueryFor Proxy req =
req & funcName %~ ("delete" <>)
& reqMethod .~ "DELETE"
instance Elem JSON list => HasJQ (Get list a) where
type JQ' (Get list a) = AjaxReq
type JQ (Get list a) = AjaxReq
jqueryFor Proxy req =
req & funcName %~ ("get" <>)
@ -233,7 +231,7 @@ instance Elem JSON list => HasJQ (Get list a) where
instance (KnownSymbol sym, HasJQ sublayout)
=> 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 subP (req & reqHeaders <>~ [HeaderArg hname])
@ -242,14 +240,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
subP = Proxy :: Proxy sublayout
instance Elem JSON list => HasJQ (Post list a) where
type JQ' (Post list a) = AjaxReq
type JQ (Post list a) = AjaxReq
jqueryFor Proxy req =
req & funcName %~ ("post" <>)
& reqMethod .~ "POST"
instance Elem JSON list => HasJQ (Put list a) where
type JQ' (Put list a) = AjaxReq
type JQ (Put list a) = AjaxReq
jqueryFor Proxy req =
req & funcName %~ ("put" <>)
@ -257,7 +255,7 @@ instance Elem JSON list => HasJQ (Put list a) where
instance (KnownSymbol sym, HasJQ sublayout)
=> 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 :: Proxy sublayout) $
@ -267,7 +265,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> 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 :: Proxy sublayout) $
@ -277,7 +275,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (QueryFlag sym :> sublayout) where
type JQ' (QueryFlag sym :> sublayout) = JQ' sublayout
type JQ (QueryFlag sym :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -287,7 +285,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> 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 :: Proxy sublayout) $
@ -298,7 +296,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> 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 :: Proxy sublayout) $
@ -308,7 +306,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (MatrixFlag sym :> sublayout) where
type JQ' (MatrixFlag sym :> sublayout) = JQ' sublayout
type JQ (MatrixFlag sym :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -317,14 +315,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
where str = symbolVal (Proxy :: Proxy sym)
instance HasJQ Raw where
type JQ' Raw = Method -> AjaxReq
type JQ Raw = Method -> AjaxReq
jqueryFor Proxy req method =
req & funcName %~ ((toLower <$> method) <>)
& reqMethod .~ method
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 :: Proxy sublayout) $
@ -332,7 +330,7 @@ instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout
instance (KnownSymbol path, HasJQ sublayout)
=> HasJQ (path :> sublayout) where
type JQ' (path :> sublayout) = JQ' sublayout
type JQ (path :> sublayout) = JQ sublayout
jqueryFor Proxy req =
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)
=> 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) $
req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
@ -35,7 +35,7 @@ data MyLovelyHorse a
instance (HasJQ sublayout)
=> 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) $
req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ]
@ -47,7 +47,7 @@ data WhatsForDinner a
instance (HasJQ sublayout)
=> 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) $
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*
* 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)
* 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)
* 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
-----

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

@ -36,6 +36,8 @@ library
Servant
Servant.Server
Servant.Server.Internal
Servant.Server.Internal.ServantErr
Servant.Server.Internal.Enter
Servant.Utils.StaticFiles
build-depends:
base >= 4.7 && < 5
@ -45,6 +47,8 @@ library
, either >= 4.3 && < 4.4
, http-types >= 0.8 && < 0.9
, network-uri >= 2.6 && < 2.7
, mtl >= 2 && < 3
, mmorph >= 1
, safe >= 0.3 && < 0.4
, servant >= 0.2 && < 0.4
, split >= 0.2 && < 0.3
@ -100,6 +104,18 @@ test-suite spec
, temporary
, text
, transformers
, mtl
, wai
, wai-extra
, 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 FlexibleContexts #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
-- | This module lets you implement 'Server's for defined APIs. You'll
-- most likely just need 'serve'.
@ -14,13 +15,73 @@ module Servant.Server
, -- * Handlers for all standard combinators
HasServer(..)
, 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
import Data.Proxy (Proxy)
import Network.Wai (Application)
import Servant.API (Canonicalize, canonicalize)
import Servant.Server.Internal
import Data.Proxy (Proxy)
import Network.Wai (Application)
import Servant.Server.Internal
import Servant.Server.Internal.Enter
import Servant.Server.Internal.ServantErr
-- * Implementing Servers
@ -45,5 +106,30 @@ import Servant.Server.Internal
-- >
-- > main :: IO ()
-- > 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,
strictRequestBody)
import Servant.API ((:<|>) (..), (:>), Capture,
Canonicalize, Delete, Get, Header,
Delete, Get, Header,
MatrixFlag, MatrixParam, MatrixParams,
Patch, Post, Put, QueryFlag,
QueryParam, QueryParams, Raw,
@ -46,9 +46,12 @@ import Servant.API ((:<|>) (..), (:>), Capture,
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..))
import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
getHeaders)
import Servant.Common.Text (FromText, fromText)
import Servant.Server.Internal.ServantErr
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
@ -174,13 +177,11 @@ processedPathInfo r =
where pinfo = parsePathInfo r
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 (Int, String) IO)
type ServerT layout m = ServerT' (Canonicalize layout) m
type Server layout = ServerT layout (EitherT ServantErr IO)
-- * Instances
@ -197,7 +198,7 @@ type ServerT layout m = ServerT' (Canonicalize layout) m
-- > postBook book = ...
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 pa a request $ \mResponse ->
@ -231,8 +232,8 @@ captured _ = fromText
instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where
type ServerT' (Capture capture a :> sublayout) m =
a -> ServerT' sublayout m
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of
(first : rest)
@ -259,16 +260,14 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
-- are not met.
instance HasServer Delete where
type ServerT' Delete m = m ()
type ServerT Delete m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ succeedWith $ case e of
Right () ->
responseLBS status204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
Right () -> responseLBS status204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -292,7 +291,7 @@ instance
#endif
( 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
| pathIsEmpty request && requestMethod request == methodGet = do
@ -304,8 +303,7 @@ instance
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -317,15 +315,14 @@ instance
#endif
HasServer (Get ctypes ()) where
type ServerT' (Get ctypes ()) m = m ()
type ServerT (Get ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -335,9 +332,10 @@ instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#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
| pathIsEmpty request && requestMethod request == methodGet = do
@ -350,8 +348,7 @@ instance
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -379,8 +376,8 @@ instance
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where
type ServerT' (Header sym a :> sublayout) m =
Maybe a -> ServerT' sublayout m
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
@ -408,7 +405,7 @@ instance
( AllCTRender ctypes a
) => 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
| pathIsEmpty request && requestMethod request == methodPost = do
@ -420,8 +417,7 @@ instance
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -432,15 +428,14 @@ instance
#endif
HasServer (Post ctypes ()) where
type ServerT' (Post ctypes ()) m = m ()
type ServerT (Post ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -450,9 +445,10 @@ instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#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
| pathIsEmpty request && requestMethod request == methodPost = do
@ -465,8 +461,7 @@ instance
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -490,7 +485,7 @@ instance
#endif
( 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
| pathIsEmpty request && requestMethod request == methodPut = do
@ -502,8 +497,7 @@ instance
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -514,15 +508,14 @@ instance
#endif
HasServer (Put ctypes ()) where
type ServerT' (Put ctypes ()) m = m ()
type ServerT (Put ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -532,9 +525,10 @@ instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#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
| pathIsEmpty request && requestMethod request == methodPut = do
@ -547,8 +541,7 @@ instance
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -570,7 +563,7 @@ instance
#endif
( 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
| pathIsEmpty request && requestMethod request == methodPatch = do
@ -582,8 +575,7 @@ instance
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -594,15 +586,14 @@ instance
#endif
HasServer (Patch ctypes ()) where
type ServerT' (Patch ctypes ()) m = m ()
type ServerT (Patch ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -612,9 +603,10 @@ instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#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
| pathIsEmpty request && requestMethod request == methodPatch = do
@ -627,8 +619,7 @@ instance
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left (status, message) -> succeedWith $
responseLBS (mkStatus status (cs message)) [] (cs message)
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
@ -657,8 +648,8 @@ instance
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where
type ServerT' (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT' sublayout m
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
@ -695,8 +686,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where
type ServerT' (QueryParams sym a :> sublayout) m =
[a] -> ServerT' sublayout m
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
@ -728,8 +719,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where
type ServerT' (QueryFlag sym :> sublayout) m =
Bool -> ServerT' sublayout m
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
@ -771,8 +762,8 @@ parseMatrixText = parseQueryText
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParam sym a :> sublayout) where
type ServerT' (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT' sublayout m
type ServerT (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
@ -809,8 +800,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParams sym a :> sublayout) where
type ServerT' (MatrixParams sym a :> sublayout) m =
[a] -> ServerT' sublayout m
type ServerT (MatrixParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
@ -843,8 +834,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (MatrixFlag sym :> sublayout) where
type ServerT' (MatrixFlag sym :> sublayout) m =
Bool -> ServerT' sublayout m
type ServerT (MatrixFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
@ -872,7 +863,7 @@ instance (KnownSymbol sym, HasServer sublayout)
-- > server = serveDirectory "/var/www/images"
instance HasServer Raw where
type ServerT' Raw m = Application
type ServerT Raw m = Application
route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith)
@ -900,8 +891,8 @@ instance HasServer Raw where
instance ( AllCTUnrender list a, HasServer sublayout
) => HasServer (ReqBody list a :> sublayout) where
type ServerT' (ReqBody list a :> sublayout) m =
a -> ServerT' sublayout m
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
route Proxy subserver request respond = do
-- 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@.
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
(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, (<:>))
import Servant.API ((:<|>) (..), (:>),
AddHeader (addHeader), Capture,
addHeader, Capture,
Delete, Get, Header (..), Headers,
JSON, MatrixFlag, MatrixParam,
MatrixParams, Patch, PlainText,
Post, Put, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody)
import Servant.Server (Server, serve)
import Servant.Server (Server, serve, ServantErr(..), err404)
import Servant.Server.Internal (RouteMismatch (..))
@ -96,11 +96,11 @@ spec = do
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
captureApi :: Proxy CaptureApi
captureApi = Proxy
captureServer :: Integer -> EitherT (Int, String) IO Animal
captureServer :: Integer -> EitherT ServantErr IO Animal
captureServer legs = case legs of
4 -> return jerry
2 -> return tweety
_ -> left (404, "not found")
_ -> left err404
captureSpec :: Spec
captureSpec = do
@ -450,11 +450,11 @@ headerApi = Proxy
headerSpec :: Spec
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 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 Nothing = error "Expected a string"

1
servant/CHANGELOG.md
View file

@ -1,6 +1,5 @@
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
* Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box
* 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 TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.API (
@ -49,26 +49,21 @@ module Servant.API (
module Servant.Common.Text,
-- | Classes and instances for types that can be converted to and from @Text@
-- * Canonicalizing (flattening) API types
Canonicalize,
canonicalize,
-- * Utilities
module Servant.Utils.Links,
-- | Type-safe internal URIs
) where
import Data.Proxy (Proxy (..))
import Servant.API.Alternative ((:<|>) (..))
import Servant.API.Capture (Capture)
import Servant.API.ContentTypes (FormUrlEncoded,
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON,
MimeRender (..),
MimeUnrender (..), OctetStream,
PlainText, ToFormUrlEncoded (..))
import Servant.API.Delete (Delete)
import Servant.API.Get (Get)
import Servant.API.Header (Header(..))
import Servant.API.Header (Header (..))
import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
MatrixParams)
import Servant.API.Patch (Patch)
@ -78,40 +73,13 @@ import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams)
import Servant.API.Raw (Raw)
import Servant.API.ReqBody (ReqBody)
import Servant.API.ResponseHeaders ( Headers, getHeaders, getResponse
, AddHeader(addHeader) )
import Servant.API.ResponseHeaders (AddHeader (addHeader),
BuildHeadersTo (buildHeadersTo),
GetHeaders (getHeaders),
HList (..), Headers (..),
getHeadersHList, getResponse)
import Servant.API.Sub ((:>))
import Servant.Common.Text (FromText (..), ToText (..))
import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
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 DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Alternative ((:<|>)(..)) where
#if !MIN_VERSION_base(4,8,0)

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

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

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

@ -10,6 +10,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | A collection of basic Content-Types (also known as Internet Media
-- 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 #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Delete (Delete) where
import Data.Typeable ( Typeable )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -9,11 +9,13 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# OPTIONS_HADDOCK not-home #-}
-- | 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
-- example above).
module Servant.API.ResponseHeaders
( Headers
, getResponse
, getHeaders
( Headers(..)
, AddHeader(addHeader)
, BuildHeadersTo(buildHeadersTo)
, GetHeaders(getHeaders)
, HeaderValMap
, HList(..)
) where
import Data.ByteString.Char8 (pack)
import Data.ByteString.Conversion (ToByteString, toByteString')
#if !MIN_VERSION_base(4,8,0)
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 Data.Proxy
import GHC.TypeLits (KnownSymbol, symbolVal)
@ -41,27 +49,102 @@ import Servant.API.Header (Header (..))
-- Instead, use 'addHeader'.
data Headers ls a = Headers { getResponse :: a
-- ^ The underlying value of a 'Headers'
, getHeaders :: [HTTP.Header]
-- ^ The list of header values of a 'Headers'.
-- These are guaranteed to correspond with the
-- first type of @Headers@ if constructed with
-- 'addHeader'.
} deriving (Eq, Show, Functor)
, getHeadersHList :: HList ls
-- ^ HList of headers.
} deriving (Functor)
-- 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
data HList a where
HNil :: HList '[]
HCons :: Header h x -> HList xs -> HList (Header h x ': xs)
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
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( KnownSymbol h, ToByteString v
) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
addHeader a (Headers resp heads) = Headers resp ((headerName, toByteString' a) : heads)
where
headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
BuildHeadersTo '[] where
buildHeadersTo _ = HNil
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False
) => BuildHeadersTo ((Header h v) ': xs) where
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
#if MIN_VERSION_base(4,8,0)
@ -70,10 +153,12 @@ instance
( KnownSymbol h, ToByteString v
, new ~ (Headers '[Header h v] a)
) => AddHeader h v a new where
addHeader a resp = Headers resp [(headerName, toByteString' a)]
where
headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
addHeader a resp = Headers resp (HCons (Header a) HNil)
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
-- >>> import Servant.API

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

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

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

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

2
sources.txt
View file

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