summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Connection/Tcp.hs13
-rw-r--r--Connection/Tox.hs9
-rw-r--r--Connection/Tox/Threads.hs7
-rw-r--r--Presence/DNSCache.hs5
-rw-r--r--Presence/Presence.hs9
-rw-r--r--Presence/XMPPServer.hs6
-rw-r--r--ToxManager.hs9
-rw-r--r--ToxToXMPP.hs3
-rw-r--r--examples/dhtd.hs30
-rw-r--r--src/Control/Concurrent/Lifted/Instrument.hs3
-rw-r--r--src/DPut.hs16
-rw-r--r--src/Network/Address.hs3
-rw-r--r--src/Network/BitTorrent/MainlineDHT.hs19
-rw-r--r--src/Network/Kademlia/Bootstrap.hs22
-rw-r--r--src/Network/QueryResponse.hs15
-rw-r--r--src/Network/StreamServer.hs3
-rw-r--r--src/Network/Tox.hs44
-rw-r--r--src/Network/Tox/ContactInfo.hs3
-rw-r--r--src/Network/Tox/DHT/Handlers.hs14
-rw-r--r--src/Network/Tox/Onion/Transport.hs12
-rw-r--r--src/Network/UPNP.hs3
21 files changed, 154 insertions, 94 deletions
diff --git a/Connection/Tcp.hs b/Connection/Tcp.hs
index 2c2c8d76..9a44f34f 100644
--- a/Connection/Tcp.hs
+++ b/Connection/Tcp.hs
@@ -80,6 +80,7 @@ import Network.StreamServer
80import Network.SocketLike hiding (sClose) 80import Network.SocketLike hiding (sClose)
81import qualified Connection as G 81import qualified Connection as G
82 ;import Connection (Manager (..), Policy(..)) 82 ;import Connection (Manager (..), Policy(..))
83import DPut
83 84
84 85
85type Microseconds = Int 86type Microseconds = Int
@@ -298,10 +299,10 @@ server allocate sessionConduits = do
298 `fmap` atomically (readTVar $ listenmap server) 299 `fmap` atomically (readTVar $ listenmap server)
299 when (not listening) $ do 300 when (not listening) $ do
300 301
301 hPutStrLn stderr $ "Started listening on "++show port 302 dput XMisc $ "Started listening on "++show port
302 303
303 sserv <- flip streamServer port ServerConfig 304 sserv <- flip streamServer port ServerConfig
304 { serverWarn = hPutStrLn stderr 305 { serverWarn = dput XMisc
305 , serverSession = \sock _ h -> do 306 , serverSession = \sock _ h -> do
306 (conkey,u) <- makeConnKey params sock 307 (conkey,u) <- makeConnKey params sock
307 _ <- newConnection server sessionConduits params conkey u h In 308 _ <- newConnection server sessionConduits params conkey u h In
@@ -311,7 +312,7 @@ server allocate sessionConduits = do
311 atomically $ listenmap server `modifyTVar'` Map.insert port sserv 312 atomically $ listenmap server `modifyTVar'` Map.insert port sserv
312 313
313 doit server (Ignore port) = do 314 doit server (Ignore port) = do
314 hPutStrLn stderr $ "Stopping listen on "++show port 315 dput XMisc $ "Stopping listen on "++show port
315 mb <- atomically $ do 316 mb <- atomically $ do
316 map <- readTVar $ listenmap server 317 map <- readTVar $ listenmap server
317 modifyTVar' (listenmap server) $ Map.delete port 318 modifyTVar' (listenmap server) $ Map.delete port
@@ -758,7 +759,7 @@ bshow :: Show a => a -> ByteString
758bshow e = S.pack . show $ e 759bshow e = S.pack . show $ e
759 760
760warn :: ByteString -> IO () 761warn :: ByteString -> IO ()
761warn str = S.hPutStrLn stderr str >> hFlush stderr 762warn str =dputB XMisc str >> hFlush stderr
762 763
763debugNoise :: Monad m => t -> m () 764debugNoise :: Monad m => t -> m ()
764debugNoise str = return () 765debugNoise str = return ()
@@ -790,8 +791,8 @@ tcpManager grokKey s2k resolvKey sv = do
790 Just conkey -> do 791 Just conkey -> do
791 control sv $ case grokKey conkey of 792 control sv $ case grokKey conkey of
792 (saddr,params,ms) -> ConnectWithEndlessRetry saddr params ms 793 (saddr,params,ms) -> ConnectWithEndlessRetry saddr params ms
793 OpenToConnect -> hPutStrLn stderr "TODO: TCP OpenToConnect" 794 OpenToConnect -> dput XMisc "TODO: TCP OpenToConnect"
794 RefusingToConnect -> hPutStrLn stderr "TODO: TCP RefusingToConnect" 795 RefusingToConnect -> dput XMisc "TODO: TCP RefusingToConnect"
795 , connections = do 796 , connections = do
796 c <- readTVar $ conmap sv 797 c <- readTVar $ conmap sv
797 fmap (exportConnection nullping c) <$> readTVar rmap 798 fmap (exportConnection nullping c) <$> readTVar rmap
diff --git a/Connection/Tox.hs b/Connection/Tox.hs
index 03ffbc25..1cbbdaee 100644
--- a/Connection/Tox.hs
+++ b/Connection/Tox.hs
@@ -31,6 +31,7 @@ import GHC.Conc (labelThread)
31#endif 31#endif
32import GHC.Conc (ThreadStatus (..), threadStatus) 32import GHC.Conc (ThreadStatus (..), threadStatus)
33import System.IO 33import System.IO
34import DPut
34 35
35 36
36 37
@@ -81,7 +82,7 @@ launch lbl st f = do
81 tid <- forkIO (f stvar) 82 tid <- forkIO (f stvar)
82 labelThread tid lbl 83 labelThread tid lbl
83 stat <- threadStatus tid 84 stat <- threadStatus tid
84 hPutStrLn stderr $ "launch "++lbl++" "++show stat 85 dput XMan $ "launch "++lbl++" "++show stat
85 return $ StatefulTask tid stvar 86 return $ StatefulTask tid stvar
86 87
87 88
@@ -142,12 +143,12 @@ setToxPolicy :: Parameters extra
142 -> Policy 143 -> Policy
143 -> IO () 144 -> IO ()
144setToxPolicy params conmap k@(Key me them) policy = do 145setToxPolicy params conmap k@(Key me them) policy = do
145 hPutStrLn stderr $ "C.setToxPolicy "++show (them,policy) 146 dput XMan $ "C.setToxPolicy "++show (them,policy)
146 case policy of 147 case policy of
147 TryingToConnect -> do 148 TryingToConnect -> do
148 mst <- lookupForPolicyChange conmap k policy 149 mst <- lookupForPolicyChange conmap k policy
149 r <- atomically $ lookupContact k (roster params) 150 r <- atomically $ lookupContact k (roster params)
150 hPutStrLn stderr $ "C.r="++show (fmap (const ()) r) 151 dput XMan $ "C.r="++show (fmap (const ()) r)
151 forM_ r $ \(sec,c) -> do 152 forM_ r $ \(sec,c) -> do
152 let persue_methods = PersueContactMethods 153 let persue_methods = PersueContactMethods
153 { allsessions = sessions params 154 { allsessions = sessions params
@@ -178,7 +179,7 @@ setToxPolicy params conmap k@(Key me them) policy = do
178 fmap (fromMaybe G.Dormant) $ forM (Map.lookup (id2key them) sbk) $ \ss -> do 179 fmap (fromMaybe G.Dormant) $ forM (Map.lookup (id2key them) sbk) $ \ss -> do
179 stats <- mapM (readTVar . ncState) ss 180 stats <- mapM (readTVar . ncState) ss
180 return $ maximum stats 181 return $ maximum stats
181 hPutStrLn stderr $ "C.mst="++show (fmap (const ()) mst) 182 dput XMan $ "C.mst="++show (fmap (const ()) mst)
182 forM_ mst $ \st -> do 183 forM_ mst $ \st -> do
183 let getPolicy = readTVar $ connPolicy st 184 let getPolicy = readTVar $ connPolicy st
184 tasks <- atomically $ readTVar (handshakeTask st) 185 tasks <- atomically $ readTVar (handshakeTask st)
diff --git a/Connection/Tox/Threads.hs b/Connection/Tox/Threads.hs
index aeeab0e1..6a7edeb4 100644
--- a/Connection/Tox/Threads.hs
+++ b/Connection/Tox/Threads.hs
@@ -41,6 +41,7 @@ import Data.Functor.Identity
41import Data.Time.Clock.POSIX 41import Data.Time.Clock.POSIX
42import System.IO 42import System.IO
43import System.Timeout 43import System.Timeout
44import DPut
44 45
45 46
46 47
@@ -146,11 +147,11 @@ persueContact getPolicy getStatus PersueContactMethods{..} statusVar = do
146 DHT.cookieRequest crypto client (toPublic myseckey) ni 147 DHT.cookieRequest crypto client (toPublic myseckey) ni
147 interval <- case mbCookie of 148 interval <- case mbCookie of
148 Nothing -> do 149 Nothing -> do
149 hPutStrLn stderr ("persueContact: (" ++ show mykeyAsId ++") <--> (" ++ show theirkeyAsId ++ ").") 150 dput XMan ("persueContact: (" ++ show mykeyAsId ++") <--> (" ++ show theirkeyAsId ++ ").")
150 hPutStrLn stderr ("persueContact: CookieRequest failed. TODO: dhtpkNodes thingy") 151 dput XMan ("persueContact: CookieRequest failed. TODO: dhtpkNodes thingy")
151 return longRetryInterval 152 return longRetryInterval
152 Just cookie -> do 153 Just cookie -> do
153 hPutStrLn stderr "Have cookie, creating handshake packet..." 154 dput XMan "Have cookie, creating handshake packet..."
154 let hp = HParam { hpOtherCookie = cookie 155 let hp = HParam { hpOtherCookie = cookie
155 , hpMySecretKey = myseckey 156 , hpMySecretKey = myseckey
156 , hpCookieRemotePubkey = theirpubkey 157 , hpCookieRemotePubkey = theirpubkey
diff --git a/Presence/DNSCache.hs b/Presence/DNSCache.hs
index aaf1a7be..afcc227c 100644
--- a/Presence/DNSCache.hs
+++ b/Presence/DNSCache.hs
@@ -50,6 +50,7 @@ import SockAddr ()
50import ControlMaybe ( handleIO_ ) 50import ControlMaybe ( handleIO_ )
51import GetHostByAddr ( getHostByAddr ) 51import GetHostByAddr ( getHostByAddr )
52import InterruptibleDelay 52import InterruptibleDelay
53import DPut
53 54
54type TimeStamp = UTCTime 55type TimeStamp = UTCTime
55 56
@@ -106,7 +107,7 @@ make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromB
106 107
107tryForkOS :: IO () -> IO ThreadId 108tryForkOS :: IO () -> IO ThreadId
108tryForkOS action = catchIOError (forkOS action) $ \e -> do 109tryForkOS action = catchIOError (forkOS action) $ \e -> do
109 hPutStrLn stderr $ "DNSCache: Link with -threaded to avoid excessively long time-out." 110 dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out."
110 forkIO action 111 forkIO action
111 112
112 113
@@ -152,7 +153,7 @@ strip_brackets s =
152 153
153reportTimeout :: forall a. Show a => a -> IO () 154reportTimeout :: forall a. Show a => a -> IO ()
154reportTimeout addrtext = do 155reportTimeout addrtext = do
155 hPutStrLn stderr $ "timeout resolving: "++show addrtext 156 dput XMisc $ "timeout resolving: "++show addrtext
156 -- killThread rt 157 -- killThread rt
157 158
158unmap6mapped4 :: SockAddr -> SockAddr 159unmap6mapped4 :: SockAddr -> SockAddr
diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 2f59a52f..18bde516 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -62,6 +62,7 @@ import Util
62import qualified Connection 62import qualified Connection
63import Network.Tox.NodeId (id2key,key2id) 63import Network.Tox.NodeId (id2key,key2id)
64import Crypto.Tox (decodeSecret) 64import Crypto.Tox (decodeSecret)
65import DPut
65 66
66isPeerKey :: ConnectionKey -> Bool 67isPeerKey :: ConnectionKey -> Bool
67isPeerKey k = case k of { PeerKey {} -> True ; _ -> False } 68isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }
@@ -239,23 +240,23 @@ chooseResourceName state k addr clientsNameForMe desired = do
239#endif 240#endif
240 cfs <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return []) 241 cfs <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return [])
241 let profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile0) cfs 242 let profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile0) cfs
242 -- hPutStrLn stderr $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs) 243 -- dput XMisc $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs)
243 let wanted_profile = head $ profiles ++ [wanted_profile0] 244 let wanted_profile = head $ profiles ++ [wanted_profile0]
244 secs <- configText ConfigFiles.getSecrets user wanted_profile 245 secs <- configText ConfigFiles.getSecrets user wanted_profile
245 case secs of 246 case secs of
246 sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec) 247 sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec)
247 , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub) 248 , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub)
248 -> do activateAccount toxman k wanted_profile s 249 -> do activateAccount toxman k wanted_profile s
249 hPutStrLn stderr $ "loaded tox secret " ++ show sec 250 dput XMisc $ "loaded tox secret " ++ show sec
250 return wanted_profile 251 return wanted_profile
251 _ -> do 252 _ -> do
252 -- XXX: We should probably fail to connect when an 253 -- XXX: We should probably fail to connect when an
253 -- invalid Tox profile is used. For now, we'll 254 -- invalid Tox profile is used. For now, we'll
254 -- fall back to the Unix account login. 255 -- fall back to the Unix account login.
255 hPutStrLn stderr "failed to find tox secret" 256 dput XMisc "failed to find tox secret"
256 return "." 257 return "."
257 ("*.tox","") -> do 258 ("*.tox","") -> do
258 hPutStrLn stderr $ "TODO: Match single tox key profile or generate first." 259 dput XMisc $ "TODO: Match single tox key profile or generate first."
259 -- TODO: Match single tox key profile or generate first. 260 -- TODO: Match single tox key profile or generate first.
260 _todo 261 _todo
261 _ -> return "." 262 _ -> return "."
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 936b2137..c73146fd 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -926,7 +926,7 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
926 when (begindoc==EventBeginDocument) $ do 926 when (begindoc==EventBeginDocument) $ do
927 whenJust nextElement $ \xml -> do 927 whenJust nextElement $ \xml -> do
928 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do 928 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
929 -- liftIO $ hPutStrLn stderr $ "STREAM ATTRS "++show stream_attrs 929 -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs
930 let stream_name = lookupAttrib "to" stream_attrs 930 let stream_name = lookupAttrib "to" stream_attrs
931 -- xmpp_version = lookupAttrib "version" stream_attrs 931 -- xmpp_version = lookupAttrib "version" stream_attrs
932 fix $ \loop -> do 932 fix $ \loop -> do
@@ -1866,10 +1866,10 @@ xmppServer allocate xmpp = do
1866 forkIO $ do 1866 forkIO $ do
1867 myThreadId >>= flip labelThread ("XMPP.monitor") 1867 myThreadId >>= flip labelThread ("XMPP.monitor")
1868 monitor sv peer_params xmpp 1868 monitor sv peer_params xmpp
1869 hPutStrLn stderr $ "Starting peer listen" 1869 dput XMisc $ "Starting peer listen"
1870 peer_bind <- maybe (getBindAddress "5269" True) return $ xmppPeerBind xmpp 1870 peer_bind <- maybe (getBindAddress "5269" True) return $ xmppPeerBind xmpp
1871 control sv (Listen peer_bind peer_params) 1871 control sv (Listen peer_bind peer_params)
1872 hPutStrLn stderr $ "Starting client listen" 1872 dput XMisc $ "Starting client listen"
1873 client_bind <- maybe (getBindAddress "5222" True) return $ xmppClientBind xmpp 1873 client_bind <- maybe (getBindAddress "5222" True) return $ xmppClientBind xmpp
1874 control sv (Listen client_bind client_params) 1874 control sv (Listen client_bind client_params)
1875 return XMPPServer { _xmpp_sv = sv, _xmpp_peer_params = peer_params } 1875 return XMPPServer { _xmpp_sv = sv, _xmpp_peer_params = peer_params }
diff --git a/ToxManager.hs b/ToxManager.hs
index cd835983..04695894 100644
--- a/ToxManager.hs
+++ b/ToxManager.hs
@@ -30,6 +30,7 @@ import System.IO
30import Text.Read 30import Text.Read
31import ToxToXMPP 31import ToxToXMPP
32import XMPPServer (ConnectionKey) 32import XMPPServer (ConnectionKey)
33import DPut
33 34
34#ifdef THREAD_DEBUG 35#ifdef THREAD_DEBUG
35import Control.Concurrent.Lifted.Instrument 36import Control.Concurrent.Lifted.Instrument
@@ -64,7 +65,7 @@ toxman :: Announcer
64 -> ToxManager ConnectionKey 65 -> ToxManager ConnectionKey
65toxman announcer toxbkts tox presence = ToxManager 66toxman announcer toxbkts tox presence = ToxManager
66 { activateAccount = \k pubname seckey -> do 67 { activateAccount = \k pubname seckey -> do
67 hPutStrLn stderr $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey) 68 dput XMan $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey)
68 let ContactInfo{ accounts } = Tox.toxContactInfo tox 69 let ContactInfo{ accounts } = Tox.toxContactInfo tox
69 pub = toPublic seckey 70 pub = toPublic seckey
70 pubid = Tox.key2id pub 71 pubid = Tox.key2id pub
@@ -100,7 +101,7 @@ toxman announcer toxbkts tox presence = ToxManager
100 return () 101 return ()
101 102
102 , deactivateAccount = \k pubname -> do 103 , deactivateAccount = \k pubname -> do
103 hPutStrLn stderr $ "toxman DECTIVATE (todo) 1 " ++ show pubname 104 dput XMan $ "toxman DECTIVATE (todo) 1 " ++ show pubname
104 let ContactInfo{ accounts } = Tox.toxContactInfo tox 105 let ContactInfo{ accounts } = Tox.toxContactInfo tox
105 mpubid = readMaybe $ T.unpack $ T.take 43 pubname 106 mpubid = readMaybe $ T.unpack $ T.take 43 pubname
106 bStopped <- fmap (fromMaybe Nothing) $ atomically $ do 107 bStopped <- fmap (fromMaybe Nothing) $ atomically $ do
@@ -122,7 +123,7 @@ toxman announcer toxbkts tox presence = ToxManager
122 return (akey,bkts) 123 return (akey,bkts)
123 else return Nothing 124 else return Nothing
124 forM_ bStopped $ \kbkts -> do 125 forM_ bStopped $ \kbkts -> do
125 hPutStrLn stderr $ "toxman DECTIVATE (todo) 3 " ++ show pubname 126 dput XMan $ "toxman DECTIVATE (todo) 3 " ++ show pubname
126 let Just pubid = mpubid 127 let Just pubid = mpubid
127 pub = Tox.id2key pubid 128 pub = Tox.id2key pubid
128 forM_ kbkts $ \(akey,bkts) -> do 129 forM_ kbkts $ \(akey,bkts) -> do
@@ -141,7 +142,7 @@ toxman announcer toxbkts tox presence = ToxManager
141 let m = do meid <- readMaybe $ T.unpack $ T.take 43 me 142 let m = do meid <- readMaybe $ T.unpack $ T.take 43 me
142 themid <- readMaybe $ T.unpack $ T.take 43 them 143 themid <- readMaybe $ T.unpack $ T.take 43 them
143 return $ Tox.Key meid themid 144 return $ Tox.Key meid themid
144 hPutStrLn stderr $ "toxman ConnectionPolicy " ++ show (me,them,p,fmap (const ()) m) 145 dput XMan $ "toxman ConnectionPolicy " ++ show (me,them,p,fmap (const ()) m)
145 forM_ m $ \k -> do 146 forM_ m $ \k -> do
146 setPolicy (Tox.toxMgr tox) k p 147 setPolicy (Tox.toxMgr tox) k p
147 case p of 148 case p of
diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index 367e5bf7..b1c233a3 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -62,6 +62,7 @@ import Control.Concurrent.Lifted.Instrument
62import Control.Concurrent.Lifted 62import Control.Concurrent.Lifted
63import GHC.Conc (labelThread) 63import GHC.Conc (labelThread)
64#endif 64#endif
65import DPut
65 66
66xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage 67xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage
67xmppToTox = do 68xmppToTox = do
@@ -216,7 +217,7 @@ startConnecting tx them = do
216 217
217stopConnecting :: ToxToXMPP -> PublicKey -> IO () 218stopConnecting :: ToxToXMPP -> PublicKey -> IO ()
218stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them = do 219stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them = do
219 hPutStrLn stderr $ "STOP CONNECTING " ++ show (key2id them) 220 dput XMisc $ "STOP CONNECTING " ++ show (key2id them)
220 let pub = toPublic $ userSecret acnt 221 let pub = toPublic $ userSecret acnt
221 me = key2id pub 222 me = key2id pub
222 akey <- akeyDHTKeyShare announcer me them 223 akey <- akeyDHTKeyShare announcer me them
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 355450a2..83e8c24f 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -369,6 +369,12 @@ clientSession s@Session{..} sock cnum h = do
369 case B.unsnoc x of 369 case B.unsnoc x of
370 Just (str,c) | isSpace c -> (str,False) 370 Just (str,c) | isSpace c -> (str,False)
371 _ -> (x,True) 371 _ -> (x,True)
372 allDebugTags = [XAnnounce .. XMisc]
373 showDebugTags = do
374 vs <- mapM getVerbose allDebugTags
375 let f True = "v"
376 f False = "-"
377 hPutClient h $ showReport (zip (map (drop 1 . show) allDebugTags) (map f vs))
372 let readHex :: (Read n, Integral n) => String -> Maybe n 378 let readHex :: (Read n, Integral n) => String -> Maybe n
373 readHex s = readMaybe ("0x" ++ s) 379 readHex s = readMaybe ("0x" ++ s)
374 strToSession :: String -> IO (Either String Tox.NetCryptoSession) 380 strToSession :: String -> IO (Either String Tox.NetCryptoSession)
@@ -635,6 +641,20 @@ clientSession s@Session{..} sock cnum h = do
635 setQuiet tag 641 setQuiet tag
636 hPutClient h $ "Suppressing " ++ show tag ++ " messages." 642 hPutClient h $ "Suppressing " ++ show tag ++ " messages."
637 643
644 ("quiet",s) | "all" <- strp s
645 -> cmd0 $ do
646 mapM_ setQuiet allDebugTags
647 showDebugTags
648
649 (verbose,s) | "" <- strp s
650 , verbose `elem` ["verbose","quiet"]
651 -> cmd0 $ showDebugTags
652
653 ("verbose",s) | "all" <- strp s
654 -> cmd0 $ do
655 mapM_ setVerbose allDebugTags
656 showDebugTags
657
638 ("verbose",s) | s' <- strp s 658 ("verbose",s) | s' <- strp s
639 , Just (tag::DebugTag) <- readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s') 659 , Just (tag::DebugTag) <- readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s')
640 -> cmd0 $ do 660 -> cmd0 $ do
@@ -1410,8 +1430,10 @@ main = do
1410 1430
1411 announcer <- forkAnnouncer 1431 announcer <- forkAnnouncer
1412 1432
1413 -- Default: quiet all tags. 1433 -- Default: quiet all tags (except XMisc).
1414 forM [minBound .. maxBound] setQuiet 1434 forM [minBound .. maxBound] setQuiet
1435 -- Default: verbose XMisc
1436 setVerbose XMisc
1415 1437
1416 (quitBt,btdhts,btips,baddrs) <- case portbt opts of 1438 (quitBt,btdhts,btips,baddrs) <- case portbt opts of
1417 "" -> return (return (), Map.empty,return [],[]) 1439 "" -> return (return (), Map.empty,return [],[])
@@ -1508,7 +1530,7 @@ main = do
1508 "" -> return (Nothing,return (), Map.empty, return [],[]) 1530 "" -> return (Nothing,return (), Map.empty, return [],[])
1509 toxport -> do 1531 toxport -> do
1510 addrTox <- getBindAddress toxport (ip6tox opts) 1532 addrTox <- getBindAddress toxport (ip6tox opts)
1511 hPutStrLn stderr $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts)) 1533 dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
1512 tox <- Tox.newTox keysdb 1534 tox <- Tox.newTox keysdb
1513 addrTox 1535 addrTox
1514 (Just _netCryptoSessionsState) 1536 (Just _netCryptoSessionsState)
@@ -1771,7 +1793,7 @@ main = do
1771 installHandler sigINT (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing 1793 installHandler sigINT (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
1772 let defaultToxData = do 1794 let defaultToxData = do
1773 rster <- Tox.newContactInfo 1795 rster <- Tox.newContactInfo
1774 orouter <- newOnionRouter (hPutStrLn stderr) 1796 orouter <- newOnionRouter (dput XMisc)
1775 return (rster, orouter) 1797 return (rster, orouter)
1776 (rstr,orouter) <- fromMaybe defaultToxData $ do 1798 (rstr,orouter) <- fromMaybe defaultToxData $ do
1777 tox <- mbtox 1799 tox <- mbtox
@@ -1830,7 +1852,7 @@ main = do
1830 (checkQuit >> return (return ())) 1852 (checkQuit >> return (return ()))
1831 what 1853 what
1832 1854
1833 forM msv $ \_ -> hPutStrLn stderr "Started XMPP server." 1855 forM msv $ \_ -> dput XMisc "Started XMPP server."
1834 1856
1835 -- Wait for DHT and XMPP threads to finish. 1857 -- Wait for DHT and XMPP threads to finish.
1836 -- Use ResourceT to clean-up XMPP server. 1858 -- Use ResourceT to clean-up XMPP server.
diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs
index 5b3237cc..187b9276 100644
--- a/src/Control/Concurrent/Lifted/Instrument.hs
+++ b/src/Control/Concurrent/Lifted/Instrument.hs
@@ -22,6 +22,7 @@ import Data.Time()
22import Data.Time.Clock 22import Data.Time.Clock
23import System.IO 23import System.IO
24import Control.Monad.IO.Class 24import Control.Monad.IO.Class
25import DPut
25 26
26 27
27data PerThread = PerThread 28data PerThread = PerThread
@@ -38,7 +39,7 @@ data GlobalState = GlobalState
38globals :: MVar GlobalState 39globals :: MVar GlobalState
39globals = unsafePerformIO $ newMVar $ GlobalState 40globals = unsafePerformIO $ newMVar $ GlobalState
40 { threads = Map.empty 41 { threads = Map.empty
41 , reportException = hPutStrLn stderr 42 , reportException = dput XMisc
42 } 43 }
43{-# NOINLINE globals #-} 44{-# NOINLINE globals #-}
44 45
diff --git a/src/DPut.hs b/src/DPut.hs
index b305a581..ff828112 100644
--- a/src/DPut.hs
+++ b/src/DPut.hs
@@ -6,8 +6,12 @@ import System.IO (stderr,hPutStrLn)
6import Data.Maybe 6import Data.Maybe
7import System.IO.Unsafe (unsafePerformIO) 7import System.IO.Unsafe (unsafePerformIO)
8import System.Log.Logger 8import System.Log.Logger
9import qualified Data.ByteString.Char8 as B
10import qualified Data.Text as T
11import qualified Data.Text.Encoding as T
9 12
10data DebugTag = XAnnounce | XDHT | XOnion | XNetCrypto | XPing | XLan | XMisc | XWLog 13-- | Debug Tags, add more as needed, but ensure XAnnounce is always first, XMisc last
14data DebugTag = XAnnounce | XBitTorrent | XDHT | XLan | XMan | XNetCrypto | XOnion | XPing | XRefresh | XWLog | XMisc
11 deriving (Eq,Ord,Show,Read,Enum,Bounded) 15 deriving (Eq,Ord,Show,Read,Enum,Bounded)
12 16
13appName :: String 17appName :: String
@@ -19,6 +23,9 @@ a <.> b = a ++ "." ++ b
19dput :: DebugTag -> String -> IO () 23dput :: DebugTag -> String -> IO ()
20dput tag msg = debugM (appName <.> show tag) msg 24dput tag msg = debugM (appName <.> show tag) msg
21 25
26dputB :: DebugTag -> B.ByteString -> IO ()
27dputB tag msg = debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg)
28
22setTagLevel :: Priority -> DebugTag -> IO () 29setTagLevel :: Priority -> DebugTag -> IO ()
23setTagLevel level tag = updateGlobalLogger (appName <.> show tag) (setLevel level) 30setTagLevel level tag = updateGlobalLogger (appName <.> show tag) (setLevel level)
24 31
@@ -27,3 +34,10 @@ setQuiet = setTagLevel WARNING
27 34
28setVerbose :: DebugTag -> IO () 35setVerbose :: DebugTag -> IO ()
29setVerbose = setTagLevel DEBUG 36setVerbose = setTagLevel DEBUG
37
38getVerbose tag = do
39 logger <- getLogger (appName <.> show tag)
40 case getLevel logger of
41 Just p | p <= DEBUG -> return True
42 _ -> return False
43
diff --git a/src/Network/Address.hs b/src/Network/Address.hs
index 3766d614..367f608b 100644
--- a/src/Network/Address.hs
+++ b/src/Network/Address.hs
@@ -131,6 +131,7 @@ import System.Locale (defaultTimeLocale)
131#endif 131#endif
132import System.Entropy 132import System.Entropy
133import System.IO (stderr) 133import System.IO (stderr)
134import DPut
134 135
135-- import Paths_bittorrent (version) 136-- import Paths_bittorrent (version)
136 137
@@ -1193,7 +1194,7 @@ getBindAddress bindspec enabled6 = do
1193 then SockAddrInet6 (parsePort listenPortString) 0 iN6ADDR_ANY 0 1194 then SockAddrInet6 (parsePort listenPortString) 0 iN6ADDR_ANY 0
1194 else SockAddrInet (parsePort listenPortString) iNADDR_ANY 1195 else SockAddrInet (parsePort listenPortString) iNADDR_ANY
1195 where parsePort s = fromMaybe 0 $ readMaybe s 1196 where parsePort s = fromMaybe 0 $ readMaybe s
1196 hPutStrLn stderr $ BS8.pack $ "Listening on " ++ show listenAddr 1197 dput XMisc $ "Listening on " ++ show listenAddr
1197 return listenAddr 1198 return listenAddr
1198 1199
1199-- | True if the argument is an IPv4-mapped address with prefix ::FFFF:0:0/96 1200-- | True if the argument is an IPv4-mapped address with prefix ::FFFF:0:0/96
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
index 847d820b..626f980f 100644
--- a/src/Network/BitTorrent/MainlineDHT.hs
+++ b/src/Network/BitTorrent/MainlineDHT.hs
@@ -87,6 +87,7 @@ import qualified Data.Aeson as JSON
87import Text.Read 87import Text.Read
88import System.Global6 88import System.Global6
89import Control.TriadCommittee 89import Control.TriadCommittee
90import DPut
90 91
91newtype NodeId = NodeId ByteString 92newtype NodeId = NodeId ByteString
92 deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable) 93 deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable)
@@ -431,10 +432,10 @@ addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr Byte
431addVerbosity tr = 432addVerbosity tr =
432 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do 433 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
433 forM_ m $ mapM_ $ \(msg,addr) -> do 434 forM_ m $ mapM_ $ \(msg,addr) -> do
434 hPutStrLn stderr (showPacket id addr " --> " msg) 435 dput XBitTorrent (showPacket id addr " --> " msg)
435 kont m 436 kont m
436 , sendMessage = \addr msg -> do 437 , sendMessage = \addr msg -> do
437 hPutStrLn stderr (showPacket id addr " <-- " msg) 438 dput XBitTorrent (showPacket id addr " <-- " msg)
438 sendMessage tr addr msg 439 sendMessage tr addr msg
439 } 440 }
440 441
@@ -642,18 +643,18 @@ newClient swarms addr = do
642 fork $ fix $ \again -> do 643 fork $ fix $ \again -> do
643 myThreadId >>= flip labelThread "addr4" 644 myThreadId >>= flip labelThread "addr4"
644 (addr, ns) <- atomically $ readTChan addr4 645 (addr, ns) <- atomically $ readTChan addr4
645 hPutStrLn stderr $ "External IPv4: "++show (addr, length ns) 646 dput XBitTorrent $ "External IPv4: "++show (addr, length ns)
646 forM_ ns $ \n -> do 647 forM_ ns $ \n -> do
647 hPutStrLn stderr $ "Change IP, ping: "++show n 648 dput XBitTorrent $ "Change IP, ping: "++show n
648 ping outgoingClient n 649 ping outgoingClient n
649 -- TODO: trigger bootstrap ipv4 650 -- TODO: trigger bootstrap ipv4
650 again 651 again
651 fork $ fix $ \again -> do 652 fork $ fix $ \again -> do
652 myThreadId >>= flip labelThread "addr6" 653 myThreadId >>= flip labelThread "addr6"
653 (addr,ns) <- atomically $ readTChan addr6 654 (addr,ns) <- atomically $ readTChan addr6
654 hPutStrLn stderr $ "External IPv6: "++show (addr, length ns) 655 dput XBitTorrent $ "External IPv6: "++show (addr, length ns)
655 forM_ ns $ \n -> do 656 forM_ ns $ \n -> do
656 hPutStrLn stderr $ "Change IP, ping: "++show n 657 dput XBitTorrent $ "Change IP, ping: "++show n
657 ping outgoingClient n 658 ping outgoingClient n
658 -- TODO: trigger bootstrap ipv6 659 -- TODO: trigger bootstrap ipv6
659 again 660 again
@@ -734,7 +735,7 @@ mainlineKademlia client committee refresher
734 return $ do 735 return $ do
735 io1 >> io2 736 io1 >> io2
736 {- noisy (timestamp updates are currently reported as transitions to Accepted) 737 {- noisy (timestamp updates are currently reported as transitions to Accepted)
737 hPutStrLn stderr $ unwords 738 dput XBitTorrent $ unwords
738 [ show (transitionedTo tr) 739 [ show (transitionedTo tr)
739 , show (transitioningNode tr) 740 , show (transitioningNode tr)
740 ] -} 741 ] -}
@@ -753,7 +754,7 @@ transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeI
753transitionCommittee committee (RoutingTransition ni Stranger) = do 754transitionCommittee committee (RoutingTransition ni Stranger) = do
754 delVote committee (nodeId ni) 755 delVote committee (nodeId ni)
755 return $ do 756 return $ do
756 hPutStrLn stderr $ "delVote "++show (nodeId ni) 757 dput XBitTorrent $ "delVote "++show (nodeId ni)
757transitionCommittee committee _ = return $ return () 758transitionCommittee committee _ = return $ return ()
758 759
759updateRouting :: MainlineClient -> Routing -> NodeInfo -> Message BValue -> IO () 760updateRouting :: MainlineClient -> Routing -> NodeInfo -> Message BValue -> IO ()
@@ -768,7 +769,7 @@ updateRouting client routing naddr msg = do
768 case msg of 769 case msg of
769 R { rspReflectedIP = Just sockaddr } 770 R { rspReflectedIP = Just sockaddr }
770 -> do 771 -> do
771 -- hPutStrLn stderr $ "External: "++show (nodeId naddr,sockaddr) 772 -- dput XBitTorrent $ "External: "++show (nodeId naddr,sockaddr)
772 atomically $ addVote committee (nodeId naddr) sockaddr 773 atomically $ addVote committee (nodeId naddr) sockaddr
773 _ -> return () 774 _ -> return ()
774 insertNode (mainlineKademlia client committee refresher) naddr 775 insertNode (mainlineKademlia client committee refresher) naddr
diff --git a/src/Network/Kademlia/Bootstrap.hs b/src/Network/Kademlia/Bootstrap.hs
index d77f524c..4197e06e 100644
--- a/src/Network/Kademlia/Bootstrap.hs
+++ b/src/Network/Kademlia/Bootstrap.hs
@@ -143,7 +143,7 @@ forkPollForRefresh r@BucketRefresher{ refreshInterval
143 where 143 where
144 refresh :: Int -> IO Int 144 refresh :: Int -> IO Int
145 refresh n = do 145 refresh n = do
146 -- hPutStrLn stderr $ "Refresh time! "++ show n 146 -- dput XRefresh $ "Refresh time! "++ show n
147 refreshBucket r n 147 refreshBucket r n
148 148
149 go again ( bktnum :-> refresh_time ) = do 149 go again ( bktnum :-> refresh_time ) = do
@@ -162,7 +162,7 @@ forkPollForRefresh r@BucketRefresher{ refreshInterval
162 return () 162 return ()
163 return () 163 return ()
164 picoseconds -> do 164 picoseconds -> do
165 -- hPutStrLn stderr $ show (picoseconds `div` 10^12) ++ " seconds until refresh " ++ show bktnum 165 -- dput XRefresh $ show (picoseconds `div` 10^12) ++ " seconds until refresh " ++ show bktnum
166 threadDelay ( picoseconds `div` 10^6 ) 166 threadDelay ( picoseconds `div` 10^6 )
167 again 167 again
168 168
@@ -202,13 +202,13 @@ onFinishedRefresh BucketRefresher { bootstrapCountdown
202 , refreshQueue 202 , refreshQueue
203 , refreshBuckets } num now = do 203 , refreshBuckets } num now = do
204 bootstrapping <- readTVar bootstrapMode 204 bootstrapping <- readTVar bootstrapMode
205 if not bootstrapping then return $ return () -- hPutStrLn stderr $ "Finished non-boostrapping refresh: "++show num 205 if not bootstrapping then return $ return () -- dput XRefresh $ "Finished non-boostrapping refresh: "++show num
206 else do 206 else do
207 tbl <- readTVar refreshBuckets 207 tbl <- readTVar refreshBuckets
208 action <- 208 action <-
209 if num /= R.bktCount tbl - 1 209 if num /= R.bktCount tbl - 1
210 then do modifyTVar' bootstrapCountdown (fmap pred) 210 then do modifyTVar' bootstrapCountdown (fmap pred)
211 return $ return () -- hPutStrLn stderr $ "BOOTSTRAP decrement" 211 return $ return () -- dput XRefresh $ "BOOTSTRAP decrement"
212 else do 212 else do
213 -- The last bucket finished. 213 -- The last bucket finished.
214 cnt <- readTVar bootstrapCountdown 214 cnt <- readTVar bootstrapCountdown
@@ -225,17 +225,17 @@ onFinishedRefresh BucketRefresher { bootstrapCountdown
225 -- Schedule immediate refresh for unfull buckets (other than this one). 225 -- Schedule immediate refresh for unfull buckets (other than this one).
226 modifyTVar' refreshQueue $ Int.insert n (now - 1) 226 modifyTVar' refreshQueue $ Int.insert n (now - 1)
227 writeTVar bootstrapCountdown $! Just $! length unfull 227 writeTVar bootstrapCountdown $! Just $! length unfull
228 return $ return () -- hPutStrLn stderr $ "BOOTSTRAP scheduling: "++show unfull 228 return $ return () -- dput XRefresh $ "BOOTSTRAP scheduling: "++show unfull
229 Just n -> do writeTVar bootstrapCountdown $! Just $! pred n 229 Just n -> do writeTVar bootstrapCountdown $! Just $! pred n
230 return $ return () -- hPutStrLn stderr "BOOTSTRAP decrement (last bucket)" 230 return $ return () -- dput XRefresh "BOOTSTRAP decrement (last bucket)"
231 cnt <- readTVar bootstrapCountdown 231 cnt <- readTVar bootstrapCountdown
232 if (cnt == Just 0) 232 if (cnt == Just 0)
233 then do 233 then do
234 -- Boostrap finished! 234 -- Boostrap finished!
235 writeTVar bootstrapMode False 235 writeTVar bootstrapMode False
236 writeTVar bootstrapCountdown Nothing 236 writeTVar bootstrapCountdown Nothing
237 return $ do action ; hPutStrLn stderr $ "BOOTSTRAP complete (" ++ show (R.shape tbl) ++ ")." 237 return $ do action ; dput XRefresh $ "BOOTSTRAP complete (" ++ show (R.shape tbl) ++ ")."
238 else return $ do action ; hPutStrLn stderr $ "BOOTSTRAP progress " ++ show (num,R.shape tbl,cnt) 238 else return $ do action ; dput XRefresh $ "BOOTSTRAP progress " ++ show (num,R.shape tbl,cnt)
239 239
240refreshBucket :: (Show nid, Ord ni, Ord nid, Hashable nid, Hashable ni) => 240refreshBucket :: (Show nid, Ord ni, Ord nid, Hashable nid, Hashable ni) =>
241 BucketRefresher nid ni -> Int -> IO Int 241 BucketRefresher nid ni -> Int -> IO Int
@@ -254,7 +254,7 @@ refreshBucket r@BucketRefresher{ refreshSearch = sch
254 fin <- atomically $ newTVar False 254 fin <- atomically $ newTVar False
255 resultCounter <- atomically $ newTVar Set.empty 255 resultCounter <- atomically $ newTVar Set.empty
256 256
257 hPutStrLn stderr $ "Start refresh " ++ show (n,sample) 257 dput XRefresh $ "Start refresh " ++ show (n,sample)
258 258
259 -- Set 15 minute timeout in order to avoid overlapping refreshes. 259 -- Set 15 minute timeout in order to avoid overlapping refreshes.
260 s <- search sch tbl sample $ if n+1 == R.defaultBucketCount 260 s <- search sch tbl sample $ if n+1 == R.defaultBucketCount
@@ -289,9 +289,9 @@ restartBootstrap r@BucketRefresher{ bootstrapMode, bootstrapCountdown } = do
289 writeTVar bootstrapMode True 289 writeTVar bootstrapMode True
290 writeTVar bootstrapCountdown Nothing 290 writeTVar bootstrapCountdown Nothing
291 if not unchanged then return $ do 291 if not unchanged then return $ do
292 hPutStrLn stderr "BOOTSTRAP entered bootstrap mode" 292 dput XRefresh "BOOTSTRAP entered bootstrap mode"
293 refreshLastBucket r 293 refreshLastBucket r
294 else return $ hPutStrLn stderr "BOOTSTRAP already bootstrapping" 294 else return $ dput XRefresh "BOOTSTRAP already bootstrapping"
295 295
296bootstrap :: (Ord ni, Ord nid, Hashable nid, Hashable ni, Foldable t, Foldable t1, Show nid) => 296bootstrap :: (Ord ni, Ord nid, Hashable nid, Hashable ni, Foldable t, Foldable t1, Show nid) =>
297 BucketRefresher nid ni 297 BucketRefresher nid ni
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 4e697109..3ee6d945 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -37,6 +37,7 @@ import System.Endian
37import System.IO 37import System.IO
38import System.IO.Error 38import System.IO.Error
39import System.Timeout 39import System.Timeout
40import DPut
40 41
41-- | Three methods are required to implement a datagram based query\/response protocol. 42-- | Three methods are required to implement a datagram based query\/response protocol.
42data Transport err addr x = Transport 43data Transport err addr x = Transport
@@ -426,6 +427,16 @@ ignoreErrors = ErrorReporter
426 , reportTimeout = \_ _ _ -> return () 427 , reportTimeout = \_ _ _ -> return ()
427 } 428 }
428 429
430logErrors :: ( Show addr
431 , Show meth
432 ) => ErrorReporter addr x meth tid String
433logErrors = ErrorReporter
434 { reportParseError = \err -> dput XMisc err
435 , reportMissingHandler = \meth addr x -> dput XMisc $ show addr ++ " --> Missing handler ("++show meth++")"
436 , reportUnknown = \addr x err -> dput XMisc $ show addr ++ " --> " ++ err
437 , reportTimeout = \meth tid addr -> dput XMisc $ show addr ++ " --> Timeout ("++show meth++")"
438 }
439
429printErrors :: ( Show addr 440printErrors :: ( Show addr
430 , Show meth 441 , Show meth
431 ) => Handle -> ErrorReporter addr x meth tid String 442 ) => Handle -> ErrorReporter addr x meth tid String
@@ -550,9 +561,9 @@ udpTransport' bind_address = do
550 (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do 561 (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do
551 let host4 = toBE32 raw4 562 let host4 = toBE32 raw4
552 -- Change 4mapped6 to ordinary IPv4. 563 -- Change 4mapped6 to ordinary IPv4.
553 -- hPutStrLn stderr $ "4mapped6 -> "++show (SockAddrInet port host4) 564 -- dput XMisc $ "4mapped6 -> "++show (SockAddrInet port host4)
554 saferSendTo sock bs (SockAddrInet port host4) 565 saferSendTo sock bs (SockAddrInet port host4)
555 addr@(SockAddrInet6 {}) -> \bs -> hPutStrLn stderr ("Discarding packet to "++show addr) 566 addr@(SockAddrInet6 {}) -> \bs -> dput XMisc ("Discarding packet to "++show addr)
556 addr4 -> \bs -> saferSendTo sock bs addr4 567 addr4 -> \bs -> saferSendTo sock bs addr4
557 _ -> \addr bs -> saferSendTo sock bs addr 568 _ -> \addr bs -> saferSendTo sock bs addr
558 , closeTransport = close sock 569 , closeTransport = close sock
diff --git a/src/Network/StreamServer.hs b/src/Network/StreamServer.hs
index 6a36ed00..01680b77 100644
--- a/src/Network/StreamServer.hs
+++ b/src/Network/StreamServer.hs
@@ -57,6 +57,7 @@ import System.IO (Handle)
57import Control.Concurrent.MVar (newMVar) 57import Control.Concurrent.MVar (newMVar)
58 58
59import Network.SocketLike 59import Network.SocketLike
60import DPut
60 61
61data ServerHandle = ServerHandle Socket (Weak ThreadId) 62data ServerHandle = ServerHandle Socket (Weak ThreadId)
62 63
@@ -89,7 +90,7 @@ bshow e = show e
89-- | Send a string to stderr. Not exported. Default 'serverWarn' when 90-- | Send a string to stderr. Not exported. Default 'serverWarn' when
90-- 'withSession' is used to configure the server. 91-- 'withSession' is used to configure the server.
91warnStderr :: String -> IO () 92warnStderr :: String -> IO ()
92warnStderr str = hPutStrLn stderr str >> hFlush stderr 93warnStderr str = dput XMisc str >> hFlush stderr
93 94
94data ServerConfig = ServerConfig 95data ServerConfig = ServerConfig
95 { serverWarn :: String -> IO () 96 { serverWarn :: String -> IO ()
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index a13a4f10..efddc2a0 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -141,9 +141,9 @@ newCrypto = do
141 noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew 141 noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew
142 cookieKeys <- atomically $ newTVar [] 142 cookieKeys <- atomically $ newTVar []
143 cache <- newSecretsCache 143 cache <- newSecretsCache
144 hPutStrLn stderr $ "secret(tox) = " ++ DHT.showHex secret 144 dput XNetCrypto $ "secret(tox) = " ++ DHT.showHex secret
145 hPutStrLn stderr $ "public(tox) = " ++ DHT.showHex pubkey 145 dput XNetCrypto $ "public(tox) = " ++ DHT.showHex pubkey
146 hPutStrLn stderr $ "symmetric(tox) = " ++ DHT.showHex symkey 146 dput XNetCrypto $ "symmetric(tox) = " ++ DHT.showHex symkey
147 return TransportCrypto 147 return TransportCrypto
148 { transportSecret = secret 148 { transportSecret = secret
149 , transportPublic = pubkey 149 , transportPublic = pubkey
@@ -233,7 +233,7 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
233 , lookupHandler = handlers -- var 233 , lookupHandler = handlers -- var
234 , tableMethods = modifytbl tbl 234 , tableMethods = modifytbl tbl
235 } 235 }
236 eprinter = printErrors stderr 236 eprinter = logErrors -- printErrors stderr
237 mkclient (tbl,var) handlers = 237 mkclient (tbl,var) handlers =
238 let client = Client 238 let client = Client
239 { clientNet = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net 239 { clientNet = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net
@@ -277,7 +277,7 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do
277 mbContactsVar <- fmap contacts . HashMap.lookup mykeyAsId <$> atomically (readTVar (accounts (toxContactInfo tox))) 277 mbContactsVar <- fmap contacts . HashMap.lookup mykeyAsId <$> atomically (readTVar (accounts (toxContactInfo tox)))
278 case mbContactsVar of 278 case mbContactsVar of
279 Nothing -> do 279 Nothing -> do
280 hPutStrLn stderr ("netCrypto: (" ++ show mykeyAsId ++") accounts lookup failed.") 280 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") accounts lookup failed.")
281 return [] 281 return []
282 282
283 Just contactsVar -> do 283 Just contactsVar -> do
@@ -292,13 +292,13 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do
292 return (kp,sa,fr,cp) 292 return (kp,sa,fr,cp)
293 case tup of 293 case tup of
294 (Nothing,Nothing,Nothing,Nothing) -> do 294 (Nothing,Nothing,Nothing,Nothing) -> do
295 hPutStrLn stderr ("netCrypto: (" ++ show mykeyAsId ++") friend not found (" ++ show theirkeyAsId ++ ").") 295 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") friend not found (" ++ show theirkeyAsId ++ ").")
296 return [] 296 return []
297 (mbKeyPkt,Nothing,mbFR,mbPolicy) -> do 297 (mbKeyPkt,Nothing,mbFR,mbPolicy) -> do
298 hPutStrLn stderr ("netCrypto: (" ++ show mykeyAsId ++") no SockAddr for friend (" ++ show theirkeyAsId ++ "). TODO: search their node?") 298 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") no SockAddr for friend (" ++ show theirkeyAsId ++ "). TODO: search their node?")
299 return [] 299 return []
300 (Nothing,_,_,_) -> do 300 (Nothing,_,_,_) -> do
301 hPutStrLn stderr ("netCrypto: (" ++ show mykeyAsId ++") no DHT-key for friend (" ++ show theirkeyAsId ++ "). TODO: what?") 301 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") no DHT-key for friend (" ++ show theirkeyAsId ++ "). TODO: what?")
302 return [] 302 return []
303 (Just (stamp_theirDhtKey,keyPkt),Just (stamp_saddr,saddr),mbFR,mbPolicy) 303 (Just (stamp_theirDhtKey,keyPkt),Just (stamp_saddr,saddr),mbFR,mbPolicy)
304 | theirDhtKey <- DHT.dhtpk keyPkt -> do 304 | theirDhtKey <- DHT.dhtpk keyPkt -> do
@@ -310,7 +310,7 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do
310 Just sessions | matchedSessions <- filter (sessionUsesIdentity (toPublic myseckey)) sessions 310 Just sessions | matchedSessions <- filter (sessionUsesIdentity (toPublic myseckey)) sessions
311 , not (null matchedSessions) 311 , not (null matchedSessions)
312 -> do 312 -> do
313 hPutStrLn stderr ("netCrypto: Already have a session for " ++ show mykeyAsId ++ "<-->" ++ show theirkeyAsId) 313 dput XNetCrypto ("netCrypto: Already have a session for " ++ show mykeyAsId ++ "<-->" ++ show theirkeyAsId)
314 return matchedSessions 314 return matchedSessions
315 -- if not, send handshake, this is separate session 315 -- if not, send handshake, this is separate session
316 _ -> do 316 _ -> do
@@ -319,16 +319,16 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do
319 let crypto = toxCryptoKeys tox 319 let crypto = toxCryptoKeys tox
320 client = toxDHT tox 320 client = toxDHT tox
321 case nodeInfo (key2id theirDhtKey) saddr of 321 case nodeInfo (key2id theirDhtKey) saddr of
322 Left e -> hPutStrLn stderr ("netCrypto: nodeInfo fail... " ++ e) >> return [] 322 Left e -> dput XNetCrypto ("netCrypto: nodeInfo fail... " ++ e) >> return []
323 Right ni -> do 323 Right ni -> do
324 mbCookie <- DHT.cookieRequest crypto client (toPublic myseckey) ni 324 mbCookie <- DHT.cookieRequest crypto client (toPublic myseckey) ni
325 case mbCookie of 325 case mbCookie of
326 Nothing -> do 326 Nothing -> do
327 hPutStrLn stderr ("netCrypto: (" ++ show mykeyAsId ++") <--> (" ++ show theirkeyAsId ++ ").") 327 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") <--> (" ++ show theirkeyAsId ++ ").")
328 hPutStrLn stderr ("netCrypto: CookieRequest failed. TODO: dhtpkNodes thingy") 328 dput XNetCrypto ("netCrypto: CookieRequest failed. TODO: dhtpkNodes thingy")
329 return [] 329 return []
330 Just cookie -> do 330 Just cookie -> do
331 hPutStrLn stderr "Have cookie, creating handshake packet..." 331 dput XNetCrypto "Have cookie, creating handshake packet..."
332 let hp = HParam { hpOtherCookie = cookie 332 let hp = HParam { hpOtherCookie = cookie
333 , hpMySecretKey = myseckey 333 , hpMySecretKey = myseckey
334 , hpCookieRemotePubkey = theirpubkey 334 , hpCookieRemotePubkey = theirpubkey
@@ -349,12 +349,12 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do
349 delay = (millisecs * 5 `div` 4) 349 delay = (millisecs * 5 `div` 4)
350 if secnum < 20000000 350 if secnum < 20000000
351 then do 351 then do
352 hPutStrLn stderr $ "sent handshake, now delaying " ++ show (secnum * 1.25) ++ " second(s).." 352 dput XNetCrypto $ "sent handshake, now delaying " ++ show (secnum * 1.25) ++ " second(s).."
353 -- threadDelay delay 353 -- threadDelay delay
354 -- Commenting loop for simpler debugging 354 -- Commenting loop for simpler debugging
355 return [] -- netCryptoWithBackoff delay tox myseckey theirpubkey -- hopefully it will find an active session this time. 355 return [] -- netCryptoWithBackoff delay tox myseckey theirpubkey -- hopefully it will find an active session this time.
356 else do 356 else do
357 hPutStrLn stderr "Unable to establish session..." 357 dput XNetCrypto "Unable to establish session..."
358 return [] 358 return []
359 359
360-- | Create a DHTPublicKey packet to send to a remote contact. 360-- | Create a DHTPublicKey packet to send to a remote contact.
@@ -387,12 +387,12 @@ addVerbosity tr =
387 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do 387 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
388 forM_ m $ mapM_ $ \(msg,addr) -> do 388 forM_ m $ mapM_ $ \(msg,addr) -> do
389 when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do 389 when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do
390 mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " --> " ++ x)) 390 mapM_ (\x -> dput XMisc ( (show addr) ++ " --> " ++ x))
391 $ xxd 0 msg 391 $ xxd 0 msg
392 kont m 392 kont m
393 , sendMessage = \addr msg -> do 393 , sendMessage = \addr msg -> do
394 when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do 394 when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do
395 mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " <-- " ++ x)) 395 mapM_ (\x -> dput XMisc ( (show addr) ++ " <-- " ++ x))
396 $ xxd 0 msg 396 $ xxd 0 msg
397 sendMessage tr addr msg 397 sendMessage tr addr msg
398 } 398 }
@@ -437,15 +437,15 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
437 -- patch in newly allocated roster state. 437 -- patch in newly allocated roster state.
438 crypto = crypto1 { userKeys = myKeyPairs roster } 438 crypto = crypto1 { userKeys = myKeyPairs roster }
439 forM_ suppliedDHTKey $ \k -> do 439 forM_ suppliedDHTKey $ \k -> do
440 maybe (hPutStrLn stderr "failed to encode suppliedDHTKey") 440 maybe (dput XMisc "failed to encode suppliedDHTKey")
441 (C8.hPutStrLn stderr . C8.append "Using suppliedDHTKey: ") 441 (dputB XMisc . C8.append "Using suppliedDHTKey: ")
442 $ encodeSecret k 442 $ encodeSecret k
443 443
444 drg <- drgNew 444 drg <- drgNew
445 let lookupClose _ = return Nothing 445 let lookupClose _ = return Nothing
446 446
447 mkrouting <- DHT.newRouting addr crypto updateIP updateIP 447 mkrouting <- DHT.newRouting addr crypto updateIP updateIP
448 let ignoreErrors _ = return () -- Set this to (hPutStrLn stderr) to debug onion route building. 448 let ignoreErrors _ = return () -- Set this to (dput XMisc) to debug onion route building.
449 orouter <- newOnionRouter ignoreErrors 449 orouter <- newOnionRouter ignoreErrors
450 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp 450 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp
451 451
@@ -493,8 +493,8 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
493 { toxDHT = dhtclient 493 { toxDHT = dhtclient
494 , toxOnion = onionclient 494 , toxOnion = onionclient
495 , toxToRoute = onInbound (updateContactInfo roster) dtacrypt 495 , toxToRoute = onInbound (updateContactInfo roster) dtacrypt
496 , toxCrypto = addHandler (hPutStrLn stderr) (sessionPacketH sessionsState) cryptonet 496 , toxCrypto = addHandler (dput XMisc) (sessionPacketH sessionsState) cryptonet
497 , toxHandshakes = addHandler (hPutStrLn stderr) (handshakeH sessionsState) handshakes 497 , toxHandshakes = addHandler (dput XMisc) (handshakeH sessionsState) handshakes
498 , toxCryptoSessions = sessionsState 498 , toxCryptoSessions = sessionsState
499 , toxCryptoKeys = crypto 499 , toxCryptoKeys = crypto
500 , toxRouting = mkrouting dhtclient 500 , toxRouting = mkrouting dhtclient
diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs
index 64ea861b..5135813a 100644
--- a/src/Network/Tox/ContactInfo.hs
+++ b/src/Network/Tox/ContactInfo.hs
@@ -18,6 +18,7 @@ import Network.Tox.DHT.Transport as DHT
18import Network.Tox.NodeId (id2key) 18import Network.Tox.NodeId (id2key)
19import Network.Tox.Onion.Transport as Onion 19import Network.Tox.Onion.Transport as Onion
20import System.IO 20import System.IO
21import DPut
21 22
22newtype ContactInfo extra = ContactInfo 23newtype ContactInfo extra = ContactInfo
23 -- | Map our toxid public key to an Account record. 24 -- | Map our toxid public key to an Account record.
@@ -55,7 +56,7 @@ myKeyPairs (ContactInfo accounts) = do
55 56
56updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO () 57updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
57updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do 58updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
58 hPutStrLn stderr "updateContactInfo!!!" 59 dput XMisc "updateContactInfo!!!"
59 now <- getPOSIXTime 60 now <- getPOSIXTime
60 atomically $ do 61 atomically $ do
61 as <- readTVar (accounts roster) 62 as <- readTVar (accounts roster)
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
index 43169fa0..58a29c3e 100644
--- a/src/Network/Tox/DHT/Handlers.hs
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -404,9 +404,9 @@ unwrapNodes (SendNodes ns) = (ns,ns,Just ())
404 404
405getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) 405getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
406getNodes client cbvar nid addr = do 406getNodes client cbvar nid addr = do
407 -- hPutStrLn stderr $ show addr ++ " <-- getnodes " ++ show nid 407 -- dput XMisc $ show addr ++ " <-- getnodes " ++ show nid
408 reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr 408 reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
409 -- hPutStrLn stderr $ show addr ++ " -sendnodes-> " ++ show reply 409 -- dput XMisc $ show addr ++ " -sendnodes-> " ++ show reply
410 forM_ (join reply) $ \(SendNodes ns) -> 410 forM_ (join reply) $ \(SendNodes ns) ->
411 forM_ ns $ \n -> do 411 forM_ ns $ \n -> do
412 now <- getPOSIXTime 412 now <- getPOSIXTime
@@ -430,13 +430,13 @@ updateRouting client routing orouter naddr msg
430 case prefer4or6 naddr Nothing of 430 case prefer4or6 naddr Nothing of
431 Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing) 431 Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing)
432 Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing) 432 Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing)
433 Want_Both -> do hPutStrLn stderr "BUG:unreachable" 433 Want_Both -> do dput XMisc "BUG:unreachable"
434 error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__ 434 error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
435 435
436updateTable :: Client -> NodeInfo -> OnionRouter -> TriadCommittee NodeId SockAddr -> BucketRefresher NodeId NodeInfo -> IO () 436updateTable :: Client -> NodeInfo -> OnionRouter -> TriadCommittee NodeId SockAddr -> BucketRefresher NodeId NodeInfo -> IO ()
437updateTable client naddr orouter committee refresher = do 437updateTable client naddr orouter committee refresher = do
438 self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher) 438 self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
439 -- hPutStrLn stderr $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr) 439 -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr)
440 when (self /= naddr) $ do 440 when (self /= naddr) $ do
441 -- TODO: IP address vote? 441 -- TODO: IP address vote?
442 insertNode (toxKademlia client committee orouter refresher) naddr 442 insertNode (toxKademlia client committee orouter refresher) naddr
@@ -455,7 +455,7 @@ toxKademlia client committee orouter refresher
455 return $ do 455 return $ do
456 io1 >> io2 456 io1 >> io2
457 {- 457 {-
458 hPutStrLn stderr $ unwords 458 dput XMisc $ unwords
459 [ show (transitionedTo tr) 459 [ show (transitionedTo tr)
460 , show (transitioningNode tr) 460 , show (transitioningNode tr)
461 ] 461 ]
@@ -467,7 +467,7 @@ transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeI
467transitionCommittee committee (RoutingTransition ni Stranger) = do 467transitionCommittee committee (RoutingTransition ni Stranger) = do
468 delVote committee (nodeId ni) 468 delVote committee (nodeId ni)
469 return $ do 469 return $ do
470 -- hPutStrLn stderr $ "delVote "++show (nodeId ni) 470 -- dput XMisc $ "delVote "++show (nodeId ni)
471 return () 471 return ()
472transitionCommittee committee _ = return $ return () 472transitionCommittee committee _ = return $ return ()
473 473
@@ -500,7 +500,7 @@ isDHTRequest _ _ = Left "Bad dht relay request"
500 500
501dhtRequestH :: NodeInfo -> DHTRequest -> IO () 501dhtRequestH :: NodeInfo -> DHTRequest -> IO ()
502dhtRequestH ni req = do 502dhtRequestH ni req = do
503 hPutStrLn stderr $ "Unhandled DHT Request: " ++ show req 503 dput XMisc $ "Unhandled DHT Request: " ++ show req
504 504
505handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler 505handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler
506handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH 506handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 8a66f2b2..70714465 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -246,7 +246,7 @@ encodeOnionAddr crypto _ (msg,OnionToOwner ni p) =
246 , nodeAddr ni ) 246 , nodeAddr ni )
247encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do 247encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do
248 encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) 248 encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) )
249 -- hPutStrLn stderr $ "ONION encode missing routeid" 249 -- dput XMisc $ "ONION encode missing routeid"
250 -- return Nothing 250 -- return Nothing
251encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do 251encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do
252 let go route = do 252 let go route = do
@@ -255,8 +255,8 @@ encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do
255 , nodeAddr $ routeNodeA route) 255 , nodeAddr $ routeNodeA route)
256 mapM' f x = do 256 mapM' f x = do
257 let _ = x :: Maybe OnionRoute 257 let _ = x :: Maybe OnionRoute
258 -- hPutStrLn stderr $ "ONION encode sending to " ++ show ni 258 -- dput XMisc $ "ONION encode sending to " ++ show ni
259 -- hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (fmap (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x) 259 -- dput XMisc $ "ONION encode getRoute -> " ++ show (fmap (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x)
260 mapM f x -- ONION encode getRoute -> Nothing 260 mapM f x -- ONION encode getRoute -> Nothing
261 getRoute ni rid >>= mapM' go 261 getRoute ni rid >>= mapM' go
262 262
@@ -525,7 +525,7 @@ handleOnionResponse proxy crypto saddr udp kont (OnionResponse path msg) = do
525 Left e -> do 525 Left e -> do
526 -- todo report encryption error 526 -- todo report encryption error
527 let n = peanoVal path 527 let n = peanoVal path
528 hPutStrLn stderr $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e] 528 dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e]
529 kont 529 kont
530 Right (Addressed dst path') -> do 530 Right (Addressed dst path') -> do
531 sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg) 531 sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg)
@@ -897,9 +897,9 @@ parseDataToRoute crypto (OnionToRouteResponse dta, od) = do
897 r = either (const $ Right (OnionToRouteResponse dta,od)) Left e 897 r = either (const $ Right (OnionToRouteResponse dta,od)) Left e
898 -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail 898 -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail
899 case e of 899 case e of
900 Left _ -> hPutStrLn stderr $ "Failed keys: " ++ show (map (key2id . snd) ks) 900 Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks)
901 Right _ -> return () 901 Right _ -> return ()
902 hPutStrLn stderr $ unlines 902 dput XMisc $ unlines
903 [ "parseDataToRoute " ++ either id (const "Right") e 903 [ "parseDataToRoute " ++ either id (const "Right") e
904 , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner 904 , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner
905 , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter 905 , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter
diff --git a/src/Network/UPNP.hs b/src/Network/UPNP.hs
index ed6b4777..f053369f 100644
--- a/src/Network/UPNP.hs
+++ b/src/Network/UPNP.hs
@@ -6,6 +6,7 @@ import Network.Socket
6import System.Directory 6import System.Directory
7import System.IO 7import System.IO
8import System.Process as Process 8import System.Process as Process
9import DPut
9 10
10protocols :: SocketType -> [String] 11protocols :: SocketType -> [String]
11protocols Stream = ["tcp"] 12protocols Stream = ["tcp"]
@@ -35,5 +36,5 @@ requestPorts description binds = do
35 phandle <- spawnProcess upnpc $ "-e": description : "-r" : requests 36 phandle <- spawnProcess upnpc $ "-e": description : "-r" : requests
36 return $ Just phandle 37 return $ Just phandle
37 else do 38 else do
38 hPutStrLn stderr $ "Warning: unable to find miniupnpc client at "++upnpc++"." 39 dput XMisc $ "Warning: unable to find miniupnpc client at "++upnpc++"."
39 bail 40 bail
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 07:38:15 +0000