Support schema-less response bodies

src/Tie/Codegen/Response.hs

@@ -45,7 +45,7 @@ codegenResponses resolver Operation {..} = do
   let responseBodyType Response {responseContent}
         -- We treat JSON responses specially
         | Just jsonContent <- lookup "application/json" responseContent =
-          [codegenFieldType jsonContent]
+          [maybe "Data.Aeson.Value" codegenFieldType jsonContent]
         -- Everything else we use a Network.Wai.StreamingBody type
         | not (null responseContent) =
           ["Network.Wai.StreamingBody"]
@@ -56,6 +56,21 @@ codegenResponses resolver Operation {..} = do
       responseHeaderTypes Response {headers} =
         map codegenHeaderSchema headers
 
+      -- Since we insert StreamingBody for mime types that we don't know,
+      -- we have to generate Show instances for those types!
+      canDeriveStockShowInstanceForResponse Response {responseContent}
+        | Just _ <- lookup "application/json" responseContent =
+          True
+        | not (null responseContent) =
+          False
+        | otherwise =
+          True
+
+      requiresCustomShowInstance =
+        not $ all
+          canDeriveStockShowInstanceForResponse
+          (maybeToList defaultResponse ++ map snd responses)
+
       decl =
         "data" <+> toApiResponseTypeName name <> PP.line
           <> PP.indent
@@ -78,15 +93,29 @@ codegenResponses resolver Operation {..} = do
                        | Just response <- [defaultResponse]
                      ]
                   ++ [ "deriving" <+> "(" <> "Show" <> ")"
+                       | not requiresCustomShowInstance
                      ]
             )
+
       instances =
         codegenToResponses name responses defaultResponse
 
+      showInstance =
+        "instance" <+> "Show" <+> toApiResponseTypeName name <+> "where" <> PP.line
+          <> PP.indent
+            4
+            ( "show" <+> "_" <+> "=" <+> "\"" <> toApiResponseTypeName name <+> "{}" <> "\""
+            )
+
       exceptionInstance =
         "instance" <+> "Control.Exception.Exception" <+> toApiResponseTypeName name
 
-  pure (PP.vsep [decl, mempty, exceptionInstance, mempty, instances])
+  pure
+    ( PP.vsep $
+        intersperse mempty $
+          [decl, exceptionInstance, instances]
+            ++ [showInstance | requiresCustomShowInstance]
+    )
 
 codegenToResponses :: Name -> [(Int, Response)] -> Maybe Response -> Doc ann
 codegenToResponses operationName responses defaultResponse =

src/Tie/Operation.hs

@@ -85,7 +85,7 @@ data Header = Header
 data Response = Response
   { description :: Text,
     -- | Response contents per media type
-    responseContent :: [(MediaType, Named Type)],
+    responseContent :: [(MediaType, Maybe (Named Type))],
     -- | Response headers
     headers :: [Header]
   }
@@ -178,11 +178,11 @@ operationSchemaDependencies getDependencies Operation {..} =
       ++ map getDependencies (pathDependencies path)
       ++ [ getDependencies contentSchema
            | Just Response {responseContent} <- [defaultResponse],
-             (_mediaType, contentSchema) <- responseContent
+             (_mediaType, Just contentSchema) <- responseContent
          ]
       ++ [ getDependencies contentSchema
            | (_, Response {responseContent}) <- responses,
-             (_mediaType, contentSchema) <- responseContent
+             (_mediaType, Just contentSchema) <- responseContent
          ]
       ++ [ getDependencies schema
            | Param {schema} <- queryParams
@@ -333,16 +333,23 @@ responseToResponse resolver errors@Errors {..} response@OpenApi.Response {..} =
         headers
       }
 
-responseMediaTypeObject :: Monad m => Resolver m -> Errors m -> OpenApi.Response -> m [(MediaType, Named Type)]
+responseMediaTypeObject ::
+  Monad m =>
+  Resolver m ->
+  Errors m ->
+  OpenApi.Response ->
+  m [(MediaType, Maybe (Named Type))]
 responseMediaTypeObject resolver Errors {..} response =
   forM (InsOrd.toList (OpenApi._responseContent response)) $ \(mediaType, OpenApi.MediaTypeObject {..}) -> do
-    referencedSchema <-
-      whenNothing
-        _mediaTypeObjectSchema
-        requestBodyMissingSchema
-    type_ <-
-      schemaRefToType resolver referencedSchema
-    pure (mediaType, type_)
+    case _mediaTypeObjectSchema of
+      Nothing ->
+        -- A response with a body that is not described by a schema
+        -- e.g. when returning a text/csv
+        pure (mediaType, Nothing)
+      Just referencedSchema -> do
+        type_ <-
+          schemaRefToType resolver referencedSchema
+        pure (mediaType, Just type_)
 
 parsePath :: FilePath -> [PathSegment Text]
 parsePath path =
@@ -446,9 +453,13 @@ normalizeResponse :: Monad m => Name -> Response -> m (Response, [(Name, Type)])
 normalizeResponse name response@Response {..} = do
   (responseContent, inlineDefinitions) <- runWriterT $
     forM responseContent $ \(mediaType, schema) -> do
-      (normedType, inlineDefinitions) <- normalizeNamedType (pure name) schema
-      tell inlineDefinitions
-      pure (mediaType, normedType)
+      case schema of
+        Nothing ->
+          pure (mediaType, Nothing)
+        Just schema -> do
+          (normedType, inlineDefinitions) <- normalizeNamedType (pure name) schema
+          tell inlineDefinitions
+          pure (mediaType, Just normedType)
   pure (response {responseContent}, inlineDefinitions)
 
 normalizeRequestBody :: Monad m => Name -> RequestBody -> m (RequestBody, [(Name, Type)])

test/golden/csv.yaml

@@ -13,33 +13,18 @@ paths:
       operationId: test
       responses:
         '200':
-          description: Successful response
+          description: CSV response without schema
           content:
-            application/json:
-              schema:
-                $ref: "#/components/schemas/Test"              
-components:
-  schemas:
-openapi: "3.0.0"
-info:
-  version: 1.0.0
-  title: Scarf
-  license:
-    name: AllRightsReserved
-servers:
-  - url: https://scarf.sh/api/v1
-paths:
-  /test:
+            text/csv: {}
+  /test2:
     get:
       summary: test
-      operationId: test
+      operationId: test2
       responses:
         '200':
-          description: Successful response
+          description: JSON response without schema
           content:
-            text/csv:
-              schema:
-                $ref: "#/components/schemas/Test"              
+            application/json: {}
 components:
   schemas:
     Test: 

test/golden/csv.yaml.out

@@ -35,14 +35,18 @@ import Test.Response
 
 
 
-import Test.Schemas.Test
+
 
 import Test.Response.Test
+import Test.Response.Test2
 
 data Api m = Api {
     -- | test
     test ::
-        m TestResponse
+        m TestResponse,
+    -- | test
+    test2 ::
+        m Test2Response
 }
 
 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 +62,16 @@ application run api notFound request respond =
                 x ->
                     unsupportedMethod x
 
+        ["test2"] ->
+            case Network.Wai.requestMethod request of
+                "GET" ->
+                    run request (do
+                        response <- Control.Monad.Catch.handle pure (test2 api)
+                        Control.Monad.IO.Class.liftIO (respond $! (toResponse response))
+                    )
+                x ->
+                    unsupportedMethod x
+
         _ ->
             notFound request respond
     where
@@ -326,7 +340,7 @@ import qualified Network.HTTP.Types
 import qualified Network.Wai
 import qualified Web.HttpApiData
 
-import Test.Schemas.Test
+
 
 import Test.Response
 
@@ -334,15 +348,17 @@ import Test.Response
 
 data TestResponse
     = TestResponse200 Network.Wai.StreamingBody
-    deriving (Show)
 
 instance Control.Exception.Exception TestResponse
 
 instance ToResponse TestResponse where
     toResponse (TestResponse200 x) =
         Network.Wai.responseStream (toEnum 200) ([(Network.HTTP.Types.hContentType, "text/csv")]) x
+
+instance Show TestResponse where
+    show _ = "TestResponse {}"
 ---------------------
-Test/Schemas/Test.hs
+Test/Response/Test2.hs
 
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -350,7 +366,7 @@ Test/Schemas/Test.hs
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
-module Test.Schemas.Test where
+module Test.Response.Test2 where
 
 import qualified Control.Applicative
 import qualified Control.Exception
@@ -376,30 +392,19 @@ import qualified Web.HttpApiData
 
 
 
+import Test.Response
 
 
 
-
-newtype Test = Test
-    {
-        name :: (Data.Maybe.Maybe (Data.Text.Text))
-    }
+data Test2Response
+    = Test2Response200 Data.Aeson.Value
     deriving (Show)
 
-instance Data.Aeson.ToJSON Test where
-    toJSON Test {..} = Data.Aeson.object
-        [
-            "name" Data.Aeson..= name
-        ]
+instance Control.Exception.Exception Test2Response
 
-    toEncoding Test {..} = Data.Aeson.Encoding.pairs
-        ( Data.Aeson.Encoding.pair "name" (Data.Aeson.toEncoding name)
-        )
-
-instance Data.Aeson.FromJSON Test where
-    parseJSON = Data.Aeson.withObject "Test" $ \o ->
-        Test
-            <$> o Data.Aeson..:? "name"
+instance ToResponse Test2Response where
+    toResponse (Test2Response200 x) =
+        Network.Wai.responseBuilder (toEnum 200) ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
 ---------------------
 test.cabal
 
@@ -424,4 +429,4 @@ library
     Test.Request
     Test.Response
     Test.Response.Test
-    Test.Schemas.Test
+    Test.Response.Test2