01a020d · typeable/servant

git.iko.soy/typeable/servant

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

Canonicalize types

commit01a020d43289e80400ce7ae48a86f70b356936ad authorAlp Mestanogullari <alpmestan@gmail.com> dateSun 19 Apr 2015, 13:23 (11 years ago) parentf6f120d bf63786

4 files changed+63−47

compare with master

unifiedsplit

CHANGELOG.md+1 src/Servant/Server.hs+5−3 src/Servant/Server/Internal.hs+56−43 src/Servant/Utils/StaticFiles.hs+1−1

CHANGELOG.md+1

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

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

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

77* 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`

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

910* Add server support for response headers

1011

src/Servant/Server.hs+5−3

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

11{-# LANGUAGE TypeFamilies #-}

2+{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE OverloadedStrings #-}

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

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

1314 , -- * Handlers for all standard combinators

1415 HasServer(..)

1516 , Server

17+ , ServerT

1618 ) where

1719

1820import Data.Proxy (Proxy)

1921import Network.Wai (Application)

20−

22+import Servant.API (Canonicalize, canonicalize)

2123import Servant.Server.Internal

2224

2325

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

4345-- >

4446-- > main :: IO ()

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

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

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

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

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,

3232 requestMethod, responseLBS,

3333 strictRequestBody)

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

35− Delete, Get, Header, MatrixFlag,

36− MatrixParam, MatrixParams, Patch,

37− Post, Put, QueryFlag, QueryParam,

38− QueryParams, Raw, ReqBody)

35+ Canonicalize, Delete, Get, Header,

36+ MatrixFlag, MatrixParam, MatrixParams,

37+ Patch, Post, Put, QueryFlag,

38+ QueryParam, QueryParams, Raw,

39+ ReqBody)

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

4041 AllCTRender (..),

4142 AllCTUnrender (..))

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

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

4445

45−

4646data ReqBodyState = Uncalled

4747 | Called !B.ByteString

4848 | Done !B.ByteString

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

168168 where pinfo = parsePathInfo r

169169

170170class HasServer layout where

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

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

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

173172

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

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

175174

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

176178

177179-- * Instances

178180

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

188190-- > where listAllBooks = ...

189191-- > postBook book = ...

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

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

193+

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

195+

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

193− route pa a request $ \ mResponse ->

197+ route pa a request $ \mResponse ->

194198 if isMismatch mResponse

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

196200 else respond mResponse

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

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

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

223227

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

225− a -> ServerT sublayout m

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

229+ a -> ServerT' sublayout m

226230

227231 route Proxy subserver request respond = case processedPathInfo request of

228232 (first : rest)

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

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

249253-- are not met.

250254instance HasServer Delete where

251− type ServerT Delete m = m ()

255+

256+ type ServerT' Delete m = m ()

252257

253258 route Proxy action request respond

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

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

277282-- list.

278283instance ( AllCTRender ctypes a

279284 ) => HasServer (Get ctypes a) where

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

285+

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

287+

281288 route Proxy action request respond

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

283290 e <- runEitherT action

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

296303

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

298305instance HasServer (Get ctypes ()) where

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

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

300307 route Proxy action request respond

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

302309 e <- runEitherT action

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

310317

311318-- Add response headers

312319instance ( 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)

314321 route Proxy action request respond

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

316323 e <- runEitherT action

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

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

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

353360

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

355− Maybe a -> ServerT sublayout m

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

362+ Maybe a -> ServerT' sublayout m

356363

357364 route Proxy subserver request respond = do

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

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

375382-- list.

376383instance ( AllCTRender ctypes a

377384 ) => HasServer (Post ctypes a) where

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

385+

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

379387

380388 route Proxy action request respond

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

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

394402 | otherwise = respond $ failWith NotFound

395403

396404instance HasServer (Post ctypes ()) where

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

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

398406 route Proxy action request respond

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

400408 e <- runEitherT action

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

408416

409417-- Add response headers

410418instance ( 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)

412420 route Proxy action request respond

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

414422 e <- runEitherT action

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

441449-- list.

442450instance ( AllCTRender ctypes a

443451 ) => HasServer (Put ctypes a) where

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

452+

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

445454

446455 route Proxy action request respond

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

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

460469 | otherwise = respond $ failWith NotFound

461470

462471instance HasServer (Put ctypes ()) where

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

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

464473 route Proxy action request respond

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

466475 e <- runEitherT action

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

474483

475484-- Add response headers

476485instance ( 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)

478487 route Proxy action request respond

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

480489 e <- runEitherT action

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

505514-- yielding status code 200 along the way.

506515instance ( AllCTRender ctypes a

507516 ) => HasServer (Patch ctypes a) where

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

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

509518

510519 route Proxy action request respond

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

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

524533 | otherwise = respond $ failWith NotFound

525534

526535instance HasServer (Patch ctypes ()) where

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

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

528537 route Proxy action request respond

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

530539 e <- runEitherT action

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

538547

539548-- Add response headers

540549instance ( 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)

542551 route Proxy action request respond

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

544553 e <- runEitherT action

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

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

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

582591

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

584− Maybe a -> ServerT sublayout m

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

593+ Maybe a -> ServerT' sublayout m

585594

586595 route Proxy subserver request respond = do

587596 let querytext = parseQueryText $ rawQueryString request

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

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

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

620629

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

622− [a] -> ServerT sublayout m

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

631+ [a] -> ServerT' sublayout m

623632

624633 route Proxy subserver request respond = do

625634 let querytext = parseQueryText $ rawQueryString request

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

651660instance (KnownSymbol sym, HasServer sublayout)

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

653662

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

655− Bool -> ServerT sublayout m

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

664+ Bool -> ServerT' sublayout m

656665

657666 route Proxy subserver request respond = do

658667 let querytext = parseQueryText $ rawQueryString request

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

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

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

696705

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

698− Maybe a -> ServerT sublayout m

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

707+ Maybe a -> ServerT' sublayout m

699708

700709 route Proxy subserver request respond = case parsePathInfo request of

701710 (first : _)

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

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

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

734743

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

736− [a] -> ServerT sublayout m

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

745+ [a] -> ServerT' sublayout m

737746

738747 route Proxy subserver request respond = case parsePathInfo request of

739748 (first : _)

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

766775instance (KnownSymbol sym, HasServer sublayout)

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

768777

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

770− Bool -> ServerT sublayout m

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

779+ Bool -> ServerT' sublayout m

771780

772781 route Proxy subserver request respond = case parsePathInfo request of

773782 (first : _)

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

794803-- > server :: Server MyApi

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

796805instance HasServer Raw where

797− type ServerT Raw m = Application

806+

807+ type ServerT' Raw m = Application

808+

798809 route Proxy rawApplication request respond =

799810 rawApplication request (respond . succeedWith)

800811

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

821832instance ( AllCTUnrender list a, HasServer sublayout

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

823834

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

825− a -> ServerT sublayout m

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

836+ a -> ServerT' sublayout m

826837

827838 route Proxy subserver request respond = do

828839 -- See HTTP RFC 2616, section 7.2.1

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

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

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

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

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

855+

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

857+

845858 route Proxy subserver request respond = case processedPathInfo request of

846859 (first : rest)

847860 | first == cs (symbolVal proxyPath)

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

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

99import Filesystem.Path.CurrentOS (decodeString)

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

1111import Servant.API.Raw (Raw)

12−import Servant.Server.Internal (Server)

12+import Servant.Server (Server)

1313

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

1515--