{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE ViewPatterns              #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE NondecreasingIndentation  #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE PartialTypeSignatures     #-}
{-# LANGUAGE PatternSynonyms           #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}

module Main where

import Control.Arrow
import Control.Applicative
import Control.Concurrent.STM
import Control.Concurrent.STM.TMChan
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.Array.MArray (getAssocs)
import Data.Bool
import Data.Char
import Data.Conduit as C
import qualified Data.Conduit.List as C
import Data.Function
import Data.Hashable
import Data.List
import Data.Word
import Data.InOrOut
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set        as Set
import Data.Tuple
import Data.Time.Clock
import qualified Data.XML.Types  as XML
import GHC.Conc (threadStatus,ThreadStatus(..))
import GHC.Stats
import Network.Socket
import System.Environment
import System.IO
import System.Mem
import System.Posix.Process
import Text.PrettyPrint.HughesPJClass
import Text.Printf
import Text.Read
#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
import GHC.Conc                  (labelThread)
#endif
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import System.Posix.Signals
import qualified Data.Array.Unboxed as U
import qualified Data.Conduit as Conduit

import Announcer
import Announcer.Tox
import ToxManager
import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys)
import DebugUtil
import Network.UPNP as UPNP
import Network.Address hiding (NodeId, NodeInfo(..))
import Network.QueryResponse
import Network.StreamServer
import Network.Kademlia.CommonAPI
import Network.Kademlia.Persistence
import Network.Kademlia.Routing as R
import Network.Kademlia.Search
import qualified Network.BitTorrent.MainlineDHT as Mainline
import qualified Network.Tox as Tox
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as B
import qualified Data.Text.Encoding as E
import qualified Data.Text.Encoding.Error as E
import Control.Concurrent.Tasks
import System.IO.Error
import qualified Data.Serialize as S
import Network.BitTorrent.DHT.ContactInfo as Peers
import qualified Data.MinMaxPSQ as MM
import Data.Wrapper.PSQ as PSQ (pattern (:->))
import qualified Data.Wrapper.PSQ as PSQ
import Data.Ord
import Data.Time.Clock.POSIX
import qualified Network.Tox.DHT.Transport as Tox
import qualified Network.Tox.DHT.Handlers as Tox
import qualified Network.Tox.Onion.Transport as Tox
import qualified Network.Tox.Onion.Handlers as Tox
import qualified Network.Tox.Crypto.Transport as Tox (CryptoMessage(..))
import qualified Network.Tox.Crypto.Handlers as Tox
import Data.Typeable
import Network.Tox.ContactInfo as Tox
import OnionRouter
import Data.PacketQueue
import qualified Data.Word64Map as W64
import Network.Tox.AggregateSession
import System.FilePath
import System.Process
import System.Posix.IO
import Data.Word64RangeMap
import Network.Tox.Crypto.Transport
import Data.Conduit.Cereal
import qualified Data.Conduit.Binary as Conduit

-- Presence imports.
import ConsoleWriter
import Presence
import XMPPServer
import Connection
import ToxToXMPP
import XMPPToTox
import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp,TCPStatus)
import Control.Concurrent.Supply
import qualified Data.CyclicBuffer as CB
import DPut


pshow :: Show a => a -> B.ByteString
pshow = B.pack . show

marshalForClient :: String -> String
marshalForClient s = show (length s) ++ ":" ++ s

marshalForClientB :: B.ByteString -> B.ByteString
marshalForClientB s = B.concat [pshow (B.length s),":",s]

data ClientHandle = ClientHandle Handle (MVar Int)

-- | Writes a message and signals ready for next command.
hPutClient :: ClientHandle -> String -> IO ()
hPutClient (ClientHandle h hstate) s = do
    st <- takeMVar hstate
    hPutStr h ('.' : marshalForClient s)
    putMVar hstate 1 -- ready for input

-- | Writes a message and signals ready for next command.
hPutClientB :: ClientHandle -> B.ByteString -> IO ()
hPutClientB (ClientHandle h hstate) s = do
    st <- takeMVar hstate
    B.hPutStr h ('.' `B.cons` marshalForClientB s)
    putMVar hstate 1 -- ready for input

-- | Writes message, but signals there is more to come.
hPutClientChunk :: ClientHandle -> String -> IO ()
hPutClientChunk (ClientHandle h hstate) s = do
    st <- takeMVar hstate
    hPutStr h (' ' : marshalForClient s)
    putMVar hstate 2 -- ready for more output


{-
pingNodes :: String -> DHT -> IO Bool
pingNodes netname DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "ping" dhtPing = do
    let fname = nodesFileName netname
    attempt <- tryIOError $ do
        J.decode <$> L.readFile fname
         >>= maybe (ioError $ userError "Nothing") return
-}

asProxyTypeOf :: a -> proxy a -> a
asProxyTypeOf = const

pingNodes :: String -> DHT -> IO (Maybe Int)
pingNodes netname dht@DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "ping" dhtPing = do
    let fname = nodesFileName netname
    ns <- loadNodes netname
    case ns of
        [] -> return Nothing
        _ -> do
            fork $ do
                 myThreadId >>= flip labelThread ("pinging."++fname)
                 putStrLn $ "Forked "++show fname
                 withTaskGroup ("withTaskGroup."++fname) 10 $ \g -> do
                   forM_ (ns `asTypeOf` [])
                        $ \n -> forkTask g (show n)
                                $ void
                                $ ping [] n
                 putStrLn $ "Load finished "++show fname
            return $ Just $ length ns
pingNodes _ _ = return Nothing



reportTable :: Show ni => BucketList ni -> [(String,String)]
reportTable bkts = map (show *** show . fst)
                 $ concat
                 $ zipWith map (map (,) [0::Int ..])
                 $ R.toList
                 $ bkts

reportResult ::
    String
    -> (r -> String)
    -> (tok -> Maybe String)
    -> (ni -> String)
    -> ClientHandle
    -> Either String ([ni],[r],Maybe tok)
    -> IO ()
reportResult meth showR showTok showN h (Left e)            = hPutClient h e
reportResult meth showR showTok showN h (Right (ns,rs,tok)) = do
    hPutClient h $ showReport report
 where
    report = intercalate [("","")] [ tok_r , node_r , result_r ]

    tok_r = maybe [] (pure . ("token:",)) $ showTok =<< tok

    node_r = map ( ("n",) . showN ) ns

    result_r | (meth=="node") = []
             | otherwise      = map ( (take 1 meth,) . showR ) rs

-- example:
-- * 10 peer 141d6c6ee2810f46d28bbe8373d4f454a4122535
-- - 1  peer 141d6c6ee2810f46d28bbe8373d4f454a4122535
--   22 node 141d6c6ee2810f46d28bbe8373d4f454a4122535
--
-- key: '*' in progress
--      '-' stopped
--      ' ' finished
showSearches :: ( Show nid
                , Ord nid
                , Hashable nid
                , Ord ni
                , Hashable ni
                ) => Map.Map (String,nid) (DHTSearch nid ni) -> IO String
showSearches searches = do
    tups <- forM (Map.toList searches) $ \((meth,nid),DHTSearch{..}) -> do
        (is'fin, cnt) <- atomically $
                (,) <$> searchIsFinished searchState
                    <*> (Set.size <$> readTVar searchResults)
        tstat <- threadStatus searchThread
        let stat = case tstat of
                _ | is'fin     -> ' '
                ThreadFinished -> '-'
                ThreadDied     -> '-'
                _              -> '*'
        return (stat,show cnt,meth,show nid)
    let cnt'width = maximum $ map (\(_,cnt,_,_)->length cnt) tups
        mth'width = maximum $ map (\(_,_,mth,_)->length mth) tups
    return $ do -- List monad.
        (stat,cnt,meth,nid) <- tups
        printf "  %c %-*s %-*s %s\n" stat cnt'width cnt mth'width meth nid

forkSearch ::
    ( Ord nid
    , Hashable nid
    , Ord ni
    , Hashable ni
    , Show nid
    ) =>
    String
    -> nid
    -> DHTQuery nid ni
    -> TVar (Map.Map (String,nid) (DHTSearch nid ni))
    -> TVar (BucketList ni)
    -> ThreadId
    -> TVar (Maybe (IO ()))
    -> STM ()
forkSearch method nid DHTQuery{qsearch,qshowTok,qshowR} dhtSearches dhtBuckets  tid kvar = do
    ns <- R.kclosest (searchSpace qsearch) searchK nid <$> readTVar dhtBuckets
    st <- newSearch qsearch nid ns
    results <- newTVar Set.empty
    let storeResult r = modifyTVar' results (Set.insert (qshowR r))
                        >> return True
        new = DHTSearch
            { searchThread  = tid
            , searchState   = st
            , searchShowTok = qshowTok
            , searchResults = results
            }
    modifyTVar' dhtSearches $ Map.insert (method,nid) new
    -- Finally, we write the search loop action into a tvar that will be executed in a new
    -- thread.
    writeTVar kvar $ Just $ searchLoop qsearch nid storeResult st

reportSearchResults :: (Show t, Ord t1, Ord t, Hashable t) =>
                                   String -> ClientHandle -> DHTSearch t1 t -> IO ()
reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} = do
    (ns,rs) <- atomically $ do
        mm <- readTVar $ searchInformant searchState
        rset <- readTVar searchResults
        let ns = map (\(MM.Binding ni tok _) -> (ni,tok))
                     $ MM.toList mm
            rs = Set.toList rset
        return (ns,rs)
    let n'width       = succ $ maximum $ map (length . show . fst) ns
        showN (n,tok) = take n'width (show n ++ repeat ' ') ++ (fromMaybe "" $ searchShowTok =<< tok)
        ns'           = map showN ns
    reportResult meth id (const Nothing) id h (Right (ns',rs, Just ()))

data ConnectionManager = forall status k. ConnectionManager { typedManager :: Connection.Manager status k }

data Session = Session
    { netname           :: String
    , selectedKey       :: Maybe PublicKey
    , dhts              :: Map.Map String DHT
    , externalAddresses :: IO [SockAddr]
    , swarms            :: Mainline.SwarmsDatabase
    , cryptosessions    :: Tox.NetCryptoSessions
    , toxkeys           :: TVar Tox.AnnouncedKeys
    , roster            :: Tox.ContactInfo JabberClients
    , announceToLan     :: IO ()
    , connectionManager :: Maybe ConnectionManager
    , onionRouter       :: OnionRouter
    , announcer         :: Announcer
    , signalQuit        :: IO ()
    , mbTox             :: Maybe (Tox.Tox JabberClients)
    }

exceptionsToClient :: ClientHandle -> IO () -> IO ()
exceptionsToClient (ClientHandle h hstate) action =
    action `catch` \(SomeException e) -> do
                        st <- takeMVar hstate
                        when (st /= 1) $ do
                            hPutStr h ('.': marshalForClient (show e))
                        putMVar hstate 1 -- ready for input

hGetClientLine :: ClientHandle -> IO String
hGetClientLine (ClientHandle h hstate) = do
    st <- takeMVar hstate
    -- st should be 1
    x <- hGetLine h
    putMVar hstate 0 -- ready for output
    return x

hCloseClient :: ClientHandle -> IO ()
hCloseClient (ClientHandle h hstate) = do
    st <- takeMVar hstate
    hClose h
    putMVar hstate 3 -- closed file handle

clientSession0 :: Session -> t1 -> t -> Handle -> IO ()
clientSession0 s sock cnum h = do
    hstate <- newMVar 1 -- ready for input
    clientSession s sock cnum (ClientHandle h hstate)
  `catch` \e -> if isEOFError e then return ()
                                else throwIO e


parseDebugTag :: String -> Maybe DebugTag
parseDebugTag s' = readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s')

showPolicy TryingToConnect   = "*"
showPolicy OpenToConnect     = "o"
showPolicy RefusingToConnect = "x"

clientSession :: Session -> t1 -> t -> ClientHandle -> IO ()
clientSession s@Session{..} sock cnum h = do
    line <- dropWhile isSpace <$> hGetClientLine h
    let (c,args) = second (dropWhile isSpace) $ break isSpace line
        cmd0 :: IO () -> IO ()
        cmd0 action = exceptionsToClient h action >> clientSession s sock cnum h
        switchNetwork dest = do hPutClient h ("Network: "++dest)
                                clientSession s{netname=dest} sock cnum h
        switchKey key = clientSession s { selectedKey = key } sock cnum h
        twoWords str = let (word1,a1) = break isSpace (dropWhile isSpace str)
                           (word2,a2) = break isSpace (dropWhile isSpace a1)
                           in (word1,word2,drop 1 a2)
        strp = B.unpack . fst . until snd dropEnd . (,False) . B.dropWhile isSpace . B.pack
            where
                dropEnd (x,_) =
                    case B.unsnoc x of
                                 Just (str,c) | isSpace c -> (str,False)
                                 _ -> (x,True)
        allDebugTags = [minBound .. maxBound]
        showDebugTags = do
                vs <- mapM getVerbose allDebugTags
                let f True = "v"
                    f False = "-"
                hPutClient h $ showReport (zip (map (drop 1 . show) allDebugTags) (map f vs))
    let readHex :: (Read n, Integral n) => String -> Maybe n
        readHex s = readMaybe ("0x" ++ s)
        strToSession :: String -> IO (Either String Tox.NetCryptoSession)
        strToSession idStr
          = case readHex idStr of
                Nothing -> return (Left "Unable to parse session id")
                Just id -> do
                    sessions <- filter ((==id) . Tox.ncSessionId)
                              . concat
                              . Map.elems <$> (atomically $ readTVar (Tox.netCryptoSessionsByKey cryptosessions))
                    case sessions of
                        []     -> return (Left "Session not found")
                        (x:xs) -> return (Right x)
    let mkrow :: (SecretKey, PublicKey) -> (String,String)
        mkrow (a,b) | Just x <- encodeSecret a= (B.unpack x, show (Tox.key2id b))
        mkrow _ = error (concat ["Assertion fail in 'mkrow' function at ", __FILE__, ":", show __LINE__])
        sessionCommands :: [[String]]
        sessionCommands =
            [ ["ping"]   -- pinglike
            , ["cookie"] -- pinglike
            , ["stop"]
            , ["throw"]
            , ["quit"]
            , ["pid"]
            , ["external-ip"]
            , ["threads"]
            , ["mem"]
            , ["nid"]
            , ["lan"]
            , ["ls"]
            , ["k"]
            , ["roster"]
            , ["sessions"]
            , ["session"]
            , ["netcrypto"]
            , ["onion"]
            , ["g"]
            , ["p"]
            , ["a"]
            , ["s"]
            , ["x"]
            , ["save"]
            , ["load"]
            , ["swarms"]
            , ["peers"]
            , ["toxids"]
            , ["c"]
            , ["quiet"]
            , ["verbose"]
            , ["help"]
            ]
    case (map toLower c,args) of
        (n, _) | n `elem` Map.keys dhts -> switchNetwork n
        -- "ping"
        -- "cookie"
        (pinglike, s) | Just DHT{dhtPing} <- Map.lookup netname dhts
                      , Just DHTPing{ pingQuery=ping
                                    , pingShowResult=showr } <- Map.lookup pinglike dhtPing
                      , ws@(_:_) <- words s
                    -> cmd0 $ do
                        case readEither $ last ws of
                          Right addr -> do result <- ping (init ws) addr
                                           let rs = [" ", maybe "Timeout." showr result]
                                           hPutClient h $ unlines rs
                          Left er -> hPutClient h er
        (x,_) | not (null (strp x))
              , x `notElem` map head sessionCommands -> cmd0 $ do
                hPutClient h $ "error."

        ("stop", _) -> do hPutClient h "Terminating DHT Daemon."
                          hCloseClient h
                          signalQuit

        ("throw", er) -> cmd0 $ do
                            throwIO $ userError er
                            hPutClient h "The impossible happened!"

        ("quit", _) -> hPutClient h "" >> hCloseClient h

        ("pid", _) -> cmd0 $ do
                    pid <- getProcessID
                    hPutClient h (show pid)
        ("external-ip", _) -> cmd0 $ do
                    unlines . map (either show show . either4or6) <$> externalAddresses
                        >>= hPutClient h
#ifdef THREAD_DEBUG
        ("threads", s) -> cmd0 $ do
                    let want_ss = ["-v"] `isInfixOf` words s
                    r <- threadReport want_ss
                    hPutClient h r
#endif
        ("mem", s) -> cmd0 $ do
                    case s of
                        "gc" -> do hPutClient h "Performing garbage collection..."
                                   performMajorGC
                        "" -> do
#if MIN_VERSION_base(4,10,1)
                            is_enabled <- getRTSStatsEnabled
#else
                            is_enabled <- getGCStatsEnabled
#endif
                            if is_enabled
                             then do
#if MIN_VERSION_base(4,10,1)
                                RTSStats{..} <- getRTSStats
                                let r = [ ("bytesAllocated", show allocated_bytes)
                                        , ("numGcs", show gcs)
                                        , ("maxBytesUsed", show max_live_bytes)
                                        --, ("numByteUsageSamples", show numByteUsageSamples)
                                        , ("cumulativeBytesUsed", show cumulative_live_bytes)
                                        , ("bytesCopied", show copied_bytes)
                                        , ("currentBytesUsed", show allocated_bytes)
                                        --, ("currentBytesSlop", show currentBytesSlop)
                                        , ("maxBytesSlop", show max_slop_bytes)
                                        -- , ("peakMegabytesAllocated", show peakMegabytesAllocated)
                                        , ("mutatorCpuNanoseconds", show mutator_cpu_ns)
                                        , ("mutatorWallNanoseconds", show mutator_elapsed_ns)
                                        , ("gcCpuSeconds", show gc_cpu_ns)
                                        , ("gcWallSeconds", show gc_elapsed_ns)
                                        , ("cpuSeconds", show cpu_ns)
                                        , ("wallSeconds", show elapsed_ns)
                                        , ("parTotBytesCopied", show par_copied_bytes)
                                        , ("parMaxBytesCopied", show cumulative_par_max_copied_bytes)
#else
                                GCStats{..} <- getGCStats
                                let r = [ ("bytesAllocated", show bytesAllocated)
                                        , ("numGcs", show numGcs)
                                        , ("maxBytesUsed", show maxBytesUsed)
                                        , ("numByteUsageSamples", show numByteUsageSamples)
                                        , ("cumulativeBytesUsed", show cumulativeBytesUsed)
                                        , ("bytesCopied", show bytesCopied)
                                        , ("currentBytesUsed", show currentBytesUsed)
                                        , ("currentBytesSlop", show currentBytesSlop)
                                        , ("maxBytesSlop", show maxBytesSlop)
                                        , ("peakMegabytesAllocated", show peakMegabytesAllocated)
                                        , ("mutatorCpuSeconds", show mutatorCpuSeconds)
                                        , ("mutatorWallSeconds", show mutatorWallSeconds)
                                        , ("gcCpuSeconds", show gcCpuSeconds)
                                        , ("gcWallSeconds", show gcWallSeconds)
                                        , ("cpuSeconds", show cpuSeconds)
                                        , ("wallSeconds", show wallSeconds)
                                        , ("parTotBytesCopied", show parTotBytesCopied)
                                        , ("parMaxBytesCopied", show parMaxBytesCopied)
#endif
                                        ]
                                hPutClient h $ showReport r
                            else hPutClient h "Run with +RTS -T to obtain live memory-usage information."
                        _ -> hPutClient h "error."

        ("nid", s) | Just DHT{dhtParseId} <- Map.lookup netname dhts
                    -> cmd0 $ do
                        hPutClient h $ case dhtParseId s of
                            Left e    ->
                                -- HACK: split nospam from hex toxid
                                case dhtParseId (take 64 s) of
                                    Left e -> case Tox.parseNoSpamId $ T.pack s of
                                                Left ej -> if elem '@' s
                                                            then "Error: " ++ ej
                                                            else "Error: " ++ e
                                                Right jid -> unlines [ show jid
                                                                     , Tox.noSpamIdToHex jid ]
                                    Right nid -> let nspam = drop 64 s
                                                     jid :: Maybe Tox.NoSpamId
                                                     jid = readMaybe $ '0':'x':nspam ++ "@" ++ show nid ++ ".tox"
                                                 in unlines [ maybe "" show jid
                                                            , show nid ++ " nospam:" ++ nspam ]
                            Right nid -> show nid

        ("lan", _)  -> cmd0 $ do
                        announceToLan
                        hPutClient h "ok"

        ("ls", _) | Just DHT{dhtBuckets} <- Map.lookup netname dhts
                    -> cmd0 $ do
                        bkts <- atomically $ readTVar dhtBuckets
                        let r = reportTable bkts
                        hPutClient h $
                            showReport $
                                    r ++ [ ("buckets", show $ R.shape bkts)
                                         , ("node-id", show $ thisNode bkts)
                                         , ("network", netname) ]

        --  TODO: online documentation.
        --
        --  k - manage key-pairs
        --
        --      k                  (list keys)
        --      k gen              (generate new key and list keys)
        --      k add <secret-key> (input a specific secret key)
        --      k del <secret-key>
        --      k secrets          (list key pairs, including secret keys)

        ("k", s) | ""           <- strp s -> cmd0 $ do
                        ks <- atomically $ myKeyPairs roster
                        let spaces k | Just sel <- selectedKey, (sel == k) = " *"
                                     | otherwise                           = "  "
                        hPutClient h $ unlines $ map (\(_,k) -> mappend (spaces k) . show . Tox.key2id $ k) ks
                 | "gen"        <- strp s -> do
                        secret <- generateSecretKey
                        let pubkey = toPublic secret
                        oldks <- atomically $ do
                            ks <- myKeyPairs roster
                            Tox.addContactInfo roster secret Map.empty
                            return ks
                        let asString = show . Tox.key2id
                        hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) oldks
                                                  ++ [mappend " *" . show . Tox.key2id $ pubkey]
                        switchKey $ Just pubkey
                 | "secrets"    <- strp s -> cmd0 $ do
                        ks <- atomically $ myKeyPairs roster
                        skey <- maybe (return Nothing) (atomically . dhtSecretKey)
                                      $ Map.lookup netname dhts
                        hPutClient h . showReport $ (map mkrow ks ++) $ fromMaybe [] $ do
                            sk <- skey
                            let pk = Tox.key2id $ toPublic sk
                            x <- encodeSecret sk
                            Just [("",""),("dht-key:",""),(B.unpack x, show pk)]
                 | ("sel",_:expr) <- break isSpace s -> do
                         ks <- atomically $ map (show . Tox.key2id . snd) <$> myKeyPairs roster
                         case find (isInfixOf expr) ks of
                            Just k -> do
                                hPutClient h $ "Selected key: "++k
                                switchKey $ Just $ Tox.id2key $ read k
                            Nothing -> cmd0 $ hPutClient h "no match."
                 | ("add":secs) <- words s
                 , mbSecs <- map (decodeSecret . B.pack) secs
                 , all isJust mbSecs -> do
                        let f (Just b) = b
                            f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
                        let toPair x = (x,toPublic x)
                            pairs = map (toPair . f) mbSecs
                        oldks <- atomically $ do
                            oldks <- myKeyPairs roster
                            forM pairs $ \(sk,_) -> Tox.addContactInfo roster sk Map.empty
                            return oldks
                        hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) oldks
                                                  ++ map (mappend " *" . show . Tox.key2id .snd) pairs
                        switchKey $ listToMaybe $ map snd pairs
                 | ("del":secs) <- words s
                 , mbSecs <- map (decodeSecret . B.pack) secs
                 , all isJust mbSecs -> do
                        let f (Just b) = b
                            f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
                        let toPair x = (x,toPublic x)
                            pairs = map (toPair . f) mbSecs
                        ks <- atomically $ do
                            forM pairs $ \(_,pk) -> Tox.delContactInfo roster pk
                            myKeyPairs roster
                        hPutClient h . showReport $ map mkrow ks
                        switchKey $ do
                            k <- selectedKey
                            guard $ k `notElem` map snd pairs
                            Just k

        ("roster", s) -> cmd0 $ join $ atomically $ do
            let ContactInfo{accounts} = roster
                nosummary = not (null s)
            as <- readTVar accounts
            css <- forM as $ \acnt -> do
                    cs <- readTVar (contacts acnt)
                    forM cs $ \c -> do
                        ck <- readTVar $ contactKeyPacket c
                        ca <- readTVar $ contactLastSeenAddr c
                        cf <- readTVar $ contactFriendRequest c
                        cp <- readTVar $ contactPolicy c
                        let summarizeNodeId | nosummary = id
                                            | otherwise = take 6
                            summarizeAddr | nosummary = id
                                          | otherwise = reverse . take 20 . reverse
                        return $ [ maybe "/" showPolicy cp
                                 , maybe "" (summarizeNodeId . show . Tox.key2id . Tox.dhtpk . snd) ck
                                 , maybe "" (summarizeAddr . show . snd) ca
                                 , maybe "" (show . T.decodeUtf8 . Tox.friendRequestText . snd) cf
                                 ]
            return $ do
                forM_ (HashMap.toList css) $ \(me,xss) -> do
                    let cs = map (\(toxid,xs) -> show toxid : xs)
                                 $ HashMap.toList xss
                    hPutClientChunk h $ unlines [ show me, map (const '-') (show me) ]
                    hPutClientChunk h $ showColumns $ ["ToxID","","NodeID","Address","FR text"]
                                                      : cs
                hPutClient h ""

        ("quiet",s) | s' <- strp s
                    , Just (tag::DebugTag) <- parseDebugTag s'
                    -> cmd0 $ do
                setQuiet tag
                hPutClient h $ "Suppressing " ++ show tag ++ " messages."

        ("quiet",s) | "all" <- strp s
                    -> cmd0 $ do
                mapM_ setQuiet allDebugTags
                showDebugTags

        (verbose,s) | "" <- strp s
                    , verbose `elem` ["verbose","quiet"]
                    -> cmd0 $ showDebugTags

        ("verbose",s) | "all" <- strp s
                    -> cmd0 $ do
                mapM_ setVerbose allDebugTags
                showDebugTags

        ("verbose",s) | s' <- strp s
                    , Just (tag::DebugTag) <- parseDebugTag s'
                    -> cmd0 $ do
                setVerbose tag
                hPutClient h $ "Showing " ++ show tag ++ " messages."

        -- list information about current netcrypto sesssions
        ("sessions", s) | "" <- strp s
            -> cmd0 $ do
                sessions <- concat . Map.elems <$> (atomically $ readTVar (Tox.netCryptoSessionsByKey cryptosessions))
                let sessionsReport = mapM showPerSession sessions
                    headers = ["SessionID", "YourKey", "TheirKey", "Address", "NextMsg", "Dropped" {-,"Handled","Unhandled" -}
                              ,"Progress" ]
                    showPerSession (Tox.NCrypto
                                        { ncState = progressVar
                                        , ncSessionId = id
                                        , ncMyPublicKey = yourkey
                                        , ncTheirPublicKey = theirkey
                                        , ncLastNMsgs = lastN
                                        , ncSockAddr = sockAddr
                                        }) = do
                        progress <- atomically $ readTVar progressVar
                        (num,dropped) <- atomically $ liftA2 (,) (CB.getTotal lastN) (CB.getDropped lastN)
                        as <- atomically (CB.cyclicBufferViewList lastN)
                        let (h,u) = partition (fst . snd) as
                            countHandled   = length h
                            countUnhandled = length u
                        return [ printf "%x" id           -- "SessionID"
                               , take 8 $ show (Tox.key2id yourkey) -- "YourKey"
                               , show (Tox.key2id theirkey)-- "TheirKey"
                               , drop 11 $ show sockAddr  -- "Address"
                               , show num                 -- "NextMsg"
                               , show dropped             -- "Dropped"
                            -- , show countHandled        -- "Handled"
                            -- , show countUnhandled      -- "Unhandled"
                               , show progress
                               ]
                if null sessions
                 then hPutClient h "No sessions."
                 else do
                    rows <- sessionsReport
                    hPutClient h (showColumns (headers:rows))
        -- session <N> set key val
        ("session",s) | (idStr,"set",unstripped) <- twoWords s
                      , (key,val,unstripped2) <- twoWords unstripped
                      , let setmap = [("ncRequestInterval", \s x -> writeTVar (Tox.ncRequestInterval s) x)
                                     ,("ncAliveInterval", \s x -> writeTVar (Tox.ncAliveInterval s) x)
                                     ,("ncIdleEvent", \s x -> writeTVar (Tox.ncIdleEvent s) x)
                                     ,("ncTimeOut", \s x -> writeTVar (Tox.ncTimeOut s) x)
                                     ]
                      , Just stmFunc <- Data.List.lookup key setmap
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case readMaybe val of
                                        Just (x::Int) -> do
                                            atomically (stmFunc session x)
                                            hPutClient h $ "Session " ++ idStr ++ ": " ++ key ++ " = " ++ val
                                        _ -> 
                                            hPutClient h $ "Invalid " ++ key ++ " value: " ++ val

        -- session <N> interval factor
        ("session",s) | (idStr,"interval",unstripped) <- twoWords s
                      , val <- strp unstripped
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            let displayIntervals session = atomically $ do
                                intervals <- forM [Tox.ncRequestInterval,Tox.ncAliveInterval, Tox.ncIdleEvent, Tox.ncTimeOut] $ \i -> readTVar (i session)
                                let keys = ["ncRequestInterval","ncAliveInterval","ncIdleEvent","ncTimeOut"]
                                return (intercalate "\n" $
                                            map (\(key,val) -> "Session " ++ idStr ++ ": " ++ key ++ " = " ++ val)
                                                (zip keys (map show intervals)))
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case readMaybe val of
                                        Just (factor::Double) -> do
                                             atomically $ do
                                                modifyTVar (Tox.ncRequestInterval session) (round . (*factor) . fromIntegral)
                                                modifyTVar (Tox.ncAliveInterval session) (round . (*factor) . fromIntegral)
                                                modifyTVar (Tox.ncIdleEvent session) (round . (*factor) . fromIntegral)
                                                modifyTVar (Tox.ncTimeOut session) (round . (*factor) . fromIntegral)
                                             displayIntervals session >>= hPutClient h
                                        _ -> displayIntervals session >>= hPutClient h . (("No parse (" ++ show val ++ ").\n") ++)

        -- report error when setting invalid keys
        ("session",s) | (idStr,"set",unstripped) <- twoWords s
                      , (key,val,unstripped2) <- twoWords unstripped
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> hPutClient h $ "What is " ++ key ++ "?"
        -- session <N> tail
        -- show context (latest lossless messages)
        ("session", s) | (idStr,tailcmd,unstripped) <- twoWords s
                        , "" <- strp unstripped
                        , tailcmd `elem` ["tail","context"]
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                     msgs <- atomically $ CB.cyclicBufferViewList (Tox.ncLastNMsgs session)
                                     hPutClientB h (B.unlines (map showMsg msgs))
        -- session <N> me
        -- display information about how you look to that session
        ("session", s) | (idStr,"me",unstripped) <- twoWords s
                        , "" <- strp unstripped
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                     view <- atomically (readTVar (Tox.ncView session) >>= Tox.viewSnapshot)
                                     hPutClientB h (vShowMe view 0)
        -- session <N> them
        -- display information about the person on the other end of the session
        ("session", s) | (idStr,them,unstripped) <- twoWords s
                        , "" <- strp unstripped
                        , them `elem` ["them","you"]
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                     view <- atomically (readTVar (Tox.ncView session) >>= Tox.viewSnapshot)
                                     hPutClientB h (vShowThem view 0)
        -- session <N> online
        -- send ONLINE packet to session N
        ("session", s) | (idStr,"online",unstripped) <- twoWords s
                        , stripped <- strp unstripped
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case mbTox of
                                        Nothing -> hPutClient h "Requires Tox enabled."
                                        Just tox-> do
                                            Tox.sendOnline (Tox.toxCryptoKeys tox) session
                                            hPutClient h "sent ONLINE"
        -- session <N> online
        -- send OFFLINE packet to session N
        ("session", s) | (idStr,"offline",unstripped) <- twoWords s
                        , stripped <- strp unstripped
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case mbTox of
                                        Nothing -> hPutClient h "Requires Tox enabled."
                                        Just tox-> do
                                            Tox.sendOffline (Tox.toxCryptoKeys tox) session
                                            hPutClient h "sent OFFLINE"
        -- session <N> kill
        -- send KILL packet to session N
        ("session", s) | (idStr,"kill",unstripped) <- twoWords s
                        , stripped <- strp unstripped
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case mbTox of
                                        Nothing -> hPutClient h "Requires Tox enabled."
                                        Just tox-> do
                                            Tox.sendKill (Tox.toxCryptoKeys tox) session
                                            hPutClient h "sent KillPacket"
        -- session <N> nick <NICKNAME>
        -- send NICK packet to session N, setting nick to NICKNAME
        ("session", s) | (idStr,"nick",unstripped) <- twoWords s
                        , nick <- strp unstripped
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case mbTox of
                                        Nothing -> hPutClient h "Requires Tox enabled."
                                        Just tox-> do
                                            Tox.setNick (Tox.toxCryptoKeys tox) session (B.pack nick)
                                            hPutClient h "sent NICKNAME"
        -- session <N> status <STATUS>
        -- send USERSTATUS packet to session N, set status to STATUS
        ("session", s) | (idStr,"status",unstripped) <- twoWords s
                        , statusStr  <- strp unstripped
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case mbTox of
                                        Nothing -> hPutClient h "Requires Tox enabled."
                                        Just tox-> do
                                            case readMaybe statusStr of
                                                Nothing -> hPutClient h "Unable to parse status"
                                                Just status -> do
                                                    Tox.setStatus (Tox.toxCryptoKeys tox) session status
                                                    hPutClient h "sent USERSTATUS"
        -- session <N> typing <TYPINGSTATUS>
        -- send TYPING packet to session N, set typing to TYPINGSTATUS
        ("session", s) | (idStr,"typing",unstripped) <- twoWords s
                        , typingstatus <- strp unstripped
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case mbTox of
                                        Nothing -> hPutClient h "Requires Tox enabled."
                                        Just tox-> do
                                            case readMaybe typingstatus of
                                                Nothing -> hPutClient h "Unable to parse status"
                                                Just status -> do
                                                    Tox.setTyping (Tox.toxCryptoKeys tox) session status
                                                    hPutClient h "sent TYPINGSTATUS"
        -- session <N> statusmsg <MSG>
        -- send STATUSMESSAGE packet to session N, setting status message to MSG
        ("session", s) | (idStr,"statusmsg",statusmsg) <- twoWords s
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case mbTox of
                                        Nothing -> hPutClient h "Requires Tox enabled."
                                        Just tox-> do
                                            Tox.setStatusMsg (Tox.toxCryptoKeys tox) session (B.pack statusmsg)
                                            hPutClient h "sent STATUSMESSAGE"
        -- session <N> c <MSG>
        -- send MESSAGE packet to session N (send chat message MSG)
        ("session", s) | (idStr,msgcmd,msg) <- twoWords s
                        , msgcmd `elem` ["c","msg","send"]
                        -> cmd0 $ do
                            lrSession <- strToSession idStr
                            case lrSession of
                                Left s -> hPutClient h s
                                Right session -> do
                                    case mbTox of
                                        Nothing -> hPutClient h "Requires Tox enabled."
                                        Just tox-> do
                                            Tox.sendChatMsg (Tox.toxCryptoKeys tox) session (B.pack msg)
                                            hPutClient h "sent MESSAGE"

        ("onion", s) -> cmd0 $ do
            now <- getPOSIXTime
            join $ atomically $ do
            rm <- IntMap.fromList . catMaybes . map (\(i,m) -> fmap (i,) m) <$> getAssocs (routeMap onionRouter)
            ts <- readTVar $ trampolineNodes onionRouter
            tcnt <- readTVar $ trampolineCount onionRouter
            icnt <- HashMap.size <$> readTVar (trampolineIds onionRouter)
            rs <- getAssocs (pendingRoutes onionRouter)
            pqs <- readTVar (pendingQueries onionRouter)
            let showRecord :: Int -> Int -> [String]
                showRecord n wanted_ver
                    | Just RouteRecord{responseCount,timeoutCount,routeVersion,routeBirthTime} <- IntMap.lookup n rm
                                = [ show n, show responseCount, show timeoutCount, show (now-routeBirthTime)
                                  , if routeVersion >= wanted_ver
                                     then show routeVersion
                                     else show routeVersion ++ "(pending)" ]
                    | otherwise = [show n, "error!","","",""]
                r = map (uncurry showRecord) rs
            return $ do
                hPutClientChunk h $ unlines [ "trampolines: " ++ show (IntMap.size ts,tcnt,icnt)
                                            , "pending: " ++ show (W64.size pqs) ]
                hPutClient h $ showColumns $ ["","responses","timeouts", "age", "version"]:r

        -- necrypto <FRIEND-TOXID>
        -- establish a netcrypto session with specified person
        ("netcrypto", s) -> cmd0 $ do
            let exes = Map.fromList [("atox",("/usr/bin/tmux -c","atox"))]
            netcrypto (Map.lookup netname dhts) selectedKey h roster mbTox exes (strp s)
        ("g", s) | Just DHT{..} <- Map.lookup netname dhts
                    -> cmd0 $ do
                        -- arguments: method
                        --            nid
                        --            (optional dest-ni)
                        self <- atomically $ thisNode <$> readTVar dhtBuckets
                        let (method,xs) = break isSpace $ dropWhile isSpace s
                            (nidstr,ys) = break isSpace $ dropWhile isSpace xs
                            destination = dropWhile isSpace ys
                            goQuery qry = either (hPutClient h . ("Bad search target: "++))
                                                 (goTarget qry)
                                                 $ dhtParseId nidstr
                            goTarget DHTQuery{..} nid =
                                go nid >>= reportResult method qshowR qshowTok show h
                              where
                                go | null destination = fmap Right . qhandler self
                                   | otherwise        = case readEither destination of
                                        Right ni -> fmap (maybe (Left "Timeout.") Right)
                                                    . flip (searchQuery qsearch) ni
                                        Left  e  -> const $ return $ Left ("Bad destination: "++e)
                        maybe (hPutClient h ("Unsupported method: "++method))
                              goQuery
                              $ Map.lookup method dhtQuery

        -- TODO: Online help.
        --
        -- p - put/publish a single given datum on a single given node.
        --
        --         When destination address (node-addr) is optional, it's absense means to
        --         publish information in the local node's own database.
        --
        --         Bittorrent: (peer) publish yourself as peer in swarm.
        --                     (port) set your current bittorrent listen port.
        --
        --             p peer <infohash> <token> [node-addr]
        --
        --             p port <num>
        --
        --         Tox: (toxid) publish a rendezvous onion route to dht node.
        --              (friend) send a friend-request over a rendezvous point.
        --              (dhtkey) send your dht node-id over a rendezvous point.
        --
        --             p toxid <key> <token> <node-addr>
        --
        --             p friend <nospamid> <rendezvous-addr> <text>
        --
        --             p dhtkey <key> <rendezvous-addr>

        ("p", s) | Just DHT{..} <- Map.lookup netname dhts
                    -> cmd0 $ do
                        -- arguments:  Left                  Right
                        --             ----                  -----
                        --             method                method
                        --             data (jid or key)     data
                        --             dest-rendezvous(r)    token
                        --             (optional extra-text) (optional dest-ni)
                        self <- atomically $ thisNode <$> readTVar dhtBuckets
                        let (method,xs) = break isSpace $ dropWhile isSpace s
                            (dtastr,ys) = break isSpace $ dropWhile isSpace xs
                            (tokenstr,zs) = break isSpace $ dropWhile isSpace ys
                            destination = dropWhile isSpace zs
                            goTarget DHTAnnouncable{..} | Right asend <- announceSendData = do
                                let dta = announceParseData dtastr
                                    tok = dta >>= flip announceParseToken tokenstr
                                case liftA2 (,) dta tok of
                                    Left e    -> hPutClient h e
                                    Right nid -> go asend nid >>= either (hPutClient h) (hPutClient h . show)
                              where
                                go asend | null destination = fmap (maybe (Left "Timeout.") Right)
                                                              . flip (uncurry asend) Nothing
                                         | otherwise        = case announceParseAddress destination of
                                            Right ni -> fmap (maybe (Left "Timeout.") Right)
                                                        . flip (uncurry asend) (Just ni)
                                            Left  e  -> const $ return $ Left ("Bad destination: "++e)
                            goTarget DHTAnnouncable{..} | Left (searchName,parseResult,asend) <- announceSendData = do
                                either (hPutClient h) id $ do
                                    dta <- announceParseData $ unwords [dtastr,destination]
                                    r   <- parseResult tokenstr
                                    return $ case selectedKey of
                                        Nothing -> hPutClient h "Missing secret user-key."
                                        Just k  -> do
                                            asend k dta r
                                            hPutClient h "Sent."
                        maybe (hPutClient h ("Unsupported method: "++method))
                              goTarget
                              $ Map.lookup method dhtAnnouncables

        -- TODO: Online documentation.
        --
        -- a - announce, like put/publish but automatically selects nodes to publish on
        --     and periodically refreshes them.
        --
        --     The method name is preceded with a + to start or a - to stop a given
        --     recurring publication.
        --
        --     BitTorrent: (peer) Every minute, announce you are participating
        --                        in a torrent swarm.
        --
        --         a +peer <infohash> a -peer <infohash>
        --
        --     Tox: (toxid) Every 15 seconds, announce your tox identity to the
        --                  DHT so friends can find you.
        --
        --         a +toxid <key>
        --         a -toxid <key>
        --
        --         a +friend <jid> <text>
        --         a +dhtkey <key>
        ("a", "") -> cmd0 $ do
                        now <- getPOSIXTime
                        rs <- atomically $ do
                            as <- scheduleToList announcer
                            forM (as) $ \(k,ptm,item) -> do
                                let kstr = unpackAnnounceKey announcer k
                                return [ if ptm==0 then "now"
                                                   else show (ptm - now)
                                       , show (itemStatusNum item)
                                       , kstr
                                       ]
                        hPutClient h $ showColumns rs
        ("a", s) | Just DHT{..} <- Map.lookup netname dhts
                 , not (null s)
                    -> cmd0 $ do
                        let (op:method,xs) = break isSpace $ dropWhile isSpace s
                            dtastr         = dropWhile isSpace xs

                            a = Map.lookup method dhtAnnouncables
                            q = do DHTAnnouncable { announceSendData } <- a
                                   Map.lookup (either (\(search,_,_)->search)
                                                      (const method)
                                                      announceSendData)
                                              dhtQuery
                            doitR :: Char -> Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
                            doitR '+' = scheduleAnnounce
                            doitR '-' = \a k _ _ -> cancel a k
                            doitR _   = \_ _ _ _ -> hPutClientChunk h "Starting(+) or canceling(-)?"
                            doitL :: Char -> Announcer -> AnnounceKey -> SearchMethod r -> r -> IO ()
                            doitL '+' = scheduleSearch
                            doitL '-' = \a k _ _ -> cancel a k
                            doitL _   = \_ _ _ _ -> hPutClientChunk h "Starting(+) or canceling(-)?"
                            matchingResult ::
                                ( Typeable stok
                                , Typeable ptok
                                , Typeable sni
                                , Typeable pni )
                                            => Search nid addr stok sni sr
                                            -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr))
                                            -> Maybe (stok :~: ptok, sni :~: pni)
                            matchingResult _ _ = liftA2 (,) eqT eqT
                            matchingResult2 ::
                                ( Typeable sr
                                , Typeable pr )
                                            => Search nid addr stok sni sr
                                            -> (PublicKey -> pdta -> pr -> IO ())
                                            -> (pdta -> nid)
                                            -> Maybe (pr :~: sr)
                            matchingResult2 _ _ _ = eqT
                            reportit target = case op of
                                        '+' -> hPutClient h $ "Announcing at " ++ target ++ "."
                                        '-' -> hPutClient h $ "Canceling " ++ target ++ "."
                            -- mameth is for typical kademlia announce.
                            mameth = do
                                DHTAnnouncable { announceSendData
                                               , announceParseData
                                               , announceInterval
                                               , announceTarget } <- a
                                DHTQuery { qsearch } <- q
                                asend <- either (const Nothing) Just announceSendData
                                (Refl, Refl) <- matchingResult qsearch asend
                                -- return $ hPutClient h "Type matches."
                                dta <- either (const Nothing) Just $ announceParseData dtastr
                                return $ do
                                    let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr)
                                    doitR op announcer
                                            akey
                                            (AnnounceMethod qsearch asend
                                                            (\nid -> R.kclosest (searchSpace qsearch)
                                                                                searchK
                                                                                nid
                                                                     <$> readTVar dhtBuckets)
                                                            (announceTarget dta)
                                                            announceInterval)
                                            dta
                                    reportit $ show $ announceTarget dta
                            -- lmeth is for atypical announce messages such as
                            --   Tox dht-key and friend-request messages.
                            lmeth :: Maybe (IO ())
                            lmeth = do
                                DHTAnnouncable { announceSendData
                                               , announceParseData
                                               , announceInterval
                                               , announceTarget } <- a
                                DHTQuery { qsearch } <- q
                                (_,_,asend) <- either Just (const Nothing) announceSendData
                                Refl <- matchingResult2 qsearch asend announceTarget
                                dta <- either (const Nothing) Just $ announceParseData dtastr
                                pub <- selectedKey
                                return $ do
                                    let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr)
                                    doitL op announcer
                                            akey
                                            (SearchMethod qsearch (asend pub)
                                                            (\nid -> R.kclosest (searchSpace qsearch)
                                                                                searchK
                                                                                nid
                                                                     <$> readTVar dhtBuckets)
                                                            (announceTarget dta)
                                                            announceInterval)
                                            dta
                                    reportit $ show $ announceTarget dta
                            ptest = fromMaybe "E:NoMethod"
                                        $ fmap (\DHTAnnouncable { announceParseData
                                                                , announceTarget }
                                                  -> either ("E:"++) (show . announceTarget)
                                                          $ announceParseData dtastr)
                                               a

                        let aerror = unlines
                                [ "announce error."
                                , "method = " ++ method
                                , "query = " ++ maybe "nil" (const "ok") q
                                , "publish = " ++ maybe "nil" (const "ok") a
                                -- , "chktok = " ++ maybe "nil" (const "ok") chktok -- chktok = nil
                                -- , "chkni = " ++ maybe "nil" (const "ok") chkni
                                , "ptest = " ++ ptest
                                , "mameth = " ++ show (fmap (const ()) mameth)
                                , "lmeth  = " ++ show (fmap (const ()) lmeth)
                                , "selectedKey = " ++ show selectedKey
                                ]
                        fromMaybe (hPutClient h aerror) $ mameth <|> lmeth

        ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts
                    -> cmd0 $ do
                        let (method,xs) = break isSpace s
                            (nidstr,ys) = break isSpace $ dropWhile isSpace xs
                            presentSearches = hPutClient h
                                              =<< showSearches
                                              =<< atomically (readTVar dhtSearches)
                            goTarget qry nid = do
                                kvar <- atomically $ newTVar Nothing
                                -- Forking a thread, but it may ubruptly quit if the following
                                -- STM action decides not to add a new search.  This is so that
                                -- I can store the ThreadId into new DHTSearch structure.
                                tid <- fork $ join $ atomically (readTVar kvar >>= maybe retry return)
                                join $ atomically $ do
                                    schs <- readTVar dhtSearches
                                    case Map.lookup (method,nid) schs of
                                        Nothing  -> do forkSearch method nid qry dhtSearches dhtBuckets tid kvar
                                                       return $ presentSearches
                                        Just sch -> do writeTVar kvar (Just $ return ())
                                                       return $ reportSearchResults method h sch
                            goQuery qry = either (hPutClient h . ("Bad search target: "++))
                                                 (goTarget qry)
                                                 $ dhtParseId nidstr
                        if null method then presentSearches
                                       else maybe (hPutClient h ("Unsupported method: "++method))
                                                  goQuery
                                                  $ Map.lookup method dhtQuery

        ("x", s) | Just DHT{..} <- Map.lookup netname dhts
                    -> cmd0 $ do
                        let (method,xs) = break isSpace s
                            (nidstr,ys) = break isSpace $ dropWhile isSpace xs
                            go nid = join $ atomically $ do
                                schs <- readTVar dhtSearches
                                case Map.lookup (method,nid) schs of
                                    Nothing -> return $ hPutClient h "No match."
                                    Just DHTSearch{searchThread} -> do
                                        modifyTVar' dhtSearches (Map.delete (method,nid))
                                        return $ do
                                            killThread searchThread
                                            hPutClient h "Removed search."
                        either (hPutClient h . ("Bad search target: "++)) go $ dhtParseId nidstr

        ("save", _) | Just dht <- Map.lookup netname dhts
                    -> cmd0 $ do
                        saveNodes netname dht
                        hPutClient h $ "Saved " ++ nodesFileName netname ++ "."

        ("load", _) | Just dht <- Map.lookup netname dhts
                    -> cmd0 $ do
                        b <- pingNodes netname dht
                        case b of
                            Just num ->
                                  hPutClient h $ unwords [ "Pinging"
                                                         , show num
                                                         , "nodes from"
                                                         , nodesFileName netname ++ "."
                                                         ]
                            Nothing ->
                                  hPutClient h $ "Failed: " ++ nodesFileName netname ++ "."

        ("swarms", s) -> cmd0 $ do
                    let fltr = case s of
                                    ('-':'v':cs) | all isSpace (take 1 cs)
                                      -> const True
                                    _ -> (\(h,c,n) -> c/=0 )
                    ss <- atomically $ Peers.knownSwarms <$> readTVar (Mainline.contactInfo swarms)
                    let r = map (\(h,c,n) -> (unwords [show h,show c], maybe "" show n))
                            $ filter fltr ss
                    hPutClient h $ showReport r

        ("peers", s) -> cmd0 $ case readEither s of
                        Right ih -> do
                            ps <- atomically $ Peers.lookup ih <$> readTVar (Mainline.contactInfo swarms)
                            hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps
                        Left er -> hPutClient h er
        ("toxids", s) -> cmd0 $ do
                        keydb <- atomically $ readTVar toxkeys
                        now <- getPOSIXTime
                        let entries = map mkentry $ PSQ.toList (Tox.keyByAge keydb)
                            mkentry (k :-> tm) = [ show cnt, show k, show (now - tm) ]
                                where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb)
                        hPutClient h $ showColumns entries

        ("c", s) | Just (ConnectionManager mgr) <- connectionManager
                 , "" <- strp s
                 -> cmd0 $ join $ atomically $ do
            cs <- do
                ks <- connections mgr
                forM ks $ \k -> do
                    stat <- Connection.status mgr k
                    return (k,stat)
            let mkrow (k,st) = [ Connection.showKey mgr k
                               , Connection.showStatus mgr (connStatus st)
                               , showPolicy (connPolicy st)
                               ]
                rs = map mkrow cs
            return $ do
            hPutClient h $ showColumns rs

        ("help", s) | Just DHT{..} <- Map.lookup netname dhts
                    -> cmd0 $ do
            let tolist :: a -> [a]
                tolist = (:[])

                dhtkeys, announcables, ks, allcommands :: [[String]]
                dhtkeys = map tolist $ Map.keys dhts
                queries = map (tolist . ("s "++)) $ Map.keys dhtQuery
                xs = map (tolist . ("x "++)) $ Map.keys dhtQuery
                gs = map (tolist . ("g "++)) $ Map.keys dhtQuery
                announcables = map (tolist . ("p "++)) $ Map.keys dhtAnnouncables
                ks = [["k gen"],["k public"],["k secret"]]
                allcommands = sortBy (comparing (take 1)) $ concat [sessionCommands, dhtkeys, announcables, ks, queries, gs,xs]

            hPutClient h ("Available commands:\n" ++ showColumns allcommands)

        _    -> cmd0 $ hPutClient h "error."

netcrypto
  :: Maybe DHT
  -> Maybe PublicKey
  -> ClientHandle
  -> ContactInfo extra1
  -> Maybe (Tox.Tox extra2)
  -> Map.Map String (String,String) -- profile name to (multiplexer,exe name) for supported child executables
  -> String
  -> IO ()
netcrypto _ _ h _ Nothing _ _ =  hPutClient h "Requires Tox enabled."
netcrypto _ Nothing h _ _ _ _ =  hPutClient h "No key is selected, see k command."
netcrypto (Just (DHT {..})) (Just mypubkey) h roster (Just tox) exes paramStr =
    either
      (const $
       either
         (hPutClient h . ("Bad netcrypto target: " ++))
         goNodeInfo
         (readEither keystr) -- attempt read as NodeInfo type
       )
      (goPubkey . Tox.id2key) $
    readEither keystr -- attempt read as NodeId type
  where
    params = words paramStr
    keystr = bool (head params) "" (null params)
    -- TODO:
    -- execProfiles:
    -- atox@24-25,48-51,64-45  gnome-tox-notifier@24-25,49,50
    --      ^-- word64 type values that should be forwarded to this process
    execParams=drop 1 params
    parseExecParam :: String -> (String,[(Maybe Word64,Maybe Word64)])
    parseExecParam param = let (name,drop 1 -> rangesCombined) = span (/='@') param
                               wordsBy x str = groupBy (const (/=x)) str
                               rangesUnparsed = wordsBy ',' rangesCombined
                               parseRange :: String -> (Maybe Word64,Maybe Word64)
                               parseRange "all" = (Nothing,Nothing)
                               parseRange x = let (low,drop 1 -> high) = break (==',') x
                                                  in (readMaybe low,readMaybe high)
                               in (name,map parseRange rangesUnparsed)
    execs = map parseExecParam execParams


    goNodeInfo userkey_nodeinfo = do
      msec <-
        atomically $ do
          fmap userSecret . HashMap.lookup (Tox.key2id mypubkey) <$>
            readTVar (accounts roster)
      case msec of
        Nothing -> hPutClient h "Error getting secret key"
        Just sec -> do
          let their_pub = Tox.id2key $ Tox.nodeId userkey_nodeinfo
              their_addr = Tox.nodeAddr userkey_nodeinfo
          let acsVar = accounts (Tox.toxContactInfo tox)
          acsmap <- atomically $ readTVar acsVar
          case HashMap.lookup (Tox.key2id mypubkey) acsmap of
            Nothing -> hPutClient h "Unable to find account for selected key"
            Just account -> do
              now <- getPOSIXTime
              atomically $ do
                mcontact <- HashMap.lookup (Tox.nodeId userkey_nodeinfo) <$> readTVar (contacts account)
                forM_ mcontact $ \contact -> do
                mnid <- fmap (Tox.key2id . Tox.dhtpk . snd) <$> readTVar (contactKeyPacket contact)
                forM_ mnid $ \nid -> do
                forM_ (Tox.nodeInfo nid their_addr) $ \their_ni -> do
                    setContactAddr now their_pub their_ni account
              sessions <- Tox.netCrypto tox sec their_pub
              exeDir <- takeDirectory <$> getExecutablePath
              forM_ sessions $ \session -> do
                forM_ execs $ \(exekey,ranges) -> do
                    case Map.lookup exekey exes of
                        Nothing -> return ()
                        Just (multiplexer,exename) -> do
                            let exepath = exeDir </> exename
                            (myReadFd,myWriteFd) <- System.Posix.IO.createPipe
                            myRead  <- fdToHandle myReadFd
                            myWrite <- fdToHandle myWriteFd
                            whoAmI <- atomically $ newTVar mypubkey
                            whoAreThey <- atomically $ newTVar their_pub
                            let fdArgs = [show myWriteFd,show myReadFd]
                            if null multiplexer
                                then callProcess exepath fdArgs
                                else do
                                    let (multiplexer_exe,multiplexer_args) = splitAt 1 (words multiplexer)
                                    callProcess multiplexer (multiplexer_args ++ [intercalate " " (exepath:fdArgs)])
                            -- tell subprocess who is talking to who
                            B.hPutStr myWrite ("\NUL\NUL" `B.append` S.encode (Tox.key2id mypubkey))
                            B.hPutStr myWrite ("\NUL\SOH" `B.append` S.encode (Tox.key2id their_pub))
                            -- add hooks so subprocess is updated on incoming
                            let makeHook session typ
                                    = \session msg
                                       -> do -- if (getMessageType msg == typ)
                                             me <- atomically $ readTVar whoAmI
                                             when (me /= mypubkey) $ do
                                                atomically $ writeTVar whoAmI mypubkey
                                                B.hPutStr myWrite ("\NUL\NUL" `B.append` S.encode (Tox.key2id mypubkey))
                                             them <- atomically $ readTVar whoAreThey
                                             when (them /= their_pub) $ do
                                                atomically $ writeTVar whoAreThey their_pub
                                                B.hPutStr myWrite ("\NUL\SOH" `B.append` S.encode (Tox.key2id their_pub))
                                             B.hPutStr myWrite (S.encode msg)
                                             return (Just id)
                                addHooks currentHooks typs = forM_ typs $ \typ -> modifyTVar (Tox.ncHooks session) (Map.insert typ (currentHooks typ ++ [makeHook session typ]))
                            case ranges of
                                [(Nothing,Nothing)] -> atomically $ do
                                     typs <- map fromWord64 . filter (/=0) . U.elems <$> readTVar (Tox.ncIncomingTypeArray session)
                                     addHooks (const []) typs
                                _ -> atomically . forM_ ranges $ \range -> do
                                    case range of
                                        (Just first,Just last) -> do
                                            let typs = map fromWord64 [first .. last]
                                            hooks <- readTVar (Tox.ncHooks session)
                                            let currentHooks typ = fromMaybe [] (Map.lookup typ hooks)
                                            addHooks currentHooks typs
                            -- forward messages from subprocess
                            forwardThread <- forkIO $ do
                                tid <- myThreadId
                                let sidStr = printf "(%x)" (Tox.ncSessionId session)
                                labelThread tid (exekey ++ ".forward" ++ sidStr)
                                let myconduit = Conduit.sourceHandle myRead  .| conduitGet2 S.get -- :: ConduitT i CryptoMessage IO ()
                                Conduit.runConduit (myconduit .| awaitForever (\msg -> do
                                    let typ = toWord64 (getMessageType msg)
                                    mbSendIt <- liftIO $ atomically (lookupInRangeMap typ (Tox.ncOutHooks session))
                                    case mbSendIt of
                                        Just sendit -> liftIO . void $ sendit (Tox.toxCryptoKeys tox) session msg
                                        Nothing     -> return () -- do
                                         -- uncomment to let unhooked pass thru:
                                         -- if lossyness (msgId msg) == Lossless
                                         --             then sendLossless (Tox.toxCryptoKeys tox) session msg
                                         --             else sendLossy (Tox.toxCryptoKeys tox) session msg
                                    ))
                            -- add hook to killThread on kill packet
                            atomically $ do
                                hooks <- readTVar (Tox.ncHooks session)
                                let currentHooks = fromMaybe [] $ Map.lookup (Msg KillPacket) hooks
                                let myhook :: Tox.NetCryptoSession  -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
                                    myhook _ _ = killThread forwardThread >> return (Just id)
                                modifyTVar' (Tox.ncHooks session) (Map.insert (Msg KillPacket) (currentHooks ++ [myhook]))
              hPutClient h "Handshake sent"
    goPubkey their_pub = do
      msec <-
        atomically $ do
          ks <- map swap <$> myKeyPairs roster
          return $ Data.List.lookup mypubkey ks
      case msec of
        Nothing -> hPutClient h "Error getting secret key"
        Just sec -> do
          Tox.netCrypto tox sec their_pub
          hPutClient h "Handshake sent"

readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr]
readExternals nodeAddr vars = do
    as <- atomically $ mapM (fmap (nodeAddr . selfNode) . readTVar) vars
    let unspecified (SockAddrInet _ 0)              = True
        unspecified (SockAddrInet6 _ _ (0,0,0,0) _) = True
        unspecified _                               = False
    -- TODO: Filter to only global addresses?
    return $ filter (not . unspecified) as

data Options = Options
    { portbt    :: String
    , porttox   :: String
    , portxmpp  :: String -- client-to-server
    , portxmppS :: String -- server-to-server
    , ip6bt     :: Bool
    , ip6tox    :: Bool
    , dhtkey    :: Maybe SecretKey
    -- | Currently only relevant to XMPP server code.
    --
    --   [ 0 ] Don't log XMPP stanzas.
    --
    --   [ 1 ] Log non-ping stanzas.
    --
    --   [ 2 ] Log all stanzas, even pings.
    , verbosity :: Int
    , verboseTags :: [DebugTag]
    }
 deriving (Eq,Show)

sensibleDefaults :: Options
sensibleDefaults = Options
    { portbt      = "6881"
    , porttox     = "33445"
    , portxmpp    = "5222"
    , portxmppS   = "5269"
    , ip6bt       = True
    , ip6tox      = True
    , dhtkey      = Nothing
    , verbosity   = 2
    , verboseTags = [XUnexpected, XUnused]
    }

-- bt=<port>,tox=<port>
-- -4
parseArgs :: [String] -> Options -> Options
parseArgs []                  opts = opts
parseArgs ("--dhtkey":k:args) opts = parseArgs args opts
    { dhtkey = decodeSecret $ B.pack k }
parseArgs ("--dht-key":k:args) opts = parseArgs args opts
    { dhtkey = decodeSecret $ B.pack k }
parseArgs ("-4":args) opts         = parseArgs args opts
    { ip6bt  = False
    , ip6tox = False }
parseArgs ("-v":tags:args) opts     = parseArgs args opts
    { verboseTags = let gs = groupBy (const (/= ',')) tags
                        ss = map (dropWhile (==',')) gs
                        (ds0,as0) = partition (\s -> last (' ':s) == '-') ss
                        as = mapMaybe parseDebugTag as0
                        ds = mapMaybe (parseDebugTag . init) ds0
                    in (verboseTags opts `union` as) \\ ds
    }
parseArgs (arg:args) opts          = parseArgs args opts
    { portbt    = fromMaybe (portbt opts)  $ Prelude.lookup "bt"  ports
    , porttox   = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports
    , portxmpp  = fromMaybe (portxmpp opts) $ Prelude.lookup "xmpp" ports
    , portxmppS = fromMaybe (portxmppS opts) $ Prelude.lookup "xmpp.s2s" ports }
 where
    ports = map ( (dropWhile (==',') *** dropWhile (=='='))
                . break (=='=') )
                $ groupBy (const (/= ',')) arg

noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r)
noArgPing f [] x = f x
noArgPing _ _  _ = return Nothing

-- | Create a Conduit Source by repeatedly calling an IO action.
ioToSource :: IO (Maybe x) -> IO () -> C.Source IO x
ioToSource !action !onEOF = liftIO action >>= \case
        Nothing   -> liftIO onEOF
        Just item -> do C.yield item
                        ioToSource action onEOF

newXmmpSink :: Tox.NetCryptoSession -> C.Sink (Flush Tox.CryptoMessage) IO ()
newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar }) = C.awaitForever $ \flush_cyptomessage -> do
    let sendit :: Tox.NetCryptoSession -> Flush Tox.CryptoMessage -> IO ()
        sendit session (Chunk msg) = do
            outq <- atomically $ do
                mbOutq <- readTVar outGoingQVar
                case mbOutq of
                    Tox.HaveHandshake outq -> return outq
                    Tox.NeedHandshake -> retry
            extra <- Tox.nqToWireIO outq
            r <- atomically $ do
                        rTry <- Tox.tryAppendQueueOutgoing extra outq msg
                        case rTry of
                            Tox.OGFull -> retry
                            Tox.OGSuccess x -> return (Tox.OGSuccess x)
                            Tox.OGEncodeFail -> return Tox.OGEncodeFail
            case r of
                Tox.OGSuccess x  -> case Tox.ncSockAddr session of
                    Tox.HaveDHTKey saddr -> Tox.sendSessionPacket (Tox.ncAllSessions session) saddr x
                    _                    -> return ()
                Tox.OGEncodeFail -> dput XMisc ("FAILURE to Encode Outgoing: " ++ show msg)
                _                -> return ()
        sendit session Flush = return ()
    liftIO $ sendit session flush_cyptomessage


-- | Called upon a new Tox friend-connection session with a remote peer in
-- order to set up translating conduits that simulate a remote XMPP server.
announceToxJabberPeer :: PublicKey  -- ^ This node's long-term user key.
                      -> PublicKey -- ^ Remote tox node's long-term user key.
                      -> TChan ((SockAddr,ConnectionData), Tcp.ConnectionEvent XML.Event)
                      -> SockAddr -- ^ Local bind address for incoming Tox packets.
                      -> SockAddr -- ^ Remote address for this connection.
                      -> STM Bool
                      -> C.Source IO Tox.CryptoMessage
                      -> C.Sink (Flush Tox.CryptoMessage) IO ()
                      -> IO (Maybe (Tox.NetCryptoSession -> Tox.NetCryptoSession))
announceToxJabberPeer me them echan laddr saddr pingflag tsrc tsnk
    = do
     atomically $ do
        v <- newTVar Nothing
        writeTChan echan
            ( (saddr, ConnectionData (Left (Local laddr)) XMPPServer.Tox (xmppHostname me) v)
            , Tcp.Connection pingflag xsrc xsnk )
     return Nothing
 where
    xsrc = tsrc =$= toxToXmpp laddr me (xmppHostname them)
    xsnk = flushPassThrough xmppToTox =$= tsnk

vShowMe :: Tox.ViewSnapshot -> Int -> B.ByteString
vShowMe (Tox.ViewSnapshot { vNick, vStatus, vStatusMsg, vTyping }) indent
    = B.unlines
    . map doRow $  [ ["Nick: ", vNick ]
                   , ["Status: ", "(" <> pshow vStatus <> ") " <> vStatusMsg ]
                   , ["Typing: ", pshow vTyping ]
                   ]
    where (<>) = B.append
          space = B.replicate indent ' '
          doRow = B.append space . B.concat

vShowThem :: Tox.ViewSnapshot -> Int -> B.ByteString
vShowThem (Tox.ViewSnapshot { vTheirNick, vTheirStatus, vTheirStatusMsg, vTheirTyping }) indent
    = B.unlines
    . map doRow $  [ ["Nick: ", vTheirNick ]
                   , ["Status: ", "(" <> pshow vTheirStatus <> ") " <> vTheirStatusMsg ]
                   , ["Typing: ", pshow vTheirTyping ]
                   ]
    where (<>) = B.append
          space = B.replicate indent ' '
          doRow = B.append space . B.concat

showMsg ::(Word32, (Bool,(Tox.ViewSnapshot, InOrOut Tox.CryptoMessage))) -> B.ByteString
showMsg (n,(flg,(snapshot,iocm))) = B.concat [bool "  " "h " flg, showmsg' (snapshot,iocm)]
    where
        showmsg' (snapshot,In cm) = B.concat [Tox.vTheirNick snapshot,"> ", pshow cm]
        showmsg' (snapshot,Out cm) = B.concat [{-utf8boldify-} (Tox.vNick snapshot),": ",pshow cm]
        utf8boldify s = boldify (T.decodeUtf8With E.lenientDecode s)
            where
                boldify :: T.Text -> B.ByteString
                boldify j = E.encodeUtf8 $ T.map addIt j
                    where addIt x = let o = ord x in case o of
                            _ | o <= 90 && o >= 65  -> chr (o + 119743)
                            _ | o <= 122 && o >= 97 -> chr (o + 119737)
                            _ -> x

onNewToxSession :: XMPPServer
                     -> TVar (Map.Map Uniq24 AggregateSession)
                     -> ContactInfo extra
                     -> SockAddr
                     -> Tox.NetCryptoSession
                     -> IO ()
onNewToxSession sv ssvar ContactInfo{accounts} addrTox netcrypto = do
    let them s = Tox.ncTheirPublicKey s

        me   s = Tox.ncMyPublicKey s

        onStatusChange :: (Tox.NetCryptoSession -> Tcp.ConnectionEvent XML.Event -> STM ())
                          -> AggregateSession -> Tox.NetCryptoSession -> Status Tox.ToxProgress -> STM ()
        onStatusChange announce c s Established = onConnect announce c s
        onStatusChange announce _ s _           = onEOF announce s

        onEOF announce s = do
            HashMap.lookup (Tox.key2id $ me s) <$> readTVar accounts
                >>= mapM_ (setTerminated $ them s)
            announce s Tcp.EOF

        onConnect announce c s = do
            HashMap.lookup (Tox.key2id $ me s) <$> readTVar accounts
                >>= mapM_ (setEstablished $ them s)
            announce s $ Tcp.Connection (return False) xmppSrc xmppSnk
          where
            toxSrc  :: ConduitT ()                         (Int, CryptoMessage) IO ()
            toxSnk  :: ConduitT (Maybe Int, CryptoMessage) Void                 IO ()
            xmppSrc :: ConduitT ()                         XML.Event            IO ()
            xmppSnk :: ConduitT (Flush XML.Event)          Void                 IO ()

            toxSrc  = ioToSource (atomically $ orElse (awaitAny c)
                                                  $ aggregateStatus c >>= \case
                                                    Dormant -> return Nothing
                                                    _       -> retry)
                                 (return ())
            toxSnk  = C.mapM_ (uncurry $ dispatchMessage c)
            xmppSrc = toxSrc .| C.map snd .| toxToXmpp addrTox (me s) (xmppHostname $ them s)
            xmppSnk = flushPassThrough xmppToTox
                        .| C.mapMaybe (\case Flush   -> Nothing
                                             Chunk x -> Just (Nothing,x))
                        .| toxSnk

    uniqkey <- xor24 <$> hash24 (them netcrypto) <*> hash24 (me netcrypto)

    c <- atomically $ do
        mc <- Map.lookup uniqkey <$> readTVar ssvar
        case mc of
            Nothing -> do
                announce <- do
                    v <- newTVar Nothing
                    let ck       = uniqueAsKey uniqkey
                        condta s = ConnectionData (Left (Local addrTox))
                                                XMPPServer.Tox
                                                (xmppHostname $ me s)
                                                v
                    return $ \s e -> writeTChan (xmppEventChannel sv) ( (ck, condta s), e)
                c <- newAggregateSession $ onStatusChange announce
                modifyTVar' ssvar $ Map.insert uniqkey c
                return c
            Just c  -> return c

    addDestroySessionHook netcrypto (Just 0) $ delSession c . fromIntegral . ncSessionId
    addSession c netcrypto

    return ()

selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text
selectManager mtman tcp profile = case T.splitAt 43 profile of
    (k,".tox") | Just tman <- mtman
               -> let -- The following error call is safe because the toxConnections field
                      -- does not make use of the PresenceState passed to tman.
                      tox = toxConnections $ tman $ error "PresenseState"
                      tkey them = do
                        me <- readMaybe (T.unpack k)
                        them <- case T.splitAt 43 them of
                            (them0,".tox") -> readMaybe (T.unpack them0)
                            _              -> Nothing
                        return (Tox.ToxContact me them)
                  in Manager
                    { resolvePeer = \themhost -> do
                        r <- fromMaybe (return []) $ do
                            (themT,".tox") <- Just $ T.splitAt 43 themhost
                            them <- readMaybe $ T.unpack themT
                            me <- readMaybe $ T.unpack k
                            let contact = Tox.ToxContact me them
                            Just $ resolvePeer tox contact
                        dput XMan $ "resolvePeer(tox) " ++ show (T.take 8 $ k,T.take 8 $ themhost,r)
                        return r
                    , reverseAddress = \paddr -> do
                        r <- fromMaybe (return []) $ do
                            me <- readMaybe $ T.unpack k
                            Just $ do
                                reverseAddress tox paddr
                                 <&> mapMaybe (\case
                                    Tox.ToxContact a k | a == me -> Just $ T.pack (show k) `T.append` ".tox"
                                    _                            -> Nothing)
                        dput XMan $ "reverseAddress(tox)" ++ show (T.take 8 k,paddr) ++ ": " ++ show r
                        return r

                    , showKey = \key -> T.unpack key ++ ".tox"
                    , setPolicy = \them -> case tkey them of
                        Just tk -> \p -> setPolicy tox tk p
                        Nothing -> \p -> return ()
                    , status =  \them -> case tkey them of
                        Just tk -> fmap ToxStatus <$> status tox tk
                        Nothing -> return $ Connection Dormant RefusingToConnect
                    , connections = let valid (Tox.ToxContact local them) = do
                                            guard $ T.pack (show local) == k
                                            return $ T.pack (show them ++ ".tox")
                                    in fmap (mapMaybe valid) $ connections tox
                    , stringToKey = \s -> Just $ T.pack (s ++ ".tox")
                    , showProgress = \(ToxStatus stat) -> showProgress tox stat
                    }
    _ -> Manager
                    { resolvePeer = \themhost -> do
                        dput XMan $ "resolvePeer(tcp) " ++ show (profile,themhost)
                        resolvePeer tcp themhost
                    , reverseAddress = \paddr -> do
                        dput XMan $ "reverseAddress(tcp) " ++ show (profile,paddr)
                        reverseAddress tcp paddr

                    , showKey = showKey tcp
                    , setPolicy = setPolicy tcp
                    , status =  \k -> fmap XMPPStatus <$> status tcp k
                    , connections = connections tcp
                    , stringToKey = stringToKey tcp
                    , showProgress = \(XMPPStatus stat) -> showProgress tcp stat
                    }


main :: IO ()
main = do
    args <- getArgs
    let opts = parseArgs args sensibleDefaults
    print opts

    swarms <- Mainline.newSwarmsDatabase
    -- Restore peer database before forking the listener thread.
    peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat")
    either (dput XMisc . ("bt-peers.dat: "++))
           (atomically . writeTVar (Mainline.contactInfo swarms))
           (peerdb >>= S.decodeLazy)

    announcer <- forkAnnouncer

    -- Default: quiet all tags (except XMisc).
    forM [minBound .. maxBound] setQuiet
    forM (verboseTags opts) setVerbose

    (quitBt,btdhts,btips,baddrs) <- case portbt opts of
        "" -> return (return (), Map.empty,return [],[])
        p  -> do
            addr <- getBindAddress p (ip6bt opts)
            (bt,btR,btBootstrap4, btBootstrap6) <- Mainline.newClient swarms addr
            quitBt <- forkListener "bt" (clientNet bt)
            mainlineSearches <- atomically $ newTVar Map.empty
            peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port.
            let mainlineDHT bkts wantip = DHT
                    { dhtBuckets = bkts btR
                    , dhtPing    = Map.singleton "ping" $ DHTPing
                                        { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Mainline.ping bt
                                        , pingShowResult = show
                                        }
                    , dhtQuery   = Map.fromList
                                    [ ("node", DHTQuery
                                        { qsearch = (Mainline.nodeSearch bt)
                                        , qhandler = (\ni -> fmap Mainline.unwrapNodes
                                                                . Mainline.findNodeH btR ni
                                                                . flip Mainline.FindNode (Just Want_Both))
                                        , qshowR = show
                                        , qshowTok = (const Nothing)
                                        })
                                    -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
                                    -- sr = InfoHash
                                    -- stok = Token
                                    -- sni = NodeInfo
                                    , ("peer", DHTQuery
                                        { qsearch = (Mainline.peerSearch bt)
                                        , qhandler = (\ni -> fmap Mainline.unwrapPeers
                                                                . Mainline.getPeersH btR swarms ni
                                                                . flip Mainline.GetPeers (Just Want_Both)
                                                                . (read . show)) -- TODO: InfoHash -> NodeId
                                        , qshowR = (show . pPrint)
                                        , qshowTok = (Just . show)
                                        })
                                    ]
                    , dhtParseId  = readEither :: String -> Either String Mainline.NodeId
                    , dhtSearches = mainlineSearches
                    , dhtFallbackNodes = Mainline.bootstrapNodes wantip
                    , dhtAnnouncables = Map.fromList
                                    -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
                                    -- dta = Announce
                                    -- pr = Announced
                                    -- ptok = Token
                                    -- pni = NodeInfo
                                    [ ("peer", DHTAnnouncable { announceSendData = Right $ \ih tok -> \case
                                                                    Just ni -> do
                                                                        port <- atomically $ readTVar peerPort
                                                                        let dta = Mainline.mkAnnounce port ih tok
                                                                        Mainline.announce bt dta ni
                                                                    Nothing -> return Nothing
                                                              , announceParseAddress = readEither
                                                              , announceParseData = readEither
                                                              , announceParseToken = const $ readEither
                                                              , announceInterval = 60 -- TODO: Is one minute good?
                                                              , announceTarget = (read . show) -- TODO: InfoHash -> NodeId -- peer
                                                              })
                                    , ("port", DHTAnnouncable { announceParseData = readEither
                                                              , announceParseToken = \_ _ -> return ()
                                                              , announceParseAddress = const $ Right ()
                                                              , announceSendData = Right $ \dta () -> \case
                                                                    Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
                                                                                  return $ Just dta
                                                                    Just _ -> return Nothing
                                                              , announceInterval = 0 -- TODO: The "port" setting should probably
                                                                                     -- be a command rather than an announcement.
                                                              , announceTarget = const $ Mainline.zeroID
                                                              })]

                    , dhtSecretKey = return Nothing
                    , dhtBootstrap = case wantip of
                                        Want_IP4 -> btBootstrap4
                                        Want_IP6 -> btBootstrap6
                    }
                dhts = Map.fromList $
                        ("bt4", mainlineDHT Mainline.routing4 Want_IP4)
                        : if ip6bt opts
                            then [ ("bt6", mainlineDHT Mainline.routing6 Want_IP6) ]
                            else []
                ips :: IO [SockAddr]
                ips = readExternals Mainline.nodeAddr
                                        [ Mainline.routing4 btR
                                        , Mainline.routing6 btR
                                        ]
            return (quitBt,dhts,ips, [addr])

    keysdb <- Tox.newKeysDatabase

    _crypto <- Tox.newCrypto
    let emptyDestroyHook :: Tox.NetCryptoSession -> IO ()
        emptyDestroyHook session = dput XNetCrypto $ "SESSION DESTROY HOOK NOT ADDED ! publkey= " ++ show (Tox.key2id (Tox.ncTheirPublicKey session))
    _netCryptoSessionsState <- Tox.newSessionsState _crypto emptyDestroyHook Tox.defaultUnRecHook Tox.defaultCryptoDataHooks
    (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- case porttox opts of
        "" -> return (Nothing,return (), Map.empty, return [],[])
        toxport -> do
            addrTox <- getBindAddress toxport (ip6tox opts)
            dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
            tox <- Tox.newTox keysdb
                              addrTox
                              (Just _netCryptoSessionsState)
                              (dhtkey opts)
            (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox True

            toxSearches <- atomically $ newTVar Map.empty

            let toxDHT bkts wantip = DHT
                    { dhtBuckets = bkts (Tox.toxRouting tox)
                    , dhtPing    = Map.fromList
                                    [ ("ping", DHTPing
                                            { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Tox.ping (Tox.toxDHT tox)
                                            , pingShowResult = show
                                            })
                                    , ("cookie", DHTPing
                                            { pingQuery = \case
                                                [keystr] | Just mykey <- readMaybe keystr
                                                         -> Tox.cookieRequest (Tox.toxCryptoKeys tox)
                                                                              (Tox.toxDHT tox)
                                                                              (Tox.id2key mykey)
                                                _        -> const $ return Nothing
                                            , pingShowResult = show
                                            })]
                    , dhtQuery   = Map.fromList
                                    [ ("node", DHTQuery
                                        { qsearch = Tox.nodeSearch (Tox.toxDHT tox)
                                                                   (Tox.nodesOfInterest $ Tox.toxRouting tox)
                                        , qhandler = (\ni -> fmap Tox.unwrapNodes
                                                                . Tox.getNodesH (Tox.toxRouting tox) ni
                                                                . Tox.GetNodes)
                                        , qshowR = show -- NodeInfo
                                        , qshowTok = (const Nothing)
                                        })
                                    , ("toxid", DHTQuery
                                        { qsearch = Tox.toxQSearch tox
                                        , qhandler = -- qhandler :: ni -> nid -> IO ([ni], [r], tok)
                                                         (\ni nid ->
                                                            Tox.unwrapAnnounceResponse Nothing
                                                                <$> clientAddress (Tox.toxDHT tox) Nothing
                                                                <*> Tox.announceH (Tox.toxRouting tox)
                                                                                  (Tox.toxTokens tox)
                                                                                  (Tox.toxAnnouncedKeys tox)
                                                                                  (Tox.OnionDestination Tox.SearchingAlias ni Nothing)
                                                                                  (Tox.AnnounceRequest zeros32 nid Tox.zeroID))
                                        , qshowR  = show -- Rendezvous
                                        , qshowTok = Just . show -- Nonce32
                                        })
                                    ]
                    , dhtParseId  = readEither :: String -> Either String Tox.NodeId
                    , dhtSearches = toxSearches
                    , dhtFallbackNodes = return []
                    , dhtAnnouncables = Map.fromList
                                    -- To announce your own tox OrjBG... identity is online:
                                    --
                                    -- > a +toxid OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu
                                    [ ("toxid", DHTAnnouncable { announceSendData = Right (toxAnnounceSendData tox)
                                                               , announceParseAddress = readEither
                                                               , announceParseToken = const $ readEither
                                                               , announceParseData = fmap Tox.id2key . readEither
                                                               , announceTarget = Tox.key2id -- toxid

                    -- For peers we are announcing ourselves to, if we are not
                    -- announced to them toxcore tries every 3 seconds to
                    -- announce ourselves to them until they return that we
                    -- have announced ourselves to, then toxcore sends an
                    -- announce request packet every 15 seconds to see if we
                    -- are still announced and re announce ourselves at the
                    -- same time. The timeout of 15 seconds means a `ping_id`
                    -- received in the last packet will not have had time to
                    -- expire (20 second minimum timeout) before it is resent
                    -- 15 seconds later. Toxcore sends every announce packet
                    -- with the `ping_id` previously received from that peer
                    -- with the same path (if possible).
                                                               , announceInterval = toxAnnounceInterval

                                                               })
                                    -- dhtkey parameters:
                                    --
                                    -- ni  = NodeInfo
                                    -- r   = Rendezvous
                                    -- tok = Nonce32
                                    -- dta = PublicKey{-them-}
                                    --
                                    -- Using k-selected identity, to share your dht
                                    -- key with remote tox user
                                    -- "KWoEx1XQHrluIoW.3nK6BFb6XCebKWr3nDDt3V7CcoJ"
                                    -- ...
                                    --
                                    -- > a +dhtkey KWoEx1XQHrluIoW.3nK6BFb6XCebKWr3nDDt3V7CcoJ
                                    , ("dhtkey", DHTAnnouncable { announceSendData = Left ("toxid", readEither, \me them addr -> do
                                                                        dkey <- Tox.getContactInfo tox
                                                                        sendMessage
                                                                            (Tox.toxToRoute tox)
                                                                            (Tox.AnnouncedRendezvous them addr)
                                                                            (me,Tox.OnionDHTPublicKey dkey))
                                                                , announceParseAddress = \str -> do
                                                                        ni <- readEither str
                                                                        return ( ni :: Tox.NodeInfo )
                                                                , announceParseToken = \_ str -> do
                                                                        tok <- readEither str
                                                                        return ( tok :: Nonce32 )
                                                                , announceParseData = fmap Tox.id2key . readEither
                                                                , announceTarget = Tox.key2id

                    -- We send this packet every 30 seconds if there is more
                    -- than one peer (in the 8) that says they our friend is
                    -- announced on them. This packet can also be sent through
                    -- the DHT module as a DHT request packet (see DHT) if we
                    -- know the DHT public key of the friend and are looking
                    -- for them in the DHT but have not connected to them yet.
                    -- 30 second is a reasonable timeout to not flood the
                    -- network with too many packets while making sure the
                    -- other will eventually receive the packet. Since packets
                    -- are sent through every peer that knows the friend,
                    -- resending it right away without waiting has a high
                    -- likelihood of failure as the chances of packet loss
                    -- happening to all (up to to 8) packets sent is low.
                    --
                                                               , announceInterval = 30

                                                               })
                                    -- "friend" parameters
                                    --
                                    -- ni  = NodeInfo
                                    -- r   = Rendezvous
                                    -- tok = Nonce32
                                    -- dta = (NoSpamId{-them-},String)
                                    --
                                    -- Using k-selected identity, to send a
                                    -- friend-request to the JID $TESTZ300@OrjBG...:
                                    --
                                    -- > a +friend $TESTZ300@OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox Hey, add me!
                                    --
                                    , ("friend", DHTAnnouncable { announceSendData = Left ("toxid", readEither, \me them0 addr -> do
                                                                        let (Tox.NoSpamId sum them,txt) = them0
                                                                            Tox.NoSpam nospam _ = sum
                                                                            fr = Tox.FriendRequest nospam (T.encodeUtf8 $ T.pack txt)
                                                                        sendMessage
                                                                            (Tox.toxToRoute tox)
                                                                            (Tox.AnnouncedRendezvous them addr)
                                                                            (me,Tox.OnionFriendRequest fr))
                                                                , announceParseAddress = \str -> do
                                                                        ni <- readEither str
                                                                        return ( ni :: Tox.NodeInfo )
                                                                , announceParseToken = \_ str -> do
                                                                        tok <- readEither str
                                                                        return ( tok :: Nonce32 )
                                                                , announceParseData = \str -> do
                                                                        let (jidstr,txt) = break isSpace str
                                                                        jid <- readEither jidstr
                                                                        return (jid, drop 1 txt)
                                                                , announceTarget = \(Tox.NoSpamId _ pub,_) -> Tox.key2id pub

                    -- Friend requests are sent with exponentially increasing
                    -- interval of 2 seconds, 4 seconds, 8 seconds, etc... in
                    -- toxcore. This is so friend requests get resent but
                    -- eventually get resent in intervals that are so big that
                    -- they essentially expire. The sender has no way of
                    -- knowing if a peer refuses a friend requests which is why
                    -- friend requests need to expire in some way.  Note that
                    -- the interval is the minimum timeout, if toxcore cannot
                    -- send that friend request it will try again until it
                    -- manages to send it. One reason for not being able to
                    -- send the friend request would be that the onion has not
                    -- found the friend in the onion and so cannot send an
                    -- onion data packet to them.
                    --
                    -- TODO: Support exponential backoff behavior.  For now, setting
                    -- interval to 8 seconds.

                                                               , announceInterval = 8
                                                               })]
                    , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox)
                    , dhtBootstrap = case wantip of
                                        Want_IP4 -> toxStrap4
                                        Want_IP6 -> toxStrap6
                    }
                dhts = Map.fromList $
                        ("tox4", toxDHT Tox.routing4 Want_IP4)
                        : if ip6tox opts
                            then [ ("tox6", toxDHT Tox.routing6 Want_IP6) ]
                            else []
                ips :: IO [SockAddr]
                ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox
                                                 , Tox.routing6 $ Tox.toxRouting tox ]
            return (Just tox, quitTox, dhts, ips, [addrTox])

    let netCryptoSessionsState = maybe _netCryptoSessionsState Tox.toxCryptoSessions mbtox

    _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs

    ssvar <- atomically $ newTVar Map.empty
    (msv,mconns,mstate) <- case portxmpp opts of
        "" -> return (Nothing,Nothing,Nothing)
        p  -> do
            cport <- getBindAddress p True{-IPv6 supported-}
            -- TODO: Allow running without an XMPP server-to-server port.
            --       This should probably be default for toxmpp use.
            sport <- getBindAddress (portxmppS opts) True{-IPv6 supported-}

            -- XMPP initialization
            cw <- newConsoleWriter
            let lookupBkts :: String -> Map.Map String DHT -> Maybe (String,TVar (BucketList Tox.NodeInfo))
                lookupBkts name m = case Map.lookup name m of
                    Nothing              -> Nothing
                    Just DHT{dhtBuckets} -> cast (name, dhtBuckets)
            let toxbkts = catMaybes
                            [ lookupBkts "tox4" toxdhts
                            , lookupBkts "tox6" toxdhts
                            ]

            sv <- xmppServer Tcp.noCleanUp (Just sport)
            tcp <- xmppConnections sv -- :: IO ( Manager TCPStatus T.Text )
            let tman = toxman ssvar announcer toxbkts <$> mbtox
            state     <- newPresenceState cw tman sv (selectManager tman tcp)
            forkXmpp sv (presenceHooks state (verbosity opts) (Just cport) (Just sport))
            conns     <- xmppConnections  sv
            return (Just sv, Just conns, Just state)

    forM_ (take 1 taddrs) $ \addrTox -> do
        atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do
            {-
            -- allsessionsMap <- atomically $ readTVar (netCryptoSessions netCryptoSessionsState)
            let sockAddr = Tox.ncSockAddr netcrypto
                pubKey   = Tox.ncTheirPublicKey netcrypto
            tmchan <- atomically newTMChan
            let pingflag         = return False -- XMPPServer should never send pings.
                                                -- This is taken care of by the tox layer.
                receiveCrypto    = atomically $ readTMChan tmchan
                onEOF            = return () -- setTerminate is called elsewhere.
                xmppSrc          = ioToSource receiveCrypto onEOF
                xmppSink         = newXmmpSink netcrypto
            -}
            forM_ msv $ \sv -> do
                let Tox.HaveDHTKey saddr = Tox.ncSockAddr netcrypto
                {-
                    Tox.HaveDHTKey dkey  = Tox.ncTheirDHTKey netcrypto
                    nid                  = Tox.key2id dkey
                    them                 = Tox.ncTheirPublicKey netcrypto
                    me                   = Tox.ncMyPublicKey netcrypto

                announceToxJabberPeer me them (xmppEventChannel sv) addrTox saddr pingflag xmppSrc xmppSink
                -}

                forM_ mbtox $ \tox -> do
                onNewToxSession sv ssvar (Tox.toxContactInfo tox) saddr netcrypto
                {-
                mbacc <- HashMap.lookup (Tox.key2id me)
                         <$> atomically (readTVar accounts)
                -- TODO: Add account if it doesn't exist?
                forM_ mbacc $ \acnt -> do
                now <- getPOSIXTime
                forM_ (either (const Nothing) Just $ Tox.nodeInfo nid saddr)
                    $ \ni -> do
                atomically $ do setEstablished them acnt
                                setContactAddr now them ni acnt
            atomically $ do
                supply <- readTVar (Tox.listenerIDSupply netCryptoSessionsState)
                let (listenerId,supply') = freshId supply
                writeTVar (Tox.listenerIDSupply netCryptoSessionsState) supply'
                modifyTVar' (Tox.ncListeners netcrypto) (IntMap.insert listenerId (0,tmchan))
                -}
            return Nothing

    let dhts = Map.union btdhts toxdhts

    (waitForSignal, checkQuit) <- do
        signalQuit <- atomically $ newTVar False
        let quitCommand = atomically $ writeTVar signalQuit True
        installHandler sigTERM (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
        installHandler sigINT (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
        let defaultToxData = do
                rster <- Tox.newContactInfo
                orouter <- newOnionRouter (dput XMisc)
                return (rster, orouter)
        (rstr,orouter) <- fromMaybe defaultToxData $ do
            tox <- mbtox
            return $ return ( Tox.toxContactInfo tox, Tox.toxOnionRoutes tox )
        let session = clientSession0 $ Session
                { netname           = concat $ take 1 $ Map.keys dhts -- initial default DHT
                , selectedKey       = Nothing
                , dhts              = dhts  -- all DHTs
                , signalQuit        = quitCommand
                , swarms            = swarms
                , cryptosessions    = netCryptoSessionsState
                , toxkeys           = keysdb
                , roster            = rstr
                , announceToLan     = fromMaybe (return ()) $ Tox.toxAnnounceToLan <$> mbtox
                , connectionManager = ConnectionManager <$> mconns
                , onionRouter       = orouter
                , externalAddresses = liftM2 (++) btips toxips
                , announcer         = announcer
                , mbTox             = mbtox
                }
        srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
        return ( do atomically $ readTVar signalQuit >>= check
                    quitListening srv
               , readTVar signalQuit >>= check
               )


    forM_ (Map.toList dhts)
          $ \(netname, dht@DHT { dhtBuckets = bkts
                               , dhtQuery = qrys
                               , dhtPing = pings
                               , dhtFallbackNodes = getBootstrapNodes
                               , dhtBootstrap = bootstrap }) -> do
        btSaved <- loadNodes netname --  :: IO [Mainline.NodeInfo]
        putStrLn $ "Loaded "++show (length btSaved)++" nodes for "++netname++"."
        fallbackNodes <- getBootstrapNodes
        let isNodesSearch :: ni :~: r -> Search nid addr tok ni r -> Search nid addr tok ni ni
            isNodesSearch Refl sch = sch
            ping = maybe (const $ return False)
                         (\DHTPing{pingQuery} -> fmap (maybe False (const True)) . pingQuery [])
                         $ Map.lookup "ping" pings
        fork $ do
            myThreadId >>= flip labelThread ("bootstrap."++netname)
            bootstrap btSaved fallbackNodes
        return ()

    forkIO $ do
        myThreadId >>= flip labelThread "XMPP.stanzas"
        let console = cwPresenceChan <$> (mstate >>= consoleWriter)
        fix $ \loop -> do
        what <- atomically
            $ orElse (do (client,stanza) <- maybe retry takeTMVar console
                         return $ forM_ mstate $ \state -> do
                                     informClientPresence0 state Nothing client stanza
                                     loop)
                     (checkQuit >> return (return ()))
        what

    forM msv $ \_ -> dput XMisc "Started XMPP server."

    -- Wait for DHT and XMPP threads to finish.
    -- Use ResourceT to clean-up XMPP server.
    waitForSignal

    forM_ mstate $ \PresenceState{server=xmpp} -> do
        quitXmpp xmpp
    stopAnnouncer announcer
    quitBt
    quitTox

    swarmsdb <- atomically $ readTVar (Mainline.contactInfo swarms)
    forM_ (Map.toList dhts) $ \(netname,dht) -> do
        saveNodes netname dht
        dput XMisc $ "Saved " ++ nodesFileName netname ++ "."
    L.writeFile "bt-peers.dat" $ S.encodeLazy swarmsdb
    dput XMisc $ "Saved bt-peers.dat"