From 5c849844608a6a1c7b7bc5e1c164773a4f985c70 Mon Sep 17 00:00:00 2001
From: KtorZ <matthias.benkort@gmail.com>
Date: Tue, 16 Jun 2020 17:26:50 +0200
Subject: [PATCH] store block production in the pool monitoring worker

---
 .../Cardano/Wallet/Shelley/Compatibility.hs   | 29 ++++++++++++-------
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 19 ++++++++++--
 2 files changed, 35 insertions(+), 13 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
index 1c75931f36e..5ac510ad836 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
@@ -60,6 +60,7 @@ module Cardano.Wallet.Shelley.Compatibility
     , fromPoolDistr
     , fromNonMyopicMemberRewards
     , optimumNumberOfPools
+    , getProducer
 
     , fromBlockNo
     , fromShelleyBlock
@@ -328,6 +329,13 @@ toBlockHeader genesisHash epLength blk =
                 SL.bheaderPrev header
         }
 
+getProducer :: ShelleyBlock -> W.PoolId
+getProducer blk =
+    let
+        O.ShelleyBlock (SL.Block (SL.BHeader header _) _) _ = blk
+    in
+        fromPoolKeyHash $ SL.hashKey (SL.bheaderVk header)
+
 fromShelleyBlock
     :: W.Hash "Genesis"
     -> W.EpochLength
@@ -656,16 +664,15 @@ fromShelleyRegistrationCert
     :: SL.DCert TPraosStandardCrypto
     -> Maybe (W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef)
 fromShelleyRegistrationCert = \case
-    SL.DCertPool (SL.RegPool pp) ->
-        Just $
-            ( W.PoolRegistrationCertificate
-                { W.poolId = fromPoolKeyHash $ SL._poolPubKey pp
-                , W.poolOwners = fromOwnerKeyHash <$> Set.toList (SL._poolOwners pp)
-                , W.poolMargin = fromUnitInterval (SL._poolMargin pp)
-                , W.poolCost = Quantity $ fromIntegral (SL._poolCost pp)
-                }
-            , fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp)
-            )
+    SL.DCertPool (SL.RegPool pp) -> Just
+        ( W.PoolRegistrationCertificate
+            { W.poolId = fromPoolKeyHash $ SL._poolPubKey pp
+            , W.poolOwners = fromOwnerKeyHash <$> Set.toList (SL._poolOwners pp)
+            , W.poolMargin = fromUnitInterval (SL._poolMargin pp)
+            , W.poolCost = Quantity $ fromIntegral (SL._poolCost pp)
+            }
+        , fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp)
+        )
 
     SL.DCertPool (SL.RetirePool{}) ->
         Nothing -- FIXME We need to acknowledge pool retirement
@@ -691,7 +698,7 @@ fromStakeCredential = \case
     SL.KeyHashObj (SL.KeyHash h) ->
         W.ChimericAccount (getHash h)
 
-fromPoolKeyHash :: SL.KeyHash 'SL.StakePool TPraosStandardCrypto -> W.PoolId
+fromPoolKeyHash :: SL.KeyHash rol TPraosStandardCrypto -> W.PoolId
 fromPoolKeyHash (SL.KeyHash h) =
     W.PoolId (getHash h)
 
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 1e86ec231e7..1978d9ce531 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -23,7 +23,7 @@ import Cardano.BM.Data.Severity
 import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Pool.DB
-    ( DBLayer (..) )
+    ( DBLayer (..), ErrPointAlreadyExists (..) )
 import Cardano.Wallet.Api.Types
     ( ApiT (..) )
 import Cardano.Wallet.Network
@@ -44,7 +44,13 @@ import Cardano.Wallet.Primitive.Types
     , SlotId
     )
 import Cardano.Wallet.Shelley.Compatibility
-    ( Shelley, ShelleyBlock, fromShelleyBlock', toBlockHeader, toPoint )
+    ( Shelley
+    , ShelleyBlock
+    , fromShelleyBlock'
+    , getProducer
+    , toBlockHeader
+    , toPoint
+    )
 import Cardano.Wallet.Shelley.Network
     ( NodePoolLsqData (..) )
 import Cardano.Wallet.Unsafe
@@ -220,6 +226,9 @@ monitorStakePools tr gp nl db@DBLayer{..} = do
     forward blocks (_nodeTip, _pparams) = do
         atomically $ forM_ blocks $ \blk -> do
             let (slot, registrations) = fromShelleyBlock' getEpochLength blk
+            runExceptT (putPoolProduction (getHeader blk) (getProducer blk)) >>= \case
+                Left e   -> liftIO $ traceWith tr $ MsgErrProduction e
+                Right () -> pure ()
             forM_ registrations $ \(pool, metadata) -> do
                 liftIO $ traceWith tr $ MsgStakePoolRegistration pool
                 putPoolRegistration slot pool
@@ -233,6 +242,7 @@ data StakePoolLog
     | MsgCrashMonitoring
     | MsgRollingBackTo SlotId
     | MsgStakePoolRegistration PoolRegistrationCertificate
+    | MsgErrProduction ErrPointAlreadyExists
     deriving (Show, Eq)
 
 instance HasPrivacyAnnotation StakePoolLog
@@ -244,6 +254,7 @@ instance HasSeverityAnnotation StakePoolLog where
         MsgCrashMonitoring{} -> Error
         MsgRollingBackTo{} -> Info
         MsgStakePoolRegistration{} -> Info
+        MsgErrProduction{} -> Error
 
 instance ToText StakePoolLog where
     toText = \case
@@ -263,3 +274,7 @@ instance ToText StakePoolLog where
             "Rolling back to " <> pretty point
         MsgStakePoolRegistration pool ->
             "Discovered stake pool registration: " <> pretty pool
+        MsgErrProduction (ErrPointAlreadyExists blk) ->  mconcat
+            [ "Couldn't store production for given block before it conflicts "
+            , "with another block. Conflicting block header is: ", pretty blk
+            ]