~singpolyma/cheogram-smtp

ref: 3464bcaa8680d0122af20073fbc0072841d8edbd cheogram-smtp/IQManager.hs -rw-r--r-- 2.4 KiB
3464bcaaStephen Paul Weber Always use line buffering, even when redirected to file 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
module IQManager (iqManager, iqManager') where

import Prelude ()
import BasicPrelude
import Control.Concurrent.STM (
		STM, TMVar, TVar, modifyTVar', newEmptyTMVar, newTVar, orElse,
		readTVar, takeTMVar, tryPutTMVar, writeTVar
	)
import Control.Concurrent.STM.Delay    (newDelay, waitDelay)
import UnexceptionalIO.Trans           (Unexceptional)
import qualified Data.Map.Strict       as Map
import qualified Network.Protocol.XMPP as XMPP

import Util

type ResponseMap = Map.Map (Maybe Text) (TMVar XMPP.IQ)

iqSendTimeoutMicroseconds :: Int
iqSendTimeoutMicroseconds = 5000000

iqSenderUnexceptional :: (Unexceptional m) =>
	   TVar ResponseMap
	-> XMPP.IQ
	-> m (STM (Maybe XMPP.IQ))
iqSenderUnexceptional responseMapVar iqToSend = do
	timeout <- fromIO_ $ newDelay iqSendTimeoutMicroseconds
	iqResponseVar <- atomicUIO newEmptyTMVar
	atomicUIO $ modifyTVar' responseMapVar $
			Map.insert (XMPP.iqID iqToSend) iqResponseVar
	return (
			(waitDelay timeout *> pure Nothing)
			`orElse`
			fmap Just (takeTMVar iqResponseVar)
		)

iqSender ::
	  (XMPP.IQ -> XMPP.XMPP a)
	-> XMPP.IQ
	-> XMPP.XMPP a
iqSender baseSender iqToSend
	| XMPP.iqType iqToSend `elem` [XMPP.IQGet, XMPP.IQSet] = do
		result <- baseSender iqToSend
		XMPP.putStanza iqToSend
		return result
	| otherwise = error "iqManager can only send IQGet or IQSet"

iqReceiver :: (Unexceptional m) => TVar ResponseMap -> XMPP.IQ -> m ()
iqReceiver responseMapVar receivedIQ
	| XMPP.iqType receivedIQ `elem` [XMPP.IQResult, XMPP.IQError] = do
		maybeIqResponseVar <- atomicUIO $ do
			responseMap <- readTVar responseMapVar
			let (maybeIqResponseVar, responseMap') =
				Map.updateLookupWithKey
				(const $ const Nothing)
				(XMPP.iqID receivedIQ) responseMap
			writeTVar responseMapVar $! responseMap'
			return maybeIqResponseVar
		forM_ maybeIqResponseVar $ \iqResponseVar ->
			atomicUIO $ tryPutTMVar iqResponseVar receivedIQ
	| otherwise = return () -- TODO: log or otherwise signal error?

iqManager' :: (Unexceptional m1, Unexceptional m2, Unexceptional m3) =>
	m1 (XMPP.IQ -> m2 (STM (Maybe XMPP.IQ)), XMPP.IQ -> m3 ())
iqManager' = do
	responseMapVar <- atomicUIO $ newTVar Map.empty
	return (
			iqSenderUnexceptional responseMapVar,
			iqReceiver responseMapVar
		)

iqManager :: (Unexceptional m1, Unexceptional m2) =>
	m1 (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ)), XMPP.IQ -> m2 ())
iqManager = do
	(sender, receiver) <- iqManager'
	return (iqSender sender, receiver)