Haskell-OpenAPI-Code-Generator · joel-bach · Mar 30, 2024 · Mar 30, 2024
diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
@@ -24,6 +24,7 @@ jobs:
           - .#checks.x86_64-linux.testSystem1
           - .#checks.x86_64-linux.testSystem2
           - .#checks.x86_64-linux.testSystem3
+          - .#checks.x86_64-linux.testExample
     steps:
     - uses: actions/[email protected]
     - uses: cachix/install-nix-action@v20

diff --git a/README.md b/README.md
@@ -72,22 +72,9 @@ The following features are not supported
 - `xml`
 
 ## Development
-Re-generate the code found in the [example](./example/) directory if you made changes to the output generator.
-You can do this using the [example-configuration.yml](./example-configuration.yml):
 
-``` bash
-openapi3-code-generator-exe --configuration example-configuration.yml
-```
-
-Also make sure that the tests there run fine:
-
-``` bash
-cd example
-stack test
-```
-
-Also adapt golden tests:
+Make sure to update the example and the golden tests:
 
 ``` bash
-./update_golden.sh
+./update_golden_and_example.sh
 ```
diff --git a/example-configuration.yml b/example-configuration.yml
diff --git a/example/generatedCode/default.nix b/example/generatedCode/default.nix
@@ -0,0 +1,14 @@
+{ mkDerivation, aeson, base, bytestring, ghc-prim, http-client
+, http-conduit, http-types, lib, mtl, scientific, text, time
+, transformers, unordered-containers, vector
+}:
+mkDerivation {
+  pname = "openapi";
+  version = "0.1.0.0";
+  src = ./.;
+  libraryHaskellDepends = [
+    aeson base bytestring ghc-prim http-client http-conduit http-types
+    mtl scientific text time transformers unordered-containers vector
+  ];
+  license = "unknown";
+}
diff --git a/example/generatedCode/openapi.cabal b/example/generatedCode/openapi.cabal
diff --git a/example/generatedCode/src/OpenAPI.hs b/example/generatedCode/src/OpenAPI.hs
diff --git a/example/generatedCode/src/OpenAPI/Common.hs b/example/generatedCode/src/OpenAPI/Common.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
@@ -14,12 +15,13 @@ module OpenAPI.Common
     doBodyCallWithConfigurationM,
     runWithConfiguration,
     textToByte,
+    byteToText,
     stringifyModel,
     anonymousSecurityScheme,
+    jsonObjectToList,
     Configuration (..),
     SecurityScheme,
     MonadHTTP (..),
-    StringifyModel,
     JsonByteString (..),
     JsonDateTime (..),
     RequestBodyEncoding (..),
@@ -35,25 +37,35 @@ import qualified Control.Monad.Reader as MR
 import qualified Control.Monad.Trans.Class as MT
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Encoding as Encoding
+import Data.Aeson.Text (encodeToTextBuilder)
 import qualified Data.Bifunctor as BF
-import qualified Data.ByteString.Char8 as B8
-import qualified Data.ByteString.Lazy.Char8 as LB8
-import qualified Data.HashMap.Strict as HMap
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Maybe as Maybe
 import qualified Data.Scientific as Scientific
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
+import Data.Text.Encoding.Error (lenientDecode)
+import Data.Text.Lazy (toStrict)
+import Data.Text.Lazy.Builder (toLazyText)
 import qualified Data.Time.LocalTime as Time
 import qualified Data.Vector as Vector
 import qualified Network.HTTP.Client as HC
 import qualified Network.HTTP.Simple as HS
 import qualified Network.HTTP.Types as HT
 
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as KeyMap
+#else
+import qualified Data.HashMap.Strict as HMap
+#endif
+
 -- | Abstracts the usage of 'Network.HTTP.Simple.httpBS' away,
 --  so that it can be used for testing
 class Monad m => MonadHTTP m where
-  httpBS :: HS.Request -> m (HS.Response B8.ByteString)
+  httpBS :: HS.Request -> m (HS.Response BS.ByteString)
 
 -- | This instance is the default instance used for production code
 instance MonadHTTP IO where
@@ -154,7 +166,7 @@ doCallWithConfiguration ::
   -- | Query parameters
   [QueryParameter] ->
   -- | The raw response from the server
-  m (HS.Response B8.ByteString)
+  m (HS.Response BS.ByteString)
 doCallWithConfiguration config method path queryParams =
   httpBS $ createBaseRequest config method path queryParams
 
@@ -165,7 +177,7 @@ doCallWithConfigurationM ::
   Text ->
   Text ->
   [QueryParameter] ->
-  ClientT m (HS.Response B8.ByteString)
+  ClientT m (HS.Response BS.ByteString)
 doCallWithConfigurationM method path queryParams = do
   config <- MR.ask
   MT.lift $ doCallWithConfiguration config method path queryParams
@@ -188,7 +200,7 @@ doBodyCallWithConfiguration ::
   -- | JSON or form data deepobjects
   RequestBodyEncoding ->
   -- | The raw response from the server
-  m (HS.Response B8.ByteString)
+  m (HS.Response BS.ByteString)
 doBodyCallWithConfiguration config method path queryParams Nothing _ = doCallWithConfiguration config method path queryParams
 doBodyCallWithConfiguration config method path queryParams (Just body) RequestBodyEncodingJSON =
   httpBS $ HS.setRequestMethod (textToByte method) $ HS.setRequestBodyJSON body baseRequest
@@ -209,7 +221,7 @@ doBodyCallWithConfigurationM ::
   [QueryParameter] ->
   Maybe body ->
   RequestBodyEncoding ->
-  ClientT m (HS.Response B8.ByteString)
+  ClientT m (HS.Response BS.ByteString)
 doBodyCallWithConfigurationM method path queryParams body encoding = do
   config <- MR.ask
   MT.lift $ doBodyCallWithConfiguration config method path queryParams body encoding
@@ -232,13 +244,13 @@ createBaseRequest config method path queryParams =
       HS.setRequestMethod (textToByte method) $
         HS.setRequestQueryString query $
           HS.setRequestPath
-            (B8.pack (T.unpack $ byteToText basePathModifier <> path))
+            (textToByte $ basePathModifier <> path)
             baseRequest
   where
     baseRequest = parseURL $ configBaseURL config
-    basePath = HC.path baseRequest
+    basePath = byteToText $ HC.path baseRequest
     basePathModifier =
-      if basePath == B8.pack "/" && T.isPrefixOf "/" path
+      if basePath == "/" && T.isPrefixOf "/" path
         then ""
         else basePath
     -- filters all maybe
@@ -249,17 +261,19 @@ createBaseRequest config method path queryParams =
         then HS.addRequestHeader HT.hUserAgent $ textToByte userAgent
         else id
 
-serializeQueryParams :: [QueryParameter] -> [(B8.ByteString, B8.ByteString)]
+serializeQueryParams :: [QueryParameter] -> [(BS.ByteString, BS.ByteString)]
 serializeQueryParams = (>>= serializeQueryParam)
 
-serializeQueryParam :: QueryParameter -> [(B8.ByteString, B8.ByteString)]
+serializeQueryParam :: QueryParameter -> [(BS.ByteString, BS.ByteString)]
 serializeQueryParam QueryParameter {..} =
-  let concatValues :: B8.ByteString -> [(Maybe Text, B8.ByteString)] -> [(Text, B8.ByteString)]
+  let concatValues :: BS.ByteString -> [(Maybe Text, BS.ByteString)] -> [(Text, BS.ByteString)]
       concatValues joinWith =
         if queryParamExplode
           then fmap (BF.first $ Maybe.fromMaybe queryParamName)
           else
-            pure . (queryParamName,) . B8.intercalate joinWith
+            pure
+              . (queryParamName,)
+              . BS.intercalate joinWith
               . fmap
                 ( \case
                     (Nothing, value) -> value
@@ -277,29 +291,29 @@ serializeQueryParam QueryParameter {..} =
           )
             $ jsonToFormDataFlat Nothing value
 
-encodeStrict :: Aeson.ToJSON a => a -> B8.ByteString
-encodeStrict = LB8.toStrict . Aeson.encode
+encodeStrict :: Aeson.ToJSON a => a -> BS.ByteString
+encodeStrict = LBS.toStrict . Aeson.encode
 
-jsonToFormDataFlat :: Maybe Text -> Aeson.Value -> [(Maybe Text, B8.ByteString)]
+jsonToFormDataFlat :: Maybe Text -> Aeson.Value -> [(Maybe Text, BS.ByteString)]
 jsonToFormDataFlat _ Aeson.Null = []
 jsonToFormDataFlat name (Aeson.Number a) = [(name, encodeStrict a)]
 jsonToFormDataFlat name (Aeson.String a) = [(name, textToByte a)]
 jsonToFormDataFlat name (Aeson.Bool a) = [(name, encodeStrict a)]
-jsonToFormDataFlat _ (Aeson.Object object) = HMap.toList object >>= uncurry jsonToFormDataFlat . BF.first Just
+jsonToFormDataFlat _ (Aeson.Object object) = jsonObjectToList object >>= uncurry jsonToFormDataFlat . BF.first Just
 jsonToFormDataFlat name (Aeson.Array vector) = Vector.toList vector >>= jsonToFormDataFlat name
 
 -- | creates form data bytestring array
-createFormData :: (Aeson.ToJSON a) => a -> [(B8.ByteString, B8.ByteString)]
+createFormData :: (Aeson.ToJSON a) => a -> [(BS.ByteString, BS.ByteString)]
 createFormData body =
   let formData = jsonToFormData $ Aeson.toJSON body
    in fmap (BF.bimap textToByte textToByte) formData
 
--- | Convert a 'B8.ByteString' to 'Text'
-byteToText :: B8.ByteString -> Text
-byteToText = TE.decodeUtf8
+-- | Convert a 'BS.ByteString' to 'Text'
+byteToText :: BS.ByteString -> Text
+byteToText = TE.decodeUtf8With lenientDecode
 
--- | Convert 'Text' a to 'B8.ByteString'
-textToByte :: Text -> B8.ByteString
+-- | Convert 'Text' a to 'BS.ByteString'
+textToByte :: Text -> BS.ByteString
 textToByte = TE.encodeUtf8
 
 parseURL :: Text -> HS.Request
@@ -320,43 +334,26 @@ jsonToFormDataPrefixed prefix (Aeson.Bool False) = [(prefix, "false")]
 jsonToFormDataPrefixed _ Aeson.Null = []
 jsonToFormDataPrefixed prefix (Aeson.String a) = [(prefix, a)]
 jsonToFormDataPrefixed "" (Aeson.Object object) =
-  HMap.toList object >>= uncurry jsonToFormDataPrefixed
+  jsonObjectToList object >>= uncurry jsonToFormDataPrefixed
 jsonToFormDataPrefixed prefix (Aeson.Object object) =
-  HMap.toList object >>= (\(x, y) -> jsonToFormDataPrefixed (prefix <> "[" <> x <> "]") y)
+  jsonObjectToList object >>= (\(x, y) -> jsonToFormDataPrefixed (prefix <> "[" <> x <> "]") y)
 jsonToFormDataPrefixed prefix (Aeson.Array vector) =
   Vector.toList vector >>= jsonToFormDataPrefixed (prefix <> "[]")
 
--- | This type class makes the code generation for URL parameters easier as it allows to stringify a value
+-- | This function makes the code generation for URL parameters easier as it allows to stringify a value
 --
 -- The 'Show' class is not sufficient as strings should not be stringified with quotes.
-class Show a => StringifyModel a where
-  -- | Stringifies a showable value
-  --
-  -- >>> stringifyModel "Test"
-  -- "Test"
-  --
-  -- >>> stringifyModel 123
-  -- "123"
-  stringifyModel :: a -> String
-
-instance StringifyModel String where
-  -- stringifyModel :: String -> String
-  stringifyModel = id
-
-instance StringifyModel Text where
-  -- stringifyModel :: Text -> String
-  stringifyModel = T.unpack
-
-instance {-# OVERLAPS #-} Show a => StringifyModel a where
-  -- stringifyModel :: Show a => a -> String
-  stringifyModel = show
-
--- | Wraps a 'B8.ByteString' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON'
-newtype JsonByteString = JsonByteString B8.ByteString
+stringifyModel :: Aeson.ToJSON a => a -> Text
+stringifyModel x = case Aeson.toJSON x of
+  Aeson.String s -> s
+  v -> toStrict $ toLazyText $ encodeToTextBuilder v
+
+-- | Wraps a 'BS.ByteString' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON'
+newtype JsonByteString = JsonByteString BS.ByteString
   deriving (Show, Eq, Ord)
 
 instance Aeson.ToJSON JsonByteString where
-  toJSON (JsonByteString s) = Aeson.toJSON $ B8.unpack s
+  toJSON (JsonByteString s) = Aeson.toJSON $ byteToText s
 
 instance Aeson.FromJSON JsonByteString where
   parseJSON (Aeson.String s) = pure $ JsonByteString $ textToByte s
@@ -391,3 +388,11 @@ instance Aeson.ToJSON a => Aeson.ToJSON (Nullable a) where
 instance Aeson.FromJSON a => Aeson.FromJSON (Nullable a) where
   parseJSON Aeson.Null = pure Null
   parseJSON x = NonNull <$> Aeson.parseJSON x
+
+#if MIN_VERSION_aeson(2,0,0)
+jsonObjectToList :: KeyMap.KeyMap v -> [(Text, v)]
+jsonObjectToList = fmap (BF.first Key.toText) . KeyMap.toList
+#else
+jsonObjectToList :: HMap.HashMap Text v -> [(Text, v)]
+jsonObjectToList = HMap.toList
+#endif
diff --git a/example/generatedCode/src/OpenAPI/Configuration.hs b/example/generatedCode/src/OpenAPI/Configuration.hs
@@ -6,16 +6,17 @@
 module OpenAPI.Configuration where
 
 import qualified Data.Text
+import qualified Data.Text as Data.Text.Internal
 import qualified GHC.Types 
 import qualified OpenAPI.Common
 
 -- | The default url specified by the OpenAPI specification
 -- 
 -- @https://petstore.swagger.io/v2@
-defaultURL = Data.Text.pack "https://petstore.swagger.io/v2"
+defaultURL = Data.Text.Internal.pack "https://petstore.swagger.io/v2"
 -- | The default application name used in the @User-Agent@ header which is based on the @info.title@ field of the specification
 -- 
 -- @Swagger Petstore@
-defaultApplicationName = Data.Text.pack "Swagger Petstore"
+defaultApplicationName = Data.Text.Internal.pack "Swagger Petstore"
 -- | The default configuration containing the 'defaultURL' and no authorization
 defaultConfiguration = OpenAPI.Common.Configuration defaultURL OpenAPI.Common.anonymousSecurityScheme GHC.Types.True defaultApplicationName
diff --git a/example/generatedCode/src/OpenAPI/Operations/AddPet.hs b/example/generatedCode/src/OpenAPI/Operations/AddPet.hs
@@ -17,15 +17,16 @@ import qualified Data.Aeson as Data.Aeson.Types
 import qualified Data.Aeson as Data.Aeson.Types.FromJSON
 import qualified Data.Aeson as Data.Aeson.Types.ToJSON
 import qualified Data.Aeson as Data.Aeson.Types.Internal
-import qualified Data.ByteString.Char8
-import qualified Data.ByteString.Char8 as Data.ByteString.Internal
+import qualified Data.ByteString
+import qualified Data.ByteString as Data.ByteString.Internal
+import qualified Data.ByteString as Data.ByteString.Internal.Type
 import qualified Data.Either
 import qualified Data.Foldable
 import qualified Data.Functor
 import qualified Data.Maybe
 import qualified Data.Scientific
 import qualified Data.Text
-import qualified Data.Text.Internal
+import qualified Data.Text as Data.Text.Internal
 import qualified Data.Time.Calendar as Data.Time.Calendar.Days
 import qualified Data.Time.LocalTime as Data.Time.LocalTime.Internal.ZonedTime
 import qualified Data.Vector
@@ -51,7 +52,7 @@ addPet :: forall m . OpenAPI.Common.MonadHTTP m => Pet -- ^ The request body to
   -> OpenAPI.Common.ClientT m (Network.HTTP.Client.Types.Response AddPetResponse) -- ^ Monadic computation which returns the result of the operation
 addPet body = GHC.Base.fmap (\response_0 -> GHC.Base.fmap (Data.Either.either AddPetResponseError GHC.Base.id GHC.Base.. (\response body -> if | (\status_1 -> Network.HTTP.Types.Status.statusCode status_1 GHC.Classes.== 200) (Network.HTTP.Client.Types.responseStatus response) -> Data.Either.Right AddPetResponse200
                                                                                                                                                | (\status_2 -> Network.HTTP.Types.Status.statusCode status_2 GHC.Classes.== 405) (Network.HTTP.Client.Types.responseStatus response) -> Data.Either.Right AddPetResponse405
-                                                                                                                                               | GHC.Base.otherwise -> Data.Either.Left "Missing default response type") response_0) response_0) (OpenAPI.Common.doBodyCallWithConfigurationM (Data.Text.toUpper GHC.Base.$ Data.Text.pack "POST") (Data.Text.pack "/pet") GHC.Base.mempty (GHC.Maybe.Just body) OpenAPI.Common.RequestBodyEncodingJSON)
+                                                                                                                                               | GHC.Base.otherwise -> Data.Either.Left "Missing default response type") response_0) response_0) (OpenAPI.Common.doBodyCallWithConfigurationM (Data.Text.toUpper GHC.Base.$ Data.Text.Internal.pack "POST") "/pet" GHC.Base.mempty (GHC.Maybe.Just body) OpenAPI.Common.RequestBodyEncodingJSON)
 -- | Represents a response of the operation 'addPet'.
 -- 
 -- The response constructor is chosen by the status code of the response. If no case matches (no specific case for the response code, no range case, no default case), 'AddPetResponseError' is used.
@@ -69,18 +70,18 @@ addPetWithConfiguration :: forall m . OpenAPI.Common.MonadHTTP m => OpenAPI.Comm
 addPetWithConfiguration config
                         body = GHC.Base.fmap (\response_3 -> GHC.Base.fmap (Data.Either.either AddPetResponseError GHC.Base.id GHC.Base.. (\response body -> if | (\status_4 -> Network.HTTP.Types.Status.statusCode status_4 GHC.Classes.== 200) (Network.HTTP.Client.Types.responseStatus response) -> Data.Either.Right AddPetResponse200
                                                                                                                                                                 | (\status_5 -> Network.HTTP.Types.Status.statusCode status_5 GHC.Classes.== 405) (Network.HTTP.Client.Types.responseStatus response) -> Data.Either.Right AddPetResponse405
-                                                                                                                                                                | GHC.Base.otherwise -> Data.Either.Left "Missing default response type") response_3) response_3) (OpenAPI.Common.doBodyCallWithConfiguration config (Data.Text.toUpper GHC.Base.$ Data.Text.pack "POST") (Data.Text.pack "/pet") GHC.Base.mempty (GHC.Maybe.Just body) OpenAPI.Common.RequestBodyEncodingJSON)
+                                                                                                                                                                | GHC.Base.otherwise -> Data.Either.Left "Missing default response type") response_3) response_3) (OpenAPI.Common.doBodyCallWithConfiguration config (Data.Text.toUpper GHC.Base.$ Data.Text.Internal.pack "POST") "/pet" GHC.Base.mempty (GHC.Maybe.Just body) OpenAPI.Common.RequestBodyEncodingJSON)
 -- | > POST /pet
 -- 
--- The same as 'addPet' but returns the raw 'Data.ByteString.Char8.ByteString'.
+-- The same as 'addPet' but returns the raw 'Data.ByteString.ByteString'.
 addPetRaw :: forall m . OpenAPI.Common.MonadHTTP m => Pet -- ^ The request body to send
-  -> OpenAPI.Common.ClientT m (Network.HTTP.Client.Types.Response Data.ByteString.Internal.ByteString) -- ^ Monadic computation which returns the result of the operation
-addPetRaw body = GHC.Base.id (OpenAPI.Common.doBodyCallWithConfigurationM (Data.Text.toUpper GHC.Base.$ Data.Text.pack "POST") (Data.Text.pack "/pet") GHC.Base.mempty (GHC.Maybe.Just body) OpenAPI.Common.RequestBodyEncodingJSON)
+  -> OpenAPI.Common.ClientT m (Network.HTTP.Client.Types.Response Data.ByteString.Internal.Type.ByteString) -- ^ Monadic computation which returns the result of the operation
+addPetRaw body = GHC.Base.id (OpenAPI.Common.doBodyCallWithConfigurationM (Data.Text.toUpper GHC.Base.$ Data.Text.Internal.pack "POST") "/pet" GHC.Base.mempty (GHC.Maybe.Just body) OpenAPI.Common.RequestBodyEncodingJSON)
 -- | > POST /pet
 -- 
--- The same as 'addPet' but accepts an explicit configuration and returns the raw 'Data.ByteString.Char8.ByteString'.
+-- The same as 'addPet' but accepts an explicit configuration and returns the raw 'Data.ByteString.ByteString'.
 addPetWithConfigurationRaw :: forall m . OpenAPI.Common.MonadHTTP m => OpenAPI.Common.Configuration -- ^ The configuration to use in the request
   -> Pet -- ^ The request body to send
-  -> m (Network.HTTP.Client.Types.Response Data.ByteString.Internal.ByteString) -- ^ Monadic computation which returns the result of the operation
+  -> m (Network.HTTP.Client.Types.Response Data.ByteString.Internal.Type.ByteString) -- ^ Monadic computation which returns the result of the operation
 addPetWithConfigurationRaw config
-                           body = GHC.Base.id (OpenAPI.Common.doBodyCallWithConfiguration config (Data.Text.toUpper GHC.Base.$ Data.Text.pack "POST") (Data.Text.pack "/pet") GHC.Base.mempty (GHC.Maybe.Just body) OpenAPI.Common.RequestBodyEncodingJSON)
+                           body = GHC.Base.id (OpenAPI.Common.doBodyCallWithConfiguration config (Data.Text.toUpper GHC.Base.$ Data.Text.Internal.pack "POST") "/pet" GHC.Base.mempty (GHC.Maybe.Just body) OpenAPI.Common.RequestBodyEncodingJSON)