ad16c4f · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge branch 'master' into existential-error

ad16c4fChristian Marie11 years ago

.gitignore+5−5

compare with master

unifiedsplit

@@ -1,8 +1,8 @@

1−dist

1+/dist

2−bin

2+/bin

3−lib

3+/lib

4−share

4+/share

5−packages

5+/packages

6*-packages.conf.d

7cabal-dev

8add-source-timestamps

scripts/bump-versions.shnew file+61

@@ -0,0 +1,61 @@

1+#!/bin/bash -

2+#===============================================================================

3+#

4+# FILE: bump-versions.sh

5+#

6+# USAGE: ./bump-versions.sh

7+#

8+# DESCRIPTION: Bump the versions for all servant packages

9+#

10+# OPTIONS: See usage

11+# REQUIREMENTS: bumper, bash >= 4

12+# CREATED: 11.05.2015 21:36

13+# REVISION: ---

14+#===============================================================================

15+

16+set -o nounset

17+set -o errexit

18+

19+. lib/common.sh

20+

21+usage () {

22+ echo " bump-versions.sh <POSITION> [-d|--dry-run]"

23+ echo " | [-h|--help]"

24+ echo " Bumps the specified positional version of all servant packages."

25+ echo " POSITION is a number between 0 and 3, inclusive."

26+ exit 0

27+}

28+

29+if [ $# -eq 0 ] ; then

30+ echo "expecting one or more arguments. Got 0"

31+ usage

32+elif [ $# -gt 2 ] ; then

33+ echo "expecting one or more arguments"

34+ usage

35+fi

36+

37+versions_equal

38+

39+while [ "${1:-unset}" != "unset" ] ; do

40+ case "$1" in

41+ -h | --help) usage ;;

42+ -d | --dry-run) DRY_RUN=true

43+ shift ;;

44+ 0) if POSITION="none" ; then POSITION=0 ; else usage ; fi

45+ shift ;;

46+ 1) if POSITION="none" ; then POSITION=1 ; else usage ; fi

47+ shift ;;

48+ 2) if POSITION="none" ; then POSITION=2 ; else usage ; fi

49+ shift ;;

50+ 3) if POSITION="none" ; then POSITION=3 ; else usage ; fi

51+ shift ;;

52+ *) usage ;;

53+ esac

54+done

55+

56+if $DRY_RUN ; then

57+ bumper --dry-run -"$POSITION" $(join , "${SOURCES[@]}")

58+else

59+ bumper -"$POSITION" $(join , "${SOURCES[@]}")

60+fi

61+

scripts/lib/common.shnew file+31

@@ -0,0 +1,31 @@

1+#!/bin/bash -

2+#===============================================================================

3+#

4+# FILE: lib/common.sh

5+#

6+# DESCRIPTION: Common functions for servant's shell scripts

7+# Meant to be sourced rather than run.

8+#

9+# REQUIREMENTS: bash >= 4

10+#===============================================================================

11+

12+

13+DIR=$( dirname $( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ))

14+DRY_RUN=false

15+POSITION="none"

16+SOURCES_TXT="$( dirname $DIR)/sources.txt"

17+CABAL=${CABAL:-cabal}

18+

19+declare -a SOURCES

20+readarray -t SOURCES < "$SOURCES_TXT"

21+

22+join () { local IFS="$1"; shift; echo "$*"; }

23+

24+versions_equal () {

25+ local NUM=$(find . -name 'servant*.cabal' | xargs grep "^version:" | awk '{ print $2 }' | uniq -c | wc -l)

26+ if [ 1 -eq $NUM ] ; then

27+ return 0

28+ else

29+ echo "versions of packages are not all the same!" && exit 1

30+ fi

31+}

scripts/start-sandbox.sh+1−5

@@ -14,11 +14,7 @@ set -o nounset

14set -o errexit

16DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

17−SOURCES_TXT="$( dirname $DIR)/sources.txt"

17+. "$DIR"/lib/common.sh

18−CABAL=${CABAL:-cabal}

19−

20−declare -a SOURCES

21−readarray -t SOURCES < "$SOURCES_TXT"

23prepare_sandbox () {

19prepare_sandbox () {

24 $CABAL sandbox init

20 $CABAL sandbox init

scripts/test-all.sh+2−6

@@ -15,13 +15,9 @@ set -o nounset

15set -o errexit

17DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

18−GHC_FLAGS="-Werror"

18+. "$DIR"/lib/common.sh

19−SOURCES_TXT="$( dirname $DIR)/sources.txt"

20−CABAL=${CABAL:-cabal}

21−

22−declare -a SOURCES

23−readarray -t SOURCES < "$SOURCES_TXT"

20+GHC_FLAGS="-Werror"

26prepare_sandbox () {

22prepare_sandbox () {

27 $CABAL sandbox init

23 $CABAL sandbox init

scripts/update-defaults-nix.sh+1−5

@@ -12,11 +12,7 @@ set -o nounset

12set -o errexit

14DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

15−BASE_DIR="$( dirname $DIR)"

15+. "$DIR"/lib/common.sh

16−SOURCES_TXT="$BASE_DIR/sources.txt"

17−

18−declare -a SOURCES

19−readarray -t SOURCES < "$SOURCES_TXT"

21for s in ${SOURCES[@]} ; do

17for s in ${SOURCES[@]} ; do

22 echo $s

18 echo $s

scripts/upload.shnew file+52

@@ -0,0 +1,52 @@

1+#!/bin/bash -

2+#===============================================================================

3+#

4+# FILE: upload.sh

5+#

6+# USAGE: ./upload.sh <USER> <PASSWORD>

7+#

8+# DESCRIPTION: Uploads all servant packages to Hackage

9+#

10+# REQUIREMENTS: cabal, bash >= 4

11+# AUTHOR: Julian K. Arni

12+# CREATED: 05.06.2015 13:05

13+#===============================================================================

14+

15+set -o nounset

16+set -o errexit

17+

18+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

19+. "$DIR"/lib/common.sh

20+

21+usage () {

22+ echo " upload.sh <USER> <PASSWORD>"

23+ echo " Uploads all servant packages to Hackage"

24+ exit 0

25+}

26+

27+

28+upload_package () {

29+ local package="$1"

30+ local user="$2"

31+ local pass="$3"

32+ local cabalFile="$package.cabal"

33+ pushd "$package"

34+ local version=$(grep -i '^version:' $cabalFile | awk '{ print $2 }')

35+ local sdist="dist/${package}-${version}.tar.gz"

36+ cabal sdist

37+ echo "User is: $user"

38+ cabal upload --user="$user" --password="$pass" "$sdist"

39+ popd

40+}

41+

42+

43+if [ $# -ne 2 ] ; then

44+ echo "expecting two arguments."

45+ usage

46+fi

47+

48+versions_equal

49+

50+for s in ${SOURCES[@]} ; do

51+ upload_package "$s" "$1" "$2"

52+done

servant-blaze/servant-blaze.cabal+1−1

@@ -2,7 +2,7 @@

2-- documentation, see http://haskell.org/cabal/users-guide/

4name: servant-blaze

5−version: 0.4.0.0

5+version: 0.4.1

6synopsis: Blaze-html support for servant

7-- description:

8homepage: http://haskell-servant.github.io/

servant-blaze/src/Servant/HTML/Blaze.hs+1−1

@@ -25,7 +25,7 @@ import Text.Blaze.Html.Renderer.Utf8 (renderHtml)

26data HTML deriving Typeable

28−-- | @text/plain;charset=utf-8@

28+-- | @text/html;charset=utf-8@

29instance Accept HTML where

30 contentType _ = "text" M.// "html" M./: ("charset", "utf-8")

servant-client/CHANGELOG.md+4

@@ -1,3 +1,7 @@

1+0.4.1

2+-----

3+* The `HasClient` instance for `Delete cts ()` now does not care at all about content types provided.

10.4

50.4

2---

6---

3* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

7* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

servant-client/servant-client.cabal+4−1

@@ -1,5 +1,5 @@

1name: servant-client

2−version: 0.4.0

2+version: 0.4.1

3synopsis: automatical derivation of querying functions for servant webservices

4description:

5 This library lets you derive automatically Haskell functions that

@@ -56,6 +56,9 @@ test-suite spec

56 default-language: Haskell2010

57 hs-source-dirs: test

58 main-is: Spec.hs

59+ other-modules:

60+ Servant.ClientSpec

61+ , Servant.Common.BaseUrlSpec

59 build-depends:

62 build-depends:

60 base == 4.*

63 base == 4.*

61 , aeson

64 , aeson

servant-client/src/Servant/Client.hs+10−7

@@ -7,6 +7,7 @@

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE UndecidableInstances #-}

10#if !MIN_VERSION_base(4,8,0)

11#if !MIN_VERSION_base(4,8,0)

11{-# LANGUAGE OverlappingInstances #-}

12{-# LANGUAGE OverlappingInstances #-}

12#endif

13#endif

@@ -126,8 +127,9 @@ instance

126#if MIN_VERSION_base(4,8,0)

127#if MIN_VERSION_base(4,8,0)

127 {-# OVERLAPPABLE #-}

128 {-# OVERLAPPABLE #-}

128#endif

129#endif

130+ -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances

129− (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where

131+ (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where

130− type Client (Delete (ct ': cts) a) = EitherT ServantError IO a

132+ type Client (Delete cts' a) = EitherT ServantError IO a

131 clientWithRoute Proxy req baseurl =

133 clientWithRoute Proxy req baseurl =

132 snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl

134 snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl

133

135

@@ -137,8 +139,8 @@ instance

137#if MIN_VERSION_base(4,8,0)

139#if MIN_VERSION_base(4,8,0)

138 {-# OVERLAPPING #-}

140 {-# OVERLAPPING #-}

139#endif

141#endif

140− HasClient (Delete (ct ': cts) ()) where

142+ HasClient (Delete cts ()) where

141− type Client (Delete (ct ': cts) ()) = EitherT ServantError IO ()

143+ type Client (Delete cts ()) = EitherT ServantError IO ()

142 clientWithRoute Proxy req baseurl =

144 clientWithRoute Proxy req baseurl =

143 void $ performRequestNoBody H.methodDelete req [204] baseurl

145 void $ performRequestNoBody H.methodDelete req [204] baseurl

144

146

@@ -148,9 +150,10 @@ instance

148#if MIN_VERSION_base(4,8,0)

150#if MIN_VERSION_base(4,8,0)

149 {-# OVERLAPPING #-}

151 {-# OVERLAPPING #-}

150#endif

152#endif

153+ -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances

151− ( MimeUnrender ct a, BuildHeadersTo ls

154+ ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)

152− ) => HasClient (Delete (ct ': cts) (Headers ls a)) where

155+ ) => HasClient (Delete cts' (Headers ls a)) where

153− type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)

156+ type Client (Delete cts' (Headers ls a)) = EitherT ServantError IO (Headers ls a)

154 clientWithRoute Proxy req baseurl = do

157 clientWithRoute Proxy req baseurl = do

155 (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl

158 (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl

156 return $ Headers { getResponse = resp

159 return $ Headers { getResponse = resp

servant-client/src/Servant/Common/BaseUrl.hs+23−9

@@ -1,8 +1,19 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

1−{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE ViewPatterns #-}

3+{-# LANGUAGE ViewPatterns #-}

3−module Servant.Common.BaseUrl where

4+module Servant.Common.BaseUrl (

5+ -- * types

6+ BaseUrl (..)

7+ , InvalidBaseUrlException

8+ , Scheme (..)

9+ -- * functions

10+ , parseBaseUrl

11+ , showBaseUrl

12+) where

14+import Control.Monad.Catch (MonadThrow, throwM, Exception)

5import Data.List

15import Data.List

16+import Data.Typeable

6import GHC.Generics

17import GHC.Generics

7import Network.URI

18import Network.URI

8import Safe

19import Safe

@@ -34,20 +45,23 @@ showBaseUrl (BaseUrl urlscheme host port) =

34 (Https, 443) -> ""

45 (Https, 443) -> ""

35 _ -> ":" ++ show port

46 _ -> ":" ++ show port

48+data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)

49+instance Exception InvalidBaseUrlException

50+

37−parseBaseUrl :: String -> Either String BaseUrl

51+parseBaseUrl :: MonadThrow m => String -> m BaseUrl

38parseBaseUrl s = case parseURI (removeTrailingSlash s) of

52parseBaseUrl s = case parseURI (removeTrailingSlash s) of

39 -- This is a rather hacky implementation and should be replaced with something

53 -- This is a rather hacky implementation and should be replaced with something

40 -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).

54 -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).

41 Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->

55 Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->

42− Right (BaseUrl Http host port)

56+ return (BaseUrl Http host port)

43 Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->

57 Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->

44− Right (BaseUrl Http host 80)

58+ return (BaseUrl Http host 80)

45 Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->

59 Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->

46− Right (BaseUrl Https host port)

60+ return (BaseUrl Https host port)

47 Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->

61 Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->

48− Right (BaseUrl Https host 443)

62+ return (BaseUrl Https host 443)

49 _ -> if "://" `isInfixOf` s

63 _ -> if "://" `isInfixOf` s

50− then Left ("invalid base url: " ++ s)

64+ then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)

51 else parseBaseUrl ("http://" ++ s)

65 else parseBaseUrl ("http://" ++ s)

52 where

66 where

53 removeTrailingSlash str = case lastMay str of

67 removeTrailingSlash str = case lastMay str of

servant-client/src/Servant/Common/Req.hs+5−1

@@ -1,3 +1,4 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE CPP #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

@@ -18,6 +19,7 @@ import Data.String.Conversions

18import Data.Proxy

19import Data.Proxy

19import Data.Text (Text)

20import Data.Text (Text)

20import Data.Text.Encoding

21import Data.Text.Encoding

22+import Data.Typeable

21import Network.HTTP.Client hiding (Proxy)

23import Network.HTTP.Client hiding (Proxy)

22import Network.HTTP.Client.TLS

24import Network.HTTP.Client.TLS

23import Network.HTTP.Media

25import Network.HTTP.Media

@@ -53,7 +55,9 @@ data ServantError

53 | ConnectionError

55 | ConnectionError

54 { connectionError :: String

56 { connectionError :: String

55 }

57 }

56− deriving (Show)

58+ deriving (Show, Typeable)

59+

60+instance Exception ServantError

58data Req = Req

62data Req = Req

59 { reqPath :: String

63 { reqPath :: String

servant-client/test/Servant/ClientSpec.hs+17−9

@@ -80,7 +80,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

81type Api =

82 "get" :> Get '[JSON] Person

83− :<|> "delete" :> Delete '[JSON] ()

83+ :<|> "deleteEmpty" :> Delete '[] ()

84 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

85 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

86 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

@@ -98,6 +98,7 @@ type Api =

98 ReqBody '[JSON] [(String, [Rational])] :>

99 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

100 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

101+ :<|> "deleteContentType" :> Delete '[JSON] ()

101api :: Proxy Api

102api :: Proxy Api

102api = Proxy

103api = Proxy

103

104

@@ -123,6 +124,7 @@ server = serve api (

123 :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")

124 :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")

124 :<|> (\ a b c d -> return (a, b, c, d))

125 :<|> (\ a b c d -> return (a, b, c, d))

125 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

126 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

127+ :<|> return ()

126 )

128 )

127

129

128withServer :: (BaseUrl -> IO a) -> IO a

130withServer :: (BaseUrl -> IO a) -> IO a

@@ -148,7 +150,7 @@ withFailServer action = withWaiDaemon (return failServer) action

148spec :: IO ()

150spec :: IO ()

149spec = withServer $ \ baseUrl -> do

151spec = withServer $ \ baseUrl -> do

150 let getGet :: EitherT ServantError IO Person

152 let getGet :: EitherT ServantError IO Person

151− getDelete :: EitherT ServantError IO ()

153+ getDeleteEmpty :: EitherT ServantError IO ()

152 getCapture :: String -> EitherT ServantError IO Person

154 getCapture :: String -> EitherT ServantError IO Person

153 getBody :: Person -> EitherT ServantError IO Person

155 getBody :: Person -> EitherT ServantError IO Person

154 getQueryParam :: Maybe String -> EitherT ServantError IO Person

156 getQueryParam :: Maybe String -> EitherT ServantError IO Person

@@ -161,8 +163,9 @@ spec = withServer $ \ baseUrl -> do

161 getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)

163 getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)

162 getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])

164 getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])

163 getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool)

165 getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool)

166+ getDeleteContentType :: EitherT ServantError IO ()

164 ( getGet

167 ( getGet

165− :<|> getDelete

168+ :<|> getDeleteEmpty

166 :<|> getCapture

169 :<|> getCapture

167 :<|> getBody

170 :<|> getBody

168 :<|> getQueryParam

171 :<|> getQueryParam

@@ -174,15 +177,20 @@ spec = withServer $ \ baseUrl -> do

174 :<|> getRawSuccess

177 :<|> getRawSuccess

175 :<|> getRawFailure

178 :<|> getRawFailure

176 :<|> getMultiple

179 :<|> getMultiple

177− :<|> getRespHeaders)

180+ :<|> getRespHeaders

181+ :<|> getDeleteContentType)

178 = client api baseUrl

182 = client api baseUrl

179

183

180 hspec $ do

184 hspec $ do

181 it "Servant.API.Get" $ do

185 it "Servant.API.Get" $ do

182 (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice

186 (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice

183

187

184− it "Servant.API.Delete" $ do

188+ describe "Servant.API.Delete" $ do

189+ it "allows empty content type" $ do

185− (Arrow.left show <$> runEitherT getDelete) `shouldReturn` Right ()

190+ (Arrow.left show <$> runEitherT getDeleteEmpty) `shouldReturn` Right ()

191+

192+ it "allows content type" $ do

193+ (Arrow.left show <$> runEitherT getDeleteContentType) `shouldReturn` Right ()

186

194

187 it "Servant.API.Capture" $ do

195 it "Servant.API.Capture" $ do

188 (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)

196 (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)

@@ -274,11 +282,11 @@ spec = withServer $ \ baseUrl -> do

274failSpec :: IO ()

282failSpec :: IO ()

275failSpec = withFailServer $ \ baseUrl -> do

283failSpec = withFailServer $ \ baseUrl -> do

276 let getGet :: EitherT ServantError IO Person

284 let getGet :: EitherT ServantError IO Person

277− getDelete :: EitherT ServantError IO ()

285+ getDeleteEmpty :: EitherT ServantError IO ()

278 getCapture :: String -> EitherT ServantError IO Person

286 getCapture :: String -> EitherT ServantError IO Person

279 getBody :: Person -> EitherT ServantError IO Person

287 getBody :: Person -> EitherT ServantError IO Person

280 ( getGet

288 ( getGet

281− :<|> getDelete

289+ :<|> getDeleteEmpty

282 :<|> getCapture

290 :<|> getCapture

283 :<|> getBody

291 :<|> getBody

284 :<|> _ )

292 :<|> _ )

@@ -289,7 +297,7 @@ failSpec = withFailServer $ \ baseUrl -> do

289 hspec $ do

297 hspec $ do

290 context "client returns errors appropriately" $ do

298 context "client returns errors appropriately" $ do

291 it "reports FailureResponse" $ do

299 it "reports FailureResponse" $ do

292− Left res <- runEitherT getDelete

300+ Left res <- runEitherT getDeleteEmpty

293 case res of

301 case res of

294 FailureResponse (Status 404 "Not Found") _ _ -> return ()

302 FailureResponse (Status 404 "Not Found") _ _ -> return ()

295 _ -> fail $ "expected 404 response, but got " <> show res

303 _ -> fail $ "expected 404 response, but got " <> show res

servant-docs/servant-docs.cabal+1−1

@@ -1,5 +1,5 @@

1name: servant-docs

2−version: 0.4.0

2+version: 0.4.1

3synopsis: generate API docs for your servant webservice

4description:

5 Library for generating API docs from a servant API definition.

servant-examples/auth-combinator/auth-combinator.hs+9−8

@@ -28,14 +28,15 @@ data AuthProtected

28instance HasServer rest => HasServer (AuthProtected :> rest) where

29 type ServerT (AuthProtected :> rest) m = ServerT rest m

31− route Proxy a request respond =

31+ route Proxy a = WithRequest $ \ request ->

32+ route (Proxy :: Proxy rest) $ do

32− case lookup "Cookie" (requestHeaders request) of

33+ case lookup "Cookie" (requestHeaders request) of

33− Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header."

34+ Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.")

34− Just v -> do

35+ Just v -> do

35− authGranted <- isGoodCookie v

36+ authGranted <- isGoodCookie v

36− if authGranted

37+ if authGranted

37− then route (Proxy :: Proxy rest) a request respond

38+ then a

38− else respond . succeedWith $ responseLBS status403 [] "Invalid cookie."

39+ else return $ failWith $ HttpError status403 (Just "Invalid cookie.")

40type PrivateAPI = Get '[JSON] [PrivateData]

41type PrivateAPI = Get '[JSON] [PrivateData]

servant-examples/servant-examples.cabal+12−12

@@ -1,5 +1,5 @@

1name: servant-examples

2−version: 0.4

2+version: 0.4.1

3synopsis: Example programs for servant

4description: Example programs for servant,

5 showcasing solutions to common needs.

@@ -26,11 +26,11 @@ executable tutorial

26 , js-jquery

27 , lucid

28 , random

29− , servant

29+ , servant == 0.4.*

30− , servant-docs

30+ , servant-docs == 0.4.*

31− , servant-jquery

31+ , servant-jquery == 0.4.*

32− , servant-lucid

32+ , servant-lucid == 0.4.*

33− , servant-server

33+ , servant-server == 0.4.*

34 , text

35 , time

36 , transformers

@@ -47,9 +47,9 @@ executable t8-main

47 aeson

48 , base >= 4.7 && < 5

49 , either

50− , servant

50+ , servant == 0.4.*

51− , servant-client

51+ , servant-client == 0.4.*

52− , servant-server

52+ , servant-server == 0.4.*

53 , wai

55executable hackage

@@ -70,8 +70,8 @@ executable wai-middleware

70 build-depends:

71 aeson >= 0.8

72 , base >= 4.7 && < 5

73− , servant

73+ , servant == 0.4.*

74− , servant-server

74+ , servant-server == 0.4.*

75 , text

76 , wai

77 , wai-extra

@@ -86,7 +86,7 @@ executable auth-combinator

86 , base >= 4.7 && < 5

87 , bytestring

88 , http-types

89− , servant

89+ , servant == 0.4.*

90 , servant-server == 0.4.*

91 , text

92 , wai

servant-jquery/servant-jquery.cabal+1−1

@@ -1,5 +1,5 @@

1name: servant-jquery

2−version: 0.4.0

2+version: 0.4.1

3synopsis: Automatically derive (jquery) javascript functions to query servant webservices

4description:

5 Automatically derive jquery-based javascript functions to query servant webservices.

servant-lucid/servant-lucid.cabal+1−1

@@ -2,7 +2,7 @@

2-- documentation, see http://haskell.org/cabal/users-guide/

4name: servant-lucid

5−version: 0.4.0.0

5+version: 0.4.1

6synopsis: Servant support for lucid

7-- description:

8homepage: http://haskell-servant.github.io/

servant-lucid/src/Servant/HTML/Lucid.hs+1−1

@@ -24,7 +24,7 @@ import Servant.API (Accept (..), MimeRender (..))

25data HTML deriving Typeable

27−-- | @text/plain;charset=utf-8@

27+-- | @text/html;charset=utf-8@

28instance Accept HTML where

29 contentType _ = "text" M.// "html" M./: ("charset", "utf-8")

servant-server/CHANGELOG.md+6

@@ -1,3 +1,9 @@

1+0.4.1

2+-----

3+* Bump attoparsec upper bound to < 0.14

4+* Bump wai-app-static upper bound to < 3.2

5+* Bump either upper bound to < 4.5

10.4

70.4

2---

8---

3* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

9* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

servant-server/example/greet.hs+1−1

@@ -44,7 +44,7 @@ testApi = Proxy

44-- There's one handler per endpoint, which, just like in the type

45-- that represents the API, are glued together using :<|>.

46--

47−-- Each handler runs in the 'EitherT (Int, String) IO' monad.

47+-- Each handler runs in the 'EitherT ServantErr IO' monad.

48server :: Server TestApi

49server = helloH :<|> postGreetH :<|> deleteGreetH

servant-server/servant-server.cabal+10−6

@@ -1,5 +1,5 @@

1name: servant-server

2−version: 0.4.0

2+version: 0.4.1

3synopsis: A family of combinators for defining webservices APIs and serving them

4description:

5 A family of combinators for defining webservices APIs and serving them

@@ -35,15 +35,19 @@ library

35 Servant

36 Servant.Server

37 Servant.Server.Internal

38− Servant.Server.Internal.ServantErr

39 Servant.Server.Internal.Enter

38 Servant.Server.Internal.Enter

39+ Servant.Server.Internal.PathInfo

40+ Servant.Server.Internal.Router

41+ Servant.Server.Internal.RoutingApplication

42+ Servant.Server.Internal.ServantErr

40 Servant.Utils.StaticFiles

43 Servant.Utils.StaticFiles

41 build-depends:

44 build-depends:

42 base >= 4.7 && < 5

45 base >= 4.7 && < 5

43− , aeson >= 0.7 && < 0.9

46+ , aeson >= 0.7 && < 0.10

44− , attoparsec >= 0.12 && < 0.13

47+ , attoparsec >= 0.12 && < 0.14

45 , bytestring >= 0.10 && < 0.11

48 , bytestring >= 0.10 && < 0.11

49+ , containers >= 0.5 && < 0.6

46− , either >= 4.3 && < 4.4

50+ , either >= 4.3 && < 4.5

47 , http-types >= 0.8 && < 0.9

51 , http-types >= 0.8 && < 0.9

48 , network-uri >= 2.6 && < 2.7

52 , network-uri >= 2.6 && < 2.7

49 , mtl >= 2 && < 3

53 , mtl >= 2 && < 3

@@ -51,7 +55,7 @@ library

51 , safe >= 0.3 && < 0.4

55 , safe >= 0.3 && < 0.4

52 , servant == 0.4.*

56 , servant == 0.4.*

53 , split >= 0.2 && < 0.3

57 , split >= 0.2 && < 0.3

54− , string-conversions >= 0.3 && < 0.4

58+ , string-conversions >= 0.3 && < 0.5

55 , system-filepath >= 0.4 && < 0.5

59 , system-filepath >= 0.4 && < 0.5

56 , filepath >= 1

60 , filepath >= 1

57 , text >= 1.2 && < 1.3

61 , text >= 1.2 && < 1.3

servant-server/src/Servant/Server.hs+1−2

@@ -81,7 +81,6 @@ import Data.Proxy (Proxy)

81import Network.Wai (Application)

82import Servant.Server.Internal

83import Servant.Server.Internal.Enter

84−import Servant.Server.Internal.ServantErr

87-- * Implementing Servers

86-- * Implementing Servers

@@ -108,7 +107,7 @@ import Servant.Server.Internal.ServantErr

108-- > main = Network.Wai.Handler.Warp.run 8080 app

107-- > main = Network.Wai.Handler.Warp.run 8080 app

109--

108--

110serve :: HasServer layout => Proxy layout -> Server layout -> Application

109serve :: HasServer layout => Proxy layout -> Server layout -> Application

111−serve p server = toApplication (route p server)

110+serve p server = toApplication (runRouter (route p (return (RR (Right server)))))

112

111

113

112

114-- Documentation

113-- Documentation

servant-server/src/Servant/Server/Internal.hs+169−426

@@ -2,6 +2,7 @@

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

@@ -11,17 +12,20 @@

11{-# LANGUAGE OverlappingInstances #-}

12{-# LANGUAGE OverlappingInstances #-}

12#endif

13#endif

14−module Servant.Server.Internal where

15+module Servant.Server.Internal

16+ ( module Servant.Server.Internal

17+ , module Servant.Server.Internal.PathInfo

18+ , module Servant.Server.Internal.Router

19+ , module Servant.Server.Internal.RoutingApplication

20+ , module Servant.Server.Internal.ServantErr

21+ ) where

16#if !MIN_VERSION_base(4,8,0)

23#if !MIN_VERSION_base(4,8,0)

17import Control.Applicative ((<$>))

24import Control.Applicative ((<$>))

18−import Data.Monoid (Monoid, mappend, mempty)

19#endif

25#endif

20−import Control.Monad.Trans.Either (EitherT, runEitherT)

26+import Control.Monad.Trans.Either (EitherT)

21import qualified Data.ByteString as B

27import qualified Data.ByteString as B

22−import qualified Data.ByteString.Lazy as BL

28+import qualified Data.Map as M

23−import Data.IORef (newIORef, readIORef, writeIORef)

24−import Data.List (unfoldr)

25import Data.Maybe (catMaybes, fromMaybe)

29import Data.Maybe (catMaybes, fromMaybe)

26import Data.String (fromString)

30import Data.String (fromString)

27import Data.String.Conversions (cs, (<>))

31import Data.String.Conversions (cs, (<>))

@@ -31,12 +35,9 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)

31import Data.Typeable

35import Data.Typeable

32import GHC.TypeLits (KnownSymbol, symbolVal)

36import GHC.TypeLits (KnownSymbol, symbolVal)

33import Network.HTTP.Types hiding (Header, ResponseHeaders)

37import Network.HTTP.Types hiding (Header, ResponseHeaders)

34−import Network.Wai (Application, Request, Response,

38+import Network.Wai (Application, lazyRequestBody,

35− ResponseReceived, lazyRequestBody,

36− pathInfo, rawQueryString,

39+ rawQueryString, requestHeaders,

37− requestBody, requestHeaders,

38− requestMethod, responseLBS,

40+ requestMethod, responseLBS)

39− strictRequestBody)

40import Servant.API ((:<|>) (..), (:>), Capture,

41import Servant.API ((:<|>) (..), (:>), Capture,

41 Delete, Get, Header,

42 Delete, Get, Header,

42 MatrixFlag, MatrixParam, MatrixParams,

43 MatrixFlag, MatrixParam, MatrixParams,

@@ -50,136 +51,15 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,

50 getHeaders)

51 getHeaders)

51import Servant.Common.Text (FromText, fromText)

52import Servant.Common.Text (FromText, fromText)

54+import Servant.Server.Internal.PathInfo

55+import Servant.Server.Internal.Router

56+import Servant.Server.Internal.RoutingApplication

53import Servant.Server.Internal.ServantErr

57import Servant.Server.Internal.ServantErr

55−data ReqBodyState = Uncalled

56− | Called !B.ByteString

57− | Done !B.ByteString

58−

59−

60−toApplication :: RoutingApplication -> Application

61−toApplication ra request respond = do

62− reqBodyRef <- newIORef Uncalled

63− -- We may need to consume the requestBody more than once. In order to

64− -- maintain the illusion that 'requestBody' works as expected,

65− -- 'ReqBodyState' is introduced, and the complete body is memoized and

66− -- returned as many times as requested with empty "Done" marker chunks in

67− -- between.

68− -- See https://github.com/haskell-servant/servant/issues/3

69− let memoReqBody = do

70− ior <- readIORef reqBodyRef

71− case ior of

72− Uncalled -> do

73− r <- BL.toStrict <$> strictRequestBody request

74− writeIORef reqBodyRef $ Done r

75− return r

76− Called bs -> do

77− writeIORef reqBodyRef $ Done bs

78− return bs

79− Done bs -> do

80− writeIORef reqBodyRef $ Called bs

81− return B.empty

82−

83− ra request{ requestBody = memoReqBody } (routingRespond . routeResult)

84− where

85− routingRespond :: Either RouteMismatch Response -> IO ResponseReceived

86− routingRespond (Left NotFound) =

87− respond $ responseLBS notFound404 [] "not found"

88− routingRespond (Left WrongMethod) =

89− respond $ responseLBS methodNotAllowed405 [] "method not allowed"

90− routingRespond (Left (InvalidBody err)) =

91− respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err

92− routingRespond (Left UnsupportedMediaType) =

93− respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"

94− routingRespond (Left (HttpError status body)) =

95− respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body

96− routingRespond (Right response) =

97− respond response

98−

99−-- Note that the ordering of the constructors has great significance! It

100−-- determines the Ord instance and, consequently, the monoid instance.

101−-- * Route mismatch

102−data RouteMismatch =

103− NotFound -- ^ the usual "not found" error

104− | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error

105− | UnsupportedMediaType -- ^ request body has unsupported media type

106− | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error

107− | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.

108− deriving (Eq, Ord, Show)

109−

110−instance Monoid RouteMismatch where

111− mempty = NotFound

112− -- The following isn't great, since it picks @InvalidBody@ based on

113− -- alphabetical ordering, but any choice would be arbitrary.

114− --

115− -- "As one judge said to the other, 'Be just and if you can't be just, be

116− -- arbitrary'" -- William Burroughs

117− mappend = max

118−

119−

120−-- | A wrapper around @'Either' 'RouteMismatch' a@.

121−newtype RouteResult a =

122− RR { routeResult :: Either RouteMismatch a }

123− deriving (Eq, Show)

124−

125−failWith :: RouteMismatch -> RouteResult a

126−failWith = RR . Left

127−

128−succeedWith :: a -> RouteResult a

129−succeedWith = RR . Right

130−

131−isMismatch :: RouteResult a -> Bool

132−isMismatch (RR (Left _)) = True

133−isMismatch _ = False

134−

135−-- | Like `null . pathInfo`, but works with redundant trailing slashes.

136−pathIsEmpty :: Request -> Bool

137−pathIsEmpty = f . processedPathInfo

138− where

139− f [] = True

140− f [""] = True

141− f _ = False

142−

143−-- | If we get a `Right`, it has precedence over everything else.

144−--

145−-- This in particular means that if we could get several 'Right's,

146−-- only the first we encounter would be taken into account.

147−instance Monoid (RouteResult a) where

148− mempty = RR $ Left mempty

149−

150− RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)

151− RR (Left _) `mappend` RR (Right y) = RR $ Right y

152− r `mappend` _ = r

153−

154−type RoutingApplication =

155− Request -- ^ the request, the field 'pathInfo' may be modified by url routing

156− -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived

157−

158−splitMatrixParameters :: Text -> (Text, Text)

159−splitMatrixParameters = T.break (== ';')

160−

161−parsePathInfo :: Request -> [Text]

162−parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo

163− where mergePairs = concat . unfoldr pairToList

164− pairToList [] = Nothing

165− pairToList ((a, b):xs) = Just ([a, b], xs)

166−

167−-- | Returns a processed pathInfo from the request.

168−--

169−-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be

170−-- processed, so routing works as intended. Therefor this function should be used to access

171−-- the pathInfo for routing purposes.

172−processedPathInfo :: Request -> [Text]

173−processedPathInfo r =

174− case pinfo of

175− (x:xs) | T.head x == ';' -> xs

176− _ -> pinfo

177− where pinfo = parsePathInfo r

178−

179class HasServer layout where

59class HasServer layout where

180 type ServerT layout (m :: * -> *) :: *

60 type ServerT layout (m :: * -> *) :: *

181

182− route :: Proxy layout -> Server layout -> RoutingApplication

62+ route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router

183

184type Server layout = ServerT layout (EitherT ServantErr IO)

64type Server layout = ServerT layout (EitherT ServantErr IO)

185

@@ -200,12 +80,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where

200

201 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m

81 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m

202

203− route Proxy (a :<|> b) request respond =

83+ route Proxy server = choice (route pa (extractL <$> server))

204− route pa a request $ \mResponse ->

84+ (route pb (extractR <$> server))

205− if isMismatch mResponse

206− then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')

207− else respond mResponse

208−

209 where pa = Proxy :: Proxy a

85 where pa = Proxy :: Proxy a

210 pb = Proxy :: Proxy b

86 pb = Proxy :: Proxy b

211

@@ -227,7 +103,7 @@ captured _ = fromText

227-- >

103-- >

228-- > server :: Server MyApi

104-- > server :: Server MyApi

229-- > server = getBook

105-- > server = getBook

230−-- > where getBook :: Text -> EitherT (Int, String) IO Book

106+-- > where getBook :: Text -> EitherT ServantErr IO Book

231-- > getBook isbn = ...

107-- > getBook isbn = ...

232instance (KnownSymbol capture, FromText a, HasServer sublayout)

108instance (KnownSymbol capture, FromText a, HasServer sublayout)

233 => HasServer (Capture capture a :> sublayout) where

109 => HasServer (Capture capture a :> sublayout) where

@@ -235,25 +111,72 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)

235 type ServerT (Capture capture a :> sublayout) m =

111 type ServerT (Capture capture a :> sublayout) m =

236 a -> ServerT sublayout m

112 a -> ServerT sublayout m

237

113

238− route Proxy subserver request respond = case processedPathInfo request of

114+ route Proxy subserver =

239− (first : rest)

115+ DynamicRouter $ \ first ->

116+ route (Proxy :: Proxy sublayout)

240− -> case captured captureProxy first of

117+ (case captured captureProxy first of

241− Nothing -> respond $ failWith NotFound

118+ Nothing -> return $ failWith NotFound

242− Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{

119+ Just v -> feedTo subserver v)

243− pathInfo = rest

244− } respond

245− _ -> respond $ failWith NotFound

246−

247 where captureProxy = Proxy :: Proxy (Capture capture a)

120 where captureProxy = Proxy :: Proxy (Capture capture a)

248

121

249

122

123+methodRouter :: (AllCTRender ctypes a)

124+ => Method -> Proxy ctypes -> Status

125+ -> IO (RouteResult (EitherT ServantErr IO a))

126+ -> Router

127+methodRouter method proxy status action = LeafRouter route'

128+ where

129+ route' request respond

130+ | pathIsEmpty request && requestMethod request == method = do

131+ runAction action respond $ \ output -> do

132+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

133+ case handleAcceptH proxy (AcceptHeader accH) output of

134+ Nothing -> failWith UnsupportedMediaType

135+ Just (contentT, body) -> succeedWith $

136+ responseLBS status [ ("Content-Type" , cs contentT)] body

137+ | pathIsEmpty request && requestMethod request /= method =

138+ respond $ failWith WrongMethod

139+ | otherwise = respond $ failWith NotFound

140+

141+methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)

142+ => Method -> Proxy ctypes -> Status

143+ -> IO (RouteResult (EitherT ServantErr IO (Headers h v)))

144+ -> Router

145+methodRouterHeaders method proxy status action = LeafRouter route'

146+ where

147+ route' request respond

148+ | pathIsEmpty request && requestMethod request == method = do

149+ runAction action respond $ \ output -> do

150+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

151+ headers = getHeaders output

152+ case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of

153+ Nothing -> failWith UnsupportedMediaType

154+ Just (contentT, body) -> succeedWith $

155+ responseLBS status ( ("Content-Type" , cs contentT) : headers) body

156+ | pathIsEmpty request && requestMethod request /= method =

157+ respond $ failWith WrongMethod

158+ | otherwise = respond $ failWith NotFound

159+

160+methodRouterEmpty :: Method

161+ -> IO (RouteResult (EitherT ServantErr IO ()))

162+ -> Router

163+methodRouterEmpty method action = LeafRouter route'

164+ where

165+ route' request respond

166+ | pathIsEmpty request && requestMethod request == method = do

167+ runAction action respond $ \ () ->

168+ succeedWith $ responseLBS noContent204 [] ""

169+ | pathIsEmpty request && requestMethod request /= method =

170+ respond $ failWith WrongMethod

171+ | otherwise = respond $ failWith NotFound

172+

250-- | If you have a 'Delete' endpoint in your API,

173-- | If you have a 'Delete' endpoint in your API,

251-- the handler for this endpoint is meant to delete

174-- the handler for this endpoint is meant to delete

252-- a resource.

175-- a resource.

253--

176--

254-- The code of the handler will, just like

177-- The code of the handler will, just like

255-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and

178-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and

256−-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@.

179+-- 'Servant.API.Put.Put', run in @EitherT ServantErr IO ()@.

257-- The 'Int' represents the status code and the 'String' a message

180-- The 'Int' represents the status code and the 'String' a message

258-- to be returned. You can use 'Control.Monad.Trans.Either.left' to

181-- to be returned. You can use 'Control.Monad.Trans.Either.left' to

259-- painlessly error out if the conditions for a successful deletion

182-- painlessly error out if the conditions for a successful deletion

@@ -267,20 +190,7 @@ instance

267

190

268 type ServerT (Delete ctypes a) m = m a

191 type ServerT (Delete ctypes a) m = m a

269

192

270− route Proxy action request respond

193+ route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200

271− | pathIsEmpty request && requestMethod request == methodDelete = do

272− e <- runEitherT action

273− respond $ case e of

274− Right output -> do

275− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

276− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

277− Nothing -> failWith UnsupportedMediaType

278− Just (contentT, body) -> succeedWith $

279− responseLBS status200 [ ("Content-Type" , cs contentT)] body

280− Left err -> succeedWith $ responseServantErr err

281− | pathIsEmpty request && requestMethod request /= methodDelete =

282− respond $ failWith WrongMethod

283− | otherwise = respond $ failWith NotFound

284

194

285instance

195instance

286#if MIN_VERSION_base(4,8,0)

196#if MIN_VERSION_base(4,8,0)

@@ -290,15 +200,7 @@ instance

290

200

291 type ServerT (Delete ctypes ()) m = m ()

201 type ServerT (Delete ctypes ()) m = m ()

292

202

293− route Proxy action request respond

203+ route Proxy = methodRouterEmpty methodDelete

294− | pathIsEmpty request && requestMethod request == methodDelete = do

295− e <- runEitherT action

296− respond . succeedWith $ case e of

297− Right () -> responseLBS noContent204 [] ""

298− Left err -> responseServantErr err

299− | pathIsEmpty request && requestMethod request /= methodDelete =

300− respond $ failWith WrongMethod

301− | otherwise = respond $ failWith NotFound

302

204

303-- Add response headers

205-- Add response headers

304instance

206instance

@@ -310,26 +212,12 @@ instance

310

212

311 type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)

213 type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)

312

214

313− route Proxy action request respond

215+ route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200

314− | pathIsEmpty request && requestMethod request == methodDelete = do

315− e <- runEitherT action

316− respond $ case e of

317− Right output -> do

318− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

319− headers = getHeaders output

320− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

321− Nothing -> failWith UnsupportedMediaType

322− Just (contentT, body) -> succeedWith $

323− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

324− Left err -> succeedWith $ responseServantErr err

325− | pathIsEmpty request && requestMethod request /= methodDelete =

326− respond $ failWith WrongMethod

327− | otherwise = respond $ failWith NotFound

328

216

329-- | When implementing the handler for a 'Get' endpoint,

217-- | When implementing the handler for a 'Get' endpoint,

330-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'

218-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'

331-- and 'Servant.API.Put.Put', the handler code runs in the

219-- and 'Servant.API.Put.Put', the handler code runs in the

332−-- @EitherT (Int, String) IO@ monad, where the 'Int' represents

220+-- @EitherT ServantErr IO@ monad, where the 'Int' represents

333-- the status code and the 'String' a message, returned in case of

221-- the status code and the 'String' a message, returned in case of

334-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

222-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

335-- to quickly fail if some conditions are not met.

223-- to quickly fail if some conditions are not met.

@@ -347,20 +235,7 @@ instance

347

235

348 type ServerT (Get ctypes a) m = m a

236 type ServerT (Get ctypes a) m = m a

349

237

350− route Proxy action request respond

238+ route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200

351− | pathIsEmpty request && requestMethod request == methodGet = do

352− e <- runEitherT action

353− respond $ case e of

354− Right output -> do

355− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

356− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

357− Nothing -> failWith UnsupportedMediaType

358− Just (contentT, body) -> succeedWith $

359− responseLBS ok200 [ ("Content-Type" , cs contentT)] body

360− Left err -> succeedWith $ responseServantErr err

361− | pathIsEmpty request && requestMethod request /= methodGet =

362− respond $ failWith WrongMethod

363− | otherwise = respond $ failWith NotFound

364

239

365-- '()' ==> 204 No Content

240-- '()' ==> 204 No Content

366instance

241instance

@@ -371,15 +246,7 @@ instance

371

246

372 type ServerT (Get ctypes ()) m = m ()

247 type ServerT (Get ctypes ()) m = m ()

373

248

374− route Proxy action request respond

249+ route Proxy = methodRouterEmpty methodGet

375− | pathIsEmpty request && requestMethod request == methodGet = do

376− e <- runEitherT action

377− respond . succeedWith $ case e of

378− Right () -> responseLBS noContent204 [] ""

379− Left err -> responseServantErr err

380− | pathIsEmpty request && requestMethod request /= methodGet =

381− respond $ failWith WrongMethod

382− | otherwise = respond $ failWith NotFound

383

250

384-- Add response headers

251-- Add response headers

385instance

252instance

@@ -391,21 +258,7 @@ instance

391

258

392 type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)

259 type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)

393

260

394− route Proxy action request respond

261+ route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200

395− | pathIsEmpty request && requestMethod request == methodGet = do

396− e <- runEitherT action

397− respond $ case e of

398− Right output -> do

399− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

400− headers = getHeaders output

401− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

402− Nothing -> failWith UnsupportedMediaType

403− Just (contentT, body) -> succeedWith $

404− responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body

405− Left err -> succeedWith $ responseServantErr err

406− | pathIsEmpty request && requestMethod request /= methodGet =

407− respond $ failWith WrongMethod

408− | otherwise = respond $ failWith NotFound

409

262

410-- | If you use 'Header' in one of the endpoints for your API,

263-- | If you use 'Header' in one of the endpoints for your API,

411-- this automatically requires your server-side handler to be a function

264-- this automatically requires your server-side handler to be a function

@@ -425,7 +278,7 @@ instance

425-- >

278-- >

426-- > server :: Server MyApi

279-- > server :: Server MyApi

427-- > server = viewReferer

280-- > server = viewReferer

428−-- > where viewReferer :: Referer -> EitherT (Int, String) IO referer

281+-- > where viewReferer :: Referer -> EitherT ServantErr IO referer

429-- > viewReferer referer = return referer

282-- > viewReferer referer = return referer

430instance (KnownSymbol sym, FromText a, HasServer sublayout)

283instance (KnownSymbol sym, FromText a, HasServer sublayout)

431 => HasServer (Header sym a :> sublayout) where

284 => HasServer (Header sym a :> sublayout) where

@@ -433,16 +286,15 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

433 type ServerT (Header sym a :> sublayout) m =

286 type ServerT (Header sym a :> sublayout) m =

434 Maybe a -> ServerT sublayout m

287 Maybe a -> ServerT sublayout m

435

288

436− route Proxy subserver request respond = do

289+ route Proxy subserver = WithRequest $ \ request ->

437 let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)

290 let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)

438− route (Proxy :: Proxy sublayout) (subserver mheader) request respond

291+ in route (Proxy :: Proxy sublayout) (feedTo subserver mheader)

439−

440− where str = fromString $ symbolVal (Proxy :: Proxy sym)

292+ where str = fromString $ symbolVal (Proxy :: Proxy sym)

441

293

442-- | When implementing the handler for a 'Post' endpoint,

294-- | When implementing the handler for a 'Post' endpoint,

443-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

295-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

444-- and 'Servant.API.Put.Put', the handler code runs in the

296-- and 'Servant.API.Put.Put', the handler code runs in the

445−-- @EitherT (Int, String) IO@ monad, where the 'Int' represents

297+-- @EitherT ServantErr IO@ monad, where the 'Int' represents

446-- the status code and the 'String' a message, returned in case of

298-- the status code and the 'String' a message, returned in case of

447-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

299-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

448-- to quickly fail if some conditions are not met.

300-- to quickly fail if some conditions are not met.

@@ -461,20 +313,7 @@ instance

461

313

462 type ServerT (Post ctypes a) m = m a

314 type ServerT (Post ctypes a) m = m a

463

315

464− route Proxy action request respond

316+ route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201

465− | pathIsEmpty request && requestMethod request == methodPost = do

466− e <- runEitherT action

467− respond $ case e of

468− Right output -> do

469− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

470− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

471− Nothing -> failWith UnsupportedMediaType

472− Just (contentT, body) -> succeedWith $

473− responseLBS status201 [ ("Content-Type" , cs contentT)] body

474− Left err -> succeedWith $ responseServantErr err

475− | pathIsEmpty request && requestMethod request /= methodPost =

476− respond $ failWith WrongMethod

477− | otherwise = respond $ failWith NotFound

478

317

479instance

318instance

480#if MIN_VERSION_base(4,8,0)

319#if MIN_VERSION_base(4,8,0)

@@ -484,15 +323,7 @@ instance

484

323

485 type ServerT (Post ctypes ()) m = m ()

324 type ServerT (Post ctypes ()) m = m ()

486

325

487− route Proxy action request respond

326+ route Proxy = methodRouterEmpty methodPost

488− | pathIsEmpty request && requestMethod request == methodPost = do

489− e <- runEitherT action

490− respond . succeedWith $ case e of

491− Right () -> responseLBS noContent204 [] ""

492− Left err -> responseServantErr err

493− | pathIsEmpty request && requestMethod request /= methodPost =

494− respond $ failWith WrongMethod

495− | otherwise = respond $ failWith NotFound

496

327

497-- Add response headers

328-- Add response headers

498instance

329instance

@@ -504,26 +335,12 @@ instance

504

335

505 type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)

336 type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)

506

337

507− route Proxy action request respond

338+ route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201

508− | pathIsEmpty request && requestMethod request == methodPost = do

509− e <- runEitherT action

510− respond $ case e of

511− Right output -> do

512− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

513− headers = getHeaders output

514− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

515− Nothing -> failWith UnsupportedMediaType

516− Just (contentT, body) -> succeedWith $

517− responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body

518− Left err -> succeedWith $ responseServantErr err

519− | pathIsEmpty request && requestMethod request /= methodPost =

520− respond $ failWith WrongMethod

521− | otherwise = respond $ failWith NotFound

522

339

523-- | When implementing the handler for a 'Put' endpoint,

340-- | When implementing the handler for a 'Put' endpoint,

524-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

341-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

525-- and 'Servant.API.Post.Post', the handler code runs in the

342-- and 'Servant.API.Post.Post', the handler code runs in the

526−-- @EitherT (Int, String) IO@ monad, where the 'Int' represents

343+-- @EitherT ServantErr IO@ monad, where the 'Int' represents

527-- the status code and the 'String' a message, returned in case of

344-- the status code and the 'String' a message, returned in case of

528-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

345-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

529-- to quickly fail if some conditions are not met.

346-- to quickly fail if some conditions are not met.

@@ -541,20 +358,7 @@ instance

541

358

542 type ServerT (Put ctypes a) m = m a

359 type ServerT (Put ctypes a) m = m a

543

360

544− route Proxy action request respond

361+ route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200

545− | pathIsEmpty request && requestMethod request == methodPut = do

546− e <- runEitherT action

547− respond $ case e of

548− Right output -> do

549− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

550− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

551− Nothing -> failWith UnsupportedMediaType

552− Just (contentT, body) -> succeedWith $

553− responseLBS status200 [ ("Content-Type" , cs contentT)] body

554− Left err -> succeedWith $ responseServantErr err

555− | pathIsEmpty request && requestMethod request /= methodPut =

556− respond $ failWith WrongMethod

557− | otherwise = respond $ failWith NotFound

558

362

559instance

363instance

560#if MIN_VERSION_base(4,8,0)

364#if MIN_VERSION_base(4,8,0)

@@ -564,15 +368,7 @@ instance

564

368

565 type ServerT (Put ctypes ()) m = m ()

369 type ServerT (Put ctypes ()) m = m ()

566

370

567− route Proxy action request respond

371+ route Proxy = methodRouterEmpty methodPut

568− | pathIsEmpty request && requestMethod request == methodPut = do

569− e <- runEitherT action

570− respond . succeedWith $ case e of

571− Right () -> responseLBS noContent204 [] ""

572− Left err -> responseServantErr err

573− | pathIsEmpty request && requestMethod request /= methodPut =

574− respond $ failWith WrongMethod

575− | otherwise = respond $ failWith NotFound

576

372

577-- Add response headers

373-- Add response headers

578instance

374instance

@@ -584,26 +380,12 @@ instance

584

380

585 type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)

381 type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)

586

382

587− route Proxy action request respond

383+ route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200

588− | pathIsEmpty request && requestMethod request == methodPut = do

589− e <- runEitherT action

590− respond $ case e of

591− Right output -> do

592− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

593− headers = getHeaders output

594− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

595− Nothing -> failWith UnsupportedMediaType

596− Just (contentT, body) -> succeedWith $

597− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

598− Left err -> succeedWith $ responseServantErr err

599− | pathIsEmpty request && requestMethod request /= methodPut =

600− respond $ failWith WrongMethod

601− | otherwise = respond $ failWith NotFound

602

384

603-- | When implementing the handler for a 'Patch' endpoint,

385-- | When implementing the handler for a 'Patch' endpoint,

604-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

386-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

605-- and 'Servant.API.Put.Put', the handler code runs in the

387-- and 'Servant.API.Put.Put', the handler code runs in the

606−-- @EitherT (Int, String) IO@ monad, where the 'Int' represents

388+-- @EitherT ServantErr IO@ monad, where the 'Int' represents

607-- the status code and the 'String' a message, returned in case of

389-- the status code and the 'String' a message, returned in case of

608-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

390-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

609-- to quickly fail if some conditions are not met.

391-- to quickly fail if some conditions are not met.

@@ -619,20 +401,7 @@ instance

619

401

620 type ServerT (Patch ctypes a) m = m a

402 type ServerT (Patch ctypes a) m = m a

621

403

622− route Proxy action request respond

404+ route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200

623− | pathIsEmpty request && requestMethod request == methodPatch = do

624− e <- runEitherT action

625− respond $ case e of

626− Right output -> do

627− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

628− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

629− Nothing -> failWith UnsupportedMediaType

630− Just (contentT, body) -> succeedWith $

631− responseLBS status200 [ ("Content-Type" , cs contentT)] body

632− Left err -> succeedWith $ responseServantErr err

633− | pathIsEmpty request && requestMethod request /= methodPatch =

634− respond $ failWith WrongMethod

635− | otherwise = respond $ failWith NotFound

636

405

637instance

406instance

638#if MIN_VERSION_base(4,8,0)

407#if MIN_VERSION_base(4,8,0)

@@ -642,15 +411,7 @@ instance

642

411

643 type ServerT (Patch ctypes ()) m = m ()

412 type ServerT (Patch ctypes ()) m = m ()

644

413

645− route Proxy action request respond

414+ route Proxy = methodRouterEmpty methodPatch

646− | pathIsEmpty request && requestMethod request == methodPatch = do

647− e <- runEitherT action

648− respond . succeedWith $ case e of

649− Right () -> responseLBS noContent204 [] ""

650− Left err -> responseServantErr err

651− | pathIsEmpty request && requestMethod request /= methodPatch =

652− respond $ failWith WrongMethod

653− | otherwise = respond $ failWith NotFound

654

415

655-- Add response headers

416-- Add response headers

656instance

417instance

@@ -662,21 +423,7 @@ instance

662

423

663 type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)

424 type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)

664

425

665− route Proxy action request respond

426+ route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200

666− | pathIsEmpty request && requestMethod request == methodPatch = do

667− e <- runEitherT action

668− respond $ case e of

669− Right outpatch -> do

670− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

671− headers = getHeaders outpatch

672− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of

673− Nothing -> failWith UnsupportedMediaType

674− Just (contentT, body) -> succeedWith $

675− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

676− Left err -> succeedWith $ responseServantErr err

677− | pathIsEmpty request && requestMethod request /= methodPatch =

678− respond $ failWith WrongMethod

679− | otherwise = respond $ failWith NotFound

680

427

681-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

428-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

682-- this automatically requires your server-side handler to be a function

429-- this automatically requires your server-side handler to be a function

@@ -696,7 +443,7 @@ instance

696-- >

443-- >

697-- > server :: Server MyApi

444-- > server :: Server MyApi

698-- > server = getBooksBy

445-- > server = getBooksBy

699−-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]

446+-- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]

700-- > getBooksBy Nothing = ...return all books...

447-- > getBooksBy Nothing = ...return all books...

701-- > getBooksBy (Just author) = ...return books by the given author...

448-- > getBooksBy (Just author) = ...return books by the given author...

702instance (KnownSymbol sym, FromText a, HasServer sublayout)

449instance (KnownSymbol sym, FromText a, HasServer sublayout)

@@ -705,7 +452,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

705 type ServerT (QueryParam sym a :> sublayout) m =

452 type ServerT (QueryParam sym a :> sublayout) m =

706 Maybe a -> ServerT sublayout m

453 Maybe a -> ServerT sublayout m

707

454

708− route Proxy subserver request respond = do

455+ route Proxy subserver = WithRequest $ \ request ->

709 let querytext = parseQueryText $ rawQueryString request

456 let querytext = parseQueryText $ rawQueryString request

710 param =

457 param =

711 case lookup paramname querytext of

458 case lookup paramname querytext of

@@ -713,9 +460,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

713 Just Nothing -> Nothing -- param present with no value -> Nothing

460 Just Nothing -> Nothing -- param present with no value -> Nothing

714 Just (Just v) -> fromText v -- if present, we try to convert to

461 Just (Just v) -> fromText v -- if present, we try to convert to

715 -- the right type

462 -- the right type

716−

717− route (Proxy :: Proxy sublayout) (subserver param) request respond

463+ in route (Proxy :: Proxy sublayout) (feedTo subserver param)

718−

719 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

464 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

720

465

721-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,

466-- | 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)

735-- >

480-- >

736-- > server :: Server MyApi

481-- > server :: Server MyApi

737-- > server = getBooksBy

482-- > server = getBooksBy

738−-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]

483+-- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]

739-- > getBooksBy authors = ...return all books by these authors...

484-- > getBooksBy authors = ...return all books by these authors...

740instance (KnownSymbol sym, FromText a, HasServer sublayout)

485instance (KnownSymbol sym, FromText a, HasServer sublayout)

741 => HasServer (QueryParams sym a :> sublayout) where

486 => HasServer (QueryParams sym a :> sublayout) where

@@ -743,16 +488,14 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

743 type ServerT (QueryParams sym a :> sublayout) m =

488 type ServerT (QueryParams sym a :> sublayout) m =

744 [a] -> ServerT sublayout m

489 [a] -> ServerT sublayout m

745

490

746− route Proxy subserver request respond = do

491+ route Proxy subserver = WithRequest $ \ request ->

747 let querytext = parseQueryText $ rawQueryString request

492 let querytext = parseQueryText $ rawQueryString request

748 -- if sym is "foo", we look for query string parameters

493 -- if sym is "foo", we look for query string parameters

749 -- named "foo" or "foo[]" and call fromText on the

494 -- named "foo" or "foo[]" and call fromText on the

750 -- corresponding values

495 -- corresponding values

751 parameters = filter looksLikeParam querytext

496 parameters = filter looksLikeParam querytext

752 values = catMaybes $ map (convert . snd) parameters

497 values = catMaybes $ map (convert . snd) parameters

753−

754− route (Proxy :: Proxy sublayout) (subserver values) request respond

498+ in route (Proxy :: Proxy sublayout) (feedTo subserver values)

755−

756 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

499 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

757 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")

500 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")

758 convert Nothing = Nothing

501 convert Nothing = Nothing

@@ -768,7 +511,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

768-- >

511-- >

769-- > server :: Server MyApi

512-- > server :: Server MyApi

770-- > server = getBooks

513-- > server = getBooks

771−-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]

514+-- > where getBooks :: Bool -> EitherT ServantErr IO [Book]

772-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...

515-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...

773instance (KnownSymbol sym, HasServer sublayout)

516instance (KnownSymbol sym, HasServer sublayout)

774 => HasServer (QueryFlag sym :> sublayout) where

517 => HasServer (QueryFlag sym :> sublayout) where

@@ -776,15 +519,13 @@ instance (KnownSymbol sym, HasServer sublayout)

776 type ServerT (QueryFlag sym :> sublayout) m =

519 type ServerT (QueryFlag sym :> sublayout) m =

777 Bool -> ServerT sublayout m

520 Bool -> ServerT sublayout m

778

521

779− route Proxy subserver request respond = do

522+ route Proxy subserver = WithRequest $ \ request ->

780 let querytext = parseQueryText $ rawQueryString request

523 let querytext = parseQueryText $ rawQueryString request

781 param = case lookup paramname querytext of

524 param = case lookup paramname querytext of

782 Just Nothing -> True -- param is there, with no value

525 Just Nothing -> True -- param is there, with no value

783 Just (Just v) -> examine v -- param with a value

526 Just (Just v) -> examine v -- param with a value

784 Nothing -> False -- param not in the query string

527 Nothing -> False -- param not in the query string

785−

786− route (Proxy :: Proxy sublayout) (subserver param) request respond

528+ in route (Proxy :: Proxy sublayout) (feedTo subserver param)

787−

788 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

529 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

789 examine v | v == "true" || v == "1" || v == "" = True

530 examine v | v == "true" || v == "1" || v == "" = True

790 | otherwise = False

531 | otherwise = False

@@ -810,7 +551,7 @@ parseMatrixText = parseQueryText

810-- >

551-- >

811-- > server :: Server MyApi

552-- > server :: Server MyApi

812-- > server = getBooksBy

553-- > server = getBooksBy

813−-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book]

554+-- > where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book]

814-- > getBooksBy Nothing = ...return all books...

555-- > getBooksBy Nothing = ...return all books...

815-- > getBooksBy (Just author) = ...return books by the given author...

556-- > getBooksBy (Just author) = ...return books by the given author...

816instance (KnownSymbol sym, FromText a, HasServer sublayout)

557instance (KnownSymbol sym, FromText a, HasServer sublayout)

@@ -819,16 +560,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

819 type ServerT (MatrixParam sym a :> sublayout) m =

560 type ServerT (MatrixParam sym a :> sublayout) m =

820 Maybe a -> ServerT sublayout m

561 Maybe a -> ServerT sublayout m

821

562

563+ route Proxy subserver = WithRequest $ \ request ->

822− route Proxy subserver request respond = case parsePathInfo request of

564+ case parsePathInfo request of

823− (first : _)

565+ (first : _)

824− -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first

566+ -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first

825− param = case lookup paramname querytext of

567+ param = case lookup paramname querytext of

826− Nothing -> Nothing -- param absent from the query string

568+ Nothing -> Nothing -- param absent from the query string

827− Just Nothing -> Nothing -- param present with no value -> Nothing

569+ Just Nothing -> Nothing -- param present with no value -> Nothing

828− Just (Just v) -> fromText v -- if present, we try to convert to

570+ Just (Just v) -> fromText v -- if present, we try to convert to

829− -- the right type

571+ -- the right type

830− route (Proxy :: Proxy sublayout) (subserver param) request respond

572+ route (Proxy :: Proxy sublayout) (feedTo subserver param)

831− _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond

573+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver Nothing)

832

574

833 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

575 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

834

576

@@ -849,7 +591,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

849-- >

591-- >

850-- > server :: Server MyApi

592-- > server :: Server MyApi

851-- > server = getBooksBy

593-- > server = getBooksBy

852−-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book]

594+-- > where getBooksBy :: [Text] -> EitherT ServantErr IO [Book]

853-- > getBooksBy authors = ...return all books by these authors...

595-- > getBooksBy authors = ...return all books by these authors...

854instance (KnownSymbol sym, FromText a, HasServer sublayout)

596instance (KnownSymbol sym, FromText a, HasServer sublayout)

855 => HasServer (MatrixParams sym a :> sublayout) where

597 => HasServer (MatrixParams sym a :> sublayout) where

@@ -857,16 +599,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

857 type ServerT (MatrixParams sym a :> sublayout) m =

599 type ServerT (MatrixParams sym a :> sublayout) m =

858 [a] -> ServerT sublayout m

600 [a] -> ServerT sublayout m

859

601

602+ route Proxy subserver = WithRequest $ \ request ->

860− route Proxy subserver request respond = case parsePathInfo request of

603+ case parsePathInfo request of

861− (first : _)

604+ (first : _)

862− -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first

605+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first

863− -- if sym is "foo", we look for matrix parameters

606+ -- if sym is "foo", we look for matrix parameters

864− -- named "foo" or "foo[]" and call fromText on the

607+ -- named "foo" or "foo[]" and call fromText on the

865− -- corresponding values

608+ -- corresponding values

866− parameters = filter looksLikeParam matrixtext

609+ parameters = filter looksLikeParam matrixtext

867− values = catMaybes $ map (convert . snd) parameters

610+ values = catMaybes $ map (convert . snd) parameters

868− route (Proxy :: Proxy sublayout) (subserver values) request respond

611+ route (Proxy :: Proxy sublayout) (feedTo subserver values)

869− _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond

612+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])

870

613

871 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

614 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

872 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")

615 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")

@@ -883,7 +626,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

883-- >

626-- >

884-- > server :: Server MyApi

627-- > server :: Server MyApi

885-- > server = getBooks

628-- > server = getBooks

886−-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book]

629+-- > where getBooks :: Bool -> EitherT ServantErr IO [Book]

887-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...

630-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...

888instance (KnownSymbol sym, HasServer sublayout)

631instance (KnownSymbol sym, HasServer sublayout)

889 => HasServer (MatrixFlag sym :> sublayout) where

632 => HasServer (MatrixFlag sym :> sublayout) where

@@ -891,17 +634,18 @@ instance (KnownSymbol sym, HasServer sublayout)

891 type ServerT (MatrixFlag sym :> sublayout) m =

634 type ServerT (MatrixFlag sym :> sublayout) m =

892 Bool -> ServerT sublayout m

635 Bool -> ServerT sublayout m

893

636

637+ route Proxy subserver = WithRequest $ \ request ->

894− route Proxy subserver request respond = case parsePathInfo request of

638+ case parsePathInfo request of

895− (first : _)

639+ (first : _)

896− -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first

640+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first

897− param = case lookup paramname matrixtext of

641+ param = case lookup paramname matrixtext of

898− Just Nothing -> True -- param is there, with no value

642+ Just Nothing -> True -- param is there, with no value

899− Just (Just v) -> examine v -- param with a value

643+ Just (Just v) -> examine v -- param with a value

900− Nothing -> False -- param not in the query string

644+ Nothing -> False -- param not in the query string

901−

645+

902− route (Proxy :: Proxy sublayout) (subserver param) request respond

646+ route (Proxy :: Proxy sublayout) (feedTo subserver param)

903−

647+

904− _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond

648+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)

905

649

906 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

650 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

907 examine v | v == "true" || v == "1" || v == "" = True

651 examine v | v == "true" || v == "1" || v == "" = True

@@ -919,8 +663,11 @@ instance HasServer Raw where

919

663

920 type ServerT Raw m = Application

664 type ServerT Raw m = Application

921

665

922− route Proxy rawApplication request respond =

666+ route Proxy rawApplication = LeafRouter $ \ request respond -> do

667+ r <- rawApplication

668+ case r of

669+ RR (Left err) -> respond $ failWith err

923− rawApplication request (respond . succeedWith)

670+ RR (Right app) -> app request (respond . succeedWith)

924

671

925-- | If you use 'ReqBody' in one of the endpoints for your API,

672-- | If you use 'ReqBody' in one of the endpoints for your API,

926-- this automatically requires your server-side handler to be a function

673-- this automatically requires your server-side handler to be a function

@@ -940,7 +687,7 @@ instance HasServer Raw where

940-- >

687-- >

941-- > server :: Server MyApi

688-- > server :: Server MyApi

942-- > server = postBook

689-- > server = postBook

943−-- > where postBook :: Book -> EitherT (Int, String) IO Book

690+-- > where postBook :: Book -> EitherT ServantErr IO Book

944-- > postBook book = ...insert into your db...

691-- > postBook book = ...insert into your db...

945instance ( AllCTUnrender list a, HasServer sublayout

692instance ( AllCTUnrender list a, HasServer sublayout

946 ) => HasServer (ReqBody list a :> sublayout) where

693 ) => HasServer (ReqBody list a :> sublayout) where

@@ -948,19 +695,20 @@ instance ( AllCTUnrender list a, HasServer sublayout

948 type ServerT (ReqBody list a :> sublayout) m =

695 type ServerT (ReqBody list a :> sublayout) m =

949 a -> ServerT sublayout m

696 a -> ServerT sublayout m

950

697

951− route Proxy subserver request respond = do

698+ route Proxy subserver = WithRequest $ \ request ->

699+ route (Proxy :: Proxy sublayout) $ do

952− -- See HTTP RFC 2616, section 7.2.1

700+ -- See HTTP RFC 2616, section 7.2.1

953− -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1

701+ -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1

954− -- See also "W3C Internet Media Type registration, consistency of use"

702+ -- See also "W3C Internet Media Type registration, consistency of use"

955− -- http://www.w3.org/2001/tag/2002/0129-mime

703+ -- http://www.w3.org/2001/tag/2002/0129-mime

956− let contentTypeH = fromMaybe "application/octet-stream"

704+ let contentTypeH = fromMaybe "application/octet-stream"

957− $ lookup hContentType $ requestHeaders request

705+ $ lookup hContentType $ requestHeaders request

958− mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

706+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

959− <$> lazyRequestBody request

707+ <$> lazyRequestBody request

960− case mrqbody of

708+ case mrqbody of

961− Nothing -> respond . failWith $ UnsupportedMediaType

709+ Nothing -> return $ failWith $ UnsupportedMediaType

962− Just (Left e) -> respond . failWith $ InvalidBody e

710+ Just (Left e) -> return $ failWith $ InvalidBody e

963− Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond

711+ Just (Right v) -> feedTo subserver v

964

712

965-- | Make sure the incoming request starts with @"/path"@, strip it and

713-- | Make sure the incoming request starts with @"/path"@, strip it and

966-- pass the rest of the request path to @sublayout@.

714-- pass the rest of the request path to @sublayout@.

@@ -968,14 +716,9 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout

968

716

969 type ServerT (path :> sublayout) m = ServerT sublayout m

717 type ServerT (path :> sublayout) m = ServerT sublayout m

970

718

971− route Proxy subserver request respond = case processedPathInfo request of

719+ route Proxy subserver = StaticRouter $

972− (first : rest)

973− | first == cs (symbolVal proxyPath)

720+ M.singleton (cs (symbolVal proxyPath))

974− -> route (Proxy :: Proxy sublayout) subserver request{

721+ (route (Proxy :: Proxy sublayout) subserver)

975− pathInfo = rest

976− } respond

977− _ -> respond $ failWith NotFound

978−

979 where proxyPath = Proxy :: Proxy path

722 where proxyPath = Proxy :: Proxy path

980

723

981ct_wildcard :: B.ByteString

724ct_wildcard :: B.ByteString

servant-server/src/Servant/Server/Internal/PathInfo.hsnew file+38

@@ -0,0 +1,38 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Servant.Server.Internal.PathInfo where

4+import Data.List (unfoldr)

5+import Data.Text (Text)

6+import qualified Data.Text as T

7+import Network.Wai (Request, pathInfo)

9+-- | Like `null . pathInfo`, but works with redundant trailing slashes.

10+pathIsEmpty :: Request -> Bool

11+pathIsEmpty = f . processedPathInfo

12+ where

13+ f [] = True

14+ f [""] = True

15+ f _ = False

16+

17+

18+splitMatrixParameters :: Text -> (Text, Text)

19+splitMatrixParameters = T.break (== ';')

20+

21+parsePathInfo :: Request -> [Text]

22+parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo

23+ where mergePairs = concat . unfoldr pairToList

24+ pairToList [] = Nothing

25+ pairToList ((a, b):xs) = Just ([a, b], xs)

26+

27+-- | Returns a processed pathInfo from the request.

28+--

29+-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be

30+-- processed, so routing works as intended. Therefor this function should be used to access

31+-- the pathInfo for routing purposes.

32+processedPathInfo :: Request -> [Text]

33+processedPathInfo r =

34+ case pinfo of

35+ (x:xs) | T.head x == ';' -> xs

36+ _ -> pinfo

37+ where pinfo = parsePathInfo r

38+

servant-server/src/Servant/Server/Internal/Router.hsnew file+72

@@ -0,0 +1,72 @@

1+module Servant.Server.Internal.Router where

3+import Data.Map (Map)

4+import qualified Data.Map as M

5+import Data.Monoid ((<>))

6+import Data.Text (Text)

7+import Network.Wai (Request, pathInfo)

8+import Servant.Server.Internal.PathInfo

9+import Servant.Server.Internal.RoutingApplication

10+

11+-- | Internal representation of a router.

12+data Router =

13+ WithRequest (Request -> Router)

14+ -- ^ current request is passed to the router

15+ | StaticRouter (Map Text Router)

16+ -- ^ first path component used for lookup and removed afterwards

17+ | DynamicRouter (Text -> Router)

18+ -- ^ first path component used for lookup and removed afterwards

19+ | LeafRouter RoutingApplication

20+ -- ^ to be used for routes that match an empty path

21+ | Choice Router Router

22+ -- ^ left-biased choice between two routers

23+

24+-- | Smart constructor for the choice between routers.

25+-- We currently optimize the following cases:

26+--

27+-- * Two static routers can be joined by joining their maps.

28+-- * Two dynamic routers can be joined by joining their codomains.

29+-- * Two 'WithRequest' routers can be joined by passing them

30+-- the same request and joining their codomains.

31+-- * A 'WithRequest' router can be joined with anything else by

32+-- passing the same request to both but ignoring it in the

33+-- component that does not need it.

34+--

35+choice :: Router -> Router -> Router

36+choice (StaticRouter table1) (StaticRouter table2) =

37+ StaticRouter (M.unionWith choice table1 table2)

38+choice (DynamicRouter fun1) (DynamicRouter fun2) =

39+ DynamicRouter (\ first -> choice (fun1 first) (fun2 first))

40+choice (WithRequest router1) (WithRequest router2) =

41+ WithRequest (\ request -> choice (router1 request) (router2 request))

42+choice (WithRequest router1) router2 =

43+ WithRequest (\ request -> choice (router1 request) router2)

44+choice router1 (WithRequest router2) =

45+ WithRequest (\ request -> choice router1 (router2 request))

46+choice router1 router2 = Choice router1 router2

47+

48+-- | Interpret a router as an application.

49+runRouter :: Router -> RoutingApplication

50+runRouter (WithRequest router) request respond =

51+ runRouter (router request) request respond

52+runRouter (StaticRouter table) request respond =

53+ case processedPathInfo request of

54+ first : rest

55+ | Just router <- M.lookup first table

56+ -> let request' = request { pathInfo = rest }

57+ in runRouter router request' respond

58+ _ -> respond $ failWith NotFound

59+runRouter (DynamicRouter fun) request respond =

60+ case processedPathInfo request of

61+ first : rest

62+ -> let request' = request { pathInfo = rest }

63+ in runRouter (fun first) request' respond

64+ _ -> respond $ failWith NotFound

65+runRouter (LeafRouter app) request respond = app request respond

66+runRouter (Choice r1 r2) request respond =

67+ runRouter r1 request $ \ mResponse1 ->

68+ if isMismatch mResponse1

69+ then runRouter r2 request $ \ mResponse2 ->

70+ respond (mResponse1 <> mResponse2)

71+ else respond mResponse1

72+

servant-server/src/Servant/Server/Internal/RoutingApplication.hsnew file+144

@@ -0,0 +1,144 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeOperators #-}

5+module Servant.Server.Internal.RoutingApplication where

7+#if !MIN_VERSION_base(4,8,0)

8+import Control.Applicative (Applicative, (<$>))

9+import Data.Monoid (Monoid, mappend, mempty)

10+#endif

11+import Control.Monad.Trans.Either (EitherT, runEitherT)

12+import qualified Data.ByteString as B

13+import qualified Data.ByteString.Lazy as BL

14+import Data.IORef (newIORef, readIORef, writeIORef)

15+import Data.Maybe (fromMaybe)

16+import Data.Monoid ((<>))

17+import Data.String (fromString)

18+import Network.HTTP.Types hiding (Header, ResponseHeaders)

19+import Network.Wai (Application, Request, Response,

20+ ResponseReceived,

21+ requestBody,

22+ responseLBS,

23+ strictRequestBody)

24+import Servant.API ((:<|>) (..))

25+import Servant.Server.Internal.ServantErr

26+

27+type RoutingApplication =

28+ Request -- ^ the request, the field 'pathInfo' may be modified by url routing

29+ -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived

30+

31+-- | A wrapper around @'Either' 'RouteMismatch' a@.

32+newtype RouteResult a =

33+ RR { routeResult :: Either RouteMismatch a }

34+ deriving (Eq, Show, Functor, Applicative)

35+

36+-- | If we get a `Right`, it has precedence over everything else.

37+--

38+-- This in particular means that if we could get several 'Right's,

39+-- only the first we encounter would be taken into account.

40+instance Monoid (RouteResult a) where

41+ mempty = RR $ Left mempty

42+

43+ RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)

44+ RR (Left _) `mappend` RR (Right y) = RR $ Right y

45+ r `mappend` _ = r

46+

47+-- Note that the ordering of the constructors has great significance! It

48+-- determines the Ord instance and, consequently, the monoid instance.

49+data RouteMismatch =

50+ NotFound -- ^ the usual "not found" error

51+ | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error

52+ | UnsupportedMediaType -- ^ request body has unsupported media type

53+ | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error

54+ | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.

55+ deriving (Eq, Ord, Show)

56+

57+instance Monoid RouteMismatch where

58+ mempty = NotFound

59+ -- The following isn't great, since it picks @InvalidBody@ based on

60+ -- alphabetical ordering, but any choice would be arbitrary.

61+ --

62+ -- "As one judge said to the other, 'Be just and if you can't be just, be

63+ -- arbitrary'" -- William Burroughs

64+ mappend = max

65+

66+data ReqBodyState = Uncalled

67+ | Called !B.ByteString

68+ | Done !B.ByteString

69+

70+toApplication :: RoutingApplication -> Application

71+toApplication ra request respond = do

72+ reqBodyRef <- newIORef Uncalled

73+ -- We may need to consume the requestBody more than once. In order to

74+ -- maintain the illusion that 'requestBody' works as expected,

75+ -- 'ReqBodyState' is introduced, and the complete body is memoized and

76+ -- returned as many times as requested with empty "Done" marker chunks in

77+ -- between.

78+ -- See https://github.com/haskell-servant/servant/issues/3

79+ let memoReqBody = do

80+ ior <- readIORef reqBodyRef

81+ case ior of

82+ Uncalled -> do

83+ r <- BL.toStrict <$> strictRequestBody request

84+ writeIORef reqBodyRef $ Done r

85+ return r

86+ Called bs -> do

87+ writeIORef reqBodyRef $ Done bs

88+ return bs

89+ Done bs -> do

90+ writeIORef reqBodyRef $ Called bs

91+ return B.empty

92+

93+ ra request{ requestBody = memoReqBody } (routingRespond . routeResult)

94+ where

95+ routingRespond :: Either RouteMismatch Response -> IO ResponseReceived

96+ routingRespond (Left NotFound) =

97+ respond $ responseLBS notFound404 [] "not found"

98+ routingRespond (Left WrongMethod) =

99+ respond $ responseLBS methodNotAllowed405 [] "method not allowed"

100+ routingRespond (Left (InvalidBody err)) =

101+ respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err

102+ routingRespond (Left UnsupportedMediaType) =

103+ respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"

104+ routingRespond (Left (HttpError status body)) =

105+ respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body

106+ routingRespond (Right response) =

107+ respond response

108+

109+runAction :: IO (RouteResult (EitherT ServantErr IO a))

110+ -> (RouteResult Response -> IO r)

111+ -> (a -> RouteResult Response)

112+ -> IO r

113+runAction action respond k = do

114+ r <- action

115+ go r

116+ where

117+ go (RR (Right a)) = do

118+ e <- runEitherT a

119+ respond $ case e of

120+ Right x -> k x

121+ Left err -> succeedWith $ responseServantErr err

122+ go (RR (Left err)) = respond $ failWith err

123+

124+feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)

125+feedTo f x = (($ x) <$>) <$> f

126+

127+extractL :: RouteResult (a :<|> b) -> RouteResult a

128+extractL (RR (Right (a :<|> _))) = RR (Right a)

129+extractL (RR (Left err)) = RR (Left err)

130+

131+extractR :: RouteResult (a :<|> b) -> RouteResult b

132+extractR (RR (Right (_ :<|> b))) = RR (Right b)

133+extractR (RR (Left err)) = RR (Left err)

134+

135+failWith :: RouteMismatch -> RouteResult a

136+failWith = RR . Left

137+

138+succeedWith :: a -> RouteResult a

139+succeedWith = RR . Right

140+

141+isMismatch :: RouteResult a -> Bool

142+isMismatch (RR (Left _)) = True

143+isMismatch _ = False

144+

servant-server/test/Servant/ServerSpec.hs+51−1

@@ -42,7 +42,8 @@ import Servant.API ((:<|>) (..), (:>),

42 Post, Put, QueryFlag, QueryParam,

43 QueryParams, Raw, ReqBody)

44import Servant.Server (Server, serve, ServantErr(..), err404)

45−import Servant.Server.Internal (RouteMismatch (..))

45+import Servant.Server.Internal.RoutingApplication

46+ (RouteMismatch (..))

48-- * test data types

49-- * test data types

@@ -89,6 +90,7 @@ spec = do

89 headerSpec

90 headerSpec

90 rawSpec

91 rawSpec

91 unionSpec

92 unionSpec

93+ prioErrorsSpec

92 errorsSpec

94 errorsSpec

93 responseHeadersSpec

95 responseHeadersSpec

@@ -572,6 +574,54 @@ responseHeadersSpec = describe "ResponseHeaders" $ do

572 Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""

574 Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""

573 `shouldRespondWith` 415

575 `shouldRespondWith` 415

574

576

577+type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer

578+

579+prioErrorsApi :: Proxy PrioErrorsApi

580+prioErrorsApi = Proxy

581+

582+-- | Test the relative priority of error responses from the server.

583+--

584+-- In particular, we check whether matching continues even if a 'ReqBody'

585+-- or similar construct is encountered early in a path. We don't want to

586+-- see a complaint about the request body unless the path actually matches.

587+--

588+prioErrorsSpec :: Spec

589+prioErrorsSpec = describe "PrioErrors" $ do

590+ let server = return . age

591+ with (return $ serve prioErrorsApi server) $ do

592+ let check (mdescr, method) path (cdescr, ctype, body) resp =

593+ it fulldescr $

594+ Test.Hspec.Wai.request method path [(hContentType, ctype)] body

595+ `shouldRespondWith` resp

596+ where

597+ fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr

598+ ++ " " ++ cs path ++ " (" ++ cdescr ++ ")"

599+

600+ get' = ("GET", methodGet)

601+ put' = ("PUT", methodPut)

602+

603+ txt = ("text" , "text/plain;charset=utf8" , "42" )

604+ ijson = ("invalid json", "application/json;charset=utf8", "invalid" )

605+ vjson = ("valid json" , "application/json;charset=utf8", encode alice)

606+

607+ check get' "/" txt 404

608+ check get' "/bar" txt 404

609+ check get' "/foo" txt 415

610+ check put' "/" txt 404

611+ check put' "/bar" txt 404

612+ check put' "/foo" txt 405

613+ check get' "/" ijson 404

614+ check get' "/bar" ijson 404

615+ check get' "/foo" ijson 400

616+ check put' "/" ijson 404

617+ check put' "/bar" ijson 404

618+ check put' "/foo" ijson 405

619+ check get' "/" vjson 404

620+ check get' "/bar" vjson 404

621+ check get' "/foo" vjson 200

622+ check put' "/" vjson 404

623+ check put' "/bar" vjson 404

624+ check put' "/foo" vjson 405

575

625

576-- | Test server error functionality.

626-- | Test server error functionality.

577errorsSpec :: Spec

627errorsSpec :: Spec

servant/CHANGELOG.md+9

@@ -1,3 +1,12 @@

1+0.4.2

2+-----

3+* Fix missing cases for `Patch` in `safeLink`

5+0.4.1

6+-----

7+* Allow whitespace after parsing JSON

8+* Stricter matching for `safeLink` for `Capture`

10.4

100.4

2---

11---

3* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

12* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

servant/servant.cabal+2−2

@@ -1,5 +1,5 @@

1name: servant

2−version: 0.4.0

2+version: 0.4.1

3synopsis: A family of combinators for defining webservices APIs

4description:

5 A family of combinators for defining webservices APIs and serving them

@@ -55,7 +55,7 @@ library

55 , http-media >= 0.4 && < 0.7

56 , http-types == 0.8.*

57 , text >= 1 && < 2

58− , string-conversions >= 0.3 && < 0.4

58+ , string-conversions >= 0.3 && < 0.5

59 , network-uri >= 2.6

60 hs-source-dirs: src

61 default-language: Haskell2010

servant/src/Servant/API/Capture.hs+1

@@ -9,6 +9,7 @@ import GHC.TypeLits (Symbol)

9-- | Capture a value from the request path under a certain type @a@.

10--

11-- Example:

12+--

12-- >>> -- GET /books/:isbn

13-- >>> -- GET /books/:isbn

13-- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

14-- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

14data Capture (sym :: Symbol) a

15data Capture (sym :: Symbol) a

servant/src/Servant/API/ContentTypes.hs+1−1

@@ -166,7 +166,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps

166 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept

167 where pctyps = Proxy :: Proxy ctyps

168 amrs = allMimeRender pctyps val

169− lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs

169+ lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs

170

171

172--------------------------------------------------------------------------

servant/src/Servant/Utils/Links.hs+9−3

@@ -72,8 +72,7 @@

72--

73-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ())

74-- >>> safeLink api bad_link

75−-- <BLANKLINE>

75+-- ...

76−-- <interactive>:64:1:

77-- Could not deduce (Or

76-- Could not deduce (Or

78-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))

77-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))

79-- (IsElem'

78-- (IsElem'

@@ -123,6 +122,7 @@ import Servant.API.Header ( Header )

123import Servant.API.Get ( Get )

122import Servant.API.Get ( Get )

124import Servant.API.Post ( Post )

123import Servant.API.Post ( Post )

125import Servant.API.Put ( Put )

124import Servant.API.Put ( Put )

125+import Servant.API.Patch ( Patch )

126import Servant.API.Delete ( Delete )

127import Servant.API.Sub ( type (:>) )

128import Servant.API.Raw ( Raw )

@@ -168,7 +168,8 @@ type family IsElem endpoint api :: Constraint where

168 IsElem (e :> sa) (e :> sb) = IsElem sa sb

169 IsElem sa (Header x :> sb) = IsElem sa sb

170 IsElem sa (ReqBody y x :> sb) = IsElem sa sb

171− IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb

171+ IsElem (Capture z y :> sa) (Capture x y :> sb)

172+ = IsElem sa sb

172 IsElem sa (QueryParam x y :> sb) = IsElem sa sb

173 IsElem sa (QueryParam x y :> sb) = IsElem sa sb

173 IsElem sa (QueryParams x y :> sb) = IsElem sa sb

174 IsElem sa (QueryParams x y :> sb) = IsElem sa sb

174 IsElem sa (QueryFlag x :> sb) = IsElem sa sb

175 IsElem sa (QueryFlag x :> sb) = IsElem sa sb

@@ -178,6 +179,7 @@ type family IsElem endpoint api :: Constraint where

178 IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'

179 IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'

179 IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct'

180 IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct'

180 IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'

181 IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'

182+ IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct'

181 IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'

183 IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'

182 IsElem e e = ()

184 IsElem e e = ()

183 IsElem e a = IsElem' e a

185 IsElem e a = IsElem' e a

@@ -352,6 +354,10 @@ instance HasLink (Put y r) where

352 type MkLink (Put y r) = URI

354 type MkLink (Put y r) = URI

353 toLink _ = linkURI

355 toLink _ = linkURI

354

356

357+instance HasLink (Patch y r) where

358+ type MkLink (Patch y r) = URI

359+ toLink _ = linkURI

360+

355instance HasLink (Delete y r) where

361instance HasLink (Delete y r) where

356 type MkLink (Delete y r) = URI

362 type MkLink (Delete y r) = URI

357 toLink _ = linkURI

363 toLink _ = linkURI