From ee0f50943efd65eb1c906338b00c204591826a16 Mon Sep 17 00:00:00 2001
From: James Crayne <jim.crayne@gmail.com>
Date: Tue, 29 May 2018 21:16:37 +0000
Subject: sendCrypto & friends

        * sendOnline
        * sendOffline
        * sendKill
        * setNick
        * setStatus
        * setStatusMsg
        * setTyping
---
 src/Network/Tox/Crypto/Handlers.hs | 80 +++++++++++++++++++++++++-------------
 1 file changed, 53 insertions(+), 27 deletions(-)

diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 2fb7f2c1..486ee076 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -289,6 +289,15 @@ newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieR
 
 type XMessage = CryptoMessage -- todo
 
+-- THIS Would work if not for the IO shared secret cache...
+-- increments packet nonce, only call when actually queuing an outgoing packet
+-- getOutGoingParam crypto session = do
+--    n24 <- (ncMyPacketNonce session)
+--    let state = computeSharedSecret (transportSecret crypto) (ncTheirPublicKey session) n24
+--    modifyTVar (ncMyPacketNonce session) (+1)
+--    rangemap <- readTVar (ncOutgoingIdMap session)
+--    return (state,n24,rangemap)
+
 ncToWire :: STM (State,Nonce24,RangeMap TArray Word8 TVar)
          -> Word32{- packet number we expect to recieve -}
          -> Word32{- buffer_end -}
@@ -536,7 +545,6 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non
                 Just session -> updateCryptoSession sessions addr hp session -- update existing session
     return Nothing
 
-
 cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
     let crypto = transportCrypto sessions
         allsessions = netCryptoSessions sessions
@@ -671,28 +679,48 @@ allMsgTypes fDefault = A.listArray (minBound,maxBound) (0:knownMsgs)
              , map (const 0)                 [ 200 .. 255 ] -- All lossy, exept the last
              ]
 
+sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String ())
+sendCrypto crypto session updateLocal cm = do
+    let outq = ncOutgoingQueue session
+    -- XXX: potential race? if shared secret comes out of sync with cache?
+    getOutGoingParam <- PQ.readyOutGoing outq
+    atomically $ do
+        result <- PQ.tryAppendQueueOutgoing getOutGoingParam outq cm
+        case result of
+            PQ.OGSuccess    -> updateLocal >> return (Right())
+            PQ.OGFull       -> return (Left "Outgoing packet buffer is full")
+            PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet")
+
+sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
+sendOnline crypto session = sendCrypto crypto session (return ()) (OneByte ONLINE)
+
+sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
+sendOffline crypto session = sendCrypto crypto session (return ()) (OneByte OFFLINE)
+
+
+sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
+sendKill crypto session = sendCrypto crypto session (return ()) (OneByte KillPacket)
+
 setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
 setNick crypto session nick = do
     let Just (_,maxlen) = msgSizeParam NICKNAME
     if B.length nick > maxlen
      then return (Left $ "nickname must not exceed " ++ show maxlen ++ " bytes.")
      else do
-        let viewVar = ncView session
-        atomically $ do
-            view <- readTVar viewVar
-            writeTVar (svNick view) nick
-        let nickPacket = error "todo"
-        return (Left "TODO: sendMessage crypto (NetCrypto nickPacket)")
-        -- return (Right ())
-        --
+        let updateLocal = do
+                let viewVar = ncView session
+                view <- readTVar viewVar
+                writeTVar (svNick view) nick
+        let cm = UpToN NICKNAME nick
+        sendCrypto crypto session updateLocal cm
+
 setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String ())
 setTyping crypto session status = do
-   let viewVar = ncView session
-   atomically $ do
-    view <- readTVar viewVar
-    writeTVar (svTyping view) status
-   let typingPacket = error "todo"
-   return (Left "TODO: sendMessage crypto (NetCrypto typingPacket)")
+   let updateLocal = do
+        view <- readTVar (ncView session)
+        writeTVar (svTyping view) status
+   let cm = TwoByte TYPING (fromEnum8 status)
+   sendCrypto crypto session updateLocal cm
 
 setNoSpam :: TransportCrypto -> NetCryptoSession -> Maybe NoSpam -> IO (Either String ())
 setNoSpam crypto session mbnospam = do
@@ -704,12 +732,11 @@ setNoSpam crypto session mbnospam = do
 
 setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String ())
 setStatus crypto session status = do
-   let viewVar = ncView session
-   atomically $ do
-    view <- readTVar viewVar
-    writeTVar (svStatus view) status
-   let statusPacket = error "todo"
-   return (Left "TODO: sendMessage crypto (NetCrypto statusPacket)")
+   let updateLocal = do
+        view <- readTVar (ncView session)
+        writeTVar (svStatus view) status
+   let cm = TwoByte USERSTATUS (fromEnum8 status)
+   sendCrypto crypto session updateLocal cm
 
 setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
 setStatusMsg crypto session msg = do
@@ -717,12 +744,11 @@ setStatusMsg crypto session msg = do
     if B.length msg > maxlen
      then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.")
      else do
-        let viewVar = ncView session
-        atomically $ do
-            view <- readTVar viewVar
-            writeTVar (svStatusMsg view) msg
-        let statusMsgPacket = error "todo"
-        return (Left "TODO: sendMessage crypto (NetCrypto statusMsgPacket)")
+        let updateLocal = do
+                view <- readTVar (ncView session)
+                writeTVar (svStatusMsg view) msg
+        let cm = UpToN STATUSMESSAGE msg
+        sendCrypto crypto session updateLocal cm
 
 -- | handles nothings
 defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook]
-- 
cgit v1.2.3