Permalink
Browse files

Clean types

  • Loading branch information...
coot committed Jan 10, 2019
1 parent b77bc77 commit 4bc057c0c01daddbaf70a298dfce9d94dd57089e
@@ -26,23 +26,26 @@ data TxSubmission (n :: Nat) tx err m a where
-> TxSubmission n tx err m a
TxSubmissionDone
:: a
-> TxSubmissionHandler err m
-> TxSubmissionErrHandler err m a
-> TxSubmission n tx err m a

instance Functor m => Functor (TxSubmission n tx err m) where
fmap f (TxSubmission tx cli) = TxSubmission tx (fmap f cli)
fmap f (TxSubmissionDone a h) = TxSubmissionDone (f a) h
fmap f (TxSubmissionDone a h) = TxSubmissionDone (f a) (fmap f h)

newtype TxSubmissionHandler err m = TxSubmissionHandler {
runTxSubmissionHandler :: Maybe err -> m ()
newtype TxSubmissionErrHandler err m a = TxSubmissionErrHandler {
runTxSubmissionErrHandler :: Maybe err -> m a
}

instance Functor m => Functor (TxSubmissionErrHandler err m) where
fmap f (TxSubmissionErrHandler g) = TxSubmissionErrHandler $ (fmap . fmap) f g

txSubmissionClientFromList
:: ( Applicative m
)
=> SNat l
-> NonEmpty tx
-> TxSubmissionHandler err m
-> TxSubmissionErrHandler err m [tx]
-> TxSubmissionClient l tx err m [tx]
txSubmissionClientFromList (SSucc _) (tx :| []) txHandler
= TxSubmissionClient $ pure $ TxSubmission tx (TxSubmissionClient $ pure $ TxSubmissionDone [] txHandler)
@@ -55,7 +58,7 @@ txSubmissionClientFromProducer
:: Monad m
=> SNat l
-> Producer tx m ()
-> TxSubmissionHandler err m
-> TxSubmissionErrHandler err m (Producer tx m ())
-> TxSubmissionClient l tx err m (Producer tx m ())
txSubmissionClientFromProducer (SSucc sl) producer txHandler = TxSubmissionClient $
Pipes.next producer >>= \nxt -> case nxt of
@@ -74,7 +77,7 @@ txSubmissionClientStream
-> Peer (TxSubmissionProtocolN n) (TxSubmissionMessage n tx err)
(Yielding (StIdle Zero))
(Finished StDone)
m ()
m a
txSubmissionClientStream = f SZero
where
f :: forall (k :: Nat) (n :: Nat) (l :: Nat) tx err m a.
@@ -86,7 +89,7 @@ txSubmissionClientStream = f SZero
-> Peer (TxSubmissionProtocolN n) (TxSubmissionMessage n tx err)
(Yielding (StIdle k))
(Finished StDone)
m ()
m a
f sk sn sl (TxSubmissionClient submit) = lift $ submit >>= \cli -> case cli of
TxSubmission tx scli ->
-- recursievly send all transactions
@@ -100,4 +103,4 @@ txSubmissionClientStream = f SZero
-- await for server response
await $ \(MsgServerDone merr) ->
-- end the protocol
lift $ done <$> runTxSubmissionHandler txHandler merr
lift $ done <$> runTxSubmissionErrHandler txHandler merr
@@ -13,12 +13,8 @@ import Data.Functor (($>))
import Protocol.Core
import Ouroboros.Network.Protocol.TxSubmission.Type

newtype TxSubmissionServer tx err m a = TxSubmissionServer {
runTxSubmissionServer :: m (TxSubmissionHandlers tx err m a)
}

data TxSubmissionHandlers tx err m a = TxSubmissionHandlers {
handleTx :: tx -> m (TxSubmissionHandlers tx err m a),
data TxSubmissionServer tx err m a = TxSubmissionServer {
handleTx :: tx -> m (TxSubmissionServer tx err m a),
handleTxDone :: m (Either err a)
}

@@ -30,11 +26,11 @@ txSubmissionServer
-> ([tx] -> m err) -- error handler
-> a
-> TxSubmissionServer tx err m a
txSubmissionServer handleTx validateTx handleErr result = TxSubmissionServer $ pure (go [])
txSubmissionServer handleTx validateTx handleErr result = go []
where
go :: [tx] -- malformed transactions
-> TxSubmissionHandlers tx err m a
go errs = TxSubmissionHandlers {
-> TxSubmissionServer tx err m a
go errs = TxSubmissionServer {
handleTx = \tx -> validateTx tx >>= \txValid -> if txValid
then handleTx tx $> go errs
else pure $ go (tx : errs),
@@ -63,15 +59,15 @@ txSubmissionServerStream
(Awaiting (StIdle Zero))
(Finished StDone)
m (Maybe a)
txSubmissionServerStream sn (TxSubmissionServer server) = lift $ go SZero <$> server
txSubmissionServerStream sn = go SZero
where
go :: SNat i
-> TxSubmissionServer tx err m a
-> Peer (TxSubmissionProtocolN n) (TxSubmissionMessage n tx err)
(Awaiting (StIdle k))
(Finished StDone)
m (Maybe a)
go si TxSubmissionHandlers {handleTx, handleTxDone} =
go si TxSubmissionServer {handleTx, handleTxDone} =
await $ \msg -> case msg of
MsgTx tx -> case SSucc si `lessEqualThan` sn of
STrue -> lift $ go (SSucc si) <$> handleTx tx

0 comments on commit 4bc057c

Please sign in to comment.