badge-service: log each request's command and each store check's outcome

apps/simplex-badge-service/src/BadgeService/Service.hs

@@ -381,6 +381,7 @@ handleServiceRequest key verifier checks cc trackerQ_ User {userId} reqId sigKey
   resp <-
     badgeServiceResponse key verifier checks cc trackerQ_ sigKey reqData `catchOwn'` \_ ->
       logError ("badge service request " <> reqIdT <> " failed") $> errorResponse BSEInternal
+  logInfo $ "badge answer: " <> responseName resp
   sendChatCmd cc (APISendServiceResponse userId reqId (responseObject resp)) >>= \case
     Right _ -> pure ()
     Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e
@@ -408,7 +409,7 @@ badgeServiceResponse key verifier checks cc trackerQ_ sigKey reqData = case J.fr
   J.Success BadgeServiceRequest {version, purchaseKey, request}
     | not (version `isCompatible` supportedBadgeServiceVRange) -> pure $ errorResponse BSEUnsupportedVersion
     | purchaseKey /= sigKey -> pure $ errorResponse BSEBadRequest
-    | otherwise -> case request of
+    | otherwise -> logInfo ("badge request: " <> commandName request) >> case request of
         BSCRedeemBadgeCode {masterKey, code} -> case purchaseKey of
           Just k -> redeemCode key cc trackerQ_ k masterKey code
           Nothing -> pure $ errorResponse BSEBadRequest
@@ -658,6 +659,35 @@ firstChargeNotGranted provider = \case
 
 -- | A forged receipt and a refunded one are both receipt_invalid, so the client learns nothing a
 -- forger could iterate on. A test purchase is named, since the device that made it already knows.
+-- | What each request was answered, to pair with its command in a log. No payload: a credential,
+-- an invoice and a statement are the client's, and an error's message can quote what it refused.
+responseName :: BadgeServiceResponse -> Text
+responseName = \case
+  BSPBadgeCatalog {} -> "catalog"
+  BSPBadgeInvoice {} -> "invoice"
+  BSPBadgeCredential {credential = Just _, subscription} ->
+    "badge issued" <> maybe "" (\s -> ", subscription " <> tshow s) subscription
+  BSPBadgeCredential {credential = Nothing} -> "no month to issue"
+  BSPError {code} -> "error " <> tshow code
+
+-- | The command each request ran, so a log can be followed without the request ids. No payload:
+-- a payment holds a store receipt, and an upgrade a receipt code.
+commandName :: BadgeServiceCommand -> Text
+commandName = \case
+  BSCGetBadgeCatalog -> "getBadgeCatalog"
+  BSCGetBadgeInvoice {} -> "getBadgeInvoice"
+  BSCRedeemBadgeCode {} -> "redeemBadgeCode"
+  BSCPurchaseBadge {payment} -> "purchaseBadge " <> paymentName payment
+  BSCUpgradeBadgeSubscription {payment} -> "upgradeBadgeSubscription " <> paymentName payment
+  BSCIssueBadge {} -> "issueBadge"
+  BSCPauseBadge -> "pauseBadge"
+  where
+    paymentName = \case
+      SPApple {} -> "(App Store)"
+      SPGoogle {} -> "(Play)"
+      SPInvoice {} -> "(invoice)"
+      SPReceipt {} -> "(receipt)"
+
 storeRefusalResponse :: StoreRefusal -> IO BadgeServiceResponse
 storeRefusalResponse = \case
   SRInvalid reason -> logInfo ("store receipt refused: " <> reason) $> errorResponse BSEReceiptInvalid

apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs

@@ -22,6 +22,7 @@ module BadgeService.StoreReceipts
   )
 where
 
+import BadgeService.Log (logInfo)
 import Control.Exception (Exception, catch, evaluate, try)
 import qualified Data.ByteString.Lazy as LB
 import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, isControl, isDigit, isPrint, isSpace)
@@ -64,6 +65,17 @@ data StoreRefusal
   | SRNotConfigured -- no verifier for this store is deployed; the purchase may be real
   deriving (Eq, Show)
 
+-- | What a refusal was, for a log. The reasons carry no receipt, token or key: a store request's
+-- exceptions are reduced to their kind, and an unsendable token to its shape.
+refusalLabel :: StoreRefusal -> Text
+refusalLabel = \case
+  SRInvalid reason -> "invalid: " <> reason
+  SRTestPurchase -> "a test purchase"
+  SRPending -> "not settled yet"
+  SRUnreachable reason -> "no answer: " <> reason
+  SRVerifierFailed reason -> "this service failed: " <> reason
+  SRNotConfigured -> "no verifier configured"
+
 -- | Apple's receipt is verified offline, from the certificate chain it ships; a Play token is opaque
 -- and must be asked about, and a subscription's charges are known only to its store, so those fields are in IO.
 data StoreVerifier = StoreVerifier
@@ -159,9 +171,12 @@ toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, ackn
   where
     unconfigured = pure $ Left SRNotConfigured
     -- nothing was fetched, so a throw or an overrun is this service's failure or a shape it does not know, never an outage
-    offline verdict =
-      (fromMaybe (Left $ SRVerifierFailed "apple verifier timed out") <$> timeout verifyTimeout (forced verdict))
-        `catchOwn'` \_ -> pure $ Left $ SRVerifierFailed "apple verifier threw"
+    offline verdict = do
+      r <-
+        (fromMaybe (Left $ SRVerifierFailed "apple verifier timed out") <$> timeout verifyTimeout (forced verdict))
+          `catchOwn'` \_ -> pure $ Left $ SRVerifierFailed "apple verifier threw"
+      logInfo $ "apple receipt: " <> either refusalLabel (const "vouched") r
+      pure r
     online = askStore verifyTimeout
 
 -- | Both stores are asked online about a subscription, so a throw or an overrun is no verdict. A test
@@ -182,9 +197,13 @@ newtype StoreVerifierFailure = StoreVerifierFailure Text
 instance Exception StoreVerifierFailure
 
 askStore :: Int -> Text -> IO (Either StoreRefusal a) -> IO (Either StoreRefusal a)
-askStore limit what call =
-  (fromMaybe (Left $ SRUnreachable $ what <> " timed out") <$> timeout limit ((call >>= forced) `catch` verifierFailed))
-    `catchOwn'` \_ -> pure $ Left $ SRUnreachable $ what <> " threw"
+askStore limit what call = do
+  r <-
+    (fromMaybe (Left $ SRUnreachable $ what <> " timed out") <$> timeout limit ((call >>= forced) `catch` verifierFailed))
+      `catchOwn'` \_ -> pure $ Left $ SRUnreachable $ what <> " threw"
+  -- that the store was asked and what came of it, since not every path answers with the refusal
+  logInfo $ what <> ": " <> either refusalLabel (const "vouched") r
+  pure r
   where
     verifierFailed (StoreVerifierFailure reason) = pure $ Left $ SRVerifierFailed reason