01a020d · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Merge pull request #32 from haskell-servant/canonical-types

01a020dAlp Mestanogullari12 years ago

CHANGELOG.md+1

compare with master

unifiedsplit

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

5* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*

6* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)

7* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)

8+* Canonicalize API types before generating the handler types with `Server`

8* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)

9* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)

9* Add server support for response headers

10* Add server support for response headers

src/Servant/Server.hs+5−3

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

1{-# LANGUAGE TypeFamilies #-}

2+{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

4-- | This module lets you implement 'Server's for defined APIs. You'll

5-- | This module lets you implement 'Server's for defined APIs. You'll

@@ -13,11 +14,12 @@ module Servant.Server

13 , -- * Handlers for all standard combinators

14 , -- * Handlers for all standard combinators

14 HasServer(..)

15 HasServer(..)

15 , Server

16 , Server

17+ , ServerT

16 ) where

18 ) where

18import Data.Proxy (Proxy)

20import Data.Proxy (Proxy)

19import Network.Wai (Application)

21import Network.Wai (Application)

20−

22+import Servant.API (Canonicalize, canonicalize)

21import Servant.Server.Internal

23import Servant.Server.Internal

@@ -43,5 +45,5 @@ import Servant.Server.Internal

43-- >

45-- >

44-- > main :: IO ()

46-- > main :: IO ()

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

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

46−serve :: HasServer layout => Proxy layout -> Server layout -> Application

48+serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application

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

49+serve p server = toApplication (route (canonicalize p) server)

src/Servant/Server/Internal.hs+56−43

@@ -32,17 +32,17 @@ import Network.Wai (Application, Request, Response,

32 requestMethod, responseLBS,

33 strictRequestBody)

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

35− Delete, Get, Header, MatrixFlag,

35+ Canonicalize, Delete, Get, Header,

36− MatrixParam, MatrixParams, Patch,

36+ MatrixFlag, MatrixParam, MatrixParams,

37− Post, Put, QueryFlag, QueryParam,

37+ Patch, Post, Put, QueryFlag,

38− QueryParams, Raw, ReqBody)

38+ QueryParam, QueryParams, Raw,

39+ ReqBody)

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

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

40 AllCTRender (..),

41 AllCTRender (..),

41 AllCTUnrender (..))

42 AllCTUnrender (..))

42import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)

43import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)

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

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

45−

46data ReqBodyState = Uncalled

47 | Called !B.ByteString

48 | Done !B.ByteString

@@ -168,11 +168,13 @@ processedPathInfo r =

168 where pinfo = parsePathInfo r

169

170class HasServer layout where

171− type ServerT layout (m :: * -> *) :: *

171+ type ServerT' layout (m :: * -> *) :: *

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

173

172

174−type Server layout = ServerT layout (EitherT (Int, String) IO)

173+ route :: Proxy layout -> Server' layout -> RoutingApplication

175

174

175+type Server layout = Server' (Canonicalize layout)

176+type Server' layout = ServerT' layout (EitherT (Int, String) IO)

177+type ServerT layout m = ServerT' (Canonicalize layout) m

176

178

177-- * Instances

179-- * Instances

178

180

@@ -188,9 +190,11 @@ type Server layout = ServerT layout (EitherT (Int, String) IO)

188-- > where listAllBooks = ...

190-- > where listAllBooks = ...

189-- > postBook book = ...

191-- > postBook book = ...

190instance (HasServer a, HasServer b) => HasServer (a :<|> b) where

192instance (HasServer a, HasServer b) => HasServer (a :<|> b) where

193+

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

194+ type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m

195+

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

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

193− route pa a request $ \ mResponse ->

197+ route pa a request $ \mResponse ->

194 if isMismatch mResponse

198 if isMismatch mResponse

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

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

196 else respond mResponse

200 else respond mResponse

@@ -221,8 +225,8 @@ captured _ = fromText

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

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

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

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

223

227

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

228+ type ServerT' (Capture capture a :> sublayout) m =

225− a -> ServerT sublayout m

229+ a -> ServerT' sublayout m

226

230

227 route Proxy subserver request respond = case processedPathInfo request of

231 route Proxy subserver request respond = case processedPathInfo request of

228 (first : rest)

232 (first : rest)

@@ -248,7 +252,8 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)

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

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

249-- are not met.

253-- are not met.

250instance HasServer Delete where

254instance HasServer Delete where

255+

251− type ServerT Delete m = m ()

256+ type ServerT' Delete m = m ()

252

257

253 route Proxy action request respond

258 route Proxy action request respond

254 | pathIsEmpty request && requestMethod request == methodDelete = do

259 | pathIsEmpty request && requestMethod request == methodDelete = do

@@ -277,7 +282,9 @@ instance HasServer Delete where

277-- list.

282-- list.

278instance ( AllCTRender ctypes a

283instance ( AllCTRender ctypes a

279 ) => HasServer (Get ctypes a) where

284 ) => HasServer (Get ctypes a) where

285+

280− type ServerT (Get ctypes a) m = m a

286+ type ServerT' (Get ctypes a) m = m a

287+

281 route Proxy action request respond

288 route Proxy action request respond

282 | pathIsEmpty request && requestMethod request == methodGet = do

289 | pathIsEmpty request && requestMethod request == methodGet = do

283 e <- runEitherT action

290 e <- runEitherT action

@@ -296,7 +303,7 @@ instance ( AllCTRender ctypes a

296

303

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

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

298instance HasServer (Get ctypes ()) where

305instance HasServer (Get ctypes ()) where

299− type ServerT (Get ctypes ()) m = m ()

306+ type ServerT' (Get ctypes ()) m = m ()

300 route Proxy action request respond

307 route Proxy action request respond

301 | pathIsEmpty request && requestMethod request == methodGet = do

308 | pathIsEmpty request && requestMethod request == methodGet = do

302 e <- runEitherT action

309 e <- runEitherT action

@@ -310,7 +317,7 @@ instance HasServer (Get ctypes ()) where

310

317

311-- Add response headers

318-- Add response headers

312instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where

319instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where

313− type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)

320+ type ServerT' (Get ctypes (Headers h v)) m = m (Headers h v)

314 route Proxy action request respond

321 route Proxy action request respond

315 | pathIsEmpty request && requestMethod request == methodGet = do

322 | pathIsEmpty request && requestMethod request == methodGet = do

316 e <- runEitherT action

323 e <- runEitherT action

@@ -351,8 +358,8 @@ instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where

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

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

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

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

353

360

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

361+ type ServerT' (Header sym a :> sublayout) m =

355− Maybe a -> ServerT sublayout m

362+ Maybe a -> ServerT' sublayout m

356

363

357 route Proxy subserver request respond = do

364 route Proxy subserver request respond = do

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

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

@@ -375,7 +382,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

375-- list.

382-- list.

376instance ( AllCTRender ctypes a

383instance ( AllCTRender ctypes a

377 ) => HasServer (Post ctypes a) where

384 ) => HasServer (Post ctypes a) where

385+

378− type ServerT (Post ctypes a) m = m a

386+ type ServerT' (Post ctypes a) m = m a

379

387

380 route Proxy action request respond

388 route Proxy action request respond

381 | pathIsEmpty request && requestMethod request == methodPost = do

389 | pathIsEmpty request && requestMethod request == methodPost = do

@@ -394,7 +402,7 @@ instance ( AllCTRender ctypes a

394 | otherwise = respond $ failWith NotFound

402 | otherwise = respond $ failWith NotFound

395

403

396instance HasServer (Post ctypes ()) where

404instance HasServer (Post ctypes ()) where

397− type ServerT (Post ctypes ()) m = m ()

405+ type ServerT' (Post ctypes ()) m = m ()

398 route Proxy action request respond

406 route Proxy action request respond

399 | pathIsEmpty request && requestMethod request == methodPost = do

407 | pathIsEmpty request && requestMethod request == methodPost = do

400 e <- runEitherT action

408 e <- runEitherT action

@@ -408,7 +416,7 @@ instance HasServer (Post ctypes ()) where

408

416

409-- Add response headers

417-- Add response headers

410instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where

418instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where

411− type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)

419+ type ServerT' (Post ctypes (Headers h v)) m = m (Headers h v)

412 route Proxy action request respond

420 route Proxy action request respond

413 | pathIsEmpty request && requestMethod request == methodPost = do

421 | pathIsEmpty request && requestMethod request == methodPost = do

414 e <- runEitherT action

422 e <- runEitherT action

@@ -441,7 +449,8 @@ instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where

441-- list.

449-- list.

442instance ( AllCTRender ctypes a

450instance ( AllCTRender ctypes a

443 ) => HasServer (Put ctypes a) where

451 ) => HasServer (Put ctypes a) where

452+

444− type ServerT (Put ctypes a) m = m a

453+ type ServerT' (Put ctypes a) m = m a

445

454

446 route Proxy action request respond

455 route Proxy action request respond

447 | pathIsEmpty request && requestMethod request == methodPut = do

456 | pathIsEmpty request && requestMethod request == methodPut = do

@@ -460,7 +469,7 @@ instance ( AllCTRender ctypes a

460 | otherwise = respond $ failWith NotFound

469 | otherwise = respond $ failWith NotFound

461

470

462instance HasServer (Put ctypes ()) where

471instance HasServer (Put ctypes ()) where

463− type ServerT (Put ctypes ()) m = m ()

472+ type ServerT' (Put ctypes ()) m = m ()

464 route Proxy action request respond

473 route Proxy action request respond

465 | pathIsEmpty request && requestMethod request == methodPut = do

474 | pathIsEmpty request && requestMethod request == methodPut = do

466 e <- runEitherT action

475 e <- runEitherT action

@@ -474,7 +483,7 @@ instance HasServer (Put ctypes ()) where

474

483

475-- Add response headers

484-- Add response headers

476instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where

485instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where

477− type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)

486+ type ServerT' (Put ctypes (Headers h v)) m = m (Headers h v)

478 route Proxy action request respond

487 route Proxy action request respond

479 | pathIsEmpty request && requestMethod request == methodPut = do

488 | pathIsEmpty request && requestMethod request == methodPut = do

480 e <- runEitherT action

489 e <- runEitherT action

@@ -505,7 +514,7 @@ instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where

505-- yielding status code 200 along the way.

514-- yielding status code 200 along the way.

506instance ( AllCTRender ctypes a

515instance ( AllCTRender ctypes a

507 ) => HasServer (Patch ctypes a) where

516 ) => HasServer (Patch ctypes a) where

508− type ServerT (Patch ctypes a) m = m a

517+ type ServerT' (Patch ctypes a) m = m a

509

518

510 route Proxy action request respond

519 route Proxy action request respond

511 | pathIsEmpty request && requestMethod request == methodPatch = do

520 | pathIsEmpty request && requestMethod request == methodPatch = do

@@ -524,7 +533,7 @@ instance ( AllCTRender ctypes a

524 | otherwise = respond $ failWith NotFound

533 | otherwise = respond $ failWith NotFound

525

534

526instance HasServer (Patch ctypes ()) where

535instance HasServer (Patch ctypes ()) where

527− type ServerT (Patch ctypes ()) m = m ()

536+ type ServerT' (Patch ctypes ()) m = m ()

528 route Proxy action request respond

537 route Proxy action request respond

529 | pathIsEmpty request && requestMethod request == methodPatch = do

538 | pathIsEmpty request && requestMethod request == methodPatch = do

530 e <- runEitherT action

539 e <- runEitherT action

@@ -538,7 +547,7 @@ instance HasServer (Patch ctypes ()) where

538

547

539-- Add response headers

548-- Add response headers

540instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where

549instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where

541− type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)

550+ type ServerT' (Patch ctypes (Headers h v)) m = m (Headers h v)

542 route Proxy action request respond

551 route Proxy action request respond

543 | pathIsEmpty request && requestMethod request == methodPatch = do

552 | pathIsEmpty request && requestMethod request == methodPatch = do

544 e <- runEitherT action

553 e <- runEitherT action

@@ -580,8 +589,8 @@ instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) wher

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

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

581 => HasServer (QueryParam sym a :> sublayout) where

590 => HasServer (QueryParam sym a :> sublayout) where

582

591

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

592+ type ServerT' (QueryParam sym a :> sublayout) m =

584− Maybe a -> ServerT sublayout m

593+ Maybe a -> ServerT' sublayout m

585

594

586 route Proxy subserver request respond = do

595 route Proxy subserver request respond = do

587 let querytext = parseQueryText $ rawQueryString request

596 let querytext = parseQueryText $ rawQueryString request

@@ -618,8 +627,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

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

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

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

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

620

629

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

630+ type ServerT' (QueryParams sym a :> sublayout) m =

622− [a] -> ServerT sublayout m

631+ [a] -> ServerT' sublayout m

623

632

624 route Proxy subserver request respond = do

633 route Proxy subserver request respond = do

625 let querytext = parseQueryText $ rawQueryString request

634 let querytext = parseQueryText $ rawQueryString request

@@ -651,8 +660,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

651instance (KnownSymbol sym, HasServer sublayout)

660instance (KnownSymbol sym, HasServer sublayout)

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

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

653

662

654− type ServerT (QueryFlag sym :> sublayout) m =

663+ type ServerT' (QueryFlag sym :> sublayout) m =

655− Bool -> ServerT sublayout m

664+ Bool -> ServerT' sublayout m

656

665

657 route Proxy subserver request respond = do

666 route Proxy subserver request respond = do

658 let querytext = parseQueryText $ rawQueryString request

667 let querytext = parseQueryText $ rawQueryString request

@@ -694,8 +703,8 @@ parseMatrixText = parseQueryText

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

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

695 => HasServer (MatrixParam sym a :> sublayout) where

704 => HasServer (MatrixParam sym a :> sublayout) where

696

705

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

706+ type ServerT' (MatrixParam sym a :> sublayout) m =

698− Maybe a -> ServerT sublayout m

707+ Maybe a -> ServerT' sublayout m

699

708

700 route Proxy subserver request respond = case parsePathInfo request of

709 route Proxy subserver request respond = case parsePathInfo request of

701 (first : _)

710 (first : _)

@@ -732,8 +741,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

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

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

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

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

734

743

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

744+ type ServerT' (MatrixParams sym a :> sublayout) m =

736− [a] -> ServerT sublayout m

745+ [a] -> ServerT' sublayout m

737

746

738 route Proxy subserver request respond = case parsePathInfo request of

747 route Proxy subserver request respond = case parsePathInfo request of

739 (first : _)

748 (first : _)

@@ -766,8 +775,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

766instance (KnownSymbol sym, HasServer sublayout)

775instance (KnownSymbol sym, HasServer sublayout)

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

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

768

777

769− type ServerT (MatrixFlag sym :> sublayout) m =

778+ type ServerT' (MatrixFlag sym :> sublayout) m =

770− Bool -> ServerT sublayout m

779+ Bool -> ServerT' sublayout m

771

780

772 route Proxy subserver request respond = case parsePathInfo request of

781 route Proxy subserver request respond = case parsePathInfo request of

773 (first : _)

782 (first : _)

@@ -794,7 +803,9 @@ instance (KnownSymbol sym, HasServer sublayout)

794-- > server :: Server MyApi

803-- > server :: Server MyApi

795-- > server = serveDirectory "/var/www/images"

804-- > server = serveDirectory "/var/www/images"

796instance HasServer Raw where

805instance HasServer Raw where

806+

797− type ServerT Raw m = Application

807+ type ServerT' Raw m = Application

808+

798 route Proxy rawApplication request respond =

809 route Proxy rawApplication request respond =

799 rawApplication request (respond . succeedWith)

810 rawApplication request (respond . succeedWith)

800

811

@@ -821,8 +832,8 @@ instance HasServer Raw where

821instance ( AllCTUnrender list a, HasServer sublayout

832instance ( AllCTUnrender list a, HasServer sublayout

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

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

823

834

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

835+ type ServerT' (ReqBody list a :> sublayout) m =

825− a -> ServerT sublayout m

836+ a -> ServerT' sublayout m

826

837

827 route Proxy subserver request respond = do

838 route Proxy subserver request respond = do

828 -- See HTTP RFC 2616, section 7.2.1

839 -- See HTTP RFC 2616, section 7.2.1

@@ -841,7 +852,9 @@ instance ( AllCTUnrender list a, HasServer sublayout

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

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

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

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

843instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where

854instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where

855+

844− type ServerT (path :> sublayout) m = ServerT sublayout m

856+ type ServerT' (path :> sublayout) m = ServerT' sublayout m

857+

845 route Proxy subserver request respond = case processedPathInfo request of

858 route Proxy subserver request respond = case processedPathInfo request of

846 (first : rest)

859 (first : rest)

847 | first == cs (symbolVal proxyPath)

860 | first == cs (symbolVal proxyPath)

src/Servant/Utils/StaticFiles.hs+1−1

@@ -9,7 +9,7 @@ module Servant.Utils.StaticFiles (

9import Filesystem.Path.CurrentOS (decodeString)

10import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)

11import Servant.API.Raw (Raw)

12−import Servant.Server.Internal (Server)

12+import Servant.Server (Server)

14-- | Serve anything under the specified directory as a 'Raw' endpoint.

15--