Merge pull request #485 from input-output-hk/KtorZ/logging-api-layer

Review logging in API layer

lib/bech32/src/Codec/Binary/Bech32/Internal.hs

@@ -753,7 +753,7 @@ locateErrors residue len
           let p1 = (l_s1 - l_s0 + 1023) `mod` 1023 in
           if (p1 >= len) then [] else
           let l_e1 = l_s0 + (1023 - 997) * p1 in
-          if (l_e1 `mod` 33 > 0) then [] else [p1]
+          [p1 | l_e1 `mod` 33 <= 0]
     | otherwise =
           case filter (not . null) $ map findError [0 .. len - 1] of
               [] -> []

lib/core/src/Cardano/Wallet.hs

@@ -44,7 +44,7 @@ import Prelude hiding
     ( log )
 
 import Cardano.BM.Trace
-    ( Trace, logDebug, logError, logInfo )
+    ( Trace, appendName, logDebug, logError, logInfo, logNotice )
 import Cardano.Wallet.DB
     ( DBLayer
     , ErrNoSuchWallet (..)
@@ -88,6 +88,7 @@ import Cardano.Wallet.Primitive.Model
     , applyBlocks
     , availableUTxO
     , currentTip
+    , getPending
     , getState
     , initWallet
     , newPending
@@ -130,7 +131,7 @@ import Control.DeepSeq
 import Control.Monad
     ( forM, unless )
 import Control.Monad.IO.Class
-    ( liftIO )
+    ( MonadIO, liftIO )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
@@ -157,17 +158,20 @@ import Data.Quantity
     ( Quantity (..) )
 import Data.Text
     ( Text )
+import Data.Text.Class
+    ( toText )
 import Data.Time.Clock
     ( getCurrentTime )
 import Fmt
-    ( blockListF, pretty, (+|), (+||), (|+), (||+) )
+    ( Buildable, blockListF, pretty, (+|), (+||), (|+), (||+) )
 
 import qualified Cardano.Wallet.DB as DB
 import qualified Cardano.Wallet.Primitive.CoinSelection.Random as CoinSelection
 import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Data.List as L
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
+import qualified Data.Text as T
 
 {-------------------------------------------------------------------------------
                                  Types
@@ -333,7 +337,7 @@ cancelWorker (WorkerRegistry mvar) wid =
 
 -- | Create a new instance of the wallet layer.
 newWalletLayer
-    :: forall s t. ()
+    :: forall s t. (Buildable (Tx t))
     => Trace IO Text
     -> Block (Tx t)
         -- ^ Very first block
@@ -343,6 +347,9 @@ newWalletLayer
     -> TransactionLayer t
     -> IO (WalletLayer s t)
 newWalletLayer tracer block0 feePolicy db nw tl = do
+    logDebugT $ "Wallet layer starting with: "
+        <> "block0: "+| block0 |+ ", "
+        <> "fee policy: "+|| feePolicy ||+""
     registry <- newRegistry
     return WalletLayer
         { createWallet = _createWallet
@@ -359,6 +366,15 @@ newWalletLayer tracer block0 feePolicy db nw tl = do
         , attachPrivateKey = _attachPrivateKey
         }
   where
+    logDebugT :: MonadIO m => Text -> m ()
+    logDebugT = liftIO . logDebug tracer
+
+    logInfoT :: MonadIO m => Text -> m ()
+    logInfoT = liftIO . logInfo tracer
+
+    debug :: (Buildable a, MonadIO m) => Text -> a -> m a
+    debug msg a = logDebugT (msg <> pretty a) $> a
+
     {---------------------------------------------------------------------------
                                        Wallets
     ---------------------------------------------------------------------------}
@@ -438,14 +454,16 @@ newWalletLayer tracer block0 feePolicy db nw tl = do
         -> ExceptT ErrNoSuchWallet IO ()
     _restoreWallet re wid = do
         (w, _) <- _readWallet wid
-        liftIO $ logInfo tracer $ "restoring wallet: " +|| wid ||+ ""
+        let workerName = "worker." <> T.take 8 (toText wid)
+        t <- liftIO $ appendName workerName tracer
+        liftIO $ logInfo t $ "Restoring wallet "+| wid |+"..."
         worker <- liftIO $ forkIO $ do
             runExceptT (networkTip nw) >>= \case
                 Left e -> do
-                    logError tracer $ "restoreSleep: " +|| e ||+ ""
-                    restoreSleep wid (currentTip w)
+                    logError t $ "Failed to get network tip: " +|| e ||+ ""
+                    restoreSleep t wid (currentTip w)
                 Right tip -> do
-                    restoreStep wid (currentTip w, tip)
+                    restoreStep t wid (currentTip w, tip)
         liftIO $ registerWorker re (wid, worker)
 
     -- | Infinite restoration loop. We drain the whole available chain and try
@@ -455,56 +473,59 @@ newWalletLayer tracer block0 feePolicy db nw tl = do
     -- The function only terminates if the wallet has disappeared from the DB.
     restoreStep
         :: (DefineTx t)
-        => WalletId
+        => Trace IO Text
+        -> WalletId
         -> (BlockHeader, BlockHeader)
         -> IO ()
-    restoreStep wid (slot, tip) = do
+    restoreStep t wid (slot, tip) = do
         runExceptT (nextBlocks nw slot) >>= \case
             Left e -> do
-                logError tracer $ "restoreStep: " +|| e ||+ ""
-                restoreSleep wid slot
+                logError t $ "Failed to get next blocks: " +|| e ||+ "."
+                restoreSleep t wid slot
             Right [] -> do
-                restoreSleep wid slot
+                logDebug t "Wallet restored."
+                restoreSleep t wid slot
             Right blocks -> do
                 let next = view #header . last $ blocks
-                runExceptT (restoreBlocks wid blocks (tip ^. #slotId)) >>= \case
-                    Left (ErrNoSuchWallet _) -> logError tracer $
-                        "restoreStep: wallet " +| wid |+ " is gone!"
+                runExceptT (restoreBlocks t wid blocks (tip ^. #slotId)) >>= \case
+                    Left (ErrNoSuchWallet _) ->
+                        logNotice t "Wallet is gone! Terminating worker..."
                     Right () -> do
-                        restoreStep wid (next, tip)
+                        restoreStep t wid (next, tip)
 
     -- | Wait a short delay before querying for blocks again. We do take this
     -- opportunity to also refresh the chain tip as it has probably increased
     -- in order to refine our syncing status.
     restoreSleep
         :: (DefineTx t)
-        => WalletId
+        => Trace IO Text
+        -> WalletId
         -> BlockHeader
         -> IO ()
-    restoreSleep wid slot = do
+    restoreSleep t wid slot = do
         let tenSeconds = 10000000 in threadDelay tenSeconds
         runExceptT (networkTip nw) >>= \case
             Left e -> do
-                logError tracer $ "restoreSleep: " +|| e ||+ ""
-                restoreSleep wid slot
+                logError t $ "Failed to get network tip: " +|| e ||+ ""
+                restoreSleep t wid slot
             Right tip ->
-                restoreStep wid (slot, tip)
+                restoreStep t wid (slot, tip)
 
     -- | Apply the given blocks to the wallet and update the wallet state,
     -- transaction history and corresponding metadata.
     restoreBlocks
         :: (DefineTx t)
-        => WalletId
+        => Trace IO Text
+        -> WalletId
         -> [Block (Tx t)]
         -> SlotId -- ^ Network tip
         -> ExceptT ErrNoSuchWallet IO ()
-    restoreBlocks wid blocks tip = do
+    restoreBlocks t wid blocks tip = do
         let (inf, sup) =
                 ( view #slotId . header . head $ blocks
                 , view #slotId . header . last $ blocks
                 )
-        liftIO $ logInfo tracer $
-            "Applying blocks ["+| inf |+" ... "+| sup |+"]"
+        liftIO $ logInfo t $ "Applying blocks ["+| inf |+" ... "+| sup |+"]"
 
         -- NOTE
         -- Not as good as a transaction, but, with the lock, nothing can make
@@ -519,16 +540,19 @@ newWalletLayer tracer block0 feePolicy db nw tl = do
             let nonEmpty = not . null . transactions
             let (h,q) = first (filter nonEmpty) $
                     splitAt (length blocks - 1) blocks
+            liftIO $ logDebug t $ pretty (h ++ q)
             let (txs, cp') = applyBlocks @s @t (h ++ q) cp
             let progress = slotRatio sup tip
             let status' = if progress == maxBound
                     then Ready
                     else Restoring progress
             let meta' = meta { status = status' } :: WalletMetadata
-            liftIO $ logInfo tracer $
-                "Tx History: " +|| length txs ||+ ""
-            unless (null txs) $ liftIO $ logDebug tracer $ pretty $
-                blockListF (snd <$> Map.elems txs)
+            let nPending = Set.size (getPending cp')
+            liftIO $ logInfo t $ pretty meta'
+            liftIO $ logInfo t $ nPending ||+" transaction(s) pending."
+            liftIO $ logInfo t $ length txs ||+ " new transaction(s) discovered."
+            unless (null txs) $ liftIO $ logDebug t $
+                pretty $ blockListF (snd <$> Map.elems txs)
             DB.putCheckpoint db (PrimaryKey wid) cp'
             DB.putTxHistory db (PrimaryKey wid) txs
             DB.putWalletMeta db (PrimaryKey wid) meta'
@@ -575,12 +599,13 @@ newWalletLayer tracer block0 feePolicy db nw tl = do
         let utxo = availableUTxO @s @t w
         (sel, utxo') <- withExceptT ErrCreateUnsignedTxCoinSelection $
             CoinSelection.random opts recipients utxo
+        logInfoT $ "Coins selected for transaction: \n"+| sel |+""
         withExceptT ErrCreateUnsignedTxFee $ do
             let feeOpts = FeeOptions
                     { estimate = computeFee feePolicy . estimateSize tl
                     , dustThreshold = minBound
                     }
-            adjustForFee feeOpts utxo' sel
+            debug "Coins after fee adjustment" =<< adjustForFee feeOpts utxo' sel
 
     _signTx
         :: (Show s, NFData s, IsOwned s, GenChange s)

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

@@ -7,6 +7,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -180,6 +181,12 @@ data WalletMetadata = WalletMetadata
 
 instance NFData WalletMetadata
 
+instance Buildable WalletMetadata where
+    build (WalletMetadata wName wTime _ wStatus wDelegation) = mempty
+        <> build wName <> " (" <> build wStatus <> "), "
+        <> "created at " <> build wTime <> ", "
+        <> build wDelegation
+
 -- | Length-restricted name of a wallet
 newtype WalletName = WalletName { getWalletName ::  Text }
     deriving (Generic, Eq, Show)
@@ -202,6 +209,9 @@ instance FromText WalletName where
 instance ToText WalletName where
     toText = getWalletName
 
+instance Buildable WalletName where
+    build = build . toText
+
 -- | Calling 'fromText @WalletName' on shorter longer string will fail.
 walletNameMinLength :: Int
 walletNameMinLength = 1
@@ -246,13 +256,27 @@ instance Ord WalletState where
     Restoring _ <= Ready = True
     Restoring a <= Restoring b = a <= b
 
+instance Buildable WalletState where
+    build = \case
+        Ready ->
+            "restored"
+        Restoring (Quantity p) ->
+            "still restoring (" <> build (toText p) <> ")"
+
 data WalletDelegation poolId
     = NotDelegating
     | Delegating !poolId
     deriving (Generic, Eq, Show)
 deriving instance Functor WalletDelegation
 instance NFData poolId => NFData (WalletDelegation poolId)
 
+instance Buildable poolId => Buildable (WalletDelegation poolId) where
+    build = \case
+        NotDelegating ->
+            "not delegating"
+        Delegating poolId ->
+            "delegating to " <> build poolId
+
 newtype WalletPassphraseInfo = WalletPassphraseInfo
     { lastUpdatedAt :: UTCTime }
     deriving (Generic, Eq, Ord, Show)
@@ -276,6 +300,9 @@ newtype PoolId = PoolId
 
 instance NFData PoolId
 
+instance Buildable PoolId where
+    build = build . getPoolId
+
 {-------------------------------------------------------------------------------
                                     Block
 -------------------------------------------------------------------------------}
@@ -555,7 +582,6 @@ instance Buildable Coin where
 isValidCoin :: Coin -> Bool
 isValidCoin c = c >= minBound && c <= maxBound
 
-
 {-------------------------------------------------------------------------------
                                     UTxO
 -------------------------------------------------------------------------------}

lib/core/src/Data/Quantity.hs

@@ -30,8 +30,12 @@ module Data.Quantity
 
 import Prelude
 
+import Control.Arrow
+    ( left )
 import Control.DeepSeq
     ( NFData )
+import Control.Monad
+    ( unless )
 import Data.Aeson
     ( FromJSON (..)
     , ToJSON (..)
@@ -46,7 +50,9 @@ import Data.Aeson.Types
 import Data.Proxy
     ( Proxy (..) )
 import Data.Text.Class
-    ( FromText (..), ToText (..) )
+    ( FromText (..), TextDecodingError (..), ToText (..) )
+import Data.Text.Read
+    ( decimal )
 import GHC.Generics
     ( Generic )
 import GHC.TypeLits
@@ -136,6 +142,18 @@ instance Enum Percentage where
     fromEnum (Percentage p) = fromEnum p
     toEnum = either (error . ("toEnum: " <>) . show) id . mkPercentage
 
+instance ToText Percentage where
+    toText (Percentage p) = T.pack (show p) <> "%"
+
+instance FromText Percentage where
+    fromText txt = do
+        (p, u) <- left (const err) $ decimal txt
+        unless (u == "%") $ Left err
+        left (const err) $ mkPercentage @Integer p
+      where
+        err = TextDecodingError
+            "expected a value between 0 and 100 with a '%' suffix (e.g. '14%')"
+
 -- | Safe constructor for 'Percentage'
 mkPercentage
     :: Integral i