~singpolyma/cheogram-smtp

cheogram-smtp/gateway.hs -rw-r--r-- 8.4 KiB
7021b245Stephen Paul Weber jabber:iq:gateway working against my local Gajim 5 months ago
                                                                                
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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
module Main (main) where

import Prelude ()
import BasicPrelude
import System.IO
	(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Control.Concurrent              (threadDelay)
import Control.Concurrent.STM          (STM)
import Control.Error                   (exceptT, ExceptT(..), headZ, throwE)
import Control.Lens                    (over, set, at, _Right, traverseOf)
import Network                         (PortID (PortNumber))
import Data.Time.Clock                 (getCurrentTime)
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 Data.MIME.EncodedWord as MIME

import Email
import IQManager
import Router
import Util
import VCard

newtype RawComponentStanza = RawComponentStanza XML.Element

instance XMPP.Stanza RawComponentStanza where
	stanzaTo (RawComponentStanza el) =
		XMPP.parseJID =<< XML.attributeText (s"to") el
	stanzaFrom (RawComponentStanza el) =
		XMPP.parseJID =<< XML.attributeText (s"from") el
	stanzaID (RawComponentStanza el) = XML.attributeText (s"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"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 _ componentJid _ iq@XMPP.IQ {
		XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Nothing },
		XMPP.iqPayload = Just payload
	} | [prompt] <- fmap (mconcat . XML.elementText) $
	    XML.isNamed (s"{jabber:iq:gateway}prompt") =<<
	    XML.elementChildren =<<
	    XML.isNamed (s"{jabber:iq:gateway}query") payload =
		-- TODO: Check if prompt is a valid email address
		XMPP.putStanza $ flip iqReply iq $ Just $ XML.Element
			(s"{jabber:iq:gateway}query") [] [
				XML.NodeElement $ mkElement
				(s"{jabber:iq:gateway}jid") $
					XMPP.formatJID $ componentJid {
						XMPP.jidNode = Just $ XMPP.Node$
						               escapeJid prompt
					}
			]
iqSetHandler _ _ _ iq = XMPP.putStanza $ iqError notImplemented iq

addVCardData :: VCard -> MIME.MIMEMessage -> MIME.MIMEMessage
addVCardData vcard =
	set (MIME.headers . at (s"X-URL"))
		(MIME.encodeEncodedWords <$> headZ (url vcard)) .
	over (MIME.headerFrom MIME.defaultCharsets) (map
		(\(MIME.Mailbox name addr) ->
			MIME.Mailbox (nickname vcard <|> fn vcard <|> name) addr
		)
	)

fetchAndAddVCardData ::
	   (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ)))
	-> MIME.MIMEMessage
	-> Maybe XMPP.JID
	-> XMPP.JID
	-> XMPP.XMPP MIME.MIMEMessage
fetchAndAddVCardData sendIQ email from to =
	(`addVCardData` email) .  maybe emptyVCard parseVCard <$>
	(atomicUIO =<< sendIQ (vcardRequest to) { XMPP.iqFrom = from })

messageHandler ::
	   MIME.Domain
	-> String
	-> (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ)))
	-> XMPP.Message
	-> XMPP.XMPP ()
messageHandler fromDomain sendmail sendIQ message@XMPP.Message {
	XMPP.messageFrom = from,
	XMPP.messageTo = to
} = do
	now <- liftIO getCurrentTime
	exceptT XMPP.putStanza return $ do
		email <- ExceptT $ traverseOf (_Right . emailMessage')
			(\msg ->
				maybe (return msg)
				(fetchAndAddVCardData sendIQ msg to)
				from
			)
			(messageToEmail fromDomain now message)
		result <- sendEmail sendmail email
		if result then return () else throwE $ messageError err message
	where
	err = errorPayload "cancel" "undefined-condition"
		(s"Could not send email (maybe matched SPAM filter?)") []

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?

iqGetHandler :: XMPP.IQ -> XMPP.XMPP ()
iqGetHandler iq@XMPP.IQ {
	XMPP.iqTo = Just to,
	XMPP.iqPayload = Just p
} | Nothing <- XMPP.jidNode to,
    [_] <- XML.isNamed (s"{http://jabber.org/protocol/disco#info}query") p =
	XMPP.putStanza $ iqReply (Just $ XML.Element
		(s"{http://jabber.org/protocol/disco#info}query")
		(maybeToList nodeAttribute) [
			XML.NodeElement $ mkDiscoIdentity
				(s"gateway") (s"smtp") (s"Cheogram SMTP")
		]
	) iq
  | Nothing <- XMPP.jidNode to,
    [_] <- XML.isNamed (s"{jabber:iq:gateway}query") p =
	XMPP.putStanza $ flip iqReply iq $ Just $ XML.Element
		(s"{jabber:iq:gateway}query") [] [
			XML.NodeElement $ mkElement
				(s"{jabber:iq:gateway}prompt")
				(s"Email address"),
			XML.NodeElement $ mkElement
				(s"{jabber:iq:gateway}desc")
				(s"Please enter your contact's email address.")
		]
  | Nothing <- XMPP.jidNode to,
    [_] <- XML.isNamed (s"{vcard-temp}vCard") p =
	XMPP.putStanza $ flip iqReply iq $ Just $ XML.Element
		(s"{vcard-temp}vCard") [] [
			XML.NodeElement $ mkElement (s"{vcard-temp}URL")
				(s"https://smtp.cheogram.com"),
			XML.NodeElement $ mkElement (s"{vcard-temp}DESC") (s"\
				\A bidirectional gateway between XMPP and SMTP.\
				\\n\nLicensed under AGPLv3+.\n\nSource code \
				\for this gateway is available from \
				\the listed homepage.\n\n\
				\Part of the Soprani.ca project.")
		]
	where
	nodeAttribute = fmap (\node -> (s"node", [XML.ContentText node])) $
		XML.attributeText (s"node") p
iqGetHandler iq = XMPP.putStanza $ iqError notImplemented iq

presenceProbeHandler :: XMPP.Presence -> XMPP.XMPP ()
presenceProbeHandler XMPP.Presence {
	XMPP.presenceFrom = Just from,
	XMPP.presenceTo = Just to@XMPP.JID { XMPP.jidNode = Nothing }
} = XMPP.putStanza $ (XMPP.emptyPresence XMPP.PresenceAvailable) {
		XMPP.presenceTo = Just from,
		XMPP.presenceFrom = Just to
	}
presenceProbeHandler _ = return ()

presenceSubscribeHandler :: XMPP.Presence -> XMPP.XMPP ()
presenceSubscribeHandler XMPP.Presence {
	XMPP.presenceFrom = Just from,
	XMPP.presenceTo = Just to@XMPP.JID { XMPP.jidNode = Nothing }
} = do
	XMPP.putStanza $ (XMPP.emptyPresence XMPP.PresenceSubscribed) {
			XMPP.presenceTo = Just from,
			XMPP.presenceFrom = Just to
		}
	XMPP.putStanza $ (XMPP.emptyPresence XMPP.PresenceAvailable) {
			XMPP.presenceTo = Just from,
			XMPP.presenceFrom = Just to
		}
presenceSubscribeHandler _ = return ()

main :: IO ()
main = do
	hSetBuffering stdout LineBuffering
	hSetBuffering stderr LineBuffering

	(componentJidTxt:host:portTxt:secret:sendmailTxt:trustedTxt) <- 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 trustedTxt
	let port = PortNumber $ read portTxt
	let server = XMPP.Server componentJid (textToString host) port
	let sendmail = textToString sendmailTxt

	replyMap <- STMMap.newIO
	exceptT print return $ runRoutedComponent server secret $ do
		(sendIQ, iqReceived) <- iqManager
		return $ defaultRoutes {
			presenceProbeRoute = presenceProbeHandler,
			presenceSubscribeRoute = presenceSubscribeHandler,
			iqGetRoute = iqGetHandler,
			iqSetRoute =
				iqSetHandler replyMap componentJid trustedJids,
			iqResultRoute = iqReceived,
			iqErrorRoute = iqReceived,
			messageNormalRoute =
				messageHandler emailDomain sendmail sendIQ,
			messageChatRoute =
				messageHandler emailDomain sendmail sendIQ,
			messageErrorRoute = messageErrorHandler replyMap
		}