From 6349966097b44cc4a1f32f12f2eefae75d6b95c3 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Wed, 1 Dec 2021 20:57:25 -0500 Subject: [PATCH] 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. --- Adhoc.hs | 18 +-- DB.hs | 116 +++++++++++++++++ Main.hs | 329 +++++++++++++++++++++---------------------------- cheogram.cabal | 2 +- 4 files changed, 267 insertions(+), 198 deletions(-) create mode 100644 DB.hs diff --git a/Adhoc.hs b/Adhoc.hs index 835c131..4397699 100644 --- a/Adhoc.hs +++ b/Adhoc.hs @@ -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 diff --git a/DB.hs b/DB.hs new file mode 100644 index 0000000..6820fee --- /dev/null +++ b/DB.hs @@ -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 diff --git a/Main.hs b/Main.hs index fe39e4c..2b5a28f 100644 --- a/Main.hs +++ b/Main.hs @@ -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 ) diff --git a/cheogram.cabal b/cheogram.cabal index dab40bc..7fd843f 100644 --- a/cheogram.cabal +++ b/cheogram.cabal @@ -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 -- 2.34.5