bf289cc · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #873 from phadej/modifiers

bf289ccOleg Grenrus9 years ago

servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+31−27

compare with master

unifiedsplit

@@ -25,7 +25,7 @@ import Data.Monoid ((<>))

25import Data.Proxy (Proxy (Proxy))

26import Data.Sequence (fromList)

27import Data.String (fromString)

28−import Data.Text (pack)

28+import Data.Text (Text, pack)

29import GHC.TypeLits (KnownSymbol, symbolVal)

30import qualified Network.HTTP.Types as H

31import Servant.API ((:<|>) ((:<|>)), (:>),

@@ -37,16 +37,17 @@ import Servant.API ((:<|>) ((:<|>)), (:>),

37 Capture, CaptureAll,

38 Description, EmptyAPI,

39 FramingUnrender (..),

40− Header, Headers (..),

40+ Header', Headers (..),

41 HttpVersion, IsSecure,

42 MimeRender (mimeRender),

43 MimeUnrender (mimeUnrender),

44 NoContent (NoContent),

45− QueryFlag, QueryParam,

45+ QueryFlag, QueryParam',

46 QueryParams, Raw,

47 ReflectMethod (..),

48− RemoteHost, ReqBody,

48+ RemoteHost, ReqBody',

49 ResultStream(..),

50+ SBoolI,

50 Stream,

51 Stream,

51 Summary, ToHttpApiData,

52 Summary, ToHttpApiData,

52 Vault, Verb,

53 Vault, Verb,

@@ -57,6 +58,9 @@ import Servant.API ((:<|>) ((:<|>)), (:>),

57 toQueryParam,

58 toQueryParam,

58 toUrlPiece)

59 toUrlPiece)

59import Servant.API.ContentTypes (contentTypes)

60import Servant.API.ContentTypes (contentTypes)

61+import Servant.API.Modifiers (FoldRequired,

62+ RequiredArgument,

63+ foldRequiredArgument)

61import Servant.Client.Core.Internal.Auth

65import Servant.Client.Core.Internal.Auth

62import Servant.Client.Core.Internal.BasicAuth

66import Servant.Client.Core.Internal.BasicAuth

@@ -325,20 +329,20 @@ instance OVERLAPPABLE_

325-- > viewReferer = client myApi

329-- > viewReferer = client myApi

326-- > -- then you can just use "viewRefer" to query that endpoint

330-- > -- then you can just use "viewRefer" to query that endpoint

327-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments

331-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments

328−instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

332+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))

329− => HasClient m (Header sym a :> api) where

333+ => HasClient m (Header' mods sym a :> api) where

330

334

331− type Client m (Header sym a :> api) =

335+ type Client m (Header' mods sym a :> api) =

332− Maybe a -> Client m api

336+ RequiredArgument mods a -> Client m api

333

337

334 clientWithRoute pm Proxy req mval =

338 clientWithRoute pm Proxy req mval =

335− clientWithRoute pm (Proxy :: Proxy api)

339+ clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument

336− (maybe req

340+ (Proxy :: Proxy mods) add (maybe req add) mval

337− (\value -> addHeader hname value req)

341+ where

338− mval

342+ hname = fromString $ symbolVal (Proxy :: Proxy sym)

339− )

340

343

341− where hname = fromString $ symbolVal (Proxy :: Proxy sym)

344+ add :: a -> Request

345+ add value = addHeader hname value req

342

346

343-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

347-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

344-- functions.

348-- functions.

@@ -388,22 +392,22 @@ instance HasClient m api => HasClient m (Description desc :> api) where

388-- > -- then you can just use "getBooksBy" to query that endpoint.

392-- > -- then you can just use "getBooksBy" to query that endpoint.

389-- > -- 'getBooksBy Nothing' for all books

393-- > -- 'getBooksBy Nothing' for all books

390-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov

394-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov

391−instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

395+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))

392− => HasClient m (QueryParam sym a :> api) where

396+ => HasClient m (QueryParam' mods sym a :> api) where

393

397

394− type Client m (QueryParam sym a :> api) =

398+ type Client m (QueryParam' mods sym a :> api) =

395− Maybe a -> Client m api

399+ RequiredArgument mods a -> Client m api

396

400

397 -- if mparam = Nothing, we don't add it to the query string

401 -- if mparam = Nothing, we don't add it to the query string

398 clientWithRoute pm Proxy req mparam =

402 clientWithRoute pm Proxy req mparam =

399− clientWithRoute pm (Proxy :: Proxy api)

403+ clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument

400− (maybe req

404+ (Proxy :: Proxy mods) add (maybe req add) mparam

405+ where

406+ add :: a -> Request

401− (flip (appendToQueryString pname) req . Just)

407+ add param = appendToQueryString pname (Just $ toQueryParam param) req

402− mparamText

403− )

404

408

409+ pname :: Text

405− where pname = pack $ symbolVal (Proxy :: Proxy sym)

410+ pname = pack $ symbolVal (Proxy :: Proxy sym)

406− mparamText = fmap toQueryParam mparam

407

411

408-- | If you use a 'QueryParams' in one of your endpoints in your API,

412-- | If you use a 'QueryParams' in one of your endpoints in your API,

409-- the corresponding querying function will automatically take

413-- the corresponding querying function will automatically take

@@ -514,9 +518,9 @@ instance RunClient m => HasClient m Raw where

514-- > addBook = client myApi

518-- > addBook = client myApi

515-- > -- then you can just use "addBook" to query that endpoint

519-- > -- then you can just use "addBook" to query that endpoint

516instance (MimeRender ct a, HasClient m api)

520instance (MimeRender ct a, HasClient m api)

517− => HasClient m (ReqBody (ct ': cts) a :> api) where

521+ => HasClient m (ReqBody' mods (ct ': cts) a :> api) where

518

522

519− type Client m (ReqBody (ct ': cts) a :> api) =

523+ type Client m (ReqBody' mods (ct ': cts) a :> api) =

520 a -> Client m api

524 a -> Client m api

521

525

522 clientWithRoute pm Proxy req body =

526 clientWithRoute pm Proxy req body =

servant-docs/src/Servant/Docs/Internal.hs+6−6

@@ -534,7 +534,7 @@ sampleByteStrings ctypes@Proxy Proxy =

534--

535-- Example of an instance:

536--

537−-- > instance ToParam (QueryParam "capital" Bool) where

537+-- > instance ToParam (QueryParam' mods "capital" Bool) where

538-- > toParam _ =

539-- > DocQueryParam "capital"

540-- > ["true", "false"]

@@ -859,7 +859,7 @@ instance OVERLAPPING_

859 p = Proxy :: Proxy a

860

861instance (KnownSymbol sym, HasDocs api)

862− => HasDocs (Header sym a :> api) where

862+ => HasDocs (Header' mods sym a :> api) where

863 docsFor Proxy (endpoint, action) =

864 docsFor subApiP (endpoint, action')

865

@@ -867,14 +867,14 @@ instance (KnownSymbol sym, HasDocs api)

867 action' = over headers (|> headername) action

868 headername = T.pack $ symbolVal (Proxy :: Proxy sym)

869

870−instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api)

870+instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)

871− => HasDocs (QueryParam sym a :> api) where

871+ => HasDocs (QueryParam' mods sym a :> api) where

872

873 docsFor Proxy (endpoint, action) =

874 docsFor subApiP (endpoint, action')

875

876 where subApiP = Proxy :: Proxy api

877− paramP = Proxy :: Proxy (QueryParam sym a)

877+ paramP = Proxy :: Proxy (QueryParam' mods sym a)

878 action' = over params (|> toParam paramP) action

879

880instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)

@@ -929,7 +929,7 @@ instance (KnownSymbol desc, HasDocs api)

929-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that

930-- both are even defined) for any particular type.

931instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)

932− => HasDocs (ReqBody (ct ': cts) a :> api) where

932+ => HasDocs (ReqBody' mods (ct ': cts) a :> api) where

933

934 docsFor Proxy (endpoint, action) opts@DocOptions{..} =

935 docsFor subApiP (endpoint, action') opts

servant-docs/test/Servant/DocsSpec.hs+3−1

@@ -33,7 +33,9 @@ import Servant.Docs.Internal

33-- This declaration simply checks that all instances are in place.

34_ = docs comprehensiveAPI

36−instance ToParam (QueryParam "foo" Int) where

36+instance ToParam (QueryParam' mods "foo" Int) where

37+ toParam = error "unused"

38+instance ToParam (QueryParam' mods "bar" Int) where

37 toParam = error "unused"

39 toParam = error "unused"

38instance ToParam (QueryParams "foo" Int) where

40instance ToParam (QueryParams "foo" Int) where

39 toParam = error "unused"

41 toParam = error "unused"

servant-foreign/servant-foreign.cabal+5−4

@@ -36,10 +36,11 @@ library

36 exposed-modules: Servant.Foreign

37 , Servant.Foreign.Internal

38 , Servant.Foreign.Inflections

39− build-depends: base == 4.*

39+ build-depends: base >= 4.7 && <4.11

40+ , base-compat >= 0.9.3 && <0.10

40− , lens == 4.*

41+ , lens == 4.*

41− , servant == 0.12.*

42+ , servant == 0.12.*

42− , text >= 1.2 && < 1.3

43+ , text >= 1.2 && < 1.3

43 , http-types

44 , http-types

44 hs-source-dirs: src

45 hs-source-dirs: src

45 default-language: Haskell2010

46 default-language: Haskell2010

servant-foreign/src/Servant/Foreign/Internal.hs+14−15

@@ -20,12 +20,12 @@

20-- arbitrary programming languages.

21module Servant.Foreign.Internal where

23+import Prelude ()

24+import Prelude.Compat

25+

23import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),

26import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),

24 (.~))

27 (.~))

25import Data.Data (Data)

28import Data.Data (Data)

26−#if !MIN_VERSION_base(4,8,0)

27−import Data.Monoid

28−#endif

29import Data.Proxy

30import Data.String

31import Data.Text

@@ -33,10 +33,9 @@ import Data.Typeable (Typeable)

33import Data.Text.Encoding (decodeUtf8)

34import GHC.TypeLits

35import qualified Network.HTTP.Types as HTTP

36−import Prelude hiding (concat)

37import Servant.API

36import Servant.API

38import Servant.API.TypeLevel

37import Servant.API.TypeLevel

39−

38+import Servant.API.Modifiers (RequiredArgument)

41newtype FunctionName = FunctionName { unFunctionName :: [Text] }

40newtype FunctionName = FunctionName { unFunctionName :: [Text] }

42 deriving (Data, Show, Eq, Monoid, Typeable)

41 deriving (Data, Show, Eq, Monoid, Typeable)

@@ -238,9 +237,9 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)

238 method = reflectMethod (Proxy :: Proxy method)

237 method = reflectMethod (Proxy :: Proxy method)

239 methodLC = toLower $ decodeUtf8 method

238 methodLC = toLower $ decodeUtf8 method

240

239

241−instance (KnownSymbol sym, HasForeignType lang ftype (Maybe a), HasForeign lang ftype api)

240+instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)

242− => HasForeign lang ftype (Header sym a :> api) where

241+ => HasForeign lang ftype (Header' mods sym a :> api) where

243− type Foreign ftype (Header sym a :> api) = Foreign ftype api

242+ type Foreign ftype (Header' mods sym a :> api) = Foreign ftype api

244

243

245 foreignFor lang Proxy Proxy req =

244 foreignFor lang Proxy Proxy req =

246 foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg]

245 foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg]

@@ -248,12 +247,12 @@ instance (KnownSymbol sym, HasForeignType lang ftype (Maybe a), HasForeign lang

248 hname = pack . symbolVal $ (Proxy :: Proxy sym)

247 hname = pack . symbolVal $ (Proxy :: Proxy sym)

249 arg = Arg

248 arg = Arg

250 { _argName = PathSegment hname

249 { _argName = PathSegment hname

251− , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a)) }

250+ , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (RequiredArgument mods a)) }

252 subP = Proxy :: Proxy api

251 subP = Proxy :: Proxy api

253

252

254−instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)

253+instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)

255− => HasForeign lang ftype (QueryParam sym a :> api) where

254+ => HasForeign lang ftype (QueryParam' mods sym a :> api) where

256− type Foreign ftype (QueryParam sym a :> api) = Foreign ftype api

255+ type Foreign ftype (QueryParam' mods sym a :> api) = Foreign ftype api

257

256

258 foreignFor lang Proxy Proxy req =

257 foreignFor lang Proxy Proxy req =

259 foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $

258 foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $

@@ -262,7 +261,7 @@ instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype ap

262 str = pack . symbolVal $ (Proxy :: Proxy sym)

261 str = pack . symbolVal $ (Proxy :: Proxy sym)

263 arg = Arg

262 arg = Arg

264 { _argName = PathSegment str

263 { _argName = PathSegment str

265− , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }

264+ , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (RequiredArgument mods a)) }

266

265

267instance

266instance

268 (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api)

267 (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api)

@@ -299,8 +298,8 @@ instance HasForeign lang ftype Raw where

299 & reqMethod .~ method

298 & reqMethod .~ method

300

299

301instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api)

300instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api)

302− => HasForeign lang ftype (ReqBody list a :> api) where

301+ => HasForeign lang ftype (ReqBody' mods list a :> api) where

303− type Foreign ftype (ReqBody list a :> api) = Foreign ftype api

302+ type Foreign ftype (ReqBody' mods list a :> api) = Foreign ftype api

304

303

305 foreignFor lang ftype Proxy req =

304 foreignFor lang ftype Proxy req =

306 foreignFor lang ftype (Proxy :: Proxy api) $

305 foreignFor lang ftype (Proxy :: Proxy api) $

servant-foreign/test/Servant/ForeignSpec.hs+4−2

@@ -7,9 +7,11 @@

7{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TemplateHaskell #-}

11{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE TypeOperators #-}

12+#if __GLASGOW__HASKELL < 709

13+{-# OPTIONS_GHC -fcontext-stack=41 #-}

14+#endif

13#include "overlapping-compat.h"

15#include "overlapping-compat.h"

15module Servant.ForeignSpec where

17module Servant.ForeignSpec where

@@ -99,7 +101,7 @@ listFromAPISpec = describe "listFromAPI" $ do

99 shouldBe postReq $ defReq

101 shouldBe postReq $ defReq

100 { _reqUrl = Url

102 { _reqUrl = Url

101 [ Segment $ Static "test" ]

103 [ Segment $ Static "test" ]

102− [ QueryArg (Arg "param" "intX") Normal ]

104+ [ QueryArg (Arg "param" "maybe intX") Normal ]

103 , _reqMethod = "POST"

105 , _reqMethod = "POST"

104 , _reqHeaders = []

106 , _reqHeaders = []

105 , _reqBody = Just "listX of stringX"

107 , _reqBody = Just "listX of stringX"

servant-server/src/Servant/Server/Internal.hs+69−46

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

12{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE UndecidableInstances #-}

16#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802

17#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802

17#define HAS_TYPE_ERROR

18#define HAS_TYPE_ERROR

@@ -33,7 +34,7 @@ module Servant.Server.Internal

33 , module Servant.Server.Internal.ServantErr

34 , module Servant.Server.Internal.ServantErr

34 ) where

35 ) where

36−import Control.Monad (when)

37+import Control.Monad (join, when)

37import Control.Monad.Trans (liftIO)

38import Control.Monad.Trans (liftIO)

38import Control.Monad.Trans.Resource (runResourceT)

39import Control.Monad.Trans.Resource (runResourceT)

39import qualified Data.ByteString as B

40import qualified Data.ByteString as B

@@ -43,7 +44,7 @@ import qualified Data.ByteString.Lazy as BL

43import Data.Maybe (fromMaybe, mapMaybe,

44import Data.Maybe (fromMaybe, mapMaybe,

44 isNothing, maybeToList)

45 isNothing, maybeToList)

45import Data.Either (partitionEithers)

46import Data.Either (partitionEithers)

46−import Data.String (fromString)

47+import Data.String (IsString (..))

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

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

48import Data.Tagged (Tagged(..), retag, untag)

49import Data.Tagged (Tagged(..), retag, untag)

49import qualified Data.Text as T

50import qualified Data.Text as T

@@ -69,15 +70,17 @@ import Web.HttpApiData (FromHttpApiData, parseHeader,

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

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

70 CaptureAll, Verb, EmptyAPI,

71 CaptureAll, Verb, EmptyAPI,

71 ReflectMethod(reflectMethod),

72 ReflectMethod(reflectMethod),

72− IsSecure(..), Header, QueryFlag,

73+ IsSecure(..), Header', QueryFlag,

73− QueryParam, QueryParams, Raw,

74+ QueryParam', QueryParams, Raw,

74− RemoteHost, ReqBody, Vault,

75+ RemoteHost, ReqBody', Vault,

75 WithNamedContext,

76 WithNamedContext,

76 Description, Summary,

77 Description, Summary,

77 Accept(..),

78 Accept(..),

78 FramingRender(..), Stream,

79 FramingRender(..), Stream,

79 StreamGenerator(..), ToStreamGenerator(..),

80 StreamGenerator(..), ToStreamGenerator(..),

80− BoundaryStrategy(..))

81+ BoundaryStrategy(..),

82+ If, SBool (..), SBoolI (..))

83+import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient)

81import Servant.API.ContentTypes (AcceptHeader (..),

84import Servant.API.ContentTypes (AcceptHeader (..),

82 AllCTRender (..),

85 AllCTRender (..),

83 AllCTUnrender (..),

86 AllCTUnrender (..),

@@ -361,29 +364,39 @@ streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \

361-- > server = viewReferer

364-- > server = viewReferer

362-- > where viewReferer :: Referer -> Handler referer

365-- > where viewReferer :: Referer -> Handler referer

363-- > viewReferer referer = return referer

366-- > viewReferer referer = return referer

367+instance

364−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

368+ (KnownSymbol sym, FromHttpApiData a, HasServer api context

369+ , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

370+ )

365− => HasServer (Header sym a :> api) context where

371+ => HasServer (Header' mods sym a :> api) context where

366−

372+------

367− type ServerT (Header sym a :> api) m =

373+ type ServerT (Header' mods sym a :> api) m =

368− Maybe a -> ServerT api m

374+ RequestArgument mods a -> ServerT api m

369

375

370 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

376 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

371

377

372 route Proxy context subserver = route (Proxy :: Proxy api) context $

378 route Proxy context subserver = route (Proxy :: Proxy api) context $

373 subserver `addHeaderCheck` withRequest headerCheck

379 subserver `addHeaderCheck` withRequest headerCheck

374 where

380 where

381+ headerName :: IsString n => n

375− headerName = symbolVal (Proxy :: Proxy sym)

382+ headerName = fromString $ symbolVal (Proxy :: Proxy sym)

383+

384+ headerCheck :: Request -> DelayedIO (RequestArgument mods a)

376 headerCheck req =

385 headerCheck req =

386+ unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev

387+ where

388+ mev :: Maybe (Either T.Text a)

377− case lookup (fromString headerName) (requestHeaders req) of

389+ mev = fmap parseHeader $ lookup headerName (requestHeaders req)

378− Nothing -> return Nothing

390+

379− Just txt ->

391+ errReq = delayedFailFatal err400

380− case parseHeader txt of

392+ { errBody = "Header " <> headerName <> " is required"

393+ }

394+

381− Left e -> delayedFailFatal err400

395+ errSt e = delayedFailFatal err400

382− { errBody = cs $ "Error parsing header "

396+ { errBody = cs $ "Error parsing header "

383− <> fromString headerName

397+ <> headerName

384− <> " failed: " <> e

398+ <> " failed: " <> e

385− }

399+ }

386− Right hdr -> return $ Just hdr

387

400

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

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

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

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

@@ -406,33 +419,41 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

406-- > where getBooksBy :: Maybe Text -> Handler [Book]

419-- > where getBooksBy :: Maybe Text -> Handler [Book]

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

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

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

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

422+instance

409−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

423+ ( KnownSymbol sym, FromHttpApiData a, HasServer api context

424+ , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

425+ )

410− => HasServer (QueryParam sym a :> api) context where

426+ => HasServer (QueryParam' mods sym a :> api) context where

411−

427+------

412− type ServerT (QueryParam sym a :> api) m =

428+ type ServerT (QueryParam' mods sym a :> api) m =

413− Maybe a -> ServerT api m

429+ RequestArgument mods a -> ServerT api m

414

430

415 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

431 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

416

432

417 route Proxy context subserver =

433 route Proxy context subserver =

418 let querytext req = parseQueryText $ rawQueryString req

434 let querytext req = parseQueryText $ rawQueryString req

435+ paramname = cs $ symbolVal (Proxy :: Proxy sym)

436+

437+ parseParam :: Request -> DelayedIO (RequestArgument mods a)

419 parseParam req =

438 parseParam req =

439+ unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev

440+ where

441+ mev :: Maybe (Either T.Text a)

420− case lookup paramname (querytext req) of

442+ mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req

421− Nothing -> return Nothing -- param absent from the query string

443+

422− Just Nothing -> return Nothing -- param present with no value -> Nothing

444+ errReq = delayedFailFatal err400

423− Just (Just v) ->

445+ { errBody = cs $ "Query parameter " <> paramname <> " is required"

424− case parseQueryParam v of

446+ }

447+

425− Left e -> delayedFailFatal err400

448+ errSt e = delayedFailFatal err400

426− { errBody = cs $ "Error parsing query parameter "

449+ { errBody = cs $ "Error parsing query parameter "

427− <> paramname <> " failed: " <> e

450+ <> paramname <> " failed: " <> e

428− }

451+ }

429−

452+

430− Right param -> return $ Just param

431 delayed = addParameterCheck subserver . withRequest $ \req ->

453 delayed = addParameterCheck subserver . withRequest $ \req ->

432 parseParam req

454 parseParam req

433

455

434 in route (Proxy :: Proxy api) context delayed

456 in route (Proxy :: Proxy api) context delayed

435− where paramname = cs $ symbolVal (Proxy :: Proxy sym)

436

457

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

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

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

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

@@ -561,11 +582,11 @@ instance HasServer Raw context where

561-- > server = postBook

582-- > server = postBook

562-- > where postBook :: Book -> Handler Book

583-- > where postBook :: Book -> Handler Book

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

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

564−instance ( AllCTUnrender list a, HasServer api context

585+instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)

565− ) => HasServer (ReqBody list a :> api) context where

586+ ) => HasServer (ReqBody' mods list a :> api) context where

566

587

567− type ServerT (ReqBody list a :> api) m =

588+ type ServerT (ReqBody' mods list a :> api) m =

568− a -> ServerT api m

589+ If (FoldLenient mods) (Either String a) a -> ServerT api m

569

590

570 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

591 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

571

592

@@ -588,9 +609,11 @@ instance ( AllCTUnrender list a, HasServer api context

588 -- Body check, we get a body parsing functions as the first argument.

609 -- Body check, we get a body parsing functions as the first argument.

589 bodyCheck f = withRequest $ \ request -> do

610 bodyCheck f = withRequest $ \ request -> do

590 mrqbody <- f <$> liftIO (lazyRequestBody request)

611 mrqbody <- f <$> liftIO (lazyRequestBody request)

612+ case sbool :: SBool (FoldLenient mods) of

613+ STrue -> return mrqbody

591− case mrqbody of

614+ SFalse -> case mrqbody of

592− Left e -> delayedFailFatal err400 { errBody = cs e }

615+ Left e -> delayedFailFatal err400 { errBody = cs e }

593− Right v -> return v

616+ Right v -> return v

594

617

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

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

596-- pass the rest of the request path to @api@.

619-- pass the rest of the request path to @api@.

servant-server/test/Servant/ServerSpec.hs+6−6

@@ -47,7 +47,7 @@ import Network.Wai.Test (defaultRequest, request,

47 simpleHeaders, simpleStatus)

48import Servant.API ((:<|>) (..), (:>), AuthProtect,

49 BasicAuth, BasicAuthData(BasicAuthData),

50− Capture, CaptureAll, Delete, Get, Header (..),

50+ Capture, CaptureAll, Delete, Get, Header,

51 Headers, HttpVersion,

52 IsSecure (..), JSON,

53 NoContent (..), Patch, PlainText,

@@ -461,8 +461,8 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do

461------------------------------------------------------------------------------

462

463type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent

464−headerApi :: Proxy (HeaderApi a)

464+headerApi :: Proxy a -> Proxy (HeaderApi a)

465−headerApi = Proxy

465+headerApi _ = Proxy

466

467headerSpec :: Spec

468headerSpec = describe "Servant.API.Header" $ do

@@ -479,19 +479,19 @@ headerSpec = describe "Servant.API.Header" $ do

479 return NoContent

480 expectsString Nothing = error "Expected a string"

481

482− with (return (serve headerApi expectsInt)) $ do

482+ with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do

483 let delete' x = THW.request methodDelete x [("MyHeader", "5")]

484

485 it "passes the header to the handler (Int)" $

486 delete' "/" "" `shouldRespondWith` 200

487

488− with (return (serve headerApi expectsString)) $ do

488+ with (return (serve (headerApi (Proxy :: Proxy String)) expectsString)) $ do

489 let delete' x = THW.request methodDelete x [("MyHeader", "more from you")]

490

491 it "passes the header to the handler (String)" $

492 delete' "/" "" `shouldRespondWith` 200

493

494− with (return (serve headerApi expectsInt)) $ do

494+ with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do

495 let delete' x = THW.request methodDelete x [("MyHeader", "not a number")]

496

497 it "checks for parse errors" $

servant/servant.cabal+3−1

@@ -49,12 +49,13 @@ library

49 Servant.API.HttpVersion

50 Servant.API.Internal.Test.ComprehensiveAPI

51 Servant.API.IsSecure

52+ Servant.API.Modifiers

52 Servant.API.QueryParam

53 Servant.API.QueryParam

53 Servant.API.Raw

54 Servant.API.Raw

54− Servant.API.Stream

55 Servant.API.RemoteHost

56 Servant.API.ReqBody

57 Servant.API.ResponseHeaders

58+ Servant.API.Stream

58 Servant.API.Sub

59 Servant.API.Sub

59 Servant.API.TypeLevel

60 Servant.API.TypeLevel

60 Servant.API.Vault

61 Servant.API.Vault

@@ -77,6 +78,7 @@ library

77 , mmorph >= 1 && < 1.2

78 , mmorph >= 1 && < 1.2

78 , tagged >= 0.7.3 && < 0.9

79 , tagged >= 0.7.3 && < 0.9

79 , text >= 1 && < 1.3

80 , text >= 1 && < 1.3

81+ , singleton-bool >= 0.1.2.0 && <0.2

80 , string-conversions >= 0.3 && < 0.5

82 , string-conversions >= 0.3 && < 0.5

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

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

82 , vault >= 0.3 && < 0.4

84 , vault >= 0.3 && < 0.4

servant/src/Servant/API.hs+14−4

@@ -7,6 +7,8 @@ module Servant.API (

7 -- | Type-level combinator for alternative endpoints: @':<|>'@

8 module Servant.API.Empty,

9 -- | Type-level combinator for an empty API: @'EmptyAPI'@

10+ module Servant.API.Modifiers,

11+ -- | Type-level modifiers for 'QueryParam', 'Header' and 'ReqBody'.

11 -- * Accessing information from the request

13 -- * Accessing information from the request

12 module Servant.API.Capture,

14 module Servant.API.Capture,

@@ -64,6 +66,10 @@ module Servant.API (

64 -- * Utilities

66 -- * Utilities

65 module Servant.Utils.Links,

67 module Servant.Utils.Links,

66 -- | Type-safe internal URIs

68 -- | Type-safe internal URIs

69+

70+ -- * Re-exports

71+ If,

72+ SBool (..), SBoolI (..)

67 ) where

73 ) where

69import Servant.API.Alternative ((:<|>) (..))

75import Servant.API.Alternative ((:<|>) (..))

@@ -77,10 +83,11 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,

77import Servant.API.Description (Description, Summary)

83import Servant.API.Description (Description, Summary)

78import Servant.API.Empty (EmptyAPI (..))

84import Servant.API.Empty (EmptyAPI (..))

79import Servant.API.Experimental.Auth (AuthProtect)

85import Servant.API.Experimental.Auth (AuthProtect)

80−import Servant.API.Header (Header (..))

86+import Servant.API.Header (Header, Header')

81import Servant.API.HttpVersion (HttpVersion (..))

87import Servant.API.HttpVersion (HttpVersion (..))

82import Servant.API.IsSecure (IsSecure (..))

88import Servant.API.IsSecure (IsSecure (..))

89+import Servant.API.Modifiers (Required, Optional, Lenient, Strict)

83−import Servant.API.QueryParam (QueryFlag, QueryParam,

90+import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam',

84 QueryParams)

91 QueryParams)

85import Servant.API.Raw (Raw)

92import Servant.API.Raw (Raw)

86import Servant.API.Stream (Stream, StreamGet, StreamPost,

93import Servant.API.Stream (Stream, StreamGet, StreamPost,

@@ -93,12 +100,12 @@ import Servant.API.Stream (Stream, StreamGet, StreamPost,

93 NewlineFraming,

100 NewlineFraming,

94 NetstringFraming)

101 NetstringFraming)

95import Servant.API.RemoteHost (RemoteHost)

102import Servant.API.RemoteHost (RemoteHost)

96−import Servant.API.ReqBody (ReqBody)

103+import Servant.API.ReqBody (ReqBody, ReqBody')

97import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,

104import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,

98 BuildHeadersTo (buildHeadersTo),

105 BuildHeadersTo (buildHeadersTo),

99 GetHeaders (getHeaders),

106 GetHeaders (getHeaders),

100 HList (..), Headers (..),

107 HList (..), Headers (..),

101− getHeadersHList, getResponse)

108+ getHeadersHList, getResponse, ResponseHeader (..))

102import Servant.API.Sub ((:>))

109import Servant.API.Sub ((:>))

103import Servant.API.Vault (Vault)

110import Servant.API.Vault (Vault)

104import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,

111import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,

@@ -124,3 +131,6 @@ import Servant.Utils.Links (HasLink (..), Link, IsElem, IsElem

124 URI (..), safeLink)

131 URI (..), safeLink)

125import Web.HttpApiData (FromHttpApiData (..),

132import Web.HttpApiData (FromHttpApiData (..),

126 ToHttpApiData (..))

133 ToHttpApiData (..))

134+

135+import Data.Type.Bool (If)

136+import Data.Singletons.Bool (SBool (..), SBoolI (..))

servant/src/Servant/API/Header.hs+9−7

@@ -4,13 +4,15 @@

4{-# LANGUAGE PolyKinds #-}

5{-# OPTIONS_HADDOCK not-home #-}

6module Servant.API.Header (

7− Header(..),

7+ Header, Header',

8−) where

8+ ) where

10−import Data.ByteString (ByteString)

11import Data.Typeable (Typeable)

10import Data.Typeable (Typeable)

12import GHC.TypeLits (Symbol)

11import GHC.TypeLits (Symbol)

12+import Servant.API.Modifiers

13+

13-- | Extract the given header's value as a value of type @a@.

14-- | Extract the given header's value as a value of type @a@.

15+-- I.e. header sent by client, parsed by server.

14--

16--

15-- Example:

17-- Example:

16--

18--

@@ -18,10 +20,10 @@ import GHC.TypeLits (Symbol)

18-- >>>

20-- >>>

19-- >>> -- GET /view-my-referer

21-- >>> -- GET /view-my-referer

20-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer

22-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer

23+type Header = Header' '[Optional, Strict]

24+

21−data Header (sym :: Symbol) a = Header a

25+data Header' (mods :: [*]) (sym :: Symbol) a

22− | MissingHeader

23− | UndecodableHeader ByteString

24− deriving (Typeable, Eq, Show, Functor)

26+ deriving Typeable

26-- $setup

28-- $setup

27-- >>> import Servant.API

29-- >>> import Servant.API

servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+3

@@ -24,13 +24,16 @@ type ComprehensiveAPIWithoutRaw =

24 Get '[JSON] Int :<|>

25 Capture "foo" Int :> GET :<|>

26 Header "foo" Int :> GET :<|>

27+ Header' '[Required, Lenient] "bar" Int :> GET :<|>

27 HttpVersion :> GET :<|>

28 HttpVersion :> GET :<|>

28 IsSecure :> GET :<|>

29 IsSecure :> GET :<|>

29 QueryParam "foo" Int :> GET :<|>

30 QueryParam "foo" Int :> GET :<|>

31+ QueryParam' '[Required, Lenient] "bar" Int :> GET :<|>

30 QueryParams "foo" Int :> GET :<|>

32 QueryParams "foo" Int :> GET :<|>

31 QueryFlag "foo" :> GET :<|>

33 QueryFlag "foo" :> GET :<|>

32 RemoteHost :> GET :<|>

34 RemoteHost :> GET :<|>

33 ReqBody '[JSON] Int :> GET :<|>

35 ReqBody '[JSON] Int :> GET :<|>

36+ ReqBody' '[Lenient] '[JSON] Int :> GET :<|>

34 Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>

37 Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>

35 "foo" :> GET :<|>

38 "foo" :> GET :<|>

36 Vault :> GET :<|>

39 Vault :> GET :<|>

servant/src/Servant/API/Modifiers.hsnew file+150

@@ -0,0 +1,150 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE TypeOperators #-}

7+module Servant.API.Modifiers (

8+ -- * Required / optional argument

9+ Required, Optional,

10+ FoldRequired, FoldRequired',

11+ -- * Lenient / strict parsing

12+ Lenient, Strict,

13+ FoldLenient, FoldLenient',

14+ -- * Utilities

15+ RequiredArgument,

16+ foldRequiredArgument,

17+ unfoldRequiredArgument,

18+ RequestArgument,

19+ unfoldRequestArgument,

20+ ) where

21+

22+import Data.Proxy (Proxy (..))

23+import Data.Singletons.Bool (SBool (..), SBoolI (..))

24+import Data.Text (Text)

25+import Data.Type.Bool (If)

26+

27+-- | Required argument. Not wrapped.

28+data Required

29+

30+-- | Optional argument. Wrapped in 'Maybe'.

31+data Optional

32+

33+-- | Fold modifier list to decide whether argument is required.

34+--

35+-- >>> :kind! FoldRequired '[Required, Description "something"]

36+-- FoldRequired '[Required, Description "something"] :: Bool

37+-- = 'True

38+--

39+-- >>> :kind! FoldRequired '[Required, Optional]

40+-- FoldRequired '[Required, Optional] :: Bool

41+-- = 'False

42+--

43+-- >>> :kind! FoldRequired '[]

44+-- FoldRequired '[] :: Bool

45+-- = 'False

46+--

47+type FoldRequired mods = FoldRequired' 'False mods

48+

49+-- | Implementation of 'FoldRequired'.

50+type family FoldRequired' (acc :: Bool) (mods :: [*]) :: Bool where

51+ FoldRequired' acc '[] = acc

52+ FoldRequired' acc (Required ': mods) = FoldRequired' 'True mods

53+ FoldRequired' acc (Optional ': mods) = FoldRequired' 'False mods

54+ FoldRequired' acc (mod ': mods) = FoldRequired' acc mods

55+

56+-- | Leniently parsed argument, i.e. parsing never fail. Wrapped in @'Either' 'Text'@.

57+data Lenient

58+

59+-- | Strictly parsed argument. Not wrapped.

60+data Strict

61+

62+-- | Fold modifier list to decide whether argument should be parsed strictly or leniently.

63+--

64+-- >>> :kind! FoldLenient '[]

65+-- FoldLenient '[] :: Bool

66+-- = 'False

67+--

68+type FoldLenient mods = FoldLenient' 'False mods

69+

70+-- | Implementation of 'FoldLenient'.

71+type family FoldLenient' (acc :: Bool) (mods :: [*]) :: Bool where

72+ FoldLenient' acc '[] = acc

73+ FoldLenient' acc (Lenient ': mods) = FoldLenient' 'True mods

74+ FoldLenient' acc (Strict ': mods) = FoldLenient' 'False mods

75+ FoldLenient' acc (mod ': mods) = FoldLenient' acc mods

76+

77+-- | Helper type alias.

78+--

79+-- * 'Required' ↦ @a@

80+--

81+-- * 'Optional' ↦ @'Maybe' a@

82+--

83+type RequiredArgument mods a = If (FoldRequired mods) a (Maybe a)

84+

85+-- | Fold a 'RequiredAgument' into a value

86+foldRequiredArgument

87+ :: forall mods a r. (SBoolI (FoldRequired mods))

88+ => Proxy mods

89+ -> (a -> r) -- ^ 'Required'

90+ -> (Maybe a -> r) -- ^ 'Optional'

91+ -> RequiredArgument mods a

92+ -> r

93+foldRequiredArgument _ f g mx =

94+ case (sbool :: SBool (FoldRequired mods), mx) of

95+ (STrue, x) -> f x

96+ (SFalse, x) -> g x

97+

98+-- | Unfold a value into a 'RequiredArgument'.

99+unfoldRequiredArgument

100+ :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))

101+ => Proxy mods

102+ -> m (RequiredArgument mods a) -- ^ error when argument is required

103+ -> (Text -> m (RequiredArgument mods a)) -- ^ error when argument is strictly parsed

104+ -> Maybe (Either Text a) -- ^ value

105+ -> m (RequiredArgument mods a)

106+unfoldRequiredArgument _ errReq errSt mex =

107+ case (sbool :: SBool (FoldRequired mods), mex) of

108+ (STrue, Nothing) -> errReq

109+ (SFalse, Nothing) -> return Nothing

110+ (STrue, Just ex) -> either errSt return ex

111+ (SFalse, Just ex) -> either errSt (return . Just) ex

112+

113+-- | Helper type alias.

114+--

115+-- By default argument is 'Optional' and 'Strict'.

116+--

117+-- * 'Required', 'Strict' ↦ @a@

118+--

119+-- * 'Required', 'Lenient' ↦ @'Either' 'Text' a@

120+--

121+-- * 'Optional', 'Strict' ↦ @'Maybe' a@

122+--

123+-- * 'Optional', 'Lenient' ↦ @'Maybe' ('Either' 'Text' a)@

124+--

125+type RequestArgument mods a =

126+ If (FoldRequired mods)

127+ (If (FoldLenient mods) (Either Text a) a)

128+ (Maybe (If (FoldLenient mods) (Either Text a) a))

129+

130+

131+

132+-- | Unfold a value into a 'RequestArgument'.

133+unfoldRequestArgument

134+ :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))

135+ => Proxy mods

136+ -> m (RequestArgument mods a) -- ^ error when argument is required

137+ -> (Text -> m (RequestArgument mods a)) -- ^ error when argument is strictly parsed

138+ -> Maybe (Either Text a) -- ^ value

139+ -> m (RequestArgument mods a)

140+unfoldRequestArgument _ errReq errSt mex =

141+ case (sbool :: SBool (FoldRequired mods), mex, sbool :: SBool (FoldLenient mods)) of

142+ (STrue, Nothing, _) -> errReq

143+ (SFalse, Nothing, _) -> return Nothing

144+ (STrue, Just ex, STrue) -> return ex

145+ (STrue, Just ex, SFalse) -> either errSt return ex

146+ (SFalse, Just ex, STrue) -> return (Just ex)

147+ (SFalse, Just ex, SFalse) -> either errSt (return . Just) ex

148+

149+-- $setup

150+-- >>> import Servant.API

servant/src/Servant/API/QueryParam.hs+7−2

@@ -3,10 +3,12 @@

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE PolyKinds #-}

5{-# OPTIONS_HADDOCK not-home #-}

6−module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where

6+module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where

8import Data.Typeable (Typeable)

9import GHC.TypeLits (Symbol)

10+import Servant.API.Modifiers

11+

10-- | Lookup the value associated to the @sym@ query string parameter

12-- | Lookup the value associated to the @sym@ query string parameter

11-- and try to extract it as a value of type @a@.

13-- and try to extract it as a value of type @a@.

12--

14--

@@ -14,7 +16,10 @@ import GHC.TypeLits (Symbol)

14--

16--

15-- >>> -- /books?author=<author name>

17-- >>> -- /books?author=<author name>

16-- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]

18-- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]

19+type QueryParam = QueryParam' '[Optional, Strict]

20+

21+-- | 'QueryParam' which can be 'Required', 'Lenient', or modified otherwise.

17−data QueryParam (sym :: Symbol) (a :: *)

22+data QueryParam' (mods :: [*]) (sym :: Symbol) (a :: *)

18 deriving Typeable

23 deriving Typeable

20-- | Lookup the values associated to the @sym@ query string parameter

25-- | Lookup the values associated to the @sym@ query string parameter

servant/src/Servant/API/ReqBody.hs+12−3

@@ -2,16 +2,25 @@

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE PolyKinds #-}

4{-# OPTIONS_HADDOCK not-home #-}

5−module Servant.API.ReqBody where

5+module Servant.API.ReqBody (

6+ ReqBody, ReqBody',

7+ ) where

9+import Data.Typeable (Typeable)

10+import Servant.API.Modifiers

7−import Data.Typeable (Typeable)

8-- | Extract the request body as a value of type @a@.

12-- | Extract the request body as a value of type @a@.

9--

13--

10-- Example:

14-- Example:

11--

15--

12-- >>> -- POST /books

16-- >>> -- POST /books

13-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book

17-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book

18+type ReqBody = ReqBody' '[Required, Strict]

19+

20+-- |

21+--

22+-- /Note:/ 'ReqBody'' is always 'Required'.

14−data ReqBody (contentTypes :: [*]) (a :: *)

23+data ReqBody' (mods :: [*]) (contentTypes :: [*]) (a :: *)

15 deriving (Typeable)

24 deriving (Typeable)

17-- $setup

26-- $setup

servant/src/Servant/API/ResponseHeaders.hs+14−5

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

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

@@ -23,6 +24,7 @@

23-- example above).

24-- example above).

24module Servant.API.ResponseHeaders

25module Servant.API.ResponseHeaders

25 ( Headers(..)

26 ( Headers(..)

27+ , ResponseHeader (..)

26 , AddHeader

28 , AddHeader

27 , addHeader

29 , addHeader

28 , noHeader

30 , noHeader

@@ -32,15 +34,16 @@ module Servant.API.ResponseHeaders

32 , HList(..)

34 , HList(..)

33 ) where

35 ) where

35−import Data.ByteString.Char8 as BS (pack, unlines, init)

37+import Data.ByteString.Char8 as BS (ByteString, pack, unlines, init)

38+import Data.Typeable (Typeable)

36import Web.HttpApiData (ToHttpApiData, toHeader,

39import Web.HttpApiData (ToHttpApiData, toHeader,

37 FromHttpApiData, parseHeader)

40 FromHttpApiData, parseHeader)

38import qualified Data.CaseInsensitive as CI

41import qualified Data.CaseInsensitive as CI

39import Data.Proxy

42import Data.Proxy

40−import GHC.TypeLits (KnownSymbol, symbolVal)

43+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)

41import qualified Network.HTTP.Types.Header as HTTP

44import qualified Network.HTTP.Types.Header as HTTP

43−import Servant.API.Header (Header (..))

46+import Servant.API.Header (Header)

44import Prelude ()

47import Prelude ()

45import Prelude.Compat

48import Prelude.Compat

@@ -52,9 +55,15 @@ data Headers ls a = Headers { getResponse :: a

52 -- ^ HList of headers.

55 -- ^ HList of headers.

53 } deriving (Functor)

56 } deriving (Functor)

58+data ResponseHeader (sym :: Symbol) a

59+ = Header a

60+ | MissingHeader

61+ | UndecodableHeader ByteString

62+ deriving (Typeable, Eq, Show, Functor)

63+

55data HList a where

64data HList a where

56 HNil :: HList '[]

65 HNil :: HList '[]

57− HCons :: Header h x -> HList xs -> HList (Header h x ': xs)

66+ HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)

59type family HeaderValMap (f :: * -> *) (xs :: [*]) where

68type family HeaderValMap (f :: * -> *) (xs :: [*]) where

60 HeaderValMap f '[] = '[]

69 HeaderValMap f '[] = '[]

@@ -110,7 +119,7 @@ instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v

110-- We need all these fundeps to save type inference

119-- We need all these fundeps to save type inference

111class AddHeader h v orig new

120class AddHeader h v orig new

112 | h v orig -> new, new -> h, new -> v, new -> orig where

121 | h v orig -> new, new -> h, new -> v, new -> orig where

113− addOptionalHeader :: Header h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times

122+ addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times

114

123

115

124

116instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v )

125instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v )

servant/src/Servant/Utils/Links.hs+52−12

@@ -1,11 +1,13 @@

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeOperators #-}

9{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE UndecidableInstances #-}

9{-# OPTIONS_HADDOCK not-home #-}

11{-# OPTIONS_HADDOCK not-home #-}

11-- | Type safe generation of internal links.

13-- | Type safe generation of internal links.

@@ -101,8 +103,10 @@ module Servant.Utils.Links (

101import Data.List

103import Data.List

102import Data.Monoid.Compat ( (<>) )

104import Data.Monoid.Compat ( (<>) )

103import Data.Proxy ( Proxy(..) )

105import Data.Proxy ( Proxy(..) )

106+import Data.Singletons.Bool ( SBool (..), SBoolI (..) )

104import qualified Data.Text as Text

107import qualified Data.Text as Text

105import qualified Data.Text.Encoding as TE

108import qualified Data.Text.Encoding as TE

109+import Data.Type.Bool (If)

106import GHC.TypeLits ( KnownSymbol, symbolVal )

110import GHC.TypeLits ( KnownSymbol, symbolVal )

107import Network.URI ( URI(..), escapeURIString, isUnreserved )

111import Network.URI ( URI(..), escapeURIString, isUnreserved )

108import Prelude ()

112import Prelude ()

@@ -112,15 +116,22 @@ import Web.HttpApiData

112import Servant.API.Alternative ( (:<|>)((:<|>)) )

116import Servant.API.Alternative ( (:<|>)((:<|>)) )

113import Servant.API.BasicAuth ( BasicAuth )

117import Servant.API.BasicAuth ( BasicAuth )

114import Servant.API.Capture ( Capture, CaptureAll )

118import Servant.API.Capture ( Capture, CaptureAll )

115−import Servant.API.ReqBody ( ReqBody )

119+import Servant.API.ReqBody ( ReqBody' )

116−import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )

120+import Servant.API.QueryParam ( QueryParam', QueryParams, QueryFlag )

117−import Servant.API.Header ( Header )

121+import Servant.API.Header ( Header' )

122+import Servant.API.HttpVersion (HttpVersion)

118import Servant.API.RemoteHost ( RemoteHost )

123import Servant.API.RemoteHost ( RemoteHost )

124+import Servant.API.IsSecure (IsSecure)

125+import Servant.API.Empty (EmptyAPI (..))

119import Servant.API.Verbs ( Verb )

126import Servant.API.Verbs ( Verb )

120import Servant.API.Sub ( type (:>) )

127import Servant.API.Sub ( type (:>) )

121import Servant.API.Raw ( Raw )

128import Servant.API.Raw ( Raw )

122import Servant.API.Stream ( Stream )

129import Servant.API.Stream ( Stream )

123import Servant.API.TypeLevel

130import Servant.API.TypeLevel

131+import Servant.API.Modifiers (FoldRequired)

132+import Servant.API.Description (Description, Summary)

133+import Servant.API.Vault (Vault)

134+import Servant.API.WithNamedContext (WithNamedContext)

124import Servant.API.Experimental.Auth ( AuthProtect )

135import Servant.API.Experimental.Auth ( AuthProtect )

125

136

126-- | A safe link datatype.

137-- | A safe link datatype.

@@ -282,14 +293,15 @@ instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where

282 where

293 where

283 seg = symbolVal (Proxy :: Proxy sym)

294 seg = symbolVal (Proxy :: Proxy sym)

284

295

285−

286-- QueryParam instances

296-- QueryParam instances

287−instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)

297+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))

288− => HasLink (QueryParam sym v :> sub) where

298+ => HasLink (QueryParam' mods sym v :> sub) where

289− type MkLink (QueryParam sym v :> sub) = Maybe v -> MkLink sub

299+ type MkLink (QueryParam' mods sym v :> sub) = If (FoldRequired mods) v (Maybe v) -> MkLink sub

290 toLink _ l mv =

300 toLink _ l mv =

291 toLink (Proxy :: Proxy sub) $

301 toLink (Proxy :: Proxy sub) $

302+ case sbool :: SBool (FoldRequired mods) of

303+ STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l

292− maybe id (addQueryParam . SingleParam k . toQueryParam) mv l

304+ SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l

293 where

305 where

294 k :: String

306 k :: String

295 k = symbolVal (Proxy :: Proxy sym)

307 k = symbolVal (Proxy :: Proxy sym)

@@ -319,8 +331,8 @@ instance (HasLink a, HasLink b) => HasLink (a :<|> b) where

319 toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l

331 toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l

320

332

321-- Misc instances

333-- Misc instances

322−instance HasLink sub => HasLink (ReqBody ct a :> sub) where

334+instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where

323− type MkLink (ReqBody ct a :> sub) = MkLink sub

335+ type MkLink (ReqBody' mods ct a :> sub) = MkLink sub

324 toLink _ = toLink (Proxy :: Proxy sub)

336 toLink _ = toLink (Proxy :: Proxy sub)

325

337

326instance (ToHttpApiData v, HasLink sub)

338instance (ToHttpApiData v, HasLink sub)

@@ -337,8 +349,32 @@ instance (ToHttpApiData v, HasLink sub)

337 toLink (Proxy :: Proxy sub) $

349 toLink (Proxy :: Proxy sub) $

338 foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs

350 foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs

339

351

340−instance HasLink sub => HasLink (Header sym a :> sub) where

352+instance HasLink sub => HasLink (Header' mods sym a :> sub) where

341− type MkLink (Header sym a :> sub) = MkLink sub

353+ type MkLink (Header' mods sym a :> sub) = MkLink sub

354+ toLink _ = toLink (Proxy :: Proxy sub)

355+

356+instance HasLink sub => HasLink (Vault :> sub) where

357+ type MkLink (Vault :> sub) = MkLink sub

358+ toLink _ = toLink (Proxy :: Proxy sub)

359+

360+instance HasLink sub => HasLink (Description s :> sub) where

361+ type MkLink (Description s :> sub) = MkLink sub

362+ toLink _ = toLink (Proxy :: Proxy sub)

363+

364+instance HasLink sub => HasLink (Summary s :> sub) where

365+ type MkLink (Summary s :> sub) = MkLink sub

366+ toLink _ = toLink (Proxy :: Proxy sub)

367+

368+instance HasLink sub => HasLink (HttpVersion :> sub) where

369+ type MkLink (HttpVersion:> sub) = MkLink sub

370+ toLink _ = toLink (Proxy :: Proxy sub)

371+

372+instance HasLink sub => HasLink (IsSecure :> sub) where

373+ type MkLink (IsSecure :> sub) = MkLink sub

374+ toLink _ = toLink (Proxy :: Proxy sub)

375+

376+instance HasLink sub => HasLink (WithNamedContext name context sub) where

377+ type MkLink (WithNamedContext name context sub) = MkLink sub

342 toLink _ = toLink (Proxy :: Proxy sub)

378 toLink _ = toLink (Proxy :: Proxy sub)

343

379

344instance HasLink sub => HasLink (RemoteHost :> sub) where

380instance HasLink sub => HasLink (RemoteHost :> sub) where

@@ -349,6 +385,10 @@ instance HasLink sub => HasLink (BasicAuth realm a :> sub) where

349 type MkLink (BasicAuth realm a :> sub) = MkLink sub

385 type MkLink (BasicAuth realm a :> sub) = MkLink sub

350 toLink _ = toLink (Proxy :: Proxy sub)

386 toLink _ = toLink (Proxy :: Proxy sub)

351

387

388+instance HasLink EmptyAPI where

389+ type MkLink EmptyAPI = EmptyAPI

390+ toLink _ _ = EmptyAPI

391+

352-- Verb (terminal) instances

392-- Verb (terminal) instances

353instance HasLink (Verb m s ct a) where

393instance HasLink (Verb m s ct a) where

354 type MkLink (Verb m s ct a) = Link

394 type MkLink (Verb m s ct a) = Link

servant/test/Servant/Utils/LinksSpec.hs+19−7

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE PolyKinds #-}

4{-# LANGUAGE PolyKinds #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7+#if __GLASGOW__HASKELL < 709

8+{-# OPTIONS_GHC -fcontext-stack=41 #-}

9+#endif

6module Servant.Utils.LinksSpec where

10module Servant.Utils.LinksSpec where

8import Data.Proxy (Proxy (..))

12import Data.Proxy (Proxy (..))

@@ -11,11 +15,13 @@ import Test.Hspec (Expectation, Spec, describe, it,

11import Data.String (fromString)

15import Data.String (fromString)

13import Servant.API

17import Servant.API

14−import Servant.Utils.Links (allLinks)

18+import Servant.Utils.Links (allLinks, linkURI)

19+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)

16type TestApi =

21type TestApi =

17 -- Capture and query params

22 -- Capture and query params

18 "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent

23 "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent

24+ :<|> "hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] NoContent

19 :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent

25 :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent

21 -- Flags

27 -- Flags

@@ -55,6 +61,11 @@ spec = describe "Servant.Utils.Links" $ do

55 :> Delete '[JSON] NoContent)

61 :> Delete '[JSON] NoContent)

56 apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true"

62 apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true"

64+ let l4 = Proxy :: Proxy ("hi" :> Capture "name" String

65+ :> QueryParam' '[Required] "capital" Bool

66+ :> Delete '[JSON] NoContent)

67+ apiLink l4 "privet" False `shouldBeLink` "hi/privet?capital=false"

68+

58 it "generates correct links for CaptureAll" $ do

69 it "generates correct links for CaptureAll" $ do

59 apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))

70 apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))

60 ["roads", "lead", "to", "rome"]

71 ["roads", "lead", "to", "rome"]

@@ -75,11 +86,12 @@ spec = describe "Servant.Utils.Links" $ do

76 it "can generate all links for an API that has only linkable endpoints" $ do

87 it "can generate all links for an API that has only linkable endpoints" $ do

77 let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi)

88 let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi)

78− simple

79− `shouldBeLink` "get"

89+ simple `shouldBeLink` "get"

80− allNames ["Seneca", "Aurelius"]

81− `shouldBeLink` "all/Seneca/Aurelius"

90+ allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius"

92+ it "can generate all links for ComprehensiveAPIWithoutRaw" $ do

93+ let (firstLink :<|> _) = allLinks comprehensiveAPIWithoutRaw

94+ firstLink `shouldBeLink` ""

84-- |

96-- |

85-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,

97-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,

@@ -112,9 +124,9 @@ spec = describe "Servant.Utils.Links" $ do

112-- ...Could not deduce...

124-- ...Could not deduce...

113-- ...

125-- ...

114--

126--

115−-- >>> apiLink (Proxy :: Proxy NoEndpoint)

127+-- >>> linkURI $ apiLink (Proxy :: Proxy NoEndpoint)

116-- ...

128-- ...

117−-- ...No instance for...

129+-- <interactive>...

118-- ...

130-- ...

119--

131--

120-- sanity check

132-- sanity check