[Haskell] Fix broken client/server compilation errors (#5097)

* Remove dead legacy code

* Update cosmetics according to Haskell standard practices

* Fix failing pattern matching for lookupEither

* Bump to latest dependencies without any breaking changes

* Remove duplicate instance declarations already existing in Servant.API.Verbs

* Fix double Java/Haskell escapement bug

* Re-generate Petstore sample client/server

modules/swagger-codegen/src/main/java/io/swagger/codegen/languages/HaskellServantCodegen.java

@@ -54,6 +54,12 @@ public HaskellServantCodegen() {
         specialCharReplacements.put(">", "GreaterThan");
         specialCharReplacements.put("<", "LessThan");
 
+        // backslash and double quote need double the escapement for both Java and Haskell
+        specialCharReplacements.remove("\\");
+        specialCharReplacements.remove("\"");
+        specialCharReplacements.put("\\\\", "Back_Slash");
+        specialCharReplacements.put("\\\"", "Double_Quote");
+
         // set the output folder here
         outputFolder = "generated-code/haskell-servant";
 

modules/swagger-codegen/src/main/resources/haskell-servant/API.mustache

@@ -1,65 +1,79 @@
-{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, FlexibleInstances, OverloadedStrings, ViewPatterns #-}
-{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, DeriveTraversable, FlexibleContexts, DeriveGeneric #-}
-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports -fcontext-stack={{contextStackLimit}} #-}
-module {{title}}.API (
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC
+-fno-warn-unused-binds -fno-warn-unused-imports -fcontext-stack=328 #-}
+
+module {{title}}.API
   -- * Client and Server
-  ServerConfig(..),
-  {{title}}Backend,
-  create{{title}}Client,
-  run{{title}}Server,
-  run{{title}}Client,
-  run{{title}}ClientWithManager,
-  {{title}}Client,
+  ( ServerConfig(..)
+  , {{title}}Backend
+  , create{{title}}Client
+  , run{{title}}Server
+  , run{{title}}Client
+  , run{{title}}ClientWithManager
+  , {{title}}Client
   -- ** Servant
-  {{title}}API,
+  , {{title}}API
   ) where
 
 import {{title}}.Types
 
+import Control.Monad.Except (ExceptT)
+import Control.Monad.IO.Class
 import Data.Aeson (Value)
 import Data.Coerce (coerce)
-import Servant.API
-import Servant (serve, ServantErr)
-import Web.HttpApiData
-import qualified Network.Wai.Handler.Warp as Warp
-import qualified Data.Text as T
-import Data.Text (Text)
-import Servant.Common.BaseUrl(BaseUrl(..))
-import Servant.Client (ServantError, client, Scheme(Http))
-import Data.Proxy (Proxy(..))
-import Control.Monad.IO.Class
 import Data.Function ((&))
-import GHC.Exts (IsString(..))
 import qualified Data.Map as Map
-import GHC.Generics (Generic)
 import Data.Monoid ((<>))
-import Servant.API.Verbs (Verb, StdMethod(..))
-import Control.Monad.Except (ExceptT)
-import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
+import Data.Proxy (Proxy(..))
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHC.Exts (IsString(..))
+import GHC.Generics (Generic)
+import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
 import Network.HTTP.Types.Method (methodOptions)
-
-instance ReflectMethod 'OPTIONS where
-  reflectMethod _ = methodOptions
+import qualified Network.Wai.Handler.Warp as Warp
+import Servant (ServantErr, serve)
+import Servant.API
+import Servant.API.Verbs (StdMethod(..), Verb)
+import Servant.Client (Scheme(Http), ServantError, client)
+import Servant.Common.BaseUrl (BaseUrl(..))
+import Web.HttpApiData
 
 
 {{#apiInfo}}{{#apis}}{{#operations}}{{#operation}}{{#hasFormParams}}
 data {{vendorExtensions.x-formName}} = {{vendorExtensions.x-formName}}
-    { {{#formParams}}{{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} :: {{dataType}}{{#hasMore}}
-    , {{/hasMore}}{{/formParams}}
-    } deriving (Show, Eq, Generic)
+  { {{#formParams}}{{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} :: {{dataType}}{{#hasMore}}
+  , {{/hasMore}}{{/formParams}}
+  } deriving (Show, Eq, Generic)
 
 instance FromFormUrlEncoded {{vendorExtensions.x-formName}} where
-    fromFormUrlEncoded inputs = {{vendorExtensions.x-formName}} <$> {{#formParams}} lookupEither "{{baseName}}" inputs{{#hasMore}} <*> {{/hasMore}}{{/formParams}}
+  fromFormUrlEncoded inputs = {{vendorExtensions.x-formName}} <$> {{#formParams}}lookupEither "{{baseName}}" inputs{{#hasMore}} <*> {{/hasMore}}{{/formParams}}
+
 instance ToFormUrlEncoded {{vendorExtensions.x-formName}} where
-    toFormUrlEncoded value = [{{#formParams}}("{{baseName}}", toQueryParam $ {{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} value){{#hasMore}}, {{/hasMore}}{{/formParams}}]
-{{/hasFormParams}}{{/operation}}{{/operations}}{{/apis}}{{/apiInfo}}
+  toFormUrlEncoded value =
+    [ {{#formParams}}("{{baseName}}", toQueryParam $ {{vendorExtensions.x-formPrefix}}{{vendorExtensions.x-formParamName}} value){{#hasMore}}
+    , {{/hasMore}}{{/formParams}}
+    ]{{/hasFormParams}}{{/operation}}{{/operations}}{{/apis}}{{/apiInfo}}
 
 -- For the form data code generation.
-lookupEither :: FromHttpApiData b => Text -> [(Text, Text)] -> Either Text b
+lookupEither :: FromHttpApiData b => Text -> [(Text, Text)] -> Either String b
 lookupEither key assocs =
   case lookup key assocs of
-    Nothing -> Left $ "Could not find parameter " <> key <> " in form data"
-    Just value -> parseQueryParam value
+    Nothing -> Left $ "Could not find parameter " <> (T.unpack key) <> " in form data"
+    Just value ->
+      case parseQueryParam value of
+        Left result -> Left $ T.unpack result
+        Right result -> Right $ result
 
 {{#apiInfo}}
 -- | Servant type-level API, generated from the Swagger spec for {{title}}.
@@ -70,54 +84,56 @@ type {{title}}API
 {{/apiInfo}}
 
 -- | Server or client configuration, specifying the host and port to query or serve on.
-data ServerConfig = ServerConfig {
-    configHost :: String,  -- ^ Hostname to serve on, e.g. "127.0.0.1"
-    configPort :: Int      -- ^ Port to serve on, e.g. 8080
+data ServerConfig = ServerConfig
+  { configHost :: String  -- ^ Hostname to serve on, e.g. "127.0.0.1"
+  , configPort :: Int      -- ^ Port to serve on, e.g. 8080
   } deriving (Eq, Ord, Show, Read)
 
 -- | List of elements parsed from a query.
-newtype QueryList (p :: CollectionFormat) a = QueryList { fromQueryList :: [a] }
-  deriving (Functor, Applicative, Monad, Foldable, Traversable)
+newtype QueryList (p :: CollectionFormat) a = QueryList
+  { fromQueryList :: [a]
+  } deriving (Functor, Applicative, Monad, Foldable, Traversable)
 
 -- | Formats in which a list can be encoded into a HTTP path.
-data CollectionFormat = CommaSeparated -- ^ CSV format for multiple parameters.
-                      | SpaceSeparated -- ^ Also called "SSV"
-                      | TabSeparated -- ^ Also called "TSV"
-                      | PipeSeparated -- ^ `value1|value2|value2`
-                      | MultiParamArray -- ^ Using multiple GET parameters, e.g. `foo=bar&foo=baz`. Only for GET params.
+data CollectionFormat
+  = CommaSeparated -- ^ CSV format for multiple parameters.
+  | SpaceSeparated -- ^ Also called "SSV"
+  | TabSeparated -- ^ Also called "TSV"
+  | PipeSeparated -- ^ `value1|value2|value2`
+  | MultiParamArray -- ^ Using multiple GET parameters, e.g. `foo=bar&foo=baz`. Only for GET params.
 
 instance FromHttpApiData a => FromHttpApiData (QueryList 'CommaSeparated a) where
-    parseQueryParam = parseSeparatedQueryList ','
+  parseQueryParam = parseSeparatedQueryList ','
 
 instance FromHttpApiData a => FromHttpApiData (QueryList 'TabSeparated a) where
-    parseQueryParam = parseSeparatedQueryList '\t'
+  parseQueryParam = parseSeparatedQueryList '\t'
 
 instance FromHttpApiData a => FromHttpApiData (QueryList 'SpaceSeparated a) where
-    parseQueryParam = parseSeparatedQueryList ' '
+  parseQueryParam = parseSeparatedQueryList ' '
 
 instance FromHttpApiData a => FromHttpApiData (QueryList 'PipeSeparated a) where
-    parseQueryParam = parseSeparatedQueryList '|'
+  parseQueryParam = parseSeparatedQueryList '|'
 
 instance FromHttpApiData a => FromHttpApiData (QueryList 'MultiParamArray a) where
-    parseQueryParam = error "unimplemented FromHttpApiData for MultiParamArray collection format"
+  parseQueryParam = error "unimplemented FromHttpApiData for MultiParamArray collection format"
 
 parseSeparatedQueryList :: FromHttpApiData a => Char -> Text -> Either Text (QueryList p a)
 parseSeparatedQueryList char = fmap QueryList . mapM parseQueryParam . T.split (== char)
 
 instance ToHttpApiData a => ToHttpApiData (QueryList 'CommaSeparated a) where
-    toQueryParam = formatSeparatedQueryList ','
+  toQueryParam = formatSeparatedQueryList ','
 
 instance ToHttpApiData a => ToHttpApiData (QueryList 'TabSeparated a) where
-    toQueryParam = formatSeparatedQueryList '\t'
+  toQueryParam = formatSeparatedQueryList '\t'
 
 instance ToHttpApiData a => ToHttpApiData (QueryList 'SpaceSeparated a) where
-    toQueryParam = formatSeparatedQueryList ' '
+  toQueryParam = formatSeparatedQueryList ' '
 
 instance ToHttpApiData a => ToHttpApiData (QueryList 'PipeSeparated a) where
-    toQueryParam = formatSeparatedQueryList '|'
+  toQueryParam = formatSeparatedQueryList '|'
 
 instance ToHttpApiData a => ToHttpApiData (QueryList 'MultiParamArray a) where
-    toQueryParam = error "unimplemented ToHttpApiData for MultiParamArray collection format"
+  toQueryParam = error "unimplemented ToHttpApiData for MultiParamArray collection format"
 
 formatSeparatedQueryList :: ToHttpApiData a => Char ->  QueryList p a -> Text
 formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryParam . fromQueryList
@@ -128,26 +144,29 @@ formatSeparatedQueryList char = T.intercalate (T.singleton char) . map toQueryPa
 -- The backend can be used both for the client and the server. The client generated from the {{title}} Swagger spec
 -- is a backend that executes actions by sending HTTP requests (see @create{{title}}Client@). Alternatively, provided
 -- a backend, the API can be served using @run{{title}}Server@.
-data {{title}}Backend m = {{title}}Backend {
-    {{#apis}}{{#operations}}{{#operation}}{{operationId}} :: {{& vendorExtensions.x-clientType}}{- ^ {{& notes}} -}{{#hasMore}},
-    {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}},
-    {{/hasMore}}{{/apis}}
+data {{title}}Backend m = {{title}}Backend
+  { {{#apis}}{{#operations}}{{#operation}}{{operationId}} :: {{& vendorExtensions.x-clientType}}{- ^ {{& notes}} -}{{#hasMore}}
+  , {{/hasMore}}{{/operation}}{{/operations}}{{#hasMore}}
+  , {{/hasMore}}{{/apis}}
   }
 
-newtype {{title}}Client a = {{title}}Client { runClient :: Manager -> BaseUrl -> ExceptT ServantError IO a }
-    deriving Functor
+newtype {{title}}Client a = {{title}}Client
+  { runClient :: Manager -> BaseUrl -> ExceptT ServantError IO a
+  } deriving Functor
 
 instance Applicative {{title}}Client where
-    pure x = {{title}}Client (\_ _ -> pure x)
-    ({{title}}Client f) <*> ({{title}}Client x) = {{title}}Client (\manager url -> f manager url <*> x manager url)
+  pure x = {{title}}Client (\_ _ -> pure x)
+  ({{title}}Client f) <*> ({{title}}Client x) =
+    {{title}}Client (\manager url -> f manager url <*> x manager url)
 
 instance Monad {{title}}Client where
-    ({{title}}Client a) >>= f = {{title}}Client (\manager url -> do
-        value <- a manager url
-        runClient (f value) manager url)
+  ({{title}}Client a) >>= f =
+    {{title}}Client (\manager url -> do
+      value <- a manager url
+      runClient (f value) manager url)
 
 instance MonadIO {{title}}Client where
-    liftIO io = {{title}}Client (\_ _ -> liftIO io)
+  liftIO io = {{title}}Client (\_ _ -> liftIO io)
 {{/apiInfo}}
 
 {{#apiInfo}}
@@ -175,7 +194,6 @@ run{{title}}ClientWithManager manager clientConfig cl =
 run{{title}}Server :: MonadIO m => ServerConfig -> {{title}}Backend (ExceptT ServantErr IO)  -> m ()
 run{{title}}Server ServerConfig{..} backend =
   liftIO $ Warp.runSettings warpSettings $ serve (Proxy :: Proxy {{title}}API) (serverFromBackend backend)
-
   where
     warpSettings = Warp.defaultSettings & Warp.setPort configPort & Warp.setHost (fromString configHost)
     serverFromBackend {{title}}Backend{..} =

modules/swagger-codegen/src/main/resources/haskell-servant/Types.mustache

@@ -5,10 +5,10 @@
 module {{title}}.Types (
 {{#models}}
 {{#model}}
-    {{classname}} (..),
+  {{classname}} (..),
 {{/model}}
 {{/models}}
-    ) where
+  ) where
 
 import Data.List (stripPrefix)
 import Data.Maybe (fromMaybe)
@@ -29,14 +29,14 @@ import Data.Function ((&))
 {{^vendorExtensions.x-customNewtype}}
 {{^parent}}
 {{vendorExtensions.x-data}} {{classname}} = {{classname}}
-    { {{#vars}}{{& name}} :: {{datatype}} -- ^ {{& description}}{{#hasMore}}
-    , {{/hasMore}}{{/vars}}
-    } deriving (Show, Eq, Generic)
+  { {{#vars}}{{& name}} :: {{datatype}} -- ^ {{& description}}{{#hasMore}}
+  , {{/hasMore}}{{/vars}}
+  } deriving (Show, Eq, Generic)
 
 instance FromJSON {{classname}} where
-  parseJSON  = genericParseJSON  (removeFieldLabelPrefix True "{{vendorExtensions.x-prefix}}")
+  parseJSON = genericParseJSON (removeFieldLabelPrefix True "{{vendorExtensions.x-prefix}}")
 instance ToJSON {{classname}} where
-  toJSON     = genericToJSON     (removeFieldLabelPrefix False "{{vendorExtensions.x-prefix}}")
+  toJSON = genericToJSON (removeFieldLabelPrefix False "{{vendorExtensions.x-prefix}}")
 {{/parent}}
 {{#parent}}
 newtype {{classname}} = {{classname}} { un{{classname}} :: {{parent}} }
@@ -54,12 +54,15 @@ newtype {{classname}} = {{classname}} {{vendorExtensions.x-customNewtype}} deriv
 removeFieldLabelPrefix :: Bool -> String -> Options
 removeFieldLabelPrefix forParsing prefix =
   defaultOptions
-    { fieldLabelModifier = fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars
-    }
+  {fieldLabelModifier = fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars}
   where
     replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
-    specialChars = [{{#specialCharReplacements}}("{{&char}}", "{{&replacement}}"){{#hasMore}}, {{/hasMore}}{{/specialCharReplacements}}]
+    specialChars =
+      [ {{#specialCharReplacements}}("{{&char}}", "{{&replacement}}"){{#hasMore}}
+      , {{/hasMore}}{{/specialCharReplacements}}
+      ]
     mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack
-    replacer = if forParsing then flip T.replace else T.replace
-
-
+    replacer =
+      if forParsing
+        then flip T.replace
+        else T.replace

modules/swagger-codegen/src/main/resources/haskell-servant/stack.mustache

@@ -1,8 +1,8 @@
 resolver: lts-5.11
 extra-deps:
-- servant-0.6
-- servant-client-0.6
-- servant-server-0.6
-- http-api-data-0.2.2
+- servant-0.8.1
+- servant-client-0.8.1
+- servant-server-0.8.1
+- http-api-data-0.2.4
 packages:
 - '.'