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

{-# LANGUAGE CPP             #-}
{-# LANGUAGE DeriveFunctor   #-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE TypeOperators   #-}
{-# LANGUAGE ViewPatterns    #-}
module Network.Tox.Crypto.Handlers where

import Network.Tox.NodeId
import Network.Tox.Crypto.Transport
import Network.Tox.DHT.Transport (Cookie(..),CookieData(..), CookieRequest(..), NoSpam(..))
import Network.Tox.DHT.Handlers (Client, cookieRequest, createCookieSTM )
import Crypto.Tox
import Control.Arrow
import Control.Concurrent.STM
import Control.Concurrent.STM.TMChan
import Network.Address
import qualified Data.Map.Strict as Map
import Crypto.Hash
import Control.Applicative
import Control.Monad
import Data.Time.Clock.POSIX
import qualified Data.ByteString  as B
import System.IO
import Data.ByteString (ByteString)
import Control.Lens
import Data.Function
import qualified Data.PacketQueue as PQ
         ;import Data.PacketQueue (PacketQueue)
import qualified Data.CyclicBuffer as CB
         ;import Data.CyclicBuffer (CyclicBuffer)
import Data.Serialize             as S
import Data.Word
import Data.Maybe
import qualified Data.Word64Map as W64
import Data.Word64RangeMap
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 System.Random -- for ping fuzz
#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent
import GHC.Conc (labelThread)
#endif
import PingMachine
import qualified Data.IntMap.Strict as IntMap
import Control.Concurrent.Supply
import Data.InOrOut
import DPut
import Debug.Trace
import Text.Printf
import Data.Bool
import Connection (Status(..), Policy(..))
import Network.Tox.ContactInfo
import Network.Tox.Handshake

-- | This type indicates the progress of a tox encrypted friend link
-- connection.  Two scenarios are illustrated below.  The parenthesis show the
-- current 'G.Status' 'ToxProgress' of the session.
--
--
-- Perfect handshake scenario:
--
--  Peer 1                                  Peer 2
--  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
--                     Cookie request ->
--                                       <- Cookie response
--  (InProgress AwaitingHandshake)          (Dormant/InProgress AcquiringCookie)
--                   Handshake packet ->
--                                          * accepts connection
--                                          (InProgress AwaitingSessionPacket)
--                                       <- Handshake packet
--  *accepts connection
--  (InProgress AwaitingSessionPacket)
--                   Encrypted packet -> <- Encrypted packet
--  *confirms connection                    *confirms connection
--  (Established)                           (Established)
--
--                           Connection successful.
--
--                  Encrypted packets -> <- Encrypted packets
--
--
--
--
--  More realistic handshake scenario:
--  Peer 1                                  Peer 2
--  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
--                      Cookie request ->   *packet lost*
--                      Cookie request ->
--                                        <- Cookie response
--  (InProgress AwaitingHandshake)           (Dormant/InProgress AcquiringCookie)
--
--                                           *Peer 2 randomly starts new connection to peer 1
--                                           (InProgress AcquiringCookie)
--                                        <- Cookie request
--                     Cookie response ->
--                                           (InProgress AwaitingHandshake)
--
--                    Handshake packet -> <- Handshake packet
--  *accepts connection                      * accepts connection
--  (InProgress AwaitingSessionPacket)      (InProgress AwaitingSessionPacket)
--
--                    Encrypted packet -> <- Encrypted packet
--  *confirms connection                     *confirms connection
--  (Established)                           (Established)
--
--                              Connection successful.
--
--                   Encrypted packets -> <- Encrypted packets
data ToxProgress
    = AwaitingDHTKey        -- ^ Waiting to receive their DHT key.
    | AcquiringIPAddress    -- ^ Searching DHT to obtain their node's IP & port.
    | AcquiringCookie       -- ^ Attempting to obtain a cookie.
    | AwaitingHandshake     -- ^ Waiting to receive a handshake.
    | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed".
    deriving (Eq,Ord,Enum,Show)

type LookupPolicyFunction = Key -> STM Policy

data Key = Key NodeId{-me-} NodeId{-them-}
 deriving (Eq,Ord)

instance Show Key where show = show . showKey_

showKey_ :: Key -> String
showKey_ (Key me them) = show me ++ ":" ++ show them

-- * These types are isomorphic to Maybe, but have the advantage of documenting
--   when an item is expected to become known.
data UponDHTKey a       = NeedDHTKey       | HaveDHTKey a       deriving (Functor,Show,Eq)
data UponCookie a       = NeedCookie       | HaveCookie a       deriving (Functor,Show,Eq)
data UponHandshake a    = NeedHandshake    | HaveHandshake a    deriving (Functor,Show,Eq)
data UponCryptoPacket a = NeedCryptoPacket | HaveCryptoPacket a deriving (Functor,Show,Eq)

-- util, todo: move to another module
maybeToEither :: AsMaybe f => f b -> Either String b
maybeToEither y | Just x <- toMaybe y = Right x
maybeToEither _  = Left "maybeToEither"

-- | type class encoding of isomorphism to Maybe
class AsMaybe f where
    toMaybe :: f a -> Maybe a
    -- | The o in from is left out so as not to colide with 'Data.Maybe.fromMaybe'
    frmMaybe :: Maybe a -> f a

instance AsMaybe Maybe where
    toMaybe x = x
    frmMaybe x = x

instance AsMaybe UponDHTKey where
    toMaybe NeedDHTKey     = Nothing
    toMaybe (HaveDHTKey x) = Just x
    frmMaybe Nothing  = NeedDHTKey
    frmMaybe (Just x) = HaveDHTKey x

instance AsMaybe UponCookie where
    toMaybe NeedCookie     = Nothing
    toMaybe (HaveCookie x) = Just x
    frmMaybe Nothing  = NeedCookie
    frmMaybe (Just x) = HaveCookie x

instance AsMaybe UponHandshake where
    toMaybe NeedHandshake     = Nothing
    toMaybe (HaveHandshake x) = Just x
    frmMaybe Nothing  = NeedHandshake
    frmMaybe (Just x) = HaveHandshake x

instance AsMaybe UponCryptoPacket where
    toMaybe NeedCryptoPacket     = Nothing
    toMaybe (HaveCryptoPacket x) = Just x
    frmMaybe Nothing  = NeedCryptoPacket
    frmMaybe (Just x) = HaveCryptoPacket x


--data NetCryptoSessionStatus = Unaccepted | Accepted {- InProgress AwaitingSessionPacket -} | Confirmed {- Established -}
--    deriving (Eq,Ord,Show,Enum)


-- | The idea of IOHook is to replicate the familiar pattern
-- where a function returns Nothing to consume a value
-- or a function used to modify the value and pass it
-- to be processed by another hook.
type IOHook addr x = addr -> x -> IO (Maybe (x -> x))

-- | NetCryptoHook's use the Session as their 'addr' and the
-- value they consume or modify is CryptoMessage.
type NetCryptoHook = IOHook NetCryptoSession CryptoMessage

-- | Convert an id byte to it's type (in Word64 format)
-- Although the type doesn't enforce it, MsgTypeArray
-- should always have 256 entries.
type MsgTypeArray = A.UArray Word8 Word64

-- | 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
        , svTyping      :: TVar TypingStatus
        , svNoSpam      :: TVar (Maybe NoSpam)
        , svTheirNick        :: TVar ByteString
        , svTheirStatus      :: TVar UserStatus
        , svTheirStatusMsg   :: TVar ByteString
        , svTheirTyping      :: TVar TypingStatus
        , svTheirNoSpam      :: TVar (Maybe NoSpam)
        , 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
        }

-- | A static version of 'SessionView'
--   useful for serializing to logs
--   or storing in the ncLastNMsgs queue
data ViewSnapshot = ViewSnapshot
        { vNick        :: ByteString
        , vStatus      :: UserStatus
        , vStatusMsg   :: ByteString
        , vTyping      :: TypingStatus
        , vNoSpam      :: Maybe NoSpam
        , vTheirNick        :: ByteString
        , vTheirStatus      :: UserStatus
        , vTheirStatusMsg   :: ByteString
        , vTheirTyping      :: TypingStatus
        , vTheirNoSpam      :: Maybe NoSpam
        , vGroups      :: Map.Map GroupChatId (Set.Set SockAddr)
        }

-- | Take snapshot of SessionView
--
-- This is useful for storing the context of
-- remembered messages.
viewSnapshot :: SessionView -> STM ViewSnapshot
viewSnapshot v = do
    nick        <- readTVar (svNick v)
    status      <- readTVar (svStatus v)
    statusMsg   <- readTVar (svStatusMsg v)
    typing      <- readTVar (svTyping v)
    noSpam      <- readTVar (svNoSpam v)
    theirNick        <- readTVar (svTheirNick v)
    theirStatus      <- readTVar (svTheirStatus v)
    theirStatusMsg   <- readTVar (svTheirStatusMsg v)
    theirTyping      <- readTVar (svTheirTyping v)
    theirNoSpam      <- readTVar (svTheirNoSpam v)
    groups      <- readTVar (svGroups v)
    return ViewSnapshot
            { vNick = nick
            , vStatus = status
            , vStatusMsg = statusMsg
            , vTyping = typing
            , vNoSpam = noSpam
            , vTheirNick = theirNick
            , vTheirStatus = theirStatus
            , vTheirStatusMsg = theirStatusMsg
            , vTheirTyping = theirTyping
            , vTheirNoSpam = theirNoSpam
            , vGroups = groups
            }

type SessionID = Word64

-- | Application specific listener type (Word64)
--
-- This is some kind of information associated with a listening TChan.
-- It may be used to indicate what kind of packets it is interested in.
--
-- 0 means listen to all messages and is done automatically in 'defaultUnRecHook'
-- any other values are left open to application specific convention.
--
-- This module does not know what the different values here
-- mean, but code that sets hooks may adhere to a convention
-- defined elsewhere.
--
type ListenerType = Word64

data NetCryptoSession = NCrypto
    { ncState              :: TVar (Status ToxProgress)
    , ncMyPublicKey        :: PublicKey
    , ncSessionId          :: SessionID
    , ncTheirPublicKey     :: PublicKey -- Tox id w/o nospam
    , ncTheirBaseNonce     :: TVar (UponHandshake Nonce24) -- base nonce + packet number
    , ncMyPacketNonce      :: TVar Nonce24 -- base nonce + packet number
    , ncHandShake          :: TVar (UponHandshake (Handshake Encrypted))
    , ncCookie             :: TVar (UponCookie (Cookie Encrypted)) -- ^ Cookie issued by remote peer
    , ncTheirDHTKey        :: UponDHTKey PublicKey
    , ncTheirSessionPublic :: TVar (UponHandshake PublicKey)
    , ncSessionSecret      :: SecretKey
    , ncSockAddr           :: UponDHTKey SockAddr
    -- The remaining fields correspond to implementation specific state --
    -- where as the prior fields will be used in any implementation     --
    , ncHooks              :: TVar (Map.Map MessageType [NetCryptoHook])
    , ncUnrecognizedHook   :: TVar (MessageType -> NetCryptoHook)
    , ncIncomingTypeArray  :: TVar MsgTypeArray
    -- ^ This array maps 255 Id bytes to MessageType
    -- It should contain all messages this session understands.
    -- Use 0 for unsupported. It is used when a message comes
    -- in, and should ordinarily be the identity map.
    --
    -- Id's 0xC7 and 0x63 should contain range-specifying types only, if
    -- such things come to be defined, because these MessageId's are
    -- always escapes.
    --
    -- Currently, the values at these indices are ignored.
    , ncOutgoingIdMap      :: RangeMap TArray Word8 TVar
    -- ^ used to lookup the outgoing id for a type when sending an outoing message
    , ncOutgoingIdMapEscapedLossy :: TVar (A.Array Word8 Word8)
    -- ^ mapping of secondary id, when primary id is 0xC7
    --   (These Id's are called 'MessageName' in 'Network.Tox.Crypto.Transport')
    --   used when sending an outoing message
    , ncOutgoingIdMapEscapedLossless :: TVar (A.Array Word8 Word8)
    -- ^ mapping of secondary id, when primary id is 0x63
    --   (These Id's are called 'MessageName' in 'Network.Tox.Crypto.Transport')
    --   used when sending an outoing message
    , ncAllSessions        :: NetCryptoSessions
     -- ^ needed if one net-crypto session
     --   needs to possibly start another, as is
     --   the case in group chats
    , ncView               :: TVar SessionView
    -- ^ contains your nick, status etc
    , ncPacketQueue        :: PacketQueue CryptoData
    -- ^ a buffer in which incoming packets may be stored out of order
    -- but from which they may be extracted in sequence,
    -- helps ensure lossless packets are processed in order
    , ncRequestInterval    :: TVar Int
    -- ^ How long (in microseconds) to wait between packet requests
 -- , ncStoredRequests    :: CyclicBuffer CryptoData
    -- ^ Store the last 5 packet requests, try handling in any order
    --   if the connection seems like it is locked (TODO)
    , ncRequestThread      :: TVar (Maybe ThreadId)
    -- ^ thread which sends packet requests
    , ncDequeueThread      :: TVar (Maybe ThreadId)
    -- ^ when the thread which dequeues from ncPacketQueue
    -- is started, its ThreadId is stored here
    , ncDequeueOutGoingThread :: TVar (Maybe ThreadId)
    -- ^ the thread which actually sends lossless packets
    , ncPingMachine        :: TVar (Maybe PingMachine)
    -- ^ thread which triggers ping events
    , ncPingThread         :: TVar (Maybe ThreadId)
    -- ^ thread which actually queues outgoing pings
    , ncOutgoingQueue      :: TVar
                                (UponHandshake
                                    (PQ.PacketOutQueue
                                          (State,Nonce24,RangeMap TArray Word8 TVar)
                                          CryptoMessage
                                          (CryptoPacket Encrypted)
                                          CryptoData))
    -- ^ To send a message add it to this queue, by calling 'tryAppendQueueOutgoing'
    --   but remember to call 'readyOutGoing' first, because the shared secret cache
    --   presently requires the IO monad.
    --   This specialized queue handles setting buffer_start and buffer_end and encrypting
    --   'readyOutGoing' provides the first parameter to 'tryAppendQueueOutgoing'
    , ncLastNMsgs :: CyclicBuffer (Bool{-Handled?-},(ViewSnapshot,InOrOut CryptoMessage))
    -- ^ cyclic buffer, holds the last N non-handshake crypto messages
    --   even if there is no attached user interface.
    , ncListeners :: TVar (IntMap.IntMap (ListenerType,TMChan CryptoMessage))
    -- ^ user interfaces may "listen" by inserting themselves into this map
    -- with a unique id and a new TChan, and then reading from the TChan
    }
instance Eq NetCryptoSession where
    x == y = ncSessionId x == ncSessionId y

data NetCryptoSessions = NCSessions
    { netCryptoSessions       :: TVar (Map.Map SockAddr NetCryptoSession)
    , netCryptoSessionsByKey  :: TVar (Map.Map PublicKey [NetCryptoSession])
    , netCryptoPolicyByKey    :: LookupPolicyFunction
    , transportCrypto         :: TransportCrypto
    , defaultHooks            :: Map.Map MessageType [NetCryptoHook]
    , defaultUnrecognizedHook :: MessageType -> NetCryptoHook
    , sessionView             :: SessionView
    , msgTypeArray            :: MsgTypeArray
    , inboundQueueCapacity    :: Word32
    , outboundQueueCapacity   :: Word32
    , nextSessionId           :: TVar SessionID
    , announceNewSessionHooks :: TVar [IOHook (Maybe NoSpam) NetCryptoSession]
    , sendHandshake           :: SockAddr -> Handshake Encrypted -> IO ()
    , sendSessionPacket       :: SockAddr -> CryptoPacket Encrypted -> IO ()
    , listenerIDSupply        :: TVar Supply
    }

-- | This is the type of a hook to run when a session is created.
type NewSessionHook = IOHook (Maybe NoSpam) NetCryptoSession

addNewSessionHook :: NetCryptoSessions -> NewSessionHook -> STM ()
addNewSessionHook allsessions@(NCSessions { announceNewSessionHooks }) hook = modifyTVar announceNewSessionHooks (hook:)

forgetCrypto :: TransportCrypto -> NetCryptoSessions -> NetCryptoSession -> STM ()
forgetCrypto crypto (NCSessions {netCryptoSessions,netCryptoSessionsByKey}) session = do
    let HaveDHTKey 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)

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
    typing <- atomically $ newTVar NotTyping
    nospam <- atomically $ newTVar Nothing
    theirnick <- atomically $ newTVar B.empty
    theirstatus <- atomically $ newTVar Online
    theirstatusmsg <- atomically $ newTVar B.empty
    theirtyping <- atomically $ newTVar NotTyping
    theirnospam <- atomically $ newTVar Nothing
    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
    announceNewSessionHooks0 <- atomically $ newTVar []
    lsupply <- newSupply
    lsupplyVar <- atomically (newTVar lsupply)
    return NCSessions { netCryptoSessions       = x
                      , netCryptoSessionsByKey  = x2
                      , netCryptoPolicyByKey    = \_ -> return OpenToConnect
                      , transportCrypto         = crypto
                      , defaultHooks            = hooks
                      , defaultUnrecognizedHook = unrechook
                      , sessionView             = SessionView
                            { svNick        = nick
                            , svStatus      = status
                            , svStatusMsg   = statusmsg
                            , svTyping      = typing
                            , svNoSpam      = nospam
                            , svTheirNick        = theirnick
                            , svTheirStatus      = theirstatus
                            , svTheirStatusMsg   = theirstatusmsg
                            , svTheirTyping      = theirtyping
                            , svTheirNoSpam      = theirnospam
                            , svGroups      = grps
                            , svCacheDir    = cachedir
                            , svTmpDir      = tmpdir
                            , svConfigDir   = configdir
                            , svDownloadDir = svDownloadDir0
                            }
                      , msgTypeArray            = allMsgTypes id -- todo make this a parameter
                      , inboundQueueCapacity    = 200
                      , outboundQueueCapacity   = 400
                      , nextSessionId           = nextSessionId0
                      , announceNewSessionHooks = announceNewSessionHooks0
                      , sendHandshake     = error "Need to set sendHandshake field of NetCryptoSessions!"
                      , sendSessionPacket = error "Need to set sendSessionPacket field of NetCryptoSessions!"
                      , listenerIDSupply = lsupplyVar
                      }

type XMessage = CryptoMessage -- todo

-- THIS Would work if not for the IO shared secret cache...
-- increments packet nonce, only call when actually queuing an outgoing packet
-- getOutGoingParam crypto session = do
--    n24 <- (ncMyPacketNonce session)
--    let state = computeSharedSecret (transportSecret crypto) (ncTheirPublicKey session) n24
--    modifyTVar (ncMyPacketNonce session) (+1)
--    rangemap <- readTVar (ncOutgoingIdMap session)
--    return (state,n24,rangemap)

ncToWire :: STM (State,Nonce24,RangeMap TArray Word8 TVar)
         -> 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
    result1 <- trace ("lookupInRangeMap typ64=" ++ show typ64)
                     $ lookupInRangeMap typ64 msgOutMapVar
    case result1 of -- msgOutMapLookup typ64 msgOutMap of
        Nothing -> trace "lookupInRangeMap gave Nothing!" $ return Nothing
        Just outid -> trace ("encrypting packet with Nonce: " ++ show n24) $ 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 = let r = nonce24ToWord16 n24
                                                                            in trace (printf "converting n24 to word16: 0x%x" r) r
                                                           , 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)
--
-- This function sends a handshake response packet.
freshCryptoSession :: NetCryptoSessions -> SockAddr -> SecretKey -> POSIXTime -> HandshakeParams -> STM (Maybe (Handshake Encrypted),IO ())
freshCryptoSession  sessions
                    addr
                    newsession
                    timestamp
                    hp@(HParam
                              { hpTheirBaseNonce = mbtheirBaseNonce
                              , hpOtherCookie    = otherCookie
                              , hpTheirSessionKeyPublic = mbtheirSessionKey
                              , hpMySecretKey        = key
                              , hpCookieRemotePubkey = remotePublicKey
                              , hpCookieRemoteDhtkey = remoteDhtPublicKey
                              }) = do
    let crypto = transportCrypto sessions
        allsessions = netCryptoSessions sessions
        allsessionsByKey = netCryptoSessionsByKey sessions
        dmsg msg = trace msg (return ())
    sessionId <- do
        x <- readTVar (nextSessionId sessions)
        modifyTVar    (nextSessionId sessions) (+1)
        return x
    -- ncState0 <- newTVar Accepted -- (InProgress AwaitingSessionPacket)
    ncState0 <- newTVar (if isJust mbtheirBaseNonce
                                        then InProgress AwaitingSessionPacket
                                        else InProgress AwaitingHandshake)
    ncTheirBaseNonce0 <- newTVar (frmMaybe mbtheirBaseNonce)
    newBaseNonce <- transportNewNonce crypto
    mbMyhandshakeData <- case  nodeInfo (key2id $ hpCookieRemoteDhtkey hp) addr of
            Right nodeinfo -> Just <$> newHandShakeData timestamp crypto newBaseNonce hp nodeinfo (toPublic newsession)
            Left er        -> return Nothing -- Unable to send handshake to non-internet socket!
    myhandshake <- mapM (encodeHandshake timestamp crypto key remotePublicKey otherCookie) mbMyhandshakeData
    ncHandShake0 <- newTVar (frmMaybe myhandshake)
    ncMyPacketNonce0 <- newTVar newBaseNonce
    cookie0 <- newTVar (HaveCookie otherCookie)
    ncHooks0 <- newTVar (defaultHooks sessions)
    ncUnrecognizedHook0 <- newTVar (defaultUnrecognizedHook sessions)
    ncIncomingTypeArray0 <- newTVar (msgTypeArray sessions)
    let idMap = foldl (\mp (x,y) -> W64.insert x y mp) W64.empty (zip [0..255] [0..255])
    (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap) <- do
        idmap <- emptySTMRangeMap
        insertArrayAt idmap  0 (A.listArray (0,255) [0 .. 255])
        -- the 2 escape ranges are adjacent, so put them in one array:
        insertArrayAt idmap  512 (A.listArray (512,1023) ( replicate 256 0xC7 -- lossy escaped
                                                        ++ replicate 256 0x63 -- lossless escapped
                                                         ))
        -- lossless as separate range could have been done:
        -- > insertArrayAt idmap  768 (A.listArray (768,1023)  (replicate 256 0x63))
        lossyEsc    <- newTVar $ A.listArray (0,255) [0 .. 255]
        losslessEsc <- newTVar $ A.listArray (0,255) [0 .. 255]
        return (idmap,lossyEsc,losslessEsc)
    ncView0 <- newTVar (sessionView sessions)
    pktq <- PQ.new (inboundQueueCapacity sessions) 0
    bufstart <- newTVar 0
    mbpktoq
     <- case mbtheirSessionKey of
         Nothing -> return NeedHandshake
         Just theirSessionKey -> createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0
    mbpktoqVar <- newTVar mbpktoq
    lastNQ <- CB.new 10 0 :: STM (CyclicBuffer (Bool,(ViewSnapshot,InOrOut CryptoMessage)))
 -- ncStoredRequests0 <- CB.new 5 0 :: STM (CyclicBuffer CryptoData)
    listeners <- newTVar IntMap.empty
    msgNum <- newTVar 0
    dropNum <- newTVar 0
    theirbasenonce <- readTVar ncTheirBaseNonce0
    dmsg $ "freshCryptoSession: Session ncTheirBaseNonce=" ++ show theirbasenonce
    dmsg $ "freshCryptoSession: My Session Public =" ++ show (key2id $ toPublic newsession)
    ncTheirSessionPublic0 <- newTVar (frmMaybe mbtheirSessionKey)
    ncRequestInterval0 <- newTVar 2000000 -- (TODO: shrink this) long interval while debugging slows trace flood
    ncRequestThread0 <- newTVar Nothing
    ncDequeueThread0 <- newTVar Nothing
    ncDequeueOutGoingThread0 <- newTVar Nothing
    ncPingMachine0 <- newTVar Nothing
    ncPingThread0 <- newTVar Nothing
    let netCryptoSession0 =
            NCrypto { ncState              = ncState0
                    , ncMyPublicKey        = toPublic key
                    , ncSessionId          = sessionId
                    , ncTheirPublicKey     = remotePublicKey
                    , ncTheirBaseNonce     = ncTheirBaseNonce0
                    , ncMyPacketNonce      = ncMyPacketNonce0
                    , ncHandShake          = ncHandShake0
                    , ncCookie             = cookie0
                    , ncTheirDHTKey        = HaveDHTKey remoteDhtPublicKey
                    , ncTheirSessionPublic = ncTheirSessionPublic0
                    , ncSessionSecret      = newsession
                    , ncSockAddr           = HaveDHTKey addr
                    , ncHooks              = ncHooks0
                    , ncUnrecognizedHook   = ncUnrecognizedHook0
                    , ncAllSessions        = sessions
                    , ncIncomingTypeArray  = ncIncomingTypeArray0
                    , ncOutgoingIdMap      = ncOutgoingIdMap0
                    , ncOutgoingIdMapEscapedLossy    = lossyEscapeIdMap
                    , ncOutgoingIdMapEscapedLossless = losslessEscapeIdMap
                    , ncView               = ncView0
                    , ncPacketQueue        = pktq
                 -- , ncStoredRequests     = ncStoredRequests0 (TODO)
                    , ncRequestInterval    = ncRequestInterval0
                    , ncRequestThread         = ncRequestThread0
                    , ncDequeueThread         = ncDequeueThread0
                    , ncDequeueOutGoingThread = ncDequeueOutGoingThread0
                    , ncPingMachine           = ncPingMachine0
                    , ncPingThread            = ncPingThread0
                    , ncOutgoingQueue      = mbpktoqVar
                    , ncLastNMsgs          = lastNQ
                    , ncListeners          = listeners
                    }
    -- addSessionToMap sessions addr netCryptoSession0
    addSessionToMapIfNotThere sessions addr netCryptoSession0
    maybeLaunchMissles
        <- case mbpktoq of
            NeedHandshake -> return (return ())
            HaveHandshake pktoq -> return (runUponHandshake netCryptoSession0 addr pktoq)
    return (myhandshake,maybeLaunchMissles)

type NetCryptoOutQueue = PQ.PacketOutQueue (State,Nonce24,RangeMap TArray Word8 TVar)
                                           CryptoMessage
                                           (CryptoPacket Encrypted)
                                           CryptoData

createNetCryptoOutQueue :: NetCryptoSessions -> SecretKey -> PublicKey -> PacketQueue CryptoData
                        -> TVar Nonce24    -> RangeMap TArray Word8 TVar     -> STM (UponHandshake NetCryptoOutQueue)
createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 = do
            let crypto = transportCrypto sessions
            let toWireIO = do
                    f <- lookupNonceFunction crypto newsession theirSessionKey
                    atomically $ do
                        n24 <- readTVar ncMyPacketNonce0
                        let n24plus1 = incrementNonce24 n24
                        trace ("ncMyPacketNonce+1=" ++ show n24plus1
                            ++ "\n toWireIO: theirSessionKey = " ++ show (key2id theirSessionKey)
                            ++ "\n toWireIO: my public session key = " ++ show (key2id (toPublic newsession))
                              ) $ writeTVar ncMyPacketNonce0 n24plus1
                        return (return (f n24, n24, ncOutgoingIdMap0))
            pktoq <- PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0
            return (HaveHandshake pktoq)

-- | add new session to the lookup maps
addSessionToMap :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM ()
addSessionToMap sessions addrRaw netCryptoSession = do
    let addr = either id id $ either4or6 addrRaw
    let dmsg msg = tput XNetCrypto msg
    dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession)
    let remotePublicKey = ncTheirPublicKey netCryptoSession
        allsessions     = netCryptoSessions sessions
        allsessionsByKey= netCryptoSessionsByKey sessions
    byAddrResult <- readTVar allsessions >>= return . Map.lookup addr
    mp <- readTVar allsessionsByKey
    modifyTVar allsessions      (Map.insert addr netCryptoSession)
    modifyTVar allsessionsByKey (Map.insertWith (++) remotePublicKey [netCryptoSession])

-- | add this session to the lookup maps, overwrite if its already in them
addSessionToMapIfNotThere :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM ()
addSessionToMapIfNotThere sessions addrRaw netCryptoSession = do
    let addr = either id id $ either4or6 addrRaw
    let dmsg msg = tput XNetCrypto msg
    dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession)
    let remotePublicKey = ncTheirPublicKey netCryptoSession
        allsessions     = netCryptoSessions sessions
        allsessionsByKey= netCryptoSessionsByKey sessions
    byAddrResult <- readTVar allsessions >>= return . Map.lookup addr
    mp <- readTVar allsessions
    case byAddrResult of
        Just (NCrypto { ncSessionId = staleId }) -> do
            dmsg $ "addSessionToMapIfNotThere: addr(" ++ show addr ++") already in map(" ++ show (map (second ncSessionId) (Map.assocs mp)) ++ ")"
            dmsg $ "addSessionToMapIfNotThere: considering it stale(staleId=" ++ show staleId ++") and removing it from the by-key map, so remove it from by-key map."
            dmsg $ "addSessionToMapIfNotThere: leave it in the by-addr map, and overwrite it shortly."
            -- manually remove the stale session from the by-key map
            modifyTVar allsessionsByKey (Map.map (filter ((/=staleId) . ncSessionId)))
        Nothing -> -- nothing to remove
            dmsg $ "addSessionToMapIfNotThere: addr(" ++ show addr ++") not yet in map(" ++ show (map (second ncSessionId) (Map.assocs mp)) ++ ")"
    dmsg $ "addSessionToMapIfNotThere: Inserting addr(" ++ show addr ++") into map(" ++ show (map (second ncSessionId) (Map.assocs mp)) ++ ")"
    -- write session to by-addr map regardless of whether one is in there,
    -- it should overwrite on match
    modifyTVar allsessions (Map.insert addr netCryptoSession)
    -- Now insert new session into by-key map
    byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey
    case byKeyResult of
        Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession])
        Just xs -> do
            -- in case we're using the same long term key on different IPs ...
            modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs))

runUponHandshake :: NetCryptoSession -> SockAddr -> NetCryptoOutQueue -> IO ()
runUponHandshake netCryptoSession0 addr pktoq = do
    dput XNetCrypto "(((((((runUponHandshake))))))) Launching threads"
    let sessions = ncAllSessions netCryptoSession0
        pktq = ncPacketQueue netCryptoSession0
        remotePublicKey = ncTheirPublicKey netCryptoSession0
        crypto = transportCrypto sessions
        allsessions = netCryptoSessions sessions
        allsessionsByKey = netCryptoSessionsByKey sessions
        sidStr = printf "(%x)" (ncSessionId netCryptoSession0)
    -- launch dequeue thread
    -- (In terms of data dependency, this thread could be launched prior to handshake)
    threadid <- forkIO $ do
        tid <- myThreadId
        atomically $ writeTVar (ncDequeueThread netCryptoSession0) (Just tid)
        labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey) ++ sidStr)
        fix $ \loop -> do
            cd <- atomically $ PQ.dequeue pktq
            if msgID (bufferData cd) == PacketRequest
              then do
                dput XNetCrypto $ "Dequeued::PacketRequest seqno=" ++ show (bufferStart cd) ++ " " ++ show (bufferData cd)
                handlePacketRequest netCryptoSession0 cd
              else do
                dput XNetCrypto $ "Dequeued::" ++ show (bufferData cd) ++ " now running hook..."
                void $ runCryptoHook netCryptoSession0 (bufferData cd)
            loop
    dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoDequeue." ++ show (key2id remotePublicKey) ++ sidStr
    -- launch request thread
    -- (In terms of data dependency, this thread could be launched prior to handshake)
    threadid <- forkIO $ do
        tid <- myThreadId
        atomically $ writeTVar (ncDequeueThread netCryptoSession0) (Just tid)
        labelThread tid ("NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr)
        fix $ \loop -> do
            atomically (readTVar (ncRequestInterval netCryptoSession0)) >>= threadDelay
            nums <- atomically $ PQ.getMissing pktq
            dput XNetCrypto $ "(Request Thread) Missing Packets detected:" ++ show nums
            getOutGoingParam <- PQ.readyOutGoing pktoq
            atomically $ do 
                seqno <- PQ.getLastDequeuedPlus1 pktq
                ogresult <- PQ.tryAppendQueueOutgoing getOutGoingParam pktoq (createRequestPacket seqno nums)
                case ogresult of
                    PQ.OGSuccess -> return ()
                    _ -> retry
            loop
    dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr
    -- launch dequeueOutgoing thread
    threadidOutgoing <- forkIO $ do
        tid <- myThreadId
        atomically $ writeTVar (ncDequeueOutGoingThread netCryptoSession0) (Just tid)
        labelThread tid ("NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey) ++ sidStr)
        fix $ \loop -> do
            (_,pkt) <- atomically $ PQ.dequeueOutgoing pktoq
            dput XNetCrypto "NetCryptoDequeueOutgoing thread... Sending encrypted Packet"
            sendSessionPacket sessions addr pkt
            loop
    dput XNetCrypto $ "runUponHandshake: " ++ show threadidOutgoing ++ " = NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey) ++ sidStr
    -- launch ping Machine thread
    fuzz <- return 0 -- randomRIO (0,2000) -- Fuzz to prevent simultaneous ping/pong exchanges.
                                           -- Disabled because tox has no pong event.
    pingMachine <- forkPingMachine ("NetCrypto." ++ show (key2id remotePublicKey) ++ sidStr) (8000 + fuzz) 4000
    atomically $ writeTVar (ncPingMachine netCryptoSession0) (Just pingMachine)
    -- launch ping thread
    pingThreadId <- forkIO $ do
        tid <- myThreadId
        atomically $ writeTVar (ncPingThread netCryptoSession0) (Just tid)
        labelThread tid ("NetCryptoPingSender." ++ show (key2id remotePublicKey) ++ sidStr)
        event <- atomically $ pingWait pingMachine
        case event of
            PingIdle -> do
                dput XNetCrypto $ "pingThread (session: " ++ show (ncSessionId netCryptoSession0) ++ ") PingIdle"
                -- Normally, we would not bump the PingMachine until we receive
                -- an inbound packet.  We are doing this here because tox has
                -- no pong response packet and so we need to mark the
                -- connection non-idle here.  Doing this prevents a PingTimeOut
                -- from ever occurring. (TODO: handle timed-out sessions somehow.)
                pingBump pingMachine
                lr <- sendPing crypto netCryptoSession0
                case lr of
                    Left s -> dput XNetCrypto $ "(pingThread session: " ++ show (ncSessionId netCryptoSession0) ++ ") " ++ s
                    Right _ -> return ()
            PingTimeOut -> dput XNetCrypto $ "(pingThread session: " ++ show (ncSessionId netCryptoSession0) ++ ") PingTimeOut TODO"
    -- update session with thread ids
    let netCryptoSession = netCryptoSession0
    -- add this session to the lookup maps
    -- atomically $ addSessionToMapIfNotThere sessions addr netCryptoSession
    -- run announceNewSessionHooks
    dput XNetCrypto $ "runUponHandshake: Announcing new session"
    hooks <- atomically $ readTVar (announceNewSessionHooks sessions)
    sendOnline crypto netCryptoSession
    -- in case ONLINE packet is dropped, send anohter after delay
    forkIO $ do
        tid <- myThreadId
        labelThread tid ("Second Online." ++ show (key2id remotePublicKey) ++ sidStr)
        threadDelay 1000
        _ <- sendOnline crypto netCryptoSession
        return ()
    -- Run new session hooks
    flip fix (hooks,netCryptoSession) $ \loop (hooks,session) ->
        case hooks of
            [] -> return ()
            (h:hs) -> do
                r <- h Nothing session
                case r of
                  Just f -> loop (hs, f session)
                  Nothing -> return ()

destroySession :: NetCryptoSession -> IO ()
destroySession session = do
    let allsessions = ncAllSessions session
        sid = ncSessionId session
        stopThread :: TVar (Maybe ThreadId) -> IO ()
        stopThread x = atomically (readTVar x) >>= maybe (return ()) killThread
        stopMachine :: TVar (Maybe PingMachine) -> IO ()
        stopMachine x = atomically (readTVar x) >>= maybe (return ()) pingCancel
    atomically $ do
        modifyTVar (netCryptoSessionsByKey allsessions)
                   $ Map.map (filter ((/=sid) . ncSessionId))
        modifyTVar (netCryptoSessions allsessions)
                   $ Map.filterWithKey (\k v -> ncSessionId v /= sid)
    stopThread (ncPingThread session)
    stopMachine (ncPingMachine session)
    stopThread (ncDequeueThread session)
    stopThread (ncDequeueOutGoingThread session)

-- | Called when we get a handshake, but there's already a session entry.
--
--     1) duplicate packet ... ignore
--     2) handshake for new session (old session is lost?)

--     3) we initiated, this a response
updateCryptoSession :: NetCryptoSessions -> SockAddr -> SecretKey -> POSIXTime -> HandshakeParams
                    -> NetCryptoSession -> Handshake Encrypted -> STM (Maybe (Handshake Encrypted), IO ())
updateCryptoSession sessions addr newsession timestamp hp session handshake = do
    let dmsg msg = tput XNetCrypto msg
    ncState0 <- readTVar (ncState session)
    ncTheirBaseNonce0 <- readTVar (ncTheirBaseNonce session)
    if (ncState0 >= {-Accepted-}InProgress AwaitingSessionPacket)
        -- If the nonce in the handshake and the dht key are both the same as
        -- the ones we have saved, assume we already handled this and this is a
        -- duplicate handshake packet, otherwise disregard everything, and
        -- refresh all state.
        --
     then do
          dmsg "updateCryptoSession already accepted.."
          dmsg ("   ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0
                         ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp)
                         ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp))
          dmsg ("   ncTheirDHTKey=" ++ show (ncTheirDHTKey session)
                         ++ bool "{/=}" "{==}" (ncTheirDHTKey session == HaveDHTKey (hpCookieRemoteDhtkey hp))
                         ++ "hpCookieRemoteDhtkey=" ++ show (hpCookieRemoteDhtkey hp))
          if (  toMaybe ncTheirBaseNonce0 /= hpTheirBaseNonce hp
                ||
               ncTheirDHTKey session /= HaveDHTKey (hpCookieRemoteDhtkey hp)
             )
            then freshCryptoSession sessions addr newsession timestamp hp
            else return (Nothing,return ())
     else do
          dmsg "updateCryptoSession else clause"
          dmsg ("   ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0
                         ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp)
                         ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp))
          if ( ncTheirBaseNonce0 /= frmMaybe (hpTheirBaseNonce hp))
            then do
                case ncTheirBaseNonce0 of
                    NeedHandshake | Just theirSessionPublic <- hpTheirSessionKeyPublic hp -> do
                        writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp))
                        writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp))
                        writeTVar (ncTheirSessionPublic session) (frmMaybe (hpTheirSessionKeyPublic hp))
                        writeTVar (ncHandShake session) (HaveHandshake handshake)
                        writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket)
                        mbpktoq <- createNetCryptoOutQueue
                                                sessions
                                                newsession
                                                theirSessionPublic
                                                (ncPacketQueue session)
                                                (ncMyPacketNonce session)
                                                (ncOutgoingIdMap session)
                        writeTVar (ncOutgoingQueue session) mbpktoq
                        return (Nothing,maybe (dput XNetCrypto "ERROR: something went wrong creating the ncOutgoingQueue")
                                              (runUponHandshake session addr)
                                              (toMaybe mbpktoq))
                    HaveHandshake _ -> do
                        dmsg "basenonce mismatch, trigger refresh"
                        freshCryptoSession sessions addr newsession timestamp hp -- basenonce mismatch, trigger refresh
                    _ -> do
                        dmsg "updateCryptoSession -- unexpected condition! have hpTheirSessionKeyPublic but missing hpTheirBaseNonce?"
                        return (Nothing,return ())
            else do
                writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket)
                return (Nothing,return ())

handshakeH :: NetCryptoSessions -> SockAddr -> Handshake Encrypted -> IO (Maybe a)
handshakeH sessions addrRaw hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
    let addr = either id id $ either4or6 addrRaw
    dput XNetCrypto ("RECIEVED HANDSHAKE from " ++ show addr)
    -- Handle Handshake Message
    let crypto            = transportCrypto sessions   :: TransportCrypto
        allsessions       = netCryptoSessions sessions :: TVar (Map.Map SockAddr NetCryptoSession)
    seckeys <- map fst <$> atomically (userKeys crypto)
    dput XNetCrypto "trying the following keys:"
    forM_ seckeys $ \k -> dput XNetCrypto $ "  " ++ show (key2id . toPublic $ k)
    symkey <- atomically $ transportSymmetric crypto
    now <- getPOSIXTime
    dput XNetCrypto ("Decrypt cookie with n24=" ++ show n24 ++ "\n    symkey= " ++ show symkey)
    lr <- fmap  toHandshakeParams <$> decryptHandshake crypto hshake
    case lr of
        Left s -> dput XNetCrypto ("(NetCrypto)handshakeH: " ++ s)
        Right hp@(HParam
                      { hpTheirBaseNonce        = Just theirBaseNonce
                      , hpOtherCookie           = otherCookie
                      , hpTheirSessionKeyPublic = theirSessionKey
                      , hpMySecretKey           = key
                      , hpCookieRemotePubkey    = remotePublicKey
                      , hpCookieRemoteDhtkey    = remoteDhtPublicKey
                      }) -> do
            dput XNetCrypto ("(NetCrypto)handshakeH: hpTheirBaseNonce = " ++ show theirBaseNonce)
            -- IO action to get a new session key in case we need it in transaction to come
            newsession <- generateSecretKey
            -- Do a lookup, so we can handle the update case differently
            let dmsg msg = trace msg (return ())
            timestamp <- getPOSIXTime
            (myhandshake,launchThreads)
              <- atomically $ do
                    sessionsmap <- readTVar allsessions
                    case Map.lookup addr sessionsmap of
                        Nothing -> do
                            dmsg $ "sockaddr(" ++ show addr ++ ") not in session map(" ++ show (map (second ncSessionId) (Map.assocs sessionsmap)) ++ "), so freshCryptoSession"
                            let k = Key (key2id . toPublic $ key) (key2id remotePublicKey)
                            policy <- netCryptoPolicyByKey sessions k
                            case policy of
                                x | x `elem` [OpenToConnect,TryingToConnect] -> 
                                    freshCryptoSession sessions addr newsession timestamp hp -- create new session
                                x -> do
                                    dmsg $ "Ignoring Handshake from " ++ show (key2id remotePublicKey) ++ " due to policy: " ++ show x
                                    return (Nothing,return ())
                        Just session -> do
                            dmsg "sockaddr ALREADY in session map, so updateCryptoSession"
                            updateCryptoSession sessions addr (ncSessionSecret session) timestamp hp session hshake -- update existing session
            launchThreads
            forM myhandshake $ \response_handshake -> do
                sendHandshake sessions addr response_handshake
            return ()
    return Nothing

sessionPacketH :: NetCryptoSessions -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (x -> x))
sessionPacketH sessions addrRaw (CryptoPacket nonce16 encrypted) = do
    let addr = either id id $ either4or6 addrRaw
    dput XNetCrypto ("RECIEVED CRYPTOPACKET from " ++ show addr)
    let crypto = transportCrypto sessions
        allsessions = netCryptoSessions sessions
    sessionsmap <- atomically $ readTVar allsessions
    -- Handle Encrypted Message
    case Map.lookup addr sessionsmap of
        Nothing -> do
            dput XNetCrypto "Dropping packet.. no session"
            return Nothing -- drop packet, we have no session
        Just session@(NCrypto { ncIncomingTypeArray, ncState, ncPacketQueue, ncHooks,
                                ncSessionSecret, ncTheirSessionPublic, ncTheirBaseNonce,
                                ncPingMachine, ncSessionId}) -> do
         -- Unrecognized packets, try them thrice so as to give
         -- handshakes some time to come in
         -- TODO: Remove this loop, as it is probably unnecessary.
         -- If it is necessary, use a queue instead.
         flip fix (0::Int) $ \loop i -> do
          mbTheirBaseNonce <- atomically $ readTVar ncTheirBaseNonce
          case mbTheirBaseNonce of
           NeedHandshake -> do
            dput XNetCrypto "CryptoPacket recieved, but we still dont have their base nonce?"
            if (i < 3)
              then do
                dput XNetCrypto $ "Trying again (maybe handshake is on its way) ... i == "  ++ show i
                loop (i+1)
              else do
                dput XNetCrypto "Tried 3 times.. giving up on this packet"
                return Nothing
           HaveHandshake theirBaseNonce -> do
            -- Try to decrypt message
            let diff :: Word16
                diff      = nonce16 - (last2Bytes theirBaseNonce) -- truncating to Word16
                tempNonce = addtoNonce24 theirBaseNonce (fromIntegral diff)    -- expanding to Word
            mbpublickey <- atomically (readTVar ncTheirSessionPublic)
            lr <- fmap join $ sequence $ do -- Either Monad --
                        pubkey <- maybeToEither mbpublickey
                        Right $ do -- IO Monad
                        dput XNetCrypto $ "(NetCrypto)sessionPacketH: pubkey =  " ++ show (key2id $ pubkey)
                        dput XNetCrypto $ "(NetCrypto)sessionPacketH: theirBaseNonce =  " ++ show theirBaseNonce
                        dput XNetCrypto $ "(NetCrypto)sessionPacketH: tempNonce =  " ++ show tempNonce
                                       ++ " nonce16=" ++ printf "0x%x" nonce16 ++ " last2bytes =" ++ printf "0x%x" (last2Bytes theirBaseNonce)
                        dput XNetCrypto $ "(NetCrypto)sessionPacketH: mySession public=" ++ show (key2id $ toPublic ncSessionSecret)
                        dput XNetCrypto $ "(NetCrypto)sessionPacketH: theirSession public=" ++ show (key2id $ pubkey)
                        secret <- lookupSharedSecret crypto ncSessionSecret pubkey tempNonce
                        let step1 = decrypt secret encrypted
                        case step1 of
                            Left s -> do
                                dput XNetCrypto $ "(NetCrypto)sessionPacketH: (decrypt) " ++ s
                                return (Left s)
                            Right pln -> do
                                case decodePlain pln of
                                    Left s -> do
                                        dput XNetCrypto $ "(NetCrypto)sessionPacketH: (decodePlain) " ++ s
                                        return (Left s)
                                    Right x -> return (Right x)
            case lr of
                Left s -> do
                    dput XNetCrypto $ "(NetCrypto)sessionPacketH: " ++ s
                    return Nothing -- decryption failed, ignore packet
                Right cd'@(CryptoData {bufferStart, bufferEnd, bufferData=(unpadCryptoMsg -> cm)}) -> do -- decryption succeeded,
                    let cd = cd' { bufferData= cm }
                    -- TODO: Why do I need bufferStart & bufferEnd?
                    --
                    --   buffer_start = highest packet number handled + 1
                    --                , recvbuffers buffer_start
                    --
                    --   bufferEnd = sendbuffer buffer_end if lossy, otherwise packet number
                    -- update ncTheirBaseNonce if necessary
                    when (diff > 2 * dATA_NUM_THRESHOLD)$
                        atomically $ do
                            HaveHandshake y <- readTVar ncTheirBaseNonce
                            let x = addtoNonce24 y (fromIntegral dATA_NUM_THRESHOLD)
                            trace ("nonce y(" ++ show y ++ ") + " ++ show (fromIntegral dATA_NUM_THRESHOLD)
                                    ++ " = " ++ show x) (return ())
                            writeTVar ncTheirBaseNonce (HaveHandshake y)
                    -- then set session confirmed,
                    atomically $ writeTVar ncState {-Confirmed-}Established
                    -- bump ping machine
                    ncPingMachine0 <- atomically $ readTVar ncPingMachine
                    case ncPingMachine0 of
                        Just pingMachine -> -- Normally, we would bump the PingMachine to mark the connection
                                            -- as non-idle so that we don't need to send a ping message.
                                            -- Because tox has no pong message, we need to send a ping every
                                            -- eight seconds regardless, so we will let the PingIdle event be
                                            -- signaled even when we receive packets.
                                            -- pingBump pingMachine
                                            return ()
                        Nothing -> return ()
                    msgTypes <- atomically $ readTVar ncIncomingTypeArray
                    let msgTyp = cd ^. messageType
                        msgTypMapped64 = msgTypes A.! fromEnum8 (msgID cm)
                        msgTypMapped = fromWord64 $ msgTypMapped64
                        isLossy (GrpMsg KnownLossy _) = True
                        isLossy (Msg mid) | lossyness mid == Lossy = True
                        isLossy _ = False
                    if isLossy msgTypMapped
                        then do dput XNetCrypto $ "enqueue ncPacketQueue Lossy " ++ show cm
                                atomically $ PQ.observeOutOfBand ncPacketQueue bufferEnd
                                runCryptoHook session (bufferData cd)
                        else do dput XNetCrypto $ "enqueue ncPacketQueue Lossless " ++ show cm
                                when (msgID cm == PING) $
                                    dput XNetCrypto $ "NetCrypto Recieved PING (session " ++ show ncSessionId ++")"
                                atomically $ PQ.enqueue ncPacketQueue bufferEnd cd
                                return Nothing
    where
        last2Bytes :: Nonce24 -> Word16
        last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of
                                    Right n -> n -- trace ("byteSwap16 " ++ printf "0x%x" n ++ " = " ++ printf "0x%x" (byteSwap16 n)) $ byteSwap16 n
                                    _ -> error "unreachable-last2Bytes"
        dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3

runCryptoHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (x -> x))
runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce,ncIncomingTypeArray})
              cm {-cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm})-} = do
    hookmap <- atomically $ readTVar ncHooks
    -- run hook
    flip fix (cm,hookmap) $ \lookupAgain (cm,hookmap) -> do
        msgTypes <- atomically $ readTVar ncIncomingTypeArray
        let msgTyp = cm ^. messageType
            msgTypMapped64 = msgTypes A.! fromEnum8 (msgID cm)
            msgTypMapped = fromWord64 $ msgTypMapped64
        if msgTypMapped64 == 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 cm
                             case mbConsume of
                                Just f -> do
                                           -- ncUnrecognizedHook0 may have updated the hookmap
                                           hookmap' <- atomically $ readTVar ncHooks
                                           lookupAgain (f cm,hookmap')
                                Nothing -> return Nothing
                Just hooks -> flip fix (hooks,cm,msgTypMapped) $ \loop (hooks,cm,typ) -> do
                                let _ = cm :: CryptoMessage
                                case (hooks,cm) of
                                    ([],_) ->  return Nothing
                                    (hook:more,cd) -> do
                                        r <- hook session cm :: IO (Maybe (CryptoMessage -> CryptoMessage))
                                        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,toWord64 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

------------------ Slurped from c-toxcore for reference. -------------------------------
pattern   PACKET_ID_ONLINE               = 24
pattern   PACKET_ID_OFFLINE              = 25
pattern   PACKET_ID_NICKNAME             = 48
pattern   PACKET_ID_STATUSMESSAGE        = 49
pattern   PACKET_ID_USERSTATUS           = 50
pattern   PACKET_ID_TYPING               = 51
pattern   PACKET_ID_MESSAGE              = 64
-- pattern   PACKET_ID_ACTION               = (PACKET_ID_MESSAGE + MESSAGE_ACTION) {- 65 -}
pattern   PACKET_ID_MSI                  = 69
pattern   PACKET_ID_FILE_SENDREQUEST     = 80
pattern   PACKET_ID_FILE_CONTROL         = 81
pattern   PACKET_ID_FILE_DATA            = 82
pattern   PACKET_ID_INVITE_CONFERENCE    = 96
pattern   PACKET_ID_ONLINE_PACKET        = 97
pattern   PACKET_ID_DIRECT_CONFERENCE    = 98
pattern   PACKET_ID_MESSAGE_CONFERENCE   = 99
pattern   PACKET_ID_LOSSY_CONFERENCE     = 199
pattern   PACKET_ID_LOSSLESS_RANGE_START = 160
pattern   PACKET_ID_LOSSLESS_RANGE_SIZE  = 32
pattern   PACKET_ID_ALIVE                = 16
pattern   PACKET_ID_SHARE_RELAYS         = 17
pattern   PACKET_ID_FRIEND_REQUESTS      = 18
pattern   PACKET_ID_PADDING              = 0    -- Denotes padding
pattern   PACKET_ID_REQUEST              = 1    -- Used to request unreceived packets
pattern   PACKET_ID_KILL                 = 2    -- Used to killconnection
pattern   PACKET_ID_LOSSY_RANGE_START    = 192
pattern   PACKET_ID_LOSSY_RANGE_SIZE     = 63
----------------------------------------------------------------------------------------


-- | Handle all Tox messages that this code base is aware of.
--   The first parameter is a function which is applied to get the values
--   for keys of unknown nature. Could be either 'id' or 'const 0'
allMsgTypes :: (Word64 -> Word64) -> MsgTypeArray
allMsgTypes fDefault = A.listArray (minBound,maxBound) (0:knownMsgs)
  where
    knownMsgs :: [Word64]
    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
             ]

sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String ())
sendCrypto crypto session updateLocal cm = do
    HaveHandshake outq <- atomically $ readTVar (ncOutgoingQueue session)
    -- XXX: potential race? if shared secret comes out of sync with cache?
    dput XNetCrypto "sendCrypto: enter "
    getOutGoingParam <- PQ.readyOutGoing outq
    dput XNetCrypto "sendCrypto: got the io extra stuff"
    atomically $ do
        result <- PQ.tryAppendQueueOutgoing getOutGoingParam outq cm
        case result of
            PQ.OGSuccess    -> updateLocal >> return (Right())
            PQ.OGFull       -> return (Left "Outgoing packet buffer is full")
            PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet")

sendPing :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
sendPing crypto session = do
    let cm=OneByte PING
    addMsgToLastN False (cm ^. messageType) session (Out cm)
    sendCrypto crypto session (return ()) (OneByte PING)

sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
sendOnline crypto session = do
    let cm=OneByte ONLINE
    addMsgToLastN False (cm ^. messageType) session (Out cm)
    sendCrypto crypto session (return ()) (OneByte ONLINE)

sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
sendOffline crypto session = do
    let cm=OneByte OFFLINE
    addMsgToLastN False (cm ^. messageType) session (Out cm)
    sendCrypto crypto session (return ()) (OneByte OFFLINE)


sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
sendKill crypto session = do
    let cm=OneByte KillPacket
    mbOutQ <- atomically $ readTVar (ncOutgoingQueue session)
    case mbOutQ of
        NeedHandshake -> do
            let errmsg="NetCrypto NOT SENDING Kill packet (sessionid: " ++ show (ncSessionId session) ++ ") since no handshake yet"
            dput XNetCrypto errmsg
            dput XNetCrypto $ "Destroying session anyway"
            destroySession session
            return (Left errmsg)
        HaveHandshake outq -> do
            dput XNetCrypto $ "NetCrypto sending Kill packet (sessionid: " ++ show (ncSessionId session) ++ ")"
            getOutGoingParam <- PQ.readyOutGoing outq
            mbPkt <- atomically $ PQ.peekPacket getOutGoingParam outq cm
            case mbPkt of
                Nothing  -> do
                    let errmsg = "Error sending kill packet! (sessionid: " ++ show (ncSessionId session) ++ ")"
                    dput XNetCrypto errmsg
                    dput XNetCrypto $ "Destroying session anyway"
                    Right <$> destroySession session
                    return (Left errmsg)
                Just (pkt,seqno) -> do
                    case (ncSockAddr session) of
                      NeedDHTKey -> do
                        let errmsg= "NetCrypto NOT SENDING Kill packet (sessionid: " ++ show (ncSessionId session) ++ ") since no DHTkey(sockaddr) yet"
                        dput XNetCrypto errmsg
                        dput XNetCrypto $ "Destroying session anyway"
                        Right <$> destroySession session
                        return (Left errmsg)
                      HaveDHTKey saddr -> do
                        sendSessionPacket (ncAllSessions session) saddr pkt
                        dput XNetCrypto $ "sent kill packet (sessionid: " ++ show (ncSessionId session) ++ ")... now destroying session..."
                        Right <$> destroySession session

setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
setNick crypto session nick = do
    let Just (_,maxlen) = msgSizeParam NICKNAME
    if B.length nick > maxlen
     then return (Left $ "nickname must not exceed " ++ show maxlen ++ " bytes.")
     else do
        let updateLocal = do
                let viewVar = ncView session
                view <- readTVar viewVar
                writeTVar (svNick view) nick
        let cm = UpToN NICKNAME nick
        addMsgToLastN False (cm ^. messageType) session (Out cm)
        sendCrypto crypto session updateLocal cm

setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String ())
setTyping crypto session status = do
   let updateLocal = do
        view <- readTVar (ncView session)
        writeTVar (svTyping view) status
   let cm = TwoByte TYPING (fromEnum8 status)
   addMsgToLastN False (cm ^. messageType) session (Out cm)
   sendCrypto crypto session updateLocal cm

setNoSpam :: TransportCrypto -> NetCryptoSession -> Maybe NoSpam -> IO (Either String ())
setNoSpam crypto session mbnospam = do
   let viewVar = ncView session
   atomically $ do
    view <- readTVar viewVar
    writeTVar (svNoSpam view) mbnospam
   return (Right ())

setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String ())
setStatus crypto session status = do
   let updateLocal = do
        view <- readTVar (ncView session)
        writeTVar (svStatus view) status
   let cm = TwoByte USERSTATUS (fromEnum8 status)
   addMsgToLastN False (cm ^. messageType) session (Out cm)
   sendCrypto crypto session updateLocal cm

setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
setStatusMsg crypto session msg = do
    let Just (_,maxlen) = msgSizeParam STATUSMESSAGE
    if B.length msg > maxlen
     then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.")
     else do
        let updateLocal = do
                view <- readTVar (ncView session)
                writeTVar (svStatusMsg view) msg
        let cm = UpToN STATUSMESSAGE msg
        addMsgToLastN False (cm ^. messageType) session (Out cm)
        sendCrypto crypto session updateLocal cm

sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
sendChatMsg crypto session msg = do
    let Just (_,maxlen) = msgSizeParam MESSAGE
    if B.length msg > maxlen
     then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.")
     else do
        let updateLocal = do
                view <- readTVar (ncView session)
                writeTVar (svStatusMsg view) msg
        let cm = UpToN MESSAGE msg
        addMsgToLastN False (cm ^. messageType) session (Out cm)
        sendCrypto crypto session updateLocal cm

-- | handles nothings
defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook]
defaultCryptoDataHooks
    = Map.fromList
            [ (Msg USERSTATUS,[defaultUserStatusHook])
            , (Msg TYPING,[defaultTypingHook])
            , (Msg NICKNAME, [defaultNicknameHook])
            , (Msg STATUSMESSAGE, [defaultStatusMsgHook])
            , (Msg KillPacket, [defaultKillHook])
            ]

handlePacketRequest :: NetCryptoSession -> CryptoData -> IO ()
handlePacketRequest session (CryptoData { bufferStart=num
                                        , bufferData=cm@(msgID -> PacketRequest)
                                        }) | let getbytes (OneByte _) = []
                                                 getbytes (TwoByte _ b) = [b]
                                                 getbytes (UpToN _ bs) = B.unpack bs
                                           , bs <- getbytes cm
                                           , not (null bs)
                                           , HaveDHTKey addr <- ncSockAddr session
                                           = do
    mbOutQ <- atomically $ readTVar (ncOutgoingQueue session)
    case mbOutQ of
        HaveHandshake pktoq -> do
            getOutGoingParam <-PQ.readyOutGoing pktoq
            ps <- atomically $ PQ.getRequested getOutGoingParam pktoq num bs
            let resend (Just (n,pkt)) = sendSessionPacket (ncAllSessions session) addr pkt
                resend _ = return ()
            mapM_ resend ps
        _ -> return ()

handlePacketRequest session cd = return ()

defaultKillHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
defaultKillHook session cm@(msgID -> KillPacket) = do
    dput XNetCrypto $ "Recieved kill packet (sessionid: " ++ show (ncSessionId session) ++ ") destroying session"
    destroySession session
    return (Just $ \m -> m)
defaultKillHook _ _ = return (Just $ \cm -> cm)

defaultUserStatusHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
defaultUserStatusHook session cm@(TwoByte {msgID=USERSTATUS, msgByte=statusByte}) = do
    let status = toEnum8 statusByte
        viewVar = ncView session
    atomically $ do
        view <- readTVar viewVar
        writeTVar (svTheirStatus view) status
    hookHelper True (Msg USERSTATUS) session cm

defaultTypingHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
defaultTypingHook session cm@(TwoByte {msgID=TYPING, msgByte=statusByte}) = do
    let status = toEnum8 statusByte
        viewVar = ncView session
    atomically $ do
        view <- readTVar viewVar
        writeTVar (svTheirStatus view) status
    hookHelper True (Msg TYPING) session cm

defaultNicknameHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
defaultNicknameHook session cm@(UpToN {msgID=NICKNAME, msgBytes=nick}) = do
    let viewVar = ncView session
    atomically $ do
        view <- readTVar viewVar
        writeTVar (svTheirNick view) nick
    hookHelper True (Msg NICKNAME) session cm

defaultStatusMsgHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
defaultStatusMsgHook session cm@(UpToN {msgID=STATUSMESSAGE, msgBytes=msg}) = do
    let viewVar = ncView session
    atomically $ do
        view <- readTVar viewVar
        writeTVar (svTheirStatusMsg view) msg
    hookHelper True (Msg STATUSMESSAGE) session cm

-- | updates ncLastNMsgs, and sends message to type-0 listeners
defaultUnRecHook :: MessageType -> NetCryptoHook
defaultUnRecHook typ session cm = do
    dput XNetCrypto $ "(NetCrypto) defaultUnRecHook: packet (sessionid: " ++ show (ncSessionId session) ++ ") " ++ show cm
    hookHelper False typ session cm

hookHelper :: Bool -> MessageType -> NetCryptoHook
hookHelper _ typ session cm | any ($ typ) [isKillPacket, isOFFLINE] = do
  dput XNetCrypto $ "(hookHelper kill/offline) cm=" ++ show cm
  atomically $ do
    tmchans <- map snd . IntMap.elems <$> readTVar (ncListeners session)
    forM_ tmchans $ \chan -> closeTMChan chan
    return Nothing

hookHelper handledFlg typ  session  cm = do
    dput XNetCrypto $ "(ENTER hookHelper) " ++ show cm
    addMsgToLastN handledFlg typ session (In cm)
    atomically $ do
        idtmchans <- IntMap.assocs <$> readTVar (ncListeners session)
        mbChans
          <- forM idtmchans $ \(id,(typ,chan)) -> do
                bClosed <- isClosedTMChan chan
                if bClosed
                 then do
                    modifyTVar' (ncListeners session) (IntMap.delete id)
                    return Nothing
                 else return (if typ==0 then Just chan else Nothing)
        forM_ (catMaybes mbChans) $ \chan -> do
            writeTMChan chan cm
    return Nothing

addMsgToLastN :: Bool -> MessageType -> NetCryptoSession -> InOrOut CryptoMessage -> IO ()
addMsgToLastN handledFlg typ session cm = do
    let lastNQ = ncLastNMsgs session
    atomically $ do
        view <- readTVar (ncView session)
        snapshot <- viewSnapshot view
        num <- CB.getNextSequenceNum lastNQ
        CB.enqueue lastNQ num (handledFlg,(snapshot,cm))


-- | use to add a single hook to a specific session.
addCryptoDataHook1 :: Map.Map MessageType [NetCryptoHook] -> MessageType -> NetCryptoHook -> Map.Map MessageType [NetCryptoHook]
addCryptoDataHook1 mp typ hook = case Map.lookup typ mp of
                                    Nothing -> Map.insert typ [hook] mp
                                    Just hooks -> Map.insert typ (hook:hooks) mp