diff --git a/lib/mobility-core/mobility-core.cabal b/lib/mobility-core/mobility-core.cabal index 3b2f74d71..76f40ee72 100644 --- a/lib/mobility-core/mobility-core.cabal +++ b/lib/mobility-core/mobility-core.cabal @@ -576,6 +576,7 @@ library Kernel.Utils.Servant.API Kernel.Utils.Servant.BaseUrl Kernel.Utils.Servant.BasicAuth + Kernel.Utils.Servant.BecknResponseWrapper Kernel.Utils.Servant.Client Kernel.Utils.Servant.HeaderAuth Kernel.Utils.Servant.HTML diff --git a/lib/mobility-core/src/Kernel/Types/Beckn/Ack.hs b/lib/mobility-core/src/Kernel/Types/Beckn/Ack.hs index 2563400e4..f9de1dc6b 100644 --- a/lib/mobility-core/src/Kernel/Types/Beckn/Ack.hs +++ b/lib/mobility-core/src/Kernel/Types/Beckn/Ack.hs @@ -16,13 +16,15 @@ module Kernel.Types.Beckn.Ack where import qualified Control.Lens as L import Data.Aeson -import qualified Data.Aeson.Key as AesonKey (Key) import Data.Aeson.Types (unexpected) import qualified Data.HashMap.Strict.InsOrd as HMSIO import Data.OpenApi import EulerHS.Prelude +import qualified Kernel.Types.Beckn.Error as BError -data AckResponse = Ack +data AckResponse + = Ack + | Nack BError.Error deriving (Generic, Show) instance ToSchema AckResponse where @@ -32,13 +34,13 @@ instance ToSchema AckResponse where mempty & type_ L.?~ OpenApiObject & properties - L..~ HMSIO.singleton "message" messageSchema + L..~ HMSIO.fromList [("message", messageSchema), ("error", errorSchema)] & required L..~ ["message"] where statusSchema = (mempty :: Schema) & type_ L.?~ OpenApiString - & enum_ L.?~ ["ACK"] + & enum_ L.?~ ["ACK", "NACK"] & Inline ackSchema = (mempty :: Schema) @@ -54,19 +56,60 @@ instance ToSchema AckResponse where L..~ HMSIO.singleton "ack" ackSchema & required L..~ ["ack"] & Inline + codeSchema = (mempty :: Schema) & type_ L.?~ OpenApiString & Inline + messageFieldSchema = (mempty :: Schema) & type_ L.?~ OpenApiString & Inline + errorSchema = + (mempty :: Schema) + & type_ L.?~ OpenApiObject + & properties + L..~ HMSIO.fromList [("code", codeSchema), ("message", messageFieldSchema)] + & required L..~ ["code"] + & Inline +-- ONDC TRV10 v2.1.0 envelope: `{message: {ack: {status}}, error?: {code, message}}`. +-- Error carries only `code` and `message` — the internal `type` and `path` fields are +-- not emitted (spec-optional, and we keep those in the in-memory Error record for logs). +-- +-- Parser accepts the unwrapped shape (spec). A WAI-level wrapper middleware in the BPP +-- optionally rewraps outgoing bodies in `{response: ...}` for deployments whose BAPs +-- expect that shape; the response-wrapper middleware is the only place that knows about +-- the wrapper, keeping the wire-format contract explicit. instance FromJSON AckResponse where - parseJSON = withObject "Ack" $ \v -> do + parseJSON = withObject "AckResponse" $ \v -> do + -- Accept both unwrapped (spec) and wrapped ({response: {...}}) bodies — the wrapper + -- is handled by middleware at emit time, but a peer may echo our wrapped output back. + inner <- (v .: "response") <|> pure v status <- - (v .: "message") + (inner .: "message") >>= (.: "ack") >>= (.: "status") - unless (status == String "ACK") (unexpected status) - pure Ack + case status of + String "ACK" -> pure Ack + String "NACK" -> do + errObj <- inner .: "error" + errCode <- errObj .: "code" + errMsg <- errObj .:? "message" + pure $ + Nack + BError.Error + { BError._type = BError.INTERNAL_ERROR, + BError.code = errCode, + BError.path = Nothing, + BError.message = errMsg + } + other -> unexpected other instance ToJSON AckResponse where - toJSON Ack = "message" .== "ack" .== "status" .== String "ACK" - where - (.==) :: AesonKey.Key -> Value -> Value - k .== v = Object (k .= v) - infixr 9 .== + toJSON Ack = + object + [ "message" .= object ["ack" .= object ["status" .= ("ACK" :: Text)]] + ] + toJSON (Nack err) = + object + [ "message" .= object ["ack" .= object ["status" .= ("NACK" :: Text)]], + "error" + .= object + [ "code" .= BError.code err, + "message" .= BError.message err + ] + ] diff --git a/lib/mobility-core/src/Kernel/Types/Error.hs b/lib/mobility-core/src/Kernel/Types/Error.hs index c1b07bd69..9fb49395e 100644 --- a/lib/mobility-core/src/Kernel/Types/Error.hs +++ b/lib/mobility-core/src/Kernel/Types/Error.hs @@ -1142,21 +1142,32 @@ instance IsAPIError CallStatusError data ServiceabilityError = RideNotServiceable | RideNotServiceableInState Text - deriving (Eq, Show, IsBecknAPIError) + | UnserviceableTripCategory Text + deriving (Eq, Show) instanceExceptionWithParent 'HTTPException ''ServiceabilityError instance IsBaseError ServiceabilityError where - toMessage RideNotServiceable = Just "Requested ride is not serviceable due to georestrictions." - toMessage (RideNotServiceableInState state_) = Just ("Selected state " <> state_ <> " is not serviceable since it does not fall within the state boundary.") + toMessage RideNotServiceable = Just "Route Serviceability error" + toMessage (RideNotServiceableInState state_) = Just ("Route Serviceability error: selected state " <> state_ <> " is not serviceable.") + toMessage (UnserviceableTripCategory cat) = Just ("Route Serviceability error: unserviceable trip category " <> cat <> ".") instance IsHTTPError ServiceabilityError where toErrorCode = \case RideNotServiceable -> "RIDE_NOT_SERVICEABLE" RideNotServiceableInState _ -> "RIDE_NOT_SERVICEABLE_IN_STATE" + UnserviceableTripCategory _ -> "UNSERVICEABLE_TRIP_CATEGORY" toHttpCode = \case RideNotServiceable -> E400 RideNotServiceableInState _ -> E400 + UnserviceableTripCategory _ -> E400 + +-- ONDC v2.1.0 mandates numeric error codes in NACK responses. "90201" is +-- "Route Serviceability error" per the ONDC mobility spec. Keep the internal +-- toErrorCode for metrics/logs, and surface the ONDC code via toOndcErrorCode +-- which is what the BecknAPIError JSON actually emits. +instance IsBecknAPIError ServiceabilityError where + toOndcErrorCode _ = Just "90201" instance IsAPIError ServiceabilityError diff --git a/lib/mobility-core/src/Kernel/Types/Error/BaseError/HTTPError/BecknAPIError.hs b/lib/mobility-core/src/Kernel/Types/Error/BaseError/HTTPError/BecknAPIError.hs index cc386f1bd..78580dac2 100644 --- a/lib/mobility-core/src/Kernel/Types/Error/BaseError/HTTPError/BecknAPIError.hs +++ b/lib/mobility-core/src/Kernel/Types/Error/BaseError/HTTPError/BecknAPIError.hs @@ -32,21 +32,48 @@ class IsBecknAPIError e where toPath :: e -> Maybe Text toPath _ = Nothing + toOndcErrorCode :: e -> Maybe Text + toOndcErrorCode _ = Nothing + newtype BecknAPIError = BecknAPIError Error.Error deriving (Generic, Eq, Show) +-- ONDC TRV10 v2.1.0 shape: `{message: {ack: {status: "NACK"}}, error: {code, message}}`. +-- The error object carries only `code` and `message` — internal `type` and `path` +-- remain in the Haskell Error record for logs/metrics but are not emitted. Optional +-- `"response"` wrapping for deployments that need it is handled by WAI middleware at +-- the HTTP edge, not here. instance FromJSON BecknAPIError where - parseJSON (Object v) = BecknAPIError <$> v .: "error" + parseJSON (Object v) = do + -- Accept both unwrapped (spec) and wrapped `{response: {...}}` bodies in case a peer + -- echoes back our wrapped output. + inner <- (v .: "response") <|> pure v + errObj <- inner .: "error" + errCode <- errObj .: "code" + errMsg <- errObj .:? "message" + pure $ + BecknAPIError + Error.Error + { Error._type = Error.INTERNAL_ERROR, + Error.code = errCode, + Error.path = Nothing, + Error.message = errMsg + } parseJSON invalid = prependFailure "Parsing BecknAPIError failed, " (typeMismatch "Object" invalid) instance ToJSON BecknAPIError where - toJSON (BecknAPIError err) = object ["message" .= ack, "error" .= err] - where - ack = object ["ack" .= status] - status = object ["status" .= ("NACK" :: Text)] + toJSON (BecknAPIError err) = + object + [ "message" .= object ["ack" .= object ["status" .= ("NACK" :: Text)]], + "error" + .= object + [ "code" .= Error.code err, + "message" .= Error.message err + ] + ] instance FromResponse BecknAPIError where fromResponse = fromJsonResponse diff --git a/lib/mobility-core/src/Kernel/Utils/Error/BaseError/HTTPError/BecknAPIError.hs b/lib/mobility-core/src/Kernel/Utils/Error/BaseError/HTTPError/BecknAPIError.hs index bad05a578..7fc43136a 100644 --- a/lib/mobility-core/src/Kernel/Utils/Error/BaseError/HTTPError/BecknAPIError.hs +++ b/lib/mobility-core/src/Kernel/Utils/Error/BaseError/HTTPError/BecknAPIError.hs @@ -109,7 +109,7 @@ toBecknAPIError e = BecknAPIError Error { _type = toType e, - code = toErrorCode e, + code = fromMaybe (toErrorCode e) (toOndcErrorCode e), path = toPath e, message = toMessageIfNotInternal e } diff --git a/lib/mobility-core/src/Kernel/Utils/Error/FlowHandling.hs b/lib/mobility-core/src/Kernel/Utils/Error/FlowHandling.hs index b976e33e1..cc26014b0 100644 --- a/lib/mobility-core/src/Kernel/Utils/Error/FlowHandling.hs +++ b/lib/mobility-core/src/Kernel/Utils/Error/FlowHandling.hs @@ -25,7 +25,9 @@ module Kernel.Utils.Error.FlowHandling withFlowHandlerBecknAPI', apiHandler, becknApiHandler, + becknAuthHandler, someExceptionToBecknApiError, + throwBecknNack200, handleIfUp, throwServantError, ) @@ -34,6 +36,7 @@ where import Control.Concurrent.STM (isEmptyTMVar) import Control.Monad.Reader import qualified Data.Aeson as A +import qualified Data.Text as T import Data.Time.Clock hiding (getCurrentTime) import qualified EulerHS.Language as L import EulerHS.Prelude @@ -47,6 +50,7 @@ import qualified Kernel.Tools.Metrics.CoreMetrics as Metrics import Kernel.Tools.Metrics.CoreMetrics.Types import Kernel.Types.App import Kernel.Types.Beckn.Ack +import qualified Kernel.Types.Beckn.Error as BError import Kernel.Types.Common import Kernel.Types.Error as Err import Kernel.Types.Error.BaseError.HTTPError @@ -179,7 +183,7 @@ withFlowHandlerBecknAPI :: ) => FlowR r AckResponse -> FlowHandlerR r AckResponse -withFlowHandlerBecknAPI = withFlowHandler . becknApiHandler . handleIfUp +withFlowHandlerBecknAPI = withFlowHandler . becknApiHandler . handleIfUpBeckn -- created this for using it in beckn-gateway as it does not require any extra constraints withFlowHandlerBecknAPI' :: @@ -190,7 +194,7 @@ withFlowHandlerBecknAPI' :: ) => FlowR r AckResponse -> FlowHandlerR r AckResponse -withFlowHandlerBecknAPI' = withFlowHandler' . becknApiHandler . handleIfUp +withFlowHandlerBecknAPI' = withFlowHandler' . becknApiHandler . handleIfUpBeckn handleIfUp :: ( L.MonadFlow m, @@ -220,6 +224,14 @@ apiHandler :: m a apiHandler = (`catch` someExceptionToAPIErrorThrow) +-- | Beckn-specific handler: catches *any* synchronous exception and converts it to a +-- 'Nack' 'AckResponse' instead of propagating it as a ServantError / HTTP 4xx-5xx. +-- +-- Per ONDC spec every Beckn API responds with HTTP 200 regardless of protocol outcome; +-- success/failure is communicated via @message.ack.status@ (ACK\/NACK) with an +-- accompanying @error@ object for NACKs. So Beckn handlers must never throw to signal +-- protocol failure — this catch-and-return converts legacy 'throwError' call-sites to +-- the compliant shape automatically. becknApiHandler :: ( L.MonadFlow m, Log m, @@ -227,9 +239,45 @@ becknApiHandler :: MonadReader r m, HasField "url" r (Maybe Text) ) => - m a -> - m a -becknApiHandler = (`catch` someExceptionToBecknApiErrorThrow) + m AckResponse -> + m AckResponse +becknApiHandler action = action `catch` someExceptionToBecknNack + +someExceptionToBecknNack :: + ( L.MonadFlow m, + Log m, + Metrics.CoreMetrics m, + MonadReader r m, + HasField "url" r (Maybe Text) + ) => + SomeException -> + m AckResponse +someExceptionToBecknNack exc = withLogTag "BECKN_NACK" $ do + let callStackStr = T.pack $ prettyCallStack callStack + logError $ makeLogSomeException exc + logError $ "Callstack: " <> callStackStr + Metrics.incrementErrorCounter "DEFAULT_ERROR" exc + let BecknAPIError err = someExceptionToBecknApiError exc + pure (Nack err) + +-- | Shutdown guard for Beckn handlers — returns 'Nack' instead of throwing +-- ServerUnavailable, so the BAP still gets a compliant HTTP 200 NACK during drains. +handleIfUpBeckn :: + ( L.MonadFlow m, + Log m, + MonadReader r m, + HasField "isShuttingDown" r (TMVar ()), + Metrics.CoreMetrics m, + HasField "url" r (Maybe Text) + ) => + m AckResponse -> + m AckResponse +handleIfUpBeckn action = do + shutdown <- asks (.isShuttingDown) + shouldRun <- L.runIO $ atomically $ isEmptyTMVar shutdown + if shouldRun + then action + else someExceptionToBecknNack (toException ServerUnavailable) someExceptionToAPIErrorThrow :: ( L.MonadFlow m, @@ -246,39 +294,74 @@ someExceptionToAPIErrorThrow exc throwAPIError . InternalError . fromMaybe (show err) $ toMessage err | otherwise = throwAPIError . InternalError $ show exc -someExceptionToBecknApiErrorThrow :: +-- | Pure SomeException → BecknAPIError conversion used by 'becknApiHandler' to +-- produce a 'Nack' response without throwing. Keeps the Beckn protocol-return path +-- exception-free. +someExceptionToBecknApiError :: SomeException -> BecknAPIError +someExceptionToBecknApiError exc + | Just (HTTPException err) <- fromException exc = toBecknAPIError err + | otherwise = toBecknAPIError . InternalError $ show exc + +-- | Throws a ServantError whose HTTP status is 200 and whose body is an ONDC NACK +-- AckResponse. Used by Servant-level middleware (signature/auth checks) that run in +-- DelayedIO — before the handler — and so must short-circuit the request pipeline via +-- 'throwM'. Inside handler bodies, prefer returning 'Nack' via 'becknApiHandler'. +throwBecknNack200 :: + (Log m, MonadThrow m) => + Text -> -- ONDC error code, e.g. "10001" + Maybe Text -> -- human-readable message + m a +throwBecknNack200 code mbMessage = withLogTag "BECKN_AUTH_NACK" $ do + let err = + BError.Error + { BError._type = BError.INTERNAL_ERROR, + BError.code = code, + BError.path = Nothing, + BError.message = mbMessage + } + body = A.encode (Nack err) + serverErr = + ServerError + { errHTTPCode = 200, + errReasonPhrase = "OK", + errBody = body, + errHeaders = [(hContentType, "application/json;charset=utf-8")] + } + throwM serverErr + +-- | Beckn auth/signature handler for Servant middleware. Catches any exception raised +-- during signature verification and throws a uniform NACK (code 10001 per ONDC spec: +-- "Invalid Signature Message - Cannot verify signature for request"). Polymorphic in +-- the success type so it can wrap 'SignatureAuthResult' returns without requiring the +-- result to be 'AckResponse'. +becknAuthHandler :: ( L.MonadFlow m, Log m, Metrics.CoreMetrics m, MonadReader r m, HasField "url" r (Maybe Text) ) => - SomeException -> + m a -> m a -someExceptionToBecknApiErrorThrow exc - | Just (HTTPException err) <- fromException exc = throwBecknApiError err - | otherwise = - throwBecknApiError . InternalError $ show exc +becknAuthHandler action = action `catch` someExceptionToBecknAuthNackThrow -someExceptionToBecknApiError :: SomeException -> BecknAPIError -someExceptionToBecknApiError exc - | Just (HTTPException err) <- fromException exc = toBecknAPIError err - | otherwise = toBecknAPIError . InternalError $ show exc - -throwAPIError :: - ( Log m, - MonadThrow m, - IsHTTPException e, - Exception e, +someExceptionToBecknAuthNackThrow :: + ( L.MonadFlow m, + Log m, Metrics.CoreMetrics m, MonadReader r m, HasField "url" r (Maybe Text) ) => - e -> + SomeException -> m a -throwAPIError = throwHTTPError toAPIError +someExceptionToBecknAuthNackThrow exc = do + let callStackStr = T.pack $ prettyCallStack callStack + logError $ makeLogSomeException exc + logError $ "Callstack: " <> callStackStr + Metrics.incrementErrorCounter "BECKN_AUTH_ERROR" exc + throwBecknNack200 "10001" (Just "Invalid Signature Message - Cannot verify signature for request") -throwBecknApiError :: +throwAPIError :: ( Log m, MonadThrow m, IsHTTPException e, @@ -289,7 +372,7 @@ throwBecknApiError :: ) => e -> m a -throwBecknApiError = throwHTTPError toBecknAPIError +throwAPIError = throwHTTPError toAPIError throwHTTPError :: ( ToJSON j, diff --git a/lib/mobility-core/src/Kernel/Utils/Servant/BecknResponseWrapper.hs b/lib/mobility-core/src/Kernel/Utils/Servant/BecknResponseWrapper.hs new file mode 100644 index 000000000..469da5c8e --- /dev/null +++ b/lib/mobility-core/src/Kernel/Utils/Servant/BecknResponseWrapper.hs @@ -0,0 +1,96 @@ +{- + Copyright 2022-23, Juspay India Pvt Ltd + + This program is free software: you can redistribute it and/or modify it under the terms of the GNU Affero General Public License + + as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is + + distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + + FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more details. You should have received a copy of the GNU Affero + + General Public License along with this program. If not, see . +-} +{-# OPTIONS_GHC -Wno-error=deprecations #-} + +module Kernel.Utils.Servant.BecknResponseWrapper + ( wrapBecknResponse, + extractBapIdFromBody, + ) +where + +import qualified Data.Aeson as A +import qualified Data.Aeson.KeyMap as AKM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL +import EulerHS.Prelude +import qualified Network.Wai as Wai + +wrapBecknResponse :: (BL.ByteString -> IO Bool) -> Wai.Middleware +wrapBecknResponse shouldWrap app req respond = do + bodyBs <- consumeRequestBody req + reqWithReplayableBody <- rebindRequestBody req bodyBs + wrap <- shouldWrap bodyBs + if wrap + then app reqWithReplayableBody $ \resp -> do + let (status, headers, withBody) = Wai.responseToStream resp + respBody <- consumeStreamingBody withBody + let final = fromMaybe respBody (wrapIfAckEnvelope respBody) + respond $ Wai.responseLBS status headers final + else app reqWithReplayableBody respond + where + consumeRequestBody :: Wai.Request -> IO BL.ByteString + -- WAI's consumeRequestBodyStrict returns IO BL.ByteString in this codebase (the + -- name refers to strict stream consumption, not the ByteString flavour). Pass + -- through directly. + consumeRequestBody = Wai.consumeRequestBodyStrict + + rebindRequestBody :: Wai.Request -> BL.ByteString -> IO Wai.Request + rebindRequestBody r body = do + consumed <- newIORef False + let replay = do + already <- readIORef consumed + if already + then pure BS.empty + else do + writeIORef consumed True + pure (BL.toStrict body) + pure r {Wai.requestBody = replay} + + consumeStreamingBody :: + ((Wai.StreamingBody -> IO ()) -> IO ()) -> + IO BL.ByteString + consumeStreamingBody withBody = do + ref <- newIORef mempty + withBody $ \streamingBody -> + streamingBody + (\builder -> modifyIORef' ref (<> builder)) + (pure ()) + BB.toLazyByteString <$> readIORef ref + + wrapIfAckEnvelope :: BL.ByteString -> Maybe BL.ByteString + wrapIfAckEnvelope body = do + value <- either (const Nothing) Just (A.eitherDecode body) + guard (isAckEnvelope value) + pure $ A.encode (A.object ["response" A..= value]) + + isAckEnvelope :: A.Value -> Bool + isAckEnvelope (A.Object o) = case AKM.lookup "message" o of + Just (A.Object m) -> AKM.member "ack" m + _ -> False + isAckEnvelope _ = False + +extractBapIdFromBody :: BL.ByteString -> Maybe Text +extractBapIdFromBody body = do + value <- either (const Nothing) Just (A.eitherDecode body) + obj <- case value of + A.Object o -> Just o + _ -> Nothing + context <- case AKM.lookup "context" obj of + Just (A.Object c) -> Just c + _ -> Nothing + bapIdValue <- AKM.lookup "bap_id" context + case bapIdValue of + A.String t -> Just t + _ -> Nothing diff --git a/lib/mobility-core/src/Kernel/Utils/Servant/SignatureAuth.hs b/lib/mobility-core/src/Kernel/Utils/Servant/SignatureAuth.hs index ef474fb1e..634b2542c 100644 --- a/lib/mobility-core/src/Kernel/Utils/Servant/SignatureAuth.hs +++ b/lib/mobility-core/src/Kernel/Utils/Servant/SignatureAuth.hs @@ -119,7 +119,7 @@ instance subserver `addAuthCheck` withRequest authCheck' where authCheck' :: Wai.Request -> DelayedIO SignatureAuthResult - authCheck' req = runFlowRDelayedIO env . becknApiHandler . withLogTag "authCheck" $ do + authCheck' req = runFlowRDelayedIO env . becknAuthHandler . withLogTag "authCheck" $ do let headers = Wai.requestHeaders req pathInfo = Wai.rawPathInfo req (actionTxt, merchantId) <- getLastTwoElements (decodeUtf8 pathInfo) & fromMaybeM (InternalError $ "Beckn " <> show pathInfo <> " path doesn't have merchant id")