~singpolyma/cheogram-smtp

ref: ccfeda0ae8015c99e370c5e76ff2af16731cef07 cheogram-smtp/gateway.hs -rw-r--r-- 4.0 KiB
ccfeda0aStephen Paul Weber Add Date header, from delayed deliver if present else now 2 years 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
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 (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
		}