blob: edbf35ca72715b5081823c07142155c104aa8008 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module ToxToXMPP where
import Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.XML.Types as XML
import Network.Tox.Crypto.Transport as Tox
import XMPPServer as XMPP
import EventUtil
import ClientState
import Control.Concurrent.STM
import Control.Monad
import Crypto.Tox
import Data.Bits
import Data.Function
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
;import Data.Text (Text)
import Data.Word
import Network.Tox
import Network.Tox.ContactInfo
import Network.Tox.DHT.Transport (FriendRequest (..))
import Network.Tox.NodeId
import Network.Tox.Onion.Transport (OnionData (..))
import Presence
#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
import GHC.Conc (labelThread)
#endif
xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage
xmppToTox = do
awaitForever (\_ -> return ())
toxToXmpp :: Monad m => Text -> Conduit Tox.CryptoMessage m XML.Event
toxToXmpp toxhost = do
CL.sourceList $ XMPP.greet' "jabber:server" toxhost
awaitForever $ \toxmsg -> do
xmppInstantMessage "jabber:server" (Just toxhost) (T.pack $ show $ msgID toxmsg)
xmppInstantMessage :: Monad m => Text -> Maybe Text -> Text -> ConduitM i Event m ()
xmppInstantMessage namespace mfrom text = do
let ns n = n { nameNamespace = Just namespace }
C.yield $ EventBeginElement (ns "message")
((maybe id (\t->(attr "from" t:)) mfrom)
[attr "type" "normal" ])
C.yield $ EventBeginElement (ns "body") []
C.yield $ EventContent $ ContentText text
C.yield $ EventEndElement (ns "body")
C.yield $ EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" []
C.yield $ EventBeginElement "{http://www.w3.org/1999/xhtml}body" []
C.yield $ EventBeginElement "{http://www.w3.org/1999/xhtml}p"
[ attr "style" "font-weight:bold; color:red" ]
C.yield $ EventContent $ ContentText text
C.yield $ EventEndElement "{http://www.w3.org/1999/xhtml}p"
C.yield $ EventEndElement "{http://www.w3.org/1999/xhtml}body"
C.yield $ EventEndElement "{http://jabber.org/protocol/xhtml-im}html"
C.yield $ EventEndElement (ns "message")
key2jid :: Word32 -> PublicKey -> Text
key2jid nospam key = T.pack $ show $ NoSpamId nsp key
where
nsp = NoSpam nospam (Just sum)
sum = nlo `xor` nhi `xor` xorsum key
nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16
nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16
dispatch :: Account -> PresenceState -> ContactEvent -> IO ()
dispatch acnt st (AddrChange theirkey saddr) = return () -- todo
dispatch acnt st (PolicyChange theirkey policy ) = return () -- todo
dispatch acnt st (OnionRouted theirkey (OnionDHTPublicKey pkey)) = return () -- todo
dispatch acnt st (OnionRouted theirkey (OnionFriendRequest fr) ) = do
k2c <- atomically $ do
refs <- readTVar (clientRefs acnt)
k2c <- Map.filterWithKey (\k _ -> k `Set.member` refs) <$> readTVar (keyToChan st)
clients <- readTVar (clients st)
return $ Map.intersectionWith (,) k2c clients
-- TODO: Below we're using a hard coded default as their jabber user id.
-- This isn't the right thing, but we don't know their user-id. Perhaps
-- there should be a way to parse it out of the friend request text. Maybe
-- after a zero-termination, or as visible text (nospam:...).
let default_nospam = 0x6a7a27fc -- big-endian base64: anon/A==
theirjid = key2jid default_nospam theirkey
forM_ k2c $ \(conn,client) -> do
self <- localJID (clientUser client) (clientProfile client) (clientResource client)
ask <- presenceSolicitation theirjid self
-- TODO Send friend-request text as an instant message or at least
-- embed it in the stanza as a <status> element.
sendModifiedStanzaToClient ask (connChan conn)
forkAccountWatcher :: Account -> Tox -> PresenceState -> IO ThreadId
forkAccountWatcher acc tox st = forkIO $ do
myThreadId >>= flip labelThread ("tox-xmpp:"
++ show (key2id $ toPublic $ userSecret acc))
(chan,contacts) <- atomically $ do
chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading.
contacts <- readTVar (contacts acc)
return (chan,contacts)
-- TODO: process information in contacts HashMap.
-- Loop endlessly until clientRefs is null.
fix $ \loop -> do
mev <- atomically $
(Just <$> readTChan chan)
`orElse` do
refs <- readTVar $ clientRefs acc
check $ Set.null refs
return Nothing
forM_ mev $ \ev -> dispatch acc st ev >> loop
|
