Skip to content

Commit

Permalink
Merge pull request #21 from rschatz/master
Browse files Browse the repository at this point in the history
Support other monads than just IO.
  • Loading branch information
jkarni committed Mar 10, 2015
2 parents 947815e + f7af3b1 commit 1b61455
Show file tree
Hide file tree
Showing 2 changed files with 29 additions and 27 deletions.
1 change: 1 addition & 0 deletions src/Servant/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@ module Servant.Server

, -- * Handlers for all standard combinators
HasServer(..)
, Server
) where

import Data.Proxy (Proxy)
Expand Down
55 changes: 28 additions & 27 deletions src/Servant/Server/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -160,9 +160,10 @@ processedPathInfo r =
where pinfo = parsePathInfo r

class HasServer layout where
type Server layout :: *
type ServerT layout (m :: * -> *) :: *
route :: Proxy layout -> Server layout -> RoutingApplication

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


-- * Instances
Expand All @@ -179,7 +180,7 @@ class HasServer layout where
-- > where listAllBooks = ...
-- > postBook book = ...
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type Server (a :<|> b) = Server a :<|> Server b
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy (a :<|> b) request respond =
route pa a request $ \ mResponse ->
if isMismatch mResponse
Expand Down Expand Up @@ -212,8 +213,8 @@ captured _ = fromText
instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where

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

route Proxy subserver request respond = case processedPathInfo request of
(first : rest)
Expand All @@ -239,7 +240,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
-- painlessly error out if the conditions for a successful deletion
-- are not met.
instance HasServer Delete where
type Server Delete = EitherT (Int, String) IO ()
type ServerT Delete m = m ()

route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
Expand Down Expand Up @@ -268,7 +269,7 @@ instance HasServer Delete where
-- list.
instance ( AllCTRender ctypes a
) => HasServer (Get ctypes a) where
type Server (Get ctypes a) = EitherT (Int, String) IO a
type ServerT (Get ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
Expand Down Expand Up @@ -308,8 +309,8 @@ instance ( AllCTRender ctypes a
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where

type Server (Header sym a :> sublayout) =
Maybe a -> Server sublayout
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m

route Proxy subserver request respond = do
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
Expand All @@ -332,7 +333,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- list.
instance ( AllCTRender ctypes a
) => HasServer (Post ctypes a) where
type Server (Post ctypes a) = EitherT (Int, String) IO a
type ServerT (Post ctypes a) m = m a

route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
Expand Down Expand Up @@ -365,7 +366,7 @@ instance ( AllCTRender ctypes a
-- list.
instance ( AllCTRender ctypes a
) => HasServer (Put ctypes a) where
type Server (Put ctypes a) = EitherT (Int, String) IO a
type ServerT (Put ctypes a) m = m a

route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
Expand Down Expand Up @@ -398,7 +399,7 @@ instance ( AllCTRender ctypes a
instance ( AllCTRender ctypes a
, Typeable a
, ToJSON a) => HasServer (Patch ctypes a) where
type Server (Patch ctypes a) = EitherT (Int, String) IO a
type ServerT (Patch ctypes a) m = m a

route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
Expand Down Expand Up @@ -442,8 +443,8 @@ instance ( AllCTRender ctypes a
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where

type Server (QueryParam sym a :> sublayout) =
Maybe a -> Server sublayout
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m

route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
Expand Down Expand Up @@ -480,8 +481,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where

type Server (QueryParams sym a :> sublayout) =
[a] -> Server sublayout
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m

route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
Expand Down Expand Up @@ -513,8 +514,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where

type Server (QueryFlag sym :> sublayout) =
Bool -> Server sublayout
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m

route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
Expand Down Expand Up @@ -556,8 +557,8 @@ parseMatrixText = parseQueryText
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParam sym a :> sublayout) where

type Server (MatrixParam sym a :> sublayout) =
Maybe a -> Server sublayout
type ServerT (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m

route Proxy subserver request respond = case parsePathInfo request of
(first : _)
Expand Down Expand Up @@ -594,8 +595,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParams sym a :> sublayout) where

type Server (MatrixParams sym a :> sublayout) =
[a] -> Server sublayout
type ServerT (MatrixParams sym a :> sublayout) m =
[a] -> ServerT sublayout m

route Proxy subserver request respond = case parsePathInfo request of
(first : _)
Expand Down Expand Up @@ -628,8 +629,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (MatrixFlag sym :> sublayout) where

type Server (MatrixFlag sym :> sublayout) =
Bool -> Server sublayout
type ServerT (MatrixFlag sym :> sublayout) m =
Bool -> ServerT sublayout m

route Proxy subserver request respond = case parsePathInfo request of
(first : _)
Expand All @@ -656,7 +657,7 @@ instance (KnownSymbol sym, HasServer sublayout)
-- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images"
instance HasServer Raw where
type Server Raw = Application
type ServerT Raw m = Application
route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith)

Expand All @@ -683,8 +684,8 @@ instance HasServer Raw where
instance ( AllCTUnrender list a, HasServer sublayout
) => HasServer (ReqBody list a :> sublayout) where

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

route Proxy subserver request respond = do
-- See HTTP RFC 2616, section 7.2.1
Expand All @@ -703,7 +704,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
-- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@.
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type Server (path :> sublayout) = Server sublayout
type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of
(first : rest)
| first == cs (symbolVal proxyPath)
Expand Down

0 comments on commit 1b61455

Please sign in to comment.