From a15b2319f931b062cbf007c5d7fe9c113d3ce517 Mon Sep 17 00:00:00 2001
From: George Pollard <porges@porg.es>
Date: Wed, 19 Aug 2015 19:38:50 +1200
Subject: [PATCH] Sketch new overlapping instance for supplying a status code

---
 servant-server/src/Servant/Server/Internal.hs | 38 ++++++++++++++++++-
 1 file changed, 37 insertions(+), 1 deletion(-)

diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index e10bf937..bd4f6a77 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -129,6 +129,8 @@ allowedMethodHead method request = method == methodGet && requestMethod request
 allowedMethod :: Method -> Request -> Bool
 allowedMethod method request = allowedMethodHead method request || requestMethod request == method
 
+type ServantSuccess a = (Status, a)
+
 processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
                     => Maybe (a, BL.ByteString) -> Status -> Method
                     -> Maybe [(HeaderName, B.ByteString)]
@@ -141,7 +143,9 @@ processMethodRouter handleA status method headers request = case handleA of
       hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
 
 methodRouter :: (AllCTRender ctypes a)
-             => Method -> Proxy ctypes -> Status
+             => Method
+             -> Proxy ctypes
+             -> Status
              -> IO (RouteResult (EitherT ServantErr IO a))
              -> Router
 methodRouter method proxy status action = LeafRouter route'
@@ -156,6 +160,23 @@ methodRouter method proxy status action = LeafRouter route'
           respond $ failWith WrongMethod
       | otherwise = respond $ failWith NotFound
 
+methodRouterStatusResult :: (AllCTRender ctypes a)
+                         => Method
+                         -> Proxy ctypes
+                         -> IO (RouteResult (EitherT ServantErr IO (ServantSuccess a)))
+                         -> Router
+methodRouterStatusResult method proxy action = LeafRouter route'
+  where
+    route' request respond
+      | pathIsEmpty request && allowedMethod method request = do
+          runAction action respond $ \(status, output) -> do
+            let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
+                handleA = handleAcceptH proxy (AcceptHeader accH) output
+            processMethodRouter handleA status method Nothing request
+      | pathIsEmpty request && requestMethod request /= method =
+          respond $ failWith WrongMethod
+      | otherwise = respond $ failWith NotFound
+
 methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
                     => Method -> Proxy ctypes -> Status
                     -> IO (RouteResult (EitherT ServantErr IO (Headers h v)))
@@ -246,6 +267,21 @@ instance
       method = B8.pack $ symbolVal (Proxy :: Proxy method)
       status = toEnum $ fromInteger $ natVal (Proxy :: Proxy (DefaultStatusCode method))
 
+
+instance
+#if MIN_VERSION_base(4,8,0)
+         {-# OVERLAPPING #-}
+#endif 
+        ( AllCTRender ctypes a
+        , KnownSymbol method
+        ) => HasServer (HttpMethod method ctypes (ServantSuccess a)) where
+
+  type ServerT (HttpMethod method ctypes (ServantSuccess a)) m = m (ServantSuccess a)
+
+  route Proxy = methodRouterStatusResult method (Proxy :: Proxy ctypes)
+    where 
+      method = B8.pack $ symbolVal (Proxy :: Proxy method)
+
 instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}