~singpolyma/cheogram

fd18ca006c00b852af66ba16b62a3ef385aa7927 — Stephen Paul Weber 6 years ago b03f03d
Debounce join/part SMS notifications

We don't tell you someone left the group until they are gone for 2
minutes.  If they come back in that time, we never tell you anything.

This is for people on bad internet who keep leaving and reconnecting
right away. The stream of SMS messages is very annoying.  They will see
your messages when they come back (usually) because of MUC scrollback
features.  If they are gone longer, we will tell you and hopefully you
didn't say a lot of stuff while they were gone.

Closes #33
1 files changed, 70 insertions(+), 37 deletions(-)

M Main.hs
M Main.hs => Main.hs +70 -37
@@ 8,7 8,7 @@ import Control.Concurrent.STM
import Data.Foldable (forM_, mapM_, toList)
import System.Environment (getArgs)
import Control.Error (readZ, syncIO, runEitherT)
import Data.Time (UTCTime, addUTCTime, getCurrentTime)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Network (PortID(PortNumber))
import System.Random (Random(randomR), getStdRandom)
import System.Random.Shuffle (shuffleM)


@@ 24,6 24,9 @@ import qualified Data.UUID.V1 as UUID ( nextUUID )
import qualified Database.TokyoCabinet as TC
import Network.Protocol.XMPP -- should import qualified

instance Ord JID where
	compare x y = compare (show x) (show y)

log :: (Show a, MonadIO m) => String -> a -> m ()
log tag x = liftIO $ putStr (fromString $ tag <> " :: ") >> print x >> putStrLn mempty



@@ 200,7 203,7 @@ componentMessage db toVitelity _ (Message { messageFrom = Just from }) existingR
	writeStanzaChan toVitelity $ mkSMS tel txt
componentMessage _ _ _ m _ _ _ _ _ = log "UNKNOWN MESSAGE" m

handleJoinPartRoom db toVitelity toComponent existingRoom from to tel payloads join
handleJoinPartRoom db toVitelity toJoinPartDebouncer toComponent existingRoom from to tel payloads join
	| join,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  [status] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x,


@@ 262,16 265,8 @@ handleJoinPartRoom db toVitelity toComponent existingRoom from to tel payloads j
		log "YOU HAVE LEFT" (tel, existingRoom)
		True <- TC.runTCM $ TC.out db $ tcKey tel "joined"
		writeStanzaChan toVitelity $ mkSMS tel (fromString "* You have left " <> bareMUC)
	| fmap bareTxt existingRoom == Just bareMUC = do
		presence <- fmap (map f . fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> T.unpack bareMUC))
		log "JOINPART" (tel, existingRoom, join, resourceFrom, presence)
		writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
				fromString "* ",
				resourceFrom,
				fromString " has ",
				fromString $ if join then "joined" else "left",
				fromString " the group"
			]
	| fmap bareTxt existingRoom == Just bareMUC && join = atomically $ writeTChan toJoinPartDebouncer $ DebounceJoin tel from
	| fmap bareTxt existingRoom == Just bareMUC && not join = atomically $ writeTChan toJoinPartDebouncer $ DebouncePart tel from
	| otherwise = log "UNKNOWN STATUS" (existingRoom, from, to, tel, payloads, join)
	where
	resourceFrom = fromMaybe mempty (strResource <$> jidResource from)


@@ 457,13 452,13 @@ handleRegister _ _ toComponent _ iq@(IQ { iqType = typ }) _
		}
handleRegister _ _ _ _ _ iq = log "HANDLEREGISTER UNKNOWN" iq

componentStanza _ _ toComponent _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
componentStanza _ _ _ toComponent _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
	| [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< messagePayloads m,
	  [status] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x,
	  (_:_) <- code "104" status = do
		log "CODE104" (to, from)
		queryDisco toComponent from to
componentStanza db toVitelity toComponent componentHost (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
componentStanza db toVitelity _ toComponent componentHost (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
	| Just tel <- strNode <$> jidNode to,
	  T.length tel == 11 && fromString "1" `T.isPrefixOf` tel = do
		log "RECEIVEDMESSAGE" m


@@ 502,14 497,14 @@ componentStanza db toVitelity toComponent componentHost (ReceivedMessage (m@Mess
		}
	where
	resourceFrom = strResource <$> jidResource from
componentStanza _ toVitelity _ _ (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to }))
componentStanza _ toVitelity _ _ _ (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to }))
	| Just tel <- strNode <$> jidNode to = do
		log "FAILED TO JOIN" p
		let errorText = maybe mempty (mconcat . (fromString "\n":) . elementText) $ listToMaybe $
			isNamed (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}text") =<<
			elementChildren =<< isNamed (fromString "{jabber:component:accept}error") =<< presencePayloads p
		writeStanzaChan toVitelity $ mkSMS tel (fromString "* Failed to join " <> bareTxt from <> errorText)
componentStanza db toVitelity toComponent _ (ReceivedPresence (Presence {
componentStanza db toVitelity toJoinPartDebouncer toComponent _ (ReceivedPresence (Presence {
		presenceType = typ,
		presenceFrom = Just from,
		presenceTo = Just to@(JID { jidNode = Just toNode }),


@@ 517,8 512,8 @@ componentStanza db toVitelity toComponent _ (ReceivedPresence (Presence {
	})) | typ `elem` [PresenceAvailable, PresenceUnavailable] = do
		existingRoom <- tcGetJID db (strNode toNode) "joined"
		log "JOIN PART ROOM" (from, to, typ, existingRoom, payloads)
		handleJoinPartRoom db toVitelity toComponent existingRoom from to (strNode toNode) payloads (typ == PresenceAvailable)
componentStanza _ _ toComponent _ (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
		handleJoinPartRoom db toVitelity toJoinPartDebouncer toComponent existingRoom from to (strNode toNode) payloads (typ == PresenceAvailable)
componentStanza _ _ _ toComponent _ (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
	log "APPROVE SUBSCRIPTION" (from, to)
	writeStanzaChan toComponent $ (emptyPresence PresenceSubscribed) {
		presenceTo = Just from,


@@ 529,7 524,7 @@ componentStanza _ _ toComponent _ (ReceivedPresence (Presence { presenceType = P
		presenceTo = Just from,
		presenceFrom = Just to
	}
componentStanza _ _ toComponent _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
componentStanza _ _ _ toComponent _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
	log "RESPOND TO PROBES" (from, to)
	writeStanzaChan toComponent $ (emptyPresence PresenceAvailable) {
		presenceTo = Just from,


@@ 543,12 538,12 @@ componentStanza _ _ toComponent _ (ReceivedPresence (Presence { presenceType = P
			] []
		]
	}
componentStanza db toVitelity toComponent componentHost (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p }))
componentStanza db toVitelity _ toComponent componentHost (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p }))
	| iqType iq `elem` [IQGet, IQSet],
	  [query] <- isNamed (fromString "{jabber:iq:register}query") p = do
		log "LOOKS LIKE REGISTRATION" iq
		handleRegister db toVitelity toComponent componentHost iq query
componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p }))
componentStanza _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p }))
	| Nothing <- jidNode to,
	  [_] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
		log "DISCO ON US" (from, to, p)


@@ 568,7 563,7 @@ componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Jus
					] []
				]
		}
componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p }))
componentStanza _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p }))
	| Just _ <- jidNode to,
	  [_] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
		log "DISCO ON USER" (from, to, p)


@@ 586,7 581,7 @@ componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Jus
					] []
				]
		}
componentStanza _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQSet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p }))
componentStanza _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQSet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p }))
	| [query] <- isNamed (fromString "{jabber:iq:gateway}query") p,
	  [prompt] <- isNamed (fromString "{jabber:iq:gateway}prompt") =<< elementChildren query = do
		log "jabber:iq:gateway submit" (from, to, p)


@@ 613,7 608,7 @@ componentStanza _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQSe
								[NodeContent $ ContentText $ fromString "Only US/Canada telephone numbers accepted"]
						]
				}
componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p }))
componentStanza _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p }))
	| [_] <- isNamed (fromString "{jabber:iq:gateway}query") p = do
		log "jabber:iq:gateway query" (from, to, p)
		writeStanzaChan toComponent $ (emptyIQ IQResult) {


@@ 626,7 621,7 @@ componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Jus
					NodeElement $ Element (fromString "{jabber:iq:gateway}prompt") [ ] [NodeContent $ ContentText $ fromString "Phone Number"]
				]
		}
componentStanza db _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id }))
componentStanza db _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id }))
	| fromString "CHEOGRAMSTARTUP%" `T.isPrefixOf` id = do
		log "CHEOGRAMSTARTUP RESULT" (from, to, iq)
		-- Room exists and has people in it


@@ 642,7 637,7 @@ componentStanza db _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQR
		elementChildren =<<
		isNamed (fromString "{http://jabber.org/protocol/disco#items}query") =<<
		toList (iqPayload iq)
componentStanza db _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to, iqID = Just id }))
componentStanza db _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to, iqID = Just id }))
	| fromString "CHEOGRAMSTARTUP%" `T.isPrefixOf` id = do
		log "CHEOGRAMSTARTUP ERROR" (from, to, iq)
		-- We must assume the room has been destroyed, though maybe it's just blocking our queries


@@ 657,7 652,7 @@ componentStanza db _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQE
				True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) <> "\0false_presence") (show $ sort $ (nick,tel):xs)
				leaveRoom db toComponent componentHost tel "Service reset" -- in case we are in and can't tell?
				forM_ (parseJID $ bareTxt from <> fromString "/" <> nick) $ joinRoom db toComponent componentHost tel
componentStanza db _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to }))
componentStanza db _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to }))
	| (strNode <$> jidNode to) == Just (fromString "create"),
	  Just resource <- strResource <$> jidResource to = do
		log "create@ ERROR" (from, to, iq)


@@ 668,7 663,7 @@ componentStanza db _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQE
				leaveRoom db toComponent componentHost tel "Joined a different room."
				joinRoom db toComponent componentHost tel room
			_ -> return () -- Invalid packet, ignore
componentStanza _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to }))
componentStanza _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to }))
	| (strNode <$> jidNode to) == Just (fromString "create"),
	  Just resource <- strResource <$> jidResource to = do
		log "create@ RESULT" (from, to, iq)


@@ 676,11 671,11 @@ componentStanza _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQRe
			(tel:name:[]) -> void $ createRoom toComponent componentHost [T.unpack $ strDomain $ jidDomain from] tel (name <> "_" <> tel)
			(tel:name:servers) -> void $ createRoom toComponent componentHost servers tel name
			_ -> return () -- Invalid packet, ignore
componentStanza _ toVitelity _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to }))
componentStanza _ toVitelity _ _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to }))
	| Just tel <- strNode <$> jidNode to = do
		log "IQ ERROR" iq
		writeStanzaChan toVitelity $ mkSMS tel (fromString "Error while querying or configuring " <> formatJID from)
componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p }))
componentStanza _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p }))
	| [query] <- isNamed (fromString "{http://jabber.org/protocol/muc#owner}query") p,
	  [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query = do
		log "DISCO RESULT" (from, to, p)


@@ 697,14 692,14 @@ componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = 
				form { elementAttributes = [(fromString "{jabber:x:data}type", [ContentText $ fromString "submit"])] }
			]
		}
componentStanza _ toVitelity toComponent _ (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id }))
componentStanza _ toVitelity _ toComponent _ (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id }))
	| Just tel <- strNode <$> jidNode to,
	  fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id = do
		log "CHEOGRAMCREATE RESULT YOU HAVE CREATED" (from, to, iq)
		writeStanzaChan toVitelity $ mkSMS tel (mconcat [fromString "* You have created ", bareTxt from])
		forM_ (parseJID $ bareTxt to <> fromString "/create") $
			queryDisco toComponent from
componentStanza db _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p }))
componentStanza db _ _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p }))
	| Just tel <- strNode <$> jidNode to,
	  [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
		log "DISCO RESULT" (from, to, p)


@@ 716,7 711,7 @@ componentStanza db _ toComponent componentHost (ReceivedIQ (IQ { iqType = IQResu
			regJid <- tcGetJID db tel "registered"
			forM_ regJid $ \jid -> forM_ (parseJID $ bareTxt to) $ \to -> sendInvite db toComponent jid (Invite from to Nothing Nothing)
		joinStartupTels db toComponent componentHost from to
componentStanza _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ }))
componentStanza _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ }))
	| typ `elem` [IQGet, IQSet] = do
		log "REPLY WITH IQ ERROR" iq
		writeStanzaChan toComponent $ iq {


@@ 727,7 722,7 @@ componentStanza _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ }))
				[(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
				[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented") [] []]
		}
componentStanza _ _ _ _ s = log "UNKNOWN STANZA" s
componentStanza _ _ _ _ _ s = log "UNKNOWN STANZA" s

joinStartupTels db toComponent componentHost muc hopefulOwner = do
	muc_membersonly <- maybe False toEnum <$> TC.runTCM (TC.get db (T.unpack (bareTxt muc) <> "\0muc_membersonly"))


@@ 759,7 754,7 @@ storePresence db (ReceivedPresence p@(Presence { presenceType = PresenceAvailabl
	resourceFrom = fromMaybe "" (T.unpack . strResource <$> jidResource from)
storePresence _ _ = return ()

component db toVitelity toComponent componentHost = do
component db toVitelity toJoinPartDebouncer toComponent componentHost = do
	thread <- forkXMPP $ forever $ flip catchError (log "component EXCEPTION") $ do
		stanza <- liftIO $ atomically $ readTChan toComponent
		log "COMPONENT OUT" stanza


@@ 768,7 763,7 @@ component db toVitelity toComponent componentHost = do
	flip catchError (\e -> liftIO (log "component part 2 EXCEPTION" e >> killThread thread)) $ forever $ do
		s <- getStanza
		log "COMPONENT  IN" s
		liftIO $ componentStanza db toVitelity toComponent componentHost s
		liftIO $ componentStanza db toVitelity toJoinPartDebouncer toComponent componentHost s
		liftIO $ storePresence db s

telToVitelity tel


@@ 1088,6 1083,42 @@ multipartStitcher db chunks toVitelity toComponent componentHost conferenceServe

		go unexpired

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

joinPartDebouncer toVitelity toJoinPartDebouncer = next mempty
	where
	next state = do
		msg <- atomically (readTChan toJoinPartDebouncer)
		log "DEBOUNCE JOIN/PART" (msg, state)
		go state msg >>= next
	go state (DebounceJoin tel from) = do
		case Map.updateLookupWithKey (\_ _ -> Nothing) (tel, from) state of
			(Just _, state') -> return state' -- There was a leave, so do not send
			(Nothing, state') -> do
				writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
						fromString "* ",
						fromMaybe mempty (strResource <$> jidResource from),
						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
				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'
			(_, state') -> return state'

openTokyoCabinet :: (TC.TCDB a) => String -> IO a
openTokyoCabinet pth = TC.runTCM $ do
	db <- TC.new


@@ 1102,13 1133,15 @@ main = do
	(name:host:port:secret:vitelityJid:vitelityPassword:conferences) <- getArgs
	db <- openTokyoCabinet "./db.tcdb" :: IO TC.HDB
	chunks <- atomically newTChan
	toJoinPartDebouncer <- atomically newTChan
	toVitelity <- atomically newTChan
	toComponent <- atomically newTChan

	void $ forkIO $ forever $ threadDelay 1500000 >> atomically (writeTChan chunks TimerExpire)
	void $ forkIO $ multipartStitcher db chunks toVitelity toComponent name conferences
	void $ forkIO $ joinPartDebouncer toVitelity toJoinPartDebouncer

	void $ forkIO $ forever $ log "runComponent ENDED" =<< (runEitherT . syncIO) (runComponent (Server (fromString name) host (PortNumber $ fromIntegral (read port :: Int))) (fromString secret) (component db toVitelity toComponent name))
	void $ forkIO $ forever $ log "runComponent ENDED" =<< (runEitherT . syncIO) (runComponent (Server (fromString name) host (PortNumber $ fromIntegral (read port :: Int))) (fromString secret) (component db toVitelity toJoinPartDebouncer toComponent name))

	oldPresence <- TC.runTCM $ TC.fwmkeys db "presence\0" maxBound
	forM_ (oldPresence :: [String]) $ \pkey -> do