From f07d159805459c0c8c7b9fd546cdcfdfda750e41 Mon Sep 17 00:00:00 2001
From: "jim@bo" <jim@bo>
Date: Sun, 24 Jun 2018 23:06:09 -0400
Subject: Feature Negotiation messages, serialization code

---
 src/Network/Tox/Crypto/Transport.hs | 103 ++++++++++++++++++++++++++++++++++++
 1 file changed, 103 insertions(+)

(limited to 'src')

diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
index c7fbfdc6..a5634d71 100644
--- a/src/Network/Tox/Crypto/Transport.hs
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -58,6 +58,8 @@ module Network.Tox.Crypto.Transport
     , fromEnum16
     , toEnum8
     , msgSizeParam
+    , NegotiationID(..)
+    , NegotiationMsg(..)
     ) where
 
 import Crypto.Tox
@@ -74,12 +76,14 @@ import Data.Word
 import Data.Bits
 import Crypto.Hash
 import Control.Lens
+import Control.Monad
 import Data.Text as T
 import Data.Text.Encoding as T
 import Data.Serialize as S
 import Control.Arrow
 import DPut
 import Data.PacketQueue (toPNums)
+import Data.Function
 
 showCryptoMsg :: Word32 -> CryptoMessage -> [Char]
 showCryptoMsg seqno (UpToN PacketRequest bytes) =  "UpToN PacketRequest --> "  ++ show (toPNums seqno $ B.unpack bytes)
@@ -1323,3 +1327,102 @@ data MessageName = Ping -- 0x00
 --     (SockAddr -> NodeId)
 
 
+-----------------------------------------------------------
+-- Session feature negotiation, piggy back on AlivePacket(PING)
+--
+-- UpToN { msgID = PING{-16-}
+--       , msgBytes = S.encode (UpToN { msgID    = toEnum8 (fromEnum8 NegotiationID)
+--                                    , msgBytes = payload
+--                                    })
+--
+--
+--  RefInfo = { Word32 -- this messsage (refnum), start with 1
+--            , Word32 -- 0 if not replying, otherwise refnum of message it is in reply too
+--            }
+--
+--  position = { Word8 -- 0 = top (MessageID) level, 1 = MessageName level
+--             , Word8 -- MessageID
+--             }
+--  all MessageName-level messages use MESSAGE_GROUPCHAT as their primary Id
+data NegotiationID               -- payload --
+        = DefineTopLevel         -- Word8(NegotiationID)Word64(RefInfo):Word64(msg-type),Word16-position,Word64-type,Word24-position ...
+        -- ^ Inform remote of your top-level map
+        | DefineMap              -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num),Word16-position,Word64-type,Word24-position,Word64(msg-type), ...
+        -- ^ Inform remote of available user-selectable second-level map
+        | AnnounceSelectedMap    -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num)
+        -- ^ Inform remote which second-level map he currently has selected
+        | RequestMap             -- Word8(NegotiationID)Word64(RefInfo):Word16-position,Word64-type,Word16-position,Word64(msg-type) ...
+        -- ^ Ask remote for a selectable map supporting the message types at specific locations
+        | SelectMap              -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num)
+        -- ^ Tell remote which secondary map to use while interpretting your messages
+        | DiscardMap             -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num)
+        -- ^ Tell remote you aren't going to use the specified secondary map
+        | DenyRequest            -- Word8(NegotiationID)Word64(RefInfo)
+        -- ^ Inform remote that you opted not to comply with his request (or selection), or there was some error
+                deriving (Show,Eq,Ord,Enum,Bounded)
+
+instance Serialize NegotiationID where
+    get = toEnum . fromIntegral <$> getWord8
+    put x = putWord8 (fromIntegral . fromEnum $ x)
+
+data NegotiationMsg
+         = NegMsg { negID :: NegotiationID
+                  , negNum :: Word32
+                  , negRef :: Word32
+                  , negMapNum :: Maybe Word32
+                  , negRange  :: [((Word8,Word8),Word64)]
+                  } deriving (Eq,Show)
+
+instance Sized NegotiationMsg where
+    size = VarSize $ \case
+            x | negID x == DenyRequest                      -> 9
+            x | negID x `Prelude.elem` [SelectMap,DiscardMap,AnnounceSelectedMap]
+                                                            -> 10
+            x | negID x `Prelude.elem` [DefineTopLevel,RequestMap]
+              , xs <- negRange x                            -> 9 + 10 * (Prelude.length xs)
+
+            x | negID x == DefineMap
+              , xs <- negRange x                            -> 13 + 10 * (Prelude.length xs)
+
+instance Serialize NegotiationMsg where
+    get = do
+        i   <- get :: Get NegotiationID
+        num <- getWord32le :: Get Word32
+        ref <- getWord32le :: Get Word32
+        let getRangeReversed = flip fix [] $ \loop xs -> do
+                        emp <- isEmpty
+                        if emp then return xs
+                               else do
+                                        level <- get :: Get Word8
+                                        id    <- get :: Get Word8
+                                        typ   <- getWord64le :: Get Word64
+                                        loop (((level,id),typ):xs)
+        let getRange = Prelude.reverse <$> getRangeReversed
+        (mapNum,range)
+           <- case i  of
+            x | x `Prelude.elem` [SelectMap,DiscardMap,AnnounceSelectedMap]
+                -> do
+                    mapNum <- getWord32le :: Get Word32
+                    return (Just mapNum,[])
+            x | x `Prelude.elem` [DefineTopLevel,RequestMap]
+                -> do
+                    xs <- getRange
+                    return (Nothing,xs)
+            DefineMap -> do
+                    mapNum <- getWord32le :: Get Word32
+                    xs <- getRange
+                    return (Just mapNum,xs)
+
+            _ -> return (Nothing,[])
+        return $ NegMsg i num ref mapNum range
+
+    put msg = do
+            putWord8 (fromIntegral . fromEnum $ negID msg)
+            putWord32le (negNum msg)
+            putWord32le (negRef msg)
+            maybe (return ()) putWord32le (negMapNum msg)
+            forM_ (negRange msg) $ \((lvl,id),typ) -> do
+                putWord8 lvl
+                putWord8 id
+                putWord64le typ
+
-- 
cgit v1.2.3