summaryrefslogtreecommitdiff
path: root/ToxToXMPP.hs
blob: 1420c642ead1de18db743dadbf2f31bb0d25d9c0 (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
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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE NamedFieldPuns           #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ViewPatterns             #-}
module ToxToXMPP where

import Control.Monad
import Crypto.Tox
import Conduit                      as C
import qualified Data.Conduit.List  as CL
import Data.Dependent.Sum
import Data.Function
import Data.Functor.Identity
import Data.Maybe
import Data.Monoid
import qualified Data.Text          as T
         ;import Data.Text          (Text)
import Data.Text.Encoding           as T
import Data.Tox.Msg                 as Tox
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 :: UserStatus -> JabberShow
toxUserStatus Online   = Available
toxUserStatus Tox.Away = XMPP.Away
toxUserStatus Busy     = DoNotDisturb
toxUserStatus _        = XMPP.Away -- Default, shouldn't occur.

-- Currently unused, see note in 'toxJID'.
toJabberResource :: Int -> Maybe Text
toJabberResource addr = T.pack . show <$> Just (positive addr)
 where
    positive addr | addr < 0  = 2 * negate addr + 1
                  | otherwise = 2 * addr

toxJID :: Text -> Int -> Text
toxJID theirhost addr =
    -- unsplitJID (Nothing, theirhost, toJabberResource addr)
    --
    -- Not encoding the Tox session ID because Pidgin apparently doesn't
    -- cope well with resource IDs occuring on bare hostname JIDs.
    unsplitJID (Nothing, theirhost, Nothing)

toxToXmpp :: Monad m =>
    (Int -> Maybe Text -> Invite -> m ())
    -> SockAddr
    -> PublicKey
    -> Text
    -> ConduitM (Int,Tox.CryptoMessage) XML.Event m ()
toxToXmpp store_invite _ me theirhost = do
    CL.sourceList $ XMPP.greet' "jabber:server" theirhost
    let me_u    = Nothing
        me_h    = xmppHostname me
        im_to   = (Just $ unsplitJID
                            ( me_u
                            -- /to/ should match local address of this node.
                            , me_h
                            , Nothing))
    let
      statelessMessages addr im_from = \case

        Pkt MESSAGE :=> Identity bs ->
            xmppInstantMessage "jabber:server" im_from im_to [] bs

        Pkt TYPING :=> Identity st  -> xmppTyping "jabber:server" im_from im_to st

        Pkt NICKNAME :=> Identity bs ->
            xmppInstantMessage "jabber:server" im_from im_to
                [ attr "style" "font-weight:bold; color:red" ]
                ("NICKNAME(todo) " <> bs)

        toxmsg | msgID toxmsg == M PacketRequest -> return ()

        Pkt INVITE_GROUPCHAT :=> Identity ginv -> do
            xmppInstantMessage "jabber:server" im_from im_to
                [ attr "style" "font-weight:bold; color:red" ]
                ("INVITE(todo)" <> (T.pack $ show ginv))
            case invite ginv of
                GroupInvite {} -> do C.lift $ store_invite addr im_from ginv
                                     xmppInvite "jabber:server"  me_h (fromJust im_from) (fromJust im_to) ginv
                _              -> 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
        m <- await
        forM_ m $ \(addr,x) -> do
        let im_from = (Just $ toxJID theirhost addr)
        case x of
          Pkt USERSTATUS :=> Identity st -> do
            let status' = status { presenceShow = toxUserStatus st }
            xmppPresence "jabber:server" im_from status'
            loop status'

          Pkt STATUSMESSAGE :=> Identity bs -> do
            let status' = status { presenceStatus = [("",bs)] }
            xmppPresence "jabber:server" im_from status'
            loop status'

          Pkt ONLINE :=> _ -> do
            xmppPresence "jabber:server" im_from status
            loop status

          x -> do
            statelessMessages addr im_from x
            loop status

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 XMPP.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")

chatRoomJID me cid = T.pack (show cid) <> "@ngc." <> me

xmppInvite :: Monad m => Text -> Text -> Text -> Text -> Invite -> ConduitM i XML.Event m ()
xmppInvite namespace me them to inv =
    let ns n = n { nameNamespace = Just namespace }
    in mapM_ C.yield
        [ EventBeginElement (ns "message")
            [ attr "from" (chatRoomJID me $ inviteChatID inv)
            , attr "to" to
            ]
        ,   EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
        ,     EventBeginElement "{http://jabber.org/protocol/muc#user}invite"
                [ attr "from" them ]
        ,       EventBeginElement "{http://jabber.org/protocol/muc#user}reason" []
        ,         EventContent (ContentText $ groupName $ invite inv)
        ,       EventEndElement "{http://jabber.org/protocol/muc#user}reason"
        ,     EventEndElement "{http://jabber.org/protocol/muc#user}invite"
        ,   EventEndElement "{http://jabber.org/protocol/muc#user}x"
        , EventEndElement (ns "message")
        ]

xmppTyping :: Monad m => Text
                              -> Maybe Text
                              -> Maybe Text
                              -> Bool
                              -> ConduitM i XML.Event m ()
xmppTyping namespace mfrom mto x =
    let ns n = n { nameNamespace = Just namespace }
        st = case x of
            False -> "{http://jabber.org/protocol/chatstates}active"
            True  -> "{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")