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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ViewPatterns #-}
module ToxToXMPP where
import Control.Monad
import Crypto.Tox
import Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Function
import Data.Monoid
import qualified Data.Text as T
;import Data.Text (Text)
import Data.Text.Encoding as T
import Data.Word
import Data.XML.Types as XML
import EventUtil
import Network.Address
import Network.Tox.Crypto.Transport as Tox hiding (UserStatus (..))
import Network.Tox.NodeId
import Util (unsplitJID)
import XMPPServer as XMPP
available :: StanzaType
available = PresenceStatus { presenceShow = Available
, presencePriority = Nothing
, presenceStatus = []
, presenceWhiteList = []
}
xmppHostname :: PublicKey -> Text
xmppHostname k = T.pack $ show (key2id k) ++ ".tox"
toxUserStatus :: Word8 -> JabberShow
toxUserStatus 0 = Available
toxUserStatus 1 = Away
toxUserStatus 2 = DoNotDisturb
toxUserStatus _ = Away -- Default, shouldn't occur.
toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> ConduitM Tox.CryptoMessage XML.Event m ()
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))
let
statelessMessages = \case
UpToN MESSAGE bs ->
xmppInstantMessage "jabber:server" im_from im_to [] (T.decodeUtf8 bs)
TwoByte TYPING st -> xmppTyping "jabber:server" im_from im_to st
UpToN NICKNAME bs ->
xmppInstantMessage "jabber:server" im_from im_to
[ attr "style" "font-weight:bold; color:red" ]
("NICKNAME(todo) " <> T.decodeUtf8 bs)
toxmsg | msgID toxmsg == PacketRequest -> return ()
toxmsg -> do
xmppInstantMessage "jabber:server" im_from im_to
[ attr "style" "font-weight:bold; color:red" ]
(T.pack $ "Unhandled message: " ++ show (msgID toxmsg))
flip fix available $ \loop status -> do
let go (TwoByte USERSTATUS st) = do
let status' = status { presenceShow = toxUserStatus st }
xmppPresence "jabber:server" im_from status'
loop status'
go (UpToN STATUSMESSAGE bs) = do
let status' = status { presenceStatus = [("",T.decodeUtf8 bs)] }
xmppPresence "jabber:server" im_from status'
loop status'
go (OneByte ONLINE) = do
xmppPresence "jabber:server" im_from status
loop status
go x = do
statelessMessages x
loop status
await >>= mapM_ go
xmppPresence :: Monad m => Text -> Maybe Text -> StanzaType -> ConduitM i XML.Event m ()
xmppPresence namespace mjid p = do
let ns n = n { nameNamespace = Just namespace }
setFrom = maybe id
(\jid -> (attr "from" jid :) )
mjid
typ Offline = [attr "type" "unavailable"]
typ _ = []
shw ExtendedAway = ["xa"]
shw Chatty = ["chat"]
shw Away = ["away"]
shw DoNotDisturb = ["dnd"]
shw _ = []
jabberShow stat =
[ EventBeginElement "{jabber:client}show" []
, EventContent (ContentText stat)
, EventEndElement "{jabber:client}show" ]
C.yield $ EventBeginElement (ns "presence") (setFrom $ typ $ presenceShow p)
mapM_ C.yield $ shw (presenceShow p) >>= jabberShow
forM_ (presencePriority p) $ \prio -> do
C.yield $ EventBeginElement (ns "priority") []
C.yield $ EventContent $ ContentText (T.pack $ show prio)
C.yield $ EventEndElement (ns "priority")
forM_ (presenceStatus p) $ \(lang,txt) -> do
let atts | T.null lang = []
| otherwise = [ ("xml:lang", [ContentText lang]) ]
C.yield $ EventBeginElement (ns "status") atts
C.yield $ EventContent $ ContentText txt
C.yield $ EventEndElement (ns "status")
C.yield $ EventEndElement (ns "presence")
xmppTyping :: Monad m => Text
-> Maybe Text
-> Maybe Text
-> Word8
-> ConduitM i XML.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 XML.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")
|
