summaryrefslogtreecommitdiff
path: root/examples/dhtd.hs
blob: 0b208362f590c50cbe8eab9829af41c7a3ca6d8d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
{-# 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.Concurrent.STM
import Control.DeepSeq
import Control.Exception
import Control.Monad
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 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 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.Handlers as Tox
import Data.Typeable

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

showColumns :: [[[Char]]] -> [Char]
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
                        )=> DHTQuery
    { qsearch  :: Search nid addr tok ni r
    , qhandler :: ni -> nid -> IO ([ni], [r], tok)
    , qshowR   :: r -> String
    , qshowTok :: tok -> Maybe String
    }

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 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)
    , dhtPing          :: ni -> IO Bool
    , dhtQuery         :: Map.Map String (DHTQuery nid ni)
    , 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 $ return []) return attempt

pingNodes :: String -> DHT -> IO Bool
pingNodes netname DHT{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 $ dhtPing n)
                                 (ns `asTypeOf` [])
                         putStrLn $ "Load finished "++show fname
                       return True



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
    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
    , signalQuit        :: MVar ()
    }

clientSession :: Session -> t1 -> t -> Handle -> IO ()
clientSession s@Session{..} sock cnum h = do
    line <- map toLower . 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
    case (c,args) of
        ("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", s) | Just DHT{dhtPing} <- Map.lookup netname dhts
                    -> cmd0 $ do
                        case readEither s of
                          Right addr -> do result <- dhtPing addr
                                           let rs = [" ", show result]
                                           hPutClient h $ unlines rs
                          Left er -> hPutClient h er
        ("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

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

        (n, _) | n `elem` Map.keys dhts -> switchNetwork n

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


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)

    (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
            let mainlineDHT bkts wantip = DHT
                    { dhtBuckets = bkts btR
                    , dhtPing    = Mainline.ping bt
                    , dhtQuery   = Map.fromList
                                    [ ("node", DHTQuery (Mainline.nodeSearch bt)
                                                        (\ni -> fmap Mainline.unwrapNodes
                                                                . Mainline.findNodeH btR ni
                                                                . flip Mainline.FindNode (Just Want_Both))
                                                        show
                                                        (const Nothing))
                                    , ("peer", DHTQuery (Mainline.peerSearch bt)
                                                        (\ni -> fmap Mainline.unwrapPeers
                                                                . Mainline.getPeersH btR swarms ni
                                                                . flip Mainline.GetPeers (Just Want_Both)
                                                                . (read . show)) -- TODO: InfoHash -> NodeId
                                                        (show . pPrint)
                                                        (Just . show))
                                    ]
                    , dhtParseId  = readEither :: String -> Either String Mainline.NodeId
                    , dhtSearches = mainlineSearches
                    , dhtFallbackNodes = Mainline.bootstrapNodes wantip
                    }
                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

    (quitTox,toxdhts,toxips,taddrs) <- case porttox opts of
        "" -> return (return (), Map.empty, return [],[])
        toxport -> do
            addrTox <- getBindAddress toxport (ip6tox opts)
            tox <- Tox.newTox keysdb addrTox
            quitTox <- Tox.forkTox tox

            toxSearches <- atomically $ newTVar Map.empty

            let toxDHT bkts = DHT
                    { dhtBuckets = bkts (Tox.toxRouting tox)
                    , dhtPing    = Tox.ping (Tox.toxDHT tox)
                    , dhtQuery   = Map.fromList
                                    [ ("node", DHTQuery (Tox.nodeSearch $ Tox.toxDHT tox)
                                                        (\ni -> fmap Tox.unwrapNodes
                                                                . Tox.getNodesH (Tox.toxRouting tox) ni
                                                                . Tox.GetNodes)
                                                        show
                                                        (const Nothing))
                                    ]
                    , dhtParseId  = readEither :: String -> Either String Tox.NodeId
                    , dhtSearches = toxSearches
                    , dhtFallbackNodes = return []
                    }
                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 (quitTox, dhts, ips, [addrTox])

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

    let dhts = Map.union btdhts toxdhts

    waitForSignal <- do
        signalQuit <- newEmptyMVar
        let session = clientSession $ Session
                { netname           = concat $ take 1 $ Map.keys dhts -- initial default DHT
                , dhts              = dhts  -- all DHTs
                , signalQuit        = signalQuit
                , swarms            = swarms
                , toxkeys           = keysdb
                , externalAddresses = liftM2 (++) btips toxips
                }
        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 = ping
                             , 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
        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 ()

    {-
    let bkts4 = Mainline.routing4 btR
    (fallbackNodes4,fallbackNodes6) <- case portbt opts of
        [] -> return ([],[])
        _  -> do
            btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo]
            putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4."
            fallbackNodes4 <- Mainline.bootstrapNodes Want_IP4
            fork $ do
                myThreadId >>= flip labelThread "bootstrap.Mainline4"
                bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4
                saveNodes "bt4" (dhts Map.! "bt4")

            fallbackNodes6 <- case ip6bt opts of
                True -> do
                    btSaved6 <- loadNodes "bt6"
                    putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6."
                    let bkts6 = Mainline.routing6 btR
                    fallbackNodes6 <- Mainline.bootstrapNodes Want_IP6
                    fork $ do
                        myThreadId >>= flip labelThread "bootstrap.Mainline6"
                        bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6
                        saveNodes "bt6" (dhts Map.! "bt6")
                    return fallbackNodes6
                False -> return []
            return (fallbackNodes4,fallbackNodes6)

    (toxSaved4, toxSaved6) <- case porttox opts of
        [] -> return ([],[])
        _  -> do
            toxSaved4 <- loadNodes "tox4"
            putStrLn $ "Loaded "++show (length toxSaved4)++" nodes for tox4"
            fork $ do
                myThreadId >>= flip labelThread "bootstrap.Tox4"
                bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing4 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved4 []
                saveNodes "tox4" (dhts Map.! "tox4")

            toxSaved6 <- case ip6tox opts of
                True ->  do
                    toxSaved6 <- loadNodes "tox6"
                    putStrLn $ "Loaded "++show (length toxSaved6)++" nodes for tox6"
                    fork $ do
                        myThreadId >>= flip labelThread "bootstrap.Tox6"
                        bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing6 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved6 []
                        saveNodes "tox6" (dhts Map.! "tox6")
                    return toxSaved6
                False -> return []
            return (toxSaved4,toxSaved6)

    hPutStr stderr $ showReport $ map (("bootstrap (IPv4)",) . show) fallbackNodes4
                                  ++ map (("bootstrap (IPv6)",) . show) fallbackNodes6
    -}

    waitForSignal

    quitBt
    quitTox

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