summaryrefslogtreecommitdiff
path: root/examples/dhtd.hs
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2019-09-28 13:43:29 -0400
committerJoe Crayne <joe@jerkface.net>2020-01-01 19:27:53 -0500
commit11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch)
tree5716463275c2d3e902889db619908ded2a73971c /examples/dhtd.hs
parentadd2c76bced51fde5e9917e7449ef52be70faf87 (diff)
Factor out some new libraries
word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r--examples/dhtd.hs1826
1 files changed, 0 insertions, 1826 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
deleted file mode 100644
index 2772416b..00000000
--- a/examples/dhtd.hs
+++ /dev/null
@@ -1,1826 +0,0 @@
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE NamedFieldPuns #-}
9{-# LANGUAGE NondecreasingIndentation #-}
10{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE PartialTypeSignatures #-}
12{-# LANGUAGE PatternSynonyms #-}
13{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RecordWildCards #-}
15{-# LANGUAGE RecursiveDo #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE TupleSections #-}
18{-# LANGUAGE TypeFamilies #-}
19{-# LANGUAGE TypeOperators #-}
20{-# LANGUAGE ViewPatterns #-}
21
22module Main where
23
24import Control.Arrow
25import Control.Applicative
26import Control.Concurrent.STM
27import Control.Concurrent.STM.TMChan
28import Control.Exception
29import Control.Monad
30import Control.Monad.IO.Class (liftIO)
31import Data.Array.MArray (getAssocs)
32import Data.Bool
33import Data.Bits (xor)
34import Data.Char
35import Data.Conduit as C
36import qualified Data.Conduit.List as C
37import Data.Function
38import Data.Functor.Identity
39import Data.Hashable
40import Data.List
41import qualified Data.IntMap.Strict as IntMap
42import qualified Data.Map.Strict as Map
43import Data.Maybe
44import qualified Data.Set as Set
45import qualified Data.XML.Types as XML
46import GHC.Conc (threadStatus,ThreadStatus(..))
47import GHC.Stats
48import Network.Socket
49import System.Environment
50import System.IO
51import System.Mem
52import System.Posix.Process
53import Text.PrettyPrint.HughesPJClass
54import Text.Printf
55import Text.Read
56#ifdef THREAD_DEBUG
57import Control.Concurrent.Lifted.Instrument
58#else
59import Control.Concurrent.Lifted
60import GHC.Conc (labelThread)
61#endif
62import qualified Data.HashMap.Strict as HashMap
63import qualified Data.Text as T
64import qualified Data.Text.Encoding as T
65import System.Posix.Signals
66
67import Announcer
68import Announcer.Tox
69import ToxManager
70import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys)
71import DebugUtil
72import Network.UPNP as UPNP
73import Network.Address hiding (NodeId, NodeInfo(..))
74import Network.QueryResponse
75import qualified Network.QueryResponse.TCP as TCP
76import Network.StreamServer
77import Network.Kademlia.Bootstrap (refreshBuckets,bootstrap)
78import Network.Kademlia.CommonAPI
79import Network.Kademlia.Persistence
80import Network.Kademlia.Routing as R
81import Network.Kademlia.Search
82import qualified Network.BitTorrent.MainlineDHT as Mainline
83import qualified Network.Tox as Tox
84import qualified Data.ByteString.Lazy as L
85import qualified Data.ByteString.Char8 as B
86import Control.Concurrent.Tasks
87import System.IO.Error
88import qualified Data.Serialize as S
89import Network.BitTorrent.DHT.ContactInfo as Peers
90import qualified Data.MinMaxPSQ as MM
91import Data.Wrapper.PSQ as PSQ (pattern (:->))
92import qualified Data.Wrapper.PSQ as PSQ
93import Data.Ord
94import Data.Time.Clock.POSIX
95import qualified Network.Tox.DHT.Transport as Tox
96import qualified Network.Tox.DHT.Handlers as Tox
97import qualified Network.Tox.Onion.Transport as Tox
98import qualified Network.Tox.Onion.Handlers as Tox
99import qualified Network.Tox.Crypto.Transport as Tox
100import qualified Network.Tox.TCP as TCP
101import qualified TCPProber as TCP
102import Data.Typeable
103import Network.Tox.ContactInfo as Tox
104import OnionRouter
105import qualified Data.Word64Map as W64
106import Network.Tox.AggregateSession
107import qualified Network.Tox.Session as Tox (Session)
108 ;import Network.Tox.Session hiding (Session)
109
110-- Presence imports.
111import Connection.Tcp (TCPStatus)
112import ConsoleWriter
113import Presence
114import XMPPServer
115import Connection
116import ToxToXMPP
117import XMPPToTox
118import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp,TCPStatus)
119import DPut
120import DebugTag
121import LocalChat
122import ToxChat
123import MUC
124
125
126pshow :: Show a => a -> B.ByteString
127pshow = B.pack . show
128
129marshalForClient :: String -> String
130marshalForClient s = show (length s) ++ ":" ++ s
131
132marshalForClientB :: B.ByteString -> B.ByteString
133marshalForClientB s = B.concat [pshow (B.length s),":",s]
134
135data ClientHandle = ClientHandle Handle (MVar Int)
136
137-- | Writes a message and signals ready for next command.
138hPutClient :: ClientHandle -> String -> IO ()
139hPutClient (ClientHandle h hstate) s = do
140 st <- takeMVar hstate
141 hPutStr h ('.' : marshalForClient s)
142 putMVar hstate 1 -- ready for input
143
144-- | Writes a message and signals ready for next command.
145hPutClientB :: ClientHandle -> B.ByteString -> IO ()
146hPutClientB (ClientHandle h hstate) s = do
147 st <- takeMVar hstate
148 B.hPutStr h ('.' `B.cons` marshalForClientB s)
149 putMVar hstate 1 -- ready for input
150
151-- | Writes message, but signals there is more to come.
152hPutClientChunk :: ClientHandle -> String -> IO ()
153hPutClientChunk (ClientHandle h hstate) s = do
154 st <- takeMVar hstate
155 hPutStr h (' ' : marshalForClient s)
156 putMVar hstate 2 -- ready for more output
157
158
159{-
160pingNodes :: String -> DHT -> IO Bool
161pingNodes netname DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "ping" dhtPing = do
162 let fname = nodesFileName netname
163 attempt <- tryIOError $ do
164 J.decode <$> L.readFile fname
165 >>= maybe (ioError $ userError "Nothing") return
166-}
167
168asProxyTypeOf :: a -> proxy a -> a
169asProxyTypeOf = const
170
171pingNodes :: String -> DHT -> IO (Maybe Int)
172pingNodes netname dht@DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "ping" dhtPing = do
173 let fname = nodesFileName netname
174 ns <- loadNodes netname
175 case ns of
176 [] -> return Nothing
177 _ -> do
178 fork $ do
179 myThreadId >>= flip labelThread ("pinging."++fname)
180 putStrLn $ "Forked "++show fname
181 withTaskGroup ("withTaskGroup."++fname) 10 $ \g -> do
182 forM_ (ns `asTypeOf` [])
183 $ \n -> forkTask g (show n)
184 $ void
185 $ ping [] n
186 putStrLn $ "Load finished "++show fname
187 return $ Just $ length ns
188pingNodes _ _ = return Nothing
189
190
191
192reportTable :: Show ni => BucketList ni -> [(String,String)]
193reportTable bkts = map (show *** show . fst)
194 $ concat
195 $ zipWith map (map (,) [0::Int ..])
196 $ R.toList
197 $ bkts
198
199reportResult ::
200 String
201 -> (r -> String)
202 -> (tok -> Maybe String)
203 -> (ni -> String)
204 -> ClientHandle
205 -> Either String ([ni],[r],Maybe tok)
206 -> IO ()
207reportResult meth showR showTok showN h (Left e) = hPutClient h e
208reportResult meth showR showTok showN h (Right (ns,rs,tok)) = do
209 hPutClient h $ showReport report
210 where
211 report = intercalate [("","")] [ tok_r , node_r , result_r ]
212
213 tok_r = maybe [] (pure . ("token:",)) $ showTok =<< tok
214
215 node_r = map ( ("n",) . showN ) ns
216
217 result_r | (meth=="node") = []
218 | otherwise = map ( (take 1 meth,) . showR ) rs
219
220-- example:
221-- * 10 peer 141d6c6ee2810f46d28bbe8373d4f454a4122535
222-- - 1 peer 141d6c6ee2810f46d28bbe8373d4f454a4122535
223-- 22 node 141d6c6ee2810f46d28bbe8373d4f454a4122535
224--
225-- key: '*' in progress
226-- '-' stopped
227-- ' ' finished
228showSearches :: ( Show nid
229 , Ord nid
230 , Hashable nid
231 , Ord ni
232 , Hashable ni
233 ) => Map.Map (String,nid) (DHTSearch nid ni) -> IO String
234showSearches searches = do
235 tups <- forM (Map.toList searches) $ \((meth,nid),DHTSearch{..}) -> do
236 (is'fin, cnt) <- atomically $
237 (,) <$> searchIsFinished searchState
238 <*> (Set.size <$> readTVar searchResults)
239 tstat <- threadStatus searchThread
240 let stat = case tstat of
241 _ | is'fin -> ' '
242 ThreadFinished -> '-'
243 ThreadDied -> '-'
244 _ -> '*'
245 return (stat,show cnt,meth,show nid)
246 let cnt'width = maximum $ map (\(_,cnt,_,_)->length cnt) tups
247 mth'width = maximum $ map (\(_,_,mth,_)->length mth) tups
248 return $ do -- List monad.
249 (stat,cnt,meth,nid) <- tups
250 printf " %c %-*s %-*s %s\n" stat cnt'width cnt mth'width meth nid
251
252forkSearch ::
253 ( Ord nid
254 , Hashable nid
255 , Ord ni
256 , Hashable ni
257 , Show nid
258 ) =>
259 String
260 -> nid
261 -> DHTQuery nid ni
262 -> TVar (Map.Map (String,nid) (DHTSearch nid ni))
263 -> TVar (BucketList ni)
264 -> ThreadId
265 -> TVar (Maybe (IO ()))
266 -> STM ()
267forkSearch method nid DHTQuery{qsearch,qshowTok,qshowR} dhtSearches dhtBuckets tid kvar = do
268 ns <- R.kclosest (searchSpace qsearch) (searchK qsearch) nid <$> readTVar dhtBuckets
269 st <- newSearch qsearch nid ns
270 results <- newTVar Set.empty
271 let storeResult r = modifyTVar' results (Set.insert (qshowR r))
272 >> return True
273 new = DHTSearch
274 { searchThread = tid
275 , searchState = st
276 , searchShowTok = qshowTok
277 , searchResults = results
278 }
279 modifyTVar' dhtSearches $ Map.insert (method,nid) new
280 -- Finally, we write the search loop action into a tvar that will be executed in a new
281 -- thread.
282 writeTVar kvar $ Just $ searchLoop qsearch nid storeResult st
283
284reportSearchResults :: (Show t, Ord t1, Ord t, Hashable t) =>
285 String -> ClientHandle -> DHTSearch t1 t -> IO ()
286reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} = do
287 (ns,rs) <- atomically $ do
288 mm <- readTVar $ searchInformant searchState
289 rset <- readTVar searchResults
290 let ns = map (\(MM.Binding ni tok _) -> (ni,tok))
291 $ MM.toList mm
292 rs = Set.toList rset
293 return (ns,rs)
294 let n'width = succ $ maximum $ map (length . show . fst) ns
295 showN (n,tok) = take n'width (show n ++ repeat ' ') ++ (fromMaybe "" $ searchShowTok =<< tok)
296 ns' = map showN ns
297 reportResult meth id (const Nothing) id h (Right (ns',rs, Just ()))
298
299data ConnectionManager = forall status k. ConnectionManager { typedManager :: Connection.Manager status k }
300
301data Session = Session
302 { netname :: String
303 , selectedKey :: Maybe PublicKey
304 , dhts :: Map.Map String DHT
305 , externalAddresses :: IO [SockAddr]
306 , swarms :: Mainline.SwarmsDatabase
307 , toxkeys :: TVar Tox.AnnouncedKeys
308 , roster :: Tox.ContactInfo JabberClients
309 , announceToLan :: IO ()
310 , connectionManager :: Maybe ConnectionManager
311 , onionRouter :: OnionRouter
312 , announcer :: Announcer
313 , signalQuit :: IO ()
314 , mbTox :: Maybe (Tox.Tox JabberClients)
315 }
316
317exceptionsToClient :: ClientHandle -> IO () -> IO ()
318exceptionsToClient (ClientHandle h hstate) action =
319 action `catch` \(SomeException e) -> do
320 st <- takeMVar hstate
321 when (st /= 1) $ do
322 hPutStr h ('.': marshalForClient (show e))
323 putMVar hstate 1 -- ready for input
324
325hGetClientLine :: ClientHandle -> IO String
326hGetClientLine (ClientHandle h hstate) = do
327 st <- takeMVar hstate
328 -- st should be 1
329 x <- hGetLine h
330 putMVar hstate 0 -- ready for output
331 return x
332
333hCloseClient :: ClientHandle -> IO ()
334hCloseClient (ClientHandle h hstate) = do
335 st <- takeMVar hstate
336 hClose h
337 putMVar hstate 3 -- closed file handle
338
339clientSession0 :: Session -> t1 -> t -> Handle -> IO ()
340clientSession0 s sock cnum h = do
341 hstate <- newMVar 1 -- ready for input
342 clientSession s sock cnum (ClientHandle h hstate)
343 `catch` \e -> if isEOFError e then return ()
344 else throwIO e
345
346
347parseDebugTag :: String -> Maybe DebugTag
348parseDebugTag s' = readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s')
349
350showPolicy TryingToConnect = "*"
351showPolicy OpenToConnect = "o"
352showPolicy RefusingToConnect = "x"
353
354waitOn :: (nid -> ni -> (result -> IO ()) -> IO ())
355 -> nid -> ni -> IO result
356waitOn bg nid ni = do
357 mvar <- newEmptyMVar
358 bg nid ni $ putMVar mvar
359 takeMVar mvar
360
361clientSession :: Session -> t1 -> t -> ClientHandle -> IO ()
362clientSession s@Session{..} sock cnum h = do
363 line <- dropWhile isSpace <$> hGetClientLine h
364 let (c,args) = second (dropWhile isSpace) $ break isSpace line
365 cmd0 :: IO () -> IO ()
366 cmd0 action = exceptionsToClient h action >> clientSession s sock cnum h
367 switchNetwork dest = do hPutClient h ("Network: "++dest)
368 clientSession s{netname=dest} sock cnum h
369 switchKey key = clientSession s { selectedKey = key } sock cnum h
370 twoWords str = let (word1,a1) = break isSpace (dropWhile isSpace str)
371 (word2,a2) = break isSpace (dropWhile isSpace a1)
372 in (word1,word2,drop 1 a2)
373 strp = B.unpack . fst . until snd dropEnd . (,False) . B.dropWhile isSpace . B.pack
374 where
375 dropEnd (x,_) =
376 case B.unsnoc x of
377 Just (str,c) | isSpace c -> (str,False)
378 _ -> (x,True)
379 allDebugTags :: [DebugTag]
380 allDebugTags = [minBound .. maxBound]
381 showDebugTags = do
382 vs <- mapM getVerbose allDebugTags
383 let f True = "v"
384 f False = "-"
385 hPutClient h $ showReport (zip (map (drop 1 . show) allDebugTags) (map f vs))
386 let readHex :: (Read n, Integral n) => String -> Maybe n
387 readHex s = readMaybe ("0x" ++ s)
388 let mkrow :: (SecretKey, PublicKey) -> (String,String)
389 mkrow (a,b) | Just x <- encodeSecret a= (B.unpack x, show (Tox.key2id b))
390 mkrow _ = error (concat ["Assertion fail in 'mkrow' function at ", __FILE__, ":", show __LINE__])
391 sessionCommands :: [[String]]
392 sessionCommands =
393 [ ["ping"] -- pinglike
394 , ["cookie"] -- pinglike
395 , ["stop"]
396 , ["throw"]
397 , ["quit"]
398 , ["pid"]
399 , ["external-ip"]
400 , ["threads"]
401 , ["mem"]
402 , ["nid"]
403 , ["lan"]
404 , ["ls"]
405 , ["k"]
406 , ["roster"]
407 , ["sessions"]
408 , ["session"]
409 , ["netcrypto"]
410 , ["tcp"]
411 , ["onion"]
412 , ["g"]
413 , ["p"]
414 , ["a"]
415 , ["s"]
416 , ["x"]
417 , ["save"]
418 , ["load"]
419 , ["swarms"]
420 , ["peers"]
421 , ["toxids"]
422 , ["c"]
423 , ["quiet"]
424 , ["verbose"]
425 , ["help"]
426 ]
427 case (map toLower c,args) of
428 (n, _) | n `elem` Map.keys dhts -> switchNetwork n
429 -- "ping"
430 -- "cookie"
431 (pinglike, s) | Just DHT{dhtPing} <- Map.lookup netname dhts
432 , Just DHTPing{ pingQuery=ping
433 , pingShowResult=showr } <- Map.lookup pinglike dhtPing
434 , ws@(_:_) <- words s
435 -> cmd0 $ do
436 case readEither $ last ws of
437 Right addr -> do result <- ping (init ws) addr
438 let rs = [" ", maybe "Timeout." showr result]
439 hPutClient h $ unlines rs
440 Left er -> hPutClient h er
441 (x,_) | not (null (strp x))
442 , x `notElem` map head sessionCommands -> cmd0 $ do
443 hPutClient h $ "error."
444
445 ("stop", _) -> do hPutClient h "Terminating DHT Daemon."
446 hCloseClient h
447 signalQuit
448
449 ("throw", er) -> cmd0 $ do
450 throwIO $ userError er
451 hPutClient h "The impossible happened!"
452
453 ("quit", _) -> hPutClient h "" >> hCloseClient h
454
455 ("pid", _) -> cmd0 $ do
456 pid <- getProcessID
457 hPutClient h (show pid)
458 ("external-ip", _) -> cmd0 $ do
459 unlines . map (either show show . either4or6) <$> externalAddresses
460 >>= hPutClient h
461#ifdef THREAD_DEBUG
462 ("threads", s) -> cmd0 $ do
463 let want_ss = ["-v"] `isInfixOf` words s
464 r <- threadReport want_ss
465 hPutClient h r
466#endif
467 ("mem", s) -> cmd0 $ do
468 case s of
469 "gc" -> do hPutClient h "Performing garbage collection..."
470 performMajorGC
471 "" -> do
472#if MIN_VERSION_base(4,10,1)
473 is_enabled <- getRTSStatsEnabled
474#else
475 is_enabled <- getGCStatsEnabled
476#endif
477 if is_enabled
478 then do
479#if MIN_VERSION_base(4,10,1)
480 RTSStats{..} <- getRTSStats
481 let r = [ ("bytesAllocated", show allocated_bytes)
482 , ("numGcs", show gcs)
483 , ("maxBytesUsed", show max_live_bytes)
484 --, ("numByteUsageSamples", show numByteUsageSamples)
485 , ("cumulativeBytesUsed", show cumulative_live_bytes)
486 , ("bytesCopied", show copied_bytes)
487 , ("currentBytesUsed", show allocated_bytes)
488 --, ("currentBytesSlop", show currentBytesSlop)
489 , ("maxBytesSlop", show max_slop_bytes)
490 -- , ("peakMegabytesAllocated", show peakMegabytesAllocated)
491 , ("mutatorCpuNanoseconds", show mutator_cpu_ns)
492 , ("mutatorWallNanoseconds", show mutator_elapsed_ns)
493 , ("gcCpuSeconds", show gc_cpu_ns)
494 , ("gcWallSeconds", show gc_elapsed_ns)
495 , ("cpuSeconds", show cpu_ns)
496 , ("wallSeconds", show elapsed_ns)
497 , ("parTotBytesCopied", show par_copied_bytes)
498 , ("parMaxBytesCopied", show cumulative_par_max_copied_bytes)
499#else
500 GCStats{..} <- getGCStats
501 let r = [ ("bytesAllocated", show bytesAllocated)
502 , ("numGcs", show numGcs)
503 , ("maxBytesUsed", show maxBytesUsed)
504 , ("numByteUsageSamples", show numByteUsageSamples)
505 , ("cumulativeBytesUsed", show cumulativeBytesUsed)
506 , ("bytesCopied", show bytesCopied)
507 , ("currentBytesUsed", show currentBytesUsed)
508 , ("currentBytesSlop", show currentBytesSlop)
509 , ("maxBytesSlop", show maxBytesSlop)
510 , ("peakMegabytesAllocated", show peakMegabytesAllocated)
511 , ("mutatorCpuSeconds", show mutatorCpuSeconds)
512 , ("mutatorWallSeconds", show mutatorWallSeconds)
513 , ("gcCpuSeconds", show gcCpuSeconds)
514 , ("gcWallSeconds", show gcWallSeconds)
515 , ("cpuSeconds", show cpuSeconds)
516 , ("wallSeconds", show wallSeconds)
517 , ("parTotBytesCopied", show parTotBytesCopied)
518 , ("parMaxBytesCopied", show parMaxBytesCopied)
519#endif
520 ]
521 hPutClient h $ showReport r
522 else hPutClient h "Run with +RTS -T to obtain live memory-usage information."
523 _ -> hPutClient h "error."
524
525 ("nid", s) | Just DHT{dhtParseId} <- Map.lookup netname dhts
526 -> cmd0 $ do
527 hPutClient h $ case dhtParseId s of
528 Left e ->
529 -- HACK: split nospam from hex toxid
530 case dhtParseId (take 64 s) of
531 Left e -> case Tox.parseNoSpamId $ T.pack s of
532 Left ej -> if elem '@' s
533 then "Error: " ++ ej
534 else "Error: " ++ e
535 Right jid -> unlines [ show jid
536 , Tox.noSpamIdToHex jid ]
537 Right nid -> let nspam = drop 64 s
538 jid :: Maybe Tox.NoSpamId
539 jid = readMaybe $ '0':'x':nspam ++ "@" ++ show nid ++ ".tox"
540 in unlines [ maybe "" show jid
541 , show nid ++ " nospam:" ++ nspam ]
542 Right nid -> show nid
543
544 ("lan", _) -> cmd0 $ do
545 announceToLan
546 hPutClient h "ok"
547
548 ("ls", _) | Just DHT{dhtBuckets} <- Map.lookup netname dhts
549 -> cmd0 $ do
550 bkts <- atomically $ readTVar dhtBuckets
551 let r = reportTable bkts
552 hPutClient h $
553 showReport $
554 r ++ [ ("buckets", show $ R.shape bkts)
555 , ("node-id", show $ thisNode bkts)
556 , ("network", netname) ]
557
558 -- TODO: online documentation.
559 --
560 -- k - manage key-pairs
561 --
562 -- k (list keys)
563 -- k gen (generate new key and list keys)
564 -- k add <secret-key> (input a specific secret key)
565 -- k del <secret-key>
566 -- k secrets (list key pairs, including secret keys)
567
568 ("k", s) | "" <- strp s -> cmd0 $ do
569 ks <- atomically $ myKeyPairs roster
570 let spaces k | Just sel <- selectedKey, (sel == k) = " *"
571 | otherwise = " "
572 hPutClient h $ unlines $ map (\(_,k) -> mappend (spaces k) . show . Tox.key2id $ k) ks
573 | "gen" <- strp s -> do
574 secret <- generateSecretKey
575 let pubkey = toPublic secret
576 oldks <- atomically $ do
577 ks <- myKeyPairs roster
578 Tox.addContactInfo roster secret Map.empty
579 return ks
580 let asString = show . Tox.key2id
581 hPutClient h $ unlines $ map (mappend " " . show . Tox.key2id . snd) oldks
582 ++ [mappend " *" . show . Tox.key2id $ pubkey]
583 switchKey $ Just pubkey
584 | "secrets" <- strp s -> cmd0 $ do
585 ks <- atomically $ myKeyPairs roster
586 skey <- maybe (return Nothing) (atomically . dhtSecretKey)
587 $ Map.lookup netname dhts
588 hPutClient h . showReport $ (map mkrow ks ++) $ fromMaybe [] $ do
589 sk <- skey
590 let pk = Tox.key2id $ toPublic sk
591 x <- encodeSecret sk
592 Just [("",""),("dht-key:",""),(B.unpack x, show pk)]
593 | ("sel",_:expr) <- break isSpace s -> do
594 ks <- atomically $ map (show . Tox.key2id . snd) <$> myKeyPairs roster
595 case find (isInfixOf expr) ks of
596 Just k -> do
597 hPutClient h $ "Selected key: "++k
598 switchKey $ Just $ Tox.id2key $ read k
599 Nothing -> cmd0 $ hPutClient h "no match."
600 | ("add":secs) <- words s
601 , mbSecs <- map (decodeSecret . B.pack) secs
602 , all isJust mbSecs -> do
603 let f (Just b) = b
604 f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
605 let toPair x = (x,toPublic x)
606 pairs = map (toPair . f) mbSecs
607 oldks <- atomically $ do
608 oldks <- myKeyPairs roster
609 forM pairs $ \(sk,_) -> Tox.addContactInfo roster sk Map.empty
610 return oldks
611 hPutClient h $ unlines $ map (mappend " " . show . Tox.key2id . snd) oldks
612 ++ map (mappend " *" . show . Tox.key2id .snd) pairs
613 switchKey $ listToMaybe $ map snd pairs
614 | ("del":secs) <- words s
615 , mbSecs <- map (decodeSecret . B.pack) secs
616 , all isJust mbSecs -> do
617 let f (Just b) = b
618 f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
619 let toPair x = (x,toPublic x)
620 pairs = map (toPair . f) mbSecs
621 ks <- atomically $ do
622 forM pairs $ \(_,pk) -> Tox.delContactInfo roster pk
623 myKeyPairs roster
624 hPutClient h . showReport $ map mkrow ks
625 switchKey $ do
626 k <- selectedKey
627 guard $ k `notElem` map snd pairs
628 Just k
629
630 ("roster", s) -> cmd0 $ join $ atomically $ do
631 let ContactInfo{accounts} = roster
632 nosummary = not (null s)
633 as <- readTVar accounts
634 css <- forM as $ \acnt -> do
635 cs <- readTVar (contacts acnt)
636 forM cs $ \c -> do
637 ck <- readTVar $ contactKeyPacket c
638 ca <- readTVar $ contactLastSeenAddr c
639 cf <- readTVar $ contactFriendRequest c
640 cp <- readTVar $ contactPolicy c
641 let summarizeNodeId | nosummary = id
642 | otherwise = take 6
643 summarizeAddr | nosummary = id
644 | otherwise = reverse . take 20 . reverse
645 return $ [ maybe "/" showPolicy cp
646 , maybe "" (summarizeNodeId . show . Tox.key2id . Tox.dhtpk . snd) ck
647 , maybe "" (summarizeAddr . show . snd) ca
648 , maybe "" (show . T.decodeUtf8 . Tox.friendRequestText . snd) cf
649 ]
650 return $ do
651 forM_ (HashMap.toList css) $ \(me,xss) -> do
652 let cs = map (\(toxid,xs) -> show toxid : xs)
653 $ HashMap.toList xss
654 hPutClientChunk h $ unlines [ show me, map (const '-') (show me) ]
655 hPutClientChunk h $ showColumns $ ["ToxID","","NodeID","Address","FR text"]
656 : cs
657 hPutClient h ""
658
659 ("quiet",s) | s' <- strp s
660 , Just (tag::DebugTag) <- parseDebugTag s'
661 -> cmd0 $ do
662 setQuiet tag
663 hPutClient h $ "Suppressing " ++ show tag ++ " messages."
664
665 ("quiet",s) | "all" <- strp s
666 -> cmd0 $ do
667 mapM_ setQuiet allDebugTags
668 showDebugTags
669
670 (verbose,s) | "" <- strp s
671 , verbose `elem` ["verbose","quiet"]
672 -> cmd0 $ showDebugTags
673
674 ("verbose",s) | "all" <- strp s
675 -> cmd0 $ do
676 mapM_ setVerbose allDebugTags
677 showDebugTags
678
679 ("verbose",s) | s' <- strp s
680 , Just (tag::DebugTag) <- parseDebugTag s'
681 -> cmd0 $ do
682 setVerbose tag
683 hPutClient h $ "Showing " ++ show tag ++ " messages."
684
685 ("tcp",s) | "" <- strp s
686 -> cmd0 $ join $ atomically $ do
687 tcps <- readTVar (TCP.lru $ tcpProberState onionRouter)
688 return $ do
689 now <- getPOSIXTime
690 forM (MM.toList tcps) $ \(MM.Binding (TCP.TCPAddress addr) tcp (Down tm)) -> do
691 hPutClientChunk h $ unwords [show addr, show (now - tm), TCP.showStat tcp] ++ "\n"
692 hPutClient h $ show (MM.size tcps) ++ " active or pending connections.\n"
693
694 ("onion", s) | "" <- strp $ map toLower s
695 -> cmd0 $ do
696 now <- getPOSIXTime
697 join $ atomically $ do
698 rm <- IntMap.fromList . catMaybes . map (\(i,m) -> fmap (i,) m) <$> getAssocs (routeMap onionRouter)
699 let trampstate t = do
700 ts <- readTVar $ setNodes t
701 tcnt <- readTVar $ setCount t
702 icnt <- HashMap.size <$> readTVar (setIDs t)
703 return (ts,tcnt,icnt)
704 (ts,tcnt,icnt) <- trampstate (trampolinesUDP onionRouter)
705 (tts,ttcnt,ticnt) <- trampstate (trampolinesTCP onionRouter)
706 rs <- getAssocs (pendingRoutes onionRouter)
707 pqs <- readTVar (pendingQueries onionRouter)
708 tcp_spill <- readTVar (TCP.probeSpill $ tcpProber onionRouter)
709 tcp_cache <- readTVar (TCP.probeCache $ tcpProber onionRouter)
710 tcp_queue <- readTVar (TCP.probeQueue $ tcpProber onionRouter)
711 tcpmode <- readTVar (tcpMode onionRouter)
712 tcps <- readTVar (TCP.lru $ tcpProberState onionRouter)
713 let showRecord :: Int -> Int -> [String]
714 showRecord n wanted_ver
715 | Just RouteRecord{responseCount,timeoutCount,routeVersion,routeBirthTime
716 ,storedRoute=Tox.OnionRoute{routeRelayPort}} <- IntMap.lookup n rm
717 = [ show n, show responseCount, show timeoutCount
718 , maybe "" show routeRelayPort
719 , show (now - routeBirthTime)
720 , if routeVersion >= wanted_ver
721 then show routeVersion
722 else show routeVersion ++ "(pending)" ]
723 | otherwise = [show n, "error!","","",""]
724 r = map (uncurry showRecord) rs
725 return $ do
726 hPutClientChunk h $ unlines [ "trampolines(UDP): " ++ show (IntMap.size ts,tcnt,icnt)
727 ++ if tcpmode then "" else " *"
728 , "trampolines(TCP): " ++ show (IntMap.size tts,ttcnt,ticnt)
729 ++ if tcpmode then " *" else ""
730 , "active TCP: " ++ show (MM.size tcps)
731 , "pending: " ++ show (W64.size pqs)
732 , "TCP spill,cache,queue: "
733 ++ show (PSQ.size tcp_spill, PSQ.size tcp_cache, PSQ.size tcp_queue)]
734 hPutClient h $ showColumns $ ["","responses","timeouts", "tcp", "age", "version"]:r
735
736 ("onion", s) | "udp" <- strp $ map toLower s
737 -> cmd0 $ do
738 atomically $ writeTVar (tcpMode onionRouter) False
739 hPutClient h "Onion routes: UDP."
740
741 ("onion", s) | "tcp" <- strp $ map toLower s
742 -> cmd0 $ do
743 atomically $ writeTVar (tcpMode onionRouter) True
744 hPutClient h "Onion routes: TCP."
745
746 ("g", s) | Just DHT{..} <- Map.lookup netname dhts
747 -> cmd0 $ do
748 -- arguments: method
749 -- nid
750 -- (optional dest-ni)
751 self <- atomically $ thisNode <$> readTVar dhtBuckets
752 let (method,xs) = break isSpace $ dropWhile isSpace s
753 (nidstr,ys) = break isSpace $ dropWhile isSpace xs
754 destination = dropWhile isSpace ys
755 goQuery qry = either (hPutClient h . ("Bad search target: "++))
756 (goTarget qry)
757 $ dhtParseId nidstr
758 goTarget DHTQuery{..} nid =
759 go nid >>= reportResult method qshowR qshowTok show h
760 where
761 go | null destination = fmap Right . qhandler self
762 | otherwise = case readEither destination of
763 Right ni -> fmap (maybe (Left "Timeout.") Right)
764 . flip (either id waitOn $ searchQuery qsearch) ni
765 Left e -> const $ return $ Left ("Bad destination: "++e)
766 maybe (hPutClient h ("Unsupported method: "++method))
767 goQuery
768 $ Map.lookup method dhtQuery
769
770 -- TODO: Online help.
771 --
772 -- p - put/publish a single given datum on a single given node.
773 --
774 -- When destination address (node-addr) is optional, it's absense means to
775 -- publish information in the local node's own database.
776 --
777 -- Bittorrent: (peer) publish yourself as peer in swarm.
778 -- (port) set your current bittorrent listen port.
779 --
780 -- p peer <infohash> <token> [node-addr]
781 --
782 -- p port <num>
783 --
784 -- Tox: (toxid) publish a rendezvous onion route to dht node.
785 -- (friend) send a friend-request over a rendezvous point.
786 -- (dhtkey) send your dht node-id over a rendezvous point.
787 --
788 -- p toxid <key> <token> <node-addr>
789 --
790 -- p friend <nospamid> <rendezvous-addr> <text>
791 --
792 -- p dhtkey <key> <rendezvous-addr>
793
794 ("p", s) | Just DHT{..} <- Map.lookup netname dhts
795 -> cmd0 $ do
796 -- arguments: Left Right
797 -- ---- -----
798 -- method method
799 -- data (jid or key) data
800 -- dest-rendezvous(r) token
801 -- (optional extra-text) (optional dest-ni)
802 self <- atomically $ thisNode <$> readTVar dhtBuckets
803 let (method,xs) = break isSpace $ dropWhile isSpace s
804 (dtastr,ys) = break isSpace $ dropWhile isSpace xs
805 (tokenstr,zs) = break isSpace $ dropWhile isSpace ys
806 destination = dropWhile isSpace zs
807 goTarget DHTAnnouncable{..} | Right asend <- announceSendData = do
808 let dta = announceParseData dtastr
809 tok = dta >>= flip announceParseToken tokenstr
810 case liftA2 (,) dta tok of
811 Left e -> hPutClient h e
812 Right nid -> go asend nid >>= either (hPutClient h) (hPutClient h . show)
813 where
814 go asend | null destination = fmap (maybe (Left "Timeout.") Right)
815 . flip (uncurry asend) Nothing
816 | otherwise = case announceParseAddress destination of
817 Right ni -> fmap (maybe (Left "Timeout.") Right)
818 . flip (uncurry asend) (Just ni)
819 Left e -> const $ return $ Left ("Bad destination: "++e)
820 goTarget DHTAnnouncable{..} | Left (searchName,parseResult,asend) <- announceSendData = do
821 either (hPutClient h) id $ do
822 dta <- announceParseData $ unwords [dtastr,destination]
823 r <- parseResult tokenstr
824 return $ case selectedKey of
825 Nothing -> hPutClient h "Missing secret user-key."
826 Just k -> do
827 asend k dta r
828 hPutClient h "Sent."
829 maybe (hPutClient h ("Unsupported method: "++method))
830 goTarget
831 $ Map.lookup method dhtAnnouncables
832
833 -- TODO: Online documentation.
834 --
835 -- a - announce, like put/publish but automatically selects nodes to publish on
836 -- and periodically refreshes them.
837 --
838 -- The method name is preceded with a + to start or a - to stop a given
839 -- recurring publication.
840 --
841 -- BitTorrent: (peer) Every minute, announce you are participating
842 -- in a torrent swarm.
843 --
844 -- a +peer <infohash> a -peer <infohash>
845 --
846 -- Tox: (toxid) Every 15 seconds, announce your tox identity to the
847 -- DHT so friends can find you.
848 --
849 -- a +toxid <key>
850 -- a -toxid <key>
851 --
852 -- a +friend <jid> <text>
853 -- a +dhtkey <key>
854 ("a", "") -> cmd0 $ do
855 now <- getPOSIXTime
856 rs <- atomically $ do
857 as <- scheduleToList announcer
858 forM (as) $ \(k,ptm,item) -> do
859 let kstr = unpackAnnounceKey announcer k
860 return [ if ptm==0 then "now"
861 else show (ptm - now)
862 , show (itemStatusNum item)
863 , kstr
864 ]
865 hPutClient h $ showColumns rs
866 ("a", s) | Just DHT{..} <- Map.lookup netname dhts
867 , not (null s)
868 -> cmd0 $ do
869 let (op:method,xs) = break isSpace $ dropWhile isSpace s
870 dtastr = dropWhile isSpace xs
871
872 a = Map.lookup method dhtAnnouncables
873 q = do DHTAnnouncable { announceSendData } <- a
874 Map.lookup (either (\(search,_,_)->search)
875 (const method)
876 announceSendData)
877 dhtQuery
878 doitR :: Char -> Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
879 doitR '+' = scheduleAnnounce
880 doitR '-' = \a k _ _ -> cancel a k
881 doitR _ = \_ _ _ _ -> hPutClientChunk h "Starting(+) or canceling(-)?"
882 doitL :: Char -> Announcer -> AnnounceKey -> SearchMethod r -> r -> IO ()
883 doitL '+' = scheduleSearch
884 doitL '-' = \a k _ _ -> cancel a k
885 doitL _ = \_ _ _ _ -> hPutClientChunk h "Starting(+) or canceling(-)?"
886 matchingResult ::
887 ( Typeable stok
888 , Typeable ptok
889 , Typeable sni
890 , Typeable pni )
891 => Search nid addr stok sni sr
892 -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr))
893 -> Maybe (stok :~: ptok, sni :~: pni)
894 matchingResult _ _ = liftA2 (,) eqT eqT
895 matchingResult2 ::
896 ( Typeable sr
897 , Typeable pr )
898 => Search nid addr stok sni sr
899 -> (PublicKey -> pdta -> pr -> IO ())
900 -> (pdta -> nid)
901 -> Maybe (pr :~: sr)
902 matchingResult2 _ _ _ = eqT
903 reportit target = case op of
904 '+' -> hPutClient h $ "Announcing at " ++ target ++ "."
905 '-' -> hPutClient h $ "Canceling " ++ target ++ "."
906 -- mameth is for typical kademlia announce.
907 mameth = do
908 DHTAnnouncable { announceSendData
909 , announceParseData
910 , announceInterval
911 , announceTarget } <- a
912 DHTQuery { qsearch } <- q
913 asend <- either (const Nothing) Just announceSendData
914 (Refl, Refl) <- matchingResult qsearch asend
915 -- return $ hPutClient h "Type matches."
916 dta <- either (const Nothing) Just $ announceParseData dtastr
917 return $ do
918 let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr)
919 doitR op announcer
920 akey
921 (AnnounceMethod qsearch asend
922 (\nid -> R.kclosest (searchSpace qsearch)
923 (searchK qsearch)
924 nid
925 <$> readTVar dhtBuckets)
926 (announceTarget dta)
927 announceInterval)
928 dta
929 reportit $ show $ announceTarget dta
930 -- lmeth is for atypical announce messages such as
931 -- Tox dht-key and friend-request messages.
932 lmeth :: Maybe (IO ())
933 lmeth = do
934 DHTAnnouncable { announceSendData
935 , announceParseData
936 , announceInterval
937 , announceTarget } <- a
938 DHTQuery { qsearch } <- q
939 (_,_,asend) <- either Just (const Nothing) announceSendData
940 Refl <- matchingResult2 qsearch asend announceTarget
941 dta <- either (const Nothing) Just $ announceParseData dtastr
942 pub <- selectedKey
943 return $ do
944 let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr)
945 doitL op announcer
946 akey
947 (SearchMethod qsearch (asend pub)
948 (\nid -> R.kclosest (searchSpace qsearch)
949 (searchK qsearch)
950 nid
951 <$> readTVar dhtBuckets)
952 (announceTarget dta)
953 announceInterval)
954 dta
955 reportit $ show $ announceTarget dta
956 ptest = fromMaybe "E:NoMethod"
957 $ fmap (\DHTAnnouncable { announceParseData
958 , announceTarget }
959 -> either ("E:"++) (show . announceTarget)
960 $ announceParseData dtastr)
961 a
962
963 let aerror = unlines
964 [ "announce error."
965 , "method = " ++ method
966 , "query = " ++ maybe "nil" (const "ok") q
967 , "publish = " ++ maybe "nil" (const "ok") a
968 -- , "chktok = " ++ maybe "nil" (const "ok") chktok -- chktok = nil
969 -- , "chkni = " ++ maybe "nil" (const "ok") chkni
970 , "ptest = " ++ ptest
971 , "mameth = " ++ show (fmap (const ()) mameth)
972 , "lmeth = " ++ show (fmap (const ()) lmeth)
973 , "selectedKey = " ++ show selectedKey
974 ]
975 fromMaybe (hPutClient h aerror) $ mameth <|> lmeth
976
977 ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts
978 -> cmd0 $ do
979 let (method,xs) = break isSpace s
980 (nidstr,ys) = break isSpace $ dropWhile isSpace xs
981 presentSearches = hPutClient h
982 =<< showSearches
983 =<< atomically (readTVar dhtSearches)
984 goTarget qry nid = do
985 kvar <- atomically $ newTVar Nothing
986 -- Forking a thread, but it may ubruptly quit if the following
987 -- STM action decides not to add a new search. This is so that
988 -- I can store the ThreadId into new DHTSearch structure.
989 tid <- fork $ join $ atomically (readTVar kvar >>= maybe retry return)
990 join $ atomically $ do
991 schs <- readTVar dhtSearches
992 case Map.lookup (method,nid) schs of
993 Nothing -> do forkSearch method nid qry dhtSearches dhtBuckets tid kvar
994 return $ presentSearches
995 Just sch -> do writeTVar kvar (Just $ return ())
996 return $ reportSearchResults method h sch
997 goQuery qry = either (hPutClient h . ("Bad search target: "++))
998 (goTarget qry)
999 $ dhtParseId nidstr
1000 if null method then presentSearches
1001 else maybe (hPutClient h ("Unsupported method: "++method))
1002 goQuery
1003 $ Map.lookup method dhtQuery
1004
1005 ("x", s) | Just DHT{..} <- Map.lookup netname dhts
1006 -> cmd0 $ do
1007 let (method,xs) = break isSpace s
1008 (nidstr,ys) = break isSpace $ dropWhile isSpace xs
1009 go nid = join $ atomically $ do
1010 schs <- readTVar dhtSearches
1011 case Map.lookup (method,nid) schs of
1012 Nothing -> return $ hPutClient h "No match."
1013 Just DHTSearch{searchThread} -> do
1014 modifyTVar' dhtSearches (Map.delete (method,nid))
1015 return $ do
1016 killThread searchThread
1017 hPutClient h "Removed search."
1018 either (hPutClient h . ("Bad search target: "++)) go $ dhtParseId nidstr
1019
1020 ("save", _) | Just dht <- Map.lookup netname dhts
1021 -> cmd0 $ do
1022 saveNodes netname dht
1023 hPutClient h $ "Saved " ++ nodesFileName netname ++ "."
1024
1025 ("load", _) | Just dht <- Map.lookup netname dhts
1026 -> cmd0 $ do
1027 b <- pingNodes netname dht
1028 case b of
1029 Just num ->
1030 hPutClient h $ unwords [ "Pinging"
1031 , show num
1032 , "nodes from"
1033 , nodesFileName netname ++ "."
1034 ]
1035 Nothing ->
1036 hPutClient h $ "Failed: " ++ nodesFileName netname ++ "."
1037
1038 ("swarms", s) -> cmd0 $ do
1039 let fltr = case s of
1040 ('-':'v':cs) | all isSpace (take 1 cs)
1041 -> const True
1042 _ -> (\(h,c,n) -> c/=0 )
1043 ss <- atomically $ Peers.knownSwarms <$> readTVar (Mainline.contactInfo swarms)
1044 let r = map (\(h,c,n) -> (unwords [show h,show c], maybe "" show n))
1045 $ filter fltr ss
1046 hPutClient h $ showReport r
1047
1048 ("peers", s) -> cmd0 $ case readEither s of
1049 Right ih -> do
1050 ps <- atomically $ Peers.lookup ih <$> readTVar (Mainline.contactInfo swarms)
1051 hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps
1052 Left er -> hPutClient h er
1053 ("toxids", s) -> cmd0 $ do
1054 keydb <- atomically $ readTVar toxkeys
1055 now <- getPOSIXTime
1056 let entries = map mkentry $ PSQ.toList (Tox.keyByAge keydb)
1057 mkentry (k :-> tm) = [ show cnt, show k, show (now - tm) ]
1058 where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb)
1059 hPutClient h $ showColumns entries
1060
1061 ("c", s) | Just (ConnectionManager mgr) <- connectionManager
1062 , "" <- strp s
1063 -> cmd0 $ join $ atomically $ do
1064 cs <- do
1065 ks <- connections mgr
1066 forM ks $ \k -> do
1067 stat <- Connection.status mgr k
1068 return (k,stat)
1069 let mkrow (k,st) = [ Connection.showKey mgr k
1070 , Connection.showStatus mgr (connStatus st)
1071 , showPolicy (connPolicy st)
1072 ]
1073 rs = map mkrow cs
1074 return $ do
1075 hPutClient h $ "connections\n" ++ showColumns rs
1076
1077 ("help", s) | Just DHT{..} <- Map.lookup netname dhts
1078 -> cmd0 $ do
1079 let tolist :: a -> [a]
1080 tolist = (:[])
1081
1082 dhtkeys, announcables, ks, allcommands :: [[String]]
1083 dhtkeys = map tolist $ Map.keys dhts
1084 queries = map (tolist . ("s "++)) $ Map.keys dhtQuery
1085 xs = map (tolist . ("x "++)) $ Map.keys dhtQuery
1086 gs = map (tolist . ("g "++)) $ Map.keys dhtQuery
1087 announcables = map (tolist . ("p "++)) $ Map.keys dhtAnnouncables
1088 ks = [["k gen"],["k public"],["k secret"]]
1089 allcommands = sortBy (comparing (take 1)) $ concat [sessionCommands, dhtkeys, announcables, ks, queries, gs,xs]
1090
1091 hPutClient h ("Available commands:\n" ++ showColumns allcommands)
1092
1093 _ -> cmd0 $ hPutClient h "error."
1094
1095
1096readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr]
1097readExternals nodeAddr vars = do
1098 as <- atomically $ mapM (fmap (nodeAddr . selfNode) . readTVar) vars
1099 let unspecified (SockAddrInet _ 0) = True
1100 unspecified (SockAddrInet6 _ _ (0,0,0,0) _) = True
1101 unspecified _ = False
1102 -- TODO: Filter to only global addresses?
1103 return $ filter (not . unspecified) as
1104
1105data Options = Options
1106 { portbt :: String
1107 , porttox :: [String]
1108 , portxmpp :: String -- client-to-server
1109 , portxmppS :: String -- server-to-server
1110 , ip6bt :: Bool
1111 , ip6tox :: Bool
1112 , dhtkey :: Maybe SecretKey
1113 -- | Currently only relevant to XMPP server code.
1114 --
1115 -- [ 0 ] Don't log XMPP stanzas.
1116 --
1117 -- [ 1 ] Log non-ping stanzas.
1118 --
1119 -- [ 2 ] Log all stanzas, even pings.
1120 , verbosity :: Int
1121 , verboseTags :: [DebugTag]
1122 }
1123 deriving (Eq,Show)
1124
1125sensibleDefaults :: Options
1126sensibleDefaults = Options
1127 { portbt = "6881"
1128 , porttox = ["33445"]
1129 , portxmpp = "5222"
1130 , portxmppS = "5269"
1131 , ip6bt = True
1132 , ip6tox = True
1133 , dhtkey = Nothing
1134 , verbosity = 2
1135 , verboseTags = [XUnexpected, XUnused]
1136 }
1137
1138-- bt=<port>,tox=<port>
1139-- -4
1140parseArgs :: [String] -> Options -> Options
1141parseArgs [] opts = opts
1142parseArgs ("--dhtkey":k:args) opts = parseArgs args opts
1143 { dhtkey = decodeSecret $ B.pack k }
1144parseArgs ("--dht-key":k:args) opts = parseArgs args opts
1145 { dhtkey = decodeSecret $ B.pack k }
1146parseArgs ("-4":args) opts = parseArgs args opts
1147 { ip6bt = False
1148 , ip6tox = False }
1149parseArgs ("-v":tags:args) opts = parseArgs args opts
1150 { verboseTags = let gs = groupBy (const (/= ',')) tags
1151 ss = map (dropWhile (==',')) gs
1152 (ds0,as0) = partition (\s -> last (' ':s) == '-') ss
1153 as = mapMaybe parseDebugTag as0
1154 ds = mapMaybe (parseDebugTag . init) ds0
1155 in (verboseTags opts `union` as) \\ ds
1156 }
1157parseArgs (arg:args) opts = parseArgs args opts
1158 { portbt = fromMaybe (portbt opts) $ Prelude.lookup "bt" ports
1159 , porttox = fromMaybe (porttox opts) $ lookupAll "tox" ports
1160 , portxmpp = fromMaybe (portxmpp opts) $ Prelude.lookup "xmpp" ports
1161 , portxmppS = fromMaybe (portxmppS opts) $ Prelude.lookup "xmpp.s2s" ports }
1162 where
1163 lookupAll seeking kvs = case filter (\(k,v) -> k == seeking) kvs of
1164 [] -> Nothing
1165 xs -> Just $ map snd xs
1166 ports = map ( (dropWhile (==',') *** dropWhile (=='='))
1167 . break (=='=') )
1168 $ groupBy (const (/= ',')) arg
1169
1170noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r)
1171noArgPing f [] x = f x
1172noArgPing _ _ _ = return Nothing
1173
1174-- | Create a Conduit Source by repeatedly calling an IO action.
1175ioToSource :: IO (Maybe x) -> IO () -> ConduitT () x IO ()
1176ioToSource !action !onEOF = liftIO action >>= \case
1177 Nothing -> do
1178 dput XNetCrypto "ioToSource terminated."
1179 liftIO onEOF
1180 Just item -> do C.yield item
1181 ioToSource action onEOF
1182
1183{-
1184newXmmpSink :: Tox.NetCryptoSession -> C.Sink (Flush Tox.CryptoMessage) IO ()
1185newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar }) = C.awaitForever $ \flush_cyptomessage -> do
1186 let sendit :: Tox.NetCryptoSession -> Flush Tox.CryptoMessage -> IO ()
1187 sendit session (Chunk msg) = do
1188 outq <- atomically $ do
1189 mbOutq <- readTVar outGoingQVar
1190 case mbOutq of
1191 Tox.HaveHandshake outq -> return outq
1192 Tox.NeedHandshake -> retry
1193 extra <- Tox.nqToWireIO outq
1194 r <- atomically $ do
1195 rTry <- Tox.tryAppendQueueOutgoing extra outq msg
1196 case rTry of
1197 Tox.OGFull -> retry
1198 Tox.OGSuccess x -> return (Tox.OGSuccess x)
1199 Tox.OGEncodeFail -> return Tox.OGEncodeFail
1200 case r of
1201 Tox.OGSuccess x -> case Tox.ncSockAddr session of
1202 Tox.HaveDHTKey saddr -> Tox.sendSessionPacket (Tox.ncAllSessions session) saddr x
1203 _ -> return ()
1204 Tox.OGEncodeFail -> dput XMisc ("FAILURE to Encode Outgoing: " ++ show msg)
1205 _ -> return ()
1206 sendit session Flush = return ()
1207 liftIO $ sendit session flush_cyptomessage
1208-}
1209
1210
1211onNewToxSession :: XMPPServer
1212 -> TVar (Map.Map Uniq24 AggregateSession)
1213 -> InviteCache IO
1214 -> ContactInfo extra
1215 -> SockAddr
1216 -> Tox.Session
1217 -> IO ()
1218onNewToxSession sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do
1219 let them s = Tox.longTermKey $ runIdentity cookie -- remote tox key
1220 where Tox.Cookie _ cookie = Tox.handshakeCookie (sReceivedHandshake s)
1221
1222 me s = toPublic $ sOurKey s
1223
1224 onStatusChange :: (Tox.Session -> Tcp.ConnectionEvent XML.Event -> STM ())
1225 -> AggregateSession -> Tox.Session -> Status Tox.ToxProgress -> STM ()
1226 onStatusChange announce c s Established = onConnect announce c s
1227 onStatusChange announce _ s _ = onEOF announce s
1228
1229 onEOF announce s = do
1230 HashMap.lookup (Tox.key2id $ me s) <$> readTVar accounts
1231 >>= mapM_ (setTerminated $ them s)
1232 announce s Tcp.EOF
1233
1234 onConnect announce c s = do
1235 HashMap.lookup (Tox.key2id $ me s) <$> readTVar accounts
1236 >>= mapM_ (setEstablished $ them s)
1237 announce s $ Tcp.Connection (return False) xmppSrc xmppSnk
1238 where
1239 toxSrc :: ConduitT () (Int, CryptoMessage) IO ()
1240 toxSnk :: ConduitT (Maybe Int, CryptoMessage) Void IO ()
1241 xmppSrc :: ConduitT () XML.Event IO ()
1242 xmppSnk :: ConduitT (Flush XML.Event) Void IO ()
1243
1244 toxSrc = ioToSource (atomically $ orElse (awaitAny c)
1245 $ aggregateStatus c >>= \case
1246 Dormant -> return Nothing
1247 _ -> retry)
1248 (return ())
1249 toxSnk = C.mapM_ (uncurry $ dispatchMessage c)
1250 xmppSrc = toxSrc .| toxToXmpp (rememberInvite invc c) addrTox (me s) (xmppHostname $ them s)
1251 xmppSnk = flushPassThrough xmppToTox
1252 .| C.mapMaybe (\case Flush -> Nothing
1253 Chunk x -> Just (Nothing,x))
1254 .| toxSnk
1255
1256 uniqkey <- xor24 <$> hash24 (them netcrypto) <*> hash24 (me netcrypto)
1257
1258 c <- atomically $ do
1259 mc <- Map.lookup uniqkey <$> readTVar ssvar
1260 case mc of
1261 Nothing -> do
1262 announce <- do
1263 v <- newTVar Nothing
1264 let ck = uniqueAsKey uniqkey
1265 condta s = ConnectionData (Left (Local addrTox))
1266 XMPPServer.Tox
1267 (xmppHostname $ me s)
1268 v
1269 return $ \s e -> writeTChan (xmppEventChannel sv) ( (ck, condta s), e)
1270 c <- newAggregateSession $ onStatusChange announce
1271 modifyTVar' ssvar $ Map.insert uniqkey c
1272 return c
1273 Just c -> return c
1274
1275 addSession c netcrypto
1276
1277 return ()
1278
1279selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text
1280selectManager mtman tcp profile = case T.splitAt 43 profile of
1281 (k,".tox") | Just tman <- mtman
1282 -> let -- The following error call is safe because the toxConnections field
1283 -- does not make use of the PresenceState passed to tman.
1284 tox = toxConnections $ tman $ error "PresenseState"
1285 tkey them = do
1286 me <- readMaybe (T.unpack k)
1287 them <- case T.splitAt 43 them of
1288 (them0,".tox") -> readMaybe (T.unpack them0)
1289 _ -> Nothing
1290 return (Tox.ToxContact me them)
1291 in Manager
1292 { resolvePeer = \themhost -> do
1293 r <- fromMaybe (return []) $ do
1294 (themT,".tox") <- Just $ T.splitAt 43 themhost
1295 them <- readMaybe $ T.unpack themT
1296 me <- readMaybe $ T.unpack k
1297 let contact = Tox.ToxContact me them
1298 Just $ resolvePeer tox contact
1299 dput XMan $ "resolvePeer(tox) " ++ show (T.take 8 $ k,T.take 8 $ themhost,r)
1300 return r
1301 , reverseAddress = \paddr -> do
1302 r <- fromMaybe (return []) $ do
1303 me <- readMaybe $ T.unpack k
1304 Just $ do
1305 reverseAddress tox paddr
1306 <&> mapMaybe (\case
1307 Tox.ToxContact a k | a == me -> Just $ T.pack (show k) `T.append` ".tox"
1308 _ -> Nothing)
1309 dput XMan $ "reverseAddress(tox)" ++ show (T.take 8 k,paddr) ++ ": " ++ show r
1310 return r
1311
1312 , showKey = \key -> T.unpack key ++ ".tox"
1313 , setPolicy = \them -> case tkey them of
1314 Just tk -> \p -> setPolicy tox tk p
1315 Nothing -> \p -> return ()
1316 , status = \them -> case tkey them of
1317 Just tk -> fmap ToxStatus <$> status tox tk
1318 Nothing -> return $ Connection Dormant RefusingToConnect
1319 , connections = let valid (Tox.ToxContact local them) = do
1320 guard $ T.pack (show local) == k
1321 return $ T.pack (show them ++ ".tox")
1322 in fmap (mapMaybe valid) $ connections tox
1323 , stringToKey = \s -> Just $ T.pack (s ++ ".tox")
1324 , showProgress = \(ToxStatus stat) -> showProgress tox stat
1325 }
1326 _ -> Manager
1327 { resolvePeer = \themhost -> do
1328 dput XMan $ "resolvePeer(tcp) " ++ show (profile,themhost)
1329 resolvePeer tcp themhost
1330 , reverseAddress = \paddr -> do
1331 dput XMan $ "reverseAddress(tcp) " ++ show (profile,paddr)
1332 reverseAddress tcp paddr
1333
1334 , showKey = showKey tcp
1335 , setPolicy = setPolicy tcp
1336 , status = \k -> fmap XMPPStatus <$> status tcp k
1337 , connections = connections tcp
1338 , stringToKey = stringToKey tcp
1339 , showProgress = \(XMPPStatus stat) -> showProgress tcp stat
1340 }
1341
1342
1343initTox :: Options
1344 -> TVar (Map.Map Uniq24 AggregateSession)
1345 -> TVar Tox.AnnouncedKeys
1346 -> Maybe XMPPServer
1347 -> InviteCache IO
1348 -> IO ( Maybe (Tox.Tox JabberClients) , IO ()
1349 , Map.Map String DHT
1350 , IO [SockAddr]
1351 , [SockAddr])
1352initTox opts ssvar keysdb mbxmpp invc = case porttox opts of
1353 [""] -> return (Nothing,return (), Map.empty, return [],[])
1354 toxport -> do
1355 dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
1356 tox <- Tox.newTox keysdb
1357 toxport
1358 (case mbxmpp of
1359 Nothing -> \_ _ _ -> return ()
1360 Just xmpp -> onNewToxSession xmpp ssvar invc)
1361 (dhtkey opts)
1362 (\_ _ -> return ()) -- TODO: TCP relay send
1363 -- addrTox <- getBindAddress toxport (ip6tox opts)
1364 (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox True
1365
1366 toxSearches <- atomically $ newTVar Map.empty
1367
1368 tcpSearches <- atomically $ newTVar Map.empty
1369
1370 let toxDHT bkts wantip = DHT
1371 { dhtBuckets = bkts (Tox.toxRouting tox)
1372 , dhtPing = Map.fromList
1373 [ ("ping", DHTPing
1374 { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Tox.ping (Tox.toxDHT tox)
1375 , pingShowResult = show
1376 })
1377 , ("cookie", DHTPing
1378 { pingQuery = \case
1379 [keystr] | Just mykey <- readMaybe keystr
1380 -> Tox.cookieRequest (Tox.toxCryptoKeys tox)
1381 (Tox.toxDHT tox)
1382 (Tox.id2key mykey)
1383 _ -> const $ return Nothing
1384 , pingShowResult = show
1385 })]
1386 , dhtQuery = Map.fromList
1387 [ ("node", DHTQuery
1388 { qsearch = Tox.nodeSearch (Tox.toxDHT tox)
1389 (Tox.nodesOfInterest $ Tox.toxRouting tox)
1390 , qhandler = (\ni -> fmap Tox.unwrapNodes
1391 . Tox.getNodesH (Tox.toxRouting tox) ni
1392 . Tox.GetNodes)
1393 , qshowR = show -- NodeInfo
1394 , qshowTok = (const Nothing)
1395 })
1396 , ("toxid", DHTQuery
1397 { qsearch = Tox.toxQSearch tox
1398 , qhandler = -- qhandler :: ni -> nid -> IO ([ni], [r], tok)
1399 (\ni nid ->
1400 Tox.unwrapAnnounceResponse Nothing
1401 <$> clientAddress (Tox.toxDHT tox) Nothing
1402 <*> Tox.announceH (Tox.toxRouting tox)
1403 (Tox.toxTokens tox)
1404 (Tox.toxAnnouncedKeys tox)
1405 (Tox.OnionDestination Tox.SearchingAlias ni Nothing)
1406 (Tox.AnnounceRequest zeros32 nid Tox.zeroID))
1407 , qshowR = show -- Rendezvous
1408 , qshowTok = Just . show -- Nonce32
1409 })
1410 ]
1411 , dhtParseId = readEither :: String -> Either String Tox.NodeId
1412 , dhtSearches = toxSearches
1413 , dhtFallbackNodes = return []
1414 , dhtAnnouncables = Map.fromList
1415 -- To announce your own tox OrjBG... identity is online:
1416 --
1417 -- > a +toxid OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu
1418 [ ("toxid", DHTAnnouncable { announceSendData = Right (toxAnnounceSendData tox)
1419 , announceParseAddress = readEither
1420 , announceParseToken = const $ readEither
1421 , announceParseData = fmap Tox.id2key . readEither
1422 , announceTarget = Tox.key2id -- toxid
1423
1424 -- For peers we are announcing ourselves to, if we are not
1425 -- announced to them toxcore tries every 3 seconds to
1426 -- announce ourselves to them until they return that we
1427 -- have announced ourselves to, then toxcore sends an
1428 -- announce request packet every 15 seconds to see if we
1429 -- are still announced and re announce ourselves at the
1430 -- same time. The timeout of 15 seconds means a `ping_id`
1431 -- received in the last packet will not have had time to
1432 -- expire (20 second minimum timeout) before it is resent
1433 -- 15 seconds later. Toxcore sends every announce packet
1434 -- with the `ping_id` previously received from that peer
1435 -- with the same path (if possible).
1436 , announceInterval = toxAnnounceInterval
1437
1438 })
1439 -- dhtkey parameters:
1440 --
1441 -- ni = NodeInfo
1442 -- r = Rendezvous
1443 -- tok = Nonce32
1444 -- dta = PublicKey{-them-}
1445 --
1446 -- Using k-selected identity, to share your dht
1447 -- key with remote tox user
1448 -- "KWoEx1XQHrluIoW.3nK6BFb6XCebKWr3nDDt3V7CcoJ"
1449 -- ...
1450 --
1451 -- > a +dhtkey KWoEx1XQHrluIoW.3nK6BFb6XCebKWr3nDDt3V7CcoJ
1452 , ("dhtkey", DHTAnnouncable { announceSendData = Left ("toxid", readEither, \me them addr -> do
1453 dkey <- Tox.getContactInfo tox
1454 sendMessage
1455 (Tox.toxToRoute tox)
1456 (Tox.AnnouncedRendezvous them addr)
1457 (me,Tox.OnionDHTPublicKey dkey))
1458 , announceParseAddress = \str -> do
1459 ni <- readEither str
1460 return ( ni :: Tox.NodeInfo )
1461 , announceParseToken = \_ str -> do
1462 tok <- readEither str
1463 return ( tok :: Nonce32 )
1464 , announceParseData = fmap Tox.id2key . readEither
1465 , announceTarget = Tox.key2id
1466
1467 -- We send this packet every 30 seconds if there is more
1468 -- than one peer (in the 8) that says they our friend is
1469 -- announced on them. This packet can also be sent through
1470 -- the DHT module as a DHT request packet (see DHT) if we
1471 -- know the DHT public key of the friend and are looking
1472 -- for them in the DHT but have not connected to them yet.
1473 -- 30 second is a reasonable timeout to not flood the
1474 -- network with too many packets while making sure the
1475 -- other will eventually receive the packet. Since packets
1476 -- are sent through every peer that knows the friend,
1477 -- resending it right away without waiting has a high
1478 -- likelihood of failure as the chances of packet loss
1479 -- happening to all (up to to 8) packets sent is low.
1480 --
1481 , announceInterval = 30
1482
1483 })
1484 -- "friend" parameters
1485 --
1486 -- ni = NodeInfo
1487 -- r = Rendezvous
1488 -- tok = Nonce32
1489 -- dta = (NoSpamId{-them-},String)
1490 --
1491 -- Using k-selected identity, to send a
1492 -- friend-request to the JID $TESTZ300@OrjBG...:
1493 --
1494 -- > a +friend $TESTZ300@OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox Hey, add me!
1495 --
1496 , ("friend", DHTAnnouncable { announceSendData = Left ("toxid", readEither, \me them0 addr -> do
1497 let (Tox.NoSpamId sum them,txt) = them0
1498 Tox.NoSpam nospam _ = sum
1499 fr = Tox.FriendRequest nospam (T.encodeUtf8 $ T.pack txt)
1500 sendMessage
1501 (Tox.toxToRoute tox)
1502 (Tox.AnnouncedRendezvous them addr)
1503 (me,Tox.OnionFriendRequest fr))
1504 , announceParseAddress = \str -> do
1505 ni <- readEither str
1506 return ( ni :: Tox.NodeInfo )
1507 , announceParseToken = \_ str -> do
1508 tok <- readEither str
1509 return ( tok :: Nonce32 )
1510 , announceParseData = \str -> do
1511 let (jidstr,txt) = break isSpace str
1512 jid <- readEither jidstr
1513 return (jid, drop 1 txt)
1514 , announceTarget = \(Tox.NoSpamId _ pub,_) -> Tox.key2id pub
1515
1516 -- Friend requests are sent with exponentially increasing
1517 -- interval of 2 seconds, 4 seconds, 8 seconds, etc... in
1518 -- toxcore. This is so friend requests get resent but
1519 -- eventually get resent in intervals that are so big that
1520 -- they essentially expire. The sender has no way of
1521 -- knowing if a peer refuses a friend requests which is why
1522 -- friend requests need to expire in some way. Note that
1523 -- the interval is the minimum timeout, if toxcore cannot
1524 -- send that friend request it will try again until it
1525 -- manages to send it. One reason for not being able to
1526 -- send the friend request would be that the onion has not
1527 -- found the friend in the onion and so cannot send an
1528 -- onion data packet to them.
1529 --
1530 -- TODO: Support exponential backoff behavior. For now, setting
1531 -- interval to 8 seconds.
1532
1533 , announceInterval = 8
1534 })]
1535 , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox)
1536 , dhtBootstrap = case wantip of
1537 Want_IP4 -> toxStrap4
1538 Want_IP6 -> toxStrap6
1539 }
1540 tcpprober = tcpProber $ Tox.toxOnionRoutes tox
1541 tcpclient = tcpKademliaClient $ Tox.toxOnionRoutes tox
1542 tcpRefresher = tcpBucketRefresher $ Tox.toxOnionRoutes tox
1543 tcpDHT = DHT
1544 { dhtBuckets = refreshBuckets tcpRefresher
1545 , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox)
1546 , dhtPing = Map.singleton "ping" DHTPing
1547 { pingQuery = noArgPing $ TCP.tcpPing (TCP.tcpClient tcpclient)
1548 , pingShowResult = show
1549 }
1550 , dhtQuery = Map.singleton "node" DHTQuery
1551 { qsearch = TCP.nodeSearch tcpprober tcpclient
1552 , qhandler = \ni nid -> do
1553 ns <- R.kclosest (searchSpace $ TCP.nodeSearch tcpprober tcpclient)
1554 (searchK $ TCP.nodeSearch tcpprober tcpclient)
1555 nid
1556 <$> atomically (readTVar $ refreshBuckets tcpRefresher)
1557 return (ns,ns,Just ())
1558 , qshowR = show -- TCP.NodeInfo
1559 , qshowTok = (const Nothing)
1560 }
1561 , dhtAnnouncables = Map.empty
1562 , dhtParseId = readEither :: String -> Either String Tox.NodeId
1563 , dhtSearches = tcpSearches
1564 , dhtFallbackNodes = return []
1565 , dhtBootstrap = bootstrap tcpRefresher
1566 }
1567 dhts = Map.fromList $
1568 ("tox4", toxDHT Tox.routing4 Want_IP4)
1569 : (if ip6tox opts
1570 then [ ("tox6", toxDHT Tox.routing6 Want_IP6) ]
1571 else [])
1572 ++ [("toxtcp", tcpDHT)]
1573 ips :: IO [SockAddr]
1574 ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox
1575 , Tox.routing6 $ Tox.toxRouting tox ]
1576 return (Just tox, quitTox, dhts, ips, [Tox.toxBindAddress tox])
1577
1578initJabber :: Options
1579 -> TVar (Map.Map Uniq24 AggregateSession)
1580 -> Announcer
1581 -> Maybe (Tox.Tox JabberClients)
1582 -> Map.Map String DHT
1583 -> MUC
1584 -> IO ( Maybe XMPPServer
1585 , Maybe (Manager TCPStatus T.Text)
1586 , Maybe (PresenceState Pending)
1587 )
1588initJabber opts ssvar announcer mbtox toxdhts toxchat = case portxmpp opts of
1589 "" -> return (Nothing,Nothing,Nothing)
1590 p -> do
1591 cport <- getBindAddress p True{-IPv6 supported-}
1592 -- TODO: Allow running without an XMPP server-to-server port.
1593 -- This should probably be default for toxmpp use.
1594 sport <- getBindAddress (portxmppS opts) True{-IPv6 supported-}
1595
1596 -- XMPP initialization
1597 cw <- newConsoleWriter
1598 let lookupBkts :: String -> Map.Map String DHT -> Maybe (String,TVar (BucketList Tox.NodeInfo))
1599 lookupBkts name m = case Map.lookup name m of
1600 Nothing -> Nothing
1601 Just DHT{dhtBuckets} -> cast (name, dhtBuckets)
1602 let toxbkts = catMaybes
1603 [ lookupBkts "tox4" toxdhts
1604 , lookupBkts "tox6" toxdhts
1605 ]
1606
1607 sv <- xmppServer Tcp.noCleanUp (Just sport)
1608 tcp <- xmppConnections sv -- :: IO ( Manager TCPStatus T.Text )
1609 let tman = toxman ssvar announcer toxbkts <$> mbtox
1610 state <- newPresenceState cw tman sv (selectManager tman tcp)
1611 chat <- atomically newMUC
1612 quitChatService <- forkLocalChat chat
1613 let chats = Map.fromList [ ("local", chat)
1614 , ("ngc", toxchat) ]
1615 forkXmpp sv (presenceHooks state chats (verbosity opts) (Just cport) (Just sport))
1616 conns <- xmppConnections sv
1617 return (Just sv, Just conns, Just state)
1618
1619main :: IO ()
1620main = do
1621 args <- getArgs
1622 let opts = parseArgs args sensibleDefaults
1623 print opts
1624
1625 swarms <- Mainline.newSwarmsDatabase
1626 -- Restore peer database before forking the listener thread.
1627 peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat")
1628 either (dput XMisc . ("bt-peers.dat: "++))
1629 (atomically . writeTVar (Mainline.contactInfo swarms))
1630 (peerdb >>= S.decodeLazy)
1631
1632 announcer <- forkAnnouncer
1633
1634 -- Default: quiet all tags (except XMisc).
1635 forM ([minBound .. maxBound]::[DebugTag]) setQuiet
1636 forM (verboseTags opts) setVerbose
1637
1638 toxchat <- atomically newMUC
1639 (quitToxChat,invc) <- forkToxChat toxchat
1640
1641 (quitBt,btdhts,btips,baddrs) <- case portbt opts of
1642 "" -> return (return (), Map.empty,return [],[])
1643 p -> do
1644 addr <- getBindAddress p (ip6bt opts)
1645 (bt,btR,btBootstrap4, btBootstrap6) <- Mainline.newClient swarms addr
1646 quitBt <- forkListener "bt" (clientNet bt)
1647 mainlineSearches <- atomically $ newTVar Map.empty
1648 peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port.
1649 let mainlineDHT bkts wantip = DHT
1650 { dhtBuckets = bkts btR
1651 , dhtPing = Map.singleton "ping" $ DHTPing
1652 { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Mainline.ping bt
1653 , pingShowResult = show
1654 }
1655 , dhtQuery = Map.fromList
1656 [ ("node", DHTQuery
1657 { qsearch = (Mainline.nodeSearch bt)
1658 , qhandler = (\ni -> fmap Mainline.unwrapNodes
1659 . Mainline.findNodeH btR ni
1660 . flip Mainline.FindNode (Just Want_Both))
1661 , qshowR = show
1662 , qshowTok = (const Nothing)
1663 })
1664 -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
1665 -- sr = InfoHash
1666 -- stok = Token
1667 -- sni = NodeInfo
1668 , ("peer", DHTQuery
1669 { qsearch = (Mainline.peerSearch bt)
1670 , qhandler = (\ni -> fmap Mainline.unwrapPeers
1671 . Mainline.getPeersH btR swarms ni
1672 . flip Mainline.GetPeers (Just Want_Both)
1673 . (read . show)) -- TODO: InfoHash -> NodeId
1674 , qshowR = (show . pPrint)
1675 , qshowTok = (Just . show)
1676 })
1677 ]
1678 , dhtParseId = readEither :: String -> Either String Mainline.NodeId
1679 , dhtSearches = mainlineSearches
1680 , dhtFallbackNodes = Mainline.bootstrapNodes wantip
1681 , dhtAnnouncables = Map.fromList
1682 -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
1683 -- dta = Announce
1684 -- pr = Announced
1685 -- ptok = Token
1686 -- pni = NodeInfo
1687 [ ("peer", DHTAnnouncable { announceSendData = Right $ \ih tok -> \case
1688 Just ni -> do
1689 port <- atomically $ readTVar peerPort
1690 let dta = Mainline.mkAnnounce port ih tok
1691 Mainline.announce bt dta ni
1692 Nothing -> return Nothing
1693 , announceParseAddress = readEither
1694 , announceParseData = readEither
1695 , announceParseToken = const $ readEither
1696 , announceInterval = 60 -- TODO: Is one minute good?
1697 , announceTarget = (read . show) -- TODO: InfoHash -> NodeId -- peer
1698 })
1699 , ("port", DHTAnnouncable { announceParseData = readEither
1700 , announceParseToken = \_ _ -> return ()
1701 , announceParseAddress = const $ Right ()
1702 , announceSendData = Right $ \dta () -> \case
1703 Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
1704 return $ Just dta
1705 Just _ -> return Nothing
1706 , announceInterval = 0 -- TODO: The "port" setting should probably
1707 -- be a command rather than an announcement.
1708 , announceTarget = const $ Mainline.zeroID
1709 })]
1710
1711 , dhtSecretKey = return Nothing
1712 , dhtBootstrap = case wantip of
1713 Want_IP4 -> btBootstrap4
1714 Want_IP6 -> btBootstrap6
1715 }
1716 dhts = Map.fromList $
1717 ("bt4", mainlineDHT Mainline.routing4 Want_IP4)
1718 : if ip6bt opts
1719 then [ ("bt6", mainlineDHT Mainline.routing6 Want_IP6) ]
1720 else []
1721 ips :: IO [SockAddr]
1722 ips = readExternals Mainline.nodeAddr
1723 [ Mainline.routing4 btR
1724 , Mainline.routing6 btR
1725 ]
1726 return (quitBt,dhts,ips, [addr])
1727
1728 keysdb <- Tox.newKeysDatabase
1729
1730 ssvar <- atomically $ newTVar Map.empty
1731 rec (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate) <- do
1732
1733 (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox opts ssvar keysdb msv invc
1734
1735 (msv,mconns,mstate) <- initJabber opts ssvar announcer mbtox toxdhts toxchat
1736
1737 return (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate)
1738
1739 _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs
1740
1741 let dhts = Map.union btdhts toxdhts
1742
1743 (waitForSignal, checkQuit) <- do
1744 signalQuit <- atomically $ newTVar False
1745 let quitCommand = atomically $ writeTVar signalQuit True
1746 installHandler sigTERM (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
1747 installHandler sigINT (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
1748 let defaultToxData = do
1749 rster <- Tox.newContactInfo
1750 crypto <- newCrypto
1751 (orouter,_) <- newOnionRouter crypto (dput XMisc)
1752 return (rster, orouter)
1753 (rstr,orouter) <- fromMaybe defaultToxData $ do
1754 tox <- mbtox
1755 return $ return ( Tox.toxContactInfo tox, Tox.toxOnionRoutes tox )
1756 let session = clientSession0 $ Session
1757 { netname = concat $ take 1 $ Map.keys dhts -- initial default DHT
1758 , selectedKey = Nothing
1759 , dhts = dhts -- all DHTs
1760 , signalQuit = quitCommand
1761 , swarms = swarms
1762 , toxkeys = keysdb
1763 , roster = rstr
1764 , announceToLan = fromMaybe (return ()) $ Tox.toxAnnounceToLan <$> mbtox
1765 , connectionManager = ConnectionManager <$> mconns
1766 , onionRouter = orouter
1767 , externalAddresses = liftM2 (++) btips toxips
1768 , announcer = announcer
1769 , mbTox = mbtox
1770 }
1771 srv <- streamServer (withSession session) [SockAddrUnix "dht.sock"]
1772 return ( do atomically $ readTVar signalQuit >>= check
1773 quitListening srv
1774 , readTVar signalQuit >>= check
1775 )
1776
1777
1778 forM_ (Map.toList dhts)
1779 $ \(netname, dht@DHT { dhtBuckets = bkts
1780 , dhtQuery = qrys
1781 , dhtPing = pings
1782 , dhtFallbackNodes = getBootstrapNodes
1783 , dhtBootstrap = bootstrap }) -> do
1784 btSaved <- loadNodes netname -- :: IO [Mainline.NodeInfo]
1785 putStrLn $ "Loaded "++show (length btSaved)++" nodes for "++netname++"."
1786 fallbackNodes <- getBootstrapNodes
1787 let isNodesSearch :: ni :~: r -> Search nid addr tok ni r -> Search nid addr tok ni ni
1788 isNodesSearch Refl sch = sch
1789 ping = maybe (const $ return False)
1790 (\DHTPing{pingQuery} -> fmap (maybe False (const True)) . pingQuery [])
1791 $ Map.lookup "ping" pings
1792 fork $ do
1793 myThreadId >>= flip labelThread ("bootstrap."++netname)
1794 bootstrap btSaved fallbackNodes
1795 return ()
1796
1797 forkIO $ do
1798 myThreadId >>= flip labelThread "XMPP.stanzas"
1799 let console = cwPresenceChan <$> (mstate >>= consoleWriter)
1800 fix $ \loop -> do
1801 what <- atomically
1802 $ orElse (do (client,stanza) <- maybe retry takeTMVar console
1803 return $ forM_ mstate $ \state -> do
1804 informClientPresence0 state Nothing client stanza
1805 loop)
1806 (checkQuit >> return (return ()))
1807 what
1808
1809 forM msv $ \_ -> dput XMisc "Started XMPP server."
1810
1811 -- Wait for DHT and XMPP threads to finish.
1812 -- Use ResourceT to clean-up XMPP server.
1813 waitForSignal
1814
1815 forM_ mstate $ \PresenceState{server=xmpp} -> do
1816 quitXmpp xmpp
1817 stopAnnouncer announcer
1818 quitBt
1819 quitTox
1820
1821 swarmsdb <- atomically $ readTVar (Mainline.contactInfo swarms)
1822 forM_ (Map.toList dhts) $ \(netname,dht) -> do
1823 saveNodes netname dht
1824 dput XMisc $ "Saved " ++ nodesFileName netname ++ "."
1825 L.writeFile "bt-peers.dat" $ S.encodeLazy swarmsdb
1826 dput XMisc $ "Saved bt-peers.dat"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:02:55 +0000