1 files changed, 74 insertions, 199 deletions

diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
index 1c641584..b79334d7 100644
--- a/src/Network/Tox/Crypto/Transport.hs
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -1,10 +1,11 @@
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE KindSignatures     #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE NamedFieldPuns     #-}
+{-# LANGUAGE PatternSynonyms    #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections      #-}
+{-# LANGUAGE ViewPatterns       #-}
 module Network.Tox.Crypto.Transport
     ( showCryptoMsg
     , parseCrypto
@@ -21,7 +22,7 @@ module Network.Tox.Crypto.Transport
     , HandshakeData(..)
     , Handshake(..)
     , PeerInfo(..)
-    , MessageID(..)
+    , module Data.Tox.Message
     , UserStatus(..)
     , TypingStatus(..)
     , GroupChatId(..)
@@ -53,13 +54,10 @@ module Network.Tox.Crypto.Transport
     , sizedN
     , sizedAtLeastN
     , isIndirectGrpChat
-    , LossyOrLossless(..)
     , fromEnum8
     , fromEnum16
     , toEnum8
     , msgSizeParam
-    , NegotiationID(..)
-    , NegotiationMsg(..)
     , getCryptoMessage
     , putCryptoMessage
     , module Data.Tox.Message
@@ -96,10 +94,11 @@ showCryptoMsg seqno (UpToN PacketRequest bytes) = "UpToN PacketRequest --> "
 showCryptoMsg _     msg                         = show msg
 
 parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr)
-parseCrypto ((B.uncons -> Just (0x1b,pkt)),saddr) = either (\_ -> Right (pkt,saddr))
-                                                           (\x -> Left  (x  ,saddr))
-                                                        $ runGet get pkt
-parseCrypto not_mine = Right not_mine
+parseCrypto (bbs,saddr) = case B.uncons bbs of
+    Just (0x1b,bs) -> case runGet get bs of
+        Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet.
+        Left  _   -> Right (bs,saddr)  -- Failed parse, strip first byte and pass it on.
+    _             -> Right (bbs,saddr) -- Type-code mismatch, pass it on.
 
 encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr)
 encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr)
@@ -659,15 +658,24 @@ class HasTitle x where
     setTitle :: x -> Text -> x
 
 instance HasTitle CryptoMessage where
-    getTitle (UpToN DIRECT_GROUPCHAT {-Ox62-}    (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,mdata)))) = decodeUtf8 mdata
-    getTitle (UpToN xE                           (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (toEnum . fromIntegral -> GroupchatTitleChange,mdata))))
-        | isIndirectGrpChat xE = decodeUtf8 mdata
-    getTitle _   = error "getTitle on CryptoMessage without title field."
-
-    setTitle (UpToN xE@DIRECT_GROUPCHAT {-0x62-} (sizedAtLeastN 3 -> B.splitAt 2 -> (bs,B.uncons -> Just (_,xs)))) messagedata
-        = UpToN xE (B.concat [bs,B.cons 0x0a (encodeUtf8 messagedata)])
-    setTitle (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,B.uncons -> Just (_,xs)))) title
-        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum GroupchatTitleChange) (encodeUtf8 title)])
+    getTitle (UpToN xE bs)
+        | DIRECT_GROUPCHAT {-0x62-} <- xE,
+          (_,0x0a,mdata) <- splitByteAt 2 bs   = decodeUtf8 mdata
+        | isIndirectGrpChat xE,
+          let (_,nmb,mdata) = splitByteAt 8 bs
+              nm = toEnum (fromIntegral nmb),
+          GroupchatTitleChange <- nm           = decodeUtf8 mdata
+    getTitle _  = error "getTitle on CryptoMessage without title field."
+
+    setTitle (UpToN xE bs) msgdta
+        | DIRECT_GROUPCHAT {-0x62-} <- xE
+            = let (pre,_,_) = splitByteAt 2 bs
+                  nm = 0x0a
+              in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
+        | isIndirectGrpChat xE
+            = let (pre,_,_) = splitByteAt 8 bs
+                  nm = fromIntegral $ fromEnum GroupchatTitleChange
+              in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
     setTitle _ _ = error "setTitle on CryptoMessage without title field."
 
 title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
@@ -677,17 +685,28 @@ class HasMessage x where
     getMessage :: x -> Text
     setMessage :: x -> Text -> x
 
+splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString)
+splitByteAt n bs = (fixed,w8,bs')
+ where
+    (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs
+
 instance HasMessage CryptoMessage where
-    getMessage (UpToN MESSAGE bstr) = T.decodeUtf8 bstr
-    getMessage (UpToN xE                           (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (mnameByte,mdata))))
-        | isIndirectGrpChat xE = decodeUtf8 mdata
-    getMessage _   = error "getMessage on CryptoMessage without message field."
-
-    setMessage (UpToN MESSAGE _) message = UpToN MESSAGE (T.encodeUtf8 $ message)
-    setMessage (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,B.uncons -> Just (mnameByte,xs)))) message
-        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (if mnameByte == 0 then 0x40 else mnameByte) (encodeUtf8 message)])
+    getMessage (UpToN xE bs)
+        | MESSAGE <- xE        = T.decodeUtf8 bs
+        | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs
+    getMessage _ = error "getMessage on CryptoMessage without message field."
+
+    setMessage (UpToN xE bs) message
+        | MESSAGE <- xE
+          = UpToN xE $ T.encodeUtf8 message
+        | isIndirectGrpChat xE
+          = let (pre8,nm0,xs) = splitByteAt 8 bs
+                nm = if nm0 == 0 then 0x40 else nm0
+                prefix x = pre8 <> B.cons nm x
+            in UpToN xE $ prefix $ T.encodeUtf8 message
     setMessage _ _ = error "setMessage on CryptoMessage without message field."
 
+
 message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x)
 message = lens getMessage setMessage
 
@@ -714,7 +733,7 @@ data PeerInfo
          { piPeerNum :: PeerNumber
          , piUserKey :: PublicKey
          , piDHTKey  :: PublicKey
-         , piName  :: ByteString -- byte-prefix for length
+         , piName    :: ByteString -- byte-prefix for length
          } deriving (Eq,Show)
 
 instance HasPeerNumber PeerInfo where
@@ -747,15 +766,13 @@ instance Serialize PeerInfo where
 -- > userStatus .~ Busy $ msg USERSTATUS
 --
 msg :: MessageID -> CryptoMessage
-msg mid | Just (True,0) <- msgSizeParam mid  = OneByte mid
-msg mid | Just (True,1) <- msgSizeParam mid  = TwoByte mid 0
-msg mid | Just (False,_) <- msgSizeParam mid = UpToN   mid B.empty
-msg mid = UpToN   mid B.empty
+msg mid | Just (True,0)  <- msgSizeParam mid = OneByte mid
+        | Just (True,1)  <- msgSizeParam mid = TwoByte mid 0
+        | Just (False,_) <- msgSizeParam mid = UpToN   mid B.empty
+        | otherwise                          = UpToN   mid B.empty
 
-leaveMsg :: Serialize a => a -> CryptoMessage
+leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage
 leaveMsg     groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01)
-
-peerQueryMsg :: Serialize a => a -> CryptoMessage
 peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08)
 
 
@@ -763,39 +780,36 @@ peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08)
 -- the maximum allowed size for the message Payload (message minus id)
 -- Or Nothing if unknown/unimplemented.
 msgSizeParam :: MessageID -> Maybe (Bool,Int)
-msgSizeParam ONLINE  = Just (True,0)
-msgSizeParam OFFLINE = Just (True,0)
-msgSizeParam USERSTATUS = Just (True,1)
-msgSizeParam TYPING     = Just (True,1)
-msgSizeParam NICKNAME         = Just (False,128)
-msgSizeParam STATUSMESSAGE    = Just (False,1007)
-msgSizeParam MESSAGE          = Just (False,1372)
-msgSizeParam ACTION           = Just (False,1372)
-msgSizeParam FILE_DATA        = Just (False,1372)-- up to 1373
-msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301
-msgSizeParam FILE_CONTROL     = Just (False,7)   -- 8 bytes if seek, otherwise 4
-msgSizeParam INVITE_GROUPCHAT = Just (False,38)
-msgSizeParam ONLINE_PACKET    = Just (True,35)
+msgSizeParam ONLINE                     = Just (True ,0)
+msgSizeParam OFFLINE                    = Just (True ,0)
+msgSizeParam USERSTATUS                 = Just (True ,1)
+msgSizeParam TYPING                     = Just (True ,1)
+msgSizeParam NICKNAME                   = Just (False,128)
+msgSizeParam STATUSMESSAGE              = Just (False,1007)
+msgSizeParam MESSAGE                    = Just (False,1372)
+msgSizeParam ACTION                     = Just (False,1372)
+msgSizeParam FILE_DATA                  = Just (False,1372)-- up to 1373
+msgSizeParam FILE_SENDREQUEST           = Just (False,300) -- 1+1+4+8+32+max255 = up to 301
+msgSizeParam FILE_CONTROL               = Just (False,7)   -- 8 bytes if seek, otherwise 4
+msgSizeParam INVITE_GROUPCHAT           = Just (False,38)
+msgSizeParam ONLINE_PACKET              = Just (True ,35)
 msgSizeParam DIRECT_GROUPCHAT  {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets
 msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable
 msgSizeParam LOSSY_GROUPCHAT   {-0xC7-} = Nothing -- variable
-msgSizeParam _ = Nothing
+msgSizeParam _                          = Nothing
 
 isIndirectGrpChat :: MessageID -> Bool
 isIndirectGrpChat MESSAGE_GROUPCHAT = True
-isIndirectGrpChat LOSSY_GROUPCHAT = True
-isIndirectGrpChat _ = False
-
+isIndirectGrpChat LOSSY_GROUPCHAT   = True
+isIndirectGrpChat _                 = False
 
 isKillPacket :: MessageType -> Bool
 isKillPacket (Msg KillPacket) = True
-isKillPacket _ = False
+isKillPacket _                = False
 
 isOFFLINE :: MessageType -> Bool
 isOFFLINE (Msg OFFLINE) = True
-isOFFLINE _ = False
-
-
+isOFFLINE _             = False
 
 
 data MessageName = Ping -- 0x00
@@ -1056,142 +1070,3 @@ data MessageName = Ping -- 0x00
                  | MessageName0xff
                 deriving (Show,Eq,Ord,Enum,Bounded)
 
--- --> CookieRequest WithoutCookie
--- <-- CookieResponse CookieAddress
--- --> Handshake CookieAddress
--- <-- Handshake CookieAddress
-
--- cookie request packet (145 bytes)
---
--- [uint8_t 24]
--- [Sender's DHT Public key (32 bytes)]
--- [Random nonce (24 bytes)]
--- [Encrypted message containing:
---     [Sender's real public key (32 bytes)]
---     [padding (32 bytes)]
---     [uint64_t echo id (must be sent back untouched in cookie response)]
--- ]
-
-
--- cookie response packet (161 bytes):
---
---     [uint8_t 25]
---     [Random nonce (24 bytes)]
---     [Encrypted message containing:
---         [Cookie]
---         [uint64_t echo id (that was sent in the request)]
---     ]
---
---     Encrypted message is encrypted with the exact same symmetric key as the
---     cookie request packet it responds to but with a different nonce.
---     (Encrypted message is encrypted with reqesters's DHT private key,
---     responders's DHT public key and the nonce.)
---
---     Since we don't receive the public key, we will need to lookup the key by
---     the SockAddr... I don't understand why the CookieResponse message is
---     special this way.  TODO: implement a multimap (SockAddr -> SharedSecret)
---     and wrap cookie queries with store/delete.  TODO: Should the entire
---     SharedScret cache be keyed on only SockAddr ?  Perhaps the secret cache
---     should be (NodeId -> Secret) and the cookie-request map should be
---     (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
-