path: root/src/Network/Tox/Crypto/Transport.hs

{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE StandaloneDeriving #-}
module Network.Tox.Crypto.Transport
    ( showCryptoMsg
    , parseCrypto
    , encodeCrypto
    , unpadCryptoMsg
    , createRequestPacket
    , parseHandshakes
    , encodeHandshakes
    , CryptoData(..)
    , CryptoMessage(..)
    , MessageName(..)
    , CryptoPacket(..)
    , HandshakeData(..)
    , Handshake(..)
    , PeerInfo(..)
    , MessageID(..)
    , UserStatus(..)
    , TypingStatus(..)
    , GroupChatId(..)
    , MessageType(..)
    , isKillPacket, isOFFLINE
    , KnownLossyness(..)
    , AsWord16(..)
    , AsWord64(..)
    -- feild name classes
    , HasGroupChatID(..)
    , HasGroupNumber(..)
    , HasPeerNumber(..)
    , HasMessageNumber(..)
    , HasMessageName(..)
    , HasMessageData(..)
    , HasName(..)
    , HasTitle(..)
    , HasMessage(..)
    , HasMessageType(..)
    -- lenses
    , userStatus, nick, statusMessage, typingStatus, action, groupChatID
    , groupNumber, groupNumberToJoin, peerNumber, messageNumber
    , messageName, messageData, name, title, message, messageType
    -- constructor
    , msg
    , leaveMsg
    , peerQueryMsg
    -- utils
    , sizedN
    , sizedAtLeastN
    , isIndirectGrpChat
    , LossyOrLossless(..)
    , fromEnum8
    , fromEnum16
    , toEnum8
    , msgSizeParam
    , NegotiationID(..)
    , NegotiationMsg(..)
    , module Data.Tox.Message
    ) where

import Crypto.Tox
import Data.Tox.Message
import Network.Tox.DHT.Transport (Cookie)
import Network.Tox.NodeId

import Network.Socket
import Data.ByteArray

import Data.ByteString as B
import Data.Maybe
import Data.Monoid
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.PacketBuffer as PB
import Data.Function

showCryptoMsg :: Word32 -> CryptoMessage -> [Char]
showCryptoMsg seqno (UpToN PacketRequest bytes) = "UpToN PacketRequest --> "
                                                  ++ show (PB.decompressSequenceNumbers seqno $ B.unpack bytes)
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

encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr)
encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr)

parseHandshakes :: ByteString -> SockAddr -> Either String (Handshake Encrypted, SockAddr)
parseHandshakes (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseHandshakes: "++) $ (,saddr) <$> runGet get pkt
parseHandshakes bs                            _     = Left $ "parseHandshakes_: " ++ show (B.unpack $ B.take 1 bs)

encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr)
encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr)

createRequestPacket :: Word32 -> [Word32] -> CryptoMessage
createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns)
                                   in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r
    where
        ys = Prelude.map (subtract (seqno - 1)) xs
        reduceToSums [] = []
        reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs)
        makeZeroes :: Word32 -> [Word32]
    --  makeZeroes 0 = []
        makeZeroes x
            = let (d,m)= x `divMod` 255
                  zeros= Prelude.replicate (fromIntegral d) 0
                  in zeros ++ [m]
        ns :: [Word8]
        ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes)

data Handshake (f :: * -> *) = Handshake
    { -- The cookie is a cookie obtained by
      -- sending a cookie request packet to the peer and getting a cookie
      -- response packet with a cookie in it.  It may also be obtained in the
      -- handshake packet by a peer receiving a handshake packet (Other
      -- Cookie).
      handshakeCookie :: Cookie f
      -- The nonce is a nonce used to encrypt the encrypted part of the handshake
      -- packet.
    , handshakeNonce :: Nonce24
      -- The encrypted part of the handshake packet is encrypted with the long
      -- term user-keys of both peers.
    , handshakeData :: f HandshakeData
    }

instance Serialize (Handshake Encrypted) where
    get = Handshake <$> get <*> get <*> get
    put (Handshake cookie n24 dta) = put cookie >> put n24 >> put dta

data HandshakeData = HandshakeData
    { baseNonce :: Nonce24
    -- ^ 24 bytes base nonce, recipient uses this to encrypt packets sent to the one who sent this handshake
    --   adding one each time, so it can double as something like an approximate packet number
    , sessionKey :: PublicKey
    -- ^ session public key of the peer (32 bytes)
    -- The recipient of the handshake encrypts using this public key when sending CryptoPackets
    , cookieHash :: Digest SHA512
    -- ^ sha512 hash of the entire Cookie sitting outside the encrypted part
    --  This prevents a replay attack where a new cookie is inserted into
    --  an old valid handshake packet
    , otherCookie :: Cookie Encrypted
    -- ^ Other Cookie (used by the recipient to respond to the handshake packet)
    }
 deriving (Eq,Ord,Show)

instance Sized HandshakeData where
    size = contramap baseNonce size
            <> contramap (key2id . sessionKey) size
            <> ConstSize 64 -- contramap cookieHash size -- missing instance Sized (Digest SHA512)
            <> contramap otherCookie size

instance Serialize HandshakeData where
    get = HandshakeData <$> get
                        <*> (id2key <$> get)
                        <*> (fromJust . digestFromByteString <$> getBytes 64)
                        <*> get
    put (HandshakeData n k h c) = do
        put n
        put $ key2id k
        putByteString (convert h)
        put c

data CryptoPacket (f :: * -> *) = CryptoPacket
    { -- | The last 2 bytes of the nonce used to encrypt 'pktData'
      pktNonce :: Word16
      -- The payload is encrypted with the session key and 'baseNonce' set by
      -- the receiver in their handshake + packet number (starting at 0, big
      -- endian math).
    , pktData :: f CryptoData
    }

deriving instance Show (CryptoPacket Encrypted)

instance Sized CryptoData where
    size = contramap bufferStart size
            <> contramap bufferEnd size
            <> contramap bufferData size

instance Serialize (CryptoPacket Encrypted) where
    get = CryptoPacket <$> get <*> get
    put (CryptoPacket n16 dta) = put n16 >> put dta

data CryptoData = CryptoData
    { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
      bufferStart :: Word32
      -- | [  uint32_t packet number if lossless
      --   , sendbuffer buffer_end  if lossy   , (big endian)]
    , bufferEnd :: Word32
      -- | [data] (TODO See Note [Padding])
    , bufferData :: CryptoMessage
    } deriving (Eq,Show)

{-
Note [Padding]

TODO: The 'bufferData' field of 'CryptoData' should probably be something like
/Padded CryptoMessage/ because c-toxcore strips leading zeros on incoming and
pads leading zeros on outgoing packets.

After studying c-toxcore (at commit c49a6e7f5bc245a51a3c85cc2c8b7f881c412998),
I've determined the following behavior.

Incoming: All leading zero bytes are stripped until possibly the whole packet
is consumed (in which case it is discarded).  This happens at
toxcore/net_crypto.c:1366:handle_data_packet_core().

Outgoing: The number of zeros added is:

    padding_length len = (1373 - len) `mod` 8 where

where /len/ is the size of the non-padded CryptoMessage.  This happens at
toxcore/net_crypto.c:936:send_data_packet_helper()

The number 1373 is written in C as MAX_CRYPTO_DATA_SIZE which is defined in
terms of the max /NetCrypto/ packet size (1400) minus the minimum possible size
of an id-byte (1) and a /CryptoPacket Encrypted/ ( 2 + 4 + 4 + 16 ).

One effect of this is that short messages will be padded to at least 5 bytes.
-}

instance Serialize CryptoData where
    get = CryptoData <$> get <*> get <*> get
    put (CryptoData start end dta) = put start >> put end >> put dta

-- The 'UserStatus' equivalent in Presence is:
--
-- data JabberShow = Offline
--                 | ExtendedAway
--                 | Away           -- Tox equiv: Away (1)
--                 | DoNotDisturb   -- Tox equiv: Busy (2)
--                 | Available      -- Tox equiv: Online (0)
--                 | Chatty
--  deriving (Show,Enum,Ord,Eq,Read)
--
-- The Enum instance on 'UserStatus' is not arbitrary.  It corresponds
-- to on-the-wire id numbers.
data UserStatus = Online | Away | Busy deriving (Show,Read,Eq,Ord,Enum)
instance Serialize UserStatus where
   get = do
        x <- get :: Get Word8
        return (toEnum8 x)
   put x = put (fromEnum8 x)

data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum)
instance Serialize TypingStatus where
   get = do
        x <- get :: Get Word8
        return (toEnum8 x)
   put x = put (fromEnum8 x :: Word8)

unpadCryptoMsg :: CryptoMessage -> CryptoMessage
unpadCryptoMsg x@(TwoByte Padding (toEnum8 -> mid))
    | msgSizeParam mid == Just (True,0) = OneByte mid
unpadCryptoMsg x@(UpToN mid0 (B.dropWhile (==0) -> B.uncons -> Just (toEnum8 -> mid,bytes)))
    | mid0 == Padding
        = case msgSizeParam mid of
            Just (True,0)  -> OneByte mid
            Just (True,1)  -> TwoByte mid (B.head bytes)
            _ -> UpToN mid bytes
unpadCryptoMsg x = x

data CryptoMessage
        = OneByte  { msgID :: MessageID }
        | TwoByte  { msgID :: MessageID, msgByte  :: Word8 }
        | UpToN    { msgID :: MessageID, msgBytes :: ByteString } -- length < N
    deriving (Eq,Show)

instance Sized CryptoMessage where
    size = VarSize $ \case
        OneByte {}              -> 1
        TwoByte {}              -> 2
        UpToN { msgBytes = bs } -> 1 + B.length bs

instance Serialize CryptoMessage where
    get = do
        i <- get :: Get MessageID
        n <- remaining
        case msgSizeParam i of
            Just (True,0) -> return $ OneByte i
            Just (True,1) -> TwoByte i <$> get
            _ -> UpToN i <$> getByteString n

    put (OneByte i)   =    putWord8 (fromIntegral . fromEnum $ i)
    put (TwoByte i b) = do putWord8 (fromIntegral . fromEnum $ i)
                           putWord8 b 
    put (UpToN i x)   = do putWord8 (fromIntegral . fromEnum $ i)
                           putByteString x

instance Serialize MessageID where
    get = toEnum . fromIntegral <$> getWord8
    put x = putWord8 (fromIntegral . fromEnum $ x)
    
erCompat :: String -> a
erCompat lens = error $ "Use of '" ++ lens ++ "'  lens on incompatible CryptoMessage type"

typingStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage)
typingStatus = lens getter setter
  where
    getter :: CryptoMessage -> UserStatus
    getter (TwoByte TYPING status) = toEnum $ fromIntegral status
    getter _                       = erCompat "typingStatus"
    setter :: CryptoMessage -> UserStatus -> CryptoMessage
    setter (TwoByte TYPING _) status = TwoByte TYPING (fromIntegral . fromEnum $ status)
    setter _ _                       = erCompat "typingStatus"

userStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage)
userStatus = lens getter setter
  where
    getter (TwoByte USERSTATUS status) = toEnum $ fromIntegral status
    getter _                           = erCompat "userStatus"
    setter (TwoByte USERSTATUS _) status = TwoByte USERSTATUS (fromIntegral . fromEnum $ status)
    setter _ _                           = erCompat "userStatus"

nick :: Functor f => (Text -> f Text)-> (CryptoMessage -> f CryptoMessage)
nick = lens getter setter
  where
    getter (UpToN NICKNAME bstr) = T.decodeUtf8 bstr
    getter _                     = erCompat "nick"
    setter (UpToN NICKNAME _) nick = UpToN NICKNAME (T.encodeUtf8 $ nick)
    setter _ _                     = erCompat "nick"

statusMessage :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage)
statusMessage = lens getter setter
  where
    getter (UpToN STATUSMESSAGE bstr) = T.unpack $ T.decodeUtf8 bstr
    getter _                          = erCompat "statusMessage"
    setter (UpToN STATUSMESSAGE _) nick = UpToN STATUSMESSAGE (T.encodeUtf8 . T.pack $ nick)
    setter _ _                          = erCompat "statusMessage"

action :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage)
action = lens getter setter
  where
    getter (UpToN ACTION bstr) = T.unpack $ T.decodeUtf8 bstr
    getter _                     = erCompat "action"
    setter (UpToN ACTION _) action = UpToN ACTION (T.encodeUtf8 . T.pack $ action)
    setter _ _                     = erCompat "action"

newtype GroupChatId = GrpId ByteString -- 33 bytes
    deriving (Show,Eq)

class HasGroupChatID x where
    getGroupChatID :: x -> GroupChatId
    setGroupChatID :: x -> GroupChatId -> x

sizedN :: Int -> ByteString -> ByteString
sizedN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
                                 else B.take n bs

sizedAtLeastN :: Int -> ByteString -> ByteString
sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
                                        else bs

instance HasGroupChatID CryptoMessage where
    -- Get
    getGroupChatID (UpToN INVITE_GROUPCHAT payload)
        = let (xs,ys) = B.splitAt 1 payload'
              payload' = sizedN 38 payload
              in case B.unpack xs of
                    [isResponse] | 0 <- isResponse -> GrpId (B.take 33 $ B.drop 2 ys) -- skip group number
                    [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers
                    _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message"

    getGroupChatID (UpToN ONLINE_PACKET payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload))
    getGroupChatID _ = error "getGroupChatID on non-groupchat message."

    -- Set
    setGroupChatID msg@(UpToN INVITE_GROUPCHAT  payload) (GrpId newid)
        = let (xs,ys) = B.splitAt 1 payload'
              payload' = sizedN 38 payload
              in case B.unpack xs of
                    [isResponse] | 0 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 2 ys), sizedN 33 newid]) -- keep group number
                    [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers
                    _ -> msg -- unexpected condition, leave unchanged

    setGroupChatID (UpToN ONLINE_PACKET payload) (GrpId newid) = UpToN ONLINE_PACKET (B.concat [B.take 2 payload, sizedN 33 newid])
    setGroupChatID _ _= error "setGroupChatID on non-groupchat message."

groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x)
groupChatID = lens getGroupChatID setGroupChatID

type GroupNumber = Word16
type PeerNumber = Word16
type MessageNumber = Word32

class HasGroupNumber x where
    getGroupNumber :: x -> GroupNumber
    setGroupNumber :: x -> GroupNumber -> x

instance HasGroupNumber CryptoMessage where
    getGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1
        = let twobytes = B.take 2 xs
              Right n = S.decode twobytes
              in n
    getGroupNumber (UpToN (fromEnum -> x) (sizedN 2 -> twobytes)) | x >= 0x61 && x <= 0x63
        = let Right n = S.decode twobytes in n
    getGroupNumber (UpToN (fromEnum -> 0xC7) (sizedN 2 -> twobytes))
        = let Right n = S.decode twobytes in n

    getGroupNumber _   = error "getGroupNumber on CryptoMessage without group number field."

    setGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) groupnum
        = UpToN INVITE_GROUPCHAT (B.cons isResp (B.append (S.encode groupnum) (B.drop 2 xs)))
    setGroupNumber (UpToN xE@(fromEnum -> x) (sizedAtLeastN 2 -> B.splitAt 2 -> (twobytes,xs))) groupnum
        | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs)
        | x == 0xC7              = UpToN xE (B.append (S.encode groupnum) xs)
    setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field."

groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x)
groupNumber = lens getGroupNumber setGroupNumber

class HasGroupNumberToJoin x where
    getGroupNumberToJoin :: x -> GroupNumber
    setGroupNumberToJoin :: x -> GroupNumber -> x

instance HasGroupNumberToJoin CryptoMessage where
    getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join
        = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local)
              Right n = S.decode twobytes
              in n
    getGroupNumberToJoin _   = error "getGroupNumberToJoin on CryptoMessage without group number (to join) field."
    setGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) groupnum 
        = let (a,b)        = B.splitAt 2 xs
              (twoBytes,c) = B.splitAt 2 b
              twoBytes' = S.encode groupnum
            in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c]))
    setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field."

groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x)
groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin

class HasPeerNumber x where
    getPeerNumber :: x -> PeerNumber
    setPeerNumber :: x -> PeerNumber -> x

instance HasPeerNumber CryptoMessage where
    getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
        = let Right n = S.decode twobytes in n
    getPeerNumber (UpToN (fromEnum -> 0xC7) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
        = let Right n = S.decode twobytes in n
    getPeerNumber _   = error "getPeerNumber on CryptoMessage without peer number field."

    setPeerNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum 
        = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
    setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum 
        = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
    setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field."

peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x)
peerNumber = lens getPeerNumber setPeerNumber

class HasMessageNumber x where
    getMessageNumber :: x -> MessageNumber
    setMessageNumber :: x -> MessageNumber -> x

instance HasMessageNumber CryptoMessage where
    getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
        = let Right n = S.decode fourbytes in n
    getMessageNumber (UpToN (fromEnum -> 0xC7) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
        = let Right n = S.decode fourbytes in n
    getMessageNumber _   = error "getMessageNumber on CryptoMessage without message number field."

    setMessageNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum 
        = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
    setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum 
        = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
    setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field."

messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x)
messageNumber = lens getMessageNumber setMessageNumber


class HasMessageName x where
    getMessageName :: x -> MessageName
    setMessageName :: x -> MessageName -> x

instance HasMessageName CryptoMessage where
    getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
        = let [n] = B.unpack onebyte
              in toEnum . fromIntegral $ n
    getMessageName (UpToN (fromEnum -> 0xC7) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
        = let [n] = B.unpack onebyte
              in toEnum . fromIntegral $ n
    getMessageName _   = error "getMessageName on CryptoMessage without message name field."

    setMessageName (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
        = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
    setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
        = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
    setMessageName _ _ = error "setMessageName on CryptoMessage without message name field."

messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x)
messageName = lens getMessageName setMessageName

data KnownLossyness = KnownLossy | KnownLossless
    deriving (Eq,Ord,Show,Enum)

data MessageType = Msg MessageID
                 | GrpMsg KnownLossyness MessageName
    deriving (Eq,Show)

class AsWord16 a where
   toWord16 :: a -> Word16
   fromWord16 :: Word16 -> a

class AsWord64 a where
   toWord64 :: a -> Word64
   fromWord64 :: Word64 -> a


toEnum8 :: (Enum a, Integral word8) => word8 -> a
toEnum8 = toEnum . fromIntegral
fromEnum8 :: Enum a => a -> Word8
fromEnum8 = fromIntegral . fromEnum

fromEnum16 :: Enum a => a -> Word16
fromEnum16 = fromIntegral . fromEnum

fromEnum64 :: Enum a => a -> Word64
fromEnum64 = fromIntegral . fromEnum


-- MessageType, for our client keep it inside 16 bits
-- but we should extend it to 32 or even 64 on the wire.
-- Bits: 000000glxxxxxxxx, x = message id or extension specific, l = if extended, lossy/lossless, g = if extended, nongroup/group
--      (at least one bit set in high byte means extended, if none but the g flag and possibly l flag, assume default grp extension)
instance AsWord16 MessageType where
    toWord16 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8)
    toWord16 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum16 lsy) + fromIntegral (fromEnum8 msgName)
    fromWord16 x | x < 256                          = Msg (toEnum $ fromIntegral x)
    fromWord16 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x)
    fromWord16 x = error "Not clear how to convert Word16 to MessageType"

instance AsWord64 MessageType where
    toWord64 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8)
    toWord64 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum64 lsy) + fromIntegral (fromEnum8 msgName)
    fromWord64 x | x < 256                          = Msg (toEnum $ fromIntegral x)
    fromWord64 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x)
    fromWord64 x = error "Not clear how to convert Word64 to MessageType"

word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x)
word16  = lens toWord16 (\_ x -> fromWord16 x)

instance Ord MessageType where
    compare (Msg x) (Msg y) = compare x y
    compare (GrpMsg lx x) (GrpMsg ly y) = let r1 = compare lx ly
                                              in if r1==EQ then compare x y else r1
    compare (Msg _) (GrpMsg _ _) = LT
    compare (GrpMsg _ _) (Msg _) = GT

class HasMessageType x where
    getMessageType :: x -> MessageType
    setMessageType :: x -> MessageType -> x

instance HasMessageType CryptoMessage where
    getMessageType (OneByte mid) = Msg mid
    getMessageType (TwoByte mid _) = Msg mid
    getMessageType m@(UpToN MESSAGE_GROUPCHAT _) = GrpMsg KnownLossless (getMessageName m)
    getMessageType m@(UpToN LOSSY_GROUPCHAT   _) = GrpMsg KnownLossy    (getMessageName m)
    getMessageType (UpToN mid _) = Msg mid

    setMessageType (OneByte _   ) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty        ) mname
    setMessageType (TwoByte  _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname
    setMessageType (OneByte _   ) (GrpMsg KnownLossy    mname) = setMessageName (UpToN LOSSY_GROUPCHAT B.empty        ) mname
    setMessageType (TwoByte  _ x) (GrpMsg KnownLossy    mname) = setMessageName (UpToN LOSSY_GROUPCHAT (B.singleton x)) mname
    setMessageType (UpToN _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname
    setMessageType (UpToN _ x) (GrpMsg KnownLossy    mname) = setMessageName (UpToN LOSSY_GROUPCHAT   x) mname
    setMessageType m (Msg mid) | Just (True,1) <- msgSizeParam mid = OneByte mid
    setMessageType (OneByte mid0  ) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid 0 
    setMessageType (TwoByte mid0 x) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid x 
    setMessageType (UpToN mid0 x)   (Msg mid) | Just (True,n) <- msgSizeParam mid = UpToN mid (sizedN n x)
    setMessageType (OneByte mid0)   (Msg mid) = UpToN mid B.empty
    setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x)
    setMessageType (UpToN mid0 x)   (Msg mid) = UpToN mid x

instance HasMessageType CryptoData where
    getMessageType (CryptoData { bufferData })     = getMessageType bufferData
    setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ }

-- | This lens should always succeed on CryptoMessage
messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x)
messageType = lens getMessageType setMessageType

type MessageData = B.ByteString

class HasMessageData x where
    getMessageData :: x -> MessageData
    setMessageData :: x -> MessageData -> x

instance HasMessageData CryptoMessage where
    getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
    getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
    getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x09,peerinfos)))) = peerinfos
    -- getMessageData on 0x62:0a is equivalent to getTitle but without decoding the utf8
    getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,title)))) = title
    getMessageData _   = error "getMessageData on CryptoMessage without message data field."

    setMessageData (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- MESSAGE_GROUPCHAT
        = UpToN xE (B.concat [bs,messagedata])
    setMessageData (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- LOSSY_GROUPCHAT
        = UpToN xE (B.concat [bs,messagedata])
    setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets
        = UpToN xE (B.concat [bs,peerinfosOrTitle])
    setMessageData _ _ = error "setMessageData on CryptoMessage without message data field."

messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x)
messageData = lens getMessageData setMessageData

class HasTitle x where
    getTitle :: x -> Text
    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)])
    setTitle _ _ = error "setTitle on CryptoMessage without title field."

title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
title = lens getTitle setTitle

class HasMessage x where
    getMessage :: x -> Text
    setMessage :: x -> Text -> x

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)])
    setMessage _ _ = error "setMessage on CryptoMessage without message field."

message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x)
message = lens getMessage setMessage

class HasName x where
    getName :: x -> Text
    setName :: x -> Text -> x


instance HasName CryptoMessage where
    -- Only MESSAGE_GROUPCHAT:NameChange has Name field
    getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata
    getName _   = error "getName on CryptoMessage without name field."

    -- If its not NameChange, this setter will set it to NameChange
    setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name
        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)])
    setName _ _ = error "setName on CryptoMessage without name field."

name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
name = lens getTitle setTitle

data PeerInfo
      = PeerInfo
         { piPeerNum :: PeerNumber
         , piUserKey :: PublicKey
         , piDHTKey  :: PublicKey
         , piName  :: ByteString -- byte-prefix for length
         } deriving (Eq,Show)

instance HasPeerNumber PeerInfo where
    getPeerNumber = piPeerNum
    setPeerNumber x n = x { piPeerNum = n }

instance Serialize PeerInfo where
    get = do
        w16 <- get
        ukey <- id2key <$> get
        dkey <- id2key <$> get
        w8 <- get :: Get Word8
        PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8)

    put (PeerInfo w16 ukey dkey bs) = do
        put w16
        put $ key2id ukey
        put $ key2id dkey
        let sz :: Word8
            sz = case B.length bs of
                    n | n <= 255  -> fromIntegral n
                      | otherwise -> 255
        put sz
        putByteString $ B.take (fromIntegral sz) bs


-- |
-- default constructor, handy for formations such as:
--
-- > 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

leaveMsg :: 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)


-- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as
-- 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 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

isIndirectGrpChat :: MessageID -> Bool
isIndirectGrpChat MESSAGE_GROUPCHAT = True
isIndirectGrpChat LOSSY_GROUPCHAT = True
isIndirectGrpChat _ = False


isKillPacket :: MessageType -> Bool
isKillPacket (Msg KillPacket) = True
isKillPacket _ = False

isOFFLINE :: MessageType -> Bool
isOFFLINE (Msg OFFLINE) = True
isOFFLINE _ = False




data MessageName = Ping -- 0x00
                 | MessageName0x01
                 | MessageName0x02
                 | MessageName0x03
                 | MessageName0x04
                 | MessageName0x05
                 | MessageName0x06
                 | MessageName0x07
                 | MessageName0x08
                 | MessageName0x09
                 | MessageName0x0a
                 | MessageName0x0b
                 | MessageName0x0c
                 | MessageName0x0d
                 | MessageName0x0e
                 | MessageName0x0f
                 | NewPeer  -- 0x10
                 | KillPeer -- 0x11
                 | MessageName0x12
                 | MessageName0x13
                 | MessageName0x14
                 | MessageName0x15
                 | MessageName0x16
                 | MessageName0x17
                 | MessageName0x18
                 | MessageName0x19
                 | MessageName0x1a
                 | MessageName0x1b
                 | MessageName0x1c
                 | MessageName0x1d
                 | MessageName0x1e
                 | MessageName0x1f
                 | MessageName0x20
                 | MessageName0x21
                 | MessageName0x22
                 | MessageName0x23
                 | MessageName0x24
                 | MessageName0x25
                 | MessageName0x26
                 | MessageName0x27
                 | MessageName0x28
                 | MessageName0x29
                 | MessageName0x2a
                 | MessageName0x2b
                 | MessageName0x2c
                 | MessageName0x2d
                 | MessageName0x2e
                 | MessageName0x2f
                 | NameChange -- 0x30
                 | GroupchatTitleChange -- 0x31
                 | MessageName0x32
                 | MessageName0x33
                 | MessageName0x34
                 | MessageName0x35
                 | MessageName0x36
                 | MessageName0x37
                 | MessageName0x38
                 | MessageName0x39
                 | MessageName0x3a
                 | MessageName0x3b
                 | MessageName0x3c
                 | MessageName0x3d
                 | MessageName0x3e
                 | MessageName0x3f
                 | ChatMessage -- 0x40
                 | Action -- 0x41
                 | MessageName0x42
                 | MessageName0x43
                 | MessageName0x44
                 | MessageName0x45
                 | MessageName0x46
                 | MessageName0x47
                 | MessageName0x48
                 | MessageName0x49
                 | MessageName0x4a
                 | MessageName0x4b
                 | MessageName0x4c
                 | MessageName0x4d
                 | MessageName0x4e
                 | MessageName0x4f
                 | MessageName0x50
                 | MessageName0x51
                 | MessageName0x52
                 | MessageName0x53
                 | MessageName0x54
                 | MessageName0x55
                 | MessageName0x56
                 | MessageName0x57
                 | MessageName0x58
                 | MessageName0x59
                 | MessageName0x5a
                 | MessageName0x5b
                 | MessageName0x5c
                 | MessageName0x5d
                 | MessageName0x5e
                 | MessageName0x5f
                 | MessageName0x60
                 | MessageName0x61
                 | MessageName0x62
                 | MessageName0x63
                 | MessageName0x64
                 | MessageName0x65
                 | MessageName0x66
                 | MessageName0x67
                 | MessageName0x68
                 | MessageName0x69
                 | MessageName0x6a
                 | MessageName0x6b
                 | MessageName0x6c
                 | MessageName0x6d
                 | MessageName0x6e
                 | MessageName0x6f
                 | MessageName0x70
                 | MessageName0x71
                 | MessageName0x72
                 | MessageName0x73
                 | MessageName0x74
                 | MessageName0x75
                 | MessageName0x76
                 | MessageName0x77
                 | MessageName0x78
                 | MessageName0x79
                 | MessageName0x7a
                 | MessageName0x7b
                 | MessageName0x7c
                 | MessageName0x7d
                 | MessageName0x7e
                 | MessageName0x7f
                 | MessageName0x80
                 | MessageName0x81
                 | MessageName0x82
                 | MessageName0x83
                 | MessageName0x84
                 | MessageName0x85
                 | MessageName0x86
                 | MessageName0x87
                 | MessageName0x88
                 | MessageName0x89
                 | MessageName0x8a
                 | MessageName0x8b
                 | MessageName0x8c
                 | MessageName0x8d
                 | MessageName0x8e
                 | MessageName0x8f
                 | MessageName0x90
                 | MessageName0x91
                 | MessageName0x92
                 | MessageName0x93
                 | MessageName0x94
                 | MessageName0x95
                 | MessageName0x96
                 | MessageName0x97
                 | MessageName0x98
                 | MessageName0x99
                 | MessageName0x9a
                 | MessageName0x9b
                 | MessageName0x9c
                 | MessageName0x9d
                 | MessageName0x9e
                 | MessageName0x9f
                 | MessageName0xa0
                 | MessageName0xa1
                 | MessageName0xa2
                 | MessageName0xa3
                 | MessageName0xa4
                 | MessageName0xa5
                 | MessageName0xa6
                 | MessageName0xa7
                 | MessageName0xa8
                 | MessageName0xa9
                 | MessageName0xaa
                 | MessageName0xab
                 | MessageName0xac
                 | MessageName0xad
                 | MessageName0xae
                 | MessageName0xaf
                 | MessageName0xb0
                 | MessageName0xb1
                 | MessageName0xb2
                 | MessageName0xb3
                 | MessageName0xb4
                 | MessageName0xb5
                 | MessageName0xb6
                 | MessageName0xb7
                 | MessageName0xb8
                 | MessageName0xb9
                 | MessageName0xba
                 | MessageName0xbb
                 | MessageName0xbc
                 | MessageName0xbd
                 | MessageName0xbe
                 | MessageName0xbf
                 | MessageName0xc0
                 | MessageName0xc1
                 | MessageName0xc2
                 | MessageName0xc3
                 | MessageName0xc4
                 | MessageName0xc5
                 | MessageName0xc6
                 | MessageName0xc7
                 | MessageName0xc8
                 | MessageName0xc9
                 | MessageName0xca
                 | MessageName0xcb
                 | MessageName0xcc
                 | MessageName0xcd
                 | MessageName0xce
                 | MessageName0xcf
                 | MessageName0xd0
                 | MessageName0xd1
                 | MessageName0xd2
                 | MessageName0xd3
                 | MessageName0xd4
                 | MessageName0xd5
                 | MessageName0xd6
                 | MessageName0xd7
                 | MessageName0xd8
                 | MessageName0xd9
                 | MessageName0xda
                 | MessageName0xdb
                 | MessageName0xdc
                 | MessageName0xdd
                 | MessageName0xde
                 | MessageName0xdf
                 | MessageName0xe0
                 | MessageName0xe1
                 | MessageName0xe2
                 | MessageName0xe3
                 | MessageName0xe4
                 | MessageName0xe5
                 | MessageName0xe6
                 | MessageName0xe7
                 | MessageName0xe8
                 | MessageName0xe9
                 | MessageName0xea
                 | MessageName0xeb
                 | MessageName0xec
                 | MessageName0xed
                 | MessageName0xee
                 | MessageName0xef
                 | MessageName0xf0
                 | MessageName0xf1
                 | MessageName0xf2
                 | MessageName0xf3
                 | MessageName0xf4
                 | MessageName0xf5
                 | MessageName0xf6
                 | MessageName0xf7
                 | MessageName0xf8
                 | MessageName0xf9
                 | MessageName0xfa
                 | MessageName0xfb
                 | MessageName0xfc
                 | MessageName0xfd
                 | MessageName0xfe
                 | 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