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

Merge branch 'master' into existential-error

Browse source
This commit is contained in:
Christian Marie 2015-06-12 19:56:49 +10:00
commit ad16c4f768
35 changed files with 757 additions and 516 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
.gitignore vendored
View file

@ -1,8 +1,8 @@
dist /dist
bin /bin
lib /lib
share /share
packages /packages
*-packages.conf.d *-packages.conf.d
cabal-dev cabal-dev
add-source-timestamps add-source-timestamps

61
scripts/bump-versions.sh Executable file
View file

@ -0,0 +1,61 @@
#!/bin/bash -
#===============================================================================
#
# FILE: bump-versions.sh
#
# USAGE: ./bump-versions.sh
#
# DESCRIPTION: Bump the versions for all servant packages
#
# OPTIONS: See usage
# REQUIREMENTS: bumper, bash >= 4
# CREATED: 11.05.2015 21:36
# REVISION: ---
#===============================================================================
set -o nounset
set -o errexit
. lib/common.sh
usage () {
echo " bump-versions.sh <POSITION> [-d|--dry-run]"
echo " | [-h|--help]"
echo " Bumps the specified positional version of all servant packages."
echo " POSITION is a number between 0 and 3, inclusive."
exit 0
}
if [ $# -eq 0 ] ; then
echo "expecting one or more arguments. Got 0"
usage
elif [ $# -gt 2 ] ; then
echo "expecting one or more arguments"
usage
fi
versions_equal
while [ "${1:-unset}" != "unset" ] ; do
case "$1" in
-h | --help) usage ;;
-d | --dry-run) DRY_RUN=true
shift ;;
0) if POSITION="none" ; then POSITION=0 ; else usage ; fi
shift ;;
1) if POSITION="none" ; then POSITION=1 ; else usage ; fi
shift ;;
2) if POSITION="none" ; then POSITION=2 ; else usage ; fi
shift ;;
3) if POSITION="none" ; then POSITION=3 ; else usage ; fi
shift ;;
*) usage ;;
esac
done
if $DRY_RUN ; then
bumper --dry-run -"$POSITION" $(join , "${SOURCES[@]}")
else
bumper -"$POSITION" $(join , "${SOURCES[@]}")
fi

31
scripts/lib/common.sh Normal file
View file

@ -0,0 +1,31 @@
#!/bin/bash -
#===============================================================================
#
# FILE: lib/common.sh
#
# DESCRIPTION: Common functions for servant's shell scripts
# Meant to be sourced rather than run.
#
# REQUIREMENTS: bash >= 4
#===============================================================================
DIR=$( dirname $( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ))
DRY_RUN=false
POSITION="none"
SOURCES_TXT="$( dirname $DIR)/sources.txt"
CABAL=${CABAL:-cabal}
declare -a SOURCES
readarray -t SOURCES < "$SOURCES_TXT"
join () { local IFS="$1"; shift; echo "$*"; }
versions_equal () {
local NUM=$(find . -name 'servant*.cabal' | xargs grep "^version:" | awk '{ print $2 }' | uniq -c | wc -l)
if [ 1 -eq $NUM ] ; then
return 0
else
echo "versions of packages are not all the same!" && exit 1
fi
}

6
scripts/start-sandbox.sh
View file

@ -14,11 +14,7 @@ set -o nounset
set -o errexit set -o errexit
DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
SOURCES_TXT="$( dirname $DIR)/sources.txt" . "$DIR"/lib/common.sh
CABAL=${CABAL:-cabal}
declare -a SOURCES
readarray -t SOURCES < "$SOURCES_TXT"
prepare_sandbox () { prepare_sandbox () {
$CABAL sandbox init $CABAL sandbox init

8
scripts/test-all.sh
View file

@ -15,13 +15,9 @@ set -o nounset
set -o errexit set -o errexit
DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
. "$DIR"/lib/common.sh
GHC_FLAGS="-Werror" GHC_FLAGS="-Werror"
SOURCES_TXT="$( dirname $DIR)/sources.txt"
CABAL=${CABAL:-cabal}
declare -a SOURCES
readarray -t SOURCES < "$SOURCES_TXT"
prepare_sandbox () { prepare_sandbox () {
$CABAL sandbox init $CABAL sandbox init

6
scripts/update-defaults-nix.sh
View file

@ -12,11 +12,7 @@ set -o nounset
set -o errexit set -o errexit
DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
BASE_DIR="$( dirname $DIR)" . "$DIR"/lib/common.sh
SOURCES_TXT="$BASE_DIR/sources.txt"
declare -a SOURCES
readarray -t SOURCES < "$SOURCES_TXT"
for s in ${SOURCES[@]} ; do for s in ${SOURCES[@]} ; do
echo $s echo $s

52
scripts/upload.sh Executable file
View file

@ -0,0 +1,52 @@
#!/bin/bash -
#===============================================================================
#
# FILE: upload.sh
#
# USAGE: ./upload.sh <USER> <PASSWORD>
#
# DESCRIPTION: Uploads all servant packages to Hackage
#
# REQUIREMENTS: cabal, bash >= 4
# AUTHOR: Julian K. Arni
# CREATED: 05.06.2015 13:05
#===============================================================================
set -o nounset
set -o errexit
DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
. "$DIR"/lib/common.sh
usage () {
echo " upload.sh <USER> <PASSWORD>"
echo " Uploads all servant packages to Hackage"
exit 0
}
upload_package () {
local package="$1"
local user="$2"
local pass="$3"
local cabalFile="$package.cabal"
pushd "$package"
local version=$(grep -i '^version:' $cabalFile | awk '{ print $2 }')
local sdist="dist/${package}-${version}.tar.gz"
cabal sdist
echo "User is: $user"
cabal upload --user="$user" --password="$pass" "$sdist"
popd
}
if [ $# -ne 2 ] ; then
echo "expecting two arguments."
usage
fi
versions_equal
for s in ${SOURCES[@]} ; do
upload_package "$s" "$1" "$2"
done

2
servant-blaze/servant-blaze.cabal
View file

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/ -- documentation, see http://haskell.org/cabal/users-guide/
name: servant-blaze name: servant-blaze
version: 0.4.0.0 version: 0.4.1
synopsis: Blaze-html support for servant synopsis: Blaze-html support for servant
-- description: -- description:
homepage: http://haskell-servant.github.io/ homepage: http://haskell-servant.github.io/

2
servant-blaze/src/Servant/HTML/Blaze.hs
View file

@ -25,7 +25,7 @@ import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
data HTML deriving Typeable data HTML deriving Typeable
-- | @text/plain;charset=utf-8@ -- | @text/html;charset=utf-8@
instance Accept HTML where instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8") contentType _ = "text" M.// "html" M./: ("charset", "utf-8")

4
servant-client/CHANGELOG.md
View file

@ -1,3 +1,7 @@
0.4.1
-----
* The `HasClient` instance for `Delete cts ()` now does not care at all about content types provided.
0.4 0.4
--- ---
* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

5
servant-client/servant-client.cabal
View file

@ -1,5 +1,5 @@
name: servant-client name: servant-client
version: 0.4.0 version: 0.4.1
synopsis: automatical derivation of querying functions for servant webservices synopsis: automatical derivation of querying functions for servant webservices
description: description:
This library lets you derive automatically Haskell functions that This library lets you derive automatically Haskell functions that
@ -56,6 +56,9 @@ test-suite spec
default-language: Haskell2010 default-language: Haskell2010
hs-source-dirs: test hs-source-dirs: test
main-is: Spec.hs main-is: Spec.hs
other-modules:
Servant.ClientSpec
, Servant.Common.BaseUrlSpec
build-depends: build-depends:
base == 4.* base == 4.*
, aeson , aeson

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

@ -7,6 +7,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverlappingInstances #-}
#endif #endif
@ -126,8 +127,9 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
type Client (Delete (ct ': cts) a) = EitherT ServantError IO a (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
type Client (Delete cts' a) = EitherT ServantError IO a
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
@ -137,8 +139,8 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Delete (ct ': cts) ()) where HasClient (Delete cts ()) where
type Client (Delete (ct ': cts) ()) = EitherT ServantError IO () type Client (Delete cts ()) = EitherT ServantError IO ()
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl =
void $ performRequestNoBody H.methodDelete req [204] baseurl void $ performRequestNoBody H.methodDelete req [204] baseurl
@ -148,9 +150,10 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
( MimeUnrender ct a, BuildHeadersTo ls -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
) => HasClient (Delete (ct ': cts) (Headers ls a)) where ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a) ) => HasClient (Delete cts' (Headers ls a)) where
type Client (Delete cts' (Headers ls a)) = EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
return $ Headers { getResponse = resp return $ Headers { getResponse = resp

32
servant-client/src/Servant/Common/BaseUrl.hs
View file

@ -1,8 +1,19 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveGeneric #-}
module Servant.Common.BaseUrl where {-# LANGUAGE ViewPatterns #-}
module Servant.Common.BaseUrl (
-- * types
BaseUrl (..)
, InvalidBaseUrlException
, Scheme (..)
-- * functions
, parseBaseUrl
, showBaseUrl
) where
import Control.Monad.Catch (MonadThrow, throwM, Exception)
import Data.List import Data.List
import Data.Typeable
import GHC.Generics import GHC.Generics
import Network.URI import Network.URI
import Safe import Safe
@ -34,20 +45,23 @@ showBaseUrl (BaseUrl urlscheme host port) =
(Https, 443) -> "" (Https, 443) -> ""
_ -> ":" ++ show port _ -> ":" ++ show port
parseBaseUrl :: String -> Either String BaseUrl data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)
instance Exception InvalidBaseUrlException
parseBaseUrl :: MonadThrow m => String -> m BaseUrl
parseBaseUrl s = case parseURI (removeTrailingSlash s) of parseBaseUrl s = case parseURI (removeTrailingSlash s) of
-- This is a rather hacky implementation and should be replaced with something -- This is a rather hacky implementation and should be replaced with something
-- implemented in attoparsec (which is already a dependency anyhow (via aeson)). -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
Right (BaseUrl Http host port) return (BaseUrl Http host port)
Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") -> Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
Right (BaseUrl Http host 80) return (BaseUrl Http host 80)
Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
Right (BaseUrl Https host port) return (BaseUrl Https host port)
Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
Right (BaseUrl Https host 443) return (BaseUrl Https host 443)
_ -> if "://" `isInfixOf` s _ -> if "://" `isInfixOf` s
then Left ("invalid base url: " ++ s) then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)
else parseBaseUrl ("http://" ++ s) else parseBaseUrl ("http://" ++ s)
where where
removeTrailingSlash str = case lastMay str of removeTrailingSlash str = case lastMay str of

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

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -18,6 +19,7 @@ import Data.String.Conversions
import Data.Proxy import Data.Proxy
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding import Data.Text.Encoding
import Data.Typeable
import Network.HTTP.Client hiding (Proxy) import Network.HTTP.Client hiding (Proxy)
import Network.HTTP.Client.TLS import Network.HTTP.Client.TLS
import Network.HTTP.Media import Network.HTTP.Media
@ -53,7 +55,9 @@ data ServantError
| ConnectionError | ConnectionError
{ connectionError :: String { connectionError :: String
} }
deriving (Show) deriving (Show, Typeable)
instance Exception ServantError
data Req = Req data Req = Req
{ reqPath :: String { reqPath :: String

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

@ -80,7 +80,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api = type Api =
"get" :> Get '[JSON] Person "get" :> Get '[JSON] Person
:<|> "delete" :> Delete '[JSON] () :<|> "deleteEmpty" :> Delete '[] ()
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@ -98,6 +98,7 @@ type Api =
ReqBody '[JSON] [(String, [Rational])] :> ReqBody '[JSON] [(String, [Rational])] :>
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
:<|> "deleteContentType" :> Delete '[JSON] ()
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
@ -123,6 +124,7 @@ server = serve api (
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d)) :<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return ()
) )
withServer :: (BaseUrl -> IO a) -> IO a withServer :: (BaseUrl -> IO a) -> IO a
@ -148,7 +150,7 @@ withFailServer action = withWaiDaemon (return failServer) action
spec :: IO () spec :: IO ()
spec = withServer $ \ baseUrl -> do spec = withServer $ \ baseUrl -> do
let getGet :: EitherT ServantError IO Person let getGet :: EitherT ServantError IO Person
getDelete :: EitherT ServantError IO () getDeleteEmpty :: EitherT ServantError IO ()
getCapture :: String -> EitherT ServantError IO Person getCapture :: String -> EitherT ServantError IO Person
getBody :: Person -> EitherT ServantError IO Person getBody :: Person -> EitherT ServantError IO Person
getQueryParam :: Maybe String -> EitherT ServantError IO Person getQueryParam :: Maybe String -> EitherT ServantError IO Person
@ -161,8 +163,9 @@ spec = withServer $ \ baseUrl -> do
getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString) getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])]) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool) getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool)
getDeleteContentType :: EitherT ServantError IO ()
( getGet ( getGet
:<|> getDelete :<|> getDeleteEmpty
:<|> getCapture :<|> getCapture
:<|> getBody :<|> getBody
:<|> getQueryParam :<|> getQueryParam
@ -174,15 +177,20 @@ spec = withServer $ \ baseUrl -> do
:<|> getRawSuccess :<|> getRawSuccess
:<|> getRawFailure :<|> getRawFailure
:<|> getMultiple :<|> getMultiple
:<|> getRespHeaders) :<|> getRespHeaders
:<|> getDeleteContentType)
= client api baseUrl = client api baseUrl
hspec $ do hspec $ do
it "Servant.API.Get" $ do it "Servant.API.Get" $ do
(Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice
it "Servant.API.Delete" $ do describe "Servant.API.Delete" $ do
(Arrow.left show <$> runEitherT getDelete) `shouldReturn` Right () it "allows empty content type" $ do
(Arrow.left show <$> runEitherT getDeleteEmpty) `shouldReturn` Right ()
it "allows content type" $ do
(Arrow.left show <$> runEitherT getDeleteContentType) `shouldReturn` Right ()
it "Servant.API.Capture" $ do it "Servant.API.Capture" $ do
(Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0) (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
@ -274,11 +282,11 @@ spec = withServer $ \ baseUrl -> do
failSpec :: IO () failSpec :: IO ()
failSpec = withFailServer $ \ baseUrl -> do failSpec = withFailServer $ \ baseUrl -> do
let getGet :: EitherT ServantError IO Person let getGet :: EitherT ServantError IO Person
getDelete :: EitherT ServantError IO () getDeleteEmpty :: EitherT ServantError IO ()
getCapture :: String -> EitherT ServantError IO Person getCapture :: String -> EitherT ServantError IO Person
getBody :: Person -> EitherT ServantError IO Person getBody :: Person -> EitherT ServantError IO Person
( getGet ( getGet
:<|> getDelete :<|> getDeleteEmpty
:<|> getCapture :<|> getCapture
:<|> getBody :<|> getBody
:<|> _ ) :<|> _ )
@ -289,7 +297,7 @@ failSpec = withFailServer $ \ baseUrl -> do
hspec $ do hspec $ do
context "client returns errors appropriately" $ do context "client returns errors appropriately" $ do
it "reports FailureResponse" $ do it "reports FailureResponse" $ do
Left res <- runEitherT getDelete Left res <- runEitherT getDeleteEmpty
case res of case res of
FailureResponse (Status 404 "Not Found") _ _ -> return () FailureResponse (Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res _ -> fail $ "expected 404 response, but got " <> show res

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

@ -1,5 +1,5 @@
name: servant-docs name: servant-docs
version: 0.4.0 version: 0.4.1
synopsis: generate API docs for your servant webservice synopsis: generate API docs for your servant webservice
description: description:
Library for generating API docs from a servant API definition. Library for generating API docs from a servant API definition.

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

@ -28,14 +28,15 @@ data AuthProtected
instance HasServer rest => HasServer (AuthProtected :> rest) where instance HasServer rest => HasServer (AuthProtected :> rest) where
type ServerT (AuthProtected :> rest) m = ServerT rest m type ServerT (AuthProtected :> rest) m = ServerT rest m
route Proxy a request respond = route Proxy a = WithRequest $ \ request ->
case lookup "Cookie" (requestHeaders request) of route (Proxy :: Proxy rest) $ do
Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header." case lookup "Cookie" (requestHeaders request) of
Just v -> do Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.")
authGranted <- isGoodCookie v Just v -> do
if authGranted authGranted <- isGoodCookie v
then route (Proxy :: Proxy rest) a request respond if authGranted
else respond . succeedWith $ responseLBS status403 [] "Invalid cookie." then a
else return $ failWith $ HttpError status403 (Just "Invalid cookie.")
type PrivateAPI = Get '[JSON] [PrivateData] type PrivateAPI = Get '[JSON] [PrivateData]

24
servant-examples/servant-examples.cabal
View file

@ -1,5 +1,5 @@
name: servant-examples name: servant-examples
version: 0.4 version: 0.4.1
synopsis: Example programs for servant synopsis: Example programs for servant
description: Example programs for servant, description: Example programs for servant,
showcasing solutions to common needs. showcasing solutions to common needs.
@ -26,11 +26,11 @@ executable tutorial
, js-jquery , js-jquery
, lucid , lucid
, random , random
, servant , servant == 0.4.*
, servant-docs , servant-docs == 0.4.*
, servant-jquery , servant-jquery == 0.4.*
, servant-lucid , servant-lucid == 0.4.*
, servant-server , servant-server == 0.4.*
, text , text
, time , time
, transformers , transformers
@ -47,9 +47,9 @@ executable t8-main
aeson aeson
, base >= 4.7 && < 5 , base >= 4.7 && < 5
, either , either
, servant , servant == 0.4.*
, servant-client , servant-client == 0.4.*
, servant-server , servant-server == 0.4.*
, wai , wai
executable hackage executable hackage
@ -70,8 +70,8 @@ executable wai-middleware
build-depends: build-depends:
aeson >= 0.8 aeson >= 0.8
, base >= 4.7 && < 5 , base >= 4.7 && < 5
, servant , servant == 0.4.*
, servant-server , servant-server == 0.4.*
, text , text
, wai , wai
, wai-extra , wai-extra
@ -86,7 +86,7 @@ executable auth-combinator
, base >= 4.7 && < 5 , base >= 4.7 && < 5
, bytestring , bytestring
, http-types , http-types
, servant , servant == 0.4.*
, servant-server == 0.4.* , servant-server == 0.4.*
, text , text
, wai , wai

2
servant-jquery/servant-jquery.cabal
View file

@ -1,5 +1,5 @@
name: servant-jquery name: servant-jquery
version: 0.4.0 version: 0.4.1
synopsis: Automatically derive (jquery) javascript functions to query servant webservices synopsis: Automatically derive (jquery) javascript functions to query servant webservices
description: description:
Automatically derive jquery-based javascript functions to query servant webservices. Automatically derive jquery-based javascript functions to query servant webservices.

2
servant-lucid/servant-lucid.cabal
View file

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/ -- documentation, see http://haskell.org/cabal/users-guide/
name: servant-lucid name: servant-lucid
version: 0.4.0.0 version: 0.4.1
synopsis: Servant support for lucid synopsis: Servant support for lucid
-- description: -- description:
homepage: http://haskell-servant.github.io/ homepage: http://haskell-servant.github.io/

2
servant-lucid/src/Servant/HTML/Lucid.hs
View file

@ -24,7 +24,7 @@ import Servant.API (Accept (..), MimeRender (..))
data HTML deriving Typeable data HTML deriving Typeable
-- | @text/plain;charset=utf-8@ -- | @text/html;charset=utf-8@
instance Accept HTML where instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8") contentType _ = "text" M.// "html" M./: ("charset", "utf-8")

6
servant-server/CHANGELOG.md
View file

@ -1,3 +1,9 @@
0.4.1
-----
* Bump attoparsec upper bound to < 0.14
* Bump wai-app-static upper bound to < 3.2
* Bump either upper bound to < 4.5
0.4 0.4
--- ---
* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

2
servant-server/example/greet.hs
View file

@ -44,7 +44,7 @@ testApi = Proxy
-- There's one handler per endpoint, which, just like in the type -- There's one handler per endpoint, which, just like in the type
-- that represents the API, are glued together using :<|>. -- that represents the API, are glued together using :<|>.
-- --
-- Each handler runs in the 'EitherT (Int, String) IO' monad. -- Each handler runs in the 'EitherT ServantErr IO' monad.
server :: Server TestApi server :: Server TestApi
server = helloH :<|> postGreetH :<|> deleteGreetH server = helloH :<|> postGreetH :<|> deleteGreetH

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

@ -1,5 +1,5 @@
name: servant-server name: servant-server
version: 0.4.0 version: 0.4.1
synopsis: A family of combinators for defining webservices APIs and serving them synopsis: A family of combinators for defining webservices APIs and serving them
description: description:
A family of combinators for defining webservices APIs and serving them A family of combinators for defining webservices APIs and serving them
@ -35,15 +35,19 @@ library
Servant Servant
Servant.Server Servant.Server
Servant.Server.Internal Servant.Server.Internal
Servant.Server.Internal.ServantErr
Servant.Server.Internal.Enter Servant.Server.Internal.Enter
Servant.Server.Internal.PathInfo
Servant.Server.Internal.Router
Servant.Server.Internal.RoutingApplication
Servant.Server.Internal.ServantErr
Servant.Utils.StaticFiles Servant.Utils.StaticFiles
build-depends: build-depends:
base >= 4.7 && < 5 base >= 4.7 && < 5
, aeson >= 0.7 && < 0.9 , aeson >= 0.7 && < 0.10
, attoparsec >= 0.12 && < 0.13 , attoparsec >= 0.12 && < 0.14
, bytestring >= 0.10 && < 0.11 , bytestring >= 0.10 && < 0.11
, either >= 4.3 && < 4.4 , containers >= 0.5 && < 0.6
, either >= 4.3 && < 4.5
, http-types >= 0.8 && < 0.9 , http-types >= 0.8 && < 0.9
, network-uri >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7
, mtl >= 2 && < 3 , mtl >= 2 && < 3
@ -51,7 +55,7 @@ library
, safe >= 0.3 && < 0.4 , safe >= 0.3 && < 0.4
, servant == 0.4.* , servant == 0.4.*
, split >= 0.2 && < 0.3 , split >= 0.2 && < 0.3
, string-conversions >= 0.3 && < 0.4 , string-conversions >= 0.3 && < 0.5
, system-filepath >= 0.4 && < 0.5 , system-filepath >= 0.4 && < 0.5
, filepath >= 1 , filepath >= 1
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3

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

@ -81,7 +81,6 @@ import Data.Proxy (Proxy)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.Server.Internal import Servant.Server.Internal
import Servant.Server.Internal.Enter import Servant.Server.Internal.Enter
import Servant.Server.Internal.ServantErr
-- * Implementing Servers -- * Implementing Servers
@ -108,7 +107,7 @@ import Servant.Server.Internal.ServantErr
-- > main = Network.Wai.Handler.Warp.run 8080 app -- > main = Network.Wai.Handler.Warp.run 8080 app
-- --
serve :: HasServer layout => Proxy layout -> Server layout -> Application serve :: HasServer layout => Proxy layout -> Server layout -> Application
serve p server = toApplication (route p server) serve p server = toApplication (runRouter (route p (return (RR (Right server)))))
-- Documentation -- Documentation

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

@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -11,17 +12,20 @@
{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverlappingInstances #-}
#endif #endif
module Servant.Server.Internal where module Servant.Server.Internal
( module Servant.Server.Internal
, module Servant.Server.Internal.PathInfo
, module Servant.Server.Internal.Router
, module Servant.Server.Internal.RoutingApplication
, module Servant.Server.Internal.ServantErr
) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.Monoid (Monoid, mappend, mempty)
#endif #endif
import Control.Monad.Trans.Either (EitherT, runEitherT) import Control.Monad.Trans.Either (EitherT)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (unfoldr)
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe)
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs, (<>)) import Data.String.Conversions (cs, (<>))
@ -31,12 +35,9 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Wai (Application, Request, Response, import Network.Wai (Application, lazyRequestBody,
ResponseReceived, lazyRequestBody, rawQueryString, requestHeaders,
pathInfo, rawQueryString, requestMethod, responseLBS)
requestBody, requestHeaders,
requestMethod, responseLBS,
strictRequestBody)
import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API ((:<|>) (..), (:>), Capture,
Delete, Get, Header, Delete, Get, Header,
MatrixFlag, MatrixParam, MatrixParams, MatrixFlag, MatrixParam, MatrixParams,
@ -50,136 +51,15 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
getHeaders) getHeaders)
import Servant.Common.Text (FromText, fromText) import Servant.Common.Text (FromText, fromText)
import Servant.Server.Internal.PathInfo
import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
reqBodyRef <- newIORef Uncalled
-- We may need to consume the requestBody more than once. In order to
-- maintain the illusion that 'requestBody' works as expected,
-- 'ReqBodyState' is introduced, and the complete body is memoized and
-- returned as many times as requested with empty "Done" marker chunks in
-- between.
-- See https://github.com/haskell-servant/servant/issues/3
let memoReqBody = do
ior <- readIORef reqBodyRef
case ior of
Uncalled -> do
r <- BL.toStrict <$> strictRequestBody request
writeIORef reqBodyRef $ Done r
return r
Called bs -> do
writeIORef reqBodyRef $ Done bs
return bs
Done bs -> do
writeIORef reqBodyRef $ Called bs
return B.empty
ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
where
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
routingRespond (Left NotFound) =
respond $ responseLBS notFound404 [] "not found"
routingRespond (Left WrongMethod) =
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
routingRespond (Left (InvalidBody err)) =
respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
routingRespond (Left UnsupportedMediaType) =
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
routingRespond (Left (HttpError status body)) =
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
routingRespond (Right response) =
respond response
-- Note that the ordering of the constructors has great significance! It
-- determines the Ord instance and, consequently, the monoid instance.
-- * Route mismatch
data RouteMismatch =
NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
| UnsupportedMediaType -- ^ request body has unsupported media type
| InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
| HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
deriving (Eq, Ord, Show)
instance Monoid RouteMismatch where
mempty = NotFound
-- The following isn't great, since it picks @InvalidBody@ based on
-- alphabetical ordering, but any choice would be arbitrary.
--
-- "As one judge said to the other, 'Be just and if you can't be just, be
-- arbitrary'" -- William Burroughs
mappend = max
-- | A wrapper around @'Either' 'RouteMismatch' a@.
newtype RouteResult a =
RR { routeResult :: Either RouteMismatch a }
deriving (Eq, Show)
failWith :: RouteMismatch -> RouteResult a
failWith = RR . Left
succeedWith :: a -> RouteResult a
succeedWith = RR . Right
isMismatch :: RouteResult a -> Bool
isMismatch (RR (Left _)) = True
isMismatch _ = False
-- | Like `null . pathInfo`, but works with redundant trailing slashes.
pathIsEmpty :: Request -> Bool
pathIsEmpty = f . processedPathInfo
where
f [] = True
f [""] = True
f _ = False
-- | If we get a `Right`, it has precedence over everything else.
--
-- This in particular means that if we could get several 'Right's,
-- only the first we encounter would be taken into account.
instance Monoid (RouteResult a) where
mempty = RR $ Left mempty
RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
RR (Left _) `mappend` RR (Right y) = RR $ Right y
r `mappend` _ = r
type RoutingApplication =
Request -- ^ the request, the field 'pathInfo' may be modified by url routing
-> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
splitMatrixParameters :: Text -> (Text, Text)
splitMatrixParameters = T.break (== ';')
parsePathInfo :: Request -> [Text]
parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
where mergePairs = concat . unfoldr pairToList
pairToList [] = Nothing
pairToList ((a, b):xs) = Just ([a, b], xs)
-- | Returns a processed pathInfo from the request.
--
-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
-- processed, so routing works as intended. Therefor this function should be used to access
-- the pathInfo for routing purposes.
processedPathInfo :: Request -> [Text]
processedPathInfo r =
case pinfo of
(x:xs) | T.head x == ';' -> xs
_ -> pinfo
where pinfo = parsePathInfo r
class HasServer layout where class HasServer layout where
type ServerT layout (m :: * -> *) :: * type ServerT layout (m :: * -> *) :: *
route :: Proxy layout -> Server layout -> RoutingApplication route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router
type Server layout = ServerT layout (EitherT ServantErr IO) type Server layout = ServerT layout (EitherT ServantErr IO)
@ -200,12 +80,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy (a :<|> b) request respond = route Proxy server = choice (route pa (extractL <$> server))
route pa a request $ \mResponse -> (route pb (extractR <$> server))
if isMismatch mResponse
then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
else respond mResponse
where pa = Proxy :: Proxy a where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b pb = Proxy :: Proxy b
@ -227,7 +103,7 @@ captured _ = fromText
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBook -- > server = getBook
-- > where getBook :: Text -> EitherT (Int, String) IO Book -- > where getBook :: Text -> EitherT ServantErr IO Book
-- > getBook isbn = ... -- > getBook isbn = ...
instance (KnownSymbol capture, FromText a, HasServer sublayout) instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where => HasServer (Capture capture a :> sublayout) where
@ -235,25 +111,72 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
type ServerT (Capture capture a :> sublayout) m = type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver =
(first : rest) DynamicRouter $ \ first ->
-> case captured captureProxy first of route (Proxy :: Proxy sublayout)
Nothing -> respond $ failWith NotFound (case captured captureProxy first of
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ Nothing -> return $ failWith NotFound
pathInfo = rest Just v -> feedTo subserver v)
} respond
_ -> respond $ failWith NotFound
where captureProxy = Proxy :: Proxy (Capture capture a) where captureProxy = Proxy :: Proxy (Capture capture a)
methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status
-> IO (RouteResult (EitherT ServantErr IO a))
-> Router
methodRouter method proxy status action = LeafRouter route'
where
route' request respond
| pathIsEmpty request && requestMethod request == method = do
runAction action respond $ \ output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH proxy (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status [ ("Content-Type" , cs contentT)] body
| pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
=> Method -> Proxy ctypes -> Status
-> IO (RouteResult (EitherT ServantErr IO (Headers h v)))
-> Router
methodRouterHeaders method proxy status action = LeafRouter route'
where
route' request respond
| pathIsEmpty request && requestMethod request == method = do
runAction action respond $ \ output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status ( ("Content-Type" , cs contentT) : headers) body
| pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
methodRouterEmpty :: Method
-> IO (RouteResult (EitherT ServantErr IO ()))
-> Router
methodRouterEmpty method action = LeafRouter route'
where
route' request respond
| pathIsEmpty request && requestMethod request == method = do
runAction action respond $ \ () ->
succeedWith $ responseLBS noContent204 [] ""
| pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | If you have a 'Delete' endpoint in your API, -- | If you have a 'Delete' endpoint in your API,
-- the handler for this endpoint is meant to delete -- the handler for this endpoint is meant to delete
-- a resource. -- a resource.
-- --
-- The code of the handler will, just like -- The code of the handler will, just like
-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and -- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@. -- 'Servant.API.Put.Put', run in @EitherT ServantErr IO ()@.
-- The 'Int' represents the status code and the 'String' a message -- The 'Int' represents the status code and the 'String' a message
-- to be returned. You can use 'Control.Monad.Trans.Either.left' to -- to be returned. You can use 'Control.Monad.Trans.Either.left' to
-- painlessly error out if the conditions for a successful deletion -- painlessly error out if the conditions for a successful deletion
@ -267,20 +190,7 @@ instance
type ServerT (Delete ctypes a) m = m a type ServerT (Delete ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -290,15 +200,7 @@ instance
type ServerT (Delete ctypes ()) m = m () type ServerT (Delete ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodDelete
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -310,26 +212,12 @@ instance
type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Get' endpoint, -- | When implementing the handler for a 'Get' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
-- and 'Servant.API.Put.Put', the handler code runs in the -- and 'Servant.API.Put.Put', the handler code runs in the
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents -- @EitherT ServantErr IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of -- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
@ -347,20 +235,7 @@ instance
type ServerT (Get ctypes a) m = m a type ServerT (Get ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- '()' ==> 204 No Content -- '()' ==> 204 No Content
instance instance
@ -371,15 +246,7 @@ instance
type ServerT (Get ctypes ()) m = m () type ServerT (Get ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodGet
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -391,21 +258,7 @@ instance
type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | If you use 'Header' in one of the endpoints for your API, -- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -425,7 +278,7 @@ instance
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = viewReferer -- > server = viewReferer
-- > where viewReferer :: Referer -> EitherT (Int, String) IO referer -- > where viewReferer :: Referer -> EitherT ServantErr IO referer
-- > viewReferer referer = return referer -- > viewReferer referer = return referer
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where => HasServer (Header sym a :> sublayout) where
@ -433,16 +286,15 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (Header sym a :> sublayout) m = type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
route (Proxy :: Proxy sublayout) (subserver mheader) request respond in route (Proxy :: Proxy sublayout) (feedTo subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | When implementing the handler for a 'Post' endpoint, -- | When implementing the handler for a 'Post' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
-- and 'Servant.API.Put.Put', the handler code runs in the -- and 'Servant.API.Put.Put', the handler code runs in the
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents -- @EitherT ServantErr IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of -- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
@ -461,20 +313,7 @@ instance
type ServerT (Post ctypes a) m = m a type ServerT (Post ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -484,15 +323,7 @@ instance
type ServerT (Post ctypes ()) m = m () type ServerT (Post ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodPost
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -504,26 +335,12 @@ instance
type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Put' endpoint, -- | When implementing the handler for a 'Put' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
-- and 'Servant.API.Post.Post', the handler code runs in the -- and 'Servant.API.Post.Post', the handler code runs in the
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents -- @EitherT ServantErr IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of -- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
@ -541,20 +358,7 @@ instance
type ServerT (Put ctypes a) m = m a type ServerT (Put ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -564,15 +368,7 @@ instance
type ServerT (Put ctypes ()) m = m () type ServerT (Put ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodPut
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -584,26 +380,12 @@ instance
type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Patch' endpoint, -- | When implementing the handler for a 'Patch' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
-- and 'Servant.API.Put.Put', the handler code runs in the -- and 'Servant.API.Put.Put', the handler code runs in the
-- @EitherT (Int, String) IO@ monad, where the 'Int' represents -- @EitherT ServantErr IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of -- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
@ -619,20 +401,7 @@ instance
type ServerT (Patch ctypes a) m = m a type ServerT (Patch ctypes a) m = m a
route Proxy action request respond route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -642,15 +411,7 @@ instance
type ServerT (Patch ctypes ()) m = m () type ServerT (Patch ctypes ()) m = m ()
route Proxy action request respond route Proxy = methodRouterEmpty methodPatch
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers -- Add response headers
instance instance
@ -662,21 +423,7 @@ instance
type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond $ case e of
Right outpatch -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders outpatch
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -696,7 +443,7 @@ instance
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book] -- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]
-- > getBooksBy Nothing = ...return all books... -- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author... -- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
@ -705,7 +452,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (QueryParam sym a :> sublayout) m = type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
param = param =
case lookup paramname querytext of case lookup paramname querytext of
@ -713,9 +460,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
Just Nothing -> Nothing -- param present with no value -> Nothing Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> fromText v -- if present, we try to convert to Just (Just v) -> fromText v -- if present, we try to convert to
-- the right type -- the right type
in route (Proxy :: Proxy sublayout) (feedTo subserver param)
route (Proxy :: Proxy sublayout) (subserver param) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@ -735,7 +480,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book] -- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]
-- > getBooksBy authors = ...return all books by these authors... -- > getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where => HasServer (QueryParams sym a :> sublayout) where
@ -743,16 +488,14 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (QueryParams sym a :> sublayout) m = type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
-- if sym is "foo", we look for query string parameters -- if sym is "foo", we look for query string parameters
-- named "foo" or "foo[]" and call fromText on the -- named "foo" or "foo[]" and call fromText on the
-- corresponding values -- corresponding values
parameters = filter looksLikeParam querytext parameters = filter looksLikeParam querytext
values = catMaybes $ map (convert . snd) parameters values = catMaybes $ map (convert . snd) parameters
in route (Proxy :: Proxy sublayout) (feedTo subserver values)
route (Proxy :: Proxy sublayout) (subserver values) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing convert Nothing = Nothing
@ -768,7 +511,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooks -- > server = getBooks
-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book] -- > where getBooks :: Bool -> EitherT ServantErr IO [Book]
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where => HasServer (QueryFlag sym :> sublayout) where
@ -776,15 +519,13 @@ instance (KnownSymbol sym, HasServer sublayout)
type ServerT (QueryFlag sym :> sublayout) m = type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
param = case lookup paramname querytext of param = case lookup paramname querytext of
Just Nothing -> True -- param is there, with no value Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string Nothing -> False -- param not in the query string
in route (Proxy :: Proxy sublayout) (feedTo subserver param)
route (Proxy :: Proxy sublayout) (subserver param) request respond
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False | otherwise = False
@ -810,7 +551,7 @@ parseMatrixText = parseQueryText
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book] -- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]
-- > getBooksBy Nothing = ...return all books... -- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author... -- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
@ -819,16 +560,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (MatrixParam sym a :> sublayout) m = type ServerT (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver = WithRequest $ \ request ->
(first : _) case parsePathInfo request of
-> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first (first : _)
param = case lookup paramname querytext of -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first
Nothing -> Nothing -- param absent from the query string param = case lookup paramname querytext of
Just Nothing -> Nothing -- param present with no value -> Nothing Nothing -> Nothing -- param absent from the query string
Just (Just v) -> fromText v -- if present, we try to convert to Just Nothing -> Nothing -- param present with no value -> Nothing
-- the right type Just (Just v) -> fromText v -- if present, we try to convert to
route (Proxy :: Proxy sublayout) (subserver param) request respond -- the right type
_ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond route (Proxy :: Proxy sublayout) (feedTo subserver param)
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver Nothing)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@ -849,7 +591,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book] -- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]
-- > getBooksBy authors = ...return all books by these authors... -- > getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParams sym a :> sublayout) where => HasServer (MatrixParams sym a :> sublayout) where
@ -857,16 +599,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
type ServerT (MatrixParams sym a :> sublayout) m = type ServerT (MatrixParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver = WithRequest $ \ request ->
(first : _) case parsePathInfo request of
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first (first : _)
-- if sym is "foo", we look for matrix parameters -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
-- named "foo" or "foo[]" and call fromText on the -- if sym is "foo", we look for matrix parameters
-- corresponding values -- named "foo" or "foo[]" and call fromText on the
parameters = filter looksLikeParam matrixtext -- corresponding values
values = catMaybes $ map (convert . snd) parameters parameters = filter looksLikeParam matrixtext
route (Proxy :: Proxy sublayout) (subserver values) request respond values = catMaybes $ map (convert . snd) parameters
_ -> route (Proxy :: Proxy sublayout) (subserver []) request respond route (Proxy :: Proxy sublayout) (feedTo subserver values)
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
@ -883,7 +626,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooks -- > server = getBooks
-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book] -- > where getBooks :: Bool -> EitherT ServantErr IO [Book]
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (MatrixFlag sym :> sublayout) where => HasServer (MatrixFlag sym :> sublayout) where
@ -891,17 +634,18 @@ instance (KnownSymbol sym, HasServer sublayout)
type ServerT (MatrixFlag sym :> sublayout) m = type ServerT (MatrixFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver = WithRequest $ \ request ->
(first : _) case parsePathInfo request of
-> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first (first : _)
param = case lookup paramname matrixtext of -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first
Just Nothing -> True -- param is there, with no value param = case lookup paramname matrixtext of
Just (Just v) -> examine v -- param with a value Just Nothing -> True -- param is there, with no value
Nothing -> False -- param not in the query string Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string
route (Proxy :: Proxy sublayout) (subserver param) request respond
route (Proxy :: Proxy sublayout) (feedTo subserver param)
_ -> route (Proxy :: Proxy sublayout) (subserver False) request respond
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True examine v | v == "true" || v == "1" || v == "" = True
@ -919,8 +663,11 @@ instance HasServer Raw where
type ServerT Raw m = Application type ServerT Raw m = Application
route Proxy rawApplication request respond = route Proxy rawApplication = LeafRouter $ \ request respond -> do
rawApplication request (respond . succeedWith) r <- rawApplication
case r of
RR (Left err) -> respond $ failWith err
RR (Right app) -> app request (respond . succeedWith)
-- | If you use 'ReqBody' in one of the endpoints for your API, -- | If you use 'ReqBody' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -940,7 +687,7 @@ instance HasServer Raw where
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = postBook -- > server = postBook
-- > where postBook :: Book -> EitherT (Int, String) IO Book -- > where postBook :: Book -> EitherT ServantErr IO Book
-- > postBook book = ...insert into your db... -- > postBook book = ...insert into your db...
instance ( AllCTUnrender list a, HasServer sublayout instance ( AllCTUnrender list a, HasServer sublayout
) => HasServer (ReqBody list a :> sublayout) where ) => HasServer (ReqBody list a :> sublayout) where
@ -948,19 +695,20 @@ instance ( AllCTUnrender list a, HasServer sublayout
type ServerT (ReqBody list a :> sublayout) m = type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT sublayout m
route Proxy subserver request respond = do route Proxy subserver = WithRequest $ \ request ->
-- See HTTP RFC 2616, section 7.2.1 route (Proxy :: Proxy sublayout) $ do
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- See HTTP RFC 2616, section 7.2.1
-- See also "W3C Internet Media Type registration, consistency of use" -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-- http://www.w3.org/2001/tag/2002/0129-mime -- See also "W3C Internet Media Type registration, consistency of use"
let contentTypeH = fromMaybe "application/octet-stream" -- http://www.w3.org/2001/tag/2002/0129-mime
$ lookup hContentType $ requestHeaders request let contentTypeH = fromMaybe "application/octet-stream"
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) $ lookup hContentType $ requestHeaders request
<$> lazyRequestBody request mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
case mrqbody of <$> lazyRequestBody request
Nothing -> respond . failWith $ UnsupportedMediaType case mrqbody of
Just (Left e) -> respond . failWith $ InvalidBody e Nothing -> return $ failWith $ UnsupportedMediaType
Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond Just (Left e) -> return $ failWith $ InvalidBody e
Just (Right v) -> feedTo subserver v
-- | Make sure the incoming request starts with @"/path"@, strip it and -- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@. -- pass the rest of the request path to @sublayout@.
@ -968,14 +716,9 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
type ServerT (path :> sublayout) m = ServerT sublayout m type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver = StaticRouter $
(first : rest) M.singleton (cs (symbolVal proxyPath))
| first == cs (symbolVal proxyPath) (route (Proxy :: Proxy sublayout) subserver)
-> route (Proxy :: Proxy sublayout) subserver request{
pathInfo = rest
} respond
_ -> respond $ failWith NotFound
where proxyPath = Proxy :: Proxy path where proxyPath = Proxy :: Proxy path
ct_wildcard :: B.ByteString ct_wildcard :: B.ByteString

38
servant-server/src/Servant/Server/Internal/PathInfo.hs Normal file
View file

@ -0,0 +1,38 @@
{-# LANGUAGE OverloadedStrings #-}
module Servant.Server.Internal.PathInfo where
import Data.List (unfoldr)
import Data.Text (Text)
import qualified Data.Text as T
import Network.Wai (Request, pathInfo)
-- | Like `null . pathInfo`, but works with redundant trailing slashes.
pathIsEmpty :: Request -> Bool
pathIsEmpty = f . processedPathInfo
where
f [] = True
f [""] = True
f _ = False
splitMatrixParameters :: Text -> (Text, Text)
splitMatrixParameters = T.break (== ';')
parsePathInfo :: Request -> [Text]
parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo
where mergePairs = concat . unfoldr pairToList
pairToList [] = Nothing
pairToList ((a, b):xs) = Just ([a, b], xs)
-- | Returns a processed pathInfo from the request.
--
-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be
-- processed, so routing works as intended. Therefor this function should be used to access
-- the pathInfo for routing purposes.
processedPathInfo :: Request -> [Text]
processedPathInfo r =
case pinfo of
(x:xs) | T.head x == ';' -> xs
_ -> pinfo
where pinfo = parsePathInfo r

72
servant-server/src/Servant/Server/Internal/Router.hs Normal file
View file

@ -0,0 +1,72 @@
module Servant.Server.Internal.Router where
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Text (Text)
import Network.Wai (Request, pathInfo)
import Servant.Server.Internal.PathInfo
import Servant.Server.Internal.RoutingApplication
-- | Internal representation of a router.
data Router =
WithRequest (Request -> Router)
-- ^ current request is passed to the router
| StaticRouter (Map Text Router)
-- ^ first path component used for lookup and removed afterwards
| DynamicRouter (Text -> Router)
-- ^ first path component used for lookup and removed afterwards
| LeafRouter RoutingApplication
-- ^ to be used for routes that match an empty path
| Choice Router Router
-- ^ left-biased choice between two routers
-- | Smart constructor for the choice between routers.
-- We currently optimize the following cases:
--
-- * Two static routers can be joined by joining their maps.
-- * Two dynamic routers can be joined by joining their codomains.
-- * Two 'WithRequest' routers can be joined by passing them
-- the same request and joining their codomains.
-- * A 'WithRequest' router can be joined with anything else by
-- passing the same request to both but ignoring it in the
-- component that does not need it.
--
choice :: Router -> Router -> Router
choice (StaticRouter table1) (StaticRouter table2) =
StaticRouter (M.unionWith choice table1 table2)
choice (DynamicRouter fun1) (DynamicRouter fun2) =
DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
choice (WithRequest router1) (WithRequest router2) =
WithRequest (\ request -> choice (router1 request) (router2 request))
choice (WithRequest router1) router2 =
WithRequest (\ request -> choice (router1 request) router2)
choice router1 (WithRequest router2) =
WithRequest (\ request -> choice router1 (router2 request))
choice router1 router2 = Choice router1 router2
-- | Interpret a router as an application.
runRouter :: Router -> RoutingApplication
runRouter (WithRequest router) request respond =
runRouter (router request) request respond
runRouter (StaticRouter table) request respond =
case processedPathInfo request of
first : rest
| Just router <- M.lookup first table
-> let request' = request { pathInfo = rest }
in runRouter router request' respond
_ -> respond $ failWith NotFound
runRouter (DynamicRouter fun) request respond =
case processedPathInfo request of
first : rest
-> let request' = request { pathInfo = rest }
in runRouter (fun first) request' respond
_ -> respond $ failWith NotFound
runRouter (LeafRouter app) request respond = app request respond
runRouter (Choice r1 r2) request respond =
runRouter r1 request $ \ mResponse1 ->
if isMismatch mResponse1
then runRouter r2 request $ \ mResponse2 ->
respond (mResponse1 <> mResponse2)
else respond mResponse1

144
servant-server/src/Servant/Server/Internal/RoutingApplication.hs Normal file
View file

@ -0,0 +1,144 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.Internal.RoutingApplication where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>))
import Data.Monoid (Monoid, mappend, mempty)
#endif
import Control.Monad.Trans.Either (EitherT, runEitherT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.String (fromString)
import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Wai (Application, Request, Response,
ResponseReceived,
requestBody,
responseLBS,
strictRequestBody)
import Servant.API ((:<|>) (..))
import Servant.Server.Internal.ServantErr
type RoutingApplication =
Request -- ^ the request, the field 'pathInfo' may be modified by url routing
-> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
-- | A wrapper around @'Either' 'RouteMismatch' a@.
newtype RouteResult a =
RR { routeResult :: Either RouteMismatch a }
deriving (Eq, Show, Functor, Applicative)
-- | If we get a `Right`, it has precedence over everything else.
--
-- This in particular means that if we could get several 'Right's,
-- only the first we encounter would be taken into account.
instance Monoid (RouteResult a) where
mempty = RR $ Left mempty
RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
RR (Left _) `mappend` RR (Right y) = RR $ Right y
r `mappend` _ = r
-- Note that the ordering of the constructors has great significance! It
-- determines the Ord instance and, consequently, the monoid instance.
data RouteMismatch =
NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
| UnsupportedMediaType -- ^ request body has unsupported media type
| InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
| HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
deriving (Eq, Ord, Show)
instance Monoid RouteMismatch where
mempty = NotFound
-- The following isn't great, since it picks @InvalidBody@ based on
-- alphabetical ordering, but any choice would be arbitrary.
--
-- "As one judge said to the other, 'Be just and if you can't be just, be
-- arbitrary'" -- William Burroughs
mappend = max
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
reqBodyRef <- newIORef Uncalled
-- We may need to consume the requestBody more than once. In order to
-- maintain the illusion that 'requestBody' works as expected,
-- 'ReqBodyState' is introduced, and the complete body is memoized and
-- returned as many times as requested with empty "Done" marker chunks in
-- between.
-- See https://github.com/haskell-servant/servant/issues/3
let memoReqBody = do
ior <- readIORef reqBodyRef
case ior of
Uncalled -> do
r <- BL.toStrict <$> strictRequestBody request
writeIORef reqBodyRef $ Done r
return r
Called bs -> do
writeIORef reqBodyRef $ Done bs
return bs
Done bs -> do
writeIORef reqBodyRef $ Called bs
return B.empty
ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
where
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
routingRespond (Left NotFound) =
respond $ responseLBS notFound404 [] "not found"
routingRespond (Left WrongMethod) =
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
routingRespond (Left (InvalidBody err)) =
respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
routingRespond (Left UnsupportedMediaType) =
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
routingRespond (Left (HttpError status body)) =
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
routingRespond (Right response) =
respond response
runAction :: IO (RouteResult (EitherT ServantErr IO a))
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction action respond k = do
r <- action
go r
where
go (RR (Right a)) = do
e <- runEitherT a
respond $ case e of
Right x -> k x
Left err -> succeedWith $ responseServantErr err
go (RR (Left err)) = respond $ failWith err
feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
feedTo f x = (($ x) <$>) <$> f
extractL :: RouteResult (a :<|> b) -> RouteResult a
extractL (RR (Right (a :<|> _))) = RR (Right a)
extractL (RR (Left err)) = RR (Left err)
extractR :: RouteResult (a :<|> b) -> RouteResult b
extractR (RR (Right (_ :<|> b))) = RR (Right b)
extractR (RR (Left err)) = RR (Left err)
failWith :: RouteMismatch -> RouteResult a
failWith = RR . Left
succeedWith :: a -> RouteResult a
succeedWith = RR . Right
isMismatch :: RouteResult a -> Bool
isMismatch (RR (Left _)) = True
isMismatch _ = False

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

@ -42,7 +42,8 @@ import Servant.API ((:<|>) (..), (:>),
Post, Put, QueryFlag, QueryParam, Post, Put, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody) QueryParams, Raw, ReqBody)
import Servant.Server (Server, serve, ServantErr(..), err404) import Servant.Server (Server, serve, ServantErr(..), err404)
import Servant.Server.Internal (RouteMismatch (..)) import Servant.Server.Internal.RoutingApplication
(RouteMismatch (..))
-- * test data types -- * test data types
@ -89,6 +90,7 @@ spec = do
headerSpec headerSpec
rawSpec rawSpec
unionSpec unionSpec
prioErrorsSpec
errorsSpec errorsSpec
responseHeadersSpec responseHeadersSpec
@ -572,6 +574,54 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415 `shouldRespondWith` 415
type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
prioErrorsApi :: Proxy PrioErrorsApi
prioErrorsApi = Proxy
-- | Test the relative priority of error responses from the server.
--
-- In particular, we check whether matching continues even if a 'ReqBody'
-- or similar construct is encountered early in a path. We don't want to
-- see a complaint about the request body unless the path actually matches.
--
prioErrorsSpec :: Spec
prioErrorsSpec = describe "PrioErrors" $ do
let server = return . age
with (return $ serve prioErrorsApi server) $ do
let check (mdescr, method) path (cdescr, ctype, body) resp =
it fulldescr $
Test.Hspec.Wai.request method path [(hContentType, ctype)] body
`shouldRespondWith` resp
where
fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
++ " " ++ cs path ++ " (" ++ cdescr ++ ")"
get' = ("GET", methodGet)
put' = ("PUT", methodPut)
txt = ("text" , "text/plain;charset=utf8" , "42" )
ijson = ("invalid json", "application/json;charset=utf8", "invalid" )
vjson = ("valid json" , "application/json;charset=utf8", encode alice)
check get' "/" txt 404
check get' "/bar" txt 404
check get' "/foo" txt 415
check put' "/" txt 404
check put' "/bar" txt 404
check put' "/foo" txt 405
check get' "/" ijson 404
check get' "/bar" ijson 404
check get' "/foo" ijson 400
check put' "/" ijson 404
check put' "/bar" ijson 404
check put' "/foo" ijson 405
check get' "/" vjson 404
check get' "/bar" vjson 404
check get' "/foo" vjson 200
check put' "/" vjson 404
check put' "/bar" vjson 404
check put' "/foo" vjson 405
-- | Test server error functionality. -- | Test server error functionality.
errorsSpec :: Spec errorsSpec :: Spec

9
servant/CHANGELOG.md
View file

@ -1,3 +1,12 @@
0.4.2
-----
* Fix missing cases for `Patch` in `safeLink`
0.4.1
-----
* Allow whitespace after parsing JSON
* Stricter matching for `safeLink` for `Capture`
0.4 0.4
--- ---
* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

4
servant/servant.cabal
View file

@ -1,5 +1,5 @@
name: servant name: servant
version: 0.4.0 version: 0.4.1
synopsis: A family of combinators for defining webservices APIs synopsis: A family of combinators for defining webservices APIs
description: description:
A family of combinators for defining webservices APIs and serving them A family of combinators for defining webservices APIs and serving them
@ -55,7 +55,7 @@ library
, http-media >= 0.4 && < 0.7 , http-media >= 0.4 && < 0.7
, http-types == 0.8.* , http-types == 0.8.*
, text >= 1 && < 2 , text >= 1 && < 2
, string-conversions >= 0.3 && < 0.4 , string-conversions >= 0.3 && < 0.5
, network-uri >= 2.6 , network-uri >= 2.6
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

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

@ -9,6 +9,7 @@ import GHC.TypeLits (Symbol)
-- | Capture a value from the request path under a certain type @a@. -- | Capture a value from the request path under a certain type @a@.
-- --
-- Example: -- Example:
--
-- >>> -- GET /books/:isbn -- >>> -- GET /books/:isbn
-- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book -- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
data Capture (sym :: Symbol) a data Capture (sym :: Symbol) a

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

@ -166,7 +166,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy ctyps where pctyps = Proxy :: Proxy ctyps
amrs = allMimeRender pctyps val amrs = allMimeRender pctyps val
lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs
-------------------------------------------------------------------------- --------------------------------------------------------------------------

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

@ -72,8 +72,7 @@
-- --
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ()) -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ())
-- >>> safeLink api bad_link -- >>> safeLink api bad_link
-- <BLANKLINE> -- ...
-- <interactive>:64:1:
-- Could not deduce (Or -- Could not deduce (Or
-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int)) -- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))
-- (IsElem' -- (IsElem'
@ -123,6 +122,7 @@ import Servant.API.Header ( Header )
import Servant.API.Get ( Get ) import Servant.API.Get ( Get )
import Servant.API.Post ( Post ) import Servant.API.Post ( Post )
import Servant.API.Put ( Put ) import Servant.API.Put ( Put )
import Servant.API.Patch ( Patch )
import Servant.API.Delete ( Delete ) import Servant.API.Delete ( Delete )
import Servant.API.Sub ( type (:>) ) import Servant.API.Sub ( type (:>) )
import Servant.API.Raw ( Raw ) import Servant.API.Raw ( Raw )
@ -168,7 +168,8 @@ type family IsElem endpoint api :: Constraint where
IsElem (e :> sa) (e :> sb) = IsElem sa sb IsElem (e :> sa) (e :> sb) = IsElem sa sb
IsElem sa (Header x :> sb) = IsElem sa sb IsElem sa (Header x :> sb) = IsElem sa sb
IsElem sa (ReqBody y x :> sb) = IsElem sa sb IsElem sa (ReqBody y x :> sb) = IsElem sa sb
IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb IsElem (Capture z y :> sa) (Capture x y :> sb)
= IsElem sa sb
IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParam x y :> sb) = IsElem sa sb
IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb
IsElem sa (QueryFlag x :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb
@ -178,6 +179,7 @@ type family IsElem endpoint api :: Constraint where
IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct' IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'
IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct' IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct'
IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct' IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'
IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct'
IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct' IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'
IsElem e e = () IsElem e e = ()
IsElem e a = IsElem' e a IsElem e a = IsElem' e a
@ -352,6 +354,10 @@ instance HasLink (Put y r) where
type MkLink (Put y r) = URI type MkLink (Put y r) = URI
toLink _ = linkURI toLink _ = linkURI
instance HasLink (Patch y r) where
type MkLink (Patch y r) = URI
toLink _ = linkURI
instance HasLink (Delete y r) where instance HasLink (Delete y r) where
type MkLink (Delete y r) = URI type MkLink (Delete y r) = URI
toLink _ = linkURI toLink _ = linkURI