{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Main where import Control.Arrow import Control.Applicative import Control.Concurrent.STM import Control.Concurrent.STM.TMChan import Control.Exception import Control.Monad import Control.Monad.IO.Class (liftIO) import Crypto.Random (getRandomBytes) import Data.Array.MArray (getAssocs) import Data.Bool import Data.Bits (xor) import Data.Char import Data.Conduit as C import qualified Data.Conduit.List as C import Data.Data import Data.Dependent.Sum import Data.Function import Data.Functor import Data.Functor.Identity import Data.Hashable import Data.List import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Set as Set import qualified Data.XML.Types as XML import GHC.Conc (threadStatus,ThreadStatus(..)) import GHC.Stats import Network.Socket import System.Environment import System.Exit import System.IO import System.Mem import System.Posix.Process import Text.PrettyPrint.HughesPJClass import Text.Printf import Text.Read import Control.Concurrent.ThreadUtil import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as T import qualified Data.Text.Encoding as T import System.Posix.Signals import Announcer import Announcer.Tox import ToxManager import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys) import qualified Data.Tox.DHT.Multi as Multi import DebugUtil import Network.UPNP as UPNP import Network.Address hiding (NodeId, NodeInfo(..)) import Network.Bind as Bind import Network.QueryResponse import qualified Network.QueryResponse.TCP as TCP import Network.StreamServer import Network.Kademlia.Bootstrap (refreshBuckets,bootstrap, BucketRefresher(..), BucketSearch(..) ) import Network.Kademlia.CommonAPI import Network.Kademlia.Persistence import Network.Kademlia.Routing as R import Network.Kademlia.Search import qualified Network.BitTorrent.MainlineDHT as Mainline import qualified Network.Tox as Tox import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as B import Control.Concurrent.Tasks import System.IO.Error import qualified Data.Serialize as S import Network.BitTorrent.DHT.ContactInfo as Peers import qualified Data.MinMaxPSQ as MM import Data.Wrapper.PSQ as PSQ (pattern (:->)) import qualified Data.Wrapper.PSQ as PSQ import Data.Wrapper.PSQInt as IPSQ (findMin) import Data.Ord import Data.Time.Clock.POSIX import qualified Network.Tox.DHT.Transport as Tox import qualified Network.Tox.DHT.Handlers as Tox import qualified Network.Tox.Onion.Transport as Tox import qualified Network.Tox.Onion.Handlers as Tox import qualified Network.Tox.Crypto.Transport as Tox import qualified Network.Tox.TCP as TCP import qualified TCPProber as TCP import Data.Typeable import Network.Tox.ContactInfo as Tox import Network.Tox.Onion.Routes import Network.Tox.RelayPinger import qualified Data.Word64Map as W64 import Network.Tox.AggregateSession import qualified Network.Tox.Session as Tox (Session) ;import Network.Tox.Session hiding (Session) -- Presence imports. import Connection.Tcp (TCPStatus) import ConsoleWriter import Presence import XMPPServer import Connection import ToxToXMPP import XMPPToTox import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp,TCPStatus) import DPut import DebugTag import LocalChat import ToxChat import MUC import Data.Either pshow :: Show a => a -> B.ByteString pshow = B.pack . show marshalForClient :: String -> String marshalForClient s = show (length s) ++ ":" ++ s marshalForClientB :: B.ByteString -> B.ByteString marshalForClientB s = B.concat [pshow (B.length s),":",s] data ClientHandle = ClientHandle Handle (MVar Int) -- | Writes a message and signals ready for next command. hPutClient :: ClientHandle -> String -> IO () hPutClient (ClientHandle h hstate) s = do st <- takeMVar hstate hPutStr h ('.' : marshalForClient s) putMVar hstate 1 -- ready for input -- | Writes a message and signals ready for next command. hPutClientB :: ClientHandle -> B.ByteString -> IO () hPutClientB (ClientHandle h hstate) s = do st <- takeMVar hstate B.hPutStr h ('.' `B.cons` marshalForClientB s) putMVar hstate 1 -- ready for input -- | Writes message, but signals there is more to come. hPutClientChunk :: ClientHandle -> String -> IO () hPutClientChunk (ClientHandle h hstate) s = do st <- takeMVar hstate hPutStr h (' ' : marshalForClient s) putMVar hstate 2 -- ready for more output {- pingNodes :: String -> DHT -> IO Bool pingNodes netname DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "ping" dhtPing = do let fname = nodesFileName netname attempt <- tryIOError $ do J.decode <$> L.readFile fname >>= maybe (ioError $ userError "Nothing") return -} asProxyTypeOf :: a -> proxy a -> a asProxyTypeOf = const pingNodes :: String -> DHT -> IO (Maybe Int) pingNodes netname dht@DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "ping" dhtPing = do let fname = nodesFileName netname ns <- loadNodes netname case ns of [] -> return Nothing _ -> do fork $ do myThreadId >>= flip labelThread ("pinging."++fname) putStrLn $ "Forked "++show fname withTaskGroup ("withTaskGroup."++fname) 10 $ \g -> do forM_ (ns `asTypeOf` []) $ \n -> forkTask g (show n) $ void $ ping [] n putStrLn $ "Load finished "++show fname return $ Just $ length ns pingNodes _ _ = return Nothing reportTable :: Show ni => BucketList ni -> [(String,String)] reportTable bkts = map (show *** show . fst) $ concat $ zipWith map (map (,) [0::Int ..]) $ R.toList $ bkts reportResult :: String -> (r -> String) -> (tok -> Maybe String) -> (ni -> String) -> ClientHandle -> Either String ([ni],[r],Maybe tok) -> IO () reportResult meth showR showTok showN h (Left e) = hPutClient h e reportResult meth showR showTok showN h (Right (ns,rs,tok)) = do hPutClient h $ showReport report where report = intercalate [("","")] [ tok_r , node_r , result_r ] tok_r = maybe [] (pure . ("token:",)) $ showTok =<< tok node_r = map ( ("n",) . showN ) ns result_r | (meth=="node") = [] | otherwise = map ( (take 1 meth,) . showR ) rs -- example: -- * 10 peer 141d6c6ee2810f46d28bbe8373d4f454a4122535 -- - 1 peer 141d6c6ee2810f46d28bbe8373d4f454a4122535 -- 22 node 141d6c6ee2810f46d28bbe8373d4f454a4122535 -- -- key: '*' in progress -- '-' stopped -- ' ' finished showSearches :: ( Show nid , Ord nid , Hashable nid , Ord ni , Hashable ni ) => Map.Map (String,nid) (DHTSearch nid ni) -> IO String showSearches searches = do tups <- forM (Map.toList searches) $ \((meth,nid),DHTSearch{..}) -> do getSearchTuple meth nid searchState searchResults searchThread return $ showSearchTuples tups showSearchTuples tups = do let cnt'width = maximum $ map (\(_,cnt,_,_)->length cnt) tups mth'width = maximum $ map (\(_,_,mth,_)->length mth) tups (stat,cnt,meth,nid) <- tups printf " %c %-*s %-*s %s\n" stat cnt'width cnt mth'width meth nid getSearchTuple meth nid searchState searchResults searchThread = do (is'fin, cnt) <- atomically $ (,) <$> searchIsFinished searchState <*> (Set.size <$> readTVar searchResults) tstat <- threadStatus searchThread let stat = case tstat of _ | is'fin -> ' ' ThreadFinished -> '-' ThreadDied -> '-' _ -> '*' return ( (stat,show cnt,meth,show nid) :: (Char,String,String,String) ) showRefresherStatus BucketRefresher{..} = do now <- getPOSIXTime (st,hdr) <- atomically $ do rq <- readTVar refreshQueue -- Int.PSQ PosixTime lt <- readTVar refreshLastTouch -- POSIXTime bm <- readTVar bootstrapMode -- Bool cd <- readTVar bootstrapCountdown -- Maybe Int st <- readTVar refreshState -- IntMap [BucketSearch nid ni] return $ (,) st $ showReport [ (" bootstrap:", show bm) , (" countdown:", show cd) , (" touched:", show (now - lt)) , (" next-up:", maybe "Nothing" (\(n,t,()) -> show n ++ " " ++ show (t - now)) $ IPSQ.findMin rq) ] let bgschs = concatMap (\(n,xs) -> map ((,) n) xs) $ IntMap.toList st tups <- forM bgschs $ \(n,BucketSearch{..}) -> do getSearchTuple ('#' : show n) bucketSample bucketState bucketResults bucketThread return $ hdr ++ showSearchTuples tups showSearchState refresher searches = do b <- showRefresherStatus refresher u <- showSearches searches return $ "Bucket Maintenance\n" ++ b ++ "User Searches\n" ++ u forkSearch :: ( Ord nid , Hashable nid , Ord ni , Hashable ni , Show nid ) => String -> nid -> DHTQuery nid ni -> TVar (Map.Map (String,nid) (DHTSearch nid ni)) -> [ni] -> ThreadId -> TVar (Maybe (IO ())) -> STM () forkSearch method nid DHTQuery{qsearch,qshowTok,qshowR} dhtSearches ns tid kvar = do st <- newSearch qsearch nid ns results <- newTVar Set.empty let storeResult r = modifyTVar' results (Set.insert (qshowR r)) >> return True new = DHTSearch { searchThread = tid , searchState = st , searchShowTok = qshowTok , searchResults = results } modifyTVar' dhtSearches $ Map.insert (method,nid) new -- Finally, we write the search loop action into a tvar that will be executed in a new -- thread. writeTVar kvar $ Just $ searchLoop qsearch nid storeResult st reportSearchResults :: (Show t, Ord t1, Ord t, Hashable t) => String -> ClientHandle -> DHTSearch t1 t -> IO () reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} = do (ns,rs) <- atomically $ do mm <- readTVar $ searchInformant searchState rset <- readTVar searchResults let ns = map (\(MM.Binding ni tok _) -> (ni,tok)) $ MM.toList mm rs = Set.toList rset return (ns,rs) let n'width = succ $ maximum $ map (length . show . fst) ns showN (n,tok) = take n'width (show n ++ repeat ' ') ++ (fromMaybe "" $ searchShowTok =<< tok) ns' = map showN ns reportResult meth id (const Nothing) id h (Right (ns',rs, Just ())) data ConnectionManager = forall status k. Data k => ConnectionManager { typedManager :: Connection.Manager status k } data Session = Session { netname :: String , selectedKey :: Maybe PublicKey , dhts :: Map.Map String DHT , externalAddresses :: IO [SockAddr] , swarms :: Mainline.SwarmsDatabase , toxkeys :: TVar Tox.AnnouncedKeys , roster :: Tox.ContactInfo JabberClients , announceToLan :: IO () , connectionManager :: Maybe ConnectionManager , onionRouter :: OnionRouter , announcer :: Announcer , signalQuit :: IO () , mbTox :: Maybe (Tox.Tox JabberClients) , sessionsVar :: TVar (Map.Map Uniq24 AggregateSession) } exceptionsToClient :: ClientHandle -> IO () -> IO () exceptionsToClient (ClientHandle h hstate) action = action `catch` \(SomeException e) -> do st <- takeMVar hstate when (st /= 1) $ do hPutStr h ('.': marshalForClient (show e)) putMVar hstate 1 -- ready for input hGetClientLine :: ClientHandle -> IO String hGetClientLine (ClientHandle h hstate) = do st <- takeMVar hstate -- st should be 1 x <- hGetLine h putMVar hstate 0 -- ready for output return x hCloseClient :: ClientHandle -> IO () hCloseClient (ClientHandle h hstate) = do st <- takeMVar hstate hClose h putMVar hstate 3 -- closed file handle clientSession0 :: Session -> t1 -> t -> Handle -> IO () clientSession0 s sock cnum h = do hstate <- newMVar 1 -- ready for input clientSession s sock cnum (ClientHandle h hstate) `catch` \e -> if isEOFError e then return () else throwIO e parseDebugTag :: String -> Maybe DebugTag parseDebugTag s' = readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s') showPolicy TryingToConnect = "*" showPolicy OpenToConnect = "o" showPolicy RefusingToConnect = "x" getSessions :: TVar (Map.Map Uniq24 AggregateSession) -> Uniq24 -> STM [Tox.Session] getSessions ssvar u24 = do agmap <- readTVar ssvar case Map.lookup u24 agmap of Nothing -> return [] Just agg -> do smap <- readTVar $ contactSession agg return $ map singleSession $ IntMap.elems smap clientSession :: Session -> t1 -> t -> ClientHandle -> IO () clientSession s@Session{..} sock cnum h = do line <- dropWhile isSpace <$> hGetClientLine h let (c,args) = second (dropWhile isSpace) $ break isSpace line cmd0 :: IO () -> IO () cmd0 action = exceptionsToClient h action >> clientSession s sock cnum h switchNetwork dest = do hPutClient h ("Network: "++dest) clientSession s{netname=dest} sock cnum h switchKey key = clientSession s { selectedKey = key } sock cnum h twoWords str = let (word1,a1) = break isSpace (dropWhile isSpace str) (word2,a2) = break isSpace (dropWhile isSpace a1) in (word1,word2,drop 1 a2) strp = B.unpack . fst . until snd dropEnd . (,False) . B.dropWhile isSpace . B.pack where dropEnd (x,_) = case B.unsnoc x of Just (str,c) | isSpace c -> (str,False) _ -> (x,True) allDebugTags :: [DebugTag] allDebugTags = [minBound .. maxBound] showDebugTags = do vs <- mapM getVerbose allDebugTags let f True = "v" f False = "-" hPutClient h $ showReport (zip (map (drop 1 . show) allDebugTags) (map f vs)) let readHex :: (Read n, Integral n) => String -> Maybe n readHex s = readMaybe ("0x" ++ s) let mkrow :: (SecretKey, PublicKey) -> (String,String) mkrow (a,b) | Just x <- encodeSecret a= (B.unpack x, show (Tox.key2id b)) mkrow _ = error (concat ["Assertion fail in 'mkrow' function at ", __FILE__, ":", show __LINE__]) sessionCommands :: [[String]] sessionCommands = [ ["ping"] -- pinglike , ["cookie"] -- pinglike , ["stop"] , ["throw"] , ["quit"] , ["pid"] , ["external-ip"] , ["threads"] , ["mem"] , ["nid"] , ["lan"] , ["ls"] , ["r"] , ["k"] , ["roster"] , ["tcp"] , ["o"] , ["g"] , ["p"] , ["a"] , ["s"] , ["x"] , ["save"] , ["load"] , ["swarms"] , ["peers"] , ["toxids"] , ["c"] , ["quiet"] , ["verbose"] , ["help"] ] case (map toLower c,args) of (n, _) | n `elem` Map.keys dhts -> switchNetwork n -- "ping" -- "cookie" (pinglike, s) | Just DHT{dhtPing} <- Map.lookup netname dhts , Just DHTPing{ pingQuery=ping , pingShowResult=showr } <- Map.lookup pinglike dhtPing , ws@(_:_) <- words s -> cmd0 $ do case readEither $ last ws of Right addr -> do result <- ping (init ws) addr let rs = [" ", maybe "Timeout." showr result] hPutClient h $ unlines rs Left er -> hPutClient h er (x,_) | not (null (strp x)) , x `notElem` map head sessionCommands -> cmd0 $ do hPutClient h $ "error." ("stop", _) -> do hPutClient h "Terminating DHT Daemon." hCloseClient h signalQuit ("throw", er) -> cmd0 $ do throwIO $ userError er hPutClient h "The impossible happened!" ("quit", _) -> hPutClient h "" >> hCloseClient h ("pid", _) -> cmd0 $ do pid <- getProcessID hPutClient h (show pid) ("external-ip", _) -> cmd0 $ do unlines . map (either show show . either4or6) <$> externalAddresses >>= hPutClient h #ifdef THREAD_DEBUG ("threads", s) -> cmd0 $ do let want_ss = ["-v"] `isInfixOf` words s r <- threadReport want_ss hPutClient h r #endif ("mem", s) -> cmd0 $ do case s of "gc" -> do hPutClient h "Performing garbage collection..." performMajorGC "" -> do #if MIN_VERSION_base(4,10,1) is_enabled <- getRTSStatsEnabled #else is_enabled <- getGCStatsEnabled #endif if is_enabled then do #if MIN_VERSION_base(4,10,1) RTSStats{..} <- getRTSStats let r = [ ("bytesAllocated", show allocated_bytes) , ("numGcs", show gcs) , ("maxBytesUsed", show max_live_bytes) --, ("numByteUsageSamples", show numByteUsageSamples) , ("cumulativeBytesUsed", show cumulative_live_bytes) , ("bytesCopied", show copied_bytes) , ("currentBytesUsed", show allocated_bytes) --, ("currentBytesSlop", show currentBytesSlop) , ("maxBytesSlop", show max_slop_bytes) -- , ("peakMegabytesAllocated", show peakMegabytesAllocated) , ("mutatorCpuNanoseconds", show mutator_cpu_ns) , ("mutatorWallNanoseconds", show mutator_elapsed_ns) , ("gcCpuSeconds", show gc_cpu_ns) , ("gcWallSeconds", show gc_elapsed_ns) , ("cpuSeconds", show cpu_ns) , ("wallSeconds", show elapsed_ns) , ("parTotBytesCopied", show par_copied_bytes) , ("parMaxBytesCopied", show cumulative_par_max_copied_bytes) #else GCStats{..} <- getGCStats let r = [ ("bytesAllocated", show bytesAllocated) , ("numGcs", show numGcs) , ("maxBytesUsed", show maxBytesUsed) , ("numByteUsageSamples", show numByteUsageSamples) , ("cumulativeBytesUsed", show cumulativeBytesUsed) , ("bytesCopied", show bytesCopied) , ("currentBytesUsed", show currentBytesUsed) , ("currentBytesSlop", show currentBytesSlop) , ("maxBytesSlop", show maxBytesSlop) , ("peakMegabytesAllocated", show peakMegabytesAllocated) , ("mutatorCpuSeconds", show mutatorCpuSeconds) , ("mutatorWallSeconds", show mutatorWallSeconds) , ("gcCpuSeconds", show gcCpuSeconds) , ("gcWallSeconds", show gcWallSeconds) , ("cpuSeconds", show cpuSeconds) , ("wallSeconds", show wallSeconds) , ("parTotBytesCopied", show parTotBytesCopied) , ("parMaxBytesCopied", show parMaxBytesCopied) #endif ] hPutClient h $ showReport r else hPutClient h "Run with +RTS -T to obtain live memory-usage information." _ -> hPutClient h "error." ("nid", s) | Just DHT{dhtParseId,dhtShowHexId} <- Map.lookup netname dhts -> cmd0 $ do hPutClient h $ case dhtParseId s of Left e -> -- HACK: split nospam from hex toxid case dhtParseId (take 64 s) of Left e -> case Tox.parseNoSpamId $ T.pack s of Left ej -> if elem '@' s then "Error: " ++ ej else "Error: " ++ e Right jid -> unlines [ show jid , Tox.noSpamIdToHex jid ] Right nid -> let nspam = drop 64 s jid :: Maybe Tox.NoSpamId jid = readMaybe $ '0':'x':nspam ++ "@" ++ show nid ++ ".tox" in unlines [ maybe "" show jid , show nid ++ " nospam:" ++ nspam ] Right nid -> maybe (show nid) (\shwhex -> unlines [show nid, shwhex nid]) dhtShowHexId ("lan", _) -> cmd0 $ do announceToLan hPutClient h "ok" ("ls", _) | Just DHT{dhtBuckets} <- Map.lookup netname dhts -> cmd0 $ do bkts <- atomically $ readTVar (refreshBuckets dhtBuckets) let r = reportTable bkts hPutClient h $ showReport $ r ++ [ ("buckets", show $ R.shape bkts) , ("node-id", show $ thisNode bkts) , ("network", netname) ] ("r", s) | Just DHT{dhtQuery,dhtBuckets} <- Map.lookup netname dhts , Just DHTQuery{qsearch} <- Map.lookup "node" dhtQuery -> cmd0 $ do ni <- atomically $ thisNode <$> readTVar (refreshBuckets dhtBuckets) let kad = searchSpace qsearch nid = kademliaLocation kad ni b = case readMaybe $ strp s of Nothing -> bucketRange 0 True Just n -> bucketRange n False rnid <- kademliaSample kad getRandomBytes nid b hPutClient h $ show rnid -- TODO: online documentation. -- -- k - manage key-pairs -- -- k (list keys) -- k gen (generate new key and list keys) -- k add (input a specific secret key) -- k del -- k secrets (list key pairs, including secret keys) ("k", s) | "" <- strp s -> cmd0 $ do ks <- atomically $ myKeyPairs roster let spaces k | Just sel <- selectedKey, (sel == k) = " *" | otherwise = " " hPutClient h $ unlines $ map (\(_,k) -> mappend (spaces k) . show . Tox.key2id $ k) ks | "gen" <- strp s -> do secret <- generateSecretKey let pubkey = toPublic secret oldks <- atomically $ do ks <- myKeyPairs roster Tox.addContactInfo roster secret Map.empty return ks let asString = show . Tox.key2id hPutClient h $ unlines $ map (mappend " " . show . Tox.key2id . snd) oldks ++ [mappend " *" . show . Tox.key2id $ pubkey] switchKey $ Just pubkey | "secrets" <- strp s -> cmd0 $ do ks <- atomically $ myKeyPairs roster skey <- maybe (return Nothing) (atomically . dhtSecretKey) $ Map.lookup netname dhts hPutClient h . showReport $ (map mkrow ks ++) $ fromMaybe [] $ do sk <- skey let pk = Tox.key2id $ toPublic sk x <- encodeSecret sk Just [("",""),("dht-key:",""),(B.unpack x, show pk)] | ("sel",_:expr) <- break isSpace s -> do ks <- atomically $ map (show . Tox.key2id . snd) <$> myKeyPairs roster case find (isInfixOf expr) ks of Just k -> do hPutClient h $ "Selected key: "++k switchKey $ Just $ Tox.id2key $ read k Nothing -> cmd0 $ hPutClient h "no match." | ("add":secs) <- words s , mbSecs <- map (decodeSecret . B.pack) secs , all isJust mbSecs -> do let f (Just b) = b f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__]) let toPair x = (x,toPublic x) pairs = map (toPair . f) mbSecs oldks <- atomically $ do oldks <- myKeyPairs roster forM pairs $ \(sk,_) -> Tox.addContactInfo roster sk Map.empty return oldks hPutClient h $ unlines $ map (mappend " " . show . Tox.key2id . snd) oldks ++ map (mappend " *" . show . Tox.key2id .snd) pairs switchKey $ listToMaybe $ map snd pairs | ("del":secs) <- words s , mbSecs <- map (decodeSecret . B.pack) secs , all isJust mbSecs -> do let f (Just b) = b f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__]) let toPair x = (x,toPublic x) pairs = map (toPair . f) mbSecs ks <- atomically $ do forM pairs $ \(_,pk) -> Tox.delContactInfo roster pk myKeyPairs roster hPutClient h . showReport $ map mkrow ks switchKey $ do k <- selectedKey guard $ k `notElem` map snd pairs Just k ("roster", s) -> cmd0 $ join $ atomically $ do let ContactInfo{accounts} = roster nosummary = not (null s) as <- readTVar accounts css <- forM as $ \acnt -> do cs <- readTVar (contacts acnt) forM cs $ \c -> do ck <- readTVar $ contactKeyPacket c ca <- readTVar $ contactLastSeenAddr c cf <- readTVar $ contactFriendRequest c cp <- readTVar $ contactPolicy c let summarizeNodeId | nosummary = id | otherwise = take 20 summarizeAddr | nosummary = id | otherwise = reverse . take 20 . reverse return $ [ maybe "/" showPolicy cp , maybe (maybe "" (summarizeNodeId . show . Tox.key2id . Tox.dhtpk . snd) ck) (summarizeAddr . show . snd) ca , maybe "" (show . T.decodeUtf8 . Tox.friendRequestText . snd) cf ] return $ do forM_ (HashMap.toList css) $ \(me,xss) -> do let cs = map (\(toxid,xs) -> show toxid : xs) $ HashMap.toList xss hPutClientChunk h $ let header = show me ++ if nosummary then "" else " (pass -v for more)" in unlines [ header, map (const '-') header ] hPutClientChunk h $ showColumns $ ["ToxID","","Address","FR text"] : cs hPutClient h "" ("quiet",s) | s' <- strp s , Just (tag::DebugTag) <- parseDebugTag s' -> cmd0 $ do setQuiet tag hPutClient h $ "Suppressing " ++ show tag ++ " messages." ("quiet",s) | "all" <- strp s -> cmd0 $ do mapM_ setQuiet allDebugTags showDebugTags (verbose,s) | "" <- strp s , verbose `elem` ["verbose","quiet"] -> cmd0 $ showDebugTags ("verbose",s) | "all" <- strp s -> cmd0 $ do mapM_ setVerbose allDebugTags showDebugTags ("verbose",s) | s' <- strp s , Just (tag::DebugTag) <- parseDebugTag s' -> cmd0 $ do setVerbose tag hPutClient h $ "Showing " ++ show tag ++ " messages." ("tcp",s) | "" <- strp s -> cmd0 $ join $ atomically $ do tcps <- readTVar (TCP.lru $ tcpProberState onionRouter) return $ do now <- getPOSIXTime forM (MM.toList tcps) $ \(MM.Binding (TCP.TCPAddress addr) tcp (Down tm)) -> do hPutClientChunk h $ unwords [show addr, show (now - tm), TCP.showStat tcp] ++ "\n" hPutClient h $ show (MM.size tcps) ++ " active or pending connections.\n" ("o", s) | "" <- strp $ map toLower s -> cmd0 $ do now <- getPOSIXTime join $ atomically $ do rm <- IntMap.fromList . catMaybes . map (\(i,m) -> fmap (i,) m) <$> getAssocs (routeMap onionRouter) let trampstate t = do ts <- readTVar $ setNodes t tcnt <- readTVar $ setCount t icnt <- HashMap.size <$> readTVar (setIDs t) return (ts,tcnt,icnt) (uts,tcnt,icnt) <- trampstate (trampolinesUDP onionRouter) (tts,ttcnt,ticnt) <- trampstate (trampolinesTCP onionRouter) rs <- getAssocs (pendingRoutes onionRouter) pqs <- readTVar (pendingQueries onionRouter) tcp_spill <- readTVar (TCP.probeSpill $ tcpProber onionRouter) tcp_cache <- readTVar (TCP.probeCache $ tcpProber onionRouter) tcp_queue <- readTVar (TCP.probeQueue $ tcpProber onionRouter) tcpmode <- requestTCPModeSTM onionRouter Nothing tcps <- readTVar (TCP.lru $ tcpProberState onionRouter) let showRecord :: Int -> Int -> [String] showRecord n wanted_ver | Just RouteRecord{responseCount,timeoutCount,routeVersion,routeBirthTime ,storedRoute=Tox.OnionRoute{routeRelayPort}} <- IntMap.lookup n rm = [ show n, show responseCount, show timeoutCount , maybe "" show routeRelayPort , show (now - routeBirthTime) , if routeVersion >= wanted_ver then show routeVersion else show routeVersion ++ "(pending)" ] | otherwise = [show n, "error!","","",""] -- otherwise = [show n, "error!",show (IntMap.lookup n rm),show (IntMap.null rm),""] r = map (uncurry showRecord) rs (rcnt,relays) <- currentRelays (tcpRelayPinger onionRouter) return $ do hPutClientChunk h $ unlines [ "trampolines(UDP): " ++ show (IntMap.size uts) -- ,tcnt,icnt) ++ if tcpmode then "" else " *" , "trampolines(TCP): " ++ show (IntMap.size tts) -- ,ttcnt,ticnt) ++ if tcpmode then " *" else "" , "active TCP: " ++ show (MM.size tcps) , "pending: " ++ show (W64.size pqs) , "TCP spill,cache,queue: " ++ show (PSQ.size tcp_spill, PSQ.size tcp_cache, PSQ.size tcp_queue)] hPutClientChunk h $ showColumns $ ["","responses","timeouts", "tcp", "age", "version"]:r hPutClient h $ unlines $ ("relays: " ++ show rcnt) : map (mappend " " . show) relays ("o", s) | "udp" <- strp $ map toLower s -> cmd0 $ do tcpm <- requestTCPMode onionRouter (Just False) hPutClient h $ "Onion routes: " ++ if tcpm then "TCP." else "UDP." ("o", s) | "tcp" <- strp $ map toLower s -> cmd0 $ do tcpm <- requestTCPMode onionRouter (Just True) hPutClient h $ "Onion routes: " ++ if tcpm then "TCP." else "UDP." ("o", s) | n <- strp $ map toLower s , all isDigit n -> cmd0 $ do case Tox.RouteId <$> readMaybe n of Just r -> do monion <- lookupRoute onionRouter (error "lookupRoute used NodeInfo argument!") r case monion of Nothing -> hPutClient h $ "No route yet for " ++ show r Just onion -> hPutClient h $ unlines $ showRoute " " onion Nothing -> hPutClient h "syntax error." ("g", s) | Just DHT{..} <- Map.lookup netname dhts -> cmd0 $ do -- arguments: method -- nid -- (optional dest-ni) self <- atomically $ thisNode <$> readTVar (refreshBuckets dhtBuckets) let (method,xs) = break isSpace $ dropWhile isSpace s (nidstr,ys) = break isSpace $ dropWhile isSpace xs destination = dropWhile isSpace ys goQuery qry = either (hPutClient h . ("Bad search target: "++)) (goTarget qry) $ dhtParseId nidstr goTarget DHTQuery{..} nid = go nid >>= reportResult method qshowR qshowTok show h where go | null destination = fmap Right . qhandler self | otherwise = case readEither destination of Right ni -> \nid -> do v <- newEmptyMVar _ <- searchQuery qsearch nid ni $ \_ r -> putMVar v r r <- takeMVar v return $ case r of Success x -> Right x Canceled -> Left "Canceled." TimedOut -> Left "Timeout." Left e -> const $ return $ Left ("Bad destination: "++e) maybe (hPutClient h ("Unsupported method: "++method)) goQuery $ Map.lookup method dhtQuery -- TODO: Online help. -- -- p - put/publish a single given datum on a single given node. -- -- When destination address (node-addr) is optional, it's absense means to -- publish information in the local node's own database. -- -- Bittorrent: (peer) publish yourself as peer in swarm. -- (port) set your current bittorrent listen port. -- -- p peer [node-addr] -- -- p port -- -- Tox: (toxid) publish a rendezvous onion route to dht node. -- (friend) send a friend-request over a rendezvous point. -- (dhtkey) send your dht node-id over a rendezvous point. -- -- p toxid -- -- p friend -- -- p dhtkey ("p", s) | Just DHT{..} <- Map.lookup netname dhts -> cmd0 $ do -- arguments: Left Right -- ---- ----- -- method method -- data (jid or key) data -- dest-rendezvous(r) token -- (optional extra-text) (optional dest-ni) self <- atomically $ thisNode <$> readTVar (refreshBuckets dhtBuckets) let (method,xs) = break isSpace $ dropWhile isSpace s (dtastr,ys) = break isSpace $ dropWhile isSpace xs (tokenstr,zs) = break isSpace $ dropWhile isSpace ys destination = dropWhile isSpace zs goTarget DHTAnnouncable{..} | Right asend <- announceSendData = do let dta = announceParseData dtastr tok = dta >>= flip announceParseToken tokenstr case liftA2 (,) dta tok of Left e -> hPutClient h e Right nid -> go asend nid >>= either (hPutClient h) (hPutClient h . show) where go asend | null destination = fmap (maybe (Left "Timeout.") Right) . flip (uncurry asend) Nothing | otherwise = case announceParseAddress destination of Right ni -> fmap (maybe (Left "Timeout.") Right) . flip (uncurry asend) (Just ni) Left e -> const $ return $ Left ("Bad destination: "++e) goTarget DHTAnnouncable{..} | Left (searchName,parseResult,asend) <- announceSendData = do either (hPutClient h) id $ do dta <- announceParseData $ unwords [dtastr,destination] r <- parseResult tokenstr return $ case selectedKey of Nothing -> hPutClient h "Missing secret user-key." Just k -> do asend k dta r hPutClient h "Sent." maybe (hPutClient h ("Unsupported method: "++method)) goTarget $ Map.lookup method dhtAnnouncables -- TODO: Online documentation. -- -- a - announce, like put/publish but automatically selects nodes to publish on -- and periodically refreshes them. -- -- The method name is preceded with a + to start or a - to stop a given -- recurring publication. -- -- BitTorrent: (peer) Every minute, announce you are participating -- in a torrent swarm. -- -- a +peer a -peer -- -- Tox: (toxid) Every 15 seconds, announce your tox identity to the -- DHT so friends can find you. -- -- a +toxid -- a -toxid -- -- a +friend -- a +dhtkey ("a", "") -> cmd0 $ do now <- getPOSIXTime rs <- atomically $ do as <- scheduleToList announcer forM (as) $ \(k,ptm,item) -> do let kstr = unpackAnnounceKey announcer k return [ if ptm==0 then "now" else show (ptm - now) , kstr ] hPutClient h $ showColumns rs ("a", s) | Just DHT{..} <- Map.lookup netname dhts , not (null s) -> cmd0 $ do let (op:method,xs) = break isSpace $ dropWhile isSpace s dtastr = dropWhile isSpace xs a = Map.lookup method dhtAnnouncables q = do DHTAnnouncable { announceSendData } <- a Map.lookup (either (\(search,_,_)->search) (const method) announceSendData) dhtQuery doitR :: Char -> Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO () doitR '+' = scheduleAnnounce doitR '-' = \a k _ _ -> cancel a k doitR _ = \_ _ _ _ -> hPutClientChunk h "Starting(+) or canceling(-)?" doitL :: Char -> Announcer -> AnnounceKey -> SearchMethod r -> r -> IO () doitL '+' = scheduleSearch doitL '-' = \a k _ _ -> cancel a k doitL _ = \_ _ _ _ -> hPutClientChunk h "Starting(+) or canceling(-)?" matchingResult :: ( Typeable stok , Typeable ptok , Typeable sni , Typeable pni ) => Search nid addr stok sni sr qk -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr)) -> Maybe (stok :~: ptok, sni :~: pni) matchingResult _ _ = liftA2 (,) eqT eqT matchingResult2 :: ( Typeable sr , Typeable pr ) => Search nid addr stok sni sr qk -> (PublicKey -> pdta -> pr -> IO ()) -> (pdta -> nid) -> Maybe (pr :~: sr) matchingResult2 _ _ _ = eqT reportit target = case op of '+' -> hPutClient h $ "Announcing at " ++ target ++ "." '-' -> hPutClient h $ "Canceling " ++ target ++ "." -- mameth is for typical kademlia announce. mameth = do DHTAnnouncable { announceSendData , announceParseData , announceInterval , announceTarget } <- a DHTQuery { qsearch } <- q asend <- either (const Nothing) Just announceSendData (Refl, Refl) <- matchingResult qsearch asend -- return $ hPutClient h "Type matches." dta <- either (const Nothing) Just $ announceParseData dtastr return $ do let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr) doitR op announcer akey (AnnounceMethod qsearch asend (\nid -> R.kclosest (searchSpace qsearch) (searchK qsearch) nid <$> readTVar (refreshBuckets dhtBuckets)) (announceTarget dta) announceInterval) dta reportit $ show $ announceTarget dta -- lmeth is for atypical announce messages such as -- Tox dht-key and friend-request messages. lmeth :: Maybe (IO ()) lmeth = do DHTAnnouncable { announceSendData , announceParseData , announceInterval , announceTarget } <- a DHTQuery { qsearch } <- q (_,_,asend) <- either Just (const Nothing) announceSendData Refl <- matchingResult2 qsearch asend announceTarget dta <- either (const Nothing) Just $ announceParseData dtastr pub <- selectedKey return $ do let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr) doitL op announcer akey (SearchMethod qsearch (asend pub) (\nid -> R.kclosest (searchSpace qsearch) (searchK qsearch) nid <$> readTVar (refreshBuckets dhtBuckets)) (announceTarget dta) announceInterval) dta reportit $ show $ announceTarget dta ptest = fromMaybe "E:NoMethod" $ fmap (\DHTAnnouncable { announceParseData , announceTarget } -> either ("E:"++) (show . announceTarget) $ announceParseData dtastr) a let aerror = unlines [ "announce error." , "method = " ++ method , "query = " ++ maybe "nil" (const "ok") q , "publish = " ++ maybe "nil" (const "ok") a -- , "chktok = " ++ maybe "nil" (const "ok") chktok -- chktok = nil -- , "chkni = " ++ maybe "nil" (const "ok") chkni , "ptest = " ++ ptest , "mameth = " ++ show (fmap (const ()) mameth) , "lmeth = " ++ show (fmap (const ()) lmeth) , "selectedKey = " ++ show selectedKey ] fromMaybe (hPutClient h aerror) $ mameth <|> lmeth ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts -> cmd0 $ do let (method,xs) = break isSpace s (nidstr,ys) = break isSpace $ dropWhile isSpace xs presentSearches = hPutClient h =<< showSearchState dhtBuckets =<< atomically (readTVar dhtSearches) goTarget qry nid = do kvar <- atomically $ newTVar Nothing -- Forking a thread, but it may ubruptly quit if the following -- STM action decides not to add a new search. This is so that -- I can store the ThreadId into new DHTSearch structure. tid <- fork $ join $ atomically (readTVar kvar >>= maybe retry return) ns <- case qry of DHTQuery{qbootNodes} -> qbootNodes nid join $ atomically $ do schs <- readTVar dhtSearches case Map.lookup (method,nid) schs of Nothing -> do forkSearch method nid qry dhtSearches ns tid kvar return $ presentSearches Just sch -> do writeTVar kvar (Just $ return ()) return $ reportSearchResults method h sch goQuery qry = either (hPutClient h . ("Bad search target: "++)) (goTarget qry) $ dhtParseId nidstr if null method then presentSearches else maybe (hPutClient h ("Unsupported method: "++method)) goQuery $ Map.lookup method dhtQuery ("x", s) | Just DHT{..} <- Map.lookup netname dhts -> cmd0 $ do let (method,xs) = break isSpace s (nidstr,ys) = break isSpace $ dropWhile isSpace xs go nid = join $ atomically $ do schs <- readTVar dhtSearches case Map.lookup (method,nid) schs of Nothing -> return $ hPutClient h "No match." Just DHTSearch{searchState} -> do modifyTVar' dhtSearches (Map.delete (method,nid)) searchCancel searchState return $ do -- killThread searchThread hPutClient h "Removed search." removeAll = join $ atomically $ do schs <- readTVar dhtSearches let (scrapped,remainder) = Map.partitionWithKey (\(m,_) _ -> m == method) schs writeTVar dhtSearches remainder return $ do ns <- forM (Map.toList scrapped) $ \((m,nid),DHTSearch{searchState}) -> do atomically $ searchCancel searchState -- killThread searchThread return $ show nid hPutClient h $ unlines $ map (mappend "Removed " . mappend method . mappend " ") ns case nidstr of "*" -> removeAll _ -> either (hPutClient h . ("Bad search target: "++)) go $ dhtParseId nidstr ("save", _) | Just dht <- Map.lookup netname dhts -> cmd0 $ do saveNodes netname dht hPutClient h $ "Saved " ++ nodesFileName netname ++ "." ("load", _) | Just dht <- Map.lookup netname dhts -> cmd0 $ do b <- pingNodes netname dht case b of Just num -> hPutClient h $ unwords [ "Pinging" , show num , "nodes from" , nodesFileName netname ++ "." ] Nothing -> hPutClient h $ "Failed: " ++ nodesFileName netname ++ "." ("swarms", s) -> cmd0 $ do let fltr = case s of ('-':'v':cs) | all isSpace (take 1 cs) -> const True _ -> (\(h,c,n) -> c/=0 ) ss <- atomically $ Peers.knownSwarms <$> readTVar (Mainline.contactInfo swarms) let r = map (\(h,c,n) -> (unwords [show h,show c], maybe "" show n)) $ filter fltr ss hPutClient h $ showReport r ("peers", s) -> cmd0 $ case readEither s of Right ih -> do ps <- atomically $ Peers.lookup ih <$> readTVar (Mainline.contactInfo swarms) hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps Left er -> hPutClient h er ("toxids", s) -> cmd0 $ do keydb <- atomically $ readTVar toxkeys now <- getPOSIXTime let entries = map mkentry $ PSQ.toList (Tox.keyByAge keydb) mkentry (k :-> tm) = [ show cnt, show k, show (now - tm) ] where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb) hPutClient h $ showColumns entries ("c", s) | Just (ConnectionManager mgr) <- connectionManager , "" <- strp s -> cmd0 $ join $ atomically $ do cs <- do ks <- connections mgr forM ks $ \k -> do stat <- Connection.status mgr k return (k,stat) let mkrow (k,st) = [ Connection.showKey mgr k , Connection.showStatus mgr (connStatus st) , showPolicy (connPolicy st) ] rs = map mkrow cs return $ do us <- mapM (mapM aggSessionKey . getToxContacts . fst) cs sessionss <- atomically $ mapM (mapM (getSessions sessionsVar)) us let ls = do (sessions,row) <- zip sessionss (lines $ showColumns rs) row : map (mappend " " . show . sTheirAddr) (concat sessions) hPutClient h $ unlines $ ("connections ("++show(length rs)++")") : ls ("help", s) | Just DHT{..} <- Map.lookup netname dhts -> cmd0 $ do let tolist :: a -> [a] tolist = (:[]) dhtkeys, announcables, ks, allcommands :: [[String]] dhtkeys = map tolist $ Map.keys dhts queries = map (tolist . ("s "++)) $ Map.keys dhtQuery xs = map (tolist . ("x "++)) $ Map.keys dhtQuery gs = map (tolist . ("g "++)) $ Map.keys dhtQuery announcables = map (tolist . ("p "++)) $ Map.keys dhtAnnouncables ks = [["k gen"],["k public"],["k secret"]] allcommands = sortBy (comparing (take 1)) $ concat [sessionCommands, dhtkeys, announcables, ks, queries, gs,xs] hPutClient h ("Available commands:\n" ++ showColumns allcommands) _ -> cmd0 $ hPutClient h "error." readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr] readExternals nodeAddr vars = do as <- atomically $ mapM (fmap (nodeAddr . selfNode) . readTVar) vars let unspecified (SockAddrInet _ 0) = True unspecified (SockAddrInet6 _ _ (0,0,0,0) _) = True unspecified _ = False -- TODO: Filter to only global addresses? return $ filter (not . unspecified) as data Options = Options { portbt :: String , porttox :: [String] , portxmpp :: String -- client-to-server , portxmppS :: String -- server-to-server , ip6bt :: Bool , ip6tox :: Bool , dhtkey :: Maybe SecretKey -- | Currently only relevant to XMPP server code. -- -- [ 0 ] Don't log XMPP stanzas. -- -- [ 1 ] Log non-ping stanzas. -- -- [ 2 ] Log all stanzas, even pings. , verbosity :: Int , verboseTags :: [DebugTag] , advertiseOnAvahi :: Bool , enableTCPDHT :: Bool } deriving (Eq,Show) sensibleDefaults :: Options sensibleDefaults = Options { portbt = "6881" , porttox = ["33445"] , portxmpp = "5222" , portxmppS = "5269" , ip6bt = True , ip6tox = True , dhtkey = Nothing , verbosity = 2 , verboseTags = [XUnexpected, XUnused] , advertiseOnAvahi = True , enableTCPDHT = True } data ShowHelp = ShowHelp deriving (Eq,Show) usage ShowHelp = let { cs = [([["--help"]] ,["Display this help"]) , ([["--dhtkey ",dhtkey] ,["--dht-key ",dhtkey]],["Use ",dhtkey," as the dht key"]) , ([["-4"]] ,["Use IPv4 only"]) , ([["--noavahi"]] ,["Disable avahi advertising on LAN"]) , ([["--notcp"]] ,["Disable TCP-relay server and client-based DHT"]) , ([["-v ",tags]] ,["Enable or disable specified DebugTags.\n DebugTags = ", listDebugTags]) ] ; dhtkey ="" ; tags = "[-]Tag1,[-]Tag2,... " ; -- TODO: word-wrap listDebugTags for terminal width listDebugTags = intercalate ", " $ map ((drop 1) . show) ([minBound .. maxBound]::[DebugTag]) ; } in do putStrLn "dhtd OPTIONS\n" forM cs $ \(how,what) -> do forM how $ putStrLn . (" "++) . concat putStr "\t" putStrLn . concat $ what exitFailure -- bt=,tox= -- -4 parseArgs :: [String] -> Options -> Either ShowHelp Options parseArgs [] opts = Right opts parseArgs ("--help":args) opts = Left ShowHelp parseArgs ("--noavahi":args) opts = parseArgs args opts { advertiseOnAvahi = False } parseArgs ("--notcp":args) opts = parseArgs args opts { enableTCPDHT = False } parseArgs ("--dhtkey":k:args) opts = parseArgs args opts { dhtkey = decodeSecret $ B.pack k } parseArgs ("--dht-key":k:args) opts = parseArgs args opts { dhtkey = decodeSecret $ B.pack k } parseArgs ("-4":args) opts = parseArgs args opts { ip6bt = False , ip6tox = False } parseArgs ("-v":tags:args) opts = parseArgs args opts { verboseTags = let gs = groupBy (const (/= ',')) tags ss = map (dropWhile (==',')) gs (ds0,as0) = partition (\s -> last (' ':s) == '-') ss as = mapMaybe parseDebugTag as0 ds = mapMaybe (parseDebugTag . init) ds0 in (verboseTags opts `union` as) \\ ds } parseArgs (arg:args) opts = parseArgs args opts { portbt = fromMaybe (portbt opts) $ Prelude.lookup "bt" ports , porttox = fromMaybe (porttox opts) $ lookupAll "tox" ports , portxmpp = fromMaybe (portxmpp opts) $ Prelude.lookup "xmpp" ports , portxmppS = fromMaybe (portxmppS opts) $ Prelude.lookup "xmpp.s2s" ports } where lookupAll seeking kvs = case filter (\(k,v) -> k == seeking) kvs of [] -> Nothing xs -> Just $ map snd xs ports = map ( (dropWhile (==',') *** dropWhile (=='=')) . break (=='=') ) $ groupBy (const (/= ',')) arg noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r) noArgPing f [] x = f x noArgPing _ _ _ = return Nothing -- | Create a Conduit Source by repeatedly calling an IO action. ioToSource :: IO (Maybe x) -> IO () -> ConduitT () x IO () ioToSource !action !onEOF = liftIO action >>= \case Nothing -> do dput XNetCrypto "ioToSource terminated." liftIO onEOF Just item -> do C.yield item ioToSource action onEOF {- newXmmpSink :: Tox.NetCryptoSession -> C.Sink (Flush Tox.CryptoMessage) IO () newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar }) = C.awaitForever $ \flush_cyptomessage -> do let sendit :: Tox.NetCryptoSession -> Flush Tox.CryptoMessage -> IO () sendit session (Chunk msg) = do outq <- atomically $ do mbOutq <- readTVar outGoingQVar case mbOutq of Tox.HaveHandshake outq -> return outq Tox.NeedHandshake -> retry extra <- Tox.nqToWireIO outq r <- atomically $ do rTry <- Tox.tryAppendQueueOutgoing extra outq msg case rTry of Tox.OGFull -> retry Tox.OGSuccess x -> return (Tox.OGSuccess x) Tox.OGEncodeFail -> return Tox.OGEncodeFail case r of Tox.OGSuccess x -> case Tox.ncSockAddr session of Tox.HaveDHTKey saddr -> Tox.sendSessionPacket (Tox.ncAllSessions session) saddr x _ -> return () Tox.OGEncodeFail -> dput XMisc ("FAILURE to Encode Outgoing: " ++ show msg) _ -> return () sendit session Flush = return () liftIO $ sendit session flush_cyptomessage -} onNewToxSession :: (IO () -> STM ()) -> XMPPServer -> TVar (Map.Map Uniq24 AggregateSession) -> InviteCache IO -> ContactInfo extra -> SockAddr -> Tox.Session -> IO () onNewToxSession runio sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do dput XMan "onNewToxSession" let them s = Tox.longTermKey $ runIdentity cookie -- remote tox key where Tox.Cookie _ cookie = Tox.handshakeCookie (sReceivedHandshake s) me s = toPublic $ sOurKey s uniqkey <- xor24 <$> hash24 (them netcrypto) <*> hash24 (me netcrypto) let onStatusChange :: (Tox.Session -> Tcp.ConnectionEvent XML.Event -> STM ()) -> AggregateSession -> Tox.Session -> Status Tox.ToxProgress -> STM () onStatusChange announce c s Established = onConnect announce c s onStatusChange announce _ s status = onEOF announce s status onEOF announce s status = do case status of Dormant -> -- Dormant AggregateSession is useless, so discard it. modifyTVar' ssvar $ Map.delete uniqkey _ -> return () runio $ dput XMan $ "EOF(" ++ take 16 (showKey256 $ them s) ++ "): " ++ show status HashMap.lookup (Tox.key2id $ me s) <$> readTVar accounts >>= mapM_ (setTerminated $ them s) announce s Tcp.EOF onConnect announce c s = do HashMap.lookup (Tox.key2id $ me s) <$> readTVar accounts >>= mapM_ (setEstablished $ them s) announce s $ Tcp.Connection (return False) xmppSrc xmppSnk where toxSrc :: ConduitT () (Int, CryptoMessage) IO () toxSnk :: ConduitT (Maybe Int, CryptoMessage) Void IO () xmppSrc :: ConduitT () XML.Event IO () xmppSnk :: ConduitT (Flush XML.Event) Void IO () toxSrc = ioToSource (atomically $ orElse (awaitAny c) $ aggregateStatus c >>= \case Dormant -> return Nothing _ -> retry) (return ()) toxSnk = C.mapM_ (uncurry $ dispatchMessage c) xmppSrc = toxSrc .| toxToXmpp (rememberInvite invc c) addrTox (me s) (xmppHostname $ them s) xmppSnk = flushPassThrough xmppToTox .| C.mapMaybe (\case Flush -> Nothing Chunk x -> Just (Nothing,x)) .| toxSnk let me_dot_tox = xmppHostname $ me netcrypto them_dot_tox = xmppHostname $ them netcrypto c <- join $ atomically $ do mc <- Map.lookup uniqkey <$> readTVar ssvar case mc of Nothing -> do announce <- do v <- newTVar $ Just them_dot_tox let ck = uniqueAsKey uniqkey condta s = ConnectionData { cdAddr = Left (Local addrTox) , cdType = XMPPServer.Tox , cdProfile = me_dot_tox , cdRemoteName = v , cdTheirNameForMe = Just me_dot_tox , cdTheirName = Just them_dot_tox } return $ \s e -> writeTChan (xmppEventChannel sv) ( (ck, condta s), e) c <- newAggregateSession $ onStatusChange announce modifyTVar' ssvar $ Map.insert uniqkey c return $ do dput XMan $ "New AggregateSession!" return c Just c -> return $ return c addSession c netcrypto return () getToxContacts :: Data d => d -> [Tox.ToxContact] getToxContacts a = case cast a of Just t -> [t] Nothing -> concat $ gmapQ getToxContacts a aggSessionKey :: Tox.ToxContact -> IO Uniq24 aggSessionKey (Tox.ToxContact me them) = xor24 <$> hash24 (Tox.id2key me) <*> hash24 (Tox.id2key them) selectManager :: Announcer -> Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text selectManager announcer mtman tcp profile = case stripSuffix ".tox" profile of Just k | Just tman <- mtman -> let -- The following error call is safe because the toxConnections field -- does not make use of the PresenceState passed to tman. tox = toxConnections $ tman $ error "PresenseState" tkey them0 = do me <- readMaybe (T.unpack k) them <- stripSuffix ".tox" them0 >>= readMaybe . T.unpack return (Tox.ToxContact me them) in Manager { resolvePeer = \themhost -> do r <- fromMaybe (return []) $ do themT <- stripSuffix ".tox" themhost them <- readMaybe $ T.unpack themT me <- readMaybe $ T.unpack k let contact = Tox.ToxContact me them Just $ resolvePeer tox contact dput XMan $ "resolvePeer(tox) " ++ show (T.take 8 $ k,T.take 8 $ themhost,r) return r , reverseAddress = \paddr -> do r <- fromMaybe (return []) $ do me <- readMaybe $ T.unpack k Just $ do reverseAddress tox paddr <&> mapMaybe (\case Tox.ToxContact a k | a == me -> Just $ T.pack (show k) `T.append` ".tox" _ -> Nothing) dput XMan $ "reverseAddress(tox)" ++ show (T.take 8 k,paddr) ++ ": " ++ show r return r , showKey = \key -> T.unpack key ++ ".tox" , setPolicy = \them -> case tkey them of Just tk -> \p -> setPolicy tox tk p Nothing -> \p -> return () , status = \them -> case tkey them of Just tk -> fmap ToxStatus <$> status tox tk Nothing -> return $ Connection Dormant RefusingToConnect , connections = let valid (Tox.ToxContact local them) = do guard $ T.pack (show local) == k return $ T.pack (show them ++ ".tox") in fmap (mapMaybe valid) $ do -- fmap (map (T.pack . show)) $ cs <- connections tox let ncs = length cs nms = length $ mapMaybe valid cs runAction announcer "Tox.connections" $ do dput XMan $ "Manager{Tox} (all,valid)=" ++ show (ncs,nms) return cs , stringToKey = \s -> Just $ T.pack (s ++ ".tox") , showProgress = \(ToxStatus stat) -> showProgress tox stat } _ -> Manager { resolvePeer = \themhost -> do dput XMan $ "resolvePeer(tcp) " ++ show (profile,themhost) resolvePeer tcp themhost , reverseAddress = \paddr -> do dput XMan $ "reverseAddress(tcp) " ++ show (profile,paddr) reverseAddress tcp paddr , showKey = showKey tcp , setPolicy = setPolicy tcp , status = \k -> fmap XMPPStatus <$> status tcp k , connections = do cs <- connections tcp runAction announcer "TCP.connections" $ do dput XMan $ "Manager{TCP} cons=" ++ show (length cs) return cs , stringToKey = stringToKey tcp , showProgress = \(XMPPStatus stat) -> showProgress tcp stat } initTox :: (IO () -> STM ()) -> Options -> TVar (Map.Map Uniq24 AggregateSession) -> TVar Tox.AnnouncedKeys -> Maybe XMPPServer -> InviteCache IO -> IO ( Maybe (Tox.Tox JabberClients) , IO () , Map.Map String DHT , IO [SockAddr] , [SockAddr]) initTox runio opts ssvar keysdb mbxmpp invc = case porttox opts of [""] -> return (Nothing,return (), Map.empty, return [],[]) toxport -> do dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts)) crypto <- Tox.newToxCrypto (dhtkey opts) tox <- Tox.newTox keysdb toxport (case mbxmpp of Nothing -> \_ _ _ -> return () Just xmpp -> onNewToxSession runio xmpp ssvar invc) crypto (enableTCPDHT opts) -- addrTox <- getBindAddress toxport (ip6tox opts) (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox (advertiseOnAvahi opts) (enableTCPDHT opts) toxSearches <- atomically $ newTVar Map.empty tcpSearches <- atomically $ newTVar Map.empty let toxDHT bkts wantip = let toxBkts = bkts (Tox.toxRouting tox) in DHT { dhtBuckets = toxBkts , dhtPing = Map.fromList [ ("ping", DHTPing { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Tox.pingUDP (Tox.toxDHT tox) , pingShowResult = show }) , ("cookie", DHTPing { pingQuery = \case [keystr] | Just mykey <- readMaybe keystr -> Tox.cookieRequest (Tox.toxCryptoKeys tox) (Tox.toxDHT tox) (Tox.id2key mykey) . (Multi.UDP ==>) _ -> const $ return Nothing , pingShowResult = show })] , dhtQuery = Map.fromList [ ("node", fix $ \q -> DHTQuery { qsearch = Tox.nodeSearch (Tox.toxDHT tox) (Tox.nodesOfInterest $ Tox.toxRouting tox) , qhandler = (\ni -> fmap Tox.unwrapNodes . Tox.getNodesH (Tox.toxRouting tox) (Multi.UDP ==> ni) . Tox.GetNodes) , qshowR = show -- NodeInfo , qshowTok = (const Nothing) , qbootNodes = genericBootNodes (refreshBuckets toxBkts) q }) , ("toxid", fix $ \q -> DHTQuery { qsearch = Tox.toxQSearch tox , qhandler = -- qhandler :: ni -> nid -> IO ([ni], [r], tok) (\ni nid -> Tox.unwrapAnnounceResponse Nothing <$> fmap (fromJust . Multi.udpNode) (clientAddress (Tox.toxDHT tox) Nothing) <*> Tox.announceH (Tox.toxRouting tox) (Tox.toxTokens tox) (Tox.toxAnnouncedKeys tox) (Tox.OnionDestination Tox.SearchingAlias ni Nothing) (Tox.AnnounceRequest zeros32 nid Tox.zeroID)) , qshowR = show -- Rendezvous , qshowTok = Just . show -- Nonce32 , qbootNodes = atomically . nearNodes tox -- genericBootNodes (refreshBuckets toxBkts) q }) ] , dhtParseId = readEither :: String -> Either String Tox.NodeId , dhtSearches = toxSearches , dhtFallbackNodes = return [] , dhtAnnouncables = Map.fromList -- To announce your own tox OrjBG... identity is online: -- -- > a +toxid OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu [ ("toxid", DHTAnnouncable { announceSendData = Right (toxAnnounceSendData tox) , announceParseAddress = readEither , announceParseToken = const $ readEither , announceParseData = fmap Tox.id2key . readEither , announceTarget = Tox.key2id -- toxid -- For peers we are announcing ourselves to, if we are not -- announced to them toxcore tries every 3 seconds to -- announce ourselves to them until they return that we -- have announced ourselves to, then toxcore sends an -- announce request packet every 15 seconds to see if we -- are still announced and re announce ourselves at the -- same time. The timeout of 15 seconds means a `ping_id` -- received in the last packet will not have had time to -- expire (20 second minimum timeout) before it is resent -- 15 seconds later. Toxcore sends every announce packet -- with the `ping_id` previously received from that peer -- with the same path (if possible). , announceInterval = toxAnnounceInterval }) -- dhtkey parameters: -- -- ni = NodeInfo -- r = Rendezvous -- tok = Nonce32 -- dta = PublicKey{-them-} -- -- Using k-selected identity, to share your dht -- key with remote tox user -- "KWoEx1XQHrluIoW.3nK6BFb6XCebKWr3nDDt3V7CcoJ" -- ... -- -- > a +dhtkey KWoEx1XQHrluIoW.3nK6BFb6XCebKWr3nDDt3V7CcoJ , ("dhtkey", DHTAnnouncable { announceSendData = Left ("toxid", readEither, \me them addr -> do -- let mthem = Just ( TCP.tcpClient -- $ tcpKademliaClient -- $ toxOnionRoutes tox -- , them ) dkey <- Tox.getContactInfo Nothing tox sendMessage (Tox.toxToRoute tox) (Tox.AnnouncedRendezvous them addr) (me,Tox.OnionDHTPublicKey dkey)) , announceParseAddress = \str -> do ni <- readEither str return ( ni :: Tox.NodeInfo ) , announceParseToken = \_ str -> do tok <- readEither str return ( tok :: Nonce32 ) , announceParseData = fmap Tox.id2key . readEither , announceTarget = Tox.key2id -- We send this packet every 30 seconds if there is more -- than one peer (in the 8) that says they our friend is -- announced on them. This packet can also be sent through -- the DHT module as a DHT request packet (see DHT) if we -- know the DHT public key of the friend and are looking -- for them in the DHT but have not connected to them yet. -- 30 second is a reasonable timeout to not flood the -- network with too many packets while making sure the -- other will eventually receive the packet. Since packets -- are sent through every peer that knows the friend, -- resending it right away without waiting has a high -- likelihood of failure as the chances of packet loss -- happening to all (up to to 8) packets sent is low. -- , announceInterval = 30 }) -- "friend" parameters -- -- ni = NodeInfo -- r = Rendezvous -- tok = Nonce32 -- dta = (NoSpamId{-them-},String) -- -- Using k-selected identity, to send a -- friend-request to the JID $TESTZ300@OrjBG...: -- -- > a +friend $TESTZ300@OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox Hey, add me! -- , ("friend", DHTAnnouncable { announceSendData = Left ("toxid", readEither, \me them0 addr -> do let (Tox.NoSpamId sum them,txt) = them0 Tox.NoSpam nospam _ = sum fr = Tox.FriendRequest nospam (T.encodeUtf8 $ T.pack txt) sendMessage (Tox.toxToRoute tox) (Tox.AnnouncedRendezvous them addr) (me,Tox.OnionFriendRequest fr)) , announceParseAddress = \str -> do ni <- readEither str return ( ni :: Tox.NodeInfo ) , announceParseToken = \_ str -> do tok <- readEither str return ( tok :: Nonce32 ) , announceParseData = \str -> do let (jidstr,txt) = break isSpace str jid <- readEither jidstr return (jid, drop 1 txt) , announceTarget = \(Tox.NoSpamId _ pub,_) -> Tox.key2id pub -- Friend requests are sent with exponentially increasing -- interval of 2 seconds, 4 seconds, 8 seconds, etc... in -- toxcore. This is so friend requests get resent but -- eventually get resent in intervals that are so big that -- they essentially expire. The sender has no way of -- knowing if a peer refuses a friend requests which is why -- friend requests need to expire in some way. Note that -- the interval is the minimum timeout, if toxcore cannot -- send that friend request it will try again until it -- manages to send it. One reason for not being able to -- send the friend request would be that the onion has not -- found the friend in the onion and so cannot send an -- onion data packet to them. -- -- TODO: Support exponential backoff behavior. For now, setting -- interval to 8 seconds. , announceInterval = 8 })] , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox) , dhtBootstrap = case wantip of Want_IP4 -> toxStrap4 Want_IP6 -> toxStrap6 , dhtShowHexId = Just $ Tox.showHexId } tcpprober = tcpProber $ Tox.toxOnionRoutes tox tcpclient = tcpKademliaClient $ Tox.toxOnionRoutes tox tcpRefresher = tcpBucketRefresher $ Tox.toxOnionRoutes tox tcpDHT = DHT { dhtBuckets = tcpRefresher , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox) , dhtPing = Map.singleton "ping" DHTPing { pingQuery = noArgPing $ TCP.tcpPing (TCP.tcpClient tcpclient) , pingShowResult = show } , dhtQuery = Map.singleton "node" $ fix $ \q -> DHTQuery { qsearch = TCP.nodeSearch tcpprober tcpclient , qhandler = \ni nid -> do ns <- R.kclosest (searchSpace $ TCP.nodeSearch tcpprober tcpclient) (searchK $ TCP.nodeSearch tcpprober tcpclient) nid <$> atomically (readTVar $ refreshBuckets tcpRefresher) return (ns,ns,Just ()) , qshowR = show -- TCP.NodeInfo , qshowTok = (const Nothing) , qbootNodes = genericBootNodes (refreshBuckets tcpRefresher) q } , dhtAnnouncables = Map.empty , dhtParseId = readEither :: String -> Either String Tox.NodeId , dhtSearches = tcpSearches , dhtFallbackNodes = return [] , dhtBootstrap = bootstrap tcpRefresher , dhtShowHexId = Just Tox.showHexId } dhts = Map.fromList $ ("tox4", toxDHT Tox.refresher4 Want_IP4) : (if ip6tox opts then ( ("tox6", toxDHT Tox.refresher6 Want_IP6) :) else id) (if enableTCPDHT opts then [ ("toxtcp", tcpDHT) ] else []) ips :: IO [SockAddr] ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox , Tox.routing6 $ Tox.toxRouting tox ] return (Just tox, quitTox, dhts, ips, [Tox.toxBindAddress tox]) initJabber :: Options -> TVar (Map.Map Uniq24 AggregateSession) -> Announcer -> Maybe (Tox.Tox JabberClients) -> MUC -> IO ( Maybe XMPPServer , Maybe ConnectionManager -- (Manager (Either Pending TCPStatus) (Either T.Text T.Text)) , Maybe (PresenceState Pending) , IO () -- quit chat thread ) initJabber opts ssvar announcer mbtox toxchat = case portxmpp opts of "" -> return (Nothing,Nothing,Nothing,return()) p -> do cport <- getBindAddress p True{-IPv6 supported-} -- TODO: Allow running without an XMPP server-to-server port. -- This should probably be default for toxmpp use. sport <- getBindAddress (portxmppS opts) True{-IPv6 supported-} -- XMPP initialization cw <- newConsoleWriter let lookupBkts :: String -> Map.Map String DHT -> Maybe (String,TVar (BucketList Tox.NodeInfo)) lookupBkts name m = case Map.lookup name m of Nothing -> Nothing Just DHT{dhtBuckets} -> cast (name, refreshBuckets dhtBuckets) sv <- xmppServer Tcp.noCleanUp (Just sport) tcp <- xmppConnections sv -- :: IO ( Manager TCPStatus T.Text ) let tman = toxman ssvar announcer <$> mbtox state <- newPresenceState cw tman sv (selectManager announcer tman tcp) chat <- atomically newMUC quitChatService <- forkLocalChat chat let chats = Map.fromList [ ("local", chat) , ("ngc", toxchat) ] xmpp_thread <- forkXmpp sv (presenceHooks state chats (verbosity opts) (Just cport) (Just sport)) let conns :: ConnectionManager -- Manager (Either Pending TCPStatus) (Either T.Text T.Text) conns = fromMaybe (ConnectionManager tcp) $ do sel <- fmap ($ error "PresenseState") tman let _ = sel :: ToxManager ClientAddress mantox = toxConnections sel :: Connection.Manager Tox.ToxProgress Tox.ToxContact Just $ ConnectionManager mantox -- addManagers (toxConnections sel) tcp return ( Just sv , Just conns , Just state , killThread xmpp_thread >> quitChatService) main :: IO () main = do args <- getArgs let eopts = parseArgs args sensibleDefaults either usage print eopts -- quits on left let Right opts = eopts swarms <- Mainline.newSwarmsDatabase -- Restore peer database before forking the listener thread. peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat") either (dput XMisc . ("bt-peers.dat: "++)) (atomically . writeTVar (Mainline.contactInfo swarms)) (peerdb >>= S.decodeLazy) announcer <- forkAnnouncer -- Default: quiet all tags (except XMisc). forM ([minBound .. maxBound]::[DebugTag]) setQuiet forM (verboseTags opts) setVerbose toxchat <- atomically newMUC (quitToxChat,invc) <- forkToxChat toxchat (quitBt,btdhts,btips,baddrs) <- case portbt opts of "" -> return (return (), Map.empty,return [],[]) p -> do msock <- Bind.udpTransport' (ip6bt opts) [p,"0"] let bail = do dput XMisc $ "Bittorrent DHT disabled. Unable to bind bittorrent dht port: " ++ p return (return (), Map.empty, return [], []) fromMaybe bail $ msock <&> \(udp,sock) -> do addr <- getSocketName sock (bt,btR,btBootstrap4, btBootstrap6,quitBtClient) <- Mainline.newClient swarms addr udp quitBt <- forkListener "bt" (dput XBitTorrent . mappend "bt-parse: ") (clientNet bt) mainlineSearches <- atomically $ newTVar Map.empty peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port. let mainlineDHT bkts wantip = DHT { dhtBuckets = bkts btR , dhtPing = Map.singleton "ping" $ DHTPing { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Mainline.ping bt , pingShowResult = show } , dhtQuery = Map.fromList [ ("node", fix $ \q -> DHTQuery { qsearch = (Mainline.nodeSearch bt) , qhandler = (\ni -> fmap Mainline.unwrapNodes . Mainline.findNodeH btR ni . flip Mainline.FindNode (Just Want_Both)) , qshowR = show , qshowTok = (const Nothing) , qbootNodes = genericBootNodes (refreshBuckets $ bkts btR) q }) -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni ) -- sr = InfoHash -- stok = Token -- sni = NodeInfo , ("peer", fix $ \q -> DHTQuery { qsearch = (Mainline.peerSearch bt) , qhandler = (\ni -> fmap Mainline.unwrapPeers . Mainline.getPeersH btR swarms ni . flip Mainline.GetPeers (Just Want_Both) . (read . show)) -- TODO: InfoHash -> NodeId , qshowR = (show . pPrint) , qshowTok = (Just . show) , qbootNodes = genericBootNodes (refreshBuckets $ bkts btR) q }) ] , dhtParseId = readEither :: String -> Either String Mainline.NodeId , dhtSearches = mainlineSearches , dhtFallbackNodes = Mainline.bootstrapNodes wantip , dhtAnnouncables = Map.fromList -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni ) -- dta = Announce -- pr = Announced -- ptok = Token -- pni = NodeInfo [ ("peer", DHTAnnouncable { announceSendData = Right $ \ih tok -> \case Just ni -> do port <- atomically $ readTVar peerPort let dta = Mainline.mkAnnounce port ih tok Mainline.announce bt dta ni Nothing -> return Nothing , announceParseAddress = readEither , announceParseData = readEither , announceParseToken = const $ readEither , announceInterval = 60 -- TODO: Is one minute good? , announceTarget = (read . show) -- TODO: InfoHash -> NodeId -- peer }) , ("port", DHTAnnouncable { announceParseData = readEither , announceParseToken = \_ _ -> return () , announceParseAddress = const $ Right () , announceSendData = Right $ \dta () -> \case Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber) return $ Just dta Just _ -> return Nothing , announceInterval = 0 -- TODO: The "port" setting should probably -- be a command rather than an announcement. , announceTarget = const $ Mainline.zeroID })] , dhtSecretKey = return Nothing , dhtBootstrap = case wantip of Want_IP4 -> btBootstrap4 Want_IP6 -> btBootstrap6 , dhtShowHexId = Nothing } dhts = Map.fromList $ ("bt4", mainlineDHT Mainline.refresher4 Want_IP4) : if ip6bt opts then [ ("bt6", mainlineDHT Mainline.refresher6 Want_IP6) ] else [] ips :: IO [SockAddr] ips = readExternals Mainline.nodeAddr [ Mainline.routing4 btR , Mainline.routing6 btR ] return (quitBt >> quitBtClient,dhts,ips, [addr]) keysdb <- Tox.newKeysDatabase ssvar <- atomically $ newTVar Map.empty :: IO ( TVar (Map.Map Uniq24 AggregateSession) ) ioChan <- atomically newTChan rec (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate) <- do (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox (writeTChan ioChan) opts ssvar keysdb msv invc (msv,mconns,mstate,quitChat) <- initJabber opts ssvar announcer mbtox toxchat return (mbtox,quitTox >> quitChat,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate) _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs let dhts = Map.union btdhts toxdhts (waitForSignal, checkQuit) <- do signalQuit <- atomically $ newTVar False let quitCommand = atomically $ writeTVar signalQuit True installHandler sigTERM (CatchOnce (do dput XMisc "sigTERM!" atomically $ writeTVar signalQuit True)) Nothing installHandler sigINT (CatchOnce (do dput XMisc "sigINT!" atomically $ writeTVar signalQuit True)) Nothing let defaultToxData = do rster <- Tox.newContactInfo crypto <- newCrypto (orouter,_,_) <- newOnionRouter crypto (dput XMisc) False -- (enableTCPDHT opts) return (rster, orouter) (rstr,orouter) <- fromMaybe defaultToxData $ do tox <- mbtox return $ return ( Tox.toxContactInfo tox, Tox.toxOnionRoutes tox ) let session = clientSession0 $ Session { netname = concat $ take 1 $ Map.keys dhts -- initial default DHT , selectedKey = Nothing , dhts = dhts -- all DHTs , signalQuit = quitCommand , swarms = swarms , toxkeys = keysdb , roster = rstr , announceToLan = fromMaybe (return ()) $ Tox.toxAnnounceToLan <$> mbtox , connectionManager = mconns , onionRouter = orouter , externalAddresses = liftM2 (++) btips toxips , announcer = announcer , mbTox = mbtox , sessionsVar = ssvar } srv <- forkStreamServer (withSession session) [SockAddrUnix "dht.sock"] return ( do readTVar signalQuit >>= check return $ quitListening srv , readTVar signalQuit >>= check ) forM_ (Map.toList dhts) $ \(netname, dht@DHT { dhtBuckets = bkts , dhtQuery = qrys , dhtPing = pings , dhtFallbackNodes = getBootstrapNodes , dhtBootstrap = bootstrap }) -> do btSaved <- loadNodes netname -- :: IO [Mainline.NodeInfo] putStrLn $ "Loaded "++show (length btSaved)++" nodes for "++netname++"." fallbackNodes <- getBootstrapNodes let isNodesSearch :: ni :~: r -> Search nid addr tok ni r qk -> Search nid addr tok ni ni qk isNodesSearch Refl sch = sch ping = maybe (const $ return False) (\DHTPing{pingQuery} -> fmap (maybe False (const True)) . pingQuery []) $ Map.lookup "ping" pings fork $ do myThreadId >>= flip labelThread ("bootstrap."++netname) bootstrap btSaved fallbackNodes return () forkLabeled "XMPP.stanzas" $ do let console = cwPresenceChan <$> (mstate >>= consoleWriter) fix $ \loop -> do what <- atomically $ orElse (do (client,stanza) <- maybe retry takeTMVar console return $ forM_ mstate $ \state -> do informClientPresence0 state Nothing client stanza loop) (checkQuit >> return (return ())) what forM msv $ \_ -> dput XMisc "Started XMPP server." -- Wait for DHT and XMPP threads to finish. -- Use ResourceT to clean-up XMPP server. fix $ \loop -> join $ atomically $ orElse waitForSignal $ do action <- readTChan ioChan return $ action >> loop forM_ mstate $ \PresenceState{server=xmpp} -> do quitXmpp xmpp stopAnnouncer announcer quitBt quitTox quitToxChat swarmsdb <- atomically $ readTVar (Mainline.contactInfo swarms) forM_ (Map.toList dhts) $ \(netname,dht) -> do saveNodes netname dht dput XMisc $ "Saved " ++ nodesFileName netname ++ "." L.writeFile "bt-peers.dat" $ S.encodeLazy swarmsdb dput XMisc $ "Saved bt-peers.dat" s <- threadReport False putStrLn s