path: root/examples/dhtd.hs

{-# 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             #-}

import Control.Arrow
import Control.Applicative
import Control.Concurrent.STM
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.Bool
import Data.Char
import Data.Hashable
import Data.List
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set        as Set
import Data.Time.Clock
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.Vector as V
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

import Announcer
import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys)
import Network.UPNP as UPNP
import Network.Address hiding (NodeId, NodeInfo(..))
import Network.Kademlia.Search
import Network.QueryResponse
import Network.StreamServer
import Network.Kademlia
import qualified Network.BitTorrent.MainlineDHT as Mainline
import qualified Network.Tox as Tox
import Network.Kademlia.Routing as R
import Data.Aeson as J (ToJSON, FromJSON)
import qualified Data.Aeson as J
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as B
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.Handlers as Tox
import Data.Typeable
import Roster

showReport :: [(String,String)] -> String
showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs

showColumns :: [[String]] -> String
showColumns rows = do
    let cols = transpose rows
        ws = map (maximum . map (succ . length)) cols
    fs <- rows
    _ <- take 1 fs -- Guard against empty rows so that 'last' is safe.
    "  " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n"


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

-- | Writes a message and signals ready for next command.
hPutClient :: Handle -> String -> IO ()
hPutClient h s = hPutStr h ('.' : marshalForClient s)

-- | Writes message, but signals there is more to come.
hPutClientChunk :: Handle -> String -> IO ()
hPutClientChunk h s = hPutStr h (' ' : marshalForClient s)

data DHTQuery nid ni = forall addr r tok.
                        ( Ord addr
                        , Typeable r
                        , Typeable tok
                        , Typeable ni
                        ) => DHTQuery
    { qsearch     :: Search nid addr tok ni r
    , qhandler    :: ni -> nid -> IO ([ni], [r], tok) -- ^ Invoked on local node, when there is no query destination.
    , qshowR      :: r -> String
    , qshowTok    :: tok -> Maybe String
    , qresultAddr :: r -> nid
    }

data DHTAnnouncable = forall dta tok ni r.
                        ( Show r
                        , Typeable dta
                        , Typeable tok
                        , Typeable ni
                        , Typeable r
                        ) => DHTAnnouncable
    { announceParseData :: String -> Either String dta
    , announceParseToken :: dta -> String -> Either String tok
    , announceParseAddress :: String -> Either String ni
    , announceSendData :: dta -> tok -> Maybe ni -> IO (Maybe r)
    , announceInterval :: POSIXTime
    }

data DHTLink = forall status linkid params.
                ( Show status
                , Show linkid
                , Typeable status
                , Typeable linkid
                , Typeable params
                ) => DHTLink
    { linkInit    :: params -> IO (Either String status)
    , linkParamParser :: [String] -> Either String params
    , linkStatus  :: IO (Either String status)
    , showLinkStatus :: status -> String
    , linkNewPipe :: String -> linkid -> IO (Either String status)
    , linkUnPipe  :: linkid -> IO (Either String status)
    }

data DHTSearch nid ni = forall addr tok r. DHTSearch
    { searchThread     :: ThreadId
    , searchState      :: SearchState nid addr tok ni r
    , searchShowTok    :: tok -> Maybe String
    , searchResults    :: TVar (Set.Set String)
    }

data DHTPing ni = forall r. DHTPing
    { pingQuery :: [String] -> ni -> IO (Maybe r)
    , pingShowResult :: r -> String
    }

data DHT = forall nid ni. ( Show     ni
                          , Read     ni
                          , ToJSON   ni
                          , FromJSON ni
                          , Ord      ni
                          , Hashable ni
                          , Show     nid
                          , Ord      nid
                          , Hashable nid
                          , Typeable ni
                          , S.Serialize nid
                          ) =>
    DHT
    { dhtBuckets       :: TVar (BucketList ni)
    , dhtSecretKey     :: STM (Maybe SecretKey)
    , dhtPing          :: Map.Map String (DHTPing ni)
    , dhtQuery         :: Map.Map String (DHTQuery nid ni)
    , dhtAnnouncables  :: Map.Map String DHTAnnouncable
    , dhtLinks         :: Map.Map String DHTLink
    , dhtParseId       :: String -> Either String nid
    , dhtSearches      :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
    , dhtFallbackNodes :: IO [ni]
    }

nodesFileName :: String -> String
nodesFileName netname = netname ++ "-nodes.json"

saveNodes :: String -> DHT -> IO ()
saveNodes netname DHT{dhtBuckets} = do
    bkts <- atomically $ readTVar dhtBuckets
    let ns = map fst $ concat $ R.toList bkts
        bs = J.encode ns
        fname = nodesFileName netname
    L.writeFile fname bs

loadNodes :: FromJSON ni => String -> IO [ni]
loadNodes netname = do
    let fname = nodesFileName netname
    attempt <- tryIOError $ do
        J.decode <$> L.readFile fname
         >>= maybe (ioError $ userError "Nothing") return
    either (const $ fallbackLoad fname) return attempt

fallbackLoad :: FromJSON t => FilePath -> IO [t]
fallbackLoad fname = do
    attempt <- tryIOError $ do
        J.decode <$> L.readFile fname
         >>= maybe (ioError $ userError "Nothing") return
    let go r = do
            let m = HashMap.lookup "nodes" (r :: J.Object)
                ns0 = case m of Just (J.Array v) -> V.toList v
                                Nothing        -> []
                ns1 = zip (map J.fromJSON ns0) ns0
                issuc (J.Error _,_) = False
                issuc _             = True
                (ss,fs) = partition issuc ns1
                ns = map (\(J.Success n,_) -> n) ss
            mapM_ print (map snd fs)  >> return ns
    either (const $ return []) go attempt


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
    case attempt of
        Left _   -> return False
        Right ns -> do fork $ do
                         myThreadId >>= flip labelThread ("pinging."++fname)
                         putStrLn $ "Forked "++show fname
                         withTaskGroup ("withTaskGroup."++fname) 10 $ \g -> do
                           mapM_ (\n -> forkTask g (show n) $ void $ ping [] n)
                                 (ns `asTypeOf` [])
                         putStrLn $ "Load finished "++show fname
                       return True
pingNodes _ _ = return False



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)
    -> Handle
    -> Either String ([ni],[r],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 -> Handle -> 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,()))

data Session = Session
    { netname           :: String
    , dhts              :: Map.Map String DHT
    , externalAddresses :: IO [SockAddr]
    , swarms            :: Mainline.SwarmsDatabase
    , toxkeys           :: TVar Tox.AnnouncedKeys
    , userkeys          :: TVar [(SecretKey,PublicKey)]
    , roster            :: Roster
    , announcer         :: Announcer
    , signalQuit        :: MVar ()
    }

clientSession :: Session -> t1 -> t -> Handle -> IO ()
clientSession s@Session{..} sock cnum h = do
    line <- dropWhile isSpace <$> hGetLine h
    let (c,args) = second (dropWhile isSpace) $ break isSpace line
        cmd0 :: IO () -> IO ()
        cmd0 action = action >> clientSession s sock cnum h
        switchNetwork dest = do hPutClient h ("Network: "++dest)
                                clientSession s{netname=dest} sock cnum h
        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)
    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 =
            [ ["stop"]
            , ["quit"]
            , ["pid"]
            , ["external-ip"]
            , ["threads"]
            , ["mem"]
            , ["ls"]
            , ["k"]
            , ["roster"]
            , ["g"]
            , ["p"]
            , ["a"]
            , ["s"]
            , ["x"]
            , ["save"]
            , ["load"]
            , ["swarms"]
            , ["peers"]
            , ["toxids"]
            , ["c"]
            , ["help"]
            ]
    case (map toLower c,args) of
        (n, _) | n `elem` Map.keys dhts -> switchNetwork n
        (x,_) | not (null (strp x))
              , x `notElem` map head sessionCommands -> cmd0 $ do
                hPutClient h $ "error."

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

        ("quit", _) -> hPutClient h "" >> hClose 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", _) -> cmd0 $ do
                    ts <- threadsInformation
                    tm <- getCurrentTime
                    r <- forM ts $ \(tid,PerThread{..}) -> do
                        stat <- threadStatus tid
                        let showStat (ThreadBlocked reason) = show reason
                            showStat stat                   = show stat
                        return [show lbl,show (diffUTCTime tm startTime),showStat stat]
                    hPutClient h $ showColumns r
#endif
        ("mem", s) -> cmd0 $ do
                    case s of
                        "gc" -> do hPutClient h "Performing garbage collection..."
                                   performMajorGC
                        "" -> do
                            is_enabled <- getGCStatsEnabled
                            if is_enabled
                             then do
                                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)
                                        ]
                                hPutClient h $ showReport r
                            else hPutClient h "Run with +RTS -T to obtain live memory-usage information."
                        _ -> hPutClient h "error."

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

        -- "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
        ("k", s) | ""           <- strp s -> cmd0 $ do
                        ks <- atomically $ readTVar userkeys
                        hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) ks
                 | "gen"        <- strp s -> cmd0 $ do
                        secret <- generateSecretKey
                        let pubkey = toPublic secret
                        oldks <- atomically $ do
                            ks <- readTVar userkeys
                            modifyTVar userkeys ((secret,pubkey):)
                            addRoster roster secret
                            return ks
                        let asString = show . Tox.key2id
                        hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) oldks
                                                  ++ [mappend " *" . show . Tox.key2id $ pubkey]
                 | "secrets"    <- strp s -> cmd0 $ do
                        ks <- atomically $ readTVar userkeys
                        skey <- maybe (return Nothing) (atomically . dhtSecretKey)
                                      $ Map.lookup netname dhts
                        hPutClient h . showReport $ map mkrow ks ++ case skey >>= encodeSecret of
                            Just x  -> [("",""),("dht-key:",B.unpack x)]
                            Nothing -> []
                 | ("add":secs) <- words s
                 , mbSecs <- map (decodeSecret . B.pack) secs
                 , all isJust mbSecs -> cmd0 $ 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 <- readTVar userkeys
                            modifyTVar userkeys (pairs ++)
                            forM pairs $ \(sk,_) -> addRoster roster sk
                            return oldks
                        hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) oldks
                                                  ++ map (mappend " *" . show . Tox.key2id .snd) pairs
                 | ("del":secs) <- words s
                 , mbSecs <- map (decodeSecret . B.pack) secs
                 , all isJust mbSecs -> cmd0 $ 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
                            modifyTVar userkeys (filter (`notElem` pairs) )
                            forM pairs $ \(_,pk) -> delRoster roster pk
                            readTVar userkeys
                        hPutClient h . showReport $ map mkrow ks
        ("roster", s) -> cmd0 $ join $ atomically $ do
            dns <- dnsPresentation roster
            fs <- HashMap.toList <$> friendRequests roster
            let showFriend (remotekey,fr) =
                    ("  " ++ show remotekey, T.unpack $ T.decodeUtf8 $ Tox.friendRequestText fr)
                showAccount (me,cs) =
                    [(show me,"")] ++ map showFriend cs
                frs = fs >>= showAccount
            return $ do
                hPutClientChunk h $ unlines [ dns, "", "Friend Requests" ]
                hPutClient h $ showReport frs
        ("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

        ("p", s) | Just DHT{..} <- Map.lookup netname dhts
                    -> cmd0 $ do
                        -- arguments: method
                        --            data
                        --            token
                        --            (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{..} = do
                                let dta = announceParseData dtastr
                                    tok = dta >>= flip announceParseToken tokenstr
                                case liftA2 (,) dta tok of
                                    Left e    -> hPutClient h e
                                    Right nid -> go nid >>= either (hPutClient h) (hPutClient h . show)
                              where
                                go | null destination = fmap (maybe (Left "Timeout.") Right)
                                                        . flip (uncurry announceSendData) Nothing
                                   | otherwise        = case announceParseAddress destination of
                                        Right ni -> fmap (maybe (Left "Timeout.") Right)
                                                    . flip (uncurry announceSendData) (Just ni)
                                        Left  e  -> const $ return $ Left ("Bad destination: "++e)
                        maybe (hPutClient h ("Unsupported method: "++method))
                              goTarget
                              $ Map.lookup method dhtAnnouncables

        ("a", s) | Just DHT{..} <- Map.lookup netname dhts
                 , not (null s)
                    -> cmd0 $ do
                        let (op:method,xs) = break isSpace $ dropWhile isSpace s
                            (dtastr,ys)    = break isSpace $ dropWhile isSpace xs
                            a = Map.lookup method dhtAnnouncables
                            q = Map.lookup method dhtQuery
                            doit :: Char -> proxy ni -> Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
                            doit '+' _ = schedule
                            doit '-' _ = cancel
                            doit _   _ = \_ _ _ _ -> hPutClient h "Starting(+) or canceling(-)?"
                            matchingResult ::
                                ( Typeable sr
                                , Typeable stok
                                , Typeable sni
                                , Typeable pr
                                , Typeable ptok
                                , Typeable pni )
                                            => Search nid addr stok sni sr
                                            -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr))
                                            -> Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
                            matchingResult _ _ = liftA3 (\a b c -> (a,b,c)) eqT eqT eqT
                            mameth = do
                                DHTAnnouncable { announceSendData
                                               , announceParseData
                                               , announceInterval } <- a
                                DHTQuery { qsearch
                                         , qresultAddr } <- q
                                (Refl,Refl,nr@Refl) <- matchingResult qsearch announceSendData
                                dta <- either (const Nothing) Just $ announceParseData dtastr
                                return $ do
                                    akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr)
                                    doit op nr announcer
                                               akey
                                               (AnnounceMethod qsearch announceSendData dhtBuckets
                                                               (qresultAddr dta)
                                                               announceInterval)
                                               dta
                        fromMaybe (hPutClient h "error.") mameth

        ("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
                        if b then hPutClient h $ "Pinging " ++ nodesFileName netname ++ "."
                             else 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 :-> Down tm) = [ show cnt, show k, show (now - tm) ]
                                where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb)
                        hPutClient h $ showColumns entries
        ("c", s) | "" <- strp s -> cmd0 $ do
                        let combinedLinkMap = Map.unions $map (dhtLinks . snd) (Map.toList dhts)
                        -- TODO: list all connections
                        let connections =  [[{-TODO-}]]
                        hPutClient h $ showColumns connections
        ("c", s) -> cmd0 $ do
                        let combinedLinkMap = Map.unions $map (dhtLinks . snd) (Map.toList dhts)
                        -- form new connection according of type corresponding to parameter
                        let ws = words s
                        result
                          <- case ws of
                              (linktype:rest)
                                -> case (Map.lookup (head ws) combinedLinkMap) of
                                    Nothing -> return . Left $ "I don't know a '" ++ head ws ++ "' link type."
                                    Just l@(DHTLink
                                              { linkInit        {- :: params   -> IO (Either String status) -}
                                              , linkParamParser {- :: [String] -> Either String params      -}
                                              , showLinkStatus  {- :: status   -> String                    -}
                                              }) -> case linkParamParser rest of
                                                        Left er -> return $ Left er
                                                        Right params -> fmap showLinkStatus <$> linkInit params
                              _ -> return $ Left "parse error"
                        case result of
                            Left er -> hPutClient h er
                            Right statusstr -> hPutClient h statusstr

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

                dhtkeys, announcables, links, 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
                links = map (tolist . ("c "++)) $ Map.keys dhtLinks
                ks = [["k gen"],["k public"],["k secret"]]
                allcommands = sortBy (comparing head) $ concat [sessionCommands, dhtkeys, announcables, links, ks, queries, gs,xs]

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

        _    -> cmd0 $ hPutClient h "error."


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
    , ip6bt   :: Bool
    , ip6tox  :: Bool
    }
 deriving (Eq,Show)

sensibleDefaults :: Options
sensibleDefaults = Options
    { portbt  = "6881"
    , porttox = "33445"
    , ip6bt   = True
    , ip6tox  = True
    }

-- bt=<port>,tox=<port>
-- -4
parseArgs :: [String] -> Options -> Options
parseArgs []          opts = opts
parseArgs ("-4":args) opts = parseArgs args opts
    { ip6bt  = False
    , ip6tox = False }
parseArgs (arg:args) opts        = parseArgs args opts
    { portbt  = fromMaybe (portbt opts)  $ Prelude.lookup "bt"  ports
    , porttox = fromMaybe (porttox opts) $ Prelude.lookup "tox" 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

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 (hPutStrLn stderr . ("bt-peers.dat: "++))
           (atomically . writeTVar (Mainline.contactInfo swarms))
           (peerdb >>= S.decodeLazy)

    announcer <- forkAnnouncer

    (quitBt,btdhts,btips,baddrs) <- case portbt opts of
        "" -> return (return (), Map.empty,return [],[])
        p  -> do
            addr <- getBindAddress p (ip6bt opts)
            (bt,btR) <- 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)
                                        , qresultAddr = Mainline.nodeId
                                        })
                                    , ("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)
                                        , qresultAddr = (read . show) -- TODO: InfoHash -> NodeId
                                        })
                                    ]
                    , dhtParseId  = readEither :: String -> Either String Mainline.NodeId
                    , dhtSearches = mainlineSearches
                    , dhtFallbackNodes = Mainline.bootstrapNodes wantip
                    , dhtAnnouncables = Map.fromList
                                    [ ("peer", DHTAnnouncable { announceSendData = \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?
                                                              })
                                    , ("port", DHTAnnouncable { announceParseData = readEither
                                                              , announceParseToken = \_ _ -> return ()
                                                              , announceParseAddress = const $ Right ()
                                                              , announceSendData = \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.
                                                              })]

                    , dhtLinks = Map.fromList
                                    [ {- TODO -}
                                    ]
                    , dhtSecretKey = return Nothing
                    }
                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

    (mbtox,quitTox,toxdhts,toxips,taddrs) <- case porttox opts of
        "" -> return (Nothing,return (), Map.empty, return [],[])
        toxport -> do
            addrTox <- getBindAddress toxport (ip6tox opts)
            crypto <- Tox.newCrypto
            netCryptoSessionsState <- Tox.newSessionsState crypto Tox.defaultUnRecHook Tox.defaultCryptoDataHooks
            tox <- Tox.newTox keysdb addrTox (Just netCryptoSessionsState)
            quitTox <- Tox.forkTox tox

            toxSearches <- atomically $ newTVar Map.empty

            let toxDHT bkts = 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)
                                        , qhandler = (\ni -> fmap Tox.unwrapNodes
                                                                . Tox.getNodesH (Tox.toxRouting tox) ni
                                                                . Tox.GetNodes)
                                        , qshowR = show -- NodeInfo
                                        , qshowTok = (const Nothing)
                                        , qresultAddr = Tox.nodeId
                                        })
                                    , ("toxid", DHTQuery
                                        { qsearch = (Tox.toxidSearch (Tox.onionTimeout tox)
                                                                          (Tox.toxCryptoKeys tox)
                                                                          (Tox.toxOnion 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 = (fmap show) -- Nonce32
                                        , qresultAddr = Tox.key2id . Tox.rendezvousKey
                                        })
                                    ]
                    , dhtParseId  = readEither :: String -> Either String Tox.NodeId
                    , dhtSearches = toxSearches
                    , dhtFallbackNodes = return []
                    , dhtAnnouncables = Map.fromList
                                    [ ("toxid", DHTAnnouncable { announceSendData = \pubkey token -> \case
                                                                    Just ni ->
                                                                        Tox.putRendezvous
                                                                            (Tox.onionTimeout tox)
                                                                            (Tox.toxCryptoKeys tox)
                                                                            (Tox.toxOnion tox)
                                                                            (pubkey :: PublicKey)
                                                                            (token :: Nonce32)
                                                                            ni
                                                                    Nothing -> return Nothing
                                                               , announceParseAddress = readEither
                                                               , announceParseToken = const $ readEither
                                                               , announceParseData = fmap Tox.id2key . readEither

                    -- 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 = 15

                                                               })
                                    , ("dhtkey", DHTAnnouncable { announceSendData = \pubkey () -> \case
                                                                    Just addr -> do
                                                                        dkey <- Tox.getContactInfo tox
                                                                        sendMessage
                                                                            (Tox.toxToRoute tox)
                                                                            (addr :: Tox.AnnouncedRendezvous)
                                                                            (pubkey,Tox.OnionDHTPublicKey dkey)
                                                                        return $ Just ()
                                                                    Nothing -> return Nothing
                                                               , announceParseAddress = readEither
                                                               , announceParseToken = \_ _ -> return ()
                                                               , announceParseData = fmap Tox.id2key . readEither

                    -- 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", DHTAnnouncable { announceSendData = \pubkey nospam -> \case
                                                                    Just addr -> do
                                                                        let fr = Tox.FriendRequest nospam txt
                                                                            -- nospam = 0xD64A8B00
                                                                            txt = "Testing Friend Request!"
                                                                        sendMessage
                                                                            (Tox.toxToRoute tox)
                                                                            (addr :: Tox.AnnouncedRendezvous)
                                                                            (pubkey,Tox.OnionFriendRequest fr)
                                                                        return $ Just ()
                                                                    Nothing -> return Nothing
                                                               , announceParseAddress = readEither
                                                               , announceParseData = fmap Tox.id2key . readEither
                                                               , announceParseToken = \pubkey nospamstr -> do
                                                                        Tox.NoSpam nospam chksum <- readEither nospamstr
                                                                        maybe (Right ())
                                                                              (Tox.verifyChecksum pubkey)
                                                                              chksum
                                                                        return nospam

                    -- 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
                                                               })]
                    , dhtLinks = Map.fromList
                                    [ {- TODO -}
                                    ]
                    , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox)
                    }
                dhts = Map.fromList $
                        ("tox4", toxDHT Tox.routing4)
                        : if ip6tox opts
                            then [ ("tox6", toxDHT Tox.routing6) ]
                            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])
    _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs

    let dhts = Map.union btdhts toxdhts

    waitForSignal <- do
        signalQuit <- newEmptyMVar
        (toxids,rstr) <- fromMaybe ((,) <$> atomically (newTVar []) <*> newRoster) $ do
            tox <- mbtox
            return $ return ( userKeys (Tox.toxCryptoKeys tox), Tox.toxRoster tox )
        let session = clientSession $ Session
                { netname           = concat $ take 1 $ Map.keys dhts -- initial default DHT
                , dhts              = dhts  -- all DHTs
                , signalQuit        = signalQuit
                , swarms            = swarms
                , toxkeys           = keysdb
                , userkeys          = toxids
                , roster            = rstr
                , externalAddresses = liftM2 (++) btips toxips
                , announcer         = announcer
                }
        srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
        return $ do
            () <- takeMVar signalQuit
            quitListening srv


    forM_ (Map.toList dhts)
          $ \(netname, dht@DHT { dhtBuckets = bkts
                               , dhtQuery = qrys
                               , dhtPing = pings
                               , dhtFallbackNodes = getBootstrapNodes }) -> 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)
            case Map.lookup "node" qrys of
                Just DHTQuery { qsearch = srch } -> do
                    case eqT of
                        Just witness -> bootstrap (isNodesSearch witness srch) bkts ping btSaved fallbackNodes
                        _            -> error $ "Missing node-search for "++netname++"."
                    saveNodes netname dht
                Nothing -> return ()
        return ()

    waitForSignal

    stopAnnouncer announcer
    quitBt
    quitTox

    swarmsdb <- atomically $ readTVar (Mainline.contactInfo swarms)
    L.writeFile "bt-peers.dat" $ S.encodeLazy swarmsdb