Introduce ServerT to specify generic handlers.

src/Servant/Server/Internal.hs

@@ -160,9 +160,12 @@ 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
 
 -- | A server for @a ':<|>' b@ first tries to match the request against the route
@@ -177,7 +180,9 @@ 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
@@ -210,8 +215,8 @@ captured _ = fromText
 instance (KnownSymbol capture, FromText a, HasServer sublayout)
       => HasServer (Capture capture a :> sublayout) where
 
-  type Server' (Capture capture a :> sublayout) =
+  type ServerT (Capture capture a :> sublayout) m =
-     a -> Server' sublayout
+     a -> ServerT sublayout m
 
   route Proxy subserver request respond = case processedPathInfo request of
     (first : rest)
@@ -237,7 +242,8 @@ 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
@@ -266,7 +272,9 @@ 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
@@ -306,8 +314,8 @@ instance ( AllCTRender ctypes a
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (Header sym a :> sublayout) where
 
-  type Server' (Header sym a :> sublayout) =
+  type ServerT (Header sym a :> sublayout) m =
-    Maybe a -> Server' sublayout
+    Maybe a -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
@@ -330,7 +338,8 @@ 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
@@ -363,7 +372,8 @@ 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
@@ -396,7 +406,8 @@ 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
@@ -440,8 +451,8 @@ instance ( AllCTRender ctypes a
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (QueryParam sym a :> sublayout) where
 
-  type Server' (QueryParam sym a :> sublayout) =
+  type ServerT (QueryParam sym a :> sublayout) m =
-    Maybe a -> Server' sublayout
+    Maybe a -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     let querytext = parseQueryText $ rawQueryString request
@@ -478,8 +489,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) =
+  type ServerT (QueryParams sym a :> sublayout) m =
-    [a] -> Server' sublayout
+    [a] -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     let querytext = parseQueryText $ rawQueryString request
@@ -511,8 +522,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 instance (KnownSymbol sym, HasServer sublayout)
       => HasServer (QueryFlag sym :> sublayout) where
 
-  type Server' (QueryFlag sym :> sublayout) =
+  type ServerT (QueryFlag sym :> sublayout) m =
-    Bool -> Server' sublayout
+    Bool -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     let querytext = parseQueryText $ rawQueryString request
@@ -554,8 +565,8 @@ parseMatrixText = parseQueryText
 instance (KnownSymbol sym, FromText a, HasServer sublayout)
       => HasServer (MatrixParam sym a :> sublayout) where
 
-  type Server' (MatrixParam sym a :> sublayout) =
+  type ServerT (MatrixParam sym a :> sublayout) m =
-    Maybe a -> Server' sublayout
+    Maybe a -> ServerT sublayout m
 
   route Proxy subserver request respond = case parsePathInfo request of
     (first : _)
@@ -592,8 +603,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) =
+  type ServerT (MatrixParams sym a :> sublayout) m =
-    [a] -> Server' sublayout
+    [a] -> ServerT sublayout m
 
   route Proxy subserver request respond = case parsePathInfo request of
     (first : _)
@@ -626,8 +637,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 instance (KnownSymbol sym, HasServer sublayout)
       => HasServer (MatrixFlag sym :> sublayout) where
 
-  type Server' (MatrixFlag sym :> sublayout) =
+  type ServerT (MatrixFlag sym :> sublayout) m =
-    Bool -> Server' sublayout
+    Bool -> ServerT sublayout m
 
   route Proxy subserver request respond =  case parsePathInfo request of
     (first : _)
@@ -654,7 +665,9 @@ 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)
 
@@ -681,8 +694,8 @@ instance HasServer Raw where
 instance ( AllCTUnrender list a, HasServer sublayout
          ) => HasServer (ReqBody list a :> sublayout) where
 
-  type Server' (ReqBody list a :> sublayout) =
+  type ServerT (ReqBody list a :> sublayout) m =
-    a -> Server' sublayout
+    a -> ServerT sublayout m
 
   route Proxy subserver request respond = do
     -- See HTTP RFC 2616, section 7.2.1
@@ -701,7 +714,9 @@ 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)