diff options
| author | James Crayne <jim.crayne@gmail.com> | 2019-09-28 13:43:29 -0400 |
|---|---|---|
| committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 19:27:53 -0500 |
| commit | 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch) | |
| tree | 5716463275c2d3e902889db619908ded2a73971c /dht/examples/dhtd.hs | |
| parent | add2c76bced51fde5e9917e7449ef52be70faf87 (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 'dht/examples/dhtd.hs')
| -rw-r--r-- | dht/examples/dhtd.hs | 1826 |
1 files changed, 1826 insertions, 0 deletions
diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs new file mode 100644 index 00000000..2772416b --- /dev/null +++ b/dht/examples/dhtd.hs | |||
| @@ -0,0 +1,1826 @@ | |||
| 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 | |||
| 22 | module Main where | ||
| 23 | |||
| 24 | import Control.Arrow | ||
| 25 | import Control.Applicative | ||
| 26 | import Control.Concurrent.STM | ||
| 27 | import Control.Concurrent.STM.TMChan | ||
| 28 | import Control.Exception | ||
| 29 | import Control.Monad | ||
| 30 | import Control.Monad.IO.Class (liftIO) | ||
| 31 | import Data.Array.MArray (getAssocs) | ||
| 32 | import Data.Bool | ||
| 33 | import Data.Bits (xor) | ||
| 34 | import Data.Char | ||
| 35 | import Data.Conduit as C | ||
| 36 | import qualified Data.Conduit.List as C | ||
| 37 | import Data.Function | ||
| 38 | import Data.Functor.Identity | ||
| 39 | import Data.Hashable | ||
| 40 | import Data.List | ||
| 41 | import qualified Data.IntMap.Strict as IntMap | ||
| 42 | import qualified Data.Map.Strict as Map | ||
| 43 | import Data.Maybe | ||
| 44 | import qualified Data.Set as Set | ||
| 45 | import qualified Data.XML.Types as XML | ||
| 46 | import GHC.Conc (threadStatus,ThreadStatus(..)) | ||
| 47 | import GHC.Stats | ||
| 48 | import Network.Socket | ||
| 49 | import System.Environment | ||
| 50 | import System.IO | ||
| 51 | import System.Mem | ||
| 52 | import System.Posix.Process | ||
| 53 | import Text.PrettyPrint.HughesPJClass | ||
| 54 | import Text.Printf | ||
| 55 | import Text.Read | ||
| 56 | #ifdef THREAD_DEBUG | ||
| 57 | import Control.Concurrent.Lifted.Instrument | ||
| 58 | #else | ||
| 59 | import Control.Concurrent.Lifted | ||
| 60 | import GHC.Conc (labelThread) | ||
| 61 | #endif | ||
| 62 | import qualified Data.HashMap.Strict as HashMap | ||
| 63 | import qualified Data.Text as T | ||
| 64 | import qualified Data.Text.Encoding as T | ||
| 65 | import System.Posix.Signals | ||
| 66 | |||
| 67 | import Announcer | ||
| 68 | import Announcer.Tox | ||
| 69 | import ToxManager | ||
| 70 | import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys) | ||
| 71 | import DebugUtil | ||
| 72 | import Network.UPNP as UPNP | ||
| 73 | import Network.Address hiding (NodeId, NodeInfo(..)) | ||
| 74 | import Network.QueryResponse | ||
| 75 | import qualified Network.QueryResponse.TCP as TCP | ||
| 76 | import Network.StreamServer | ||
| 77 | import Network.Kademlia.Bootstrap (refreshBuckets,bootstrap) | ||
| 78 | import Network.Kademlia.CommonAPI | ||
| 79 | import Network.Kademlia.Persistence | ||
| 80 | import Network.Kademlia.Routing as R | ||
| 81 | import Network.Kademlia.Search | ||
| 82 | import qualified Network.BitTorrent.MainlineDHT as Mainline | ||
| 83 | import qualified Network.Tox as Tox | ||
| 84 | import qualified Data.ByteString.Lazy as L | ||
| 85 | import qualified Data.ByteString.Char8 as B | ||
| 86 | import Control.Concurrent.Tasks | ||
| 87 | import System.IO.Error | ||
| 88 | import qualified Data.Serialize as S | ||
| 89 | import Network.BitTorrent.DHT.ContactInfo as Peers | ||
| 90 | import qualified Data.MinMaxPSQ as MM | ||
| 91 | import Data.Wrapper.PSQ as PSQ (pattern (:->)) | ||
| 92 | import qualified Data.Wrapper.PSQ as PSQ | ||
| 93 | import Data.Ord | ||
| 94 | import Data.Time.Clock.POSIX | ||
| 95 | import qualified Network.Tox.DHT.Transport as Tox | ||
| 96 | import qualified Network.Tox.DHT.Handlers as Tox | ||
| 97 | import qualified Network.Tox.Onion.Transport as Tox | ||
| 98 | import qualified Network.Tox.Onion.Handlers as Tox | ||
| 99 | import qualified Network.Tox.Crypto.Transport as Tox | ||
| 100 | import qualified Network.Tox.TCP as TCP | ||
| 101 | import qualified TCPProber as TCP | ||
| 102 | import Data.Typeable | ||
| 103 | import Network.Tox.ContactInfo as Tox | ||
| 104 | import OnionRouter | ||
| 105 | import qualified Data.Word64Map as W64 | ||
| 106 | import Network.Tox.AggregateSession | ||
| 107 | import qualified Network.Tox.Session as Tox (Session) | ||
| 108 | ;import Network.Tox.Session hiding (Session) | ||
| 109 | |||
| 110 | -- Presence imports. | ||
| 111 | import Connection.Tcp (TCPStatus) | ||
| 112 | import ConsoleWriter | ||
| 113 | import Presence | ||
| 114 | import XMPPServer | ||
| 115 | import Connection | ||
| 116 | import ToxToXMPP | ||
| 117 | import XMPPToTox | ||
| 118 | import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp,TCPStatus) | ||
| 119 | import DPut | ||
| 120 | import DebugTag | ||
| 121 | import LocalChat | ||
| 122 | import ToxChat | ||
| 123 | import MUC | ||
| 124 | |||
| 125 | |||
| 126 | pshow :: Show a => a -> B.ByteString | ||
| 127 | pshow = B.pack . show | ||
| 128 | |||
| 129 | marshalForClient :: String -> String | ||
| 130 | marshalForClient s = show (length s) ++ ":" ++ s | ||
| 131 | |||
| 132 | marshalForClientB :: B.ByteString -> B.ByteString | ||
| 133 | marshalForClientB s = B.concat [pshow (B.length s),":",s] | ||
| 134 | |||
| 135 | data ClientHandle = ClientHandle Handle (MVar Int) | ||
| 136 | |||
| 137 | -- | Writes a message and signals ready for next command. | ||
| 138 | hPutClient :: ClientHandle -> String -> IO () | ||
| 139 | hPutClient (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. | ||
| 145 | hPutClientB :: ClientHandle -> B.ByteString -> IO () | ||
| 146 | hPutClientB (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. | ||
| 152 | hPutClientChunk :: ClientHandle -> String -> IO () | ||
| 153 | hPutClientChunk (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 | {- | ||
| 160 | pingNodes :: String -> DHT -> IO Bool | ||
| 161 | pingNodes 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 | |||
| 168 | asProxyTypeOf :: a -> proxy a -> a | ||
| 169 | asProxyTypeOf = const | ||
| 170 | |||
| 171 | pingNodes :: String -> DHT -> IO (Maybe Int) | ||
| 172 | pingNodes 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 | ||
| 188 | pingNodes _ _ = return Nothing | ||
| 189 | |||
| 190 | |||
| 191 | |||
| 192 | reportTable :: Show ni => BucketList ni -> [(String,String)] | ||
| 193 | reportTable bkts = map (show *** show . fst) | ||
| 194 | $ concat | ||
| 195 | $ zipWith map (map (,) [0::Int ..]) | ||
| 196 | $ R.toList | ||
| 197 | $ bkts | ||
| 198 | |||
| 199 | reportResult :: | ||
| 200 | String | ||
| 201 | -> (r -> String) | ||
| 202 | -> (tok -> Maybe String) | ||
| 203 | -> (ni -> String) | ||
| 204 | -> ClientHandle | ||
| 205 | -> Either String ([ni],[r],Maybe tok) | ||
| 206 | -> IO () | ||
| 207 | reportResult meth showR showTok showN h (Left e) = hPutClient h e | ||
| 208 | reportResult 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 | ||
| 228 | showSearches :: ( Show nid | ||
| 229 | , Ord nid | ||
| 230 | , Hashable nid | ||
| 231 | , Ord ni | ||
| 232 | , Hashable ni | ||
| 233 | ) => Map.Map (String,nid) (DHTSearch nid ni) -> IO String | ||
| 234 | showSearches 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 | |||
| 252 | forkSearch :: | ||
| 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 () | ||
| 267 | forkSearch 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 | |||
| 284 | reportSearchResults :: (Show t, Ord t1, Ord t, Hashable t) => | ||
| 285 | String -> ClientHandle -> DHTSearch t1 t -> IO () | ||
| 286 | reportSearchResults 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 | |||
| 299 | data ConnectionManager = forall status k. ConnectionManager { typedManager :: Connection.Manager status k } | ||
| 300 | |||
| 301 | data 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 | |||
| 317 | exceptionsToClient :: ClientHandle -> IO () -> IO () | ||
| 318 | exceptionsToClient (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 | |||
| 325 | hGetClientLine :: ClientHandle -> IO String | ||
| 326 | hGetClientLine (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 | |||
| 333 | hCloseClient :: ClientHandle -> IO () | ||
| 334 | hCloseClient (ClientHandle h hstate) = do | ||
| 335 | st <- takeMVar hstate | ||
| 336 | hClose h | ||
| 337 | putMVar hstate 3 -- closed file handle | ||
| 338 | |||
| 339 | clientSession0 :: Session -> t1 -> t -> Handle -> IO () | ||
| 340 | clientSession0 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 | |||
| 347 | parseDebugTag :: String -> Maybe DebugTag | ||
| 348 | parseDebugTag s' = readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s') | ||
| 349 | |||
| 350 | showPolicy TryingToConnect = "*" | ||
| 351 | showPolicy OpenToConnect = "o" | ||
| 352 | showPolicy RefusingToConnect = "x" | ||
| 353 | |||
| 354 | waitOn :: (nid -> ni -> (result -> IO ()) -> IO ()) | ||
| 355 | -> nid -> ni -> IO result | ||
| 356 | waitOn bg nid ni = do | ||
| 357 | mvar <- newEmptyMVar | ||
| 358 | bg nid ni $ putMVar mvar | ||
| 359 | takeMVar mvar | ||
| 360 | |||
| 361 | clientSession :: Session -> t1 -> t -> ClientHandle -> IO () | ||
| 362 | clientSession 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 | |||
| 1096 | readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr] | ||
| 1097 | readExternals 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 | |||
| 1105 | data 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 | |||
| 1125 | sensibleDefaults :: Options | ||
| 1126 | sensibleDefaults = 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 | ||
| 1140 | parseArgs :: [String] -> Options -> Options | ||
| 1141 | parseArgs [] opts = opts | ||
| 1142 | parseArgs ("--dhtkey":k:args) opts = parseArgs args opts | ||
| 1143 | { dhtkey = decodeSecret $ B.pack k } | ||
| 1144 | parseArgs ("--dht-key":k:args) opts = parseArgs args opts | ||
| 1145 | { dhtkey = decodeSecret $ B.pack k } | ||
| 1146 | parseArgs ("-4":args) opts = parseArgs args opts | ||
| 1147 | { ip6bt = False | ||
| 1148 | , ip6tox = False } | ||
| 1149 | parseArgs ("-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 | } | ||
| 1157 | parseArgs (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 | |||
| 1170 | noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r) | ||
| 1171 | noArgPing f [] x = f x | ||
| 1172 | noArgPing _ _ _ = return Nothing | ||
| 1173 | |||
| 1174 | -- | Create a Conduit Source by repeatedly calling an IO action. | ||
| 1175 | ioToSource :: IO (Maybe x) -> IO () -> ConduitT () x IO () | ||
| 1176 | ioToSource !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 | {- | ||
| 1184 | newXmmpSink :: Tox.NetCryptoSession -> C.Sink (Flush Tox.CryptoMessage) IO () | ||
| 1185 | newXmmpSink 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 | |||
| 1211 | onNewToxSession :: XMPPServer | ||
| 1212 | -> TVar (Map.Map Uniq24 AggregateSession) | ||
| 1213 | -> InviteCache IO | ||
| 1214 | -> ContactInfo extra | ||
| 1215 | -> SockAddr | ||
| 1216 | -> Tox.Session | ||
| 1217 | -> IO () | ||
| 1218 | onNewToxSession 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 | |||
| 1279 | selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text | ||
| 1280 | selectManager 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 | |||
| 1343 | initTox :: 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]) | ||
| 1352 | initTox 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 | |||
| 1578 | initJabber :: 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 | ) | ||
| 1588 | initJabber 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 | |||
| 1619 | main :: IO () | ||
| 1620 | main = 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" | ||