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
|
{-# LANGUAGE CPP #-}
module Stanza.Build where
import Control.Monad
import Control.Concurrent.STM
import Data.Maybe
import Data.Text (Text)
import Data.XML.Types as XML
#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent
import GHC.Conc (labelThread)
#endif
import EventUtil
import LockedChan
import Stanza.Types
makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
makeMessage namespace from to bod =
stanzaFromList typ
$ [ EventBeginElement (mkname namespace "message")
[ attr "from" from
, attr "to" to
]
, EventBeginElement (mkname namespace "body") []
, EventContent (ContentText bod)
, EventEndElement (mkname namespace "body")
, EventEndElement (mkname namespace "message") ]
where
typ = Message { msgThread = Nothing
, msgLangMap = [("", lsm)]
}
lsm = LangSpecificMessage
{ msgBody = Just bod
, msgSubject = Nothing }
makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
makeInformSubscription namespace from to approved =
stanzaFromList (PresenceInformSubscription approved)
$ [ EventBeginElement (mkname namespace "presence")
[ attr "from" from
, attr "to" to
, attr "type" $ if approved then "subscribed"
else "unsubscribed" ]
, EventEndElement (mkname namespace "presence")]
makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza
makePresenceStanza namespace mjid pstat = do
stanzaFromList PresenceStatus { presenceShow = pstat
, presencePriority = Nothing
, presenceStatus = []
, presenceWhiteList = []
}
$ [ EventBeginElement (mkname namespace "presence")
(setFrom $ typ pstat) ]
++ (shw pstat >>= jabberShow) ++
[ EventEndElement (mkname namespace "presence")]
where
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" ]
makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza
makeRosterUpdate tojid contact as = do
let attrs = map (uncurry attr) as
stanzaFromList Unrecognized
[ EventBeginElement "{jabber:client}iq"
[ attr "to" tojid
, attr "id" "someid"
, attr "type" "set"
]
, EventBeginElement "{jabber:iq:roster}query" []
, EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
, EventEndElement "{jabber:iq:roster}item"
, EventEndElement "{jabber:iq:roster}query"
, EventEndElement "{jabber:client}iq"
]
makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
makePong namespace mid to from =
-- Note: similar to session reply
[ EventBeginElement (mkname namespace "iq")
$(case mid of
Just c -> (("id",[ContentText c]):)
_ -> id)
[ attr "type" "result"
, attr "to" to
, attr "from" from
]
, EventEndElement (mkname namespace "iq")
]
mkname :: Text -> Text -> XML.Name
mkname namespace name = (Name name (Just namespace) Nothing)
stanzaFromList :: StanzaType -> [Event] -> IO Stanza
stanzaFromList stype reply = do
let stanzaTag = listToMaybe reply
mid = stanzaTag >>= lookupAttrib "id" . tagAttrs
mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
{-
isInternal (InternalEnableHack {}) = True
isInternal (InternalCacheId {}) = True
isInternal _ = False
-}
(donevar,replyChan,replyClsrs) <- atomically $ do
donevar <- newEmptyTMVar -- TMVar ()
replyChan <- newLockedChan
replyClsrs <- newTVar (Just [])
return (donevar,replyChan, replyClsrs)
t <- forkIO $ do
forM_ reply $ atomically . writeLChan replyChan
atomically $ do putTMVar donevar ()
writeTVar replyClsrs Nothing
labelThread t $ concat $ "stanza." : take 1 (words $ show stype)
return Stanza { stanzaType = stype
, stanzaId = mid
, stanzaTo = mto -- as-is from reply list
, stanzaFrom = mfrom -- as-is from reply list
, stanzaChan = replyChan
, stanzaClosers = replyClsrs
, stanzaInterrupt = donevar
, stanzaOrigin = LocalPeer
}
|
