mempool: rename MempoolAddFail to TxValidationFail

Author: crocodile-dentist

dmq-node/src/DMQ/NodeToClient.hs

@@ -101,8 +101,8 @@ data Codecs crypto m =
 dmqCodecs :: ( MonadST m
              , Crypto crypto
              )
-          => (MempoolAddFail (Sig crypto)  -> CBOR.Encoding)
-          -> (forall s. CBOR.Decoder s  (MempoolAddFail (Sig crypto)))
+          => (TxValidationFail (Sig crypto)  -> CBOR.Encoding)
+          -> (forall s. CBOR.Decoder s  (TxValidationFail (Sig crypto)))
           -> Codecs crypto m
 dmqCodecs encodeReject' decodeReject' =
   Codecs {
@@ -144,9 +144,8 @@ ntcApps
      , MonadSTM m
      , Crypto crypto
      , Aeson.ToJSON ntcAddr
-     , Aeson.ToJSON (MempoolAddFail (Sig crypto))
-     , Show (MempoolAddFail (Sig crypto))
-     , ShowProxy (MempoolAddFail (Sig crypto))
+     , Aeson.ToJSON (TxValidationFail (Sig crypto))
+     , ShowProxy (TxValidationFail (Sig crypto))
      , ShowProxy (Sig crypto)
      , Typeable crypto
      )

dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs

@@ -26,7 +26,7 @@ localMsgSubmissionServer ::
      , Typeable msgid
      , Typeable msg
      , Show msgid
-     , Show (MempoolAddFail msg))
+     , Show (TxValidationFail msg))
   => (msg -> msgid)
   -- ^ get message id
   -> Tracer m (TraceLocalMsgSubmission msg msgid)
@@ -59,27 +59,27 @@ localMsgSubmissionServer getMsgId tracer MempoolWriter { mempoolAddTxs } =
 data TraceLocalMsgSubmission msg msgid =
     TraceReceivedMsg msgid
   -- ^ A signature was received.
-  | TraceSubmitFailure msgid (MempoolAddFail msg)
+  | TraceSubmitFailure msgid (TxValidationFail msg)
   | TraceSubmitAccept msgid
 
 deriving instance
-     (Show msg, Show msgid, Show (MempoolAddFail msg))
+     (Show msg, Show msgid, Show (TxValidationFail msg))
   => Show (TraceLocalMsgSubmission msg msgid)
 
 
 
 data MsgSubmissionServerException msgid msg =
-    MsgValidationException msgid (MempoolAddFail msg)
+    MsgValidationException msgid (TxValidationFail msg)
   | TooManyMessages
 
-deriving instance (Show (MempoolAddFail msg), Show msgid)
+deriving instance (Show (TxValidationFail msg), Show msgid)
   => Show (MsgSubmissionServerException msgid msg)
 
-instance (Typeable msgid, Typeable msg, Show (MempoolAddFail msg), Show msgid)
+instance (Typeable msgid, Typeable msg, Show (TxValidationFail msg), Show msgid)
   => Exception (MsgSubmissionServerException msgid msg) where
 
 
-instance (ToJSON msgid, ToJSON (MempoolAddFail msg))
+instance (ToJSON msgid, ToJSON (TxValidationFail msg))
       => ToJSON (TraceLocalMsgSubmission msg msgid) where
   toJSON (TraceReceivedMsg msgid) =
     -- TODO: once we have verbosity levels, we could include the full tx, for

dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs

@@ -21,7 +21,7 @@ import Ouroboros.Network.TxSubmission.Mempool.Simple
 
 -- | Type aliases for the high level client API
 --
-type LocalMsgSubmissionClient sig = LocalTxSubmissionClient sig (MempoolAddFail sig)
+type LocalMsgSubmissionClient sig = LocalTxSubmissionClient sig (TxValidationFail sig)
 type LocalMsgClientStIdle     = LocalTxClientStIdle
 
 

dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs

@@ -30,13 +30,13 @@ codecLocalMsgSubmission
      ( MonadST m
      , Crypto crypto
      )
-  => (MempoolAddFail (Sig crypto) -> CBOR.Encoding)
-  -> (forall s. CBOR.Decoder s (MempoolAddFail (Sig crypto)))
+  => (TxValidationFail (Sig crypto) -> CBOR.Encoding)
+  -> (forall s. CBOR.Decoder s (TxValidationFail (Sig crypto)))
   -> AnnotatedCodec (LocalMsgSubmission (Sig crypto)) CBOR.DeserialiseFailure m ByteString
 codecLocalMsgSubmission =
   LTX.anncodecLocalTxSubmission' SigWithBytes SigSubmission.encodeSig SigSubmission.decodeSig
 
-encodeReject :: MempoolAddFail (Sig crypto) -> CBOR.Encoding
+encodeReject :: TxValidationFail (Sig crypto) -> CBOR.Encoding
 encodeReject = \case
   SigInvalid reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 0 <> e
     where
@@ -64,7 +64,7 @@ encodeReject = \case
   SigResultOther reason
                     -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 3 <> CBOR.encodeString reason
 
-decodeReject :: CBOR.Decoder s (MempoolAddFail (Sig crypto))
+decodeReject :: CBOR.Decoder s (TxValidationFail (Sig crypto))
 decodeReject = do
   len <- CBOR.decodeListLen
   tag <- CBOR.decodeWord8

dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs

@@ -22,7 +22,7 @@ import Ouroboros.Network.TxSubmission.Mempool.Simple
 
 -- | Type aliases for the high level client API
 --
-type LocalMsgSubmissionServer sig = LocalTxSubmissionServer sig (MempoolAddFail sig)
+type LocalMsgSubmissionServer sig = LocalTxSubmissionServer sig (TxValidationFail sig)
 
 
 -- | A non-pipelined 'Peer' representing the 'LocalMsgSubmissionServer'.

dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds         #-}
 {-# LANGUAGE TypeFamilies      #-}
 
@@ -19,4 +18,4 @@ import Ouroboros.Network.TxSubmission.Mempool.Simple
 
 -- | The LocalMsgSubmission protocol is an alias for the LocalTxSubmission
 --
-type LocalMsgSubmission sig = Ouroboros.LocalTxSubmission sig (MempoolAddFail sig)
+type LocalMsgSubmission sig = Ouroboros.LocalTxSubmission sig (TxValidationFail sig)

dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs

@@ -2,17 +2,21 @@
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE MultiWayIf         #-}
 {-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE PatternSynonyms    #-}
 {-# LANGUAGE TupleSections      #-}
 {-# LANGUAGE TypeFamilies       #-}
 {-# LANGUAGE TypeOperators      #-}
+{-# LANGUAGE ViewPatterns       #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | Encapsulates signature validation utilities leveraged by the mempool writer
 --
 module DMQ.Protocol.SigSubmission.Validate where
 
 import Control.Monad
 import Control.Concurrent.Class.MonadSTM.Strict
+import Control.Exception (Exception)
 import Control.Monad.Class.MonadTime.SI
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
@@ -45,16 +49,18 @@ import Ouroboros.Network.Util.ShowProxy
 -- | The type of non-fatal failures reported by the mempool writer
 -- for invalid messages
 --
-data instance MempoolAddFail (Sig crypto) =
+data instance TxValidationFail (Sig crypto) =
     SigInvalid SigValidationError
   | SigDuplicate
   | SigExpired
   | SigResultOther Text
   deriving (Eq, Show)
 
-instance (Typeable crypto) => ShowProxy (MempoolAddFail (Sig crypto))
+instance (Typeable crypto) => ShowProxy (TxValidationFail (Sig crypto))
+
+instance (Typeable crypto) => Exception (TxValidationFail (Sig crypto))
 
-instance ToJSON (MempoolAddFail (Sig crypto)) where
+instance ToJSON (TxValidationFail (Sig crypto)) where
   toJSON SigDuplicate = String "duplicate"
   toJSON SigExpired   = String "expired"
   toJSON (SigInvalid e) = object
@@ -84,6 +90,21 @@ data SigValidationError =
   deriving (Eq, Show)
 
 
+c_MAX_CLOCK_SKEW_SEC :: NominalDiffTime
+c_MAX_CLOCK_SKEW_SEC = 5
+
+pattern NotZeroSetSnapshot :: StakeSnapshot
+pattern NotZeroSetSnapshot <- (isZero . ssSetPool -> False)
+
+pattern NotZeroMarkSnapshot :: StakeSnapshot
+pattern NotZeroMarkSnapshot <- (isZero . ssMarkPool -> False)
+
+pattern ZeroSetSnapshot :: StakeSnapshot
+pattern ZeroSetSnapshot <- (isZero . ssSetPool -> True)
+
+{-# COMPLETE NotZeroSetSnapshot, NotZeroMarkSnapshot, ZeroSetSnapshot #-}
+
+
 -- TODO:
 --  We don't validate ocert numbers, since we might not have necessary
 --  information to do so, but we can validate that they are growing.
@@ -99,9 +120,9 @@ validateSig :: forall crypto m.
             -> [Sig crypto]
             -> PoolValidationCtx m
             -- ^ cardano pool id verification
-            -> ExceptT (Sig crypto, MempoolAddFail (Sig crypto)) m
-                       [(Sig crypto, Either (MempoolAddFail (Sig crypto)) ())]
-validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs
+            -> ExceptT (Sig crypto, TxValidationFail (Sig crypto)) m
+                       [(Sig crypto, Either (TxValidationFail (Sig crypto)) ())]
+validateSig verKeyHashingFn sigs ctx = traverse process' sigs
   where
     DMQPoolValidationCtx now mNextEpoch pools ocertCountersVar = ctx
 
@@ -123,33 +144,31 @@ validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs
          ?! KESBeforeStartOCERT startKESPeriod sigKESPeriod
       e <- case Map.lookup (verKeyHashingFn coldKey) pools of
         Nothing | isNothing mNextEpoch
-                  -> invalid SigResultOther $ Text.pack "not initialized yet"
+                  -> right . Left . SigResultOther $ Text.pack "not initialized yet"
                 | otherwise
                   -> left $ SigInvalid UnrecognizedPool
-        -- TODO make 5 a constant
-        Just ss | not (isZero (ssSetPool ss)) ->
+        Just ss | NotZeroSetSnapshot <- ss ->
                     if | now < nextEpoch -> success
                          -- localstatequery is late, but the pool is about to expire
                        | isZero (ssMarkPool ss)
-                       , now > addUTCTime 5 nextEpoch -> left SigExpired
+                       , now > addUTCTime c_MAX_CLOCK_SKEW_SEC nextEpoch -> left SigExpired
                          -- we bound the time we're willing to approve a message
                          -- in case smth happened to localstatequery and it's taking
                          -- too long to update our state
-                       | now <= addUTCTime 5 nextEpoch -> success
-                       | otherwise -> left $ SigInvalid ClockSkew
-                | not (isZero (ssMarkPool ss)) ->
+                       | now <= addUTCTime c_MAX_CLOCK_SKEW_SEC nextEpoch -> success
+                       | otherwise -> right . Left $ SigInvalid ClockSkew
+                | NotZeroMarkSnapshot <- ss ->
                     -- we take abs time in case we're late with our own
                     -- localstatequery update, and/or the other side's clock
                     -- is ahead, and we're just about or have just crossed the epoch
                     -- and the pool is expected to move into the set mark
-                    if | abs (diffUTCTime nextEpoch now) <= 5 -> success
-                       | diffUTCTime nextEpoch now > 5 ->
+                    if | abs (diffUTCTime nextEpoch now) <= c_MAX_CLOCK_SKEW_SEC -> success
+                       | diffUTCTime nextEpoch now > c_MAX_CLOCK_SKEW_SEC ->
                            left . SigResultOther $ Text.pack "pool not eligible yet"
                        | otherwise -> right . Left $ SigInvalid ClockSkew
                   -- pool is deregistered and ineligible to mint blocks
-                | isZero (ssSetPool ss) ->
+                | ZeroSetSnapshot <- ss ->
                     left SigExpired
-                | otherwise -> error "validateSig: impossible pool validation error"
           where
             -- mNextEpoch and pools are initialized in one STM transaction
             -- and fromJust will not fail here
@@ -167,15 +186,14 @@ validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs
         let f = \case
               Nothing -> Right $ Just ocertN
               Just n | n <= ocertN -> Right $ Just ocertN
-                     | otherwise   -> Left . throwE . SigInvalid $ InvalidOCertCounter n ocertN
+                     | otherwise   -> Left $ InvalidOCertCounter n ocertN
         in case Map.alterF f (verKeyHashingFn coldKey) ocertCounters of
           Right ocertCounters' -> (void success, ocertCounters')
-          Left  err            -> (err, ocertCounters)
+          Left  err            -> (throwE (SigInvalid err), ocertCounters)
       -- for eg. remember to run all results with possibly non-fatal errors
       right e
       where
         success = right $ Right ()
-        invalid tag = right . Left . tag
 
         startKESPeriod, endKESPeriod :: KESPeriod
 
@@ -187,12 +205,12 @@ validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs
 
         (?!:) :: Either e1 ()
               -> (e1 -> SigValidationError)
-              -> ExceptT (MempoolAddFail (Sig crypto)) m ()
+              -> ExceptT (TxValidationFail (Sig crypto)) m ()
         (?!:) result f = firstExceptT (SigInvalid . f) . hoistEither $ result
 
         (?!) :: Bool
              -> SigValidationError
-             -> ExceptT (MempoolAddFail (Sig crypto)) m ()
+             -> ExceptT (TxValidationFail (Sig crypto)) m ()
         (?!) flag sve = if flag then void success else left (SigInvalid sve)
 
         infix 1 ?!