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 Connection
import Network.Tox.NodeId
import Network.Tox.Crypto.Transport
import Network.Tox.DHT.Transport (Cookie(..), NoSpam(..))
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 Control.Monad
import Data.Time.Clock.POSIX
import qualified Data.ByteString  as B
import Data.ByteString (ByteString)
import Control.Lens
import Data.Function
import Data.PacketBuffer as PB
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.Word64RangeMap.Unboxed as U
import qualified Data.Array.Unboxed as U
import qualified Data.Array as A
import SensibleDir
import System.FilePath
import System.Environment
import System.Directory
import System.Timeout
#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 DebugTag
import Text.Printf
import Data.Bool
import Network.Tox.Handshake

type LookupPolicyFunction = ToxContact -> STM Policy

-- * 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 = U.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)
        }

instance Serialize ViewSnapshot where
    get = ViewSnapshot <$> get <*> get <*> get <*> get <*> get
                       <*> get <*> get <*> get <*> get <*> get <*> (pure Map.empty)
    put (ViewSnapshot nick  status  statusmsg typing nospam
                      nick' status' statusmsg' typing' nospam' grps)
        = do
        put nick
        put status
        put statusmsg
        put typing
        put nospam
        put nick'
        put status'
        put statusmsg'
        put typing'
        put nospam'

-- | 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])
    , ncOutHooks           :: RangeMap TArray
                                       (TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted)))
                                       TVar
    , ncUnrecognizedHook   :: TVar (MessageType -> NetCryptoHook)
    , ncIdleEventHooks     :: TVar [(Int,NetCryptoSession -> IO ())]
    , ncDestoryHooks       :: TVar [(Int,NetCryptoSession -> IO ())]
    , 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      :: U.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
    , ncPacketBuffer       :: PacketBuffer CryptoData (CryptoPacket Encrypted)
    -- ^ 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
    , ncStoredRequests    :: CyclicBuffer CryptoData
    -- ^ Store the last 5 packet requests, try handling in any order
    --   if the connection seems like it is locked (TODO)
    , ncRequestInterval    :: TVar Int
    -- ^ How long (in miliseconds) to wait between packet requests
    , ncAliveInterval      :: TVar Int
    -- ^ How long before the next ALIVE packet ("PING")
    --   is to be sent regardless of activity
    , ncTimeOut            :: TVar Int
    -- ^ How many miliseconds of inactivity before this session is abandoned
    , ncIdleEvent          :: TVar Int
    -- ^ How many miliseconds of inactivity before emergency measures are taken
    --   Emergency measures = (rehandle the packet requests stored in ncStoredRequests)
    , 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
    , ncIdleEventThread    :: TVar (Maybe ThreadId)
    , ncOutgoingQueue      :: TVar (UponHandshake NetCryptoOutQueue)
                                    {-
                                    (PQ.PacketOutQueue
                                          (State,Nonce24,U.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
    , defaultIdleEventHooks   :: [(Int,NetCryptoSession -> IO ())]
    , defaultDestroyHook      :: [(Int,NetCryptoSession -> IO ())]
    , 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:)

addDestroySessionHook :: NetCryptoSession -> (Maybe Int) -> (NetCryptoSession -> IO ()) -> STM Int
addDestroySessionHook netcrypto mbkey hook = do
    modifyTVar (ncDestoryHooks netcrypto) $ \hooklist ->
        case mbkey of
            Just key -> ((key,hook):filter ((/=key) . fst) hooklist)
            Nothing -> let maxkey = maximum (map fst hooklist)
                           in if null hooklist then [(0,hook)] else (maxkey+1,hook):hooklist
    fst . head <$> readTVar (ncDestoryHooks netcrypto)

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
                 -> (NetCryptoSession -> IO ())         -- ^ default destroy hook
                 -> (MessageType -> NetCryptoHook)      -- ^ default hook
                 -> Map.Map MessageType [NetCryptoHook] -- ^ all hooks, can be empty to start
                 -> IO NetCryptoSessions
newSessionsState crypto destroyHook 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
                      , defaultIdleEventHooks   = [] -- [(0,handleRequestsOutOfOrder)]
                      , defaultDestroyHook      = [(0,destroyHook)]
                      , 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,U.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
    dtrace XNetCrypto ("ncToWire TOP OF FUNCTION " ++ show msg) (return ())
    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 <- dtrace XNetCrypto ("lookupInRangeMap typ64=" ++ show typ64 ++ " " ++ show typ ++ show msg)
                $ U.lookupInRangeMap typ64 msgOutMapVar
    case result1 of -- msgOutMapLookup typ64 msgOutMap of
        Nothing -> dtrace XNetCrypto "lookupInRangeMap gave Nothing!" $ return Nothing
        Just outid -> dtrace XNetCrypto ("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
                        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 dtrace XNetCrypto (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 = dtrace XNetCrypto 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)
    ncIdleEventHooks0 <- newTVar (defaultIdleEventHooks sessions)
    ncDestoryHooks0 <- newTVar (defaultDestroyHook 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,ncOutHooks0) <- do
        idmap <- U.emptySTMRangeMap
        U.insertArrayAt idmap  0 (U.listArray (0,255) [0 .. 255])
        -- the 2 escape ranges are adjacent, so put them in one array:
        U.insertArrayAt idmap  512 (U.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 $ U.listArray (0,255) [0 .. 255]
        losslessEsc <- newTVar $ U.listArray (0,255) [0 .. 255]
        outHooks <- emptySTMRangeMap
        let doNothingHook crypto session msg = return (Left "unsupported")
            assignHook 2  = (2,sendKillHook)
            assignHook 16 = (16,sendLossless{-Ping-})
            assignHook 24 = (24,sendOnlineHook)
            assignHook 25 = (25,sendLossless{-Offline-})
            assignHook 48 = (48,sendNickHook)
            assignHook 49 = (49,sendStatusMsgHook)
            assignHook 50 = (50,sendStatusHook)
            assignHook 51 = (51,sendTypingHook)
            assignHook 63 = (63,sendMessageHook)
            assignHook 64 = (64,sendMessageHook{-ACTION-})
            assignHook other = (other,doNothingHook)
        insertArrayAt outHooks 0 (A.array (0,64) (map assignHook [0..64]))
        return (idmap,lossyEsc,losslessEsc,outHooks)
    ncView0 <- newTVar (sessionView sessions)
    pktq <- PB.newPacketBuffer
    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)
    ncRequestThread0 <- newTVar Nothing
    ncDequeueThread0 <- newTVar Nothing
    ncDequeueOutGoingThread0 <- newTVar Nothing
    ncPingMachine0 <- newTVar Nothing
    ncPingThread0 <- newTVar Nothing
    ncIdleEventThread0 <- newTVar Nothing
    ncRequestInterval0 <- newTVar 1000 -- (TODO: shrink this) long interval while debugging slows trace flood
    ncAliveInterval0 <- newTVar 8000 -- 8 seconds
    -- ping Machine parameters
    fuzz <- return 0 -- randomRIO (0,2000) -- Fuzz to prevent simultaneous ping/pong exchanges.
                                           -- Disabled because tox has no pong event.
    ncTimeOut0 <- newTVar 32000 -- 32 seconds
    ncIdleEvent0 <- newTVar (5000 + fuzz) -- 5 seconds
    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
                    , ncOutHooks           = ncOutHooks0
                    , ncUnrecognizedHook   = ncUnrecognizedHook0
                    , ncIdleEventHooks     = ncIdleEventHooks0
                    , ncDestoryHooks       = ncDestoryHooks0
                    , ncAllSessions        = sessions
                    , ncIncomingTypeArray  = ncIncomingTypeArray0
                    , ncOutgoingIdMap      = ncOutgoingIdMap0
                    , ncOutgoingIdMapEscapedLossy    = lossyEscapeIdMap
                    , ncOutgoingIdMapEscapedLossless = losslessEscapeIdMap
                    , ncView               = ncView0
                    , ncPacketBuffer       = pktq
                    , ncStoredRequests     = ncStoredRequests0
                    , ncRequestInterval    = ncRequestInterval0
                    , ncAliveInterval      = ncAliveInterval0
                    , ncTimeOut            = ncTimeOut0
                    , ncIdleEvent            = ncIdleEvent0
                    , ncRequestThread         = ncRequestThread0
                    , ncDequeueThread         = ncDequeueThread0
                    , ncDequeueOutGoingThread = ncDequeueOutGoingThread0
                    , ncPingMachine           = ncPingMachine0
                    , ncPingThread            = ncPingThread0
                    , ncIdleEventThread       = ncIdleEventThread0
                    , 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,U.RangeMap TArray Word8 TVar)
                                           CryptoMessage
                                           (CryptoPacket Encrypted)
                                           CryptoData
-}
data NetCryptoOutQueue = NetCryptoOutQueue
    { nqPacketBuffer :: PacketBuffer CryptoData (CryptoPacket Encrypted)
    , nqToWire :: STM (State, Nonce24, U.RangeMap TArray Word8 TVar)
                     -> Word32
                     -> Word32
                     -> Word32
                     -> XMessage
                     -> STM (Maybe (CryptoPacket Encrypted, Word32))
    , nqToWireIO :: IO (STM (State, Nonce24, U.RangeMap TArray Word8 TVar))
    , nqPacketNo :: TVar Word32
    }

createNetCryptoOutQueue :: NetCryptoSessions -> SecretKey -> PublicKey -> PacketBuffer CryptoData (CryptoPacket Encrypted)
                        -> TVar Nonce24    -> U.RangeMap TArray Word8 TVar     -> STM (UponHandshake NetCryptoOutQueue)
createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 = do
            let crypto = transportCrypto sessions
            let toWireIO = do
                    dput XNetCrypto "=========== toWireIO TOP ==================="
                    f <- lookupNonceFunction crypto newsession theirSessionKey
                    atomically $ do
                        n24 <- readTVar ncMyPacketNonce0
                        let n24plus1 = incrementNonce24 n24
                        dtrace XNetCrypto ("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))
            seqnoVar <- newTVar 0
            return (HaveHandshake NetCryptoOutQueue
                        { nqPacketBuffer = pktq
                        , nqToWire       = ncToWire
                        , nqToWireIO     = toWireIO
                        , nqPacketNo     = seqnoVar
                        })

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

data OutGoingResult a = OGSuccess a | OGFull | OGEncodeFail
    deriving (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.)
--
-- Called from 'runUponHandshake' and 'sendCrypto'.
--
-- Whenever this is called, you should also send the resulting packet out on
-- the network.

tryAppendQueueOutgoing :: STM (State, Nonce24, U.RangeMap TArray Word8 TVar)
                            -> NetCryptoOutQueue
                            -> CryptoMessage
                            -> STM (OutGoingResult (CryptoPacket Encrypted))
tryAppendQueueOutgoing getExtra outq msg = do
    dtrace XNetCrypto ("tryAppendQueueOutgoing=========>DEBUG====?> " ++ show msg) (return ())
    pktno <- readTVar (nqPacketNo outq)
    nextno <- PB.expectingSequenceNumber (nqPacketBuffer outq)
    be <- PB.nextToSendSequenceNumber (nqPacketBuffer outq)
    mbWire <- nqToWire outq getExtra nextno be pktno msg
    case mbWire of
        Just (payload,seqno) -> do
            (isFull,_) <- PB.grokOutboundPacket (nqPacketBuffer outq) (PacketSent seqno payload)
            if isFull then return OGFull
                      else return $ OGSuccess payload
        Nothing -> return OGEncodeFail


runUponHandshake :: NetCryptoSession -> SockAddr -> NetCryptoOutQueue -> IO ()
runUponHandshake netCryptoSession0 addr pktoq = do
    dput XNetCrypto "(((((((runUponHandshake))))))) Launching threads"
    let sessions = ncAllSessions netCryptoSession0
        pktq = ncPacketBuffer 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 $ PB.awaitReadyPacket 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)
    reqthreadId <- forkIO $ do
        tid <- myThreadId
        atomically $ writeTVar (ncRequestThread netCryptoSession0) (Just tid)
        labelThread tid ("NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr)
        fix $ \loop -> do
            atomically (readTVar (ncRequestInterval netCryptoSession0)) >>= threadDelay . (* 1000)
            (nums,seqno) <- atomically $ PB.packetNumbersToRequest pktq
            dput XNetCrypto $ "(Request Thread) Missing Packets detected:" ++ show nums
            getOutGoingParam <- nqToWireIO pktoq
            sendPacketRequestResult <- sendLossless crypto netCryptoSession0 (createRequestPacket seqno nums)
            case sendPacketRequestResult of
                Left e -> dput XNetCrypto ("SEND PACKET REQUEST FAILED: " ++ e)
                _ -> dput XNetCrypto ( "SENT PACKET REQUEST (seqno=" ++ show seqno ++") " ++ show nums)
            loop
    dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr

    -- launch dequeueOutgoing thread
    {-
    -- TODO
    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
    pingMachine <- forkPingMachineDynamic ("NetCrypto." ++ show (key2id remotePublicKey) ++ sidStr) (ncIdleEvent netCryptoSession0) (ncTimeOut netCryptoSession0)
    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)
        fix $ \loop -> do
            atomically (readTVar (ncAliveInterval netCryptoSession0)) >>= threadDelay . (* 1000)
            dput XNetCryptoOut $ "pingThread (session: " ++ show (ncSessionId netCryptoSession0) ++ ") Sending Alive(PING) Packet"
            lr <- sendPing crypto netCryptoSession0
            case lr of
                Left s -> dput XNetCryptoOut $ "(pingThread session: " ++ show (ncSessionId netCryptoSession0) ++ ") " ++ s
                Right _ -> return ()
            loop

    -- launch IdleEvent thread
    idleThreadId <- forkIO $ do
        tid <- myThreadId
        atomically $ writeTVar (ncIdleEventThread netCryptoSession0) (Just tid)
        labelThread tid ("NetCryptoIdleEvent." ++ show (key2id remotePublicKey) ++ sidStr)
        event <- atomically $ pingWait pingMachine
        case event of
           PingIdle -> do
            hooks <- atomically (readTVar (ncIdleEventHooks netCryptoSession0))
            mapM_ (($ netCryptoSession0) . snd) hooks
           PingTimeOut -> destroySession netCryptoSession0
        
    -- 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
    -- 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
    -- first run all destory hooks
    hooks <- atomically (readTVar (ncDestoryHooks session))
    forM_ hooks $ \(key,hook) -> hook session
    -- now clean up threads
    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)
    stopMachine (ncPingMachine session)
    stopThread (ncPingThread session)
    stopThread (ncDequeueThread session)
    stopThread (ncDequeueOutGoingThread session)
    stopThread (ncRequestThread session)
    stopThread (ncIdleEventThread 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 do
                (r,action) <- freshCryptoSession sessions addr newsession timestamp hp
                return (r,destroySession session >> action)
            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
                                                (ncPacketBuffer 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"
                        (r,action) <- freshCryptoSession sessions addr newsession timestamp hp -- basenonce mismatch, trigger refresh
                        return (r, destroySession session >> action)
                    _ -> 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 = dtrace XNetCrypto 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 = ToxContact (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, ncPacketBuffer, ncHooks,
                                ncSessionSecret, ncTheirSessionPublic, ncTheirBaseNonce,
                                ncPingMachine, ncSessionId, ncStoredRequests}) -> 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
                        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)
                            dtrace XNetCrypto ("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
                        -- the ping machine is used to detect inactivity and respond accordingly
                        Just pingMachine -> pingBump pingMachine
                        Nothing -> return ()
                    msgTypes <- atomically $ readTVar ncIncomingTypeArray
                    let msgTyp = cd ^. messageType
                        msgTypMapped64 = msgTypes U.! fromEnum8 (msgID cm)
                        msgTypMapped = fromWord64 $ msgTypMapped64
                        isLossy (GrpMsg KnownLossy _) = True
                        isLossy (Msg mid) | lossyness mid == Lossy = True
                        isLossy _ = False
                        ack = bufferStart -- Earliest sequence number they've seen from us.
                    if (msgTypMapped /= Msg Padding && isLossy msgTypMapped) || isLossy msgTyp
                        then do dput XNetCrypto $ "enqueue ncPacketQueue Lossy (msgTyp=" ++ show msgTyp ++ " msgTypMapped=" ++show msgTypMapped ++ ") " ++ show cm
                                atomically $ PB.grokInboundPacket ncPacketBuffer
                                                (PacketReceivedLossy bufferEnd cd ack)
                                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 ++")"
                                when (msgID cm == PacketRequest) $ do
                                     dput XNetCrypto $ "PACKETREquest: " ++ showCryptoMsg bufferEnd cm
                                  -- atomically $ do
                                  --    num <- CB.getNextSequenceNum ncStoredRequests
                                  --    CB.enqueue ncStoredRequests num cd
                                     handlePacketRequest session cd
                                atomically $ PB.grokInboundPacket ncPacketBuffer
                                                (PacketReceived bufferEnd cd ack)
                                return Nothing
    where
        last2Bytes :: Nonce24 -> Word16
        last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of
                                    Right n -> n -- dtrace XNetCrypto ("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 U.! 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 = U.listArray (0,255) (replicate 256 0)
                      in zeros U.// 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 = U.listArray (minBound,maxBound) (0:knownMsgs)

knownMsgs :: [Word64]
knownMsgs =
      concat [ map (fromIntegral . fromEnum) [ PacketRequest .. KillPacket ]
             , map (const 0)                 [ 3 .. 15 ]  -- UnspecifiedPacket
             , map (fromIntegral . fromEnum) [ PING ]
             , map (const 0)                 [ 17 .. 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 (CryptoPacket Encrypted))
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 MESSAGE: " ++ show cm)
    getOutGoingParam <- nqToWireIO outq
    dput XNetCrypto "sendCrypto: got the io extra stuff"
    ncTime <- atomically $ readTVar (ncTimeOut session)
    r0 <- timeout (ncTime*1000) . atomically $ do
        result <- tryAppendQueueOutgoing getOutGoingParam outq cm
        case result of
            OGSuccess x  -> updateLocal >> return (Right x)
            OGFull       -> retry -- return (Left "Outgoing packet buffer is full")
            OGEncodeFail -> return (Left "Failed to encode outgoing packet")
    let r = case r0 of
                Nothing -> Left "Outgoing packet buffer is full"
                Just x  -> x
    case ncSockAddr session of
        HaveDHTKey saddr -> mapM_ (sendSessionPacket (ncAllSessions session) saddr) r
        _                -> return ()
    return r

sendPing :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
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 (CryptoPacket Encrypted))
sendOnline crypto session = do
    let cm=OneByte ONLINE
    sendOnlineHook crypto session cm

sendOnlineHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendOnlineHook crypto session cm = do
    addMsgToLastN False (cm ^. messageType) session (Out cm)
    result <- sendCrypto crypto session (return ()) (OneByte ONLINE)
    -- double this packet
    case result of
        Right pkt -> do
            void . forkIO $ do
                tid <- myThreadId
                labelThread tid "TEMPORARY.PACKET.DOUBLE.ONLINE"
                threadDelay 100000 -- delay 10th of a second
                case ncSockAddr session of
                    HaveDHTKey saddr -> sendSessionPacket (ncAllSessions session) saddr pkt
            return (Right pkt)

sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
sendOffline crypto session = do
    let cm=OneByte OFFLINE
    sendLossless crypto session (OneByte OFFLINE)


sendLossless :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendLossless crypto session cm = do
    addMsgToLastN False (cm ^. messageType) session (Out cm)
    sendCrypto crypto session (return ()) cm

sendLossy :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendLossy crypto session cm = sendCryptoLossy crypto session (return ()) cm

sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
sendKill crypto session = do
    let cm=OneByte KillPacket
    sendKillHook crypto session cm

sendKillHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendKillHook crypto session cm = sendCryptoLossy crypto session (destroySession session) cm

sendCryptoLossy :: TransportCrypto -> NetCryptoSession -> (IO ()) -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendCryptoLossy crypto session updateLocal cm = do
    mbOutQ <- atomically $ readTVar (ncOutgoingQueue session)
    case mbOutQ of
        NeedHandshake -> do
            let errmsg = "Error sending lossy packet! (sessionid: " ++ show (ncSessionId session) ++ ") Need the Handshake first!"
            updateLocal
            return (Left errmsg)
        HaveHandshake outq -> do
            getOutGoingParam <- nqToWireIO outq
            mbPkt <- atomically $ do
                    pktno <- readTVar (nqPacketNo outq)
                    nextno <- PB.expectingSequenceNumber (nqPacketBuffer outq)
                    be <- PB.nextToSendSequenceNumber (nqPacketBuffer outq)
                    nqToWire outq getOutGoingParam -- See 'ncToWire'
                        nextno -- packet number we expect to recieve
                        be     -- buffer_end  (for lossy)
                        pktno  -- packet number (for lossless)
                        cm
            case mbPkt of
                Nothing  -> do
                    let errmsg = "Error sending lossy packet! (sessionid: " ++ show (ncSessionId session) ++ ") " ++ show cm
                    updateLocal
                    return (Left errmsg)
                Just (pkt,seqno) -> do
                    case (ncSockAddr session) of
                      NeedDHTKey -> do
                        let errmsg= "NetCrypto NOT SENDING Lossy packet (sessionid: " ++ show (ncSessionId session) ++ ") since no DHTkey(sockaddr) yet"
                        updateLocal
                        return (Left errmsg)
                      HaveDHTKey saddr -> do
                        sendSessionPacket (ncAllSessions session) saddr pkt
                        dput XNetCrypto $ "sent lossy packet (sessionid: " ++ show (ncSessionId session) ++ ") " ++ take 40 (show cm) ++ "..."
                        updateLocal
                        return (Right pkt)

setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
setNick crypto session nick = do
    let cm = UpToN NICKNAME nick
    sendNickHook crypto session cm

sendNickHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendNickHook crypto session cm = do
    let Just (_,maxlen) = msgSizeParam NICKNAME
    let nick = msgBytes cm
    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
        addMsgToLastN False (cm ^. messageType) session (Out cm)
        sendCrypto crypto session updateLocal cm

setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String (CryptoPacket Encrypted))
setTyping crypto session status = do
   let cm = TwoByte TYPING (fromEnum8 status)
   sendTypingHook crypto session cm

sendTypingHook:: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendTypingHook crypto session cm = do
   let status = toEnum8 (msgByte cm)
   let updateLocal = do
        view <- readTVar (ncView session)
        writeTVar (svTyping view) 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 (CryptoPacket Encrypted))
setStatus crypto session status = do
   let cm = TwoByte USERSTATUS (fromEnum8 status)
   sendStatusHook crypto session cm

sendStatusHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendStatusHook crypto session cm = do
   let status = toEnum8 (msgByte cm)
   let updateLocal = do
        view <- readTVar (ncView session)
        writeTVar (svStatus view) status
   addMsgToLastN False (cm ^. messageType) session (Out cm)
   sendCrypto crypto session updateLocal cm

setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
setStatusMsg crypto session msg = do
    let cm = UpToN STATUSMESSAGE msg
    sendStatusMsgHook crypto session cm

sendStatusMsgHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendStatusMsgHook crypto session cm = do
    let Just (_,maxlen) = msgSizeParam STATUSMESSAGE
    let msg = msgBytes cm
    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
        addMsgToLastN False (cm ^. messageType) session (Out cm)
        sendCrypto crypto session updateLocal cm

sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
sendChatMsg crypto session msg = do
    let cm = UpToN MESSAGE msg
    sendMessageHook crypto session cm

sendMessageHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
sendMessageHook crypto session cm = do
    let Just (_,maxlen) = msgSizeParam MESSAGE
    let msg = msgBytes cm
    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
        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])
            ]

handleRequestsOutOfOrder :: NetCryptoSession -> IO ()
handleRequestsOutOfOrder session = do
    cds <- atomically $ CB.cyclicBufferViewList (ncStoredRequests session)
    mapM_ (handlePacketRequest session) (map snd cds)

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 <-nqToWireIO pktoq
            ps <- atomically $ PB.retrieveForResend (nqPacketBuffer pktoq) $ PB.decompressSequenceNumbers num bs
            let resend (n,pkt) = sendSessionPacket (ncAllSessions session) addr pkt
            dput XNetCrypto ("Re-Sending Packets: " ++ show (map fst ps))
            mapM_ resend ps
        _ -> dput XNetCrypto "ERROR: Incoming Packet request, yet no ncOutgoingQueue!"

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