blob: 8b2544d7d99bc0c7cf4456fa81a77093ad589cc4 (
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
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ViewPatterns #-}
module ToxToXMPP where
import Crypto.Tox
import Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Monoid
import qualified Data.Text as T
;import Data.Text (Text)
import Data.Word
import Data.Text.Encoding as T
import Data.XML.Types as XML
import EventUtil
import Network.Address
import Network.Tox.Crypto.Transport as Tox
import Network.Tox.NodeId
import Util (unsplitJID)
import XMPPServer as XMPP
xmppHostname :: PublicKey -> Text
xmppHostname k = T.pack $ show (key2id k) ++ ".tox"
toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> Conduit Tox.CryptoMessage m XML.Event
toxToXmpp laddr me theirhost = do
CL.sourceList $ XMPP.greet' "jabber:server" theirhost
let me_u = Nothing
me_h = xmppHostname me
im_from = (Just $ unsplitJID (Nothing, theirhost, Nothing)) -- /from/
im_to = (Just $ unsplitJID
( me_u
-- /to/ should match local address of this node.
, me_h
, Nothing))
awaitForever $ \case
UpToN { msgID = MESSAGE
, msgBytes = bs }
-> do
xmppInstantMessage "jabber:server" im_from im_to [] (T.decodeUtf8 bs)
TwoByte TYPING st -> xmppTyping "jabber:server" im_from im_to st
toxmsg | msgID toxmsg == PacketRequest -> return ()
toxmsg -> do
xmppInstantMessage "jabber:server"
im_from
im_to -- /to/ should match local address of this node.
[ attr "style" "font-weight:bold; color:red" ]
(T.pack $ show $ msgID toxmsg)
xmppTyping :: Monad m => Text
-> Maybe Text
-> Maybe Text
-> Word8
-> ConduitM i Event m ()
xmppTyping namespace mfrom mto x =
let ns n = n { nameNamespace = Just namespace }
st = case x of
0 -> "{http://jabber.org/protocol/chatstates}active"
1 -> "{http://jabber.org/protocol/chatstates}composing"
-- tox-core supports only 0 and 1
_ -> "{http://jabber.org/protocol/chatstates}paused"
in mapM_ C.yield
[ EventBeginElement (ns "message")
( maybe id (\t->(attr "from" t:)) mfrom
$ maybe id (\t->(attr "to" t:)) mto
$ [attr "type" "chat" ] )
, EventBeginElement st []
, EventEndElement st
, EventEndElement (ns "message")
]
xmppInstantMessage :: Monad m => Text
-> Maybe Text
-> Maybe Text
-> [(Name, [Content])]
-> Text
-> ConduitM i Event m ()
xmppInstantMessage namespace mfrom mto style text = do
let ns n = n { nameNamespace = Just namespace }
C.yield $ EventBeginElement (ns "message")
( maybe id (\t->(attr "from" t:)) mfrom
$ maybe id (\t->(attr "to" t:)) mto
$ [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" style
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")
|
