~singpolyma/cheogram-smtp: Router.hs - sourcehut git


                                                                                
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
module Router where

import Prelude ()
import BasicPrelude
import Control.Error                   (ExceptT (..))
import qualified Network.Protocol.XMPP as XMPP

import Util

runRoutedComponent ::
	   XMPP.Server
	-> Text
	-> XMPP.XMPP Routes
	-> ExceptT XMPP.Error IO ()
runRoutedComponent server secret =
	ExceptT . XMPP.runComponent server secret . (runRouted =<<)

runRouted :: Routes -> XMPP.XMPP ()
runRouted routes = forever $ XMPP.getStanza >>= (void . forkXMPP . handle)
	where
	handle (XMPP.ReceivedIQ iq@XMPP.IQ { XMPP.iqType = XMPP.IQGet }) =
		iqGetRoute routes iq
	handle (XMPP.ReceivedIQ iq@XMPP.IQ { XMPP.iqType = XMPP.IQSet }) =
		iqSetRoute routes iq
	handle (XMPP.ReceivedIQ iq@XMPP.IQ { XMPP.iqType = XMPP.IQResult }) =
		iqResultRoute routes iq
	handle (XMPP.ReceivedIQ iq@XMPP.IQ { XMPP.iqType = XMPP.IQError }) =
		iqErrorRoute routes iq
	handle (XMPP.ReceivedMessage message@XMPP.Message {
		XMPP.messageType = XMPP.MessageNormal
	}) = messageNormalRoute routes message
	handle (XMPP.ReceivedMessage message@XMPP.Message {
		XMPP.messageType = XMPP.MessageChat
	}) = messageChatRoute routes message
	handle (XMPP.ReceivedMessage message@XMPP.Message {
		XMPP.messageType = XMPP.MessageHeadline
	}) = messageHeadlineRoute routes message
	handle (XMPP.ReceivedMessage message@XMPP.Message {
		XMPP.messageType = XMPP.MessageError
	}) = messageErrorRoute routes message
	handle _ = return ()

data Routes = Routes {
	iqGetRoute :: XMPP.IQ -> XMPP.XMPP (),
	iqSetRoute :: XMPP.IQ -> XMPP.XMPP (),
	iqResultRoute :: XMPP.IQ -> XMPP.XMPP (),
	iqErrorRoute :: XMPP.IQ -> XMPP.XMPP (),
	messageNormalRoute :: XMPP.Message -> XMPP.XMPP (),
	messageChatRoute :: XMPP.Message -> XMPP.XMPP (),
	messageHeadlineRoute :: XMPP.Message -> XMPP.XMPP (),
	messageErrorRoute :: XMPP.Message -> XMPP.XMPP ()
}

defaultRoutes :: Routes
defaultRoutes = Routes {
	iqGetRoute = XMPP.putStanza . iqError notImplemented,
	iqSetRoute = XMPP.putStanza . iqError notImplemented,
	iqResultRoute = const $ return (),
	iqErrorRoute = const $ return (),
	messageNormalRoute = const $ return (),
	messageChatRoute = const $ return (),
	messageHeadlineRoute = const $ return (),
	messageErrorRoute = const $ return ()
}