summaryrefslogtreecommitdiff
path: root/Presence/Stanza/Build.hs
blob: 165524284d72948787a7a7316a307edcb31655d9 (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
{-# 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 = makeMessageEx namespace from to NormalMsg bod

makeMessageEx :: Text -> Text -> Text -> MessageType -> Text -> IO Stanza
makeMessageEx namespace from to msgtyp bod =
    stanzaFromList typ
     $ [ EventBeginElement (mkname namespace "message")
            $ addMessageType msgtyp
                [ 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)]
                  , msgType    = msgtyp
                  }
    lsm = LangSpecificMessage
            { msgBody    = Just bod
            , msgSubject = Nothing }

addMessageType ChatMsg      attrs = ("type",[ContentText "chat"]) : attrs
addMessageType GroupChatMsg attrs = ("type",[ContentText "groupchat"]) : attrs
addMessageType HeadlineMsg  attrs = ("type",[ContentText "headline"]) : attrs
addMessageType _            attrs = attrs

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 ns mjid pstat = makePresenceStanzaEx ns mjid pstat []

makePresenceStanzaEx :: Text -> Maybe Text -> JabberShow -> [XML.Event]-> IO Stanza
makePresenceStanzaEx namespace mjid pstat es = do
    stanzaFromList PresenceStatus { presenceShow = pstat
                                  , presencePriority = Nothing
                                  , presenceStatus = []
                                  , presenceWhiteList = []
                                  }
      $ [ EventBeginElement (mkname namespace "presence")
            (setFrom $ typ pstat) ]
        ++ (shw pstat >>= jabberShow) ++ es ++
        [ 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
                  }