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
module Main (main) where
import Prelude ()
import BasicPrelude
import Control.Concurrent (threadDelay)
import Control.Error (exceptT)
import Network (PortID (PortNumber))
import qualified Focus
import qualified StmContainers.Map as STMMap
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import qualified Data.XML.Types as XML
import qualified Network.Protocol.XMPP as XMPP
import qualified Network.Protocol.XMPP.Internal as XMPP
import Util
import Router
newtype RawComponentStanza = RawComponentStanza XML.Element
instance XMPP.Stanza RawComponentStanza where
stanzaTo (RawComponentStanza el) =
XMPP.parseJID =<<
XML.attributeText (s"{jabber:component:accept}to") el
stanzaFrom (RawComponentStanza el) =
XMPP.parseJID =<<
XML.attributeText (s"{jabber:component:accept}from") el
stanzaID (RawComponentStanza el) =
XML.attributeText (s"{jabber:component:accept}id") el
stanzaLang (RawComponentStanza el) =
XML.attributeText (s"xml:lang") el
stanzaPayloads (RawComponentStanza el) = XML.elementChildren el
stanzaToElement (RawComponentStanza el) = el
defaultMessageError :: XML.Element
defaultMessageError = errorPayload "cancel" "undefined-condition"
(s"Unknown error sending message") []
overrideID :: Text -> XML.Element -> XML.Element
overrideID newID el = el {
XML.elementAttributes =
(s"{jabber:component:accept}id", [XML.ContentText newID]) :
XML.elementAttributes el
}
iqSetHandler ::
STMMap.Map (Maybe Text) XMPP.IQ
-> XMPP.JID
-> [XMPP.JID]
-> XMPP.IQ
-> XMPP.XMPP ()
iqSetHandler replyMap componentJid trustedJids iq@XMPP.IQ {
XMPP.iqFrom = Just from,
XMPP.iqTo = Just to,
XMPP.iqPayload = payload
} | to == componentJid && from `elem` trustedJids = do
uuid <- liftIO UUID.nextRandom
let sid = UUID.toText uuid
atomicUIO $ STMMap.insert iq (Just sid) replyMap
mapM_ XMPP.putStanza $
RawComponentStanza . overrideID sid <$> payload
void $ forkXMPP $ do
liftIO $ threadDelay 2000000
lookupIQ <- atomicUIO $ STMMap.focus
Focus.lookupAndDelete (Just sid) replyMap
forM_ lookupIQ $ \originalIQ ->
XMPP.putStanza $ iqReply Nothing originalIQ
iqSetHandler _ _ _ iq = XMPP.putStanza $ iqError notImplemented iq
messageErrorHandler ::
STMMap.Map (Maybe Text) XMPP.IQ
-> XMPP.Message
-> XMPP.XMPP ()
messageErrorHandler replyMap message = do
let errorElement = fromMaybe defaultMessageError $ errorChild message
lookupIQ <- atomicUIO $ STMMap.focus
Focus.lookupAndDelete (XMPP.stanzaID message) replyMap
forM_ lookupIQ $ \originalIQ ->
XMPP.putStanza $ iqError errorElement originalIQ
-- TODO: else, manual bounce?
main :: IO ()
main = do
(componentJidTxt:host:portTxt:secret:trustedJidsTxt) <- getArgs
let Just componentJid = XMPP.parseJID componentJidTxt
let Just trustedJids = mapM XMPP.parseJID trustedJidsTxt
let port = PortNumber $ read portTxt
let server = XMPP.Server componentJid (textToString host) port
replyMap <- STMMap.newIO
exceptT print return $ runRoutedComponent server secret $ defaultRoutes{
iqSetRoute =
iqSetHandler replyMap componentJid trustedJids,
messageErrorRoute =
messageErrorHandler replyMap
}