~singpolyma/cheogram

7c42e963f87fe6dafa0fcc54e214fb50b6768cd1 — Stephen Paul Weber 5 years ago f5c2756
Huge refactor to use seperate backend and some other stuff
1 files changed, 548 insertions(+), 550 deletions(-)

M Main.hs
M Main.hs => Main.hs +548 -550
@@ 1,20 1,20 @@
{-# LANGUAGE PackageImports #-}
import Prelude (show, read)
import BasicPrelude hiding (show, read, forM_, mapM_, getArgs, log)
import BasicPrelude hiding (show, read, forM, mapM, forM_, mapM_, getArgs, log)
import System.IO (stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Data.Char
import Control.Concurrent
import Control.Concurrent.STM
import Data.Foldable (forM_, mapM_, toList)
import Data.Traversable (forM, mapM)
import System.Environment (getArgs)
import Control.Error (readZ, syncIO, runEitherT)
import Control.Error (readZ, syncIO, runEitherT, readMay, MaybeT(..), hoistMaybe)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Network (PortID(PortNumber))
import System.Random (Random(randomR), getStdRandom)
import System.Random.Shuffle (shuffleM)

import "monads-tf" Control.Monad.Error (catchError) -- ick
import Data.Attoparsec.Text (takeText, string, parseOnly, decimal)
import Data.XML.Types (Element(..), Node(NodeContent, NodeElement), Name(Name), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T


@@ 42,29 42,32 @@ instance Stanza StanzaRec where
	stanzaPayloads (StanzaRec _ _ _ _ payloads _) = payloads
	stanzaToElement (StanzaRec _ _ _ _ _ element) = element

writeStanzaChan chan = atomically . writeTChan chan . mkStanzaRec

mkSMS tel txt = (emptyMessage MessageChat) {
	messageTo = telToVitelity tel,
	messagePayloads = [Element (fromString "{jabber:client}body") [] [NodeContent $ ContentText txt]]
mkSMS from to txt = (emptyMessage MessageChat) {
	messageTo = Just to,
	messageFrom = Just from,
	messagePayloads = [Element (fromString "{jabber:component:accept}body") [] [NodeContent $ ContentText txt]]
}

tcKey tel key = maybe "BADTEL" T.unpack (normalizeTel tel) <> "\0" <> key
tcGetJID db tel key = (parseJID . fromString =<<) <$> TC.runTCM (TC.get db $ tcKey tel key)
tcPutJID db tel key jid = do
	True <- TC.runTCM (TC.put db (tcKey tel key) (T.unpack $ formatJID jid))
tcKey jid key = fmap (\node -> (T.unpack $ strNode node) <> "\0" <> key) (jidNode jid)
tcGetJID db jid key = liftIO $ case tcKey jid key of
	Just tck -> (parseJID . fromString =<<) <$> TC.runTCM (TC.get db tck)
	Nothing -> return Nothing
tcPutJID db cheoJid key jid = tcPut db cheoJid key $ T.unpack $ formatJID jid
tcPut db cheoJid key val = liftIO $ do
	let Just tck = tcKey cheoJid key
	True <- TC.runTCM (TC.put db tck val)
	return ()

getBody ns = listToMaybe . fmap (mconcat . elementText) . (isNamed (Name (fromString "body") (Just $ fromString ns) Nothing) <=< messagePayloads)

queryDisco toComponent to from = do
queryDisco to from = do
	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
	writeStanzaChan toComponent $ (emptyIQ IQGet) {
	return $ [mkStanzaRec $ (emptyIQ IQGet) {
		iqTo = Just to,
		iqFrom = Just from,
		iqID = uuid,
		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] []
	}
	}]

fillFormField var value form = form {
		elementNodes = map (\node ->


@@ 141,7 144,7 @@ bareTxt (JID Nothing domain _) = strDomain domain
nickFor db jid existingRoom
	| fmap bareTxt existingRoom == Just bareFrom = return $ fromMaybe (fromString "nonick") resourceFrom
	| Just tel <- normalizeTel =<< strNode <$> jidNode jid = do
		mnick <- TC.runTCM (TC.get db $ tcKey tel "nick")
		mnick <- maybe (return Nothing) (TC.runTCM .TC.get db) (tcKey jid "nick")
		case mnick of
			Just nick -> return (tel <> fromString " \"" <> fromString nick <> fromString "\"")
			Nothing -> return tel


@@ 155,26 158,15 @@ code str status =
	<>
	hasAttributeText (fromString "code") (== fromString str) status

componentMessage _ toVitelity _ (m@Message { messageType = MessageError }) _ _ _ tel body = do
componentMessage _ componentJid (m@Message { messageType = MessageError }) _ _ _ smsJid body = do
	log "MESSAGE ERROR"  m
	let errorTxt = fmap (mconcat . elementText) $ listToMaybe $
		isNamed (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}text") =<<
		elementChildren =<< isNamed (fromString "{jabber:component:accept}error") =<< messagePayloads m
	writeStanzaChan toVitelity $ mkSMS tel $
		mconcat [
			fromString "(ERROR from ",
			maybe (fromString "unspecified") formatJID (messageFrom m),
			fromString ")",
			maybe mempty (fromString "\n"<>) errorTxt,
			maybe mempty (fromString "\n"<>) body
		]
componentMessage db toVitelity toComponent m@(Message { messageTo = Just to }) existingRoom _ _ tel _
	return [mkStanzaRec $ m { messageTo = Just smsJid, messageFrom = Just componentJid }]
componentMessage db componentJid m@(Message { messageTo = Just to }) existingRoom _ _ smsJid _
	| Just invite <- getMediatedInvitation m <|> getDirectInvitation m = do
		log "GOT INVITE" (invite, m)
		forM_ (invitePassword invite) $ \password -> do
			True <- TC.runTCM $ TC.put db (tcKey tel (T.unpack (formatJID $ inviteMUC invite) <> "\0muc_roomsecret")) (T.unpack password)
			return ()
		existingInvite <- tcGetJID db tel "invited"
		forM_ (invitePassword invite) $ \password ->
			tcPut db to (T.unpack (formatJID $ inviteMUC invite) <> "\0muc_roomsecret") (T.unpack password)
		existingInvite <- tcGetJID db to "invited"
		nick <- nickFor db (inviteFrom invite) existingRoom
		let txt = mconcat [
				fromString "* ",


@@ 183,103 175,119 @@ componentMessage db toVitelity toComponent m@(Message { messageTo = Just to }) e
				maybe mempty (\t -> fromString ", saying \"" <> t <> fromString "\"") (inviteText invite),
				fromString "\nYou can switch to this group by replying with /join"
			]
		when (existingRoom /= Just (inviteMUC invite) && existingInvite /= Just (inviteMUC invite)) $ do
			tcPutJID db tel "invited" (inviteMUC invite)
			writeStanzaChan toVitelity $ mkSMS tel txt
			regJid <- tcGetJID db tel "registered"
			forM_ regJid $ \jid -> sendInvite db toComponent jid (invite { inviteFrom = to })
componentMessage _ toVitelity _ (m@Message { messageType = MessageGroupChat }) existingRoom bareFrom resourceFrom tel (Just body) = do
		if (existingRoom /= Just (inviteMUC invite) && existingInvite /= Just (inviteMUC invite)) then do
			tcPutJID db to "invited" (inviteMUC invite)
			regJid <- tcGetJID db to "registered"
			fmap (((mkStanzaRec $ mkSMS componentJid smsJid txt):) . concat . toList)
				(forM regJid $ \jid -> sendInvite db jid (invite { inviteFrom = to }))
		else
			return []
componentMessage _ componentJid (m@Message { messageType = MessageGroupChat }) existingRoom bareFrom resourceFrom smsJid (Just body) = do
	log "MESSAGE FROM GROUP" (existingRoom, body)
	if fmap bareTxt existingRoom == Just bareFrom && (
	   existingRoom /= parseJID (bareFrom <> fromString "/" <> fromMaybe mempty resourceFrom) ||
	   not (fromString "CHEOGRAM%" `T.isPrefixOf` fromMaybe mempty (messageID m))) then
		writeStanzaChan toVitelity $ mkSMS tel txt
	else
		return [mkStanzaRec $ mkSMS componentJid smsJid txt]
	else do
		log "MESSAGE FROM WRONG GROUP" (fmap bareTxt existingRoom, bareFrom, m)
		return []
	where
	txt = mconcat [fromString "(", fromMaybe (fromString "nonick") resourceFrom, fromString ") ", body]
componentMessage db toVitelity _ (Message { messageFrom = Just from }) existingRoom _ _ tel (Just body) = do
	log "WHISPER" (from, tel, body)
componentMessage db componentJid (Message { messageFrom = Just from }) existingRoom _ _ smsJid (Just body) = do
	log "WHISPER" (from, smsJid, body)
	nick <- nickFor db from existingRoom
	let txt = mconcat [fromString "(", nick, fromString " whispers) ", body]
	writeStanzaChan toVitelity $ mkSMS tel txt
componentMessage _ _ _ m _ _ _ _ _ = log "UNKNOWN MESSAGE" m
	return [mkStanzaRec $ mkSMS componentJid smsJid txt]
componentMessage _ _ m _ _ _ _ _ = do
	log "UNKNOWN MESSAGE" m
	return []

handleJoinPartRoom db toVitelity toRoomPresences toRejoinManager toJoinPartDebouncer toComponent existingRoom from to tel payloads join
handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads join
	| join,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  not $ null $ code "110" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		log "JOINED" (tel, from)
		existingInvite <- tcGetJID db tel "invited"
		log "JOINED" (to, from)
		existingInvite <- tcGetJID db to "invited"
		when (existingInvite == parseJID bareMUC) $ do
			True <- TC.runTCM $ TC.out db $ tcKey tel "invited"
			log "JOINED" (tel, from, "INVITE CLEARED")
			let Just invitedKey = tcKey to "invited"
			True <- TC.runTCM $ TC.out db invitedKey
			log "JOINED" (to, from, "INVITE CLEARED")
			return ()
		tcPutJID db tel "joined" from
		bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (tcKey tel "bookmarks"))
		True <- TC.runTCM (TC.put db (tcKey tel "bookmarks") (show $ sort $ nub $ T.unpack bareMUC : bookmarks))
		tcPutJID db to "joined" from
		let Just bookmarksKey = tcKey to "bookmarks"
		bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db bookmarksKey)
		tcPut db to "bookmarks" (show $ sort $ nub $ T.unpack bareMUC : bookmarks)

		presences <- syncCall toRoomPresences $ GetRoomPresences tel from
		atomically $ writeTChan toRoomPresences $ RecordSelfJoin tel from (Just to)
		presences <- syncCall toRoomPresences $ GetRoomPresences to from
		atomically $ writeTChan toRoomPresences $ RecordSelfJoin to from (Just to)

		atomically $ writeTChan toRejoinManager $ Joined from

		case presences of
			[] -> do -- No one in the room, so we "created"
				log "JOINED" (tel, from, "CREATED")
				log "JOINED" (to, from, "CREATED")
				uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
				let fullid = if (T.unpack resourceFrom `elem` map fst presences) then uuid else "CHEOGRAMCREATE%" <> uuid
				writeStanzaChan toComponent $ (emptyIQ IQGet) {
				return [mkStanzaRec $ (emptyIQ IQGet) {
					iqTo = Just room,
					iqFrom = Just to,
					iqID = Just $ fromString fullid,
					iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/muc#owner}query") [] []
				}
				}]
			(_:_) | isNothing (lookup (T.unpack resourceFrom) presences) -> do
				log "JOINED" (tel, from, resourceFrom, presences, "YOU HAVE JOINED")
				writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
				log "JOINED" (to, from, resourceFrom, presences, "YOU HAVE JOINED")
				fmap ((mkStanzaRec $ mkSMS componentJid smsJid $ mconcat [
						fromString "* You have joined ", bareMUC,
						fromString " as ", resourceFrom,
						fromString " along with\n",
						fromString $ intercalate ", " (filter (/= T.unpack resourceFrom) $ map fst presences)
					]
				queryDisco toComponent room to
					]):)
					(queryDisco room to)
			_ -> do
				log "JOINED" (tel, from, "FALSE PRESENCE")
				queryDisco toComponent room to
				log "JOINED" (to, from, "FALSE PRESENCE")
				queryDisco room to
	| not join,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  (_:_) <- code "303" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		log "CHANGED NICK" (tel, x)
		mapM_ (\nick -> do
			atomically $ writeTChan toRoomPresences $ RecordNickChanged tel from nick
			writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
		log "CHANGED NICK" (to, x)
		let mnick = attributeText (fromString "nick") =<<
			listToMaybe (isNamed (fromString "{http://jabber.org/protocol/muc#user}item") =<< elementChildren x)
		toList <$> forM mnick (\nick -> do
			atomically $ writeTChan toRoomPresences $ RecordNickChanged to from nick
			return $ mkStanzaRec $ mkSMS componentJid smsJid $ mconcat [
					fromString "* ",
					resourceFrom,
					fromString " has changed their nick to ",
					nick
				]
			) $ attributeText (fromString "nick")
				=<< listToMaybe (isNamed (fromString "{http://jabber.org/protocol/muc#user}item") =<< elementChildren x)
			)
	| not join,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  (_:_) <- code "332" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		log "SERVER RESTART, rejoin in 5s" (tel, from)
		void $ forkIO $ threadDelay 5000000 >> atomically (writeTChan toRejoinManager $ ForceRejoin from tel)
		log "SERVER RESTART, rejoin in 5s" (to, from)
		void $ forkIO $ threadDelay 5000000 >> atomically (writeTChan toRejoinManager $ ForceRejoin from to)
		return []
	| not join && existingRoom == Just from = do
		log "YOU HAVE LEFT" (tel, existingRoom)
		True <- TC.runTCM $ TC.out db $ tcKey tel "joined"
		atomically $ writeTChan toRoomPresences $ RecordPart tel from
		atomically $ writeTChan toRoomPresences $ Clear tel from
		writeStanzaChan toVitelity $ mkSMS tel (fromString "* You have left " <> bareMUC)
	| fmap bareTxt existingRoom == Just bareMUC && join = atomically $ writeTChan toJoinPartDebouncer $ DebounceJoin tel from (participantJid payloads)
	| fmap bareTxt existingRoom == Just bareMUC && not join = atomically $ writeTChan toJoinPartDebouncer $ DebouncePart tel from
		log "YOU HAVE LEFT" (to, existingRoom)
		let Just joinedKey = tcKey to "joined"
		True <- TC.runTCM $ TC.out db joinedKey
		atomically $ writeTChan toRoomPresences $ RecordPart to from
		atomically $ writeTChan toRoomPresences $ Clear to from
		return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "* You have left " <> bareMUC)]
	| fmap bareTxt existingRoom == Just bareMUC && join = do
		atomically $ writeTChan toJoinPartDebouncer $ DebounceJoin to from (participantJid payloads)
		return []
	| fmap bareTxt existingRoom == Just bareMUC && not join = do
		atomically $ writeTChan toJoinPartDebouncer $ DebouncePart to from
		return []
	| join = do
		log "UNKNOWN JOIN" (existingRoom, from, to, tel, payloads, join)
		atomically $ writeTChan toRoomPresences $ RecordJoin tel from (participantJid payloads)
		log "UNKNOWN JOIN" (existingRoom, from, to, payloads, join)
		atomically $ writeTChan toRoomPresences $ RecordJoin to from (participantJid payloads)
		return []
	| otherwise = do
		log "UNKNOWN NOT JOIN" (existingRoom, from, to, tel, payloads, join)
		atomically $ writeTChan toRoomPresences $ RecordPart tel from
		log "UNKNOWN NOT JOIN" (existingRoom, from, to, payloads, join)
		atomically $ writeTChan toRoomPresences $ RecordPart to from
		return []
	where
	resourceFrom = fromMaybe mempty (strResource <$> jidResource from)
	Just room = parseJID bareMUC


@@ 313,82 321,84 @@ verificationResponse =
			]
		]

data RegistrationCode = RegistrationCode { regCode :: Int,  tel :: Text, expires :: UTCTime } deriving (Show, Read)
data RegistrationCode = RegistrationCode { regCode :: Int, cheoJid :: Text, expires :: UTCTime } deriving (Show, Read)

sendRegisterVerification db toVitelity toComponent tel iq = do
	log "REGISTERVERIFIFCATION" (tel, iq)
registerVerification db componentJid to iq = do
	log "REGISTERVERIFIFCATION" (to, iq)
	code <- getStdRandom (randomR (123457::Int,987653))
	time <- getCurrentTime
	True <- TC.runTCM $ TC.put db ((maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code") $ show $ RegistrationCode code tel time
	writeStanzaChan toVitelity $ mkSMS tel $ fromString ("Enter this verification code to complete registration: " <> show code)
	writeStanzaChan toComponent $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQResult,
			iqPayload = Just verificationResponse
		}
	True <- TC.runTCM $ TC.put db ((maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code") $ show $ RegistrationCode code (formatJID to) time
	return [
			mkStanzaRec $ mkSMS componentJid to $ fromString ("Enter this verification code to complete registration: " <> show code),
			mkStanzaRec $ iq {
				iqTo = iqFrom iq,
				iqFrom = iqTo iq,
				iqType = IQResult,
				iqPayload = Just verificationResponse
			}
		]

handleVerificationCode db toComponent componentHost password iq = do
handleVerificationCode db componentJid password iq = do
	time <- getCurrentTime
	codeAndTime <- fmap (readZ =<<) $ TC.runTCM $ TC.get db regKey
	log "HANDLEVERIFICATIONCODE" (password, iq, time, codeAndTime)
	if (fmap expires codeAndTime > Just ((-300) `addUTCTime` time)) then
		forM_ codeAndTime $ \RegistrationCode { regCode = code, tel = tel } ->
		case (show code == T.unpack password, iqTo iq, iqFrom iq) of
			(True, Just to, Just from) -> do
				writeStanzaChan toComponent $ iq {
					iqTo = iqFrom iq,
					iqFrom = iqTo iq,
					iqType = IQResult,
					iqPayload = Just $ Element (fromString "{jabber:iq:register}query") [] []
				}

				bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (tcKey tel "bookmarks"))
				forM_ (mapMaybe parseJID bookmarks) $ \bookmark ->
					sendInvite db toComponent from (Invite bookmark (fromMaybe to $ telToJid tel (formatJID to)) (Just $ fromString "Cheogram registration") Nothing)

				True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) <> "\0registered") (T.unpack tel)
				tcPutJID db tel "registered" from

				-- If there is a nick that doesn't end in _sms, add _sms
				nick <- TC.runTCM (TC.get db $ tcKey tel "nick")
				forM_ nick $ \nick -> do
					let nick' = (fromMaybe (fromString nick) $ T.stripSuffix (fromString "_sms") (fromString nick)) <> fromString "_sms"

					existingRoom <- (parseJID <=< fmap bareTxt) <$> tcGetJID db tel "joined"
					forM_ existingRoom $ \room -> do
						let toJoin = parseJID (bareTxt room <> fromString "/" <> nick')
						forM_ toJoin $ joinRoom db toComponent componentHost tel

					True <- TC.runTCM (TC.put db (tcKey tel "nick") (T.unpack nick'))
					return ()
			_ ->
				writeStanzaChan toComponent $ iq {
					iqTo = iqFrom iq,
					iqFrom = iqTo iq,
					iqType = IQError,
					iqPayload = Just $ Element (fromString "{jabber:component:accept}error")
						[(fromString "{jabber:component:accept}type", [ContentText $ fromString "auth"])]
						[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}not-authorized") [] []]
				}
	else
		void $ TC.runTCM $ TC.out db regKey
	case codeAndTime of
		Just (RegistrationCode { regCode = code, cheoJid = cheoJidT })
			| fmap expires codeAndTime > Just ((-300) `addUTCTime` time) ->
				case (show code == T.unpack password, iqTo iq, iqFrom iq, parseJID cheoJidT) of
					(True, Just to, Just from, Just cheoJid) -> do
						bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "bookmarks"))
						invites <- fmap concat $ forM (mapMaybe parseJID bookmarks) $ \bookmark ->
							sendInvite db from (Invite bookmark cheoJid (Just $ fromString "Cheogram registration") Nothing)

						let Just tel = T.unpack . strNode <$> jidNode cheoJid
						True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) <> "\0registered") tel
						tcPutJID db cheoJid "registered" from

						stuff <- runMaybeT $ do
							-- If there is a nick that doesn't end in _sms, add _sms
							nick <- MaybeT . TC.runTCM . TC.get db =<< (hoistMaybe $ tcKey cheoJid "nick")
							let nick' = (fromMaybe (fromString nick) $ T.stripSuffix (fromString "_sms") (fromString nick)) <> fromString "_sms"
							tcPut db cheoJid "nick" (T.unpack nick')

							room <- MaybeT ((parseJID <=< fmap bareTxt) <$> tcGetJID db cheoJid "joined")
							toJoin <- hoistMaybe $ parseJID (bareTxt room <> fromString "/" <> nick')
							liftIO $ joinRoom db cheoJid toJoin

						return ((mkStanzaRec $ iq {
								iqTo = iqFrom iq,
								iqFrom = iqTo iq,
								iqType = IQResult,
								iqPayload = Just $ Element (fromString "{jabber:iq:register}query") [] []
							}):invites)
					_ ->
						return [mkStanzaRec $ iq {
							iqTo = iqFrom iq,
							iqFrom = iqTo iq,
							iqType = IQError,
							iqPayload = Just $ Element (fromString "{jabber:component:accept}error")
								[(fromString "{jabber:component:accept}type", [ContentText $ fromString "auth"])]
								[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}not-authorized") [] []]
						}]
		_ -> do
			void $ TC.runTCM $ TC.out db regKey
			return []
	where
	regKey = (maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code"

handleRegister db _ toComponent _ iq@(IQ { iqType = IQGet }) _ = do
handleRegister db componentJid iq@(IQ { iqType = IQGet }) _ = do
	time <- getCurrentTime
	codeAndTime <- fmap (readZ =<<) $ TC.runTCM $ TC.get db ((maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code")
	log "HANDLEREGISTER IQGet" (time, codeAndTime, iq)
	if fmap expires codeAndTime > Just ((-300) `addUTCTime` time) then
		writeStanzaChan toComponent $ iq {
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQResult,
			iqPayload = Just verificationResponse
		}
		}]
	else
		writeStanzaChan toComponent $ iq {
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQResult,


@@ 418,66 428,68 @@ handleRegister db _ toComponent _ iq@(IQ { iqType = IQGet }) _ = do
						] []
					]
				]
		}
handleRegister db toVitelity toComponent _ iq@(IQ { iqType = IQSet }) query
		}]
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query,
	  Just tel <- (normalizeTel . T.filter isDigit) =<< getFormField form (fromString "phone") = do
	  Just to <- ((`telToJid` formatJID componentJid) . T.filter isDigit) =<< getFormField form (fromString "phone") = do
		log "HANDLEREGISTER IQSet jabber:x:data phone" iq
		sendRegisterVerification db toVitelity toComponent tel iq
handleRegister db toVitelity toComponent _ iq@(IQ { iqType = IQSet }) query
		registerVerification db componentJid to iq
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
	| [phoneEl] <- isNamed (fromString "{jabber:iq:register}phone") =<< elementChildren query,
	  Just tel <- normalizeTel $ T.filter isDigit $ mconcat (elementText phoneEl) = do
	  Just to <- (`telToJid` formatJID componentJid) $ T.filter isDigit $ mconcat (elementText phoneEl) = do
		log "HANDLEREGISTER IQSet jabber:iq:register phone" iq
		sendRegisterVerification db toVitelity toComponent tel iq
handleRegister db toVitelity toComponent componentHost iq@(IQ { iqType = IQSet }) query
		registerVerification db componentJid to iq
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query,
	  Just password <- getFormField form (fromString "password") = do
		log "HANDLEREGISTER IQSet jabber:x:data password" iq
		handleVerificationCode db toComponent componentHost password iq
handleRegister db toVitelity toComponent componentHost iq@(IQ { iqType = IQSet, iqPayload = Just payload }) query
		handleVerificationCode db componentJid password iq
handleRegister db componentJid iq@(IQ { iqType = IQSet, iqPayload = Just payload }) query
	| [passwordEl] <- isNamed (fromString "{jabber:iq:register}password") =<< elementChildren query = do
		log "HANDLEREGISTER IQSet jabber:iq:register password" iq
		handleVerificationCode db toComponent componentHost (mconcat $ elementText passwordEl) iq
handleRegister db _ toComponent _ iq@(IQ { iqType = IQSet }) query
		handleVerificationCode db componentJid (mconcat $ elementText passwordEl) iq
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
	| [_] <- isNamed (fromString "{jabber:iq:register}remove") =<< elementChildren query = do
		log "HANDLEREGISTER IQSet jabber:iq:register remove" iq
		tel <- maybe mempty T.pack <$> TC.runTCM (TC.get db $ T.unpack (maybe mempty bareTxt $ iqFrom iq) <> "\0registered")
		_ <- TC.runTCM $ TC.out db $ tcKey tel "registered"
		_ <- TC.runTCM $ TC.out db $ T.unpack (maybe mempty bareTxt $ iqFrom iq) <> "\0registered"
		writeStanzaChan toComponent $ iq {
		forM_ (telToJid tel (formatJID componentJid) >>= \cheoJid -> tcKey cheoJid "registered") $ \regKey ->
			TC.runTCM $ TC.out db regKey
		void $ TC.runTCM $ TC.out db $ T.unpack (maybe mempty bareTxt $ iqFrom iq) <> "\0registered"
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQResult,
			iqPayload = Just $ Element (fromString "{jabber:iq:register}query") [] []
		}
handleRegister _ _ toComponent _ iq@(IQ { iqType = typ }) _
		}]
handleRegister _ _ iq@(IQ { iqType = typ }) _
	| typ `elem` [IQGet, IQSet] = do
		log "HANDLEREGISTER return error" iq
		writeStanzaChan toComponent $ iq {
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQError,
			iqPayload = Just $ Element (fromString "{jabber:component:accept}error")
				[(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
				[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented") [] []]
		}
handleRegister _ _ _ _ _ iq = log "HANDLEREGISTER UNKNOWN" iq
		}]
handleRegister _ _ iq _ = do
	log "HANDLEREGISTER UNKNOWN" iq
	return []

componentStanza _ _ _ _ _ toComponent _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
componentStanza _ _ _ _ _ _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
	| [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< messagePayloads m,
	  not $ null $ code "104" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		log "CODE104" (to, from)
		queryDisco toComponent from to
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
		queryDisco from to
componentStanza db mapToBackend _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
	| Just smsJid <- mapToBackend to = do
		log "RECEIVEDMESSAGE" m
		existingRoom <- tcGetJID db tel "joined"
		componentMessage db toVitelity toComponent m existingRoom (bareTxt from) resourceFrom tel $
		existingRoom <- tcGetJID db to "joined"
		componentMessage db componentJid m existingRoom (bareTxt from) resourceFrom smsJid $
			getBody "jabber:component:accept" m
	| Just jid <- (`telToJid` fromString componentHost) =<< strNode <$> jidNode to = do
	| Just jid <- (`telToJid` formatJID componentJid) =<< strNode <$> jidNode to = do
		log "MESSAGE INVALID JID" m
		writeStanzaChan toComponent $ m {
		return [mkStanzaRec $ m {
			messageFrom = Just to,
			messageTo = Just from,
			messageType = MessageError,


@@ 492,10 504,10 @@ componentStanza db toVitelity _ _ _ toComponent componentHost (ReceivedMessage (
						[NodeContent $ ContentText $ fromString "JID must include country code: " <> formatJID jid]
				]
			]
		}
		}]
	| otherwise = do
		log "MESSAGE UNKNOWN JID" m
		writeStanzaChan toComponent $ m {
		return [mkStanzaRec $ m {
			messageFrom = Just to,
			messageTo = Just from,
			messageType = MessageError,


@@ 504,43 516,46 @@ componentStanza db toVitelity _ _ _ toComponent componentHost (ReceivedMessage (
				[(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
				[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}item-not-found") [] []]
			]
		}
		}]
	where
	resourceFrom = strResource <$> jidResource from
componentStanza _ toVitelity _ toRejoinManager _ _ _ (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to, presenceID = Just id }))
	| fromString "CHEOGRAMREJOIN%" `T.isPrefixOf` id,
	  Just tel <- strNode <$> jidNode to = do
componentStanza _ mapToBackend _ toRejoinManager _ componentJid (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to, presenceID = Just id }))
	| fromString "CHEOGRAMREJOIN%" `T.isPrefixOf` id = do
		log "FAILED TO REJOIN, try again in 10s" p
		void $ forkIO $ threadDelay 10000000 >> atomically (writeTChan toRejoinManager $ ForceRejoin from tel)
	| Just tel <- strNode <$> jidNode to = do
		void $ forkIO $ threadDelay 10000000 >> atomically (writeTChan toRejoinManager $ ForceRejoin from to)
		return []
	| Just smsJid <- mapToBackend 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 toRoomPresences toRejoinManager toJoinPartDebouncer toComponent _ (ReceivedPresence (Presence {
		return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "* Failed to join " <> bareTxt from <> errorText)]
componentStanza db mapToBackend toRoomPresences toRejoinManager toJoinPartDebouncer componentJid (ReceivedPresence (Presence {
		presenceType = typ,
		presenceFrom = Just from,
		presenceTo = Just to@(JID { jidNode = Just toNode }),
		presenceTo = Just to,
		presencePayloads = payloads
	})) | typ `elem` [PresenceAvailable, PresenceUnavailable] = do
		existingRoom <- tcGetJID db (strNode toNode) "joined"
	})) | typ `elem` [PresenceAvailable, PresenceUnavailable],
	      Just smsJid <- mapToBackend to = do
		existingRoom <- tcGetJID db to "joined"
		log "JOIN PART ROOM" (from, to, typ, existingRoom, payloads)
		handleJoinPartRoom db toVitelity toRoomPresences toRejoinManager 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
		handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads (typ == PresenceAvailable)
componentStanza _ _ _ _ _ _ (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,
		presenceFrom = Just to
	}
	log "SUBSCRIBE" (from, to)
	writeStanzaChan toComponent $ (emptyPresence PresenceSubscribe) {
		presenceTo = Just from,
		presenceFrom = Just to
	}
componentStanza _ _ _ _ _ toComponent _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
	return [
			mkStanzaRec $ (emptyPresence PresenceSubscribed) {
				presenceTo = Just from,
				presenceFrom = Just to
			},
			mkStanzaRec $ (emptyPresence PresenceSubscribe) {
				presenceTo = Just from,
				presenceFrom = Just to
			}
		]
componentStanza _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
	log "RESPOND TO PROBES" (from, to)
	writeStanzaChan toComponent $ (emptyPresence PresenceAvailable) {
	return [mkStanzaRec $ (emptyPresence PresenceAvailable) {
		presenceTo = Just from,
		presenceFrom = Just to,
		presencePayloads = [


@@ 551,17 566,17 @@ componentStanza _ _ _ _ _ toComponent _ (ReceivedPresence (Presence { presenceTy
				(fromString "{http://jabber.org/protocol/caps}ver", [ContentText $ fromString "4/LEvjGRsHBQRu9D+1NwytYdFUY="])
			] []
		]
	}
componentStanza db toVitelity _ _ _ toComponent componentHost (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p }))
	}]
componentStanza db _ _ _ _ componentJid (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 }))
		handleRegister db componentJid iq query
componentStanza _ _ _ _ _ _ (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)
		writeStanzaChan toComponent $ (emptyIQ IQResult) {
		return [mkStanzaRec $ (emptyIQ IQResult) {
			iqTo = Just from,
			iqFrom = Just to,
			iqID = id,


@@ 582,12 597,12 @@ componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom
						(fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "urn:xmpp:ping"])
					] []
				]
		}
componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p }))
		}]
componentStanza _ _ _ _ _ _ (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)
		writeStanzaChan toComponent $ (emptyIQ IQResult) {
		return [mkStanzaRec $ (emptyIQ IQResult) {
			iqTo = Just from,
			iqFrom = Just to,
			iqID = id,


@@ 603,22 618,22 @@ componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom
						(fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "urn:xmpp:ping"])
					] []
				]
		}
componentStanza _ _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQSet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p }))
		}]
componentStanza _ _ _ _ _ componentJid (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)
		case telToJid (T.filter isDigit $ mconcat $ elementText prompt) (fromString componentHost) of
		case telToJid (T.filter isDigit $ mconcat $ elementText prompt) (formatJID componentJid) of
			Just jid ->
				writeStanzaChan toComponent $ (emptyIQ IQResult) {
				return [mkStanzaRec $ (emptyIQ IQResult) {
					iqTo = Just from,
					iqFrom = Just to,
					iqID = id,
					iqPayload = Just $ Element (fromString "{jabber:iq:gateway}query") []
						[NodeElement $ Element (fromString "{jabber:iq:gateway}jid") [ ] [NodeContent $ ContentText $ formatJID jid]]
				}
				}]
			Nothing ->
				writeStanzaChan toComponent $ iq {
				return [mkStanzaRec $ iq {
					iqTo = Just from,
					iqFrom = Just to,
					iqType = IQError,


@@ 630,11 645,11 @@ componentStanza _ _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType 
								[(fromString "xml:lang", [ContentText $ fromString "en"])]
								[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 _ _ _ _ _ _ (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) {
		return [mkStanzaRec $ (emptyIQ IQResult) {
			iqTo = Just from,
			iqFrom = Just to,
			iqID = id,


@@ 643,45 658,51 @@ componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom
					NodeElement $ Element (fromString "{jabber:iq:gateway}desc") [ ] [NodeContent $ ContentText $ fromString "Please enter your contact's phone number"],
					NodeElement $ Element (fromString "{jabber:iq:gateway}prompt") [ ] [NodeContent $ ContentText $ fromString "Phone Number"]
				]
		}
componentStanza db _ _ _ _ toComponent componentHost (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to }))
		}]
componentStanza db _ _ _ _ componentJid (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)
		case T.splitOn (fromString "|") resource of
			(tel:_) -> do
				nick <- maybe tel fromString <$> TC.runTCM (TC.get db $ tcKey tel "nick")
			(cheoJidT:_) | Just cheoJid <- parseJID cheoJidT -> do
				mnick <- maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "nick")
				let nick = maybe (maybe mempty strNode (jidNode cheoJid)) fromString mnick
				let Just room = parseJID $ bareTxt from <> fromString "/" <> nick
				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 }))
				(++) <$>
					leaveRoom db cheoJid "Joined a different room." <*>
					joinRoom db cheoJid room
			_ -> return [] -- Invalid packet, ignore
componentStanza _ _ _ _ _ componentJid (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)
		case map T.unpack $ T.splitOn (fromString "|") resource of
			(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 _ _ _ toRejoinManager _ _ _ (ReceivedIQ (iq@IQ { iqType = IQResult, iqID = Just id, iqFrom = Just from }))
		case T.splitOn (fromString "|") resource of
			(cheoJidT:name:[]) | Just cheoJid <- parseJID cheoJidT, Just tel <- strNode <$> jidNode cheoJid ->
				createRoom componentJid [strDomain $ jidDomain from] cheoJid (name <> fromString "_" <> tel)
			(cheoJidT:name:servers) | Just cheoJid <- parseJID cheoJidT ->
				createRoom componentJid servers cheoJid name
			_ -> return [] -- Invalid packet, ignore
componentStanza _ _ _ toRejoinManager _ _ (ReceivedIQ (iq@IQ { iqType = IQResult, iqID = Just id, iqFrom = Just from }))
	| fromString "CHEOGRAMPING%" `T.isPrefixOf` id = do
		log "PING RESULT" from
		atomically $ writeTChan toRejoinManager (PingReply from)
componentStanza _ _ _ toRejoinManager _ _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqID = Just id, iqFrom = Just from }))
		return []
componentStanza _ _ _ toRejoinManager _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqID = Just id, iqFrom = Just from }))
	| fromString "CHEOGRAMPING%" `T.isPrefixOf` id = do
		log "PING ERROR RESULT" from
		atomically $ writeTChan toRejoinManager (PingError from)
componentStanza _ toVitelity _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to }))
	| Just tel <- strNode <$> jidNode to = do
		return []
componentStanza _ mapToBackend _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to }))
	| Just smsJid <- mapToBackend 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 }))
		return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "Error while querying or configuring " <> formatJID from)]
componentStanza _ _ _ _ _ _ (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)
		uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
		let fullid = if fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id then "CHEOGRAMCREATE%" <> uuid else uuid
		writeStanzaChan toComponent $ (emptyIQ IQSet) {
		return [mkStanzaRec $ (emptyIQ IQSet) {
			iqTo = Just from,
			iqFrom = Just to,
			iqID = Just $ fromString fullid,


@@ 693,46 714,51 @@ componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQResult, iqF
				fillFormField (fromString "muc#roomconfig_membersonly") (fromString "1")
				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 }))
	| Just tel <- strNode <$> jidNode to,
		}]
componentStanza _ mapToBackend _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id }))
	| Just smsJid <- mapToBackend 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 }))
	| Just tel <- strNode <$> jidNode to,
		fmap (((mkStanzaRec $ mkSMS componentJid smsJid (mconcat [fromString "* You have created ", bareTxt from])):) . concat . toList) $
			forM (parseJID $ bareTxt to <> fromString "/create") $
				queryDisco from
componentStanza db _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p }))
	| Just _ <- strNode <$> jidNode to,
	  [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
		log "DISCO RESULT" (from, to, p)
		let vars = mapMaybe (attributeText (fromString "var")) $
			isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query
		let muc_membersonly = fromEnum $ fromString "muc_membersonly" `elem` vars
		True <- TC.runTCM $ TC.put db (T.unpack (formatJID from) <> "\0muc_membersonly") muc_membersonly
		when (fmap strResource (jidResource to) == Just (fromString "create")) $ do
			regJid <- tcGetJID db tel "registered"
			forM_ regJid $ \jid -> forM_ (parseJID $ bareTxt to) $ \to -> sendInvite db toComponent jid (Invite from to Nothing Nothing)
componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqPayload = Just p }))
		if (fmap strResource (jidResource to) == Just (fromString "create")) then do
			regJid <- tcGetJID db to "registered"
			fmap (concat . toList) $ forM ((,) <$> regJid <*> parseJID (bareTxt to)) $ \(jid, to) ->
				sendInvite db jid (Invite from to Nothing Nothing)
		else
			return []
componentStanza _ _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqPayload = Just p }))
	| not $ null $ isNamed (fromString "{urn:xmpp:ping}ping") p = do
		log "urn:xmpp:ping" (from, to)
		writeStanzaChan toComponent $ iq {
		return [mkStanzaRec $ iq {
			iqTo = Just from,
			iqFrom = Just to,
			iqType = IQResult,
			iqPayload = Nothing
		}
componentStanza _ _ _ _ _ toComponent _ (ReceivedIQ (iq@IQ { iqType = typ }))
		}]
componentStanza _ _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = typ }))
	| typ `elem` [IQGet, IQSet] = do
		log "REPLY WITH IQ ERROR" iq
		writeStanzaChan toComponent $ iq {
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQError,
			iqPayload = Just $ Element (fromString "{jabber:component:accept}error")
				[(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 = do
	log "UNKNOWN STANZA" s
	return []

participantJid payloads =
	listToMaybe $ mapMaybe (parseJID <=< attributeText (fromString "jid")) $


@@ 740,21 766,44 @@ participantJid payloads =
	elementChildren =<<
	isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads

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

		case (stanzaFrom stanza, stanzaTo stanza) of
			(Just from, Just to)
				| strDomain (jidDomain to) == backendHost,
				  from == componentJid ->
					forM_ (tcKey to "welcomed") $ \welcomedKey -> do
						welcomed <- maybe False toEnum <$> liftIO (TC.runTCM $ TC.get db welcomedKey)
						unless welcomed $ do
							putStanza $ mkSMS componentJid to $ fromString "Welcome to CheoGram! You can chat with groups of friends (one at a time), by replying to this number. Reply with /help to learn more or visit cheogram.com"
							tcPut db to "welcomed" (fromEnum True)
			_ -> return ()

		putStanza stanza

	flip catchError (\e -> liftIO (log "component part 2 EXCEPTION" e >> killThread thread)) $ forever $ do
		s <- getStanza
		log "COMPONENT  IN" s
		liftIO $ componentStanza db toVitelity toRoomPresences toRejoinManager toJoinPartDebouncer toComponent componentHost s
		liftIO $ case s of
			(ReceivedMessage m@(Message { messageFrom = Just from, messageTo = Just to }))
				| strDomain (jidDomain from) == backendHost,
				  messageType m /= MessageError,
				  Just txt <- getBody "jabber:component:accept" m,
				  Just cheoJid <- mapToComponent from ->
					mapM_ sendToComponent =<< processSMS db componentJid conferenceServers from cheoJid txt
			_ ->
				mapM_ sendToComponent =<< componentStanza db (mapToBackend backendHost) toRoomPresences toRejoinManager toJoinPartDebouncer componentJid s
	where
	mapToComponent = mapToBackend (formatJID componentJid)
	sendToComponent = atomically . writeTChan toComponent

telToVitelity tel
	| not $ all isDigit $ T.unpack tel = Nothing
	| T.length tel == 10 = parseJID (tel <> fromString "@sms")
	| T.length tel == 11, Just tel' <- T.stripPrefix (fromString "1") tel = parseJID (tel' <> fromString "@sms")
mapToBackend backendHost jid
	| Just localpart <- strNode <$> jidNode jid,
	  Just ('+', tel) <- T.uncons localpart,
	  T.all isDigit tel = parseJID (localpart <> fromString "@" <> backendHost)
	| otherwise = Nothing

normalizeTel tel


@@ 777,14 826,14 @@ stripCIPrefix prefix str
	where
	(prefix', rest) = T.splitAt (T.length $ CI.original prefix) str

data Command = Help | Create Text | Join JID | JoinInvited | JoinInvitedWrong | Debounce Int | Send Text | Who | List | Leave | InviteCmd JID | SetNick Text | Whisper JID Text | VitelityBogus Text
data Command = Help | Create Text | Join JID | JoinInvited | JoinInvitedWrong | Debounce Int | Send Text | Who | List | Leave | InviteCmd JID | SetNick Text | Whisper JID Text
	deriving (Show, Eq)

parseCommand txt room nick componentHost
parseCommand txt room nick componentJid
	| Just jid <- stripCIPrefix (fromString "/invite ") txt =
		InviteCmd <$> (
			parseJIDrequireNode jid <|>
			telToJid jid (fromString componentHost)
			telToJid jid (formatJID componentJid)
		)
	| Just room <- stripCIPrefix (fromString "/join ") txt =
		Join <$> (parseJID (room <> fromString "/" <> nick) <|> parseJID room)


@@ 794,11 843,11 @@ parseCommand txt room nick componentHost
		let (to, msg) = T.breakOn (fromString " ") input in
		Whisper <$> (
			parseJIDrequireNode to <|>
			telToJid to (fromString componentHost) <|>
			telToJid to (formatJID componentJid) <|>
			(parseJID =<< fmap (\r -> bareTxt r <> fromString "/" <> to) room)
		) <*> pure msg
	| Just stime <- stripCIPrefix (fromString "/debounce ") txt,
	  Just time <- readMay stime = Just $ Debounce time
	  Just time <- readMay (textToString stime) = Just $ Debounce time
	| citxt == fromString "/join" = Just JoinInvited
	| citxt == fromString "join" = Just JoinInvitedWrong
	| citxt == fromString "/leave" = Just Leave


@@ 806,7 855,6 @@ parseCommand txt room nick componentHost
	| citxt == fromString "/who" = Just Who
	| citxt == fromString "/list" = Just List
	| citxt == fromString "/help" = Just Help
	| citxt == fromString "You are not authorized to send SMS messages." = Just $ VitelityBogus txt
	| otherwise = Just $ Send txt
	where
	citxt = CI.mk txt


@@ 814,51 862,51 @@ parseCommand txt room nick componentHost
getMessage (ReceivedMessage m) = Just m
getMessage _ = Nothing

sendToRoom toComponent componentHost tel room msg = do
	log "SEND TO ROOM" (tel, room, msg)
sendToRoom cheoJid room msg = do
	log "SEND TO ROOM" (cheoJid, room, msg)
	uuid <- (fmap.fmap) UUID.toString UUID.nextUUID
	writeStanzaChan toComponent $ (emptyMessage MessageGroupChat) {
	return [mkStanzaRec $ (emptyMessage MessageGroupChat) {
		messageTo = parseJID $ bareTxt room,
		messageFrom = telToJid tel (fromString componentHost),
		messageFrom = Just cheoJid,
		messageID = Just $ fromString ("CHEOGRAM%" <> fromMaybe "UUIDFAIL" uuid),
		messagePayloads = [Element (fromString "{jabber:component:accept}body") [] [NodeContent $ ContentText msg]]
	}

leaveRoom db toComponent componentHost tel reason = do
	existingRoom <- tcGetJID db tel "joined"
	log "LEAVE ROOM" (existingRoom, tel, reason)
	forM_ existingRoom $ \leaveRoom -> do
		writeStanzaChan toComponent $ (emptyPresence PresenceUnavailable) {
	}]

leaveRoom :: TC.HDB -> JID -> String -> IO [StanzaRec]
leaveRoom db cheoJid reason = do
	existingRoom <- tcGetJID db cheoJid "joined"
	log "LEAVE ROOM" (existingRoom, cheoJid, reason)
	return $ (flip map) (toList existingRoom) $ \leaveRoom ->
		mkStanzaRec $ (emptyPresence PresenceUnavailable) {
			presenceTo = Just leaveRoom,
			presenceFrom = telToJid tel (fromString componentHost),
			presenceFrom = Just cheoJid,
			presencePayloads = [Element (fromString "{jabber:component:accept}status") [] [NodeContent $ ContentText $ fromString reason]]
		}
		return ()

joinRoom db toComponent componentHost tel room =
	rejoinRoom db toComponent componentHost tel room False
joinRoom db cheoJid room =
	rejoinRoom db cheoJid room False

rejoinRoom db toComponent componentHost tel room rejoin = do
	log "JOIN ROOM" (room, tel)
	password <- TC.runTCM $ TC.get db (tcKey tel (T.unpack (bareTxt room) <> "\0muc_roomsecret"))
rejoinRoom db cheoJid room rejoin = do
	log "JOIN ROOM" (room, cheoJid)
	password <- maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid (T.unpack (bareTxt room) <> "\0muc_roomsecret"))
	let pwEl = maybe [] (\pw -> [
			NodeElement $ Element (fromString "{http://jabber.org/protocol/muc}password") [] [NodeContent $ ContentText $ fromString pw]
		]) password

	uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
	writeStanzaChan toComponent $ (emptyPresence PresenceAvailable) {
	return [mkStanzaRec $ (emptyPresence PresenceAvailable) {
		presenceID = Just $ fromString $ (if rejoin then "CHEOGRAMREJOIN%" else "") <> uuid,
		presenceTo = Just room,
		presenceFrom = telToJid tel (fromString componentHost),
		presenceFrom = Just cheoJid,
		presencePayloads = [Element (fromString "{http://jabber.org/protocol/muc}x") [] ([
			NodeElement $ Element (fromString "{http://jabber.org/protocol/muc}history") [(fromString "{http://jabber.org/protocol/muc}maxchars", [ContentText $ fromString "0"])] []
		] <> pwEl)]
	}
	}]

addMUCOwner toComponent room from jid = do
addMUCOwner room from jid = do
	log "ADD MUC OWNER" (room, from, jid)
	uuid <- (fmap.fmap) UUID.toString UUID.nextUUID
	writeStanzaChan toComponent $ (emptyIQ IQSet) {
	return [mkStanzaRec $ (emptyIQ IQSet) {
		iqTo = Just room,
		iqFrom = Just from,
		iqID = fmap fromString uuid,


@@ 869,214 917,164 @@ addMUCOwner toComponent room from jid = do
					(fromString "{http://jabber.org/protocol/muc#admin}jid", [ContentText $ formatJID jid])
				] []
		]
	}
	}]

createRoom :: TChan StanzaRec -> String -> [String] -> String -> String -> IO Bool
createRoom toComponent componentHost (server:otherServers) tel name = do
	log "START CREATE ROOM" (name, tel, server:otherServers)
createRoom :: JID -> [Text] -> JID -> Text -> IO [StanzaRec]
createRoom componentJid (server:otherServers) cheoJid name
	-- First we check if this room exists on the server already
	case to of
		Just t -> queryDisco toComponent t jid >> return True
		Nothing -> return False
	| Just t <- to = queryDisco t jid
	| otherwise = return []
	where
	to = parseJID $ fromString $ name <> "@" <> server
	Just jid = parseJID $ fromString $ "create@" <> componentHost <> "/" <> intercalate "|" (tel:name:otherServers)
createRoom _ _ [] _ _ = return False
	to = parseJID $ name <> fromString "@" <> server
	Just jid = parseJID $ fromString "create@" <> formatJID componentJid <> fromString "/" <> intercalate (fromString "|") ((formatJID cheoJid):name:otherServers)
createRoom _ [] _ _ = return []

mucShortMatch tel short muc =
	node == short || T.stripSuffix (fromString "_" <> tel) node == Just short
	where
	node = maybe mempty strNode (jidNode =<< parseJID muc)

sendInvite db toComponent to (Invite { inviteMUC = room, inviteFrom = from }) = do
sendInvite db to (Invite { inviteMUC = room, inviteFrom = from }) = do
	log "SEND INVITE" (room, to, from)
	membersonly <- maybe False toEnum <$> TC.runTCM (TC.get db (T.unpack (bareTxt room) <> "\0muc_membersonly"))
	when membersonly $
		-- Try to add everyone we invite as an owner also
		addMUCOwner toComponent room from to

	writeStanzaChan toComponent $ (emptyMessage MessageNormal) {
		messageTo = Just room,
		messageFrom = Just from,
		messagePayloads = [
			Element (fromString "{http://jabber.org/protocol/muc#user}x") [] [
				NodeElement $ Element (fromString "{http://jabber.org/protocol/muc#user}invite") [
					(fromString "{http://jabber.org/protocol/muc#user}to", [ContentText $ formatJID to])
				] []
	-- Try to add everyone we invite as an owner also
	(++) <$> (if membersonly then addMUCOwner room from to else return []) <*>
		return [
				mkStanzaRec $ (emptyMessage MessageNormal) {
					messageTo = Just room,
					messageFrom = Just from,
					messagePayloads = [
						Element (fromString "{http://jabber.org/protocol/muc#user}x") [] [
							NodeElement $ Element (fromString "{http://jabber.org/protocol/muc#user}invite") [
								(fromString "{http://jabber.org/protocol/muc#user}to", [ContentText $ formatJID to])
							] []
						]
					]
				},

				mkStanzaRec $ (emptyMessage MessageNormal) {
					messageTo = Just to,
					messageFrom = Just from,
					messagePayloads = [
						Element (fromString "{jabber:x:conference}x") [
							(fromString "{jabber:x:conference}jid", [ContentText $ formatJID room])
						] [],
						Element (fromString "{jabber:component:accept}body") []
							[NodeContent $ ContentText $ mconcat [formatJID from, fromString " has invited you to join ", formatJID room]]
					]
				}
			]
		]
	}

	writeStanzaChan toComponent $ (emptyMessage MessageNormal) {
		messageTo = Just to,
		messageFrom = Just from,
		messagePayloads = [
			Element (fromString "{jabber:x:conference}x") [
				(fromString "{jabber:x:conference}jid", [ContentText $ formatJID room])
			] [],
			Element (fromString "{jabber:component:accept}body") []
				[NodeContent $ ContentText $ mconcat [formatJID from, fromString " has invited you to join ", formatJID room]]
		]
	}
registerToGateway componentJid gatewayJid did password = return [
		mkStanzaRec $ (emptyIQ IQSet) {
			iqTo = Just gatewayJid,
			iqFrom = Just componentJid,
			iqPayload = Just $ Element (fromString "{jabber:iq:register}query") []
				[
					NodeElement $ Element (fromString "{jabber:iq:register}phone") [] [NodeContent $ ContentText did],
					NodeElement $ Element (fromString "{jabber:iq:register}password") [] [NodeContent $ ContentText password]
				]
		}
	]

processSMS db toVitelity toComponent componentHost conferenceServers tel txt = do
	nick <- maybe tel fromString <$> TC.runTCM (TC.get db $ tcKey tel "nick")
	existingRoom <- (parseJID <=< fmap bareTxt) <$> tcGetJID db tel "joined"
	case parseCommand txt existingRoom nick componentHost of
processSMS db componentJid conferenceServers smsJid cheoJid txt = do
	nick <- maybe (maybe (formatJID cheoJid) strNode (jidNode cheoJid)) fromString <$> maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "nick")
	existingRoom <- (parseJID <=< fmap bareTxt) <$> tcGetJID db cheoJid "joined"
	case parseCommand txt existingRoom nick componentJid of
		Just JoinInvited -> do
			invitedRoom <- tcGetJID db tel "invited"
			invitedRoom <- tcGetJID db cheoJid "invited"
			let toJoin = invitedRoom >>= \jid -> parseJID (bareTxt jid <> fromString "/" <> nick)
			case toJoin of
				Just room -> do
					leaveRoom db toComponent componentHost tel "Joined a different room."
					joinRoom db toComponent componentHost tel room
				Nothing -> writeStanzaChan toVitelity $ mkSMS tel (fromString "You have not recently been invited to a group")
				Just room ->
					(++) <$>
					leaveRoom db cheoJid "Joined a different room." <*>
					joinRoom db cheoJid room
				Nothing -> return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "You have not recently been invited to a group")]
		Just JoinInvitedWrong
			| Just room <- existingRoom -> sendToRoom toComponent componentHost tel room (fromString "Join")
			| Just room <- existingRoom -> sendToRoom cheoJid room (fromString "Join")
			| otherwise -> do
				invitedRoom <- tcGetJID db tel "invited"
				invitedRoom <- tcGetJID db cheoJid "invited"
				let toJoin = invitedRoom >>= \jid -> parseJID (bareTxt jid <> fromString "/" <> nick)
				case toJoin of
					Just room -> do
						writeStanzaChan toVitelity $ mkSMS tel (fromString "I think you meant \"/join\", trying anyway...")
						joinRoom db toComponent componentHost tel room
					Nothing -> writeStanzaChan toVitelity $ mkSMS tel (fromString "You have not recently been invited to a group")
					Just room ->
						fmap ((mkStanzaRec $ mkSMS componentJid smsJid (fromString "I think you meant \"/join\", trying anyway...")):)
						(joinRoom db cheoJid room)
					Nothing -> return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "You have not recently been invited to a group")]
		Just (Create name) -> do
			servers <- shuffleM conferenceServers
			validRoom <- createRoom toComponent componentHost servers (T.unpack tel) (T.unpack name)
			unless validRoom $
				writeStanzaChan toVitelity $ mkSMS tel (fromString "Invalid group name")
			roomCreateStanzas <- createRoom componentJid servers cheoJid name
			if null roomCreateStanzas then
				return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "Invalid group name")]
			else
				return roomCreateStanzas
		Just (Join room) -> do
			leaveRoom db toComponent componentHost tel "Joined a different room."
			bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (tcKey tel "bookmarks"))
			joinRoom db toComponent componentHost tel $
			leaveRoom db cheoJid "Joined a different room."
			bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "bookmarks"))
			let tel = maybe mempty strNode (jidNode cheoJid)
			joinRoom db cheoJid $
				fromMaybe room $ parseJID =<< fmap (<> fromString "/" <> nick)
				(find (mucShortMatch tel (strDomain $ jidDomain room)) bookmarks)
		Just Leave -> leaveRoom db toComponent componentHost tel "Typed /leave"
		Just Leave -> leaveRoom db cheoJid "Typed /leave"
		Just Who -> do
			let f = fst :: (String, Maybe String) -> String
			let snick = T.unpack nick
			let room = maybe "" (T.unpack . bareTxt) existingRoom
			presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db ("presence\0" <> room))
			let presence' = filter (/= snick) $ map f presence
			if null presence' then
				writeStanzaChan toVitelity $ mkSMS tel $ fromString $
					"You are not joined to a group. Reply with /help to learn more"
			if null presence then
				return [mkStanzaRec $ mkSMS componentJid smsJid $ fromString $
						"You are not joined to a group. Reply with /help to learn more"
					]
			else
				writeStanzaChan toVitelity $ mkSMS tel $ fromString $ mconcat [
				return [mkStanzaRec $ mkSMS componentJid smsJid $ fromString $ mconcat $ [
					"You are joined to ", room,
					" as ", snick,
					" as ", snick] ++ if null presence' then [] else [
					" along with\n",
					intercalate ", " presence'
				]
				]]
		Just List -> do
			bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db (tcKey tel "bookmarks"))
			writeStanzaChan toVitelity $ mkSMS tel $ fromString $ "Groups you can /join\n" <> intercalate "\n" bookmarks
			mbookmarks <- maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "bookmarks")
			let bookmarks = fromMaybe [] $ readZ =<< mbookmarks
			return [mkStanzaRec $ mkSMS componentJid smsJid $ fromString $ "Groups you can /join\n" <> intercalate "\n" bookmarks]
		Just (InviteCmd jid)
			| Just room <- existingRoom, Just from <- telToJid tel (fromString componentHost) ->
				sendInvite db toComponent jid (Invite room from Nothing Nothing)
			| otherwise -> writeStanzaChan toVitelity $ mkSMS tel (fromString "You are not joined to a group. Reply with /help to learn more")
			| Just room <- existingRoom ->
				sendInvite db jid (Invite room cheoJid Nothing Nothing)
			| otherwise -> return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "You are not joined to a group. Reply with /help to learn more")]
		Just (SetNick nick) -> do
			forM_ existingRoom $ \room -> do
			tcPut db cheoJid "nick" (T.unpack nick)
			fmap (concat . toList) $ forM existingRoom $ \room -> do
				let toJoin = parseJID (bareTxt room <> fromString "/" <> nick)
				forM_ toJoin $ joinRoom db toComponent componentHost tel

			True <- TC.runTCM (TC.put db (tcKey tel "nick") (T.unpack nick))
			return ()
				fmap (concat . toList) $ forM toJoin $ joinRoom db cheoJid
		Just (Whisper to msg) -> do
			uuid <- (fmap.fmap) UUID.toString UUID.nextUUID
			writeStanzaChan toComponent $ (emptyMessage MessageChat) {
			return [mkStanzaRec $ (emptyMessage MessageChat) {
				messageTo = Just to,
				messageFrom = telToJid tel (fromString componentHost),
				messageFrom = Just cheoJid,
				messageID = Just $ fromString ("CHEOGRAM%" <> fromMaybe "UUIDFAIL" uuid),
				messagePayloads = [Element (fromString "{jabber:component:accept}body") [] [NodeContent $ ContentText msg]]
			}
			}]
		Just (Send msg)
			| fromString "(SMSSERVER) " `T.isPrefixOf` msg -> return () -- bogus message from vitelity, ignore
			| Just room <- existingRoom -> sendToRoom toComponent componentHost tel room msg
			| otherwise -> writeStanzaChan toVitelity $ mkSMS tel (fromString "You are not joined to a group")
			| Just room <- existingRoom -> sendToRoom cheoJid room msg
			| otherwise -> return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "You are not joined to a group")]
		Just (Debounce time) -> do
			True <- TC.runTCM (TC.put db (tcKey tel "debounce") (show time))
			return ()
		Just Help -> do
			writeStanzaChan toVitelity $ mkSMS tel $ fromString $ mconcat [
					"Invite to group: /invite phone-number\n",
					"Show group participants: /who\n",
					"Set nick: /nick nickname\n",
					"List groups: /list\n",
					"Create a group: /create short-name"
				]
			writeStanzaChan toVitelity $ mkSMS tel $ fromString $ mconcat [
					"Join existing group: /join group-name\n",
					"Whisper to user: /msg username message\n",
					"Leave group: /leave\n",
					"More info: http://cheogram.com"
				]
		Just (VitelityBogus txt) -> log "Bogus Vitelity message" txt
		Nothing -> writeStanzaChan toVitelity $ mkSMS tel (fromString "You sent an invalid message")

viteltiy db chunks toVitelity toComponent componentHost conferenceServers = do
	putStanza $ emptyPresence PresenceAvailable

	thread <- forkXMPP $ forever $ flip catchError (liftIO . log "vitelity EXCEPTION") $ do
		wait <- liftIO $ getStdRandom (randomR (1000000,2000000))
		stanza <- liftIO $ atomically $ readTChan toVitelity
		forM_ (strNode <$> (jidNode =<< stanzaTo stanza)) $ \tel -> do
			welcomed <- maybe False toEnum <$> liftIO (TC.runTCM $ TC.get db $ tcKey tel "welcomed")
			unless welcomed $ do
				putStanza $ mkSMS tel $ fromString "Welcome to CheoGram! You can chat with groups of friends (one at a time), by replying to this number. Reply with /help to learn more or visit cheogram.com"
				True <- liftIO (TC.runTCM $ TC.put db (tcKey tel "welcomed") (fromEnum True))
				liftIO $ threadDelay wait

		putStanza stanza
		log "VITELITY OUT" stanza
		liftIO $ threadDelay wait

	flip catchError (\e -> liftIO (log "viteltiy part 2 EXCEPTION" e >> killThread thread)) $ forever $ do
		m <- getMessage <$> getStanza
		mapM_ (log "VITELITY  IN") m
		liftIO $ case (strNode <$> (jidNode =<< messageFrom =<< m), getBody "jabber:client" =<< m) of
			(Just tel, Just txt) ->
				case parseOnly (chunkParser tel) txt of
					Left _ -> processSMS db toVitelity toComponent componentHost conferenceServers tel txt
					Right chunk -> atomically $ writeTChan chunks chunk
			_ -> return ()

data Chunk = Chunk Text Int Int Text | TimerExpire

chunkParser tel =
	Chunk tel <$>
	(string (fromString "part:") *> decimal) <*>
	(string (fromString ":of:") *> decimal) <*>
	(string (fromString ":") *> takeText)

multipartStitcher db chunks toVitelity toComponent componentHost conferenceServers =
	go mempty
	where
	go state = do
		chunk <- atomically $ readTChan chunks
		time <- getCurrentTime
		let (done, cont) = case chunk of
			Chunk tel part total txt ->
				Map.partitionWithKey (\(_,total) (_, items) -> total == Map.size items) $
				Map.insertWith (\(time, items') (_, items) ->
					(time, items' <> items)
				) (tel,total) (time, Map.singleton part txt) state
			_ -> (mempty, state)

		forM_ (Map.toList done) $ \((tel, _), (_, items)) ->
			processSMS db toVitelity toComponent componentHost conferenceServers tel $
				mconcat $ map snd $ Map.toAscList items

		let (expired, unexpired) = Map.partition (\(t, _) -> time > 60 `addUTCTime` t) cont
		forM_ (Map.keys expired) $ \(tel, total) ->
			writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
				fromString "Not all parts of your message with ",
				fromString (show total),
				fromString " parts arrived. Please send again."
			tcPut db cheoJid "debounce" (show time)
			return []
		Just Help -> return [
				mkStanzaRec $ mkSMS componentJid smsJid $ fromString $ mconcat [
						"Invite to group: /invite phone-number\n",
						"Show group participants: /who\n",
						"Set nick: /nick nickname\n",
						"List groups: /list\n",
						"Create a group: /create short-name"
					],
				mkStanzaRec $ mkSMS componentJid smsJid $ fromString $ mconcat [
						"Join existing group: /join group-name\n",
						"Whisper to user: /msg username message\n",
						"Leave group: /leave\n",
						"More info: http://cheogram.com"
					]
			]

		go unexpired
		Nothing -> return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "You sent an invalid message")]

syncCall chan req = do
	var <- atomically $ newEmptyTMVar


@@ 1088,15 1086,15 @@ data RejoinManagerCommand =
	PingReply   JID |
	PingError   JID |
	Joined      JID |
	ForceRejoin JID Text
	ForceRejoin JID JID

data RejoinManagerState = PingSent Text | Rejoining
data RejoinManagerState = PingSent JID | Rejoining

rejoinManager db toComponent componentHost toRoomPresences toRejoinManager =
rejoinManager db sendToComponent componentJid toRoomPresences toRejoinManager =
	next mempty
	where
	mkMucJid muc nick = parseJID $ bareTxt muc <> fromString "/" <> nick
	ourJids muc (x,y) = (,) <$> mkMucJid muc x <*> (T.stripSuffix (fromString $ "@" <> componentHost) =<< y)
	ourJids muc (x,y) = (,) <$> mkMucJid muc x <*> (parseJID =<< y)

	next state = atomically (readTChan toRejoinManager) >>= go state



@@ 1104,14 1102,14 @@ rejoinManager db toComponent componentHost toRoomPresences toRejoinManager =
		next $! Map.delete mucJid state
	go state (PingError mucJid) = do
		forM_ (Map.lookup mucJid state) $ \x -> case x of
			PingSent tel -> atomically $ writeTChan toRejoinManager (ForceRejoin mucJid tel)
			PingSent cheoJid -> atomically $ writeTChan toRejoinManager (ForceRejoin mucJid cheoJid)
			_ -> return ()
		next state
	go state (Joined mucJid) =
		next $! Map.delete mucJid state
	go state (ForceRejoin mucJid tel) = do
		atomically $ writeTChan toRoomPresences (StartRejoin tel mucJid)
		rejoinRoom db toComponent componentHost tel mucJid True
	go state (ForceRejoin mucJid cheoJid) = do
		atomically $ writeTChan toRoomPresences (StartRejoin cheoJid mucJid)
		mapM_ sendToComponent =<< rejoinRoom db cheoJid mucJid True
		next $! Map.insert mucJid Rejoining state
	go state CheckPings = do
		presenceKeys <- TC.runTCM $ TC.fwmkeys db "presence\0" maxBound


@@ 1119,72 1117,72 @@ rejoinManager db toComponent componentHost toRoomPresences toRejoinManager =
			let Just muc = parseJID =<< T.stripPrefix (fromString "presence\0") (T.pack pkey)
			log "go state CheckPings" $ fromString "Checking (ping?) participants in " <> formatJID muc <> fromString "..."
			presences <- fmap (mapMaybe (ourJids muc) . fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db pkey)
			(\x -> foldM x state ((let Just x = parseJID (fromString "woo@conference.singpolyma.net/000") in x, fromString "000"):presences)) $ \state (mucJid, tel) ->
			(\x -> foldM x state presences) $ \state (mucJid, cheoJid) ->
				case Map.lookup mucJid state of
					Nothing -> do
						log "PINGING" (mucJid, tel)
						log "PINGING" (mucJid, cheoJid)
						uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
						writeStanzaChan toComponent $ (emptyIQ IQGet) {
						sendToComponent $ mkStanzaRec $ (emptyIQ IQGet) {
							iqTo = Just mucJid,
							iqFrom = parseJID $ tel <> T.pack ("@" <> componentHost),
							iqFrom = Just cheoJid,
							iqID = Just $ fromString $ "CHEOGRAMPING%" <> uuid,
							iqPayload = Just $ Element (fromString "{urn:xmpp:ping}ping") [] []
						}
						return $! Map.insert mucJid (PingSent tel) state
						return $! Map.insert mucJid (PingSent cheoJid) state
					Just (PingSent _) -> do -- Timeout, rejoin
						log "PING TIMEOUT" (mucJid, tel)
						atomically $ writeTChan toRejoinManager (ForceRejoin mucJid tel)
						log "PING TIMEOUT" (mucJid, cheoJid)
						atomically $ writeTChan toRejoinManager (ForceRejoin mucJid cheoJid)
						return state
					Just Rejoining -> -- Don't ping, we're working on it
						return state

-- tel, from (bare is MUC, resource is nick), Maybe participantJID
-- tel@cheogram, from (bare is MUC, resource is nick), Maybe participantJID
data RoomPresences =
	RecordSelfJoin Text JID (Maybe JID) |
	RecordJoin Text JID (Maybe JID) |
	RecordPart Text JID |
	RecordNickChanged Text JID Text |
	Clear Text JID |
	StartRejoin Text JID |
	GetRoomPresences Text JID (TMVar [(String, Maybe String)])
	RecordSelfJoin JID JID (Maybe JID) |
	RecordJoin JID JID (Maybe JID) |
	RecordPart JID JID |
	RecordNickChanged JID JID Text |
	Clear JID JID |
	StartRejoin JID JID |
	GetRoomPresences JID JID (TMVar [(String, Maybe String)])

roomPresences db toRoomPresences =
	forever $ atomically (readTChan toRoomPresences) >>= go
	where
	go (RecordSelfJoin tel from jid) = do
	go (RecordSelfJoin cheoJid from jid) = do
		-- After a join is done we have a full presence list, remove old ones
		void $ TC.runTCM $ TC.out db $ tcKey tel (muc from <> "\0old_presence")
		globalAndLocal tel from ((resource from, T.unpack . bareTxt <$> jid):)
	go (RecordJoin tel from jid) =
		globalAndLocal tel from ((resource from, T.unpack . bareTxt <$> jid):)
	go (RecordPart tel from) = do
		globalAndLocal tel from (filter ((/=resource from) . fst))
	go (RecordNickChanged tel from nick) =
		globalAndLocal tel from $
		forM_ (tcKey cheoJid (muc from <> "\0old_presence")) (TC.runTCM . TC.out db)
		globalAndLocal cheoJid from ((resource from, T.unpack . bareTxt <$> jid):)
	go (RecordJoin cheoJid from jid) =
		globalAndLocal cheoJid from ((resource from, T.unpack . bareTxt <$> jid):)
	go (RecordPart cheoJid from) = do
		globalAndLocal cheoJid from (filter ((/=resource from) . fst))
	go (RecordNickChanged cheoJid from nick) =
		globalAndLocal cheoJid from $
			map (first $ \n -> if fromString n == resource from then T.unpack nick else n)
	go (Clear tel from) =
		void $ TC.runTCM $ TC.out db $ tcKey tel (muc from <> "\0presence")
	go (StartRejoin tel from) = do
	go (Clear cheoJid from) =
		forM_ (tcKey cheoJid (muc from <> "\0presence")) (TC.runTCM . TC.out db)
	go (StartRejoin cheoJid from) = do
		-- Copy current presences to a holding space so we can clear when rejoin is over
		presences <- (fromMaybe [] . (readZ =<<)) <$>
			(TC.runTCM $ TC.get db $ tcKey tel (muc from <> "\0presence"))
			maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid (muc from <> "\0presence"))
		old_presences <- (fromMaybe [] . (readZ =<<)) <$>
			(TC.runTCM $ TC.get db $ tcKey tel (muc from <> "\0old_presence"))
		log "STARTREJOIN" (tel, muc from, presences, old_presences)
		True <- TC.runTCM $ TC.put db (tcKey tel (muc from <> "\0old_presence"))
			maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid (muc from <> "\0old_presence"))
		log "STARTREJOIN" (cheoJid, muc from, presences, old_presences)
		tcPut db cheoJid (muc from <> "\0old_presence")
			(show (presences <> old_presences :: [(String, Maybe String)]))
		void $ TC.runTCM $ TC.out db $ tcKey tel (muc from <> "\0presence")
	go (GetRoomPresences tel from rtrn) = do
		forM_ (tcKey cheoJid (muc from <> "\0presence")) (TC.runTCM . TC.out db)
	go (GetRoomPresences cheoJid from rtrn) = do
		presences <- (fromMaybe [] . (readZ =<<)) <$>
			(TC.runTCM $ TC.get db $ tcKey tel (muc from <> "\0presence"))
			maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid (muc from <> "\0presence"))
		old_presences <- (fromMaybe [] . (readZ =<<)) <$>
			(TC.runTCM $ TC.get db $ tcKey tel (muc from <> "\0old_presence"))
		log "GETROOMPRESENCES" (tel, from, presences, old_presences)
			maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid (muc from <> "\0old_presence"))
		log "GETROOMPRESENCES" (cheoJid, from, presences, old_presences)
		atomically $ putTMVar rtrn $ sort $ nubBy (equating fst) $ presences <> old_presences

	globalAndLocal tel from f = do
	globalAndLocal cheoJid from f = do
		modify ("presence\0" <> muc from) f
		modify (tcKey tel (muc from <> "\0presence")) f
		forM_ (tcKey cheoJid (muc from <> "\0presence")) (\k -> modify k f)
	modify :: String -> ([(String, Maybe String)] -> [(String, Maybe String)]) -> IO ()
	modify k f = do
		presence <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db k)


@@ 1193,24 1191,24 @@ 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 | DebounceExpire Text JID UTCTime deriving (Show)
data JoinPartDebounce = DebounceJoin JID JID (Maybe JID) | DebouncePart JID JID | DebounceExpire JID JID UTCTime deriving (Show)

joinPartDebouncer db toVitelity toRoomPresences toJoinPartDebouncer = next mempty
joinPartDebouncer db backendHost sendToComponent componentJid toRoomPresences toJoinPartDebouncer = next mempty
	where
	next state = do
		msg <- atomically (readTChan toJoinPartDebouncer)
		log "DEBOUNCE JOIN/PART" (msg, state)
		go state msg >>= next

	recordJoinPart tel from mjid join
		| join = atomically $ writeTChan toRoomPresences $ RecordJoin tel from mjid
		| otherwise = atomically $ writeTChan toRoomPresences $ RecordPart tel from
	recordJoinPart cheoJid from mjid join
		| join = atomically $ writeTChan toRoomPresences $ RecordJoin cheoJid from mjid
		| otherwise = atomically $ writeTChan toRoomPresences $ RecordPart cheoJid from

	sendPart tel from time = do
		log "DEBOUNCE PART, GONNA SEND" (tel, from, time)
		atomically $ writeTChan toRoomPresences $ RecordPart tel from
	sendPart cheoJid from time = forM_ (mapToBackend backendHost cheoJid) $ \smsJid -> do
		log "DEBOUNCE PART, GONNA SEND" (smsJid, from, time)
		atomically $ writeTChan toRoomPresences $ RecordPart cheoJid from
		now <- getCurrentTime
		writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
		sendToComponent $ mkStanzaRec $ mkSMS componentJid smsJid $ mconcat [
				fromString "* ",
				fromMaybe mempty (strResource <$> jidResource from),
				fromString " left the group ",


@@ 1218,14 1216,14 @@ joinPartDebouncer db toVitelity toRoomPresences toJoinPartDebouncer = next mempt
				fromString " minutes ago"
			]

	sendJoin tel from time mjid = do
	sendJoin cheoJid from time mjid = forM_ (mapToBackend backendHost cheoJid) $ \smsJid -> do
		let nick = fromMaybe mempty (strResource <$> jidResource from)
		presences <- syncCall toRoomPresences $ GetRoomPresences tel from
		presences <- syncCall toRoomPresences $ GetRoomPresences cheoJid from
		now <- getCurrentTime
		log "DEBOUNCE JOIN, MAYBE GONNA SEND" (tel, from, presences)
		log "DEBOUNCE JOIN, MAYBE GONNA SEND" (cheoJid, from, presences)
		when (isNothing $ lookup (T.unpack nick) presences) $ do
			atomically $ writeTChan toRoomPresences $ RecordJoin tel from mjid
			writeStanzaChan toVitelity $ mkSMS tel $ mconcat [
			atomically $ writeTChan toRoomPresences $ RecordJoin cheoJid from mjid
			sendToComponent $ mkStanzaRec $ mkSMS componentJid smsJid $ mconcat [
					fromString "* ",
					nick,
					fromString " joined the group ",


@@ 1233,26 1231,26 @@ joinPartDebouncer db toVitelity toRoomPresences toJoinPartDebouncer = next mempt
					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
	debounceCheck state cheoJid from mjid join =
		case Map.lookup (cheoJid, from) state of
			Just (_, _, j) | j /= join -> return $! Map.delete (cheoJid, from) state -- debounce
			Just (_, _, _) -> return state -- ignore dupe
			Nothing -> do
				expire <- fmap (fromMaybe (-1) . (readZ =<<)) (TC.runTCM $ TC.get db (tcKey tel "debounce"))
				expire <- fmap (fromMaybe (-1) . (readZ =<<)) (maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "debounce"))
				time <- getCurrentTime
				if expire < 0 then recordJoinPart tel from mjid join else
					void $ forkIO $ threadDelay (expire*1000000) >> 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
				if expire < 0 then recordJoinPart cheoJid from mjid join else
					void $ forkIO $ threadDelay (expire*1000000) >> atomically (writeTChan toJoinPartDebouncer $ DebounceExpire cheoJid from time)
				return $! Map.insert (cheoJid, from) (time, mjid, join) state

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

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


@@ 1266,34 1264,34 @@ main = do
	hSetBuffering stdout LineBuffering
	hSetBuffering stderr LineBuffering

	log "" "Starting..."
	(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
	toRoomPresences <- atomically newTChan
	toRejoinManager <- atomically newTChan

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

	void $ forkIO $ forever $ atomically (writeTChan toRejoinManager CheckPings) >> threadDelay 120000000
	void $ forkIO $ rejoinManager db toComponent name toRoomPresences toRejoinManager

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

	let Just vitelityParsedJid = parseJID $ fromString vitelityJid
	forever $
		(log "runClient ENDED" <=< (runEitherT . syncIO)) $
		(log "runClient ENDED INTERNAL" =<<) $
		(log "" "runClient STARTING" >>) $
		runClient (Server (fromString "s.ms") "s.ms" (PortNumber 5222)) vitelityParsedJid (fromMaybe mempty $ strNode <$> jidNode vitelityParsedJid) (fromString vitelityPassword) $ do
		void $ bindJID vitelityParsedJid
		viteltiy db chunks toVitelity toComponent name conferences
	args <- getArgs
	case args of
		("register":componentHost:host:port:secret:backendHost:did:password:[]) -> do
			log "" "Registering..."
			let Just componentJid = parseJID (fromString componentHost)
			let Just gatewayJid = parseJID (fromString backendHost)
			void $ runComponent (Server componentJid host (PortNumber $ fromIntegral (read port :: Int))) (fromString secret) $ do
				mapM_ putStanza =<< registerToGateway componentJid gatewayJid (fromString did) (fromString password)
				liftIO $ threadDelay 1000000
		(name:host:port:secret:backendHost:conferences) -> do
			log "" "Starting..."
			let Just componentJid = parseJID (fromString name)
			db <- openTokyoCabinet "./db.tcdb" :: IO TC.HDB
			toJoinPartDebouncer <- atomically newTChan
			sendToComponent <- atomically newTChan
			toRoomPresences <- atomically newTChan
			toRejoinManager <- atomically newTChan

			void $ forkIO $ joinPartDebouncer db (fromString backendHost) (atomically . writeTChan sendToComponent) componentJid toRoomPresences toJoinPartDebouncer
			void $ forkIO $ roomPresences db toRoomPresences

			void $ forkIO $ forever $ atomically (writeTChan toRejoinManager CheckPings) >> threadDelay 120000000
			void $ forkIO $ rejoinManager db (atomically . writeTChan sendToComponent) name toRoomPresences toRejoinManager

			forever $ do
				log "" "runComponent STARTING"

				(log "runComponent ENDED" <=< (runEitherT . syncIO)) $
					runComponent (Server componentJid host (PortNumber $ fromIntegral (read port :: Int))) (fromString secret)
						(component db (fromString backendHost) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent componentJid (map fromString conferences))
		_ -> log "ERROR" "Bad arguments"