From 046d35ff9756a903b9fe6c9ded404ad62e1b4653 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= <theophile.choutri@scrive.com>
Date: Thu, 29 Aug 2024 00:06:00 +0200
Subject: [PATCH] Simplified ErrorResponse

---
 .../test/Servant/ClientTestUtils.hs           | 43 ++++++++++---------
 .../Servant/Server/Internal/ResponseRender.hs |  2 -
 2 files changed, 23 insertions(+), 22 deletions(-)

diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs
index 063cf18d1..fc106aca3 100644
--- a/servant-client/test/Servant/ClientTestUtils.hs
+++ b/servant-client/test/Servant/ClientTestUtils.hs
@@ -145,30 +145,33 @@ instance ToDeepQuery Filter where
     , (["name"], Just (Text.pack name'))
     ]
 
--- MultiVerb test endpoint
+-----------------------------
+-- MultiVerb test endpoint --
+-----------------------------
 
-data ErrorResponse a
+-- Possible errors
 
-data UserNotFound
+type GetUserMultiVerbErrors =
+  '[RespondEmpty 404 "User not found"]
 
-type instance ResponseType (ErrorResponse a) = a
+-- This is the concatenation of possible responses
+type GetUserMultiVerbResponses = 
+    GetUserMultiVerbErrors 
+      .++ '[Respond 200 "User found" Person]
 
+-- A 'AsUnion' instance
+instance (res ~ GetUserMultiVerbResponses) => AsUnion res (Maybe Person) where
+  toUnion = maybeToUnion (toUnion @GetUserMultiVerbErrors)
+  fromUnion = maybeFromUnion (fromUnion @GetUserMultiVerbErrors)
+
+-- This is our endpoint description
 type GetUserMultiVerb =
   Capture "personId" Int
   :> MultiVerb
     'GET
     '[JSON]
-    '[ ErrorResponse UserNotFound,
-       Respond 200 "User found" Person
-     ]
-    (Either UserNotFound Person)
-
-type GetUserMultiVerbResponses =
-  [ErrorResponse UserNotFound, RespondAs JSON 200 "Person" Person]
-
-instance (res ~ GetUserMultiVerbResponses) => AsUnion res (Either UserNotFound Person) where
-  toUnion = eitherToUnion (toUnion @_) (Z . I)
-  fromUnion = eitherFromUnion (fromUnion @_) (unI . unZ)
+    GetUserMultiVerbResponses
+    (Maybe Person)
 
 type Api =
   Get '[JSON] Person
@@ -212,8 +215,8 @@ type Api =
                                       WithStatus 301 Text]
   :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
   :<|> NamedRoutes RecordRoutes
-  :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
   :<|> GetUserMultiVerb
+  :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
 
 api :: Proxy Api
 api = Proxy
@@ -247,8 +250,8 @@ uverbGetSuccessOrRedirect :: Bool
                                               WithStatus 301 Text])
 uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
 recordRoutes :: RecordRoutes (AsClientT ClientM)
-captureVerbatim :: Verbatim -> ClientM Text
 getUserMultiVerb :: Int -> ClientM (Maybe Person)
+captureVerbatim :: Verbatim -> ClientM Text
 
 getRoot
   :<|> getGet
@@ -277,8 +280,8 @@ getRoot
   :<|> uverbGetSuccessOrRedirect
   :<|> uverbGetCreated
   :<|> recordRoutes
-  :<|> captureVerbatim
-  :<|> getUserMultiVerb = client api
+  :<|> getUserMultiVerb
+  :<|> captureVerbatim = client api
 
 server :: Application
 server = serve api (
@@ -332,8 +335,8 @@ server = serve api (
              { something = pure ["foo", "bar", "pweet"]
              }
          }
+  :<|> (\_ -> pure $ Just $ Person "Name" 30)
   :<|> pure . decodeUtf8 . unVerbatim
-  :<|> undefined --pure $ Just $ Person "Name" 30
   )
 
 -- * api for testing failures
diff --git a/servant-server/src/Servant/Server/Internal/ResponseRender.hs b/servant-server/src/Servant/Server/Internal/ResponseRender.hs
index 3806ede49..086f16d8e 100644
--- a/servant-server/src/Servant/Server/Internal/ResponseRender.hs
+++ b/servant-server/src/Servant/Server/Internal/ResponseRender.hs
@@ -54,7 +54,6 @@ instance IsWaiBody (SourceIO ByteString) where
 
 data SomeResponse = forall a. (IsWaiBody a) => SomeResponse (InternalResponse a)
 
-
 class ResponseListRender cs as where
   responseListRender
     :: AcceptHeader
@@ -66,7 +65,6 @@ instance ResponseListRender cs '[] where
   responseListRender _ x = case x of {}
   responseListStatuses = []
 
-
 class (IsWaiBody (ResponseBody a)) => ResponseRender cs a where
   type ResponseStatus a :: Nat
   type ResponseBody a :: Type