2 files changed, 97 insertions, 48 deletions

diff --git a/src/Data/Word64RangeMap.hs b/src/Data/Word64RangeMap.hs
index f4736d59..2e4cc8b7 100644
--- a/src/Data/Word64RangeMap.hs
+++ b/src/Data/Word64RangeMap.hs
@@ -20,14 +20,14 @@ import Data.IORef
 
 type OuterIndex = Int
 type Index = Word64
-type InnerArray b = UArray Index b
+type InnerArray b = Array Index b
 
 -- | Although this type includes a parameter for index, the code assumes bounds start at 0
 -- and the index has 'Integral', and 'Num' instances.
 newtype RefArray r ma i e = RefArray (r (ma i e))
 
 -- convenient contraint kind
-type RangeArray rangeArray m b ref = (IArray UArray b, MArray rangeArray (InnerArray b) m, Reference ref m)
+type RangeArray rangeArray m b ref = (MArray rangeArray (InnerArray b) m, Reference ref m)
 -- The RangeMap type, to be used with the above constraint
 type RangeMap rangeArray b ref = RefArray ref rangeArray OuterIndex (InnerArray b)
 
@@ -64,7 +64,7 @@ instance (Reference r m, MArray ma e m) => MArray (RefArray r ma) e m where
     unsafeWrite (RefArray r) i e = modifyRef r (\x -> Base.unsafeWrite x i e >> return (x,()))
 -}
 
-emptySTMRangeMap :: STM (RangeMap TArray Word8 TVar)
+emptySTMRangeMap :: STM (RangeMap TArray a TVar)
 emptySTMRangeMap = RefArray <$>
                      (newTVar =<<
                         newListArray (0,-1) [])
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index d5a49816..fabbf21d 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -32,7 +32,9 @@ import Data.Maybe
 import qualified Data.Word64Map as W64
 import Data.Word64RangeMap
 import qualified Data.Set         as Set
-import qualified Data.Array.Unboxed as A
+import qualified Data.Word64RangeMap.Unboxed as U
+import qualified Data.Array.Unboxed as U
+import qualified Data.Array as A
 import SensibleDir
 import System.FilePath
 import System.Environment
@@ -189,7 +191,7 @@ type NetCryptoHook = IOHook NetCryptoSession CryptoMessage
 -- | Convert an id byte to it's type (in Word64 format)
 -- Although the type doesn't enforce it, MsgTypeArray
 -- should always have 256 entries.
-type MsgTypeArray = A.UArray Word8 Word64
+type MsgTypeArray = U.UArray Word8 Word64
 
 -- | Information, that may be made visible in multiple sessions, as well
 -- as displayed in some way to the user via mutiple views.
@@ -302,6 +304,9 @@ data NetCryptoSession = NCrypto
     -- The remaining fields correspond to implementation specific state --
     -- where as the prior fields will be used in any implementation     --
     , ncHooks              :: TVar (Map.Map MessageType [NetCryptoHook])
+    , ncOutHooks           :: RangeMap TArray
+                                       (TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted)))
+                                       TVar
     , ncUnrecognizedHook   :: TVar (MessageType -> NetCryptoHook)
     , ncIdleEventHooks     :: TVar [(Int,NetCryptoSession -> IO ())]
     , ncIncomingTypeArray  :: TVar MsgTypeArray
@@ -315,7 +320,7 @@ data NetCryptoSession = NCrypto
     -- always escapes.
     --
     -- Currently, the values at these indices are ignored.
-    , ncOutgoingIdMap      :: RangeMap TArray Word8 TVar
+    , ncOutgoingIdMap      :: U.RangeMap TArray Word8 TVar
     -- ^ used to lookup the outgoing id for a type when sending an outoing message
     , ncOutgoingIdMapEscapedLossy :: TVar (A.Array Word8 Word8)
     -- ^ mapping of secondary id, when primary id is 0xC7
@@ -363,7 +368,7 @@ data NetCryptoSession = NCrypto
     , ncOutgoingQueue      :: TVar
                                 (UponHandshake
                                     (PQ.PacketOutQueue
-                                          (State,Nonce24,RangeMap TArray Word8 TVar)
+                                          (State,Nonce24,U.RangeMap TArray Word8 TVar)
                                           CryptoMessage
                                           (CryptoPacket Encrypted)
                                           CryptoData))
@@ -495,7 +500,7 @@ type XMessage = CryptoMessage -- todo
 --    rangemap <- readTVar (ncOutgoingIdMap session)
 --    return (state,n24,rangemap)
 
-ncToWire :: STM (State,Nonce24,RangeMap TArray Word8 TVar)
+ncToWire :: STM (State,Nonce24,U.RangeMap TArray Word8 TVar)
          -> Word32{- packet number we expect to recieve -}
          -> Word32{- buffer_end -}
          -> Word32{- packet number -}
@@ -512,7 +517,7 @@ ncToWire getState seqno bufend pktno msg = do
     (state,n24,msgOutMapVar) <- getState
     -- msgOutMap <- readTVar msgOutMapVar
     result1 <- dtrace XNetCrypto ("lookupInRangeMap typ64=" ++ show typ64 ++ " " ++ show typ ++ show msg)
-                $ lookupInRangeMap typ64 msgOutMapVar
+                $ U.lookupInRangeMap typ64 msgOutMapVar
     case result1 of -- msgOutMapLookup typ64 msgOutMap of
         Nothing -> dtrace XNetCrypto "lookupInRangeMap gave Nothing!" $ return Nothing
         Just outid -> dtrace XNetCrypto ("encrypting packet with Nonce: " ++ show n24) $ do
@@ -589,18 +594,26 @@ freshCryptoSession  sessions
     ncIdleEventHooks0 <- newTVar (defaultIdleEventHooks sessions)
     ncIncomingTypeArray0 <- newTVar (msgTypeArray sessions)
     let idMap = foldl (\mp (x,y) -> W64.insert x y mp) W64.empty (zip [0..255] [0..255])
-    (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap) <- do
-        idmap <- emptySTMRangeMap
-        insertArrayAt idmap  0 (A.listArray (0,255) [0 .. 255])
+    (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap,ncOutHooks0) <- do
+        idmap <- U.emptySTMRangeMap
+        U.insertArrayAt idmap  0 (U.listArray (0,255) [0 .. 255])
         -- the 2 escape ranges are adjacent, so put them in one array:
-        insertArrayAt idmap  512 (A.listArray (512,1023) ( replicate 256 0xC7 -- lossy escaped
-                                                        ++ replicate 256 0x63 -- lossless escapped
-                                                         ))
+        U.insertArrayAt idmap  512 (U.listArray (512,1023) ( replicate 256 0xC7 -- lossy escaped
+                                                          ++ replicate 256 0x63 -- lossless escapped
+                                                           ))
         -- lossless as separate range could have been done:
         -- > insertArrayAt idmap  768 (A.listArray (768,1023)  (replicate 256 0x63))
-        lossyEsc    <- newTVar $ A.listArray (0,255) [0 .. 255]
-        losslessEsc <- newTVar $ A.listArray (0,255) [0 .. 255]
-        return (idmap,lossyEsc,losslessEsc)
+        lossyEsc    <- newTVar $ U.listArray (0,255) [0 .. 255]
+        losslessEsc <- newTVar $ U.listArray (0,255) [0 .. 255]
+        outHooks <- emptySTMRangeMap
+        mapM_ ($ outHooks) -- TODO: combine into larger ranges for faster lookup
+            [ insertWhereItGoes (A.listArray (2,2)   [sendKillHook])
+            , insertWhereItGoes (A.listArray (16,16) [sendLossless{-Ping-}])
+            , insertWhereItGoes (A.listArray (24,25) [sendOnlineHook,sendLossless{-Offline-}])
+            , insertWhereItGoes (A.listArray (48,51) [sendNickHook,sendStatusMsgHook,sendStatusHook,sendTypingHook])
+            , insertWhereItGoes (A.listArray (63,64) [sendMessageHook, sendMessageHook])
+            ]
+        return (idmap,lossyEsc,losslessEsc,outHooks)
     ncView0 <- newTVar (sessionView sessions)
     pktq <- PQ.new (inboundQueueCapacity sessions) 0
     bufstart <- newTVar 0
@@ -645,6 +658,7 @@ freshCryptoSession  sessions
                     , ncSessionSecret      = newsession
                     , ncSockAddr           = HaveDHTKey addr
                     , ncHooks              = ncHooks0
+                    , ncOutHooks           = ncOutHooks0
                     , ncUnrecognizedHook   = ncUnrecognizedHook0
                     , ncIdleEventHooks     = ncIdleEventHooks0
                     , ncAllSessions        = sessions
@@ -677,13 +691,13 @@ freshCryptoSession  sessions
             HaveHandshake pktoq -> return (runUponHandshake netCryptoSession0 addr pktoq)
     return (myhandshake,maybeLaunchMissles)
 
-type NetCryptoOutQueue = PQ.PacketOutQueue (State,Nonce24,RangeMap TArray Word8 TVar)
+type NetCryptoOutQueue = PQ.PacketOutQueue (State,Nonce24,U.RangeMap TArray Word8 TVar)
                                            CryptoMessage
                                            (CryptoPacket Encrypted)
                                            CryptoData
 
 createNetCryptoOutQueue :: NetCryptoSessions -> SecretKey -> PublicKey -> PacketQueue CryptoData
-                        -> TVar Nonce24    -> RangeMap TArray Word8 TVar     -> STM (UponHandshake NetCryptoOutQueue)
+                        -> TVar Nonce24    -> U.RangeMap TArray Word8 TVar     -> STM (UponHandshake NetCryptoOutQueue)
 createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 = do
             let crypto = transportCrypto sessions
             let toWireIO = do
@@ -1084,7 +1098,7 @@ sessionPacketH sessions addrRaw (CryptoPacket nonce16 encrypted) = do
                         Nothing -> return ()
                     msgTypes <- atomically $ readTVar ncIncomingTypeArray
                     let msgTyp = cd ^. messageType
-                        msgTypMapped64 = msgTypes A.! fromEnum8 (msgID cm)
+                        msgTypMapped64 = msgTypes U.! fromEnum8 (msgID cm)
                         msgTypMapped = fromWord64 $ msgTypMapped64
                         isLossy (GrpMsg KnownLossy _) = True
                         isLossy (Msg mid) | lossyness mid == Lossy = True
@@ -1116,7 +1130,7 @@ runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionP
     flip fix (cm,hookmap) $ \lookupAgain (cm,hookmap) -> do
         msgTypes <- atomically $ readTVar ncIncomingTypeArray
         let msgTyp = cm ^. messageType
-            msgTypMapped64 = msgTypes A.! fromEnum8 (msgID cm)
+            msgTypMapped64 = msgTypes U.! fromEnum8 (msgID cm)
             msgTypMapped = fromWord64 $ msgTypMapped64
         if msgTypMapped64 == 0
          then return Nothing
@@ -1147,8 +1161,8 @@ runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionP
 -- | construct a 'MsgTypeArray' for specified types, using their known common positions
 --   in the MessageId space if they have such a thing.
 mkMsgTypes :: [MessageType] -> MsgTypeArray
-mkMsgTypes msgs = let zeros = A.listArray (0,255) (replicate 256 0)
-                      in zeros A.// map (\x -> (toIndex x,toWord64 x)) msgs
+mkMsgTypes msgs = let zeros = U.listArray (0,255) (replicate 256 0)
+                      in zeros U.// map (\x -> (toIndex x,toWord64 x)) msgs
     where
         toIndex (Msg mid) = fromIntegral . fromEnum  $ mid
         toIndex (GrpMsg KnownLossless nam) = 0x63 -- fromEnum MESSAGE_GROUPCHAT
@@ -1189,10 +1203,10 @@ pattern   PACKET_ID_LOSSY_RANGE_SIZE     = 63
 --   The first parameter is a function which is applied to get the values
 --   for keys of unknown nature. Could be either 'id' or 'const 0'
 allMsgTypes :: (Word64 -> Word64) -> MsgTypeArray
-allMsgTypes fDefault = A.listArray (minBound,maxBound) (0:knownMsgs)
-  where
-    knownMsgs :: [Word64]
-    knownMsgs =
+allMsgTypes fDefault = U.listArray (minBound,maxBound) (0:knownMsgs)
+
+knownMsgs :: [Word64]
+knownMsgs =
       concat [ map (fromIntegral . fromEnum) [ PacketRequest .. KillPacket ]
              , map (const 0)                 [ 3 .. 15 ]  -- UnspecifiedPacket
              , map (const 0)                 [ 16 .. 23 ] -- MessengerLoseless
@@ -1236,6 +1250,10 @@ sendPing crypto session = do
 sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
 sendOnline crypto session = do
     let cm=OneByte ONLINE
+    sendOnlineHook crypto session cm
+
+sendOnlineHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendOnlineHook crypto session cm = do
     addMsgToLastN False (cm ^. messageType) session (Out cm)
     result <- sendCrypto crypto session (return ()) (OneByte ONLINE)
     -- double this packet
@@ -1252,49 +1270,61 @@ sendOnline crypto session = do
 sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
 sendOffline crypto session = do
     let cm=OneByte OFFLINE
+    sendLossless crypto session cm
+
+sendLossless :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendLossless crypto session cm = do
     addMsgToLastN False (cm ^. messageType) session (Out cm)
     sendCrypto crypto session (return ()) (OneByte OFFLINE)
 
+sendLossy :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendLossy crypto session cm = sendCryptoLossy crypto session (return ()) cm
 
 sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
 sendKill crypto session = do
     let cm=OneByte KillPacket
+    sendKillHook crypto session cm
+
+sendKillHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendKillHook crypto session cm = sendCryptoLossy crypto session (destroySession session) cm
+
+sendCryptoLossy :: TransportCrypto -> NetCryptoSession -> (IO ()) -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendCryptoLossy crypto session updateLocal cm = do
     mbOutQ <- atomically $ readTVar (ncOutgoingQueue session)
     case mbOutQ of
         NeedHandshake -> do
-            let errmsg="NetCrypto NOT SENDING Kill packet (sessionid: " ++ show (ncSessionId session) ++ ") since no handshake yet"
-            dput XNetCrypto errmsg
-            dput XNetCrypto $ "Destroying session anyway"
-            destroySession session
+            let errmsg = "Error sending lossy packet! (sessionid: " ++ show (ncSessionId session) ++ ") Need the Handshake first!"
+            updateLocal
             return (Left errmsg)
         HaveHandshake outq -> do
-            dput XNetCrypto $ "NetCrypto sending Kill packet (sessionid: " ++ show (ncSessionId session) ++ ")"
             getOutGoingParam <- PQ.readyOutGoing outq
             mbPkt <- atomically $ PQ.peekPacket getOutGoingParam outq cm
             case mbPkt of
                 Nothing  -> do
-                    let errmsg = "Error sending kill packet! (sessionid: " ++ show (ncSessionId session) ++ ")"
-                    dput XNetCrypto errmsg
-                    dput XNetCrypto $ "Destroying session anyway"
-                    Right <$> destroySession session
+                    let errmsg = "Error sending lossy packet! (sessionid: " ++ show (ncSessionId session) ++ ") " ++ show cm
+                    updateLocal
                     return (Left errmsg)
                 Just (pkt,seqno) -> do
                     case (ncSockAddr session) of
                       NeedDHTKey -> do
-                        let errmsg= "NetCrypto NOT SENDING Kill packet (sessionid: " ++ show (ncSessionId session) ++ ") since no DHTkey(sockaddr) yet"
-                        dput XNetCrypto errmsg
-                        dput XNetCrypto $ "Destroying session anyway"
-                        Right <$> destroySession session
+                        let errmsg= "NetCrypto NOT SENDING Lossy packet (sessionid: " ++ show (ncSessionId session) ++ ") since no DHTkey(sockaddr) yet"
+                        updateLocal
                         return (Left errmsg)
                       HaveDHTKey saddr -> do
                         sendSessionPacket (ncAllSessions session) saddr pkt
-                        dput XNetCrypto $ "sent kill packet (sessionid: " ++ show (ncSessionId session) ++ ")... now destroying session..."
-                        destroySession session
+                        dput XNetCrypto $ "sent lossy packet (sessionid: " ++ show (ncSessionId session) ++ ") " ++ take 40 (show cm) ++ "..."
+                        updateLocal
                         return (Right pkt)
 
 setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
 setNick crypto session nick = do
+    let cm = UpToN NICKNAME nick
+    sendNickHook crypto session cm
+
+sendNickHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendNickHook crypto session cm = do
     let Just (_,maxlen) = msgSizeParam NICKNAME
+    let nick = msgBytes cm
     if B.length nick > maxlen
      then return (Left $ "nickname must not exceed " ++ show maxlen ++ " bytes.")
      else do
@@ -1302,16 +1332,20 @@ setNick crypto session nick = do
                 let viewVar = ncView session
                 view <- readTVar viewVar
                 writeTVar (svNick view) nick
-        let cm = UpToN NICKNAME nick
         addMsgToLastN False (cm ^. messageType) session (Out cm)
         sendCrypto crypto session updateLocal cm
 
 setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String (CryptoPacket Encrypted))
 setTyping crypto session status = do
+   let cm = TwoByte TYPING (fromEnum8 status)
+   sendTypingHook crypto session cm
+
+sendTypingHook:: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendTypingHook crypto session cm = do
+   let status = toEnum8 (msgByte cm)
    let updateLocal = do
         view <- readTVar (ncView session)
         writeTVar (svTyping view) status
-   let cm = TwoByte TYPING (fromEnum8 status)
    addMsgToLastN False (cm ^. messageType) session (Out cm)
    sendCrypto crypto session updateLocal cm
 
@@ -1325,36 +1359,51 @@ setNoSpam crypto session mbnospam = do
 
 setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String (CryptoPacket Encrypted))
 setStatus crypto session status = do
+   let cm = TwoByte USERSTATUS (fromEnum8 status)
+   sendStatusHook crypto session cm
+
+sendStatusHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendStatusHook crypto session cm = do
+   let status = toEnum8 (msgByte cm)
    let updateLocal = do
         view <- readTVar (ncView session)
         writeTVar (svStatus view) status
-   let cm = TwoByte USERSTATUS (fromEnum8 status)
    addMsgToLastN False (cm ^. messageType) session (Out cm)
    sendCrypto crypto session updateLocal cm
 
 setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
 setStatusMsg crypto session msg = do
+    let cm = UpToN STATUSMESSAGE msg
+    sendStatusMsgHook crypto session cm
+
+sendStatusMsgHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendStatusMsgHook crypto session cm = do
     let Just (_,maxlen) = msgSizeParam STATUSMESSAGE
+    let msg = msgBytes cm
     if B.length msg > maxlen
      then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.")
      else do
         let updateLocal = do
                 view <- readTVar (ncView session)
                 writeTVar (svStatusMsg view) msg
-        let cm = UpToN STATUSMESSAGE msg
         addMsgToLastN False (cm ^. messageType) session (Out cm)
         sendCrypto crypto session updateLocal cm
 
 sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
 sendChatMsg crypto session msg = do
+    let cm = UpToN MESSAGE msg
+    sendMessageHook crypto session cm
+
+sendMessageHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
+sendMessageHook crypto session cm = do
     let Just (_,maxlen) = msgSizeParam MESSAGE
+    let msg = msgBytes cm
     if B.length msg > maxlen
      then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.")
      else do
         let updateLocal = do
                 view <- readTVar (ncView session)
                 writeTVar (svStatusMsg view) msg
-        let cm = UpToN MESSAGE msg
         addMsgToLastN False (cm ^. messageType) session (Out cm)
         sendCrypto crypto session updateLocal cm