[CO-370] Make Content-Type parsing more lenient

We have had a lot of trouble where people will send no content-type or
simply 'application/json' and request would fail with 415 Unsupported
Media Type. Without knowing where to look, the error looks quite
unexpected and could give a lot of headache. This commit does two
changes:

- It slightly modifies the 'Accept' instance to use 'contentTypes'
  instead of 'contentType'. The latter is defined from the former by
  simply taking the head of the list returned by 'contentTypes', which in
  our case is 'application/json;charset=utf-8'

- It provides a default content-type 'application/json' when no
  content-type is provided

Author: KtorZ

wallet-new/server/Main.hs

@@ -39,6 +39,7 @@ import           Pos.Wallet.Web.Tracking.Sync (syncWallet)
 
 import qualified Cardano.Wallet.Kernel.Mode as Kernel.Mode
 
+import qualified Cardano.Wallet.API.V1.Headers as Headers
 import           Cardano.Wallet.Kernel (PassiveWallet)
 import qualified Cardano.Wallet.Kernel as Kernel
 import qualified Cardano.Wallet.Kernel.Internal as Kernel.Internal
@@ -50,7 +51,8 @@ import           Cardano.Wallet.Server.CLI (ChooseWalletBackend (..),
                      getWalletNodeOptions, walletDbPath, walletFlushDb,
                      walletRebuildDb)
 import qualified Cardano.Wallet.Server.LegacyPlugins as LegacyPlugins
-import           Cardano.Wallet.Server.Middlewares (throttleMiddleware)
+import           Cardano.Wallet.Server.Middlewares (throttleMiddleware,
+                     withDefaultHeader)
 import qualified Cardano.Wallet.Server.Plugins as Plugins
 import           Cardano.Wallet.WalletLayer (PassiveWalletLayer)
 import qualified Cardano.Wallet.WalletLayer.Kernel as WalletLayer.Kernel
@@ -109,6 +111,7 @@ actionWithLegacyWallet genesisConfig walletConfig txpConfig sscParams nodeParams
         mconcat [ LegacyPlugins.conversation wArgs
                 , LegacyPlugins.legacyWalletBackend genesisConfig walletConfig txpConfig wArgs ntpStatus
                     [ LegacyPlugins.throttleMiddleware (ccThrottle walletConfig)
+                    , withDefaultHeader (Headers.applicationJson)
                     ]
                 , LegacyPlugins.walletDocumentation wArgs
                 , LegacyPlugins.acidCleanupWorker wArgs
@@ -177,6 +180,7 @@ actionWithWallet genesisConfig walletConfig txpConfig sscParams nodeParams ntpCo
         [ Plugins.apiServer pm params w
             -- Throttle requests.
             [ throttleMiddleware (ccThrottle walletConfig)
+            , withDefaultHeader (Headers.applicationJson)
             ]
 
         -- The corresponding wallet documention, served as a different

wallet-new/src/Cardano/Wallet/API/Response.hs

@@ -229,7 +229,7 @@ instance FromJSON a => MimeUnrender ValidJSON a where
         Right v  -> return v
 
 instance Accept ValidJSON where
-    contentType _ = contentType (Proxy @ JSON)
+    contentTypes _ = contentTypes (Proxy @ JSON)
 
 instance ToJSON a => MimeRender ValidJSON a where
     mimeRender _ = mimeRender (Proxy @ JSON)

wallet-new/src/Cardano/Wallet/Server/Middlewares.hs

@@ -6,23 +6,35 @@
 module Cardano.Wallet.Server.Middlewares
     ( withMiddlewares
     , throttleMiddleware
+    , withDefaultHeader
     ) where
 
 import           Universum
 
 import           Data.Aeson (encode)
-import           Network.Wai (Application, Middleware, responseLBS)
+import qualified Data.List as List
+import           Network.HTTP.Types.Header (Header)
+import           Network.HTTP.Types.Method (methodPatch, methodPost, methodPut)
+import           Network.Wai (Application, Middleware, ifRequest,
+                     requestHeaders, requestMethod, responseLBS)
 import qualified Network.Wai.Middleware.Throttle as Throttle
 
 import           Cardano.Wallet.API.V1.Headers (applicationJson)
 import qualified Cardano.Wallet.API.V1.Types as V1
 
 import           Pos.Launcher.Configuration (ThrottleSettings (..))
 
+
 -- | "Attaches" the middlewares to this 'Application'.
 withMiddlewares :: [Middleware] -> Application -> Application
 withMiddlewares = flip $ foldr ($)
 
+-- | Only apply a @Middleware@ to request with bodies (we don't consider
+-- "DELETE" as one of them).
+ifRequestWithBody :: Middleware -> Middleware
+ifRequestWithBody =
+    ifRequest ((`List.elem` [methodPost, methodPut, methodPatch]) . requestMethod)
+
 -- | A @Middleware@ to throttle requests.
 throttleMiddleware :: Maybe ThrottleSettings -> Middleware
 throttleMiddleware Nothing app = app
@@ -40,3 +52,18 @@ throttleMiddleware (Just ts) app = \req respond -> do
         , Throttle.throttlePeriod = fromIntegral $ tsPeriod ts
         , Throttle.throttleBurst = fromIntegral $ tsBurst ts
         }
+
+-- | A @Middleware@ to default a specific Header when not provided
+withDefaultHeader :: Header -> Middleware
+withDefaultHeader header = ifRequestWithBody $ \app req send ->
+    let
+        headers =
+            requestHeaders req
+
+        req' =
+            if any (on (==) fst header) headers then
+                req
+            else
+                req { requestHeaders = header : headers }
+    in
+        app req' send