~singpolyma/cheogram: 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
module 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) =>
	(XMPP.IQ -> m ())
	-> TVar ResponseMap
	-> XMPP.IQ
	-> m (STM (Maybe XMPP.IQ))
iqSenderUnexceptional sender responseMapVar iq = do
	iqToSend <- iqDefaultID iq
	timeout <- fromIO_ $ newDelay iqSendTimeoutMicroseconds
	iqResponseVar <- atomicUIO newEmptyTMVar
	atomicUIO $ modifyTVar' responseMapVar $
			Map.insert (XMPP.iqID iqToSend) iqResponseVar
	sender iqToSend
	return (
			(waitDelay timeout *> pure Nothing)
			`orElse`
			fmap Just (takeTMVar iqResponseVar)
		)

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) =>
	(XMPP.IQ -> m2 ()) ->
	m1 (XMPP.IQ -> m2 (STM (Maybe XMPP.IQ)), XMPP.IQ -> m3 ())
iqManager sender = do
	responseMapVar <- atomicUIO $ newTVar Map.empty
	return (
			iqSenderUnexceptional sender responseMapVar,
			iqReceiver responseMapVar
		)