summaryrefslogtreecommitdiff
path: root/Presence
diff options
context:
space:
mode:
Diffstat (limited to 'Presence')
-rw-r--r--Presence/Stanza/Build.hs142
-rw-r--r--Presence/Stanza/Parse.hs2
-rw-r--r--Presence/Stanza/Types.hs (renamed from Presence/Stanza/Type.hs)2
-rw-r--r--Presence/XMPPServer.hs143
4 files changed, 146 insertions, 143 deletions
diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs
new file mode 100644
index 00000000..5c4d371a
--- /dev/null
+++ b/Presence/Stanza/Build.hs
@@ -0,0 +1,142 @@
1{-# LANGUAGE CPP #-}
2module Stanza.Build where
3
4import Control.Monad
5import Control.Concurrent.STM
6import Data.Maybe
7import Data.Text (Text)
8import Data.XML.Types as XML
9
10#ifdef THREAD_DEBUG
11import Control.Concurrent.Lifted.Instrument
12#else
13import Control.Concurrent
14import GHC.Conc (labelThread)
15#endif
16
17import EventUtil
18import LockedChan
19import Stanza.Types
20
21makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
22makeMessage namespace from to bod =
23 stanzaFromList typ
24 $ [ EventBeginElement (mkname namespace "message")
25 [ attr "from" from
26 , attr "to" to
27 ]
28 , EventBeginElement (mkname namespace "body") []
29 , EventContent (ContentText bod)
30 , EventEndElement (mkname namespace "body")
31 , EventEndElement (mkname namespace "message") ]
32 where
33 typ = Message { msgThread = Nothing
34 , msgLangMap = [("", lsm)]
35 }
36 lsm = LangSpecificMessage
37 { msgBody = Just bod
38 , msgSubject = Nothing }
39
40makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
41makeInformSubscription namespace from to approved =
42 stanzaFromList (PresenceInformSubscription approved)
43 $ [ EventBeginElement (mkname namespace "presence")
44 [ attr "from" from
45 , attr "to" to
46 , attr "type" $ if approved then "subscribed"
47 else "unsubscribed" ]
48 , EventEndElement (mkname namespace "presence")]
49
50makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza
51makePresenceStanza namespace mjid pstat = do
52 stanzaFromList PresenceStatus { presenceShow = pstat
53 , presencePriority = Nothing
54 , presenceStatus = []
55 , presenceWhiteList = []
56 }
57 $ [ EventBeginElement (mkname namespace "presence")
58 (setFrom $ typ pstat) ]
59 ++ (shw pstat >>= jabberShow) ++
60 [ EventEndElement (mkname namespace "presence")]
61 where
62 setFrom = maybe id
63 (\jid -> (attr "from" jid :) )
64 mjid
65 typ Offline = [attr "type" "unavailable"]
66 typ _ = []
67 shw ExtendedAway = ["xa"]
68 shw Chatty = ["chat"]
69 shw Away = ["away"]
70 shw DoNotDisturb = ["dnd"]
71 shw _ = []
72 jabberShow stat =
73 [ EventBeginElement "{jabber:client}show" []
74 , EventContent (ContentText stat)
75 , EventEndElement "{jabber:client}show" ]
76
77makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza
78makeRosterUpdate tojid contact as = do
79 let attrs = map (uncurry attr) as
80 stanzaFromList Unrecognized
81 [ EventBeginElement "{jabber:client}iq"
82 [ attr "to" tojid
83 , attr "id" "someid"
84 , attr "type" "set"
85 ]
86 , EventBeginElement "{jabber:iq:roster}query" []
87 , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
88 , EventEndElement "{jabber:iq:roster}item"
89 , EventEndElement "{jabber:iq:roster}query"
90 , EventEndElement "{jabber:client}iq"
91 ]
92
93makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
94makePong namespace mid to from =
95 -- Note: similar to session reply
96 [ EventBeginElement (mkname namespace "iq")
97 $(case mid of
98 Just c -> (("id",[ContentText c]):)
99 _ -> id)
100 [ attr "type" "result"
101 , attr "to" to
102 , attr "from" from
103 ]
104 , EventEndElement (mkname namespace "iq")
105 ]
106
107
108mkname :: Text -> Text -> XML.Name
109mkname namespace name = (Name name (Just namespace) Nothing)
110
111
112stanzaFromList :: StanzaType -> [Event] -> IO Stanza
113stanzaFromList stype reply = do
114 let stanzaTag = listToMaybe reply
115 mid = stanzaTag >>= lookupAttrib "id" . tagAttrs
116 mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
117 mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
118 {-
119 isInternal (InternalEnableHack {}) = True
120 isInternal (InternalCacheId {}) = True
121 isInternal _ = False
122 -}
123 (donevar,replyChan,replyClsrs) <- atomically $ do
124 donevar <- newEmptyTMVar -- TMVar ()
125 replyChan <- newLockedChan
126 replyClsrs <- newTVar (Just [])
127 return (donevar,replyChan, replyClsrs)
128 t <- forkIO $ do
129 forM_ reply $ atomically . writeLChan replyChan
130 atomically $ do putTMVar donevar ()
131 writeTVar replyClsrs Nothing
132 labelThread t $ concat $ "stanza." : take 1 (words $ show stype)
133 return Stanza { stanzaType = stype
134 , stanzaId = mid
135 , stanzaTo = mto -- as-is from reply list
136 , stanzaFrom = mfrom -- as-is from reply list
137 , stanzaChan = replyChan
138 , stanzaClosers = replyClsrs
139 , stanzaInterrupt = donevar
140 , stanzaOrigin = LocalPeer
141 }
142
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
index 50e1e25b..e2a9efdd 100644
--- a/Presence/Stanza/Parse.hs
+++ b/Presence/Stanza/Parse.hs
@@ -18,7 +18,7 @@ import Control.Concurrent.STM.Util
18import ControlMaybe (handleIO_, (<&>)) 18import ControlMaybe (handleIO_, (<&>))
19import EventUtil 19import EventUtil
20import Nesting 20import Nesting
21import Stanza.Type 21import Stanza.Types
22 22
23-- | Identify an XMPP stanza based on the open-tag. 23-- | Identify an XMPP stanza based on the open-tag.
24grokStanza :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType) 24grokStanza :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
diff --git a/Presence/Stanza/Type.hs b/Presence/Stanza/Types.hs
index 1d8041a9..6b402f4d 100644
--- a/Presence/Stanza/Type.hs
+++ b/Presence/Stanza/Types.hs
@@ -1,5 +1,5 @@
1{-# LANGUAGE FlexibleInstances #-} 1{-# LANGUAGE FlexibleInstances #-}
2module Stanza.Type where 2module Stanza.Types where
3 3
4import Control.Concurrent.STM 4import Control.Concurrent.STM
5import Data.Int 5import Data.Int
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 11a27660..a102ed5a 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -102,8 +102,9 @@ import qualified System.Random
102import Data.Void (Void) 102import Data.Void (Void)
103import DPut 103import DPut
104import DebugTag 104import DebugTag
105import Stanza.Type 105import Stanza.Build
106import Stanza.Parse 106import Stanza.Parse
107import Stanza.Types
107 108
108-- peerport :: PortNumber 109-- peerport :: PortNumber
109-- peerport = 5269 110-- peerport = 5269
@@ -450,36 +451,6 @@ sendReply donevar stype reply replychan = do
450 liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing 451 liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing
451 -- liftIO $ wlog "finished reply stanza" 452 -- liftIO $ wlog "finished reply stanza"
452 453
453stanzaFromList :: StanzaType -> [Event] -> IO Stanza
454stanzaFromList stype reply = do
455 let stanzaTag = listToMaybe reply
456 mid = stanzaTag >>= lookupAttrib "id" . tagAttrs
457 mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
458 mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
459 {-
460 isInternal (InternalEnableHack {}) = True
461 isInternal (InternalCacheId {}) = True
462 isInternal _ = False
463 -}
464 (donevar,replyChan,replyClsrs) <- atomically $ do
465 donevar <- newEmptyTMVar -- TMVar ()
466 replyChan <- newLockedChan
467 replyClsrs <- newTVar (Just [])
468 return (donevar,replyChan, replyClsrs)
469 forkIO $ do
470 forM_ reply $ atomically . writeLChan replyChan
471 atomically $ do putTMVar donevar ()
472 writeTVar replyClsrs Nothing
473 return Stanza { stanzaType = stype
474 , stanzaId = mid
475 , stanzaTo = mto -- as-is from reply list
476 , stanzaFrom = mfrom -- as-is from reply list
477 , stanzaChan = replyChan
478 , stanzaClosers = replyClsrs
479 , stanzaInterrupt = donevar
480 , stanzaOrigin = LocalPeer
481 }
482
483 454
484 455
485{- 456{-
@@ -492,95 +463,6 @@ C->Unrecognized </iq>
492-} 463-}
493 464
494 465
495mkname :: Text -> Text -> XML.Name
496mkname namespace name = (Name name (Just namespace) Nothing)
497
498makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
499makeMessage namespace from to bod =
500 stanzaFromList typ
501 $ [ EventBeginElement (mkname namespace "message")
502 [ attr "from" from
503 , attr "to" to
504 ]
505 , EventBeginElement (mkname namespace "body") []
506 , EventContent (ContentText bod)
507 , EventEndElement (mkname namespace "body")
508 , EventEndElement (mkname namespace "message") ]
509 where
510 typ = Message { msgThread = Nothing
511 , msgLangMap = [("", lsm)]
512 }
513 lsm = LangSpecificMessage
514 { msgBody = Just bod
515 , msgSubject = Nothing }
516
517makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
518makeInformSubscription namespace from to approved =
519 stanzaFromList (PresenceInformSubscription approved)
520 $ [ EventBeginElement (mkname namespace "presence")
521 [ attr "from" from
522 , attr "to" to
523 , attr "type" $ if approved then "subscribed"
524 else "unsubscribed" ]
525 , EventEndElement (mkname namespace "presence")]
526
527makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza
528makePresenceStanza namespace mjid pstat = do
529 stanzaFromList PresenceStatus { presenceShow = pstat
530 , presencePriority = Nothing
531 , presenceStatus = []
532 , presenceWhiteList = []
533 }
534 $ [ EventBeginElement (mkname namespace "presence")
535 (setFrom $ typ pstat) ]
536 ++ (shw pstat >>= jabberShow) ++
537 [ EventEndElement (mkname namespace "presence")]
538 where
539 setFrom = maybe id
540 (\jid -> (attr "from" jid :) )
541 mjid
542 typ Offline = [attr "type" "unavailable"]
543 typ _ = []
544 shw ExtendedAway = ["xa"]
545 shw Chatty = ["chat"]
546 shw Away = ["away"]
547 shw DoNotDisturb = ["dnd"]
548 shw _ = []
549 jabberShow stat =
550 [ EventBeginElement "{jabber:client}show" []
551 , EventContent (ContentText stat)
552 , EventEndElement "{jabber:client}show" ]
553
554makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza
555makeRosterUpdate tojid contact as = do
556 let attrs = map (uncurry attr) as
557 stanzaFromList Unrecognized
558 [ EventBeginElement "{jabber:client}iq"
559 [ attr "to" tojid
560 , attr "id" "someid"
561 , attr "type" "set"
562 ]
563 , EventBeginElement "{jabber:iq:roster}query" []
564 , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
565 , EventEndElement "{jabber:iq:roster}item"
566 , EventEndElement "{jabber:iq:roster}query"
567 , EventEndElement "{jabber:client}iq"
568 ]
569
570makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
571makePong namespace mid to from =
572 -- Note: similar to session reply
573 [ EventBeginElement (mkname namespace "iq")
574 $(case mid of
575 Just c -> (("id",[ContentText c]):)
576 _ -> id)
577 [ attr "type" "result"
578 , attr "to" to
579 , attr "from" from
580 ]
581 , EventEndElement (mkname namespace "iq")
582 ]
583
584xmppInbound :: ConnectionData 466xmppInbound :: ConnectionData
585 -> XMPPServerParameters -- ^ XXX: unused 467 -> XMPPServerParameters -- ^ XXX: unused
586 -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) 468 -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin)
@@ -1549,24 +1431,3 @@ forkXmpp XMPPServer { _xmpp_sv = sv
1549 return mt 1431 return mt
1550 1432
1551 1433
1552#if MIN_VERSION_stm(2,4,0)
1553#else
1554-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the
1555-- same content available as the original channel.
1556--
1557-- Terrible inefficient implementation provided to build against older libraries.
1558cloneTChan :: TChan a -> STM (TChan a)
1559cloneTChan chan = do
1560 contents <- chanContents' chan
1561 chan2 <- dupTChan chan
1562 mapM_ (writeTChan chan) contents
1563 return chan2
1564 where
1565 chanContents' chan = do
1566 b <- isEmptyTChan chan
1567 if b then return [] else do
1568 x <- readTChan chan
1569 xs <- chanContents' chan
1570 return (x:xs)
1571#endif
1572
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 10:28:26 +0000