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

Merge branch 'master' into canonical-types

Browse source 
Conflicts:
	CHANGELOG.md
	src/Servant/Server/Internal.hs
This commit is contained in:
Alp Mestanogullari 2015-04-19 10:59:14 +02:00
commit fc30c7e242
3 changed files with 35 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
CHANGELOG.md
View file

@ -5,7 +5,7 @@
* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*
* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29) * Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21) * Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
* Canonicalize API types before generating the handler typesy * Canonicalize API types before generating the handler types with `Server`
0.2.4 0.2.4
----- -----

3
src/Servant/Server.hs
View file

@ -14,6 +14,7 @@ module Servant.Server
, -- * Handlers for all standard combinators , -- * Handlers for all standard combinators
HasServer(..) HasServer(..)
, Server , Server
, ServerT
) where ) where
import Data.Proxy (Proxy) import Data.Proxy (Proxy)
@ -46,5 +47,3 @@ import Servant.Server.Internal
-- > main = Network.Wai.Handler.Warp.run 8080 app -- > main = Network.Wai.Handler.Warp.run 8080 app
serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application
serve p server = toApplication (route (canonicalize p) server) serve p server = toApplication (route (canonicalize p) server)
type Server layout = Server' (Canonicalize layout)

62
src/Servant/Server/Internal.hs
View file

@ -30,7 +30,8 @@ import Network.Wai ( Response, Request, ResponseReceived, Application
rawQueryString, responseLBS) rawQueryString, responseLBS)
import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
, MatrixParams, MatrixParam, MatrixFlag , MatrixParams, MatrixParam, MatrixFlag
, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)) , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)
, Canonicalize)
import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..) import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)
, AllCTUnrender(..),) , AllCTUnrender(..),)
import Servant.Common.Text (FromText, fromText) import Servant.Common.Text (FromText, fromText)
@ -160,10 +161,13 @@ processedPathInfo r =
where pinfo = parsePathInfo r where pinfo = parsePathInfo r
class HasServer layout where class HasServer layout where
type ServerT layout (m :: * -> *) :: * type ServerT' layout (m :: * -> *) :: *
route :: Proxy layout -> Server' layout -> RoutingApplication route :: Proxy layout -> Server' layout -> RoutingApplication
type Server' layout = ServerT layout (EitherT (Int, String) IO) type Server layout = Server' (Canonicalize layout)
type Server' layout = ServerT' layout (EitherT (Int, String) IO)
type ServerT layout m = ServerT' (Canonicalize layout) m
-- * Instances -- * Instances
@ -180,7 +184,7 @@ type Server' layout = ServerT layout (EitherT (Int, String) IO)
-- > postBook book = ... -- > postBook book = ...
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m
route Proxy (a :<|> b) request respond = route Proxy (a :<|> b) request respond =
route pa a request $ \mResponse -> route pa a request $ \mResponse ->
@ -214,8 +218,8 @@ captured _ = fromText
instance (KnownSymbol capture, FromText a, HasServer sublayout) instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where => HasServer (Capture capture a :> sublayout) where
type ServerT (Capture capture a :> sublayout) m = type ServerT' (Capture capture a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT' sublayout m
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver request respond = case processedPathInfo request of
(first : rest) (first : rest)
@ -242,7 +246,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
-- are not met. -- are not met.
instance HasServer Delete where instance HasServer Delete where
type ServerT Delete m = m () type ServerT' Delete m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do | pathIsEmpty request && requestMethod request == methodDelete = do
@ -272,7 +276,7 @@ instance HasServer Delete where
instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a
) => HasServer (Get ctypes a) where ) => HasServer (Get ctypes a) where
type ServerT (Get ctypes a) m = m a type ServerT' (Get ctypes a) m = m a
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do | pathIsEmpty request && requestMethod request == methodGet = do
@ -313,8 +317,8 @@ instance ( AllCTRender ctypes a
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where => HasServer (Header sym a :> sublayout) where
type ServerT (Header sym a :> sublayout) m = type ServerT' (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
@ -338,7 +342,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a
) => HasServer (Post ctypes a) where ) => HasServer (Post ctypes a) where
type ServerT (Post ctypes a) m = m a type ServerT' (Post ctypes a) m = m a
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
@ -372,7 +376,7 @@ instance ( AllCTRender ctypes a
instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a
) => HasServer (Put ctypes a) where ) => HasServer (Put ctypes a) where
type ServerT (Put ctypes a) m = m a type ServerT' (Put ctypes a) m = m a
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
@ -406,7 +410,7 @@ instance ( AllCTRender ctypes a
, Typeable a , Typeable a
, ToJSON a) => HasServer (Patch ctypes a) where , ToJSON a) => HasServer (Patch ctypes a) where
type ServerT (Patch ctypes a) m = m a type ServerT' (Patch ctypes a) m = m a
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
@ -450,8 +454,8 @@ instance ( AllCTRender ctypes a
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where => HasServer (QueryParam sym a :> sublayout) where
type ServerT (QueryParam sym a :> sublayout) m = type ServerT' (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -488,8 +492,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where => HasServer (QueryParams sym a :> sublayout) where
type ServerT (QueryParams sym a :> sublayout) m = type ServerT' (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -521,8 +525,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where => HasServer (QueryFlag sym :> sublayout) where
type ServerT (QueryFlag sym :> sublayout) m = type ServerT' (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -564,8 +568,8 @@ parseMatrixText = parseQueryText
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParam sym a :> sublayout) where => HasServer (MatrixParam sym a :> sublayout) where
type ServerT (MatrixParam sym a :> sublayout) m = type ServerT' (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT' sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -602,8 +606,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParams sym a :> sublayout) where => HasServer (MatrixParams sym a :> sublayout) where
type ServerT (MatrixParams sym a :> sublayout) m = type ServerT' (MatrixParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT' sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -636,8 +640,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (MatrixFlag sym :> sublayout) where => HasServer (MatrixFlag sym :> sublayout) where
type ServerT (MatrixFlag sym :> sublayout) m = type ServerT' (MatrixFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT' sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -665,7 +669,7 @@ instance (KnownSymbol sym, HasServer sublayout)
-- > server = serveDirectory "/var/www/images" -- > server = serveDirectory "/var/www/images"
instance HasServer Raw where instance HasServer Raw where
type ServerT Raw m = Application type ServerT' Raw m = Application
route Proxy rawApplication request respond = route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith) rawApplication request (respond . succeedWith)
@ -693,8 +697,8 @@ instance HasServer Raw where
instance ( AllCTUnrender list a, HasServer sublayout instance ( AllCTUnrender list a, HasServer sublayout
) => HasServer (ReqBody list a :> sublayout) where ) => HasServer (ReqBody list a :> sublayout) where
type ServerT (ReqBody list a :> sublayout) m = type ServerT' (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
-- See HTTP RFC 2616, section 7.2.1 -- See HTTP RFC 2616, section 7.2.1
@ -714,7 +718,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
-- pass the rest of the request path to @sublayout@. -- pass the rest of the request path to @sublayout@.
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type ServerT (path :> sublayout) m = ServerT sublayout m type ServerT' (path :> sublayout) m = ServerT' sublayout m
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver request respond = case processedPathInfo request of
(first : rest) (first : rest)