[haskell-http-client] add ability to choose additional characters in querystring which should not be encoded (e.g. "+" or ":") (fixes #3459) (#10424)

Author: jonschoning

CI/.drone.yml

@@ -48,7 +48,7 @@ steps:
   - dune build --build-dir=./_build
 # test haskell client
 - name: haskell-client-test
-  image: haskell:8.6.5
+  image: haskell:8.10.4
   commands:
   - (cd samples/client/petstore/haskell-http-client/ && stack --allow-different-user --install-ghc --no-haddock-deps haddock --fast && stack --allow-different-user test --fast)
 # test erlang client and server

bin/configs/haskell-http-client.yaml

@@ -2,3 +2,5 @@ generatorName: haskell-http-client
 outputDir: samples/client/petstore/haskell-http-client
 inputSpec: modules/openapi-generator/src/test/resources/2_0/petstore-with-fake-endpoints-models-for-testing.yaml
 templateDir: modules/openapi-generator/src/main/resources/haskell-http-client
+additionalProperties:
+    queryExtraUnreserved: ''

docs/generators/haskell-http-client.md

@@ -30,6 +30,7 @@ These options may be applied as additional-properties (cli) or configOptions (pl
 |legacyDiscriminatorBehavior|Set to false for generators with better support for discriminators. (Python, Java, Go, PowerShell, C#have this enabled by default).|<dl><dt>**true**</dt><dd>The mapping in the discriminator includes descendent schemas that allOf inherit from self and the discriminator mapping schemas in the OAS document.</dd><dt>**false**</dt><dd>The mapping in the discriminator includes any descendent schemas that allOf inherit from self, any oneOf schemas, any anyOf schemas, any x-discriminator-values, and the discriminator mapping schemas in the OAS document AND Codegen validates that oneOf and anyOf schemas contain the required discriminator and throws an error if the discriminator is missing.</dd></dl>|true|
 |modelDeriving|Additional classes to include in the deriving() clause of Models| |null|
 |prependFormOrBodyParameters|Add form or body parameters to the beginning of the parameter list.| |false|
+|queryExtraUnreserved|Configures additional querystring characters which must not be URI encoded, e.g. '+' or ':'| |null|
 |requestType|Set the name of the type used to generate requests| |null|
 |sortModelPropertiesByRequiredFlag|Sort model properties to place required parameters before optional parameters.| |true|
 |sortParamsByRequiredFlag|Sort method arguments to place required parameters before optional parameters.| |true|

modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellHttpClientCodegen.java

@@ -51,6 +51,7 @@ public class HaskellHttpClientCodegen extends DefaultCodegen implements CodegenC
     protected String defaultDateFormat = "%Y-%m-%d";
     protected String defaultCabalVersion = "0.1.0.0";
     protected String modulePath = null;
+    protected String defaultQueryExtraUnreserved = null;
 
     protected Boolean useKatip = true;
     protected Boolean allowNonUniqueOperationIds = false;
@@ -74,6 +75,7 @@ public class HaskellHttpClientCodegen extends DefaultCodegen implements CodegenC
     public static final String PROP_GENERATE_MODEL_CONSTRUCTORS = "generateModelConstructors";
     public static final String PROP_INLINE_MIME_TYPES = "inlineMimeTypes";
     public static final String PROP_MODEL_DERIVING = "modelDeriving";
+    public static final String PROP_QUERY_EXTRA_UNRESERVED = "queryExtraUnreserved";
     public static final String PROP_REQUEST_TYPE = "requestType";
     public static final String PROP_STRICT_FIELDS = "strictFields";
     public static final String PROP_USE_KATIP = "useKatip";
@@ -125,6 +127,7 @@ public class HaskellHttpClientCodegen extends DefaultCodegen implements CodegenC
     static final String X_MEDIA_IS_JSON = "x-mediaIsJson";
     static final String X_MEDIA_IS_WILDCARD = "x-mediaIsWildcard";
     static final String X_STRICT_FIELDS = "x-strictFields";
+    static final String X_PROP_QUERY_EXTRA_UNRESERVED = "x-queryExtraUnreserved";
     static final String X_ALL_UNIQUE_IMPORT_PATHS = "x-allUniqueImportPaths";
     static final String X_USE_KATIP = "x-useKatip";
     static final String X_ALLOW_NONUNIQUE_OPERATION_IDS = "x-allowNonUniqueOperationIds";
@@ -308,6 +311,7 @@ public HaskellHttpClientCodegen() {
         cliOptions.add(CliOption.newString(PROP_DATETIME_FORMAT, "format string used to parse/render a datetime"));
         cliOptions.add(CliOption.newString(PROP_DATETIME_PARSE_FORMAT, "overrides the format string used to parse a datetime"));
         cliOptions.add(CliOption.newString(PROP_DATE_FORMAT, "format string used to parse/render a date").defaultValue(defaultDateFormat));
+        cliOptions.add(CliOption.newString(PROP_QUERY_EXTRA_UNRESERVED, "Configures additional querystring characters which must not be URI encoded, e.g. '+' or ':'"));
 
         cliOptions.add(CliOption.newString(PROP_CUSTOM_TEST_INSTANCE_MODULE, "test module used to provide typeclass instances for types not known by the generator"));
 
@@ -371,6 +375,10 @@ public void setCabalVersion(String value) {
         setStringProp(PROP_CABAL_VERSION, value);
     }
 
+    public void setQueryExtraUnreserved(String value) {
+        additionalProperties.put(X_PROP_QUERY_EXTRA_UNRESERVED, value);
+    }
+
     public void setBaseModule(String value) {
         setStringProp(PROP_BASE_MODULE, value);
     }
@@ -505,6 +513,11 @@ public void processOpts() {
         } else {
             setCabalVersion(defaultCabalVersion);
         }
+        if (additionalProperties.containsKey(PROP_QUERY_EXTRA_UNRESERVED)) {
+            setQueryExtraUnreserved(additionalProperties.get(PROP_QUERY_EXTRA_UNRESERVED).toString());
+        } else {
+            setQueryExtraUnreserved(defaultQueryExtraUnreserved);
+        }
         if (additionalProperties.containsKey(PROP_BASE_MODULE)) {
             setBaseModule(additionalProperties.get(PROP_BASE_MODULE).toString());
         }

modules/openapi-generator/src/main/resources/haskell-http-client/Client.mustache

@@ -23,6 +23,7 @@ import qualified Control.Exception.Safe as E
 import qualified Control.Monad.IO.Class as P
 import qualified Control.Monad as P
 import qualified Data.Aeson.Types as A
+import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Lazy.Char8 as BCL
@@ -170,13 +171,18 @@ _toInitRequest config req0  =
         (configValidateAuthMethods config && (not . null . rAuthTypes) req1)
         (E.throw $ AuthMethodException $ "AuthMethod not configured: " <> (show . head . rAuthTypes) req1)
     let req2 = req1 & _setContentTypeHeader & _setAcceptHeader
-        reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders (rParams req2)
-        reqQuery = NH.renderQuery True (paramsQuery (rParams req2))
-        pReq = parsedReq { NH.method = (rMethod req2)
+        params = rParams req2
+        reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders params
+        reqQuery = let query = paramsQuery params
+                       queryExtraUnreserved = configQueryExtraUnreserved config
+                   in if B.null queryExtraUnreserved
+                        then NH.renderQuery True query
+                        else NH.renderQueryPartialEscape True (toPartialEscapeQuery queryExtraUnreserved query)
+        pReq = parsedReq { NH.method = rMethod req2
                         , NH.requestHeaders = reqHeaders
                         , NH.queryString = reqQuery
                         }
-    outReq <- case paramsBody (rParams req2) of
+    outReq <- case paramsBody params of
         ParamBodyNone -> pure (pReq { NH.requestBody = mempty })
         ParamBodyB bs -> pure (pReq { NH.requestBody = NH.RequestBodyBS bs })
         ParamBodyBL bl -> pure (pReq { NH.requestBody = NH.RequestBodyLBS bl })

modules/openapi-generator/src/main/resources/haskell-http-client/Core.mustache

@@ -58,7 +58,7 @@ import Data.Function ((&))
 import Data.Foldable(foldlM)
 import Data.Monoid ((<>))
 import Data.Text (Text)
-import Prelude (($), (.), (<$>), (<*>), Maybe(..), Bool(..), Char, String, fmap, mempty, pure, return, show, IO, Monad, Functor)
+import Prelude (($), (.), (&&), (<$>), (<*>), Maybe(..), Bool(..), Char, String, fmap, mempty, pure, return, show, IO, Monad, Functor, maybe)
 
 -- * {{configType}}
 
@@ -70,6 +70,7 @@ data {{configType}} = {{configType}}
   , configLogContext :: LogContext -- ^ Configures the logger
   , configAuthMethods :: [AnyAuthMethod] -- ^ List of configured auth methods
   , configValidateAuthMethods :: Bool -- ^ throw exceptions if auth methods are not configured
+  , configQueryExtraUnreserved :: B.ByteString -- ^ Configures additional querystring characters which must not be URI encoded, e.g. '+' or ':' 
   }
 
 -- | display the config
@@ -100,6 +101,7 @@ newConfig = do
         , configLogContext = logCxt
         , configAuthMethods = []
         , configValidateAuthMethods = True
+        , configQueryExtraUnreserved = "{{x-queryExtraUnreserved}}"
         }
 
 -- | updates config use AuthMethod on matching requests
@@ -327,6 +329,16 @@ toQuery :: WH.ToHttpApiData a => (BC.ByteString, Maybe a) -> [NH.QueryItem]
 toQuery x = [(fmap . fmap) toQueryParam x]
   where toQueryParam = T.encodeUtf8 . WH.toQueryParam
 
+toPartialEscapeQuery :: B.ByteString -> NH.Query -> NH.PartialEscapeQuery
+toPartialEscapeQuery extraUnreserved query = fmap (\(k, v) -> (k, maybe [] go v)) query
+  where go :: B.ByteString -> [NH.EscapeItem]
+        go v = v & B.groupBy (\a b -> a `B.notElem` extraUnreserved && b `B.notElem` extraUnreserved)
+                 & fmap (\xs -> if B.null xs then NH.QN xs
+                                  else if B.head xs `B.elem` extraUnreserved
+                                          then NH.QN xs -- Not Encoded
+                                          else NH.QE xs -- Encoded
+                        )
+
 -- *** OpenAPI `CollectionFormat` Utils
 
 -- | Determines the format of the array if type array is used.

modules/openapi-generator/src/main/resources/haskell-http-client/README.mustache

@@ -55,7 +55,7 @@ These options allow some customization of the code generation process.
 **haskell-http-client additional properties:**
 
 | OPTION                          | DESCRIPTION                                                                                                                   | DEFAULT  | ACTUAL                                |
-| ------------------------------- | ----------------------------------------------------------------------------------------------------------------------------- | -------- | ------------------------------------- |
+|---------------------------------|-------------------------------------------------------------------------------------------------------------------------------|----------|---------------------------------------|
 | allowFromJsonNulls              | allow JSON Null during model decoding from JSON                                                                               | true     | {{{allowFromJsonNulls}}}              |
 | allowNonUniqueOperationIds      | allow *different* API modules to contain the same operationId. Each API must be imported qualified                            | false    | {{{x-allowNonUniqueOperationIds}}}    |
 | allowToJsonNulls                | allow emitting JSON Null during model encoding to JSON                                                                        | false    | {{{allowToJsonNulls}}}                |
@@ -76,6 +76,7 @@ These options allow some customization of the code generation process.
 | requestType                     | Set the name of the type used to generate requests                                                                            |          | {{{requestType}}}                     |
 | strictFields                    | Add strictness annotations to all model fields                                                                                | true     | {{{x-strictFields}}}                  |
 | useKatip                        | Sets the default value for the UseKatip cabal flag. If true, the katip package provides logging instead of monad-logger       | true     | {{{x-useKatip}}}                      |
+| queryExtraUnreserved            | Configures additional querystring characters which must not be URI encoded, e.g. '+' or ':'                                   |          | {{{x-queryExtraUnreserved}}}          |
 
 [1]: https://www.stackage.org/haddock/lts-9.0/iso8601-time-0.1.4/Data-Time-ISO8601.html#v:formatISO8601Millis
 

modules/openapi-generator/src/main/resources/haskell-http-client/stack.mustache

@@ -1,4 +1,4 @@
-resolver: lts-18.10
+resolver: lts-18.6
 build:
   haddock-arguments:
     haddock-args:

samples/client/petstore/haskell-http-client/README.md

@@ -55,7 +55,7 @@ These options allow some customization of the code generation process.
 **haskell-http-client additional properties:**
 
 | OPTION                          | DESCRIPTION                                                                                                                   | DEFAULT  | ACTUAL                                |
-| ------------------------------- | ----------------------------------------------------------------------------------------------------------------------------- | -------- | ------------------------------------- |
+|---------------------------------|-------------------------------------------------------------------------------------------------------------------------------|----------|---------------------------------------|
 | allowFromJsonNulls              | allow JSON Null during model decoding from JSON                                                                               | true     | true              |
 | allowNonUniqueOperationIds      | allow *different* API modules to contain the same operationId. Each API must be imported qualified                            | false    | false    |
 | allowToJsonNulls                | allow emitting JSON Null during model encoding to JSON                                                                        | false    | false                |
@@ -76,6 +76,7 @@ These options allow some customization of the code generation process.
 | requestType                     | Set the name of the type used to generate requests                                                                            |          | OpenAPIPetstoreRequest                     |
 | strictFields                    | Add strictness annotations to all model fields                                                                                | true     | true                  |
 | useKatip                        | Sets the default value for the UseKatip cabal flag. If true, the katip package provides logging instead of monad-logger       | true     | true                      |
+| queryExtraUnreserved            | Configures additional querystring characters which must not be URI encoded, e.g. '+' or ':'                                   |          |           |
 
 [1]: https://www.stackage.org/haddock/lts-9.0/iso8601-time-0.1.4/Data-Time-ISO8601.html#v:formatISO8601Millis