Make response headers work properly

src/Tie/Codegen/Response.hs

@@ -39,29 +39,35 @@ import Tie.Resolve (Resolver)
 -- | Generate code for the responses of an 'Operation'.
 codegenResponses :: Monad m => Resolver m -> Operation -> m (Doc ann)
 codegenResponses resolver Operation {..} = do
-  let responseHeaderTypes Response {headers} =
-        PP.hsep (map codegenHeaderSchema headers)
+  let responseBodyType Response {jsonResponseContent} = case jsonResponseContent of
+        Just jsonContent ->
+          [codegenFieldType jsonContent]
+        Nothing ->
+          []
+
+      responseHeaderTypes Response {headers} =
+        map codegenHeaderSchema headers
 
       decl =
         "data" <+> toApiResponseTypeName name <> PP.line
           <> PP.indent
             4
             ( PP.vsep $
-                [ op <+> toApiResponseConstructorName name statusCode <+> case jsonResponseContent of
-                    Nothing -> mempty
-                    Just jsonContent ->
-                      codegenFieldType jsonContent
-                        <+> responseHeaderTypes response
-                  | (op, (statusCode, response@Response {jsonResponseContent})) <- zip ("=" : repeat "|") responses
+                [ PP.hsep $
+                    concat
+                      [ [op, toApiResponseConstructorName name statusCode],
+                        responseBodyType response,
+                        responseHeaderTypes response
+                      ]
+                  | (op, (statusCode, response)) <- zip ("=" : repeat "|") responses
                 ]
-                  ++ [ "|" <+> toApiDefaultResponseConstructorName name
-                         <+> "Network.HTTP.Types.Status"
-                         <+> case jsonResponseContent of
-                           Nothing -> mempty
-                           Just jsonContent ->
-                             codegenFieldType jsonContent
-                               <+> responseHeaderTypes response
-                       | Just response@Response {jsonResponseContent} <- [defaultResponse]
+                  ++ [ PP.hsep $
+                         concat
+                           [ ["|", toApiDefaultResponseConstructorName name, "Network.HTTP.Types.Status"],
+                             responseBodyType response,
+                             responseHeaderTypes response
+                           ]
+                       | Just response <- [defaultResponse]
                      ]
                   ++ [ "deriving" <+> "(" <> "Show" <> ")"
                      ]

test/golden/datetime.yaml.out

@@ -328,7 +328,7 @@ import Test.Response
 
 
 data TestResponse
-    = TestResponse200 Test 
+    = TestResponse200 Test
     deriving (Show)
 
 instance Control.Exception.Exception TestResponse

test/golden/enum-bug.yaml.out

@@ -331,7 +331,7 @@ import Test.Response
 
 
 data DummyResponse
-    = DummyResponse200 Package 
+    = DummyResponse200 Package
     deriving (Show)
 
 instance Control.Exception.Exception DummyResponse

test/golden/enum.yaml.out

@@ -379,7 +379,7 @@ import Test.Response
 
 
 data ListPackagesResponse
-    = ListPackagesResponse200 Package 
+    = ListPackagesResponse200 Package
     deriving (Show)
 
 instance Control.Exception.Exception ListPackagesResponse
@@ -463,7 +463,7 @@ instance Web.HttpApiData.FromHttpApiData ListPackages2ResponseBody200 where
             _ -> Left "invalid enum value"
 
 data ListPackages2Response
-    = ListPackages2Response200 ListPackages2ResponseBody200 
+    = ListPackages2Response200 ListPackages2ResponseBody200
     deriving (Show)
 
 instance Control.Exception.Exception ListPackages2Response
@@ -541,7 +541,7 @@ instance Web.HttpApiData.FromHttpApiData ListPackages3OrderParam where
             _ -> Left "invalid enum value"
 
 data ListPackages3Response
-    = ListPackages3Response201 
+    = ListPackages3Response201
     deriving (Show)
 
 instance Control.Exception.Exception ListPackages3Response
@@ -588,7 +588,7 @@ import Test.Response
 
 
 data ListPackages4Response
-    = ListPackages4Response201 
+    = ListPackages4Response201
     deriving (Show)
 
 instance Control.Exception.Exception ListPackages4Response

test/golden/headers.yaml

@@ -26,6 +26,18 @@ paths:
             application/json:
               schema:
                 $ref: "#/components/schemas/Test"              
+  /test1:
+    get:
+      summary: test
+      operationId: test1
+      responses:
+        '201':
+          description: Successfully created package
+          headers:
+            Location:
+              description: The package details URL
+              schema:
+                type: string
 components:
   schemas:
     Test: 

test/golden/headers.yaml.out

@@ -34,14 +34,19 @@ import Test.Response
 
 import Test.Schemas.Test
 
+
 import Test.Response.Test
+import Test.Response.Test1
 
 data Api m = Api {
     -- | test
     test ::
         -- @x-next@ How many items to return at one time (max 100)
         (Data.Maybe.Maybe (GHC.Int.Int32)) ->
-        m TestResponse
+        m TestResponse,
+    -- | test
+    test1 ::
+        m Test1Response
 }
 
 application :: (Control.Monad.Catch.MonadCatch m, Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application
@@ -58,6 +63,16 @@ application run api notFound request respond =
                 x ->
                     unsupportedMethod x
 
+        ["test1"] ->
+            case Network.Wai.requestMethod request of
+                "GET" ->
+                    run request (do
+                        response <- Control.Monad.Catch.handle pure (test1 api  )
+                        Control.Monad.IO.Class.liftIO (respond $! (toResponse response))
+                    )
+                x ->
+                    unsupportedMethod x
+
         _ ->
             notFound request respond
     where
@@ -331,7 +346,7 @@ import Test.Response
 
 
 data TestResponse
-    = TestResponse200 Test 
+    = TestResponse200 Test
     deriving (Show)
 
 instance Control.Exception.Exception TestResponse
@@ -340,6 +355,53 @@ instance ToResponse TestResponse where
     toResponse (TestResponse200 x ) =
         Network.Wai.responseBuilder (toEnum 200) [(Network.HTTP.Types.hContentType, "application/json")] (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
 ---------------------
+Test/Response/Test1.hs
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module Test.Response.Test1 where
+
+import qualified Control.Applicative
+import qualified Control.Exception
+import qualified Control.Monad
+import qualified Control.Monad.Catch
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Encoding
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.List
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified Data.Time
+import qualified Data.Text.Encoding
+import qualified GHC.Float
+import qualified GHC.Int
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+
+
+import Test.Response
+
+
+
+data Test1Response
+    = Test1Response201 (Data.Maybe.Maybe (Data.Text.Text))
+    deriving (Show)
+
+instance Control.Exception.Exception Test1Response
+
+instance ToResponse Test1Response where
+    toResponse (Test1Response201  __Location) =
+        Network.Wai.responseBuilder (toEnum 201) [("Location", Web.HttpApiData.toHeader __Location)] mempty
+---------------------
 Test/Schemas/Test.hs
 
 {-# LANGUAGE BangPatterns #-}
@@ -423,4 +485,5 @@ library
     Test.Request
     Test.Response
     Test.Response.Test
+    Test.Response.Test1
     Test.Schemas.Test

test/golden/lists.yaml.out

@@ -358,7 +358,7 @@ import Test.Response
 
 
 data ListPackagesResponse
-    = ListPackagesResponse200 Packages 
+    = ListPackagesResponse200 Packages
     deriving (Show)
 
 instance Control.Exception.Exception ListPackagesResponse
@@ -405,7 +405,7 @@ import Test.Response
 
 
 data ListPackages2Response
-    = ListPackages2Response200 [ Package ] 
+    = ListPackages2Response200 [ Package ]
     deriving (Show)
 
 instance Control.Exception.Exception ListPackages2Response
@@ -452,7 +452,7 @@ import Test.Response
 
 
 data ListPackages3Response
-    = ListPackages3Response200 [ Inline ] 
+    = ListPackages3Response200 [ Inline ]
     deriving (Show)
 
 instance Control.Exception.Exception ListPackages3Response

test/golden/numbers.yaml.out

@@ -328,7 +328,7 @@ import Test.Response
 
 
 data TestResponse
-    = TestResponse200 Test 
+    = TestResponse200 Test
     deriving (Show)
 
 instance Control.Exception.Exception TestResponse

test/golden/oneof.yaml.out

@@ -358,7 +358,7 @@ import Test.Response
 
 
 data ListPackagesResponse
-    = ListPackagesResponse200 Packages 
+    = ListPackagesResponse200 Packages
     deriving (Show)
 
 instance Control.Exception.Exception ListPackagesResponse
@@ -405,7 +405,7 @@ import Test.Response
 
 
 data ListPackages2Response
-    = ListPackages2Response200 Inline 
+    = ListPackages2Response200 Inline
     deriving (Show)
 
 instance Control.Exception.Exception ListPackages2Response
@@ -452,7 +452,7 @@ import Test.Response
 
 
 data ListPackages3Response
-    = ListPackages3Response200 Inline2 
+    = ListPackages3Response200 Inline2
     deriving (Show)
 
 instance Control.Exception.Exception ListPackages3Response

test/golden/petstore.yaml.out

@@ -361,8 +361,8 @@ import Test.Response
 
 
 data CreatePetsResponse
-    = CreatePetsResponse201 
-    | CreatePetsDefaultResponse Network.HTTP.Types.Status Error 
+    = CreatePetsResponse201
+    | CreatePetsDefaultResponse Network.HTTP.Types.Status Error
     deriving (Show)
 
 instance Control.Exception.Exception CreatePetsResponse
@@ -413,7 +413,7 @@ import Test.Response
 
 data ListPetsResponse
     = ListPetsResponse200 Pets (Data.Maybe.Maybe (Data.Text.Text))
-    | ListPetsDefaultResponse Network.HTTP.Types.Status Error 
+    | ListPetsDefaultResponse Network.HTTP.Types.Status Error
     deriving (Show)
 
 instance Control.Exception.Exception ListPetsResponse
@@ -463,8 +463,8 @@ import Test.Response
 
 
 data ShowPetByIdResponse
-    = ShowPetByIdResponse200 Pet 
-    | ShowPetByIdDefaultResponse Network.HTTP.Types.Status Error 
+    = ShowPetByIdResponse200 Pet
+    | ShowPetByIdDefaultResponse Network.HTTP.Types.Status Error
     deriving (Show)
 
 instance Control.Exception.Exception ShowPetByIdResponse

test/golden/test1.yaml.out

@@ -401,7 +401,7 @@ instance Data.Aeson.FromJSON CreateUserResponseBody200 where
             <$> o Data.Aeson..:? "name"
 
 data CreateUserResponse
-    = CreateUserResponse200 CreateUserResponseBody200 
+    = CreateUserResponse200 CreateUserResponseBody200
     deriving (Show)
 
 instance Control.Exception.Exception CreateUserResponse
@@ -448,7 +448,7 @@ import Test.Response
 
 
 data GetUserResponse
-    = GetUserResponse200 Vehicle 
+    = GetUserResponse200 Vehicle
     deriving (Show)
 
 instance Control.Exception.Exception GetUserResponse