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