~singpolyma/cheogram

6349966097b44cc4a1f32f12f2eefae75d6b95c3 — Stephen Paul Weber 1 year, 11 months ago 4941e92 
Abstract DB

We want to change the storage backend, because we are pushing past the limits of
what is a good idea with TokyoCabinet and have had several corruption events.

So, as a first step, break the hard dependency of the main app code on
TokyoCabinet and instead express the operations in a more abstract data model.
This data model is pretty much based on Redis, which is the intended new storage
driver, but isn't directly tied to that either.
patch browse .tar.gz 
4 files changed, 267 insertions(+), 198 deletions(-)

M Adhoc.hs
A DB.hs
M Main.hs
M cheogram.cabal

M Adhoc.hs => Adhoc.hs +9 -9
@@ 19,7 19,6 @@ import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.UUID as UUID ( toString, toText )
import qualified Data.UUID.V1 as UUID ( nextUUID )
import qualified Database.TokyoCabinet as TC
import qualified UnexceptionalIO.Trans ()
import qualified UnexceptionalIO as UIO



@@ 27,6 26,7 @@ import StanzaRec
import UniquePrefix
import Util
import qualified ConfigureDirectMessageRoute
import qualified DB

sessionLifespan :: Int
sessionLifespan = 60 * 60 * seconds


@@ 410,8 410,8 @@ getServerInfoForm = find (\el ->
		getFormField el (s"FORM_TYPE") == Just (s"http://jabber.org/network/serverinfo")
	) . (isNamed (s"{jabber:x:data}x") =<<)

sendHelp :: (UIO.Unexceptional m, TC.TCDB db) =>
	   db
sendHelp :: (UIO.Unexceptional m) =>
	   DB.DB
	-> JID
	-> (XMPP.Message -> m ())
	-> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ)))


@@ 419,8 419,8 @@ sendHelp :: (UIO.Unexceptional m, TC.TCDB db) =>
	-> JID
	-> m ()
sendHelp db componentJid sendMessage sendIQ from routeFrom = do
	maybeRoute <- fmap (join . hush) $ UIO.fromIO $ TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
	case parseJID =<< fmap fromString maybeRoute of
	maybeRoute <- (parseJID =<<) . (join . hush) <$> UIO.fromIO (DB.get db (DB.byJid from ["direct-message-route"]))
	case maybeRoute of
		Just route -> do
			replySTM <- UIO.lift $ sendIQ $ queryCommandList' route routeFrom
			discoInfoSTM <- UIO.lift $ sendIQ $ queryDiscoWithNode' Nothing route routeFrom


@@ 438,7 438,7 @@ sendHelp db componentJid sendMessage sendIQ from routeFrom = do
				Just msg -> sendMessage msg
				Nothing -> log "INVALID HELP MESSAGE" ()

adhocBotRunCommand :: (TC.TCDB db, UIO.Unexceptional m) => db -> JID -> JID -> (XMPP.Message -> m ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> STM XMPP.Message -> JID -> Text -> [Element] -> m ()
adhocBotRunCommand :: (UIO.Unexceptional m) => DB.DB -> JID -> JID -> (XMPP.Message -> m ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> STM XMPP.Message -> JID -> Text -> [Element] -> m ()
adhocBotRunCommand db componentJid routeFrom sendMessage sendIQ getMessage from body cmdEls = do
	let (nodes, cmds) = unzip $ mapMaybe (\el -> (,) <$> attributeText (s"node") el <*> pure el) cmdEls



@@ 549,11 549,11 @@ adhocBotRunCommand db componentJid routeFrom sendMessage sendIQ getMessage from 
				| otherwise -> sendMessage $ mkSMS componentJid from (s"Command error")
			Nothing -> sendMessage $ mkSMS componentJid from (s"Command timed out")

adhocBotSession :: (UIO.Unexceptional m, TC.TCDB db) => db -> JID -> (XMPP.Message -> m ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> STM XMPP.Message -> XMPP.Message-> m ()
adhocBotSession :: (UIO.Unexceptional m) => DB.DB -> JID -> (XMPP.Message -> m ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> STM XMPP.Message -> XMPP.Message-> m ()
adhocBotSession db componentJid sendMessage sendIQ getMessage message@(XMPP.Message { XMPP.messageFrom = Just from })
	| Just body <- getBody "jabber:component:accept" message = do
		maybeRoute <- fmap (join . hush) $ UIO.fromIO $ TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
		case parseJID =<< fmap fromString maybeRoute of
		maybeRoute <- (parseJID =<<) . (join . hush) <$> UIO.fromIO (DB.get db (DB.byJid from ["direct-message-route"]))
		case maybeRoute of
			Just route -> do
				mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
				case iqPayload =<< mfilter ((==IQResult) . iqType) mreply of


A DB.hs => DB.hs +116 -0
@@ 0,0 1,116 @@
module DB (DB, Key(..), byJid, byNode, mk, get, getEnum, del, set, setEnum, sadd, srem, smembers, foldKeysM, hset, hdel, hgetall) where

import Prelude ()
import BasicPrelude

import Control.Error (readZ)
import Network.Protocol.XMPP (JID(..), strNode)

import qualified Database.TokyoCabinet as TC
import qualified Data.Text as T

import Util

data DB = DB {
	tcdb :: TC.HDB
}

newtype Key = Key [String]

openTokyoCabinet :: (TC.TCDB a) => String -> IO a
openTokyoCabinet pth = TC.runTCM $ do
	db <- TC.new
	True <- TC.open db pth [TC.OREADER, TC.OWRITER, TC.OCREAT]
	return db

mk :: String -> IO DB
mk tcPath = do
	tcdb <- openTokyoCabinet tcPath
	return $ DB tcdb

tcKey :: Key -> String
tcKey (Key key) = intercalate "\0" key

tcParseKey :: String -> Key
tcParseKey str = Key $ map textToString $ T.split (=='\0') $ fromString str

get :: DB -> Key -> IO (Maybe Text)
get db key =
	fmap fromString <$> (TC.runTCM $ TC.get (tcdb db) $ tcKey key)

getEnum :: (Enum a) => DB -> Key -> IO (Maybe a)
getEnum db key =
	fmap toEnum <$> (TC.runTCM $ TC.get (tcdb db) $ tcKey key)

del :: DB -> Key -> IO ()
del db key = do
	True <- TC.runTCM $ TC.out (tcdb db) $ tcKey key
	return ()

set :: DB -> Key -> Text -> IO ()
set db key val = do
	True <- TC.runTCM $ TC.put (tcdb db) (tcKey key) (textToString val)
	return ()

setEnum :: (Enum a) => DB -> Key -> a -> IO ()
setEnum db key val = do
	True <- TC.runTCM $ TC.put (tcdb db) (tcKey key) (fromEnum val)
	return ()

sadd :: DB -> Key -> [Text] -> IO ()
sadd db key new = do
	existing <- (fromMaybe [] . (readZ =<<)) <$>
		TC.runTCM (TC.get (tcdb db) $ tcKey key)
	True <- TC.runTCM $
		TC.put (tcdb db) (tcKey key) (show $ nub $ (map textToString new) ++ existing)
	return ()

srem :: DB -> Key -> [Text] -> IO ()
srem db key toremove = do
	existing <- (fromMaybe [] . (readZ =<<)) <$>
		TC.runTCM (TC.get (tcdb db) $ tcKey key)
	True <- TC.runTCM $
		TC.put (tcdb db) (tcKey key) (show $ filter (`notElem` toremove) existing)
	return ()

smembers :: (Read r) => DB -> Key -> IO [r]
smembers db key =
	 (fromMaybe [] . (readZ =<<)) <$>
		TC.runTCM (TC.get (tcdb db) $ tcKey key)

hset :: (Eq k, Read k, Show k, Read v, Show v) => DB -> Key -> [(k, v)] -> IO ()
hset db key newitems = do
	items <- (fromMaybe [] . (readZ =<<)) <$>
		TC.runTCM (TC.get (tcdb db) $ tcKey key)
	let items' = nubBy (equating fst) (newitems ++ items)
	True <- TC.runTCM $ TC.put (tcdb db) (tcKey key) (show items')
	return ()

-- WARNING: Right now this function assumes all values are of type Maybe String
hdel :: DB -> Key -> [Text] -> IO ()
hdel db key toremove = do
	items <- (fromMaybe [] . (readZ =<<)) <$>
		TC.runTCM (TC.get (tcdb db) $ tcKey key)
	let items' = filter ((`notElem` toremove) . fst) (items :: [(Text, Maybe String)])
	True <- TC.runTCM $ TC.put (tcdb db) (tcKey key) (show items')
	return ()

hgetall :: (Read k, Read v) => DB -> Key -> IO [(k, v)]
hgetall db key =
	(fromMaybe [] . (readZ =<<)) <$>
		TC.runTCM (TC.get (tcdb db) $ tcKey key)

foldKeysM :: DB -> Key -> b -> (b -> Key -> IO b) -> IO b
foldKeysM db (Key prefix) z f = do
	keys <- TC.runTCM $ TC.fwmkeys (tcdb db) (tcKey $ Key $ prefix ++ [""]) maxBound
	foldM f z $ map tcParseKey (keys :: [String])

byJid :: JID -> [String] -> Key
byJid jid subkey = Key $ (textToString $ bareTxt jid) : subkey

-- | Used when we know the JID is @cheogram.com, for example
--   So usually this is ByTel, really
byNode :: JID -> [String] -> Key
byNode (JID { jidNode = Just node }) subkey =
	Key $ (textToString $ strNode node) : subkey
byNode jid _ = error $ "JID without node used in byNode: " ++ show jid


M Main.hs => Main.hs +141 -188
@@ 9,7 9,7 @@ import Control.Concurrent.STM
import Data.Foldable (forM_, mapM_, toList)
import Data.Traversable (forM, mapM)
import System.Environment (getArgs)
import Control.Error (readZ, MaybeT(..), hoistMaybe, headZ, justZ, hush)
import Control.Error (readZ, MaybeT(..), hoistMaybe, headZ, justZ, hush, atZ)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Network (PortID(PortNumber))
import Network.URI (parseURI, uriPath, escapeURIString)


@@ 36,7 36,6 @@ import qualified Data.ByteString.Lazy as LZ
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Builder as Builder
import qualified Database.TokyoCabinet as TC
import qualified Database.Redis as Redis
import qualified Text.Regex.PCRE.Light as PCRE
import qualified Network.Http.Client as HTTP


@@ 47,22 46,13 @@ import Util
import IQManager
import qualified ConfigureDirectMessageRoute
import qualified Config
import qualified DB
import Adhoc (adhocBotSession, commandList, queryCommandList)
import StanzaRec

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

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 ()

queryDisco to from = (:[]) . mkStanzaRec <$> queryDiscoWithNode Nothing to from

queryDiscoWithNode node to from = do


@@ 126,7 116,7 @@ getDirectInvitation m = do
nickFor db jid existingRoom
	| fmap bareTxt existingRoom == Just bareFrom = return $ fromMaybe (s"nonick") resourceFrom
	| Just tel <- mfilter isE164 (strNode <$> jidNode jid) = do
		mnick <- maybe (return Nothing) (TC.runTCM .TC.get db) (tcKey jid "nick")
		mnick <- DB.get db (DB.byNode jid ["nick"])
		case mnick of
			Just nick -> return (tel <> s" \"" <> nick <> s"\"")
			Nothing -> return tel


@@ 200,11 190,11 @@ telDiscoFeatures = [
		s"urn:xmpp:jingle:transports:ibb:1"
	]

getSipProxy :: TC.HDB -> JID -> (IQ -> UIO (STM (Maybe IQ))) -> JID -> IO (Maybe Text)
getSipProxy :: DB.DB -> JID -> (IQ -> UIO (STM (Maybe IQ))) -> JID -> IO (Maybe Text)
getSipProxy db componentJid sendIQ jid = do
	maybeProxy <- TC.runTCM $ TC.get db $ T.unpack (bareTxt jid) ++ "\0sip-proxy"
	maybeProxy <- DB.get db (DB.byJid jid ["sip-proxy"])
	case maybeProxy of
		Just proxy -> return $ Just $ T.pack proxy
		Just proxy -> return $ Just proxy
		Nothing ->
			(extractSip =<<) <$> routeQueryStateful db componentJid sendIQ jid Nothing query
	where


@@ 274,8 264,8 @@ telDiscoInfo q id from to disco =
	}

routeQueryOrReply db componentJid from smsJid resource query reply = do
	maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
	case (fmap fromString maybeRoute, maybeRouteFrom) of
	maybeRoute <- DB.get db (DB.byJid from ["direct-message-route"])
	case (maybeRoute, maybeRouteFrom) of
		(Just route, Just routeFrom) ->
				let routeTo = fromMaybe componentJid $ parseJID $ (maybe mempty (++ s"@") $ strNode <$> jidNode smsJid) ++ route in
				query routeTo routeFrom


@@ 284,8 274,8 @@ routeQueryOrReply db componentJid from smsJid resource query reply = do
	maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/" ++ (fromString resource)

routeQueryStateful db componentJid sendIQ from targetNode query = do
	maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
	case (fmap fromString maybeRoute, maybeRouteFrom) of
	maybeRoute <- DB.get db (DB.byJid from ["direct-message-route"])
	case (maybeRoute, maybeRouteFrom) of
		(Just route, Just routeFrom) -> do
			let Just routeTo = parseJID $ (maybe mempty (++ s"@") $ strNode <$> targetNode) ++ route
			iqToSend <- query routeTo routeFrom


@@ 346,13 336,10 @@ mapBody f (m@Message { messagePayloads = payloads }) =
	}

unregisterDirectMessageRoute db componentJid userJid route = do
	maybeCheoJid <- (parseJID . fromString =<<) <$> TC.runTCM (TC.get db (T.unpack (bareTxt userJid) ++ "\0cheoJid"))
	maybeCheoJid <- (parseJID =<<) <$> DB.get db (DB.byJid userJid ["cheoJid"])
	forM_ maybeCheoJid $ \cheoJid -> do
		TC.runTCM $ TC.out db (T.unpack (bareTxt userJid) ++ "\0cheoJid")

		owners <- (fromMaybe [] . (readZ =<<)) <$>
			maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "owners")
		tcPut db cheoJid "owners" (show $ (filter (/= bareTxt userJid)) owners)
		DB.del db (DB.byJid userJid ["cheoJid"])
		DB.srem db (DB.byNode cheoJid ["owners"]) [bareTxt userJid]

	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
	return $ (emptyIQ IQSet) {


@@ 364,9 351,9 @@ unregisterDirectMessageRoute db componentJid userJid route = do
			]
		}

toRouteOrFallback db componentJid bareFrom resourceFrom smsJid m fallback = do
	maybeRoute <- TC.runTCM $ TC.get db (T.unpack bareFrom ++ "\0direct-message-route")
	case (fmap fromString maybeRoute, parseJID $ escapeJid bareFrom ++ s"@" ++ formatJID componentJid ++ resourceSuffix) of
toRouteOrFallback db componentJid from smsJid m fallback = do
	maybeRoute <- DB.get db (DB.byJid from ["direct-message-route"])
	case (maybeRoute, parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ resourceSuffix) of
		(Just route, Just routeFrom) -> do
			return [mkStanzaRec $ m {
				messageFrom = Just routeFrom,


@@ 374,18 361,18 @@ toRouteOrFallback db componentJid bareFrom resourceFrom smsJid m fallback = do
			}]
		_ -> fallback
	where
	resourceSuffix = maybe mempty (s"/"++) resourceFrom
	resourceSuffix = maybe mempty (s"/"++) (strResource <$> jidResource from)

componentMessage db componentJid (m@Message { messageType = MessageError }) _ bareFrom resourceFrom smsJid body = do
componentMessage db componentJid (m@Message { messageType = MessageError }) _ from smsJid body = do
	log "MESSAGE ERROR"  m
	toRouteOrFallback db componentJid bareFrom resourceFrom smsJid m $ do
	toRouteOrFallback db componentJid from smsJid m $ do
		log "DIRECT FROM GATEWAY" smsJid
		return [mkStanzaRec $ m { messageTo = Just smsJid, messageFrom = Just componentJid }]
componentMessage db componentJid m@(Message { messageTo = Just to }) existingRoom _ _ smsJid _
componentMessage db componentJid m@(Message { messageTo = Just to }) existingRoom _ smsJid _
	| Just invite <- getMediatedInvitation m <|> getDirectInvitation m = do
		forM_ (invitePassword invite) $ \password ->
			tcPut db to (T.unpack (formatJID $ inviteMUC invite) <> "\0muc_roomsecret") (T.unpack password)
		existingInvite <- tcGetJID db to "invited"
			DB.set db (DB.byNode to [textToString $ formatJID $ inviteMUC invite, "muc_roomsecret"]) password
		existingInvite <- (parseJID =<<) <$> DB.get db (DB.byNode to ["invited"])
		nick <- nickFor db (inviteFrom invite) existingRoom
		let txt = mconcat [
				fromString "* ",


@@ 395,30 382,30 @@ componentMessage db componentJid m@(Message { messageTo = Just to }) existingRoo
				fromString "\nYou can switch to this group by replying with /join"
			]
		if (existingRoom /= Just (inviteMUC invite) && existingInvite /= Just (inviteMUC invite)) then do
			tcPutJID db to "invited" (inviteMUC invite)
			regJid <- tcGetJID db to "registered"
			DB.set db (DB.byNode to ["invited"]) (formatJID $ inviteMUC invite)
			regJid <- (parseJID =<<) <$> DB.get db (DB.byNode 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
	if fmap bareTxt existingRoom == Just bareFrom && (
	   existingRoom /= parseJID (bareFrom <> fromString "/" <> fromMaybe mempty resourceFrom) ||
componentMessage _ componentJid (m@Message { messageType = MessageGroupChat }) existingRoom from smsJid (Just body) = do
	if fmap bareTxt existingRoom == Just (bareTxt from) && (
	   existingRoom /= Just from ||
	   not (fromString "CHEOGRAM%" `T.isPrefixOf` fromMaybe mempty (messageID m))) then
		return [mkStanzaRec $ mkSMS componentJid smsJid txt]
	else do
		log "MESSAGE FROM WRONG GROUP" (fmap bareTxt existingRoom, bareFrom, m)
		log "MESSAGE FROM WRONG GROUP" (fmap bareTxt existingRoom, from, m)
		return []
	where
	txt = mconcat [fromString "(", fromMaybe (fromString "nonick") resourceFrom, fromString ") ", body]
componentMessage db componentJid m@(Message { messageFrom = Just from, messageTo = Just to }) existingRoom bareFrom resourceFrom smsJid (Just body) = do
	txt = mconcat [fromString "(", fromMaybe (fromString "nonick") (strResource <$> jidResource from), fromString ") ", body]
componentMessage db componentJid m@(Message { messageTo = Just to }) existingRoom from smsJid (Just body) = do
	ack <- case isNamed (fromString "{urn:xmpp:receipts}request") =<< messagePayloads m of
		(_:_) ->
			routeDiscoOrReply db componentJid from smsJid ("CHEOGRAM%query-then-send-ack%" ++ extra) Nothing
				(deliveryReceipt (fromMaybe mempty $ messageID m) to from)
		[] -> return []

	fmap (++ack) $ toRouteOrFallback db componentJid bareFrom resourceFrom smsJid strippedM $
	fmap (++ack) $ toRouteOrFallback db componentJid from smsJid strippedM $
		case PCRE.match autolinkRegex (encodeUtf8 body) [] of
			Just _ -> do
				log "WHISPER URL" m


@@ 439,24 426,20 @@ componentMessage db componentJid m@(Message { messageFrom = Just from, messageTo
	where
	strippedM = mapBody (const strippedBody) m
	strippedBody = stripOtrWhitespace body
	extra = T.unpack $ escapeJid $ T.pack $ show (fromMaybe mempty (messageID m), fromMaybe mempty resourceFrom)
componentMessage _ _ m _ _ _ _ _ = do
	extra = T.unpack $ escapeJid $ T.pack $ show (fromMaybe mempty (messageID m), maybe mempty strResource $ jidResource from)
componentMessage _ _ m _ _ _ _ = do
	log "UNKNOWN MESSAGE" m
	return []

handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads join
	| join,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  [x] <- isNamed (s"{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  not $ null $ code "110" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		existingInvite <- tcGetJID db to "invited"
		when (existingInvite == parseJID bareMUC) $ do
			let Just invitedKey = tcKey to "invited"
			True <- TC.runTCM $ TC.out db invitedKey
			return ()
		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)
		existingInvite <- (parseJID =<<) <$> DB.get db (DB.byNode to ["invited"])
		when (existingInvite == parseJID bareMUC) $
			DB.del db (DB.byNode to ["invited"])
		DB.set db (DB.byNode to ["joined"]) (formatJID from)
		DB.sadd db (DB.byNode to ["bookmarks"]) [bareMUC]

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


@@ 505,8 488,7 @@ handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer compon
		void $ forkIO $ threadDelay 5000000 >> atomically (writeTChan toRejoinManager $ ForceRejoin from to)
		return []
	| not join && existingRoom == Just from = do
		let Just joinedKey = tcKey to "joined"
		True <- TC.runTCM $ TC.out db joinedKey
		DB.del db (DB.byNode to ["joined"])
		atomically $ writeTChan toRoomPresences $ RecordPart to from
		atomically $ writeTChan toRoomPresences $ Clear to from
		return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "* You have left " <> bareMUC)]


@@ 566,7 548,8 @@ data RegistrationCode = RegistrationCode { regCode :: Int, cheoJid :: Text, expi
registerVerification db componentJid to iq = do
	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 (formatJID to) time
	forM_ (iqFrom iq) $ \from ->
		DB.set db (DB.byJid from ["registration_code"]) $ tshow $ RegistrationCode code (formatJID to) time
	return [
			mkStanzaRec $ mkSMS componentJid to $ fromString ("Enter this verification code to complete registration: " <> show code),
			mkStanzaRec $ iq {


@@ 577,29 560,29 @@ registerVerification db componentJid to iq = do
			}
		]

handleVerificationCode db componentJid password iq = do
handleVerificationCode db componentJid password iq from = do
	time <- getCurrentTime
	codeAndTime <- fmap (readZ =<<) $ TC.runTCM $ TC.get db regKey
	codeAndTime <- fmap (readZ . textToString =<<) $ DB.get db (DB.byJid from ["registration_code"])
	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"))
				case (show code == T.unpack password, iqTo iq, parseJID cheoJidT) of
					(True, Just to, Just cheoJid) -> do
						bookmarks <- DB.smembers db (DB.byNode 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
						let Just tel = strNode <$> jidNode cheoJid
						DB.set db (DB.byJid from ["registered"]) tel
						DB.set db (DB.byNode cheoJid ["registered"]) (bareTxt 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 (s"_sms") nick) <> s"_sms"
							tcPut db cheoJid "nick" (T.unpack nick')
							nick <- MaybeT $ DB.get db (DB.byNode cheoJid ["nick"])
							let nick' = (fromMaybe nick $ T.stripSuffix (s"_sms") nick) <> s"_sms"
							liftIO $ DB.set db (DB.byNode cheoJid ["nick"]) nick'

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



@@ 619,14 602,12 @@ handleVerificationCode db componentJid password iq = do
								[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}not-authorized") [] []]
						}]
		_ -> do
			void $ TC.runTCM $ TC.out db regKey
			DB.del db (DB.byJid from ["registration_code"])
			return []
	where
	regKey = (maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code"

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


@@ 674,19 655,19 @@ handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
	| [phoneEl] <- isNamed (fromString "{jabber:iq:register}phone") =<< elementChildren query,
	  Just to <- (`telToJid` formatJID componentJid) $ T.filter isDigit $ mconcat (elementText phoneEl) = do
		registerVerification db componentJid to iq
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
handleRegister db componentJid iq@(IQ { iqType = IQSet, iqFrom = Just from }) query
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query,
	  Just password <- getFormField form (fromString "password") = do
		handleVerificationCode db componentJid password iq
handleRegister db componentJid iq@(IQ { iqType = IQSet, iqPayload = Just payload }) query
		handleVerificationCode db componentJid password iq from
handleRegister db componentJid iq@(IQ { iqType = IQSet, iqPayload = Just payload, iqFrom = Just from }) query
	| [passwordEl] <- isNamed (fromString "{jabber:iq:register}password") =<< elementChildren query = do
		handleVerificationCode db componentJid (mconcat $ elementText passwordEl) iq
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
		handleVerificationCode db componentJid (mconcat $ elementText passwordEl) iq from
handleRegister db componentJid iq@(IQ { iqFrom = Just from, iqType = IQSet }) query
	| [_] <- isNamed (fromString "{jabber:iq:register}remove") =<< elementChildren query = do
		tel <- maybe mempty T.pack <$> TC.runTCM (TC.get db $ T.unpack (maybe mempty bareTxt $ iqFrom iq) <> "\0registered")
		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"
		tel <- fromMaybe mempty <$> DB.get db (DB.byJid from ["registered"])
		forM_ (telToJid tel (formatJID componentJid)) $ \cheoJid ->
			DB.del db (DB.byNode cheoJid  ["registered"])
		DB.del db (DB.byJid from ["registered"])
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,


@@ 709,7 690,7 @@ handleRegister _ _ iq _ = do
	return []

data ComponentContext = ComponentContext {
	db :: TC.HDB,
	db :: DB.DB,
	smsJid :: Maybe JID,
	registrationJids :: [JID],
	adhocBotMessage :: Message -> STM (),


@@ 753,11 734,9 @@ componentStanza _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom
	  not $ null $ code "104" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		queryDisco from to
componentStanza (ComponentContext { db, smsJid = (Just smsJid), componentJid }) (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) = do
	existingRoom <- tcGetJID db to "joined"
	componentMessage db componentJid m existingRoom (bareTxt from) resourceFrom smsJid $
	existingRoom <- (parseJID =<<) <$> DB.get db (DB.byNode to ["joined"])
	componentMessage db componentJid m existingRoom from smsJid $
		getBody "jabber:component:accept" m
	where
	resourceFrom = strResource <$> jidResource from
componentStanza (ComponentContext { smsJid = (Just smsJid), 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


@@ 776,7 755,7 @@ componentStanza (ComponentContext { db, smsJid = (Just smsJid), toRoomPresences,
		presenceTo = Just to,
		presencePayloads = payloads
	})) | typ `elem` [PresenceAvailable, PresenceUnavailable] = do
		existingRoom <- tcGetJID db to "joined"
		existingRoom <- (parseJID =<<) <$> DB.get db (DB.byNode to ["joined"])
		handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads (typ == PresenceAvailable)
componentStanza (ComponentContext { db, componentJid, sendIQ, maybeAvatar }) (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
	avail <- cheogramAvailable db componentJid sendIQ to from


@@ 924,10 903,10 @@ componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ iq@(IQ { iqT
	  attributeText (s"node") payload == Just (s"sip-proxy-set"),
	  [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren payload,
	  Just proxy <- getFormField form (s"sip-proxy") = do
		True <- if T.null proxy then
			TC.runTCM $ TC.out db $ T.unpack (bareTxt from) ++ "\0sip-proxy"
		if T.null proxy then
			DB.del db (DB.byJid from ["sip-proxy"])
		else
			TC.runTCM $ TC.put db (T.unpack (bareTxt from) ++ "\0sip-proxy") $ T.unpack proxy
			DB.set db (DB.byJid from ["sip-proxy"]) proxy
		return [mkStanzaRec $ iqReply Nothing iq]
componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ iq@(IQ { iqTo = Just to, iqPayload = Just payload, iqFrom = Just from }))
	| jidNode to == Nothing,


@@ 936,7 915,7 @@ componentStanza (ComponentContext { db, componentJid }) (ReceivedIQ iq@(IQ { iqT
	  attributeText (s"node") payload == Just (s"push-register"),
	  [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren payload,
	  Just pushRegisterTo <- XMPP.parseJID =<< getFormField form (s"to") = do
		TC.runTCM (TC.put db (T.unpack (bareTxt pushRegisterTo) ++ "\0possible-route") (T.unpack $ XMPP.formatJID from))
		DB.set db (DB.byJid pushRegisterTo ["possible-route"]) (XMPP.formatJID from)
		return [
				mkStanzaRec $ iqReply (
					Just $ Element (s"{http://jabber.org/protocol/commands}command")


@@ 1074,8 1053,8 @@ componentStanza (ComponentContext { db }) (ReceivedIQ (iq@IQ { iqType = IQError,
		log "create@ ERROR" (from, to, iq)
		case T.splitOn (fromString "|") resource of
			(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
				mnick <- DB.get db (DB.byNode cheoJid ["nick"])
				let nick = fromMaybe (maybe mempty strNode (jidNode cheoJid)) mnick
				let Just room = parseJID $ bareTxt from <> fromString "/" <> nick
				(++) <$>
					leaveRoom db cheoJid "Joined a different room." <*>


@@ 1163,10 1142,10 @@ componentStanza (ComponentContext { db, componentJid, sendIQ }) (ReceivedIQ (IQ 
	| [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
		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
		let muc_membersonly = s"muc_membersonly" `elem` vars
		DB.setEnum db (DB.byJid from ["muc_membersonly"]) muc_membersonly
		if (fmap strResource (jidResource to) == Just (fromString "create")) then do
			regJid <- tcGetJID db to "registered"
			regJid <- (parseJID =<<) <$> DB.get db (DB.byNode to ["registered"])
			fmap (concat . toList) $ forM ((,) <$> regJid <*> parseJID (bareTxt to)) $ \(jid, to) ->
				sendInvite db jid (Invite from to Nothing Nothing)
		else


@@ 1182,8 1161,8 @@ componentStanza _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFrom = Just from, iqTo 
componentStanza (ComponentContext { db, smsJid = maybeSmsJid, componentJid }) (ReceivedIQ (iq@IQ { iqType = typ, iqFrom = Just from }))
	| fmap strResource (jidResource =<< iqTo iq) /= Just (s"capsQuery") = do
	let resourceSuffix = maybe mempty (s"/"++) $ fmap strResource (jidResource from)
	maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
	case (fmap fromString maybeRoute, parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ resourceSuffix) of
	maybeRoute <- DB.get db (DB.byJid from ["direct-message-route"])
	case (maybeRoute, parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ resourceSuffix) of
		(Just route, Just routeFrom) -> do
			return [mkStanzaRec $ iq {
				iqFrom = Just routeFrom,


@@ 1344,20 1323,18 @@ component db redis pushStatsd backendHost did maybeAvatar cacheOOB sendIQ iqRece
					liftIO (mapM_ sendToComponent =<< processSMS db componentJid conferenceServers from cheoJid txt)
			(Just from, Just to, Nothing, Just localpart, ReceivedMessage m)
				| Just txt <- getBody "jabber:component:accept" m,
				  Just owner <- parseJID (unescapeJid localpart),
				  (T.length txt == 144 || T.length txt == 145) && (s"CHEOGRAM") `T.isPrefixOf` txt -> liftIO $ do -- the length of our token messages
					log "POSSIBLE TOKEN" (from, to, txt)
					maybeRoute <- TC.runTCM $ TC.get db (T.unpack (unescapeJid localpart) ++ "\0direct-message-route")
					when (Just (strDomain $ jidDomain from) == fmap fromString maybeRoute || bareTxt from == unescapeJid localpart) $ do
						maybeToken <- TC.runTCM $ TC.get db (T.unpack (unescapeJid localpart) ++ "\0addtoken")
						case (fmap (first parseJID) (readZ =<< maybeToken), parseJID $ unescapeJid localpart) of
							(Just (Just cheoJid, token), Just owner) | (s"CHEOGRAM"++token) == txt -> do
					maybeRoute <- DB.get db (DB.byJid owner ["direct-message-route"])
					when (Just (strDomain $ jidDomain from) == maybeRoute || bareTxt from == bareTxt owner) $ do
						maybeToken <- DB.get db (DB.byJid owner ["addtoken"])
						case (fmap (first parseJID) (readZ . textToString =<< maybeToken)) of
							(Just (Just cheoJid, token)) | (s"CHEOGRAM"++token) == txt -> do
								log "SET OWNER" (cheoJid, owner)

								True <- TC.runTCM (TC.put db (T.unpack (bareTxt owner) ++ "\0cheoJid") (T.unpack $ formatJID cheoJid))

								owners <- (fromMaybe [] . (readZ =<<)) <$>
									maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "owners")
								tcPut db cheoJid "owners" (show $ (T.unpack $ bareTxt owner) : owners)
								DB.set db (DB.byJid owner ["cheoJid"]) (formatJID cheoJid)
								DB.sadd db (DB.byNode cheoJid ["owners"]) [bareTxt owner]

							_ -> log "NO TOKEN FOUND, or mismatch" maybeToken
			(Just from, Just to, Nothing, Just localpart, _)


@@ 1374,7 1351,7 @@ component db redis pushStatsd backendHost did maybeAvatar cacheOOB sendIQ iqRece
					] } in
					-- TODO: should check if backend supports XEP-0033
					-- TODO: fallback for no-backend case should work
					mapM_ sendToComponent =<< componentMessage db componentJid m' Nothing (bareTxt from) (strResource <$> jidResource from) backendJid (getBody "jabber:component:accept" m')
					mapM_ sendToComponent =<< componentMessage db componentJid m' Nothing from backendJid (getBody "jabber:component:accept" m')
				| (s"sip.cheogram.com") == strDomain (jidDomain from) -> liftIO $ do
					let (toResource, fromResource)
						| Just toResource <- T.stripPrefix (s"CHEOGRAM%outbound-sip%") =<< (strResource <$> jidResource to) = (toResource, s"tel")


@@ 1390,11 1367,11 @@ component db redis pushStatsd backendHost did maybeAvatar cacheOOB sendIQ iqRece
								[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}item-not-found") [] []]
			(Just from, Just to, Nothing, Just localpart, _)
				| Nothing <- mapM localpartToURI (T.split (==',') $ fromMaybe mempty $ fmap strNode $ jidNode to),
				  Just routeTo <- parseJID (unescapeJid localpart ++ maybe mempty (s"/"++) (strResource <$> jidResource to)),
				  fmap (((s"CHEOGRAM%") `T.isPrefixOf`) . strResource) (jidResource to) /= Just True -> liftIO $ do
					let toResourceSuffix = maybe mempty (s"/"++) (strResource <$> jidResource to)
					maybeRoute <- TC.runTCM $ TC.get db (T.unpack (unescapeJid localpart) ++ "\0direct-message-route")
					case (fmap fromString maybeRoute, parseJID (unescapeJid localpart ++ toResourceSuffix), mapToComponent from) of
						(Just route, Just routeTo, Just componentFrom) | route == strDomain (jidDomain from) ->
					maybeRoute <- DB.get db (DB.byJid routeTo ["direct-message-route"])
					case (maybeRoute, mapToComponent from) of
						(Just route, Just componentFrom) | route == strDomain (jidDomain from) ->
							(sendToComponent . receivedStanza) =<< mapReceivedMessageM (UIO.lift . cacheOOB) (receivedStanzaFromTo componentFrom routeTo stanza)
						_ | Just jid <- (`telToJid` formatJID componentJid) =<< strNode <$> jidNode to -> do
							sendToComponent $ stanzaError stanza $


@@ 1605,9 1582,9 @@ sendToRoom cheoJid room msg = do
		messagePayloads = [Element (fromString "{jabber:component:accept}body") [] [NodeContent $ ContentText msg]]
	}]

leaveRoom :: TC.HDB -> JID -> String -> IO [StanzaRec]
leaveRoom :: DB.DB -> JID -> String -> IO [StanzaRec]
leaveRoom db cheoJid reason = do
	existingRoom <- tcGetJID db cheoJid "joined"
	existingRoom <- (parseJID =<<) <$> DB.get db (DB.byNode cheoJid ["joined"])
	return $ (flip map) (toList existingRoom) $ \leaveRoom ->
		mkStanzaRec $ (emptyPresence PresenceUnavailable) {
			presenceTo = Just leaveRoom,


@@ 1619,9 1596,9 @@ joinRoom db cheoJid room =
	rejoinRoom db cheoJid room False

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

	uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID


@@ 1665,7 1642,7 @@ mucShortMatch tel short muc =
	node = maybe mempty strNode (jidNode =<< parseJID muc)

sendInvite db to (Invite { inviteMUC = room, inviteFrom = from }) = do
	membersonly <- maybe False toEnum <$> TC.runTCM (TC.get db (T.unpack (bareTxt room) <> "\0muc_membersonly"))
	membersonly <- fromMaybe False <$> DB.getEnum db (DB.byJid room ["muc_membersonly"])
	-- Try to add everyone we invite as an owner also
	(++) <$> (if membersonly then addMUCOwner room from to else return []) <*>
		return [


@@ 1707,12 1684,12 @@ registerToGateway componentJid gatewayJid did password = return [
	]

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"
	nick <- fromMaybe (maybe (formatJID cheoJid) strNode (jidNode cheoJid)) <$> DB.get db (DB.byNode cheoJid ["nick"])
	existingRoom <- (fmap (\jid -> jid { jidResource = Nothing }) . parseJID =<<) <$> DB.get db (DB.byNode cheoJid ["joined"])
	case parseCommand txt existingRoom nick componentJid of
		Just JoinInvited -> do
			invitedRoom <- tcGetJID db cheoJid "invited"
			let toJoin = invitedRoom >>= \jid -> parseJID (bareTxt jid <> fromString "/" <> nick)
			invitedRoom <- (parseJID =<<) <$> DB.get db (DB.byNode cheoJid ["invited"])
			let toJoin = invitedRoom >>= \jid -> parseJID (bareTxt jid <> s"/" <> nick)
			case toJoin of
				Just room ->
					(++) <$>


@@ 1722,7 1699,7 @@ processSMS db componentJid conferenceServers smsJid cheoJid txt = do
		Just JoinInvitedWrong
			| Just room <- existingRoom -> sendToRoom cheoJid room (s"Join")
			| otherwise -> do
				invitedRoom <- tcGetJID db cheoJid "invited"
				invitedRoom <- (parseJID =<<) <$> DB.get db (DB.byNode cheoJid ["invited"])
				let toJoin = invitedRoom >>= \jid -> parseJID (bareTxt jid <> fromString "/" <> nick)
				case toJoin of
					Just room ->


@@ 1738,7 1715,7 @@ processSMS db componentJid conferenceServers smsJid cheoJid txt = do
				return roomCreateStanzas
		Just (Join room) -> do
			leaveRoom db cheoJid "Joined a different room."
			bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "bookmarks"))
			bookmarks <- DB.smembers db (DB.byNode cheoJid ["bookmarks"])
			let tel = maybe mempty strNode (jidNode cheoJid)
			joinRoom db cheoJid $
				fromMaybe room $ parseJID =<< fmap (<> fromString "/" <> nick)


@@ 1748,7 1725,7 @@ processSMS db componentJid conferenceServers smsJid cheoJid txt = 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))
			presence <- DB.smembers db (DB.Key ["presence", room])
			let presence' = filter (/= snick) $ map f presence
			if null presence then
				return [mkStanzaRec $ mkSMS componentJid smsJid $ fromString $


@@ 1762,15 1739,14 @@ processSMS db componentJid conferenceServers smsJid cheoJid txt = do
					intercalate ", " presence'
				]]
		Just List -> do
			mbookmarks <- maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "bookmarks")
			let bookmarks = fromMaybe [] $ readZ =<< mbookmarks
			bookmarks <- DB.smembers db (DB.byNode cheoJid ["bookmarks"])
			return [mkStanzaRec $ mkSMS componentJid smsJid $ fromString $ "Groups you can /join\n" <> intercalate "\n" bookmarks]
		Just (InviteCmd jid)
			| 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
			tcPut db cheoJid "nick" (T.unpack nick)
			DB.set db (DB.byNode cheoJid ["nick"]) nick
			fmap (concat . toList) $ forM existingRoom $ \room -> do
				let toJoin = parseJID (bareTxt room <> fromString "/" <> nick)
				fmap (concat . toList) $ forM toJoin $ joinRoom db cheoJid


@@ 1786,7 1762,7 @@ processSMS db componentJid conferenceServers smsJid cheoJid txt = do
			| 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
			tcPut db cheoJid "debounce" (show time)
			DB.set db (DB.byNode cheoJid ["debounce"]) (tshow time)
			return []
		Just Help -> return [
				mkStanzaRec $ mkSMS componentJid smsJid $ fromString $ mconcat [


@@ 1805,23 1781,19 @@ processSMS db componentJid conferenceServers smsJid cheoJid txt = do
			]
		Just (AddJid addjid) -> do
			token <- genToken 100
			True <- TC.runTCM $ TC.put db (T.unpack (bareTxt addjid) ++ "\0addtoken") (show (formatJID cheoJid, token))
			DB.set db (DB.byJid addjid ["addtoken"]) (tshow (formatJID cheoJid, token))
			return $ case parseJID (formatJID componentJid ++ s"/token") of
				Just sendFrom -> [mkStanzaRec $ mkSMS sendFrom smsJid (s"CHEOGRAM" ++ token)]
				Nothing -> []
		Just (DelJid deljid) -> do
			-- Deleting a JID is much less dangerous since in the worst case SMS just go to the actual phone number
			TC.runTCM $ TC.out db (T.unpack (bareTxt deljid) ++ "\0cheoJid")

			owners <- (fromMaybe [] . (readZ =<<)) <$>
				maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "owners")
			tcPut db cheoJid "owners" (show $ (filter (/= bareTxt deljid)) owners)
			DB.del db (DB.byJid deljid ["cheoJid"])
			DB.srem db (DB.byNode cheoJid ["owners"]) [bareTxt deljid]

			return [mkStanzaRec $ mkSMS componentJid smsJid (bareTxt deljid ++ s" removed from your phone number")]
		Just Jids -> do
			owners <- (fromMaybe [] . (readZ =<<)) <$>
				maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "owners")
			return [mkStanzaRec $ mkSMS componentJid smsJid $ fromString $ "JIDs owning this phone number:\n" <> intercalate "\n" owners]
			owners <- DB.smembers db (DB.byNode cheoJid ["owners"])
			return [mkStanzaRec $ mkSMS componentJid smsJid $ s"JIDs owning this phone number:\n" <> intercalate (s"\n") owners]
		Nothing -> return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "You sent an invalid message")]

syncCall chan req = do


@@ 1865,10 1837,9 @@ rejoinManager db sendToComponent componentJid toRoomPresences toRejoinManager =
		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
		(next =<<) $! (\x -> foldM x state (presenceKeys :: [String])) $ \state pkey -> do
			let Just muc = parseJID =<< T.stripPrefix (fromString "presence\0") (T.pack pkey)
			presences <- fmap (mapMaybe (ourJids muc) . fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db pkey)
		(next =<<) $! DB.foldKeysM db (DB.Key ["presence"]) state $ \state pkey@(DB.Key keyparts) -> do
			let Just muc = parseJID . fromString =<< atZ keyparts 1
			presences <- mapMaybe (ourJids muc) <$> DB.hgetall db pkey
			(\x -> foldM x state presences) $ \state (mucJid, cheoJid) ->
				case Map.lookup mucJid state of
					Nothing -> do


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

	globalAndLocal cheoJid from f = do
		modify ("presence\0" <> muc from) 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)
		True <- TC.runTCM $ TC.put db k $ show $ sort $ nubBy (equating fst) $ f presence
		return ()
		f (DB.Key ["presence", muc from])
		f (DB.byNode cheoJid [muc from, "presence"])
	muc = T.unpack . bareTxt
	resource x = fromMaybe "" (T.unpack . strResource <$> jidResource x)



@@ 1981,7 1940,7 @@ joinPartDebouncer db backendHost sendToComponent componentJid toRoomPresences to
			Just (_, _, j) | j /= join -> return $! Map.delete (cheoJid, from) state -- debounce
			Just (_, _, _) -> return state -- ignore dupe
			Nothing -> do
				expire <- fmap (fromMaybe (-1) . (readZ =<<)) (maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "debounce"))
				expire <- fmap (fromMaybe (-1) . (readZ . textToString =<<)) (DB.get db (DB.byNode cheoJid ["debounce"]))
				time <- getCurrentTime
				if expire < 0 then recordJoinPart cheoJid from mjid join else
					void $ forkIO $ threadDelay (expire*1000000) >> atomically (writeTChan toJoinPartDebouncer $ DebounceExpire cheoJid from time)


@@ 1999,7 1958,7 @@ joinPartDebouncer db backendHost sendToComponent componentJid toRoomPresences to
			(_, state') -> return state'


adhocBotManager :: (UIO.Unexceptional m, TC.TCDB db) => db -> JID -> (XMPP.Message -> UIO.UIO ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> (STM XMPP.Message) -> m ()
adhocBotManager :: (UIO.Unexceptional m) => DB.DB -> JID -> (XMPP.Message -> UIO.UIO ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> (STM XMPP.Message) -> m ()
adhocBotManager db componentJid sendMessage sendIQ messages = do
	cleanupChan <- atomicUIO newTChan
	statefulManager cleanupChan Map.empty


@@ 2021,12 1980,6 @@ adhocBotManager db componentJid sendMessage sendIQ messages = do
				return $ Map.insert key writer sessions
		statefulManager cleanupChan sessions'

openTokyoCabinet :: (TC.TCDB a) => String -> IO a
openTokyoCabinet pth = TC.runTCM $ do
	db <- TC.new
	True <- TC.open db pth [TC.OREADER, TC.OWRITER, TC.OCREAT]
	return db

data Avatar = Avatar Text Int64 Text

mkAvatar :: FilePath -> IO Avatar


@@ 2073,7 2026,7 @@ main = do
			(Config.Config componentJid (Config.ServerConfig host port) secret backendHost rawdid registrationJid conferences s5bListenOn (Config.ServerConfig s5bhost s5bport) jingleStore jingleStoreURL redisConnectInfo (Config.ServerConfig statsdHost statsdPort) maybeAvatarPath) <- Dhall.input Dhall.auto (fromString config)
			log "" "Starting..."
			let Just did = normalizeTel rawdid
			db <- openTokyoCabinet "./db.tcdb" :: IO TC.HDB
			db <- DB.mk "./db.tcdb"
			redis <- Redis.checkedConnect redisConnectInfo
			toJoinPartDebouncer <- atomically newTChan
			sendToComponent <- atomically newTChan


@@ 2108,23 2061,23 @@ main = do
			processDirectMessageRouteConfig <- ConfigureDirectMessageRoute.main (XMPP.jidDomain componentJid)
				(\userJid ->
					let userJid' = maybeUnescape userJid in
					(parseJID . fromString =<<) <$> TC.runTCM (TC.get db (T.unpack (bareTxt userJid') ++ "\0possible-route"))
					(parseJID =<<) <$> DB.get db (DB.byJid userJid' ["possible-route"])
				)
				(\userJid ->
					let userJid' = maybeUnescape userJid in
					(parseJID . fromString =<<) <$> TC.runTCM (TC.get db (T.unpack (bareTxt userJid') ++ "\0direct-message-route"))
					(parseJID =<<) <$> DB.get db (DB.byJid userJid' ["direct-message-route"])
				)
				(\userJid mgatewayJid -> do
					let userJid' = maybeUnescape userJid
					TC.runTCM (TC.out db (T.unpack (bareTxt userJid') ++ "\0possible-route"))
					DB.del db (DB.byJid userJid' ["possible-route"])
					case mgatewayJid of
						Just gatewayJid -> do
							maybeExistingRoute <- (parseJID . fromString =<<) <$> TC.runTCM (TC.get db (T.unpack (bareTxt userJid') ++ "\0direct-message-route"))
							maybeExistingRoute <- (parseJID =<<) <$> DB.get db (DB.byJid userJid' ["direct-message-route"])
							forM_ maybeExistingRoute $ \existingRoute ->
								when (existingRoute /= gatewayJid)
									(atomically . writeTChan sendToComponent . mkStanzaRec =<< unregisterDirectMessageRoute db componentJid userJid' existingRoute)

							True <- TC.runTCM $ TC.put db (T.unpack (bareTxt userJid') ++ "\0direct-message-route") (T.unpack $ formatJID gatewayJid)
							DB.set db (DB.byJid userJid' ["direct-message-route"]) (formatJID gatewayJid)

							forM_ (parseJID $ escapeJid (bareTxt userJid') ++ s"@" ++ formatJID componentJid) $ \from ->
								forM_ (parseJID $ did ++ s"@" ++ formatJID gatewayJid) $ \to ->


@@ 2133,8 2086,8 @@ main = do

							return ()
						Nothing -> do
							maybeExistingRoute <- (parseJID . fromString =<<) <$> TC.runTCM (TC.get db (T.unpack (bareTxt userJid') ++ "\0direct-message-route"))
							TC.runTCM $ TC.out db (T.unpack (bareTxt userJid') ++ "\0direct-message-route")
							maybeExistingRoute <- (parseJID =<<) <$> DB.get db (DB.byJid userJid' ["direct-message-route"])
							DB.del db (DB.byJid userJid' ["direct-message-route"])
							forM_ maybeExistingRoute $ \existingRoute ->
								atomically . writeTChan sendToComponent . mkStanzaRec =<< unregisterDirectMessageRoute db componentJid userJid' existingRoute
				)


M cheogram.cabal => cheogram.cabal +1 -1
@@ 21,7 21,7 @@ extra-source-files:

executable cheogram
        main-is: Main.hs
        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix, StanzaRec, Adhoc, Config
        other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix, StanzaRec, Adhoc, Config, DB
        default-language: Haskell2010
        ghc-options:      -Wall -Wno-tabs -Wno-orphans -Wno-name-shadowing -O2 -threaded