~singpolyma/jabber-iq-gateway-web: IQManager.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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
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 qualified Data.UUID             as UUID
import qualified Data.UUID.V4          as UUID

import Util

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

iqSendTimeoutMicroseconds :: Int
iqSendTimeoutMicroseconds = 5000000

iqDefaultID :: (Unexceptional m) => XMPP.IQ -> m XMPP.IQ
iqDefaultID iq@XMPP.IQ { XMPP.iqID = Just _ } = return iq
iqDefaultID iq = do
	uuid <- fromIO_ UUID.nextRandom
	return $ iq {
			XMPP.iqID = Just $ UUID.toText uuid
		}

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 iq
	| XMPP.iqType iq `elem` [XMPP.IQGet, XMPP.IQSet] = do
		iqToSend <- iqDefaultID iq
		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)