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
module Main (main) where
import Prelude ()
import BasicPrelude
import Control.Concurrent (threadDelay)
import Control.Error (exceptT)
import Network (PortID (PortNumber))
import Data.Time.Clock (getCurrentTime)
import qualified Data.ByteString.Lazy as LByteString
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 qualified Data.MIME as MIME
import qualified Network.Mail.Mime as Mail
import Util
import Router
import Email
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 && bareJid 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
messageHandler ::
MIME.Domain
-> XMPP.Message
-> XMPP.XMPP ()
messageHandler fromDomain message = do
now <- liftIO getCurrentTime
forM_ (messageToEmail fromDomain now message) $ \(from, mail) ->
liftIO $ Mail.sendmailCustom "/usr/sbin/sendmail" [
"-t", "-i",
"-f", textToString $ decodeUtf8 $
MIME.renderMailbox from
] (LByteString.fromStrict $ MIME.renderMessage mail)
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 Right (MIME.Mailbox _ (MIME.AddrSpec _ emailDomain)) =
MIME.parse (MIME.mailbox MIME.defaultCharsets)
(s"boop@" ++ encodeUtf8 componentJidTxt)
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,
messageNormalRoute = messageHandler emailDomain,
messageChatRoute = messageHandler emailDomain,
messageErrorRoute =
messageErrorHandler replyMap
}