~singpolyma/cheogram

a42b06986fa64052a1688947021fb87e590e9cf1 — Stephen Paul Weber 1 year, 10 months ago afa09a6
oops, add files
2 files changed, 85 insertions(+), 0 deletions(-)

A IQManager.hs
A UniquePrefix.hs
A IQManager.hs => IQManager.hs +72 -0
@@ 0,0 1,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
		)

A UniquePrefix.hs => UniquePrefix.hs +13 -0
@@ 0,0 1,13 @@
module UniquePrefix where

import Data.List
import qualified Data.Set as S
import qualified Data.Text as T

uniquePrefix txts = helper [] $ map (S.fromList . tail . T.inits) txts

helper done (prefixes:otherPrefixes) =
	(foldl' S.difference prefixes (done ++ otherPrefixes)) : helper (prefixes:done) otherPrefixes
helper _ [] = []

--ALT: https://pastebin.com/hFKdZw2g