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 {
@@ -139,9 +139,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)
@@ -57,27 +57,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
@@ -65,7 +65,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,11 +2,12 @@
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE MultiWayIf         #-}
 {-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections      #-}
 {-# LANGUAGE TypeFamilies       #-}
 {-# LANGUAGE TypeOperators      #-}
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 -- | Encapsulates signature validation utilities leveraged by the mempool writer
 --
 module DMQ.Protocol.SigSubmission.Validate where
@@ -45,16 +46,16 @@ 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 ToJSON (MempoolAddFail (Sig crypto)) where
+instance ToJSON (TxValidationFail (Sig crypto)) where
   toJSON SigDuplicate = String "duplicate"
   toJSON SigExpired   = String "expired"
   toJSON (SigInvalid e) = object
@@ -100,8 +101,8 @@ 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)) ())]
+            -> 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
@@ -124,22 +125,20 @@ validateSig 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)) ->
                     if | now < nextEpoch -> success
                          -- localstatequery is late, but the pool is about to expire
-                       | isZero (ssMarkPool ss) ->
-                           if now <= addUTCTime 5 nextEpoch
-                             then invalid SigInvalid ClockSkew
-                             else left $ SigInvalid ExpiredPool
+                       | isZero (ssMarkPool ss)
+                       , now > addUTCTime 5 nextEpoch -> left $ SigInvalid ExpiredPool
                          -- 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
+                       | otherwise -> right . Left $ SigInvalid ClockSkew
                 | not (isZero (ssMarkPool ss)) ->
                     -- we take abs time in case we're late with our own
                     -- localstatequery update, and/or the other side's clock
@@ -169,15 +168,14 @@ validateSig 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
 
@@ -189,12 +187,12 @@ validateSig 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 ?!

ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs

@@ -6,14 +6,13 @@
 {-# LANGUAGE GADTs                    #-}
 {-# LANGUAGE NamedFieldPuns           #-}
 {-# LANGUAGE ScopedTypeVariables      #-}
-{-# LANGUAGE StandaloneDeriving       #-}
 {-# LANGUAGE TupleSections            #-}
 {-# LANGUAGE TypeFamilies             #-}
 
 -- | The module should be imported qualified.
 --
 module Ouroboros.Network.TxSubmission.Mempool.Simple
-  ( MempoolAddFail
+  ( TxValidationFail
   , Mempool (..)
   , MempoolSeq (..)
   , MempoolWriter (..)
@@ -28,7 +27,6 @@ module Ouroboros.Network.TxSubmission.Mempool.Simple
 import Prelude hiding (read, seq)
 
 import Control.Concurrent.Class.MonadSTM.Strict
-import Control.DeepSeq
 import Control.Exception (assert)
 import Control.Monad.Trans.Except
 import Data.Bifunctor (bimap, first, second)
@@ -116,7 +114,7 @@ getReader getTxId getTxSize (Mempool mempool) =
 
 -- | type of mempool validation errors which are non-fatal
 --
-data family MempoolAddFail tx
+data family TxValidationFail tx
 
 -- | A mempool writer which generalizes the tx submission mempool writer
 -- TODO: We could replace TxSubmissionMempoolWriter with this at some point
@@ -138,7 +136,7 @@ data MempoolWriter txid tx idx m =
        -- returned.
        mempoolAddTxs
          :: [tx]
-         -> m (Either (txid, MempoolAddFail tx) [(txid, SubmitResult (MempoolAddFail tx))])
+         -> m (Either (txid, TxValidationFail tx) [(txid, SubmitResult (TxValidationFail tx))])
     }
 
 
@@ -147,10 +145,9 @@ data MempoolWriter txid tx idx m =
 --
 getWriter :: forall tx txid ctx m.
              ( MonadSTM m
-             -- TODO:
              -- , NFData txid
              -- , NFData tx
-             -- , NFData (MempoolAddFail tx)
+             -- , NFData (TxValidationFail tx)
              , Ord txid
              )
           => (tx -> txid)
@@ -159,11 +156,11 @@ getWriter :: forall tx txid ctx m.
           -- ^ acquire validation context
           -> (   [tx]
               -> ctx
-              -> ExceptT (tx, MempoolAddFail tx) m
-                         [(tx, Either (MempoolAddFail tx) ())])
+              -> ExceptT (tx, TxValidationFail tx) m
+                         [(tx, Either (TxValidationFail tx) ())])
           -- ^ validation function which should evaluate its result to normal form
           -- esp. if it is 'expensive'
-          -> MempoolAddFail tx
+          -> TxValidationFail tx
           -- ^ replace duplicates
           -> Mempool m txid tx
           -> MempoolWriter txid tx Int m
@@ -184,7 +181,7 @@ getWriter getTxId acquireCtx validateTxs duplicateFail (Mempool mempool) =
                 [if duplicate then
                    Left (txid, duplicateFail)
                  else
-                   bimap ((txid,)) (const (txid, tx)) eResult
+                   bimap (txid,) (const (txid, tx)) eResult
                 | (txid, (tx, eResult)) <- vTxs
                 , let duplicate = txid `Set.member` mempoolSet
                 ]