~singpolyma/cheogram

7f01706dc9485c30d1c6891bfea8105214f510b3 — Stephen Paul Weber 7 years ago 8df7280
Debound both joins and parts
1 files changed, 47 insertions(+), 33 deletions(-)

M Main.hs
M Main.hs => Main.hs +47 -33
@@ 1183,7 1183,7 @@ roomPresences db toRoomPresences =
	muc = T.unpack . bareTxt
	resource x = fromMaybe "" (T.unpack . strResource <$> jidResource x)

data JoinPartDebounce = DebounceJoin Text JID (Maybe JID) | DebouncePart Text JID | DebouncePartExpire Text JID UTCTime deriving (Show)
data JoinPartDebounce = DebounceJoin Text JID (Maybe JID) | DebouncePart Text JID | DebounceExpire Text JID UTCTime deriving (Show)

joinPartDebouncer toVitelity toRoomPresences toJoinPartDebouncer = next mempty
	where


@@ 1191,38 1191,52 @@ joinPartDebouncer toVitelity toRoomPresences toJoinPartDebouncer = next mempty
		msg <- atomically (readTChan toJoinPartDebouncer)
		log "DEBOUNCE JOIN/PART" (msg, state)
		go state msg >>= next
	go state (DebounceJoin tel from mjid) = do
		case Map.updateLookupWithKey (\_ _ -> Nothing) (tel, from) state of
			(Just _, state') -> return state' -- There was a leave, so do not send
			(Nothing, state') -> do
				let nick = fromMaybe mempty (strResource <$> jidResource from)
				presences <- syncCall toRoomPresences $ GetRoomPresences tel from
				log "DEBOUNCE JOIN, MAYBE GONNA SEND" (tel, from, presences)
				when (isNothing $ lookup (T.unpack nick) presences) $ do
					atomically $ writeTChan toRoomPresences $ RecordJoin tel from mjid
					writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
							fromString "* ",
							nick,
							fromString " has joined the group"
						]
				return state'
	go state (DebouncePart tel from) = do
		time <- getCurrentTime
		void $ forkIO $ threadDelay 120000000 >> atomically (writeTChan toJoinPartDebouncer $ DebouncePartExpire tel from time)
		return $! Map.insert (tel, from) time state
	go state (DebouncePartExpire tel from time) =
		case Map.updateLookupWithKey (\_ t -> if t == time then Nothing else Just t) (tel, from) state of
			(Just t, state') | t == time -> do
				atomically $ writeTChan toRoomPresences $ RecordPart tel from
				now <- getCurrentTime
				writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
						fromString "* ",
						fromMaybe mempty (strResource <$> jidResource from),
						fromString " left the group ",
						fromString $ show $ round ((now `diffUTCTime` time) / 60),
						fromString " minutes ago"
					]
				return state'

	sendPart tel from time = do
		log "DEBOUNCE PART, GONNA SEND" (tel, from, time)
		atomically $ writeTChan toRoomPresences $ RecordPart tel from
		now <- getCurrentTime
		writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
				fromString "* ",
				fromMaybe mempty (strResource <$> jidResource from),
				fromString " left the group ",
				fromString $ show $ round ((now `diffUTCTime` time) / 60),
				fromString " minutes ago"
			]

	sendJoin tel from time mjid = do
		let nick = fromMaybe mempty (strResource <$> jidResource from)
		presences <- syncCall toRoomPresences $ GetRoomPresences tel from
		now <- getCurrentTime
		log "DEBOUNCE JOIN, MAYBE GONNA SEND" (tel, from, presences)
		when (isNothing $ lookup (T.unpack nick) presences) $ do
			atomically $ writeTChan toRoomPresences $ RecordJoin tel from mjid
			writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
					fromString "* ",
					nick,
					fromString " joined the group ",
					fromString $ show $ round ((now `diffUTCTime` time) / 60),
					fromString " minutes ago"
				]

	debounceCheck state tel from mjid join =
		case Map.lookup (tel, from) state of
			Just (_, _, j) | j /= join -> return $! Map.delete (tel, from) state -- debounce
			Just (_, _, _) -> return state -- ignore dupe
			Nothing -> do
				time <- getCurrentTime
				void $ forkIO $ threadDelay 120000000 >> atomically (writeTChan toJoinPartDebouncer $ DebounceExpire tel from time)
				return $! Map.insert (tel, from) (time, mjid, join) state

	go state (DebounceJoin tel from mjid) =
		debounceCheck state tel from mjid True
	go state (DebouncePart tel from) =
		debounceCheck state tel from Nothing False
	go state (DebounceExpire tel from time) =
		case Map.updateLookupWithKey (\_ (t,m,j) -> if t == time then Nothing else Just (t,m,j)) (tel, from) state of
			(Just (t, mjid, join), state')
				| t == time && join -> sendJoin tel from time mjid >> return state'
				| t == time -> sendPart tel from time >> return state'
			(_, state') -> return state'

openTokyoCabinet :: (TC.TCDB a) => String -> IO a