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

{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE KindSignatures     #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE PatternSynonyms    #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections      #-}
{-# LANGUAGE ViewPatterns       #-}
module Network.Tox.Crypto.Transport
    ( showCryptoMsg
    , parseCrypto
    , encodeCrypto
    , unpadCryptoMsg
    , decodeRawCryptoMsg
    , parseHandshakes
    , encodeHandshakes
    , CryptoData(..)
    , CryptoMessage(..)
    , MessageName(..)
    , CryptoPacket(..)
    , HandshakeData(..)
    , Handshake(..)
    , PeerInfo(..)
    , UserStatus(..)
    , TypingStatus(..)
    , GroupChatId(..)
    , MessageType(..)
    , isKillPacket, isOFFLINE
    , KnownLossyness(..)
    , AsWord16(..)
    , AsWord64(..)
    -- feild name classes
    , HasGroupChatID(..)
    , HasGroupNumber(..)
    , HasPeerNumber(..)
    , HasMessageNumber(..)
    , HasMessageName(..)
    , HasMessageData(..)
    , HasName(..)
    , HasTitle(..)
    , HasMessage(..)
    , HasMessageType(..)
    -- lenses
    , groupNumber, groupNumberToJoin, peerNumber, messageNumber
    , messageName, messageData, name, title, message, messageType
    -- constructor
    -- utils
    , sizedN
    , sizedAtLeastN
    , isIndirectGrpChat
    , fromEnum8
    , fromEnum16
    , toEnum8
    , getCryptoMessage
    , putCryptoMessage
    ) where

import Crypto.Tox
import Data.Tox.Msg
import Network.Tox.DHT.Transport (Cookie)
import Network.Tox.NodeId
import DPut
import DebugTag
import Data.PacketBuffer as PB

import Network.Socket
import Data.ByteArray
import Data.Dependent.Sum

import Control.Monad
import Data.ByteString as B
import Data.Function
import Data.Maybe
import Data.Monoid
import Data.Word
import Data.Bits
import Crypto.Hash
import Control.Lens
import Data.Text as T
import Data.Text.Encoding as T
import Data.Serialize as S
import Control.Arrow
import GHC.TypeNats

showCryptoMsg :: Word32 -> CryptoMessage -> [Char]
showCryptoMsg _  msg = show msg

parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr)
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)

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
                        <*> getPublicKey
                        <*> (fromJust . digestFromByteString <$> getBytes 64)
                        <*> get
    put (HandshakeData n k h c) = do
        put n
        putPublicKey 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 = do
        ack <- get
        seqno <- get
        cm <- getCryptoMessage ack
        return $ CryptoData ack seqno cm
    put (CryptoData ack seqno dta) = do
        put ack
        put seqno
        putCryptoMessage ack dta

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 msg@(Pkt Padding :=> Identity (Padded bs)) =
    let unpadded = B.dropWhile (== msgbyte Padding) bs
    in either (const msg) id $ runGet (getCryptoMessage 0) unpadded
unpadCryptoMsg msg = msg

decodeRawCryptoMsg :: CryptoData -> CryptoMessage
decodeRawCryptoMsg (CryptoData ack seqno cm) = unpadCryptoMsg cm

instance Sized CryptoMessage where
    size = VarSize $ \case
        Pkt t :=> Identity x -> case sizeFor t of
            ConstSize sz -> 1 + sz
            VarSize   f  -> 1 + f x

sizeFor :: Sized x => p x -> Size x
sizeFor _ = size


getCryptoMessage :: Word32 -> Get CryptoMessage
getCryptoMessage seqno = do
        t <- getWord8
        case msgTag t of
            Just (M msg) -> do x <- getPacket seqno
                               return $ Pkt msg ==> x
            Nothing      -> return $ Pkt Padding ==> Padded mempty

putCryptoMessage :: Word32 -> CryptoMessage -> Put
putCryptoMessage seqno (Pkt t :=> Identity x) = do
    putWord8 (msgbyte t)
    putPacket seqno x


erCompat :: String -> a
erCompat lens = error $ "Use of '" ++ lens ++ "'  lens on incompatible CryptoMessage type"


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 (Pkt INVITE_CONFERENCE :=> Identity 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 (Pkt ONLINE_PACKET :=> Identity payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload))
    getGroupChatID _ = error "getGroupChatID on non-groupchat message."

    -- Set
    setGroupChatID msg@(Pkt INVITE_CONFERENCE :=> Identity 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 (Pkt ONLINE_PACKET :=> Identity payload) (GrpId newid) = Pkt 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 (Pkt INVITE_CONFERENCE :=> Identity (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 Word8
                 | 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


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 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)
title = lens getTitle setTitle

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 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

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 <- getPublicKey
        dkey <- getPublicKey
        w8 <- get :: Get Word8
        PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8)

    put (PeerInfo w16 ukey dkey bs) = do
        put w16
        putPublicKey ukey
        putPublicKey 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
        | Just (True,1)  <- msgSizeParam mid = TwoByte mid 0
        | Just (False,_) <- msgSizeParam mid = UpToN   mid B.empty
        | otherwise                          = UpToN   mid B.empty
-}

{-
leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage
leaveMsg     groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01)
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 :: Msg n t -> Bool
isIndirectGrpChat MESSAGE_CONFERENCE = True
isIndirectGrpChat LOSSY_CONFERENCE   = True
isIndirectGrpChat _                  = False

isKillPacket :: SomeMsg -> Bool
isKillPacket (M KillPacket) = True
isKillPacket _              = False

isOFFLINE :: SomeMsg -> Bool
isOFFLINE (M 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)