More Descriptive Errors (Part 2/2)

exe/wallet/Main.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
+
 -- |
 -- Copyright: © 2018-2019 IOHK
 -- License: MIT
@@ -40,8 +41,6 @@ import Cardano.Wallet
     ( newWalletLayer )
 import Cardano.Wallet.Api
     ( Api )
-import Cardano.Wallet.Api.Server
-    ( server )
 import Cardano.Wallet.Api.Types
     ( ApiMnemonicT (..)
     , ApiT (..)
@@ -81,7 +80,7 @@ import Network.HTTP.Client
 import Network.HTTP.Types.Status
     ( status404, status409 )
 import Servant
-    ( (:<|>) (..), (:>), serve )
+    ( (:<|>) (..), (:>) )
 import Servant.Client
     ( BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM )
 import Servant.Client.Core
@@ -108,6 +107,7 @@ import System.IO
 import Text.Regex.Applicative
     ( anySym, few, match, string, sym )
 
+import qualified Cardano.Wallet.Api.Server as Server
 import qualified Cardano.Wallet.DB.MVar as MVar
 import qualified Cardano.Wallet.Network.HttpBridge as HttpBridge
 import qualified Cardano.Wallet.Transaction.HttpBridge as HttpBridge
@@ -337,7 +337,7 @@ execServer (Port port) (Port bridgePort) = do
     nw <- HttpBridge.newNetworkLayer bridgePort
     let tl = HttpBridge.newTransactionLayer
     wallet <- newWalletLayer @_ @HttpBridge db nw tl
-    Warp.runSettings settings (serve (Proxy @("v2" :> Api)) (server wallet))
+    Server.start settings wallet
   where
     settings = Warp.defaultSettings
         & Warp.setPort port

lib/core/cardano-wallet-core.cabal

@@ -36,6 +36,7 @@ library
     , base
     , base58-bytestring
     , basement
+    , binary
     , bytestring
     , cardano-crypto
     , containers
@@ -45,6 +46,7 @@ library
     , fast-logger
     , fmt
     , generic-lens
+    , http-types
     , http-api-data
     , http-media
     , memory
@@ -61,6 +63,8 @@ library
     , time
     , transformers
     , vector
+    , wai
+    , warp
 
   hs-source-dirs:
       src
@@ -87,6 +91,7 @@ library
       Cardano.Wallet.Primitive.Types
       Cardano.Wallet.Transaction
       Data.Quantity
+      Network.Wai.Middleware.ServantError
   other-modules:
       Paths_cardano_wallet_core
 

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
 
 -- |
 -- Copyright: © 2018-2019 IOHK
@@ -12,7 +14,7 @@
 -- endpoints reachable through HTTP.
 
 module Cardano.Wallet.Api.Server
-    ( server
+    ( start
     ) where
 
 import Prelude
@@ -75,6 +77,8 @@ import Data.Generics.Internal.VL.Lens
     ( (^.) )
 import Data.Generics.Labels
     ()
+import Data.Proxy
+    ( Proxy (..) )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Text
@@ -83,30 +87,55 @@ import Data.Text.Class
     ( toText )
 import Fmt
     ( pretty )
+import Network.HTTP.Media.RenderHeader
+    ( renderHeader )
+import Network.HTTP.Types.Header
+    ( hContentType )
+import Network.Wai.Middleware.ServantError
+    ( handleRawError )
 import Servant
     ( (:<|>) (..)
+    , (:>)
+    , Application
+    , JSON
     , NoContent (..)
     , Server
+    , contentType
     , err403
     , err404
     , err409
     , err410
     , err500
     , err503
+    , serve
     )
 import Servant.Server
     ( Handler (..), ServantErr (..) )
 
 import qualified Cardano.Wallet as W
 import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as BL
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Network.Wai.Handler.Warp as Warp
+
+-- | Start the application server
+start
+    :: (TxId t, KeyToAddress t)
+    => Warp.Settings
+    -> WalletLayer (SeqState t) t
+    -> IO ()
+start settings wl = Warp.runSettings settings
+    $ handleRawError handler
+    application
+  where
+    -- | A Servant server for our wallet API
+    server :: Server Api
+    server = addresses wl :<|> wallets wl :<|> transactions wl
 
-
--- | A Servant server for our wallet API
-server :: (TxId t, KeyToAddress t) => WalletLayer (SeqState t) t -> Server Api
-server w =
-    addresses w :<|> wallets w :<|> transactions w
+    application :: Application
+    application = serve (Proxy @("v2" :> Api)) server
 
 {-------------------------------------------------------------------------------
                                     Wallets
@@ -272,12 +301,6 @@ class LiftHandler e where
     liftHandler action = Handler (withExceptT handler action)
     handler :: e -> ServantErr
 
--- FIXME
---
--- For now, just "dumb" mapping from our internal errors to servant errors.
--- In practice, we want to create nice error messages giving as much details as
--- we can.
-
 apiError :: ServantErr -> ApiErrorCode -> Text -> ServantErr
 apiError err code message = err
     { errBody = Aeson.encode $ Aeson.object
@@ -417,3 +440,42 @@ instance LiftHandler ErrUpdatePassphrase where
     handler = \case
         ErrUpdatePassphraseNoSuchWallet e -> handler e
         ErrUpdatePassphraseWithRootKey e  -> handler e
+
+instance LiftHandler ServantErr where
+    handler err@(ServantErr code _ body headers) = case code of
+        400 -> apiError err' BadRequest (utf8 body)
+        404 -> apiError err' NotFound $ mconcat
+            [ "I couldn't find the requested endpoint? If the endpoint contains "
+            , "path parameters, make sure they are well-formed otherwise I "
+            , "won't be able to route them correctly."
+            ]
+        405 -> apiError err' MethodNotAllowed $ mconcat
+            [ "You've reached a known endpoint but I don't know how to handle "
+            , "this HTTP method for it. Please double-check both the endpoint "
+            , "and the method used: one of them is likely incorrect (e.g. POST "
+            , "instead of PUT, or GET instead of POST...)."
+            ]
+        406 -> apiError err' NotAcceptable $ mconcat
+            [ "It seems like you don't accept 'application/json' however, I "
+            , "only speak 'application/json'! Please, double-check your "
+            , "'Accept' request header and make sure it's set to "
+            , "'application/json'."
+            ]
+        415 -> apiError err' UnsupportedMediaType $ mconcat
+            [ "I am sorry but I only speak 'application/json' and I need you to "
+            , "tell me what you're speaking before I can comprehend it. Please, "
+            , "double-check your 'Content-Type' request header and make sure "
+            , "it's set to 'application/json'."
+            ]
+        _ -> apiError err' UnexpectedError $ mconcat
+            [ "Looks like something went wrong and I wasn't ready for this. "
+            , "Here is a hint about what happened: ", utf8 body
+            ]
+      where
+        utf8 = T.replace "\"" "'" . T.decodeUtf8 . BL.toStrict
+        err' = err
+            { errHeaders =
+                ( hContentType
+                , renderHeader $ contentType $ Proxy @JSON
+                ) : headers
+            }

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -193,6 +193,12 @@ data ApiErrorCode
     | NetworkUnreachable
     | CreatedInvalidTransaction
     | RejectedByCoreNode
+    | BadRequest
+    | NotFound
+    | MethodNotAllowed
+    | NotAcceptable
+    | UnsupportedMediaType
+    | UnexpectedError
     deriving (Eq, Generic, Show)
 
 {-------------------------------------------------------------------------------

lib/core/src/Network/Wai/Middleware/ServantError.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- |
+-- Copyright: © 2018-2019 IOHK
+-- License: MIT
+--
+-- Middleware between Wai <-> Servant to accomodate raw error responses returned
+-- by servant. See also 'handleRawError'.
+
+module Network.Wai.Middleware.ServantError
+    ( handleRawError
+    ) where
+
+import Prelude
+
+import Control.Monad
+    ( guard )
+import Data.ByteString.Lazy
+    ( ByteString )
+import Network.HTTP.Types.Header
+    ( ResponseHeaders )
+import Network.HTTP.Types.Status
+    ( statusCode, statusMessage )
+import Network.Wai
+    ( Middleware, responseHeaders, responseStatus )
+import Network.Wai.Internal
+    ( Response (..) )
+import Servant.Server.Internal.ServantErr
+    ( ServantErr (..), responseServantErr )
+
+import qualified Data.Binary.Builder as Binary
+import qualified Data.ByteString.Char8 as B8
+import qualified Network.HTTP.Types.Status as HTTP
+
+-- | Make sure every error is converted to a suitable application-level error.
+--
+-- There are many cases where Servant will handle errors itself and reply to a
+-- client without even disturbing the application. This is both handy and clunky
+-- since our application return errors in a specific format (e.g. JSON, XML
+-- ...).
+--
+-- This is the case for instance if the client hits a non-exiting endpoint of
+-- the API, or if the client requests an invalid content-type, etc ...
+--
+-- Ideally, we would like clients to be able to expect one and only one format,
+-- so this middleware allows for manipulating the response returned by a Wai
+-- application (what servant boils down to) and adjust the response when
+-- necessary. So, any response with or without payload but no content-type will
+-- trigger the 'convert' function and offer the caller to adjust the response as
+-- needed.
+handleRawError
+    :: (ServantErr -> ServantErr)
+    -- ^ Convert a raw response into something that better fits the application
+    -- error
+    -> Middleware
+handleRawError adjust app req send =
+    app req (send . either (responseServantErr . adjust) id . eitherRawError)
+
+-- | Analyze whether a given error is a raw error thrown by Servant before
+-- reaching our application layer, or one from our application layer.
+eitherRawError
+    :: Response
+    -> Either ServantErr Response
+eitherRawError res =
+    let
+        status = responseStatus res
+        code = statusCode status
+        reason = B8.unpack (statusMessage status)
+        headers = responseHeaders res
+        body = responseBody res
+        maybeToEither = maybe
+            (Right res)
+            (Left . flip (ServantErr code reason) headers)
+    in
+        maybeToEither $ guard (isRawError status headers) *> body
+
+-- | Raw 'Servant' errors don't have any Content-Type. This is a lean predicate
+-- but for lack of any better way of identifying them, that's a best effort.
+isRawError
+    :: HTTP.Status
+    -> ResponseHeaders
+    -> Bool
+isRawError status headers =
+    statusCode status >= 400 && null headers
+
+-- | Extract raw body of a response, only if it suitables for transformation.
+-- Servant doesn't return files or streams by default, so if one of the two is
+-- met, it means it comes from our application layer anyway.
+responseBody
+  :: Response
+  -> Maybe ByteString
+responseBody = \case
+    ResponseBuilder _ _ b ->
+        Just (Binary.toLazyByteString b)
+    ResponseRaw _ r ->
+        responseBody r
+    ResponseFile{} ->
+        Nothing
+    ResponseStream{} ->
+        Nothing

lib/http-bridge/cardano-wallet-http-bridge.cabal

@@ -151,7 +151,6 @@ test-suite integration
     , http-types
     , memory
     , process
-    , servant-server
     , template-haskell
     , text
     , text-class

lib/http-bridge/test/integration/Main.hs

@@ -13,10 +13,6 @@ import Cardano.Launcher
     ( Command (..), StdStream (..), launch )
 import Cardano.Wallet
     ( newWalletLayer )
-import Cardano.Wallet.Api
-    ( Api )
-import Cardano.Wallet.Api.Server
-    ( server )
 import Cardano.Wallet.Compatibility.HttpBridge
     ( HttpBridge )
 import Control.Concurrent
@@ -31,14 +27,10 @@ import Data.Aeson
     ( Value (..), (.:) )
 import Data.Function
     ( (&) )
-import Data.Proxy
-    ( Proxy (..) )
 import Data.Time
     ( addUTCTime, defaultTimeLocale, formatTime, getCurrentTime )
 import Network.HTTP.Client
     ( defaultManagerSettings, newManager )
-import Servant
-    ( (:>), serve )
 import System.Directory
     ( createDirectoryIfMissing, removePathForcibly )
 import System.IO
@@ -53,6 +45,7 @@ import Test.Integration.Framework.Request
     ( Headers (Default), Payload (Empty), request )
 
 import qualified Cardano.LauncherSpec as Launcher
+import qualified Cardano.Wallet.Api.Server as Server
 import qualified Cardano.Wallet.DB.MVar as MVar
 import qualified Cardano.Wallet.Network.HttpBridge as HttpBridge
 import qualified Cardano.Wallet.Network.HttpBridgeSpec as HttpBridge
@@ -180,7 +173,7 @@ main = do
         let tl = HttpBridge.newTransactionLayer
         wallet <- newWalletLayer @_ @HttpBridge db nl tl
         let settings = Warp.defaultSettings & Warp.setPort serverPort
-        Warp.runSettings settings (serve (Proxy @("v2" :> Api)) (server wallet))
+        Server.start settings wallet
 
     waitForCluster :: String -> IO ()
     waitForCluster addr = do