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

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
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, createCookie )
import Crypto.Tox
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
import Control.Concurrent
import GHC.Conc (labelThread)
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(..))
import Connection.Tox (ToxProgress(..))


-- * 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
    , ncDequeueThread      :: Maybe ThreadId
    -- ^ when the thread which dequeues from ncPacketQueue
    -- is started, its ThreadId is stored here
    , ncPingMachine        :: Maybe PingMachine
    -- ^ when the ping thread is started, store it here
    , ncOutgoingQueue      :: 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
    }

data NetCryptoSessions = NCSessions
    { netCryptoSessions       :: TVar (Map.Map SockAddr NetCryptoSession)
    , netCryptoSessionsByKey  :: TVar (Map.Map PublicKey [NetCryptoSession])
    , transportCrypto         :: TransportCrypto
    , defaultHooks            :: Map.Map MessageType [NetCryptoHook]
    , defaultUnrecognizedHook :: MessageType -> NetCryptoHook
    , sessionView             :: SessionView
    , msgTypeArray            :: MsgTypeArray
    , inboundQueueCapacity    :: Word32
    , outboundQueueCapacity   :: Word32
    , nextSessionId           :: TVar SessionID
    , 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
                      , 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
                      }

data HandshakeParams
        = HParam
            { hpTheirBaseNonce        :: Maybe Nonce24 -- ignore and generate your own
            , hpOtherCookie           :: Cookie Encrypted
            , hpTheirSessionKeyPublic :: Maybe PublicKey
            , hpMySecretKey           :: SecretKey
            , hpCookieRemotePubkey    :: PublicKey
            , hpCookieRemoteDhtkey    :: PublicKey
            }

newHandShakeData :: TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> IO (Maybe HandshakeData)
newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr
    = do
    freshCookie
      <- case  nodeInfo (key2id hpCookieRemoteDhtkey) addr  of
            Right nodeinfo -> Just <$> createCookie crypto nodeinfo hpCookieRemotePubkey
            Left er        -> return Nothing
    let hinit                = hashInit
        Cookie n24 encrypted = hpOtherCookie
        hctx                 = hashUpdate hinit n24
        hctx'                = hashUpdate hctx encrypted
        digest               = hashFinalize hctx'
-- parameters addr {--> SockAddr -}
--    mbcookie <- case hpOtherCookie of
--                    Nothing -> case (nodeInfo hpCookieRemoteDhtkey addr) of
--                                Right nodeinfo -> cookieRequest crypto netCryptoDHTClient (toPublic hpMySecretKey) nodeinfo
--                                Left er -> return Nothing
--                    Just c -> return (Just c)

    return $
      fmap (\freshCookie' ->
            HandshakeData
                { baseNonce   = basenonce
                , sessionKey  = toPublic hpMySecretKey
                , cookieHash  = digest
                , otherCookie = freshCookie'
                }) freshCookie

type XMessage = CryptoMessage -- todo

-- 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 -> HandshakeParams -> IO ()
freshCryptoSession  sessions
                    addr
                    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
    sessionId <- atomically $ do
        x <- readTVar (nextSessionId sessions)
        modifyTVar    (nextSessionId sessions) (+1)
        return x
    -- ncState0 <- atomically $ newTVar Accepted -- (InProgress AwaitingSessionPacket)
    ncState0 <- atomically $ newTVar (if isJust mbtheirBaseNonce
                                        then InProgress AwaitingSessionPacket
                                        else InProgress AwaitingHandshake)
    ncTheirBaseNonce0 <- atomically $ newTVar (frmMaybe mbtheirBaseNonce)
    n24 <- atomically $ transportNewNonce crypto
    state <- lookupSharedSecret crypto key remotePublicKey n24
    newBaseNonce <- atomically $ transportNewNonce crypto
    mbMyhandshakeData <- newHandShakeData crypto newBaseNonce hp addr
    let encodeHandshake myhandshakeData = let plain = encodePlain myhandshakeData
    --                                        state = computeSharedSecret key remoteDhtPublicKey n24
                                              encrypted = encrypt state plain
                                              in Handshake { handshakeCookie = otherCookie
                                                           , handshakeNonce = n24
                                                           , handshakeData = encrypted
                                                           }
    let myhandshake= encodeHandshake <$> mbMyhandshakeData
    ncHandShake0 <- atomically $ newTVar (frmMaybe myhandshake)
    forM myhandshake $ \response_handshake -> do
        sendHandshake sessions addr response_handshake
    ncMyPacketNonce0 <- atomically $ newTVar newBaseNonce
    cookie0 <- atomically $ newTVar (HaveCookie otherCookie)
    newsession <- generateSecretKey
    ncHooks0 <- atomically $ newTVar (defaultHooks sessions)
    ncUnrecognizedHook0 <- atomically $ newTVar (defaultUnrecognizedHook sessions)
    ncIncomingTypeArray0 <- atomically $ newTVar (msgTypeArray sessions)
    let idMap = foldl (\mp (x,y) -> W64.insert x y mp) W64.empty (zip [0..255] [0..255])
    (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap) <- atomically $ 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 <- atomically $ newTVar (sessionView sessions)
    pktq <- atomically $ PQ.new (inboundQueueCapacity sessions) 0
    bufstart <- atomically $ newTVar 0
    mbpktoq
     <- case mbtheirSessionKey of
         Nothing -> return NeedHandshake
         Just theirSessionKey -> createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0
    lastNQ <- atomically (CB.new 10 0 :: STM (CyclicBuffer (Bool,(ViewSnapshot,InOrOut CryptoMessage))))
    listeners <- atomically $ newTVar IntMap.empty
    msgNum <- atomically $ newTVar 0
    dropNum <- atomically $ newTVar 0
    theirbasenonce <- atomically $ readTVar ncTheirBaseNonce0
    dput XNetCrypto $ "freshCryptoSession: Session ncTheirBaseNonce=" ++ show theirbasenonce
    ncTheirSessionPublic0 <- atomically $ newTVar (frmMaybe mbtheirSessionKey)
    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
                    , ncDequeueThread      = Nothing -- error "you want the NetCrypto-Dequeue thread id, but is it started?"
                    , ncPingMachine        = Nothing -- error "you want the NetCrypto-PingMachine, but is it started?"
                    , ncOutgoingQueue      = mbpktoq
                    , ncLastNMsgs          = lastNQ
                    , ncListeners          = listeners
                    }
    case mbpktoq of
        NeedHandshake -> return ()
        HaveHandshake pktoq -> runUponHandshake netCryptoSession0 addr pktoq

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     -> IO (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) $ writeTVar ncMyPacketNonce0 n24plus1
                        return (return (f n24, n24, ncOutgoingIdMap0))
            pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0
            return (HaveHandshake pktoq)


runUponHandshake :: NetCryptoSession -> SockAddr -> NetCryptoOutQueue -> IO ()
runUponHandshake netCryptoSession0 addr pktoq = do
    let sessions = ncAllSessions netCryptoSession0
        pktq = ncPacketQueue netCryptoSession0
        remotePublicKey = ncTheirPublicKey netCryptoSession0
        crypto = transportCrypto sessions
        allsessions = netCryptoSessions sessions
        allsessionsByKey = netCryptoSessionsByKey sessions
    -- launch dequeue thread
    -- (In terms of data dependency, this thread could be launched prior to handshake)
    threadid <- forkIO $ do
        tid <- myThreadId
        labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey))
        fix $ \loop -> do
            cd <- atomically $ PQ.dequeue pktq
            _ <- runCryptoHook (netCryptoSession0 {ncDequeueThread=Just tid}) (bufferData cd)
            loop
    -- launch dequeueOutgoing thread
    threadidOutgoing <- forkIO $ do
        tid <- myThreadId
        labelThread tid ("NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey))
        fix $ \loop -> do
            (_,pkt) <- atomically $ PQ.dequeueOutgoing pktoq
            dput XNetCrypto "NetCryptoDequeueOutgoing thread... Sending encrypted Packet"
            sendSessionPacket sessions addr pkt
            loop
    -- launch ping thread
    fuzz <- randomRIO (0,2000)
    pingMachine <- forkPingMachine ("NetCrypto." ++ show (key2id remotePublicKey)) (15000 + fuzz) 2000
    -- update session with thread ids
    let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid, ncPingMachine=Just pingMachine}
    -- add this session to the lookup maps
    atomically $ do
        modifyTVar allsessions (Map.insert addr netCryptoSession)
        byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey
        case byKeyResult of
            Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession])
            Just xs -> modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs))
    -- run announceNewSessionHooks
    hooks <- atomically $ readTVar (announceNewSessionHooks sessions)
    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 ()

-- | Called when we get a handshake, but there's already a session entry.
updateCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> NetCryptoSession -> Handshake Encrypted -> IO ()
updateCryptoSession sessions addr hp session handshake = do
    ncState0 <- atomically $ readTVar (ncState session)
    ncTheirBaseNonce0 <- atomically $ 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
          dput XNetCrypto "updateCryptoSession already accepted.."
          dput XNetCrypto ("   ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0
                         ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp)
                         ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp))
          dput XNetCrypto ("   ncTheirDHTKey=" ++ show (ncTheirDHTKey session)
                         ++ bool "{/=}" "{==}" (ncTheirDHTKey session == HaveDHTKey (hpCookieRemoteDhtkey hp))
                         ++ "hpCookieRemoteDhtkey=" ++ show (hpCookieRemoteDhtkey hp))
          if   (  -- Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp -- XXX: Do we really want to compare base nonce here?
                  -- ||
               ncTheirDHTKey session /= HaveDHTKey (hpCookieRemoteDhtkey hp)
               ) then freshCryptoSession sessions addr hp
                 else do
                    atomically $ do
                        writeTVar (ncTheirBaseNonce session)    (frmMaybe (hpTheirBaseNonce hp))
                        writeTVar (ncTheirSessionPublic session) (frmMaybe (hpTheirSessionKeyPublic hp))
                        writeTVar (ncHandShake session) (HaveHandshake handshake)
                    case ncOutgoingQueue session of
                        NeedHandshake -> do
                            case hpTheirSessionKeyPublic hp of
                                Just sessionpubkey -> do
                                    pktoq <- createNetCryptoOutQueue sessions (ncSessionSecret session) sessionpubkey
                                                                (ncPacketQueue session) (ncMyPacketNonce session) (ncOutgoingIdMap session)
                                    case pktoq of
                                        NeedHandshake -> dput XNetCrypto "Unexpectedly missing ncOutgoingQueue"
                                        HaveHandshake pktoq -> runUponHandshake session addr pktoq
                        HaveHandshake pktoq -> runUponHandshake session addr pktoq
     else do
          dput XNetCrypto "updateCryptoSession else clause"
          dput XNetCrypto ("   ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0
                         ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp)
                         ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp))
          if ( ncTheirBaseNonce0 /= frmMaybe (hpTheirBaseNonce hp))
            then freshCryptoSession sessions addr hp -- basenonce mismatch, trigger refresh
            else atomically $ writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket)

anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1)
anyRight e []     f = return $ Left e
anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right)

handshakeH :: NetCryptoSessions -> SockAddr -> Handshake Encrypted -> IO (Maybe a)
handshakeH sessions addr hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
    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 join . sequence $ do -- Either Monad
            CookieData cookieTime remotePubkey remoteDhtkey <- decodePlain =<< decryptSymmetric symkey n24 ecookie
            Right $ do -- IO Monad
            decrypted <- anyRight "missing key" seckeys $ \key -> do
                            dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey =  " ++ show (key2id $ remotePubkey)
                            dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 =  " ++ show nonce24
                            secret <- lookupSharedSecret crypto key remotePubkey nonce24
                            let step1 = decrypt secret encrypted
                            case step1 of
                                Left s -> do
                                    dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s
                                    return (Left s)
                                Right pln -> do
                                    case decodePlain pln of
                                        Left s -> do
                                            dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s
                                            return (Left s)
                                        Right x -> return (Right (key,x))
            return $ do -- Either Monad
            (key,HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted
            -- check cookie time < 15 seconds ago
            guard (now - fromIntegral cookieTime < 15)
            -- cookie hash is valid? sha512 of ecookie
            let hinit = hashInit
                hctx = hashUpdate hinit n24
                hctx' = hashUpdate hctx ecookie
                digest = hashFinalize hctx'
            guard (cookieHash == digest)
            -- known friend?
            -- todo TODO, see Roster.hs,
            -- talk to not yet existent Network-Manager to ascertain current permissions
            return
             HParam
                { hpTheirBaseNonce        = Just baseNonce
                , hpOtherCookie           = otherCookie
                , hpTheirSessionKeyPublic = Just sessionKey
                , hpMySecretKey           = key
                , hpCookieRemotePubkey    = remotePubkey
                , hpCookieRemoteDhtkey    = remoteDhtkey
                }
    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)
            sessionsmap <- atomically $ readTVar allsessions
            -- Do a lookup, so we can handle the update case differently
            case Map.lookup addr sessionsmap of
                Nothing -> do
                    dput XNetCrypto "sockaddr not in session map, so freshCryptoSession"
                    freshCryptoSession sessions addr hp -- create new session
                Just session -> do
                    dput XNetCrypto "sockaddr ALREADY in session map, so updateCryptoSession"
                    updateCryptoSession sessions addr hp session hshake -- update existing session
    return Nothing

sessionPacketH :: NetCryptoSessions -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (x -> x))
sessionPacketH sessions addr (CryptoPacket nonce16 encrypted) = do
    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}) -> do
         mbTheirBaseNonce <- atomically $ readTVar ncTheirBaseNonce
         case mbTheirBaseNonce of
          NeedHandshake -> dput XNetCrypto "CryptoPacket recieved, but we still dont have their base nonce?" >> 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)
                        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=cm}) -> do -- decryption succeeded,
                    -- 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
                    case ncPingMachine of
                        Just pingMachine -> pingBump pingMachine
                        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"
                                atomically $ PQ.observeOutOfBand ncPacketQueue bufferEnd
                                runCryptoHook session (bufferData cd)
                        else do dput XNetCrypto "enqueue ncPacketQueue Lossless"
                                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

-- | 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
    let HaveHandshake outq = 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")

sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
sendOnline crypto session = sendCrypto crypto session (return ()) (OneByte ONLINE)

sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
sendOffline crypto session = sendCrypto crypto session (return ()) (OneByte OFFLINE)


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

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

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 = hookHelper False

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

hookHelper handledFlg typ  session  cm = do
    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