[haskell][haskell-yesod] Fix special char replacements

[msakai]

Special character replacements in the haskell and the haskell-yesod generators are not working correctly, and this PR fixes the issue and some related issues.

The main problem is that those generators generate code that assumes the quotation mark prefixes, but the generated field names do not have the quotation mark prefixes. It seems that those generators try to usefixOperatorChars to perform special character replacements with quotation marks, but special characters have already been replaced in DefaultCodegen.fromModel() which does not insert quotation marks (c.f. #16161).

For example, the following spec resulted in the code that does not work properly.

openapi: 3.0.0
info:
  title: Test
  description: Test API
  version: 1.0.0
servers:
  - url: https://api.example.com/
    description: the server

paths:
  /hello:
    get:
      operationId: hello
      summary: "summary"
      description: "description."
      responses:
        "200":
          description: foo
          content:
            application/json:
              schema:
                $ref: '#/components/schemas/HelloResponse'

components:
  schemas:
    HelloResponse:
      type: object
      properties:
        "&id":
          type: string
          description: id
        text:
          type: string
          description: text
      required:
        - "&id"
        - text
      description: description

Generated code (Note that specialChars table contains entries like ("$", "'Dollar") and Dollar is prefixed with a quotation mark).:

...

-- | description
data HelloResponse = HelloResponse
  { helloResponseAmpersandid :: Text -- ^ id
  , helloResponseText :: Text -- ^ text
  } deriving (Show, Eq, Generic, Data)

instance FromJSON HelloResponse where
  parseJSON = genericParseJSON (removeFieldLabelPrefix True "helloResponse")
instance ToJSON HelloResponse where
  toJSON = genericToJSON (removeFieldLabelPrefix False "helloResponse")

...

-- | Remove a field label prefix during JSON parsing.
--   Also perform any replacements for special characters.
--   The @forParsing@ parameter is to distinguish between the cases in which we're using this
--   to power a @FromJSON@ or a @ToJSON@ instance. In the first case we're parsing, and we want
--   to replace special characters with their quoted equivalents (because we cannot have special
--   chars in identifier names), while we want to do vice versa when sending data instead.
removeFieldLabelPrefix :: Bool -> String -> Options
removeFieldLabelPrefix forParsing prefix =
  defaultOptions
    { omitNothingFields  = True
    , fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars
    }
  where
    replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
    specialChars =
      [ ("$", "'Dollar")
      , ("^", "'Caret")
      , ("|", "'Pipe")
      , ("=", "'Equal")
      , ("*", "'Star")
      , ("-", "'Dash")
      , ("&", "'Ampersand")
      , ("%", "'Percent")
      , ("#", "'Hash")
      , ("@", "'At")
      , ("!", "'Exclamation")
      , ("+", "'Plus")
      , (":", "'Colon")
      , (";", "'Semicolon")
      , (">", "'GreaterThan")
      , ("<", "'LessThan")
      , (".", "'Period")
      , ("_", "'Underscore")
      , ("?", "'Question_Mark")
      , (",", "'Comma")
      , ("'", "'Quote")
      , ("/", "'Slash")
      , ("(", "'Left_Parenthesis")
      , (")", "'Right_Parenthesis")
      , ("{", "'Left_Curly_Bracket")
      , ("}", "'Right_Curly_Bracket")
      , ("[", "'Left_Square_Bracket")
      , ("]", "'Right_Square_Bracket")
      , ("~", "'Tilde")
      , ("`", "'Backtick")
      , ("<=", "'Less_Than_Or_Equal_To")
      , (">=", "'Greater_Than_Or_Equal_To")
      , ("!=", "'Not_Equal")
      , ("<>", "'Not_Equal")
      , ("~=", "'Tilde_Equal")
      , ("\\", "'Back_Slash")
      , ("\"", "'Double_Quote")
      ]
    mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack
    replacer =
      if forParsing
        then flip T.replace
        else T.replace

There are two options to solve the problem:

1. use the conversion by fixOperatorChars instead of the conversion by DefaultCodegen.fromModel(), or
2. modify the generated code to be compatible with the conversion of DefaultCodegen.fromModel().

This PR chooses the latter option.

This PR also fixes two related problems:

1. There seems to be a misunderstanding about aeson's fieldLabelModifier in the original code. The current generated code uses forParsing parameter to switch conversion direction. But this is not necessary. fieldLabelModifier is always used to convert Haskell field names to JSON field names, whether at parse time or not. (Note that stripPrefix and uncapitalize do not take such parameters)

2. Change the order of replaceSpecialChars and stripPrefix. Because replaceSpecialChars can corrupt prefix if the prefix contains a replacement string of a special character as a substring. (Consider the following example spec)

openapi: 3.0.0
info:
  title: Test
  description: Test API
  version: 1.0.0
servers:
  - url: https://api.example.com/
    description: the server

paths:
  /hello:
    get:
      operationId: hello
      summary: "summary"
      description: "description."
      responses:
        "200":
          description: foo
          content:
            application/json:
              schema:
                $ref: '#/components/schemas/XAmpersand'

components:
  schemas:
    XAmpersand:
      type: object
      properties:
        id:
          type: string
          description: id
        text:
          type: string
          description: text
      required:
        - "&id"
        - text
      description: description

Generated code:

...

-- | description
data XAmpersand = XAmpersand
  { xAmpersandId :: Maybe Text -- ^ id
  , xAmpersandText :: Text -- ^ text
  } deriving (Show, Eq, Generic, Data)

instance FromJSON XAmpersand where
  parseJSON = genericParseJSON (removeFieldLabelPrefix True "xAmpersand")
instance ToJSON XAmpersand where
  toJSON = genericToJSON (removeFieldLabelPrefix False "xAmpersand")
instance ToSchema XAmpersand where
  declareNamedSchema = Swagger.genericDeclareNamedSchema
    $ Swagger.fromAesonOptions
    $ removeFieldLabelPrefix False "xAmpersand"

...

-- | Remove a field label prefix during JSON parsing.
--   Also perform any replacements for special characters.
--   The @forParsing@ parameter is to distinguish between the cases in which we're using this
--   to power a @FromJSON@ or a @ToJSON@ instance. In the first case we're parsing, and we want
--   to replace special characters with their quoted equivalents (because we cannot have special
--   chars in identifier names), while we want to do vice versa when sending data instead.
removeFieldLabelPrefix :: Bool -> String -> Options
removeFieldLabelPrefix forParsing prefix =
  defaultOptions
    { omitNothingFields  = True
    , fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars
    }
  where
    replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
    specialChars =
      [ ("$", "'Dollar")
      , ("^", "'Caret")
      , ("|", "'Pipe")
      , ("=", "'Equal")
      , ("*", "'Star")
      , ("-", "'Dash")
      , ("&", "'Ampersand")
      , ("%", "'Percent")
      , ("#", "'Hash")
      , ("@", "'At")
      , ("!", "'Exclamation")
      , ("+", "'Plus")
      , (":", "'Colon")
      , (";", "'Semicolon")
      , (">", "'GreaterThan")
      , ("<", "'LessThan")
      , (".", "'Period")
      , ("_", "'Underscore")
      , ("?", "'Question_Mark")
      , (",", "'Comma")
      , ("'", "'Quote")
      , ("/", "'Slash")
      , ("(", "'Left_Parenthesis")
      , (")", "'Right_Parenthesis")
      , ("{", "'Left_Curly_Bracket")
      , ("}", "'Right_Curly_Bracket")
      , ("[", "'Left_Square_Bracket")
      , ("]", "'Right_Square_Bracket")
      , ("~", "'Tilde")
      , ("`", "'Backtick")
      , ("<=", "'Less_Than_Or_Equal_To")
      , (">=", "'Greater_Than_Or_Equal_To")
      , ("!=", "'Not_Equal")
      , ("<>", "'Not_Equal")
      , ("~=", "'Tilde_Equal")
      , ("\\", "'Back_Slash")
      , ("\"", "'Double_Quote")
      ]
    mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack
    replacer =
      if forParsing
        then flip T.replace
        else T.replace

PR checklist

• Read the contribution guidelines.
• Pull Request title clearly describes the work in the pull request and Pull Request description provides details about how to validate the work. Missing information here may result in delayed response from the community.
• Run the following to build the project and update samples:

  ./mvnw clean package 
  ./bin/generate-samples.sh
  ./bin/utils/export_docs_generators.sh
  

  Commit all changed files.
  This is important, as CI jobs will verify all generator outputs of your HEAD commit as it would merge with master.
  These must match the expectations made by your contribution.
  You may regenerate an individual generator by passing the relevant config(s) as an argument to the script, for example ./bin/generate-samples.sh bin/configs/java*.
  For Windows users, please run the script in Git BASH.
• In case you are adding a new generator, run the following additional script :

  ./bin/utils/ensure-up-to-date
  

  Commit all changed files.
• File the PR against the correct branch: master (6.3.0) (minor release - breaking changes with fallbacks), 7.0.x (breaking changes without fallbacks)
• If your PR is targeting a particular programming language, @mention the technical committee members, so they are more likely to review the pull request.

cc: @f-f @Drezil

[f-f]

Sorry, I won't be able to review this - it's been years since my last contribution.

[wing328]

tested locally and the tests passed, e.g.

    returns 501 Not Implemented
  getUserLoginR
    returns 501 Not Implemented
  getUserLogoutR
    returns 501 Not Implemented
  putUserByTextR
    returns 501 Not Implemented

Finished in 0.0363 seconds
20 examples, 0 failures

open-api-petstore> Test suite open-api-petstore-test passed
Completed 2 action(s).
[INFO] ------------------------------------------------------------------------
[INFO] BUILD SUCCESS
[INFO] ------------------------------------------------------------------------
[INFO] Total time:  01:34 min
[INFO] Finished at: 2023-07-27T17:41:12+08:00
[INFO] ------------------------------------------------------------------------
[INFO] 3 goals, 3 executed
[INFO] 
[INFO] Publishing build scan...
[INFO] https://ge.openapi-generator.tech/s/bvp3varpiswjm

[msakai]

I tested the first example spec above with the following code:

module Main where

import qualified Data.Aeson as J
import qualified Data.ByteString.Lazy.Char8 as BL
import Test.Types

main :: IO ()
main = do
  let s = BL.pack "{\"&id\":\"foo\",\"text\":\"bar\"}"
  putStrLn (BL.unpack s)
  let val :: HelloResponse
      Just val = J.decode s
  print val
  print $ J.encode val
  print $ J.encode val == s

Result before applying the changes of this PR:

{"&id":"foo","text":"bar"}
test.hs: test.hs:12:7-50: Non-exhaustive patterns in Just val

Result after applying the changes of this PR:

{"&id":"foo","text":"bar"}
HelloResponse {helloResponseAmpersandid = "foo", helloResponseText = "bar"}
"{\"&id\":\"foo\",\"text\":\"bar\"}"
True

[wing328]

Thanks for sharing the test result.