5 files changed, 634 insertions, 68 deletions

diff --git a/dht-client.cabal b/dht-client.cabal
index 6ad4ad37..b17ceb14 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -80,6 +80,7 @@ library
                     Network.BitTorrent.MainlineDHT
                     Network.BitTorrent.MainlineDHT.Symbols
                     System.Global6
+                    Data.PacketQueue
                     Data.Word64Map
                     OnionRouter
                     Network.Tox
@@ -170,6 +171,8 @@ library
                     , transformers-base
                     , mtl
                     , ghc-prim
+                    , sensible-directory
+                    , temporary
                     , transformers
                     , conduit
                     , conduit-extra
diff --git a/src/Crypto/Tox.hs b/src/Crypto/Tox.hs
index 665a38dd..624da233 100644
--- a/src/Crypto/Tox.hs
+++ b/src/Crypto/Tox.hs
@@ -34,11 +34,13 @@ module Crypto.Tox
     , decodePlain
     -- , computeSharedSecret
     , lookupSharedSecret
+    , lookupNonceFunction
     , encrypt
     , decrypt
     , Nonce8(..)
     , Nonce24(..)
     , incrementNonce24
+    , nonce24ToWord16
     , addtoNonce24
     , Nonce32(..)
     , getRemainingEncrypted
@@ -297,16 +299,29 @@ unsafeCompare32Bytes' !n !pa !pb = do
 
 
 lookupSharedSecret :: TransportCrypto -> SecretKey -> PublicKey -> Nonce24 -> IO State
-lookupSharedSecret TransportCrypto{secretsCache} sk recipient nonce = do
+lookupSharedSecret crypto sk recipient nonce
+    = ($ nonce) <$> lookupNonceFunction crypto sk recipient
+
+{-# INLINE lookupNonceFunction #-}
+lookupNonceFunction :: TransportCrypto -> SecretKey -> PublicKey -> IO (Nonce24 -> State)
+lookupNonceFunction c@(TransportCrypto{secretsCache}) sk recipient = do
     now <- getPOSIXTime
-    atomically $ do
+    atomically $ lookupNonceFunctionSTM now c sk recipient
+
+{-# INLINE lookupNonceFunctionSTM #-}
+-- | This version of 'lookupNonceFunction' is STM instead of IO, this means if some later part of
+--   of the transaction fails, we may end up forgoing a computation that could have been cached.
+--   Use with care. In most circumstances you probably want 'lookupNonceFunction'. It also commits
+--   us to using TVars to store the cache.
+lookupNonceFunctionSTM :: POSIXTime -> TransportCrypto -> SecretKey -> PublicKey -> STM (Nonce24 -> State)
+lookupNonceFunctionSTM now TransportCrypto{secretsCache} sk recipient = do
     mm <- readTVar $ sharedSecret secretsCache
     case MM.lookup' recipient mm of
         Nothing -> do
             let miss = computeSharedSecret sk recipient
             writeTVar (sharedSecret secretsCache)
                       (MM.insertTake' 160 recipient (MM.singleton' sk miss (Down now)) (Down now) mm)
-            return $ miss nonce
+            return miss
         Just (stamp,smm) -> do
             let (r,v) = case MM.lookup' sk smm of
                     Nothing | let miss = computeSharedSecret sk recipient
@@ -314,7 +329,7 @@ lookupSharedSecret TransportCrypto{secretsCache} sk recipient nonce = do
                     Just (stamp2,hit) -> (hit , MM.insert' sk hit (Down now) smm)
             writeTVar (sharedSecret secretsCache)
                       (MM.insertTake' 160 recipient v (Down now) mm)
-            return $ r nonce
+            return r
 
 
 hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes
@@ -328,7 +343,10 @@ hsalsa20 k n = BA.append a b
 
 
 newtype Nonce24 = Nonce24 ByteString
- deriving (Eq, Ord, ByteArrayAccess,Data)
+ deriving (Eq, Ord, ByteArrayAccess, Data)
+
+nonce24ToWord16 :: Nonce24 -> Word16
+nonce24ToWord16 (Nonce24 n24) = fromIntegral (B.index n24 23) + 256 * fromIntegral (B.index n24 22)
 
 addtoNonce24 :: Nonce24 -> Word -> IO Nonce24
 addtoNonce24 (Nonce24 n24) n = Nonce24 <$> BA.copy n24 init
@@ -372,6 +390,7 @@ addtoNonce24 (Nonce24 n24) n = Nonce24 <$> BA.copy n24 init
             pokeElemOff ptr 5 $ tBE32 (W# sum_)
         init _ = error "incrementNonce24: I only support 64 and 32 bits"
 
+{-# INLINE incrementNonce24 #-}
 incrementNonce24 :: Nonce24 -> IO Nonce24
 incrementNonce24 nonce24 = addtoNonce24 nonce24 1
 
diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs
new file mode 100644
index 00000000..927d6c53
--- /dev/null
+++ b/src/Data/PacketQueue.hs
@@ -0,0 +1,170 @@
+-- | This module is useful for implementing a lossess protocol on top of a
+-- lossy datagram style protocol.  It implements a buffer in which packets may
+-- be stored out of order, but from which they are extracted in the proper
+-- sequence.
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Data.PacketQueue
+    ( PacketQueue
+    , new
+    , dequeue
+    , enqueue
+    , observeOutOfBand
+    , PacketOutQueue
+    , newOutGoing
+    , tryAppendQueueOutgoing
+    , dequeueOutgoing
+    , mapOutGoing
+    , OutGoingResult(..)
+    ) where
+
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TArray
+import Control.Monad
+import Data.Word
+import Data.Array.MArray
+
+data PacketQueue a = PacketQueue
+    { pktq    :: TArray Word32 (Maybe a)
+    , seqno   :: TVar Word32
+    , qsize   :: Word32
+    , buffend :: TVar Word32 -- on incoming, highest packet number handled + 1
+    }
+
+-- | Create a new PacketQueue.
+new :: Word32 -- ^ Capacity of queue.
+    -> Word32 -- ^ Initial sequence number.
+    -> STM (PacketQueue a)
+new capacity seqstart = do
+    let cap = if capacity `mod` 2 == 0 then capacity else capacity + 1
+    q <- newArray (0,cap - 1) Nothing
+    seqv <- newTVar seqstart
+    bufe <- newTVar 0
+    return PacketQueue
+        { pktq    = q
+        , seqno   = seqv
+        , qsize   = cap
+        , buffend = bufe
+        }
+
+observeOutOfBand :: PacketQueue a -> Word32-> STM ()
+observeOutOfBand PacketQueue { seqno, qsize, buffend } no = do
+    low <- readTVar seqno
+    let proj = no - low
+    -- Ignore packet if out of range.
+    when ( proj < qsize) $ do
+    modifyTVar' buffend (\be -> if be - low <= proj then no + 1 else be)
+
+
+-- | Retry until the next expected packet is enqueued.  Then return it.
+dequeue :: PacketQueue a -> STM a
+dequeue PacketQueue { pktq, seqno, qsize } = do
+    i0 <- readTVar seqno
+    let i = i0 `mod` qsize
+    x <- maybe retry return =<< readArray pktq i
+    writeArray pktq i Nothing
+    modifyTVar' seqno   succ
+    return x
+
+-- | Enqueue a packet.  Packets need not be enqueued in order as long as there
+-- is spare capacity in the queue.  If there is not, the packet will be
+-- silently discarded without blocking.
+enqueue :: PacketQueue a -- ^ The packet queue.
+        -> Word32        -- ^ Sequence number of the packet.
+        -> a             -- ^ The packet.
+        -> STM ()
+enqueue PacketQueue{ pktq, seqno, qsize, buffend } no x = do
+    low <- readTVar seqno
+    let proj = no - low
+    -- Ignore packet if out of range.
+    when ( proj < qsize) $ do
+    let i = no `mod` qsize
+    writeArray pktq i (Just x)
+    modifyTVar' buffend (\be -> if be - low <= proj then no + 1 else be)
+
+-- lookup :: PacketQueue a -> Word32 -> STM (Maybe a)
+-- lookup PacketQueue{ pktq, seqno, qsize } no = _todo
+
+-----------------------------------------------------
+-- * PacketOutQueue
+--
+
+data PacketOutQueue extra msg toWire fromWire = PacketOutQueue
+    { pktoInPQ   :: PacketQueue fromWire -- ^ reference to the incoming 'PacketQueue'
+    , pktoOutPQ  :: PacketQueue (Word32,toWire)
+    , pktoPacketNo :: TVar Word32
+    , pktoToWireIO :: IO (STM extra)
+    , pktoToWire :: STM extra
+                 -> Word32{-packet number we expect to recieve-}
+                 -> Word32{- buffer_end -}
+                 -> Word32{- packet number -}
+                 -> msg
+                 -> STM (Maybe (toWire,Word32{-next packet no-}))
+    }
+
+mapOutGoing :: ((Word32,towire) -> Maybe (Word32,towire)) -> PacketOutQueue extra msg towire fromwire -> STM ()
+mapOutGoing f q@(PacketOutQueue { pktoOutPQ=PacketQueue{ pktq } }) = do
+    (z,n) <- getBounds pktq
+    let ff i = do
+        e <- readArray pktq i
+        writeArray pktq i (e>>=f)
+    mapM_ ff [z .. n]
+
+newOutGoing :: PacketQueue fromwire
+                      -- ^ Incoming queue
+            -> (STM io -> Word32 {-packet number we expect to recieve-} -> Word32{-buffer_end-} -> Word32{-packet number-} -> msg -> STM (Maybe (wire,Word32{-next packet no-})))
+                      -- ^ toWire callback
+            -> IO (STM io)
+                      -- ^ io action to get extra parameter
+            -> Word32 -- ^ packet number of first outgoing packet
+            -> Word32 -- ^ Capacity of queue.
+            -> Word32 -- ^ Initial sequence number.
+            -> STM (PacketOutQueue io msg wire fromwire)
+newOutGoing inq towire toWireIO num capacity seqstart = do
+    outq <- new capacity seqstart
+    numVar <- newTVar num
+    return $ PacketOutQueue
+                { pktoInPQ = inq
+                , pktoOutPQ = outq
+                , pktoPacketNo = numVar
+                , pktoToWireIO = toWireIO
+                , pktoToWire = towire
+                }
+
+data OutGoingResult = OGSuccess | OGFull | OGEncodeFail
+    deriving (Eq,Show)
+
+-- | Convert a message to packet format and append it to the front of a queue
+--   used for outgoing messages. (Note that ‘front‛ usually means the higher
+--   index in this implementation.)
+tryAppendQueueOutgoing :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM OutGoingResult
+tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg = do
+    be <- readTVar (buffend pktoOutPQ)
+    let i = be `mod` (qsize pktoOutPQ)
+    mbPkt <- readArray (pktq pktoOutPQ) i
+    pktno <- readTVar pktoPacketNo
+    nextno <- readTVar (seqno pktoInPQ)
+    mbWire <- pktoToWire getExtra nextno be pktno msg
+    case mbWire of
+        Just (pkt,pktno')
+            -> case mbPkt of
+                    -- slot is free, insert element
+                    Nothing -> do
+                        modifyTVar' (buffend pktoOutPQ) (+1)
+                        writeTVar pktoPacketNo $! pktno'
+                        writeArray (pktq pktoOutPQ) i (Just (pktno,pkt))
+                        return OGSuccess
+                    -- queue is full, block until its not
+                    _       -> return OGFull
+        -- don't know how to send this message
+        Nothing -> return OGEncodeFail
+
+dequeueOutgoing :: PacketOutQueue extra msg wire fromwire -> STM (Word32,wire)
+dequeueOutgoing (PacketOutQueue {pktoOutPQ=PacketQueue { pktq, seqno, qsize }}) = do
+    i0 <- readTVar seqno
+    let i = i0 `mod` qsize
+    x <- maybe retry return =<< readArray pktq i
+    -- writeArray pktq i Nothing -- not cleaning
+    modifyTVar' seqno   succ
+    return x
+
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index ac3d1ef0..6a79da1b 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -1,9 +1,12 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
 module Network.Tox.Crypto.Handlers where
 
+import Network.Tox.NodeId
 import Network.Tox.Crypto.Transport
-import Network.Tox.DHT.Transport (Cookie(..),CookieData(..))
+import Network.Tox.DHT.Transport (Cookie(..),CookieData(..), CookieRequest(..))
+import Network.Tox.DHT.Handlers (Client, cookieRequest, cookieRequestH )
 import Crypto.Tox
 import Control.Concurrent.STM
 import Network.Address
@@ -13,12 +16,25 @@ import Control.Applicative
 import Control.Monad
 import Data.Time.Clock.POSIX
 import qualified Data.ByteString  as B
+import Data.ByteString (ByteString)
 import Control.Lens
 import Data.Function
+import qualified Data.PacketQueue as PQ
+         ;import Data.PacketQueue (PacketQueue)
 import Data.Serialize             as S
 import Data.Word
+import qualified Data.Word64Map as W64
 import GHC.Conc (unsafeIOToSTM)
 import qualified Data.Set         as Set
+import qualified Data.Array.Unboxed as A
+import SensibleDir
+import System.FilePath
+import System.IO.Temp
+import System.Environment
+import System.Directory
+import Control.Concurrent
+import GHC.Conc (labelThread)
+import System.IO.Unsafe(unsafeDupablePerformIO {- unsafeIOToSTM -})
 
 -- util, todo: move to another module
 maybeToEither :: Maybe b -> Either String b
@@ -31,59 +47,232 @@ data NetCryptoSessionStatus = Unaccepted | Accepted | Confirmed
 
 type IOHook addr x = addr -> x -> IO (Maybe (x -> x))
 type NetCryptoHook = IOHook NetCryptoSession CryptoData
+type MsgTypeArray = A.UArray Word8 Word16
+type MsgOutMap = W64.Word64Map Word8
+-- type MsgOutMap = A.UArray Word64 Word8 -- if above is too slow, switch to this, but use reasonable bounds
+msgOutMapLookup :: Word64 -> MsgOutMap -> Maybe Word8
+msgOutMapLookup = W64.lookup
 
+-- | Information, that may be made visible in multiple sessions, as well
+-- as displayed in some way to the user via mutiple views.
+--
+data SessionView = SessionView
+        { svNick :: TVar ByteString
+        , svStatus :: TVar UserStatus
+        , svStatusMsg :: TVar ByteString
+        , svGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr))
+        -- allthough these directories are not visible to others on the net
+        -- they are included in this type, because it facilitates organizing
+        -- the disk according to your public image.
+        , svCacheDir :: FilePath -- ^ directory path used if the session has to use the disk for cache
+                                 --   clean up only if space is needed
+        , svTmpDir :: FilePath -- ^ Once off storage goes here, should clean up quickly
+        , svConfigDir :: FilePath -- ^ profile related storage, etc, never clean up
+        , svDownloadDir :: TVar FilePath -- ^ where to put files the user downloads
+        }
 
-data NetCryptoSession = NCrypto { ncState         :: TVar NetCryptoSessionStatus
+type SessionID = Word64
+
+data NetCryptoSession = NCrypto { ncState          :: TVar NetCryptoSessionStatus
+                                , ncSessionId      :: SessionID
+                                , ncTheirPublicKey :: PublicKey -- Tox id w/o nospam
                                 , ncTheirBaseNonce :: TVar Nonce24 -- base nonce + packet number
                                 , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number
                                 , ncHandShake     :: TVar (Maybe (Handshake Encrypted))
-                                , ncCookie        :: TVar (Maybe Cookie)
+                                , ncCookie        :: TVar (Maybe Cookie) -- ^ Cookie issued by remote peer
                                 , ncTheirDHTKey   :: PublicKey
                                 , ncTheirSessionPublic :: Maybe PublicKey
                                 , ncSessionSecret :: SecretKey
                                 , ncSockAddr      :: SockAddr
                                 , ncHooks         :: TVar (Map.Map MessageType [NetCryptoHook])
                                 , ncUnrecognizedHook :: TVar (MessageType -> NetCryptoHook)
+                                , ncIncomingTypeArray :: TVar MsgTypeArray
+                                                                      -- ^ supported messages, 0 for unsupported,
+                                                                      --   otherwise the messageType, some message types
+                                                                      --   may not be in ncHooks yet, but they should appear
+                                                                      --   here if ncUnrecognizedHook will add them to ncHooks
+                                                                      --   on an as-need basis.
+                                , ncOutgoingIdMap :: TVar MsgOutMap
                                 , ncAllSessions :: NetCryptoSessions -- ^ may be needed if one net-crypto session
                                                                      --   needs to possibly start another, as is
                                                                      --   the case in group chats
-                                , ncGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr))
+                                , ncView :: TVar SessionView
+                                , ncPacketQueue :: PacketQueue CryptoData
+                                , ncBufferStart :: TVar Word32
+                                , ncDequeueThread :: Maybe ThreadId
+                                , ncOutgoingQueue :: PQ.PacketOutQueue (State,Nonce24,TVar MsgOutMap) CryptoMessage (CryptoPacket Encrypted) CryptoData
                                 }
 
 data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession)
+                                    , netCryptoSessionsByKey :: TVar (Map.Map PublicKey [NetCryptoSession])
                                     , transportCrypto :: TransportCrypto
                                     , defaultHooks :: Map.Map MessageType [NetCryptoHook]
                                     , defaultUnrecognizedHook :: MessageType -> NetCryptoHook
+                                    , sessionView :: SessionView
+                                    , msgTypeArray :: MsgTypeArray
+                                    , inboundQueueCapacity :: Word32
+                                    , outboundQueueCapacity :: Word32
+                                    , nextSessionId :: TVar SessionID
                                     }
 
-newSessionsState :: TransportCrypto -> (MessageType -> NetCryptoHook) -> Map.Map MessageType [NetCryptoHook] -> IO NetCryptoSessions
+forgetCrypto :: TransportCrypto -> NetCryptoSessions -> NetCryptoSession -> STM ()
+forgetCrypto crypto (NCSessions {netCryptoSessions,netCryptoSessionsByKey}) session = do
+    let addr = ncSockAddr session
+        sid = ncSessionId session
+        sPubKey = ncTheirPublicKey session
+    byAddrMap <- readTVar netCryptoSessions
+ {- byKeyMap  <- readTVar netCryptoSessionsByKey -}
+    case Map.lookup addr byAddrMap of
+        Nothing -> return () -- already gone
+        Just _ -> do
+            modifyTVar netCryptoSessions      (Map.delete addr)
+            modifyTVar netCryptoSessionsByKey (Map.update (\xs -> case filter (\x -> ncSessionId x /= sid) xs of
+                                                                    [] -> Nothing
+                                                                    ys -> Just ys) sPubKey)
+
+-- | initiate a netcrypto session, blocking
+netCrypto :: TransportCrypto -> NetCryptoSessions -> SecretKey -> PublicKey -> IO NetCryptoSession
+netCrypto crypto allsessions myseckey theirpubkey = do
+-- convert public key to NodeInfo check Roster
+-- if no session:
+-- 1) send dht key, actually maybe send dht-key regardless
+-- 2) send handshakes to last seen ip's, if any
+--
+-- if sessions found, is it using this private key?
+-- if not, send handshake, this is separate session
+    error "todo"
+
+newSessionsState :: TransportCrypto
+                 -> (MessageType -> NetCryptoHook) -- ^ default hook
+                 -> Map.Map MessageType [NetCryptoHook] -- ^ all hooks, can be empty to start
+                 -> IO NetCryptoSessions
 newSessionsState crypto unrechook hooks = do
     x <- atomically $ newTVar Map.empty
+    x2 <- atomically $ newTVar Map.empty
+    nick <- atomically $ newTVar B.empty
+    status <- atomically $ newTVar Online
+    statusmsg <- atomically $ newTVar B.empty
+    grps <- atomically $ newTVar Map.empty
+    pname <- getProgName
+    cachedir <- sensibleCacheDirCreateIfMissing pname
+    tmpdir <- (</> pname) <$> (getTemporaryDirectory >>= canonicalizePath) -- getCanonicalTemporaryDirectory
+    configdir <- sensibleVarLib pname
+    homedir <- getHomeDirectory
+    svDownloadDir0 <- atomically $ newTVar (homedir </> "Downloads")
+    nextSessionId0 <- atomically $ newTVar 0
     return NCSessions { netCryptoSessions = x
+                      , netCryptoSessionsByKey = x2
                       , transportCrypto = crypto
                       , defaultHooks = hooks
                       , defaultUnrecognizedHook = unrechook
+                      , sessionView = SessionView { svNick = nick
+                                                  , svStatus = status
+                                                  , svStatusMsg = statusmsg
+                                                  , svGroups = grps
+                                                  , svCacheDir = cachedir
+                                                  , svTmpDir = tmpdir
+                                                  , svConfigDir = configdir
+                                                  , svDownloadDir = svDownloadDir0
+                                                  }
+                      , msgTypeArray = allMsgTypes -- todo make this a parameter
+                      , inboundQueueCapacity = 200
+                      , outboundQueueCapacity = 400
+                      , nextSessionId = nextSessionId0
                       }
 
 data HandshakeParams
         = HParam
             { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own
-            , hpOtherCookie :: Maybe Cookie
+            , hpOtherCookie :: Cookie
             , hpTheirSessionKeyPublic :: PublicKey
             , hpMySecretKey :: SecretKey
             , hpCookieRemotePubkey :: PublicKey
             , hpCookieRemoteDhtkey :: PublicKey
             }
-newHandShakeData :: TransportCrypto -> HandshakeParams -> HandshakeData
-newHandShakeData = error "todo"
+newHandShakeData :: TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> IO (Maybe HandshakeData)
+newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr
+    = do
+    freshCookie
+      <- case  nodeInfo (key2id hpCookieRemoteDhtkey) addr  of
+            Right nodeinfo -> Just <$> cookieRequestH crypto nodeinfo (CookieRequest hpCookieRemotePubkey)
+            Left er        -> return Nothing
+    let hinit = hashInit
+        Cookie n24 encrypted = hpOtherCookie
+        hctx = hashUpdate hinit n24
+        hctx' = hashUpdate hctx encrypted
+        digest = hashFinalize hctx'
+-- parameters addr {--> SockAddr -}
+--    mbcookie <- case hpOtherCookie of
+--                    Nothing -> case (nodeInfo hpCookieRemoteDhtkey addr) of
+--                                Right nodeinfo -> cookieRequest crypto netCryptoDHTClient (toPublic hpMySecretKey) nodeinfo
+--                                Left er -> return Nothing
+--                    Just c -> return (Just c)
+
+    return $
+      fmap (\freshCookie' ->
+            HandshakeData
+                { baseNonce = basenonce
+                , sessionKey = toPublic hpMySecretKey
+                , cookieHash = digest
+                , otherCookie = freshCookie'
+                }) freshCookie
+
+type XMessage = CryptoMessage -- todo
+
+ncToWire :: STM (State,Nonce24,TVar MsgOutMap)
+         -> Word32{- packet number we expect to recieve -}
+         -> Word32{- buffer_end -}
+         -> Word32{- packet number -}
+         -> XMessage
+         -> STM (Maybe (CryptoPacket Encrypted,Word32{-next packet no-}))
+ncToWire getState seqno bufend pktno msg = do
+    let typ = getMessageType msg
+        typ64 = toWord64 typ
+    let lsness msg =
+            case typ of
+                    Msg mid -> lossyness mid
+                    GrpMsg KnownLossy _ -> Lossy
+                    GrpMsg KnownLossless _ -> Lossless
+    (state,n24,msgOutMapVar) <- getState
+    msgOutMap <- readTVar msgOutMapVar
+    case msgOutMapLookup typ64 msgOutMap of
+        Just outid -> do
+            let setMessageId (OneByte _)   mid = OneByte (toEnum8 mid)
+                setMessageId (TwoByte _ x) mid = TwoByte (toEnum8 mid) x
+                setMessageId (UpToN _ x)   mid = UpToN (toEnum8 mid) x
+                msg' = setMessageId msg outid
+                in case lsness msg of
+                        UnknownLossyness -> return Nothing
+                        Lossy    -> let cd =
+                                         CryptoData
+                                            { bufferStart = seqno
+                                            , bufferEnd = bufend
+                                            , bufferData = msg'
+                                            }
+                                        plain = encodePlain cd
+                                        encrypted = encrypt state plain
+                                        pkt = CryptoPacket { pktNonce = nonce24ToWord16 n24, pktData = encrypted }
+                                        in return (Just (pkt, pktno))
+                        Lossless -> let cd =
+                                         CryptoData
+                                            { bufferStart = seqno
+                                            , bufferEnd = pktno
+                                            , bufferData = msg'
+                                            }
+                                        plain = encodePlain cd
+                                        encrypted = encrypt state plain
+                                        pkt = CryptoPacket { pktNonce = nonce24ToWord16 n24, pktData = encrypted }
+                                        in return (Just (pkt, pktno+1))
 
 -- | called when we recieve a crypto handshake with valid cookie
+-- TODO set priority on contact addr to 0 if it is older than ForgetPeriod,
+-- then increment it regardless. (Keep addr in MinMaxPSQ in Roster.Contact)
 freshCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> IO ()
 freshCryptoSession  sessions
                     addr
                     hp@(HParam
                               { hpTheirBaseNonce = Just theirBaseNonce
-                              , hpOtherCookie    = Just otherCookie
+                              , hpOtherCookie    = otherCookie
                               , hpTheirSessionKeyPublic = theirSessionKey
                               , hpMySecretKey        = key
                               , hpCookieRemotePubkey = remotePublicKey
@@ -91,26 +280,48 @@ freshCryptoSession  sessions
                               }) = do
     let crypto = transportCrypto sessions
         allsessions = netCryptoSessions sessions
+        allsessionsByKey = netCryptoSessionsByKey sessions
+    sessionId <- atomically $ do
+        x <- readTVar (nextSessionId sessions)
+        modifyTVar    (nextSessionId sessions) (+1)
+        return x
     ncState0 <- atomically $ newTVar Accepted
     ncTheirBaseNonce0 <- atomically $ newTVar theirBaseNonce
     n24 <- atomically $ transportNewNonce crypto
     state <- lookupSharedSecret crypto key remoteDhtPublicKey n24
-    let myhandshakeData = newHandShakeData crypto hp
-        plain = encodePlain myhandshakeData
-        encrypted = encrypt state plain
-        myhandshake = Handshake { handshakeCookie = otherCookie
-                                , handshakeNonce = n24
-                                , handshakeData = encrypted
-                                }
-    ncMyPacketNonce0 <- atomically $ newTVar (baseNonce myhandshakeData)
-    ncHandShake0 <- atomically $ newTVar (Just myhandshake)
+    newBaseNonce <- atomically $ transportNewNonce crypto
+    mbMyhandshakeData <- newHandShakeData crypto newBaseNonce hp addr
+    let encodeHandshake myhandshakeData = let plain = encodePlain myhandshakeData
+    --                                        state = computeSharedSecret key remoteDhtPublicKey n24
+                                              encrypted = encrypt state plain
+                                              in Handshake { handshakeCookie = otherCookie
+                                                           , handshakeNonce = n24
+                                                           , handshakeData = encrypted
+                                                           }
+    let myhandshake= encodeHandshake <$> mbMyhandshakeData
+    ncMyPacketNonce0 <- atomically $ newTVar newBaseNonce
+    ncHandShake0 <- atomically $ newTVar myhandshake
     cookie0 <- atomically $ newTVar (Just otherCookie)
     newsession <- generateSecretKey
     ncHooks0 <- atomically $ newTVar (defaultHooks sessions)
     ncUnrecognizedHook0 <- atomically $ newTVar (defaultUnrecognizedHook sessions)
-    ncGroups0 <- atomically $ newTVar (Map.empty)
-    let netCryptoSession =
+    ncIncomingTypeArray0 <- atomically $ newTVar (msgTypeArray sessions)
+    ncOutgoingIdMap0 <- atomically $ newTVar W64.empty
+    ncView0 <- atomically $ newTVar (sessionView sessions)
+    pktq <- atomically $ PQ.new (inboundQueueCapacity sessions) 0
+    bufstart <- atomically $ newTVar 0
+    let toWireIO = do
+            f <- lookupNonceFunction crypto newsession theirSessionKey
+            atomically $ do
+                n24 <- readTVar ncMyPacketNonce0
+                let n24plus1 = unsafeDupablePerformIO (incrementNonce24 n24)
+                writeTVar ncMyPacketNonce0 n24plus1
+                return (return (f n24, n24, ncOutgoingIdMap0))
+    pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0
+    let netCryptoSession0 =
             NCrypto { ncState         = ncState0
+                    , ncSessionId     = sessionId
+                    , ncTheirPublicKey = remotePublicKey
                     , ncTheirBaseNonce= ncTheirBaseNonce0
                     , ncMyPacketNonce   = ncMyPacketNonce0
                     , ncHandShake     = ncHandShake0
@@ -122,9 +333,28 @@ freshCryptoSession  sessions
                     , ncHooks         = ncHooks0
                     , ncUnrecognizedHook = ncUnrecognizedHook0
                     , ncAllSessions = sessions
-                    , ncGroups = ncGroups0
+                    , ncIncomingTypeArray = ncIncomingTypeArray0
+                    , ncOutgoingIdMap     = ncOutgoingIdMap0
+                    , ncView = ncView0
+                    , ncPacketQueue        = pktq
+                    , ncBufferStart        = bufstart
+                    , ncDequeueThread      = Nothing -- error "you want the NetCrypto-Dequeue thread id, but is it started?"
+                    , ncOutgoingQueue      = pktoq
                     }
-    atomically $ modifyTVar allsessions (Map.insert addr netCryptoSession)
+    threadid <- forkIO $ do
+        tid <- myThreadId
+        labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey))
+        fix $ \loop -> do
+            cd <- atomically $ PQ.dequeue pktq
+            _ <- runCryptoHook (netCryptoSession0 {ncDequeueThread=Just tid}) cd
+            loop
+    let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid}
+    atomically $ do
+        modifyTVar allsessions (Map.insert addr netCryptoSession)
+        byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey
+        case byKeyResult of
+            Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession])
+            Just xs -> modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs))
 
 -- | Called when we get a handshake, but there's already a session entry.
 updateCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> NetCryptoSession -> IO ()
@@ -137,7 +367,7 @@ updateCryptoSession sessions addr hp session = do
         -- duplicate handshake packet, otherwise disregard everything, and
         -- refresh all state.
         --
-     then when (  Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp
+     then when (  Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp -- XXX: Do we really want to compare base nonce here?
                || ncTheirDHTKey session /= hpCookieRemoteDhtkey hp
                ) $ freshCryptoSession sessions addr hp
      else if ( Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp)
@@ -172,11 +402,12 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non
                 digest = hashFinalize hctx'
             guard (cookieHash == digest)
             -- known friend?
-            -- todo
+            -- todo TODO, see Roster.hs,
+            -- talk to not yet existent Network-Manager to ascertain current permissions
             return
              HParam
                 { hpTheirBaseNonce = Just baseNonce
-                , hpOtherCookie    = Just otherCookie
+                , hpOtherCookie    = otherCookie
                 , hpTheirSessionKeyPublic =  sessionKey
                 , hpMySecretKey        = key
                 , hpCookieRemotePubkey = remotePubkey
@@ -186,7 +417,7 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non
         Left _ -> return ()
         Right hp@(HParam
                       { hpTheirBaseNonce = Just theirBaseNonce
-                      , hpOtherCookie    = Just otherCookie
+                      , hpOtherCookie    = otherCookie
                       , hpTheirSessionKeyPublic = theirSessionKey
                       , hpMySecretKey        = key
                       , hpCookieRemotePubkey = remotePublicKey
@@ -207,7 +438,7 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
     -- Handle Encrypted Message
     case Map.lookup addr sessionsmap of
         Nothing -> return Nothing -- drop packet, we have no session
-        Just session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce}) -> do
+        Just session@(NCrypto {ncIncomingTypeArray, ncState, ncPacketQueue, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce}) -> do
             theirBaseNonce <- atomically $ readTVar ncTheirBaseNonce
             -- Try to decrypt message
             let diff :: Word16
@@ -236,32 +467,18 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
                             writeTVar ncTheirBaseNonce y
                     -- then set session confirmed,
                     atomically $ writeTVar ncState Confirmed
-                    hookmap <- atomically $ readTVar ncHooks
-                    -- run hook
-                    flip fix (cd,hookmap) $ \lookupAgain (cd,hookmap) -> do
-                        let msgTyp = cd ^. messageType
-                        case Map.lookup msgTyp hookmap of
-                                Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result
-                                             unrecognize <- atomically $ readTVar (ncUnrecognizedHook session)
-                                             mbConsume <- unrecognize msgTyp session cd
-                                             case mbConsume of
-                                                Just f -> do
-                                                           -- ncUnrecognizedHook0 may have updated the hookmap
-                                                           hookmap' <- atomically $ readTVar ncHooks
-                                                           lookupAgain (f cd,hookmap')
-                                                Nothing -> return Nothing
-                                Just hooks -> flip fix (hooks,cd,msgTyp) $ \loop (hooks,cd,typ) -> do
-                                                let _ = cd :: CryptoData
-                                                case (hooks,cd) of
-                                                    ([],_) ->  return Nothing
-                                                    (hook:more,cd) -> do
-                                                        r <- hook session cd :: IO (Maybe (CryptoData -> CryptoData))
-                                                        case r of
-                                                            Just f -> let newcd = f cd
-                                                                          newtyp = newcd ^. messageType
-                                                                          in if newtyp == typ then loop (more,newcd,newtyp)
-                                                                                              else lookupAgain (newcd,hookmap)
-                                                            Nothing -> return Nothing -- message consumed
+                    msgTypes <- atomically $ readTVar ncIncomingTypeArray
+                    let msgTyp = cd ^. messageType
+                        msgTypMapped16 = msgTypes A.! fromEnum8 (msgID cm)
+                        msgTypMapped = fromWord16 $ msgTypMapped16
+                        isLossy (GrpMsg KnownLossy _) = True
+                        isLossy (Msg mid) | lossyness mid == Lossy = True
+                        isLossy _ = False
+                    if isLossy msgTypMapped
+                        then do atomically $ PQ.observeOutOfBand ncPacketQueue bufferEnd
+                                runCryptoHook session cd
+                        else do atomically $ PQ.enqueue ncPacketQueue bufferEnd cd
+                                return Nothing
     where
         last2Bytes :: Nonce24 -> Word
         last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of
@@ -269,6 +486,79 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
                                     _ -> error "unreachable-last2Bytes"
         dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3
 
+-- | TODO: make this accept CrytpoMessage instead
+runCryptoHook :: NetCryptoSession -> CryptoData -> IO (Maybe (x -> x))
+runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce,ncIncomingTypeArray})
+              cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm}) = do
+    hookmap <- atomically $ readTVar ncHooks
+    -- run hook
+    flip fix (cd,hookmap) $ \lookupAgain (cd,hookmap) -> do
+        msgTypes <- atomically $ readTVar ncIncomingTypeArray
+        let msgTyp = cd ^. messageType
+            msgTypMapped16 = msgTypes A.! fromEnum8 (msgID cm)
+            msgTypMapped = fromWord16 $ msgTypMapped16
+        if msgTypMapped16 == 0
+         then return Nothing
+         else
+           case Map.lookup msgTypMapped hookmap of
+                Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result
+                             unrecognize <- atomically $ readTVar (ncUnrecognizedHook session)
+                             mbConsume <- unrecognize msgTypMapped session cd
+                             case mbConsume of
+                                Just f -> do
+                                           -- ncUnrecognizedHook0 may have updated the hookmap
+                                           hookmap' <- atomically $ readTVar ncHooks
+                                           lookupAgain (f cd,hookmap')
+                                Nothing -> return Nothing
+                Just hooks -> flip fix (hooks,cd,msgTypMapped) $ \loop (hooks,cd,typ) -> do
+                                let _ = cd :: CryptoData
+                                case (hooks,cd) of
+                                    ([],_) ->  return Nothing
+                                    (hook:more,cd) -> do
+                                        r <- hook session cd :: IO (Maybe (CryptoData -> CryptoData))
+                                        case r of
+                                            Just f -> let newcd = f cd
+                                                          newtyp = newcd ^. messageType
+                                                          in if newtyp == typ then loop (more,newcd,newtyp)
+                                                                              else lookupAgain (newcd,hookmap)
+                                            Nothing -> return Nothing -- message consumed
+
+-- | construct a 'MsgTypeArray' for specified types, using their known common positions
+--   in the MessageId space if they have such a thing.
+mkMsgTypes :: [MessageType] -> MsgTypeArray
+mkMsgTypes msgs = let zeros = A.listArray (0,255) (replicate 256 0)
+                      in zeros A.// map (\x -> (toIndex x,toWord16 x)) msgs
+    where
+        toIndex (Msg mid) = fromIntegral . fromEnum  $ mid
+        toIndex (GrpMsg KnownLossless nam) = 0x63 -- fromEnum MESSAGE_GROUPCHAT
+        toIndex (GrpMsg KnownLossy    nam) = 0xC7 -- fromEnum LOSSY_GROUPCHAT
+
+-- | Handle all Tox messages that this code base is aware of.
+allMsgTypes :: MsgTypeArray
+allMsgTypes = A.listArray (minBound,maxBound) (0:knownMsgs)
+  where
+    knownMsgs :: [Word16]
+    knownMsgs =
+      concat [ map (fromIntegral . fromEnum) [ PacketRequest .. KillPacket ]
+             , map (const 0)                 [ 3 .. 15 ]  -- UnspecifiedPacket
+             , map (const 0)                 [ 16 .. 23 ] -- MessengerLoseless
+             , map (fromIntegral . fromEnum) [ ONLINE .. OFFLINE ]
+             , map (const 0)                 [ 26 .. 47 ] -- MessengerLoseless
+             , map (fromIntegral . fromEnum) [ NICKNAME .. TYPING ]
+             , map (const 0)                 [ 52 .. 63 ] -- MessengerLoseless
+             , map (fromIntegral . fromEnum) [ MESSAGE .. ACTION ]
+             , map (const 0)                 [ 66 .. 68 ] -- MessengerLoseless
+             , map (fromIntegral . fromEnum) [ MSI ]
+             , map (const 0)                 [ 70 .. 79 ] -- MessengerLoseless
+             , map (fromIntegral . fromEnum) [ FILE_SENDREQUEST .. FILE_DATA ]
+             , map (const 0)                 [ 83 .. 95 ] -- MessengerLoseless
+             , map (fromIntegral . fromEnum) [ INVITE_GROUPCHAT .. MESSAGE_GROUPCHAT ]
+             , map (const 0)                 [ 100 .. 191 ] -- MessengerLoseless
+             , map (const 0)                 [ 192 .. 198 ] -- MessengerLossy
+             , map (fromIntegral . fromEnum) [ LOSSY_GROUPCHAT ]
+             , map (const 0)                 [ 200 .. 255 ] -- All lossy, exept the last
+             ]
+
 -- | handles nothing
 defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook]
 defaultCryptoDataHooks = Map.empty
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
index 8739c853..3133ee9b 100644
--- a/src/Network/Tox/Crypto/Transport.hs
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -21,6 +21,9 @@ module Network.Tox.Crypto.Transport
     , TypingStatus(..)
     , GroupChatId(..)
     , MessageType(..)
+    , KnownLossyness(..)
+    , AsWord16(..)
+    , AsWord64(..)
     -- feild name classes
     , HasGroupChatID(..)
     , HasGroupNumber(..)
@@ -46,6 +49,9 @@ module Network.Tox.Crypto.Transport
     , isIndirectGrpChat
     , LossyOrLossless(..)
     , lossyness
+    , fromEnum8
+    , fromEnum16
+    , toEnum8
     ) where
 
 import Crypto.Tox
@@ -59,6 +65,7 @@ import Data.ByteString as B
 import Data.Maybe
 import Data.Monoid
 import Data.Word
+import Data.Bits
 import Crypto.Hash
 import Control.Lens
 import Data.Text as T
@@ -147,10 +154,38 @@ data CryptoData = CryptoData
       -- | [  uint32_t packet number if lossless
       --   , sendbuffer buffer_end  if lossy   , (big endian)]
     , bufferEnd :: Word32
-      -- | [data]
+      -- | [data] (TODO See Note [Padding])
     , bufferData :: CryptoMessage
     }
 
+{-
+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
@@ -403,15 +438,61 @@ instance HasMessageName CryptoMessage where
 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 MessageName
+                 | 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 x) (GrpMsg y) = compare x y
-    compare (Msg _) (GrpMsg _) = LT
-    compare (GrpMsg _) (Msg _) = GT
+    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
@@ -420,13 +501,16 @@ class HasMessageType x where
 instance HasMessageType CryptoMessage where
     getMessageType (OneByte mid) = Msg mid
     getMessageType (TwoByte mid _) = Msg mid
-    getMessageType m@(UpToN mid _) | isIndirectGrpChat mid = GrpMsg (getMessageName m)
+    getMessageType m@(UpToN MESSAGE_GROUPCHAT _) = GrpMsg KnownLossless (getMessageName m)
+    getMessageType m@(UpToN LOSSY_GROUPCHAT   _) = GrpMsg KnownLossy    (getMessageName m)
     getMessageType (UpToN mid _) = Msg mid
 
-    setMessageType m@(UpToN mid _) (GrpMsg mname) | isIndirectGrpChat mid = setMessageName m mname
-    setMessageType (OneByte _   ) (GrpMsg mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty        ) mname
-    setMessageType (TwoByte  _ x) (GrpMsg mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname
-    setMessageType (UpToN _ x) (GrpMsg mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname
+    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