{-# 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 ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} 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 Control.Monad.Trans.Control import Control.Monad.Trans.Resource (runResourceT) import Data.Bool import Data.Char import Data.Conduit as C import Data.Function 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 Data.Tuple import Data.Time.Clock import qualified Data.XML.Types as XML import GHC.Conc (threadStatus,ThreadStatus(..)) import GHC.Stats import Network.Socket import System.Environment import System.IO import System.Mem import System.Posix.Process import Text.PrettyPrint.HughesPJClass import Text.Printf import Text.Read #ifdef THREAD_DEBUG import Control.Concurrent.Lifted.Instrument #else import Control.Concurrent.Lifted import GHC.Conc (labelThread) #endif import qualified Data.HashMap.Strict as HashMap import qualified Data.Vector as V import qualified Data.Text as T import qualified Data.Text.Encoding as T import System.Posix.Signals import Announcer import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys) import Network.UPNP as UPNP import Network.Address hiding (NodeId, NodeInfo(..)) import Network.QueryResponse import Network.StreamServer import Network.Kademlia.Search import qualified Network.BitTorrent.MainlineDHT as Mainline import qualified Network.Tox as Tox import Network.Kademlia.Routing as R import Data.Aeson as J (ToJSON, FromJSON) import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as B import Control.Concurrent.Tasks import System.IO.Error import qualified Data.Serialize as S import Network.BitTorrent.DHT.ContactInfo as Peers import qualified Data.MinMaxPSQ as MM import Data.Wrapper.PSQ as PSQ (pattern (:->)) import qualified Data.Wrapper.PSQ as PSQ import Data.Ord import Data.Time.Clock.POSIX import qualified Network.Tox.DHT.Transport as Tox import qualified Network.Tox.DHT.Handlers as Tox import qualified Network.Tox.Onion.Transport as Tox import qualified Network.Tox.Onion.Handlers as Tox import qualified Network.Tox.Crypto.Transport as Tox (CryptoMessage(..),CryptoData(..), isOFFLINE, isKillPacket) import qualified Network.Tox.Crypto.Handlers as Tox import Data.Typeable import Network.Tox.ContactInfo as Tox import OnionRouter import PingMachine import Data.PacketQueue -- Presence imports. import ConsoleWriter import Presence import XMPPServer import Connection import ToxToXMPP import qualified Connection.Tcp as Tcp (ConnectionEvent(..)) showReport :: [(String,String)] -> String showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs showColumns :: [[String]] -> String showColumns rows = do let cols = transpose rows ws = map (maximum . map (succ . length)) cols fs <- rows _ <- take 1 fs -- Guard against empty rows so that 'last' is safe. " " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n" marshalForClient :: String -> String marshalForClient s = show (length s) ++ ":" ++ s 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 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 data DHTQuery nid ni = forall addr r tok. ( Ord addr , Typeable r , Typeable tok , Typeable ni ) => DHTQuery { qsearch :: Search nid addr tok ni r , qhandler :: ni -> nid -> IO ([ni], [r], Maybe tok) -- ^ Invoked on local node, when there is no query destination. , qshowR :: r -> String , qshowTok :: tok -> Maybe String } data DHTAnnouncable nid = forall dta tok ni r. ( Show r , Typeable dta -- information being announced , Typeable tok -- token , Typeable r -- search result , Typeable ni -- node ) => DHTAnnouncable { announceParseData :: String -> Either String dta , announceParseToken :: dta -> String -> Either String tok , announceParseAddress :: String -> Either String ni , announceSendData :: Either ( String {- search name -} , String -> Either String r , PublicKey {- me -} -> dta -> r -> IO ()) (dta -> tok -> Maybe ni -> IO (Maybe r)) , announceInterval :: POSIXTime , announceTarget :: dta -> nid } data DHTSearch nid ni = forall addr tok r. DHTSearch { searchThread :: ThreadId , searchState :: SearchState nid addr tok ni r , searchShowTok :: tok -> Maybe String , searchResults :: TVar (Set.Set String) } data DHTPing ni = forall r. DHTPing { pingQuery :: [String] -> ni -> IO (Maybe r) , pingShowResult :: r -> String } data DHT = forall nid ni. ( Show ni , Read ni , ToJSON ni , FromJSON ni , Ord ni , Hashable ni , Show nid , Ord nid , Hashable nid , Typeable ni , S.Serialize nid ) => DHT { dhtBuckets :: TVar (BucketList ni) , dhtSecretKey :: STM (Maybe SecretKey) , dhtPing :: Map.Map String (DHTPing ni) , dhtQuery :: Map.Map String (DHTQuery nid ni) , dhtAnnouncables :: Map.Map String (DHTAnnouncable nid) , dhtParseId :: String -> Either String nid , dhtSearches :: TVar (Map.Map (String,nid) (DHTSearch nid ni)) , dhtFallbackNodes :: IO [ni] , dhtBootstrap :: [ni] -> [ni] -> IO () } nodesFileName :: String -> String nodesFileName netname = netname ++ "-nodes.json" saveNodes :: String -> DHT -> IO () saveNodes netname DHT{dhtBuckets} = do bkts <- atomically $ readTVar dhtBuckets let ns = map fst $ concat $ R.toList bkts bs = J.encode ns fname = nodesFileName netname L.writeFile fname bs loadNodes :: FromJSON ni => String -> IO [ni] loadNodes netname = do let fname = nodesFileName netname attempt <- tryIOError $ do J.decode <$> L.readFile fname >>= maybe (ioError $ userError "Nothing") return either (const $ fallbackLoad fname) return attempt fallbackLoad :: FromJSON t => FilePath -> IO [t] fallbackLoad fname = do attempt <- tryIOError $ do J.decode <$> L.readFile fname >>= maybe (ioError $ userError "Nothing") return let go r = do let m = HashMap.lookup "nodes" (r :: J.Object) ns0 = case m of Just (J.Array v) -> V.toList v Nothing -> [] ns1 = zip (map J.fromJSON ns0) ns0 issuc (J.Error _,_) = False issuc _ = True (ss,fs) = partition issuc ns1 ns = map (\(J.Success n,_) -> n) ss mapM_ print (map snd fs) >> return ns either (const $ return []) go attempt {- pingNodes :: String -> DHT -> IO Bool pingNodes netname DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "ping" dhtPing = do let fname = nodesFileName netname attempt <- tryIOError $ do J.decode <$> L.readFile fname >>= maybe (ioError $ userError "Nothing") return -} 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 (is'fin, cnt) <- atomically $ (,) <$> searchIsFinished searchState <*> (Set.size <$> readTVar searchResults) tstat <- threadStatus searchThread let stat = case tstat of _ | is'fin -> ' ' ThreadFinished -> '-' ThreadDied -> '-' _ -> '*' return (stat,show cnt,meth,show nid) let cnt'width = maximum $ map (\(_,cnt,_,_)->length cnt) tups mth'width = maximum $ map (\(_,_,mth,_)->length mth) tups return $ do -- List monad. (stat,cnt,meth,nid) <- tups printf " %c %-*s %-*s %s\n" stat cnt'width cnt mth'width meth nid forkSearch :: ( Ord nid , Hashable nid , Ord ni , Hashable ni , Show nid ) => String -> nid -> DHTQuery nid ni -> TVar (Map.Map (String,nid) (DHTSearch nid ni)) -> TVar (BucketList ni) -> ThreadId -> TVar (Maybe (IO ())) -> STM () forkSearch method nid DHTQuery{qsearch,qshowTok,qshowR} dhtSearches dhtBuckets tid kvar = do ns <- R.kclosest (searchSpace qsearch) searchK nid <$> readTVar dhtBuckets st <- newSearch qsearch nid ns results <- newTVar Set.empty let storeResult r = modifyTVar' results (Set.insert (qshowR r)) >> return True new = DHTSearch { searchThread = tid , searchState = st , searchShowTok = qshowTok , searchResults = results } modifyTVar' dhtSearches $ Map.insert (method,nid) new -- Finally, we write the search loop action into a tvar that will be executed in a new -- thread. writeTVar kvar $ Just $ searchLoop qsearch nid storeResult st reportSearchResults :: (Show t, Ord t1, Ord t, Hashable t) => String -> 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. 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 , cryptosessions :: Tox.NetCryptoSessions , toxkeys :: TVar Tox.AnnouncedKeys , userkeys :: TVar [(SecretKey,PublicKey)] , roster :: Tox.ContactInfo , connectionManager :: Maybe ConnectionManager , onionRouter :: OnionRouter , announcer :: Announcer , signalQuit :: IO () } 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 readKeys :: TVar [(SecretKey, PublicKey)] -> TVar (HashMap.HashMap Tox.NodeId Account) -> STM [(SecretKey, PublicKey)] readKeys userkeys roster = do uks <- readTVar userkeys as <- readTVar roster return $ uks ++ map ((userSecret *** Tox.id2key) . swap) (HashMap.toList as) 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 strp = B.unpack . fst . until snd dropEnd . (,False) . B.dropWhile isSpace . B.pack where dropEnd (x,_) = case B.unsnoc x of Just (str,c) | isSpace c -> (str,False) _ -> (x,True) let mkrow :: (SecretKey, PublicKey) -> (String,String) mkrow (a,b) | Just x <- encodeSecret a= (B.unpack x, show (Tox.key2id b)) mkrow _ = error (concat ["Assertion fail in 'mkrow' function at ", __FILE__, ":", show __LINE__]) sessionCommands :: [[String]] sessionCommands = [ ["ping"] -- pinglike , ["cookie"] -- pinglike , ["stop"] , ["throw"] , ["quit"] , ["pid"] , ["external-ip"] , ["threads"] , ["mem"] , ["nid"] , ["ls"] , ["k"] , ["roster"] , ["onion"] , ["g"] , ["p"] , ["a"] , ["s"] , ["x"] , ["save"] , ["load"] , ["swarms"] , ["peers"] , ["toxids"] , ["c"] , ["help"] ] case (map toLower c,args) of (n, _) | n `elem` Map.keys dhts -> switchNetwork n -- "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", _) -> cmd0 $ do ts <- threadsInformation tm <- getCurrentTime r <- forM ts $ \(tid,PerThread{..}) -> do stat <- threadStatus tid let showStat (ThreadBlocked reason) = show reason showStat stat = show stat return [show lbl,show (diffUTCTime tm startTime),showStat stat] hPutClient h $ showColumns r #endif ("mem", s) -> cmd0 $ do case s of "gc" -> do hPutClient h "Performing garbage collection..." performMajorGC "" -> do is_enabled <- getGCStatsEnabled if is_enabled then do GCStats{..} <- getGCStats let r = [ ("bytesAllocated", show bytesAllocated) , ("numGcs", show numGcs) , ("maxBytesUsed", show maxBytesUsed) , ("numByteUsageSamples", show numByteUsageSamples) , ("cumulativeBytesUsed", show cumulativeBytesUsed) , ("bytesCopied", show bytesCopied) , ("currentBytesUsed", show currentBytesUsed) , ("currentBytesSlop", show currentBytesSlop) , ("maxBytesSlop", show maxBytesSlop) , ("peakMegabytesAllocated", show peakMegabytesAllocated) , ("mutatorCpuSeconds", show mutatorCpuSeconds) , ("mutatorWallSeconds", show mutatorWallSeconds) , ("gcCpuSeconds", show gcCpuSeconds) , ("gcWallSeconds", show gcWallSeconds) , ("cpuSeconds", show cpuSeconds) , ("wallSeconds", show wallSeconds) , ("parTotBytesCopied", show parTotBytesCopied) , ("parMaxBytesCopied", show parMaxBytesCopied) ] hPutClient h $ showReport r else hPutClient h "Run with +RTS -T to obtain live memory-usage information." _ -> hPutClient h "error." ("nid", s) | Just DHT{dhtParseId} <- 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 -> "Error: " ++ e Right nid -> show nid ++ " nospam:" ++ drop 64 s Right nid -> show nid ("ls", _) | Just DHT{dhtBuckets} <- Map.lookup netname dhts -> cmd0 $ do bkts <- atomically $ readTVar dhtBuckets let r = reportTable bkts hPutClient h $ showReport $ r ++ [ ("buckets", show $ R.shape bkts) , ("node-id", show $ thisNode bkts) , ("network", netname) ] -- 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 $ readKeys userkeys (accounts 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 <- readTVar userkeys modifyTVar userkeys ((secret,pubkey):) Tox.addContactInfo roster secret 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 $ readKeys userkeys (accounts roster) skey <- maybe (return Nothing) (atomically . dhtSecretKey) $ Map.lookup netname dhts hPutClient h . showReport $ map mkrow ks ++ case skey >>= encodeSecret of Just x -> [("",""),("dht-key:",B.unpack x)] Nothing -> [] | ("sel",_:expr) <- break isSpace s -> do ks <- atomically $ map (show . Tox.key2id . snd) <$> readKeys userkeys (accounts 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 <- readTVar userkeys modifyTVar userkeys (pairs ++) forM pairs $ \(sk,_) -> Tox.addContactInfo roster sk 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 modifyTVar userkeys (filter (`notElem` pairs) ) forM pairs $ \(_,pk) -> Tox.delContactInfo roster pk readTVar userkeys hPutClient h . showReport $ map mkrow ks switchKey $ do k <- selectedKey guard $ k `notElem` map snd pairs Just k ("roster", s) -> cmd0 $ join $ atomically $ do dns <- dnsPresentation roster fs <- HashMap.toList <$> friendRequests roster let showFriend (remotekey,fr) = (" " ++ show remotekey, T.unpack $ T.decodeUtf8 $ Tox.friendRequestText fr) showAccount (me,cs) = [(show me,"")] ++ map showFriend cs frs = fs >>= showAccount return $ do hPutClientChunk h $ unlines [ dns, "", "Friend Requests" ] hPutClient h $ showReport frs ("onion", s) -> cmd0 $ join $ atomically $ do rm <- readTVar $ routeMap onionRouter ts <- readTVar $ trampolineNodes onionRouter rs <- mapM readTVar (pendingRoutes onionRouter) let showRecord :: Int -> Bool -> [String] showRecord n True = [show n, "pending", ""] showRecord n False | Just RouteRecord{responseCount,timeoutCount} <- IntMap.lookup n rm = [show n, show responseCount, show timeoutCount] | otherwise = [show n, "error!",""] r = map (uncurry showRecord) $ IntMap.toAscList rs return $ do hPutClientChunk h $ "trampolines: " ++ show (IntMap.size ts) ++ "\n" hPutClient h $ showColumns $ ["","responses","timeouts"]:r ("g", s) | Just DHT{..} <- Map.lookup netname dhts -> cmd0 $ do -- arguments: method -- nid -- (optional dest-ni) self <- atomically $ thisNode <$> readTVar dhtBuckets let (method,xs) = break isSpace $ dropWhile isSpace s (nidstr,ys) = break isSpace $ dropWhile isSpace xs destination = dropWhile isSpace ys goQuery qry = either (hPutClient h . ("Bad search target: "++)) (goTarget qry) $ dhtParseId nidstr goTarget DHTQuery{..} nid = go nid >>= reportResult method qshowR qshowTok show h where go | null destination = fmap Right . qhandler self | otherwise = case readEither destination of Right ni -> fmap (maybe (Left "Timeout.") Right) . flip (searchQuery qsearch) ni Left e -> const $ return $ Left ("Bad destination: "++e) maybe (hPutClient h ("Unsupported method: "++method)) goQuery $ Map.lookup method dhtQuery -- 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 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 -> asend k dta r 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 <- readTVar (scheduled $ announcer) forM (PSQ.toList as) $ \(k,ptm,item) -> do kstr <- unpackAnnounceKey announcer k return [ show (ptm - now) , show (itemStatusNum item) , 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 doit :: Char -> Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO () doit '+' = schedule doit '-' = cancel doit _ = \_ _ _ _ -> hPutClientChunk h "Starting(+) or canceling(-)?" matchingResult :: ( Typeable stok , Typeable ptok , Typeable sni , Typeable pni ) => Search nid addr stok sni sr -> (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 -> (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 akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr) doit op announcer akey (AnnounceMethod qsearch (Right asend) 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 akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr) doit op announcer akey (AnnounceMethod qsearch (Left $ asend pub) 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 =<< showSearches =<< atomically (readTVar dhtSearches) goTarget qry nid = do kvar <- atomically $ newTVar Nothing -- Forking a thread, but it may ubruptly quit if the following -- STM action decides not to add a new search. This is so that -- I can store the ThreadId into new DHTSearch structure. tid <- fork $ join $ atomically (readTVar kvar >>= maybe retry return) join $ atomically $ do schs <- readTVar dhtSearches case Map.lookup (method,nid) schs of Nothing -> do forkSearch method nid qry dhtSearches dhtBuckets tid kvar return $ presentSearches Just sch -> do writeTVar kvar (Just $ return ()) return $ reportSearchResults method h sch goQuery qry = either (hPutClient h . ("Bad search target: "++)) (goTarget qry) $ dhtParseId nidstr if null method then presentSearches else maybe (hPutClient h ("Unsupported method: "++method)) goQuery $ Map.lookup method dhtQuery ("x", s) | Just DHT{..} <- Map.lookup netname dhts -> cmd0 $ do let (method,xs) = break isSpace s (nidstr,ys) = break isSpace $ dropWhile isSpace xs go nid = join $ atomically $ do schs <- readTVar dhtSearches case Map.lookup (method,nid) schs of Nothing -> return $ hPutClient h "No match." Just DHTSearch{searchThread} -> do modifyTVar' dhtSearches (Map.delete (method,nid)) return $ do killThread searchThread hPutClient h "Removed search." either (hPutClient h . ("Bad search target: "++)) go $ dhtParseId nidstr ("save", _) | Just dht <- Map.lookup netname dhts -> cmd0 $ do saveNodes netname dht hPutClient h $ "Saved " ++ nodesFileName netname ++ "." ("load", _) | Just dht <- Map.lookup netname dhts -> cmd0 $ do b <- pingNodes netname dht 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 :-> Down 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 cmap <- connections mgr cs <- Map.toList <$> mapM connStatus cmap let mkrow = Connection.showKey mgr *** Connection.showStatus mgr rs = map mkrow cs return $ do hPutClient h $ showReport rs ("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 } deriving (Eq,Show) sensibleDefaults :: Options sensibleDefaults = Options { portbt = "6881" , porttox = "33445" , portxmpp = "5222" , portxmppS = "5269" , ip6bt = True , ip6tox = True , dhtkey = Nothing , verbosity = 2 } -- bt=,tox= -- -4 parseArgs :: [String] -> Options -> Options parseArgs [] opts = opts 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 (arg:args) opts = parseArgs args opts { portbt = fromMaybe (portbt opts) $ Prelude.lookup "bt" ports , porttox = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports , portxmpp = fromMaybe (portxmpp opts) $ Prelude.lookup "xmpp" ports , portxmppS = fromMaybe (portxmppS opts) $ Prelude.lookup "xmpp.s2s" ports } where ports = map ( (dropWhile (==',') *** dropWhile (=='=')) . break (=='=') ) $ groupBy (const (/= ',')) arg noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r) noArgPing f [] x = f x noArgPing _ _ _ = return Nothing -- | Create a Conduit Source by repeatedly calling an IO action. ioToSource :: IO (Maybe x) -> IO () -> C.Source IO x ioToSource !action !onEOF = liftIO action >>= \case Nothing -> 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, ncPacketQueue }) = C.awaitForever $ \flush_cyptomessage -> do let sendit :: Tox.NetCryptoSession -> Flush Tox.CryptoMessage -> IO () sendit session (Chunk msg) = do extra <- readyOutGoing ncOutgoingQueue r <- atomically $ do rTry <- tryAppendQueueOutgoing extra ncOutgoingQueue msg case rTry of OGFull -> retry OGSuccess -> return OGSuccess OGEncodeFail -> return OGEncodeFail when (r == OGEncodeFail) $ hPutStrLn stderr ("FAILURE to Encode Outgoing: " ++ show msg) sendit session Flush = return () liftIO $ sendit session flush_cyptomessage toxAnnounceSendData :: Tox.Tox -> PublicKey -> Nonce32 -> Maybe Tox.NodeInfo -> IO (Maybe (Tox.Rendezvous, Tox.AnnounceResponse)) toxAnnounceSendData tox pubkey token = \case Just ni -> Tox.putRendezvous (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox) (pubkey :: PublicKey) (token :: Nonce32) ni Nothing -> return Nothing toxQSearch :: Tox.Tox -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox) toxAnnounceInterval :: POSIXTime toxAnnounceInterval = 15 -- | -- -- These hooks will be invoked in order to connect to *.tox hosts in a user's -- XMPP roster. toxman :: Announcer -> [(String,TVar (BucketList Tox.NodeInfo))] -> Tox.Tox -> ToxManager ConnectionKey toxman announcer toxbkts tox = ToxManager { activateAccount = \k pubname seckey -> do hPutStrLn stderr $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey) let ContactInfo{ accounts } = Tox.toxContactInfo tox pub = toPublic seckey pubid = Tox.key2id pub newlyActive <- atomically $ do macnt <- HashMap.lookup pubid <$> readTVar accounts acnt <- maybe (newAccount seckey) return macnt rs <- readTVar $ clientRefs acnt writeTVar (clientRefs acnt) $! Set.insert k rs modifyTVar accounts (HashMap.insert pubid acnt) if not (Set.null rs) then return [] else do forM toxbkts $ \(nm,bkts) -> do akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid) return (akey,bkts) forM_ newlyActive $ \(akey,bkts) -> do -- Schedule recurring announce. -- schedule announcer akey (AnnounceMethod (toxQSearch tox) (Right $ toxAnnounceSendData tox) bkts pubid toxAnnounceInterval) pub -- -- Schedule recurring search for all non-connected contacts. return () , deactivateAccount = \k pubname -> do bStopped <- fmap (fromMaybe False) $ atomically $ do let ContactInfo{ accounts } = Tox.toxContactInfo tox mpubid = readMaybe $ T.unpack $ T.take 43 pubname forM mpubid $ \pubid -> do refs <- do macnt <- HashMap.lookup pubid <$> readTVar accounts rs <- fromMaybe Set.empty <$> mapM (readTVar . clientRefs) macnt forM_ macnt $ \acnt -> do modifyTVar' (clientRefs acnt) $ Set.delete k return rs if (not $ Set.null $ refs Set.\\ Set.singleton k) then do -- Stop recurring announce. -- If this is the last reference to a non-connected contact: -- Stop the recurring search for that contact return True else return False when bStopped $ hPutStrLn stderr $ "toxman DECTIVATE (todo) " ++ show pubname , setToxConnectionPolicy = \me them p -> do hPutStrLn stderr $ "toxman ConnectionPolicy " ++ show (me,them,p) case p of TryingToConnect -> do let db@ContactInfo{ accounts } = Tox.toxContactInfo tox sequence_ $ do meid <- readMaybe $ T.unpack $ T.take 43 me themid <- readMaybe $ T.unpack $ T.take 43 them Just $ atomically $ do accs <- readTVar accounts case HashMap.lookup meid accs of Nothing -> return () -- Unknown account. Just acc -> modifyTVar' (contacts acc) $ HashMap.alter (mergeContact nullContact { contactPolicy = Just TryingToConnect }) themid -- If unscheduled and unconnected, schedule recurring search for this contact. _ -> return () -- Remove contact. } #ifdef XMPP -- | Called upon a new Tox friend-connection session with a remote peer in -- order to set up translating conduits that simulate a remote XMPP server. announceToxJabberPeer :: TChan ((ConnectionKey,SockAddr), Tcp.ConnectionEvent XML.Event) -> SockAddr -- ^ Local bind address for incoming Tox packets. -> SockAddr -- ^ Remote address for this connection. -> STM Bool -> C.Source IO Tox.CryptoMessage -> C.Sink (Flush Tox.CryptoMessage) IO () -> IO (Maybe (Tox.NetCryptoSession -> Tox.NetCryptoSession)) announceToxJabberPeer echan laddr saddr pingflag tsrc tsnk = do atomically $ writeTChan echan ( (PeerKey saddr, laddr ) , Tcp.Connection pingflag xsrc xsnk ) return Nothing where xsrc = tsrc =$= toxToXmpp xsnk = flushPassThrough xmppToTox =$= tsnk #endif data PerSession = PerSession { perSessionMsgs :: PacketQueue (Bool{-Handled?-},Tox.CryptoMessage) , perSessionPublicKey :: PublicKey , perSessionAddr :: SockAddr } main :: IO () main = runResourceT $ liftBaseWith $ \resT -> do args <- getArgs let opts = parseArgs args sensibleDefaults print opts swarms <- Mainline.newSwarmsDatabase -- Restore peer database before forking the listener thread. peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat") either (hPutStrLn stderr . ("bt-peers.dat: "++)) (atomically . writeTVar (Mainline.contactInfo swarms)) (peerdb >>= S.decodeLazy) announcer <- forkAnnouncer (quitBt,btdhts,btips,baddrs) <- case portbt opts of "" -> return (return (), Map.empty,return [],[]) p -> do addr <- getBindAddress p (ip6bt opts) (bt,btR,btBootstrap4, btBootstrap6) <- Mainline.newClient swarms addr quitBt <- forkListener "bt" (clientNet bt) mainlineSearches <- atomically $ newTVar Map.empty peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port. let mainlineDHT bkts wantip = DHT { dhtBuckets = bkts btR , dhtPing = Map.singleton "ping" $ DHTPing { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Mainline.ping bt , pingShowResult = show } , dhtQuery = Map.fromList [ ("node", DHTQuery { qsearch = (Mainline.nodeSearch bt) , qhandler = (\ni -> fmap Mainline.unwrapNodes . Mainline.findNodeH btR ni . flip Mainline.FindNode (Just Want_Both)) , qshowR = show , qshowTok = (const Nothing) }) -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni ) -- sr = InfoHash -- stok = Token -- sni = NodeInfo , ("peer", DHTQuery { qsearch = (Mainline.peerSearch bt) , qhandler = (\ni -> fmap Mainline.unwrapPeers . Mainline.getPeersH btR swarms ni . flip Mainline.GetPeers (Just Want_Both) . (read . show)) -- TODO: InfoHash -> NodeId , qshowR = (show . pPrint) , qshowTok = (Just . show) }) ] , 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 } dhts = Map.fromList $ ("bt4", mainlineDHT Mainline.routing4 Want_IP4) : if ip6bt opts then [ ("bt6", mainlineDHT Mainline.routing6 Want_IP6) ] else [] ips :: IO [SockAddr] ips = readExternals Mainline.nodeAddr [ Mainline.routing4 btR , Mainline.routing6 btR ] return (quitBt,dhts,ips, [addr]) keysdb <- Tox.newKeysDatabase crypto <- Tox.newCrypto netCryptoSessionsState <- Tox.newSessionsState crypto Tox.defaultUnRecHook Tox.defaultCryptoDataHooks sessions <- atomically (newTVar []) :: IO (TVar [PerSession]) (mbtox,quitTox,toxdhts,toxips,taddrs) <- case porttox opts of "" -> return (Nothing,return (), Map.empty, return [],[]) toxport -> do addrTox <- getBindAddress toxport (ip6tox opts) hPutStrLn stderr $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts)) tox <- Tox.newTox keysdb addrTox (Just netCryptoSessionsState) (dhtkey opts) (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox toxSearches <- atomically $ newTVar Map.empty let toxDHT bkts wantip = DHT { dhtBuckets = bkts (Tox.toxRouting tox) , dhtPing = Map.fromList [ ("ping", DHTPing { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Tox.ping (Tox.toxDHT tox) , pingShowResult = show }) , ("cookie", DHTPing { pingQuery = \case [keystr] | Just mykey <- readMaybe keystr -> Tox.cookieRequest (Tox.toxCryptoKeys tox) (Tox.toxDHT tox) (Tox.id2key mykey) _ -> const $ return Nothing , pingShowResult = show })] , dhtQuery = Map.fromList [ ("node", DHTQuery { qsearch = (Tox.nodeSearch $ Tox.toxDHT tox) , qhandler = (\ni -> fmap Tox.unwrapNodes . Tox.getNodesH (Tox.toxRouting tox) ni . Tox.GetNodes) , qshowR = show -- NodeInfo , qshowTok = (const Nothing) }) , ("toxid", DHTQuery { qsearch = toxQSearch tox , qhandler = -- qhandler :: ni -> nid -> IO ([ni], [r], tok) (\ni nid -> Tox.unwrapAnnounceResponse Nothing <$> clientAddress (Tox.toxDHT tox) Nothing <*> Tox.announceH (Tox.toxRouting tox) (Tox.toxTokens tox) (Tox.toxAnnouncedKeys tox) (Tox.OnionDestination Tox.SearchingAlias ni Nothing) (Tox.AnnounceRequest zeros32 nid Tox.zeroID)) , qshowR = show -- Rendezvous , qshowTok = Just . show -- Nonce32 }) ] , dhtParseId = readEither :: String -> Either String Tox.NodeId , dhtSearches = toxSearches , dhtFallbackNodes = return [] , dhtAnnouncables = Map.fromList [ ("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-} , ("dhtkey", DHTAnnouncable { announceSendData = Left ("toxid", readEither, \me them addr -> do dkey <- Tox.getContactInfo 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) , ("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 } dhts = Map.fromList $ ("tox4", toxDHT Tox.routing4 Want_IP4) : if ip6tox opts then [ ("tox6", toxDHT Tox.routing6 Want_IP6) ] else [] ips :: IO [SockAddr] ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox , Tox.routing6 $ Tox.toxRouting tox ] return (Just tox, quitTox, dhts, ips, [addrTox]) _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs (msv,mconns,mstate) <- case portxmpp opts of "" -> return (Nothing,Nothing,Nothing) 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 serverVar <- atomically $ newEmptyTMVar 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, dhtBuckets) let toxbkts = catMaybes [ lookupBkts "tox4" toxdhts , lookupBkts "tox6" toxdhts ] state <- newPresenceState cw (toxman announcer toxbkts <$> mbtox) serverVar sv <- resT $ xmppServer (presenceHooks state (verbosity opts) (Just cport) (Just sport)) -- We now have a server object but it's not ready to use until -- we put it into the 'server' field of our /state/ record. conns <- xmppConnections sv atomically $ do putTMVar serverVar (sv,conns) -- Okay, now it's ready. :) -- FIXME: This is error prone. return (Just sv, Just conns, Just state) forM_ (take 1 taddrs) $ \addrTox -> do atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do tmchan <- atomically newTMChan let Just pingMachine = Tox.ncPingMachine netcrypto pingflag = readTVar (pingFlag pingMachine) receiveCrypto = atomically $ readTMChan tmchan #ifdef XMPP onEOF = return () -- TODO: Update toxContactInfo, not connected. xmppSrc = ioToSource receiveCrypto onEOF xmppSink = newXmmpSink netcrypto forM_ msv $ \sv -> do announceToxJabberPeer (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink -- TODO: Update toxContactInfo, connected. #endif let handleIncoming typ session cm | any ($ typ) [Tox.isKillPacket, Tox.isOFFLINE] = atomically $ do closeTMChan tmchan Tox.forgetCrypto crypto netCryptoSessionsState netcrypto return Nothing handleIncoming mTyp session cm = do atomically $ writeTMChan tmchan cm -- (Tox.bufferData cd) return Nothing atomically $ writeTVar (Tox.ncUnrecognizedHook netcrypto) handleIncoming return Nothing let dhts = Map.union btdhts toxdhts (waitForSignal, checkQuit) <- do signalQuit <- atomically $ newTVar False let quitCommand = atomically $ writeTVar signalQuit True installHandler sigTERM (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing installHandler sigINT (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing let defaultToxData = do toxids <- atomically $ newTVar [] rster <- Tox.newContactInfo orouter <- newOnionRouter (hPutStrLn stderr) return (toxids, rster, orouter) (toxids,rstr,orouter) <- fromMaybe defaultToxData $ do tox <- mbtox return $ return ( userKeys (Tox.toxCryptoKeys tox), 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 , cryptosessions = netCryptoSessionsState , toxkeys = keysdb , userkeys = toxids , roster = rstr , connectionManager = ConnectionManager <$> mconns , onionRouter = orouter , externalAddresses = liftM2 (++) btips toxips , announcer = announcer } srv <- streamServer (withSession session) (SockAddrUnix "dht.sock") return ( do atomically $ readTVar signalQuit >>= check 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 -> Search nid addr tok ni ni isNodesSearch Refl sch = sch ping = maybe (const $ return False) (\DHTPing{pingQuery} -> fmap (maybe False (const True)) . pingQuery []) $ Map.lookup "ping" pings fork $ do myThreadId >>= flip labelThread ("bootstrap."++netname) bootstrap btSaved fallbackNodes return () forkIO $ do myThreadId >>= flip labelThread "XMPP.stanzas" 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 $ \_ -> hPutStrLn stderr "Started XMPP server." -- Wait for DHT and XMPP threads to finish. -- Use ResourceT to clean-up XMPP server. waitForSignal stopAnnouncer announcer quitBt quitTox swarmsdb <- atomically $ readTVar (Mainline.contactInfo swarms) L.writeFile "bt-peers.dat" $ S.encodeLazy swarmsdb