cleanup code for netcrypto sessions

1 files changed, 23 insertions, 0 deletions

diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs
index cb308bce..f9d9f28f 100644
--- a/src/Data/PacketQueue.hs
+++ b/src/Data/PacketQueue.hs
@@ -17,6 +17,7 @@ module Data.PacketQueue
     , packetQueueViewList
     , newOutGoing
     , readyOutGoing
+    , peekPacket
     , tryAppendQueueOutgoing
     , dequeueOutgoing
     , getHighestHandledPacketPlus1
@@ -187,6 +188,27 @@ data OutGoingResult = OGSuccess | OGFull | OGEncodeFail
 readyOutGoing :: PacketOutQueue extra msg wire fromwire -> IO (STM extra)
 readyOutGoing (PacketOutQueue {pktoToWireIO }) = pktoToWireIO
 
+peekPacket :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM (Maybe (wire,Word32))
+peekPacket getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg
+ = do
+    be <- readTVar (buffend pktoOutPQ)
+    let i = be `mod` (qsize pktoOutPQ)
+    let arrayEmpty :: MArray a e m => a Word32 e -> m Bool
+        arrayEmpty ar = do (lowB,highB) <- getBounds ar
+                           let result= lowB > highB
+                           return $ trace ("arrayEmpty result=" ++ show result
+                                        ++ " lowB="    ++ show lowB
+                                        ++ " highB = " ++ show highB
+                                        ++ " i = " ++ show i) result
+    mbPkt <- do emp <- arrayEmpty (pktq pktoOutPQ)
+                if emp then trace "(peekPacket empty)"    $ return Nothing
+                       else trace "(peekPacket nonempty)" $ do
+                                result <- readArray (pktq pktoOutPQ) i
+                                return $ trace ("readArray (isJust result)=="  ++ show (isJust result)) result
+    pktno <- readTVar pktoPacketNo
+    nextno <- readTVar (seqno pktoInPQ)
+    pktoToWire getExtra nextno be pktno msg
+
 -- | Convert a message to packet format and append it to the front of a queue
 --   used for outgoing messages. (Note that ‘front‛ usually means the higher
 --   index in this implementation.)
@@ -210,6 +232,7 @@ tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPac
     pktno <- readTVar pktoPacketNo
     nextno <- readTVar (seqno pktoInPQ)
     mbWire <- pktoToWire getExtra nextno be pktno msg
+    -- TODO all the above lines ^^ can be replaced with call to peekPacket
     case trace "(tryAppendQueueOutgoing mbWire)" mbWire of
         Just (pkt,pktno')
             -> trace "(tryAppendQueueOutgoing A)"