From bebbcb16ef789b65790cd4fb53301a2a12d0b8ca Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Tue, 31 Jan 2017 18:20:13 -0500 Subject: [PATCH] Proxy through the registration form and record the route --- ConfigureDirectMessageRoute.hs | 253 +++++++++++++++++++++++++++++++++ Main.hs | 106 ++++++++------ Util.hs | 48 +++++++ cheogram.cabal | 1 + 4 files changed, 363 insertions(+), 45 deletions(-) create mode 100644 ConfigureDirectMessageRoute.hs create mode 100644 Util.hs diff --git a/ConfigureDirectMessageRoute.hs b/ConfigureDirectMessageRoute.hs new file mode 100644 index 0000000..479b2e6 --- /dev/null +++ b/ConfigureDirectMessageRoute.hs @@ -0,0 +1,253 @@ +module ConfigureDirectMessageRoute (main, nodeName) where + +import Prelude () +import BasicPrelude hiding (log) +import Data.Foldable (toList) +import Control.Concurrent +import Control.Concurrent.STM +import Data.Time (UTCTime, diffUTCTime, getCurrentTime) +import Data.XML.Types (Element(..), Node(NodeContent, NodeElement), Name(..), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText) +import Control.Monad.Loops (iterateM_) + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.UUID (UUID) +import qualified Data.UUID as UUID (toString, fromString) +import qualified Data.UUID.V1 as UUID (nextUUID) +import qualified Network.Protocol.XMPP as XMPP + +import Util + +newtype SessionID = SessionID UUID deriving (Ord, Eq, Show) + +main :: (XMPP.JID -> XMPP.JID -> IO ()) -> IO (XMPP.IQ -> IO XMPP.IQ) +main setRouteJid = do + stanzas <- newTQueueIO + void $ forkIO $ iterateM_ (\sessions -> do + (iq, reply) <- atomically (readTQueue stanzas) + (sessions', response) <- processOneIQ setRouteJid sessions iq + atomically $ reply response + now <- getCurrentTime + return $! Map.filter (\(_, time) -> now `diffUTCTime` time < 600) sessions' + ) Map.empty + return (\iq -> do + result <- atomically newEmptyTMVar + atomically $ writeTQueue stanzas (iq, putTMVar result) + atomically $ readTMVar result + ) + +processOneIQ :: (XMPP.JID -> XMPP.JID -> IO ()) -> Map SessionID (Session, UTCTime) -> XMPP.IQ -> IO (Map SessionID (Session, UTCTime), XMPP.IQ) +processOneIQ setRouteJid sessions iq@(XMPP.IQ { XMPP.iqID = Just iqID, XMPP.iqFrom = Just from, XMPP.iqPayload = realPayload }) + | Just sid <- sessionIDFromText . snd =<< T.uncons =<< T.stripPrefix (s"ConfigureDirectMessageRoute") iqID, + XMPP.iqType iq == XMPP.IQResult = + lookupAndStepSession setRouteJid sessions sid iqID from payload + | elementName payload /= s"{http://jabber.org/protocol/commands}command" || + attributeText (s"node") payload /= Just nodeName = do + log "ConfigureDirectMessageRoute.processOneIQ BAD INPUT" (elementName payload, attributeText (s"node") payload) + return (sessions, iqError (Just iqID) (Just from) "cancel" "feature-not-implemented" Nothing) + | Just sid <- sessionIDFromText =<< attributeText (s"sessionid") payload = + lookupAndStepSession setRouteJid sessions sid iqID from payload + | otherwise = do + (sid, session) <- newSession + now <- getCurrentTime + return (Map.insert sid (session, now) sessions, stage1 from iqID sid) + where + payload = fromMaybe (Element (s"no-payload") [] []) realPayload +processOneIQ _ sessions iq@(XMPP.IQ { XMPP.iqID = iqID, XMPP.iqFrom = from }) = do + log "ConfigureDirectMessageRoute.processOneIQ BAD INPUT" iq + return (sessions, iqError iqID from "cancel" "feature-not-implemented" Nothing) + +lookupAndStepSession :: (XMPP.JID -> XMPP.JID -> IO ()) -> Map SessionID (Session, UTCTime) -> Session' (IO (Map SessionID (Session, UTCTime), XMPP.IQ)) +lookupAndStepSession setRouteJid sessions sid iqID from payload + | Just (stepSession, _) <- Map.lookup sid sessions = + if attributeText (s"{http://jabber.org/protocol/commands}action") payload == Just (s"cancel") then + return (Map.delete sid sessions, (XMPP.emptyIQ XMPP.IQResult) { + XMPP.iqID = Just iqID, + XMPP.iqTo = Just from, + XMPP.iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") + [ + (s"{http://jabber.org/protocol/commands}node", [ContentText nodeName]), + (s"{http://jabber.org/protocol/commands}sessionid", [ContentText $ sessionIDToText sid]), + (s"{http://jabber.org/protocol/commands}status", [ContentText $ s"cancelled"]) + ] [] + }) + else + let (session', iq) = stepSession sid iqID from payload in + fmap (flip (,) iq) $ case session' of + SessionNext s -> do + now <- getCurrentTime + return $! Map.insert sid (s, now) sessions + SessionCancel -> return $! Map.delete sid sessions + SessionComplete userJid gatewayJid -> do + userJid `setRouteJid` gatewayJid + return $! Map.delete sid sessions + | otherwise = do + log "ConfigureDirectMessageRoute.processOneIQ NO SESSION FOUND" (sid, iqID, from, payload) + return (sessions, iqError (Just iqID) (Just from) "modify" "bad-request" (Just "bad-sessionid")) + +data SessionResult = SessionNext Session | SessionCancel | SessionComplete XMPP.JID XMPP.JID +type Session' a = SessionID -> Text -> XMPP.JID -> Element -> a +type Session = Session' (SessionResult, XMPP.IQ) + +data RegisterFormType = DataForm | LegacyRegistration + +stage5 :: Text -> XMPP.JID -> Session +stage5 stage4iqID stage4from sid iqID from error = + (SessionComplete stage4from from, (XMPP.emptyIQ XMPP.IQResult) { + XMPP.iqID = Just stage4iqID, + XMPP.iqTo = Just stage4from, + XMPP.iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") + [ + (s"{http://jabber.org/protocol/commands}node", [ContentText nodeName]), + (s"{http://jabber.org/protocol/commands}sessionid", [ContentText $ sessionIDToText sid]), + (s"{http://jabber.org/protocol/commands}status", [ContentText $ s"completed"]) + ] + [ + NodeElement $ Element (s"{http://jabber.org/protocol/commands}note") [ + (s"{http://jabber.org/protocol/commands}type", [ContentText $ s"info"]) + ] [ + NodeContent $ ContentText $ s"Registration complete." + ] + ] + }) + +stage4 :: RegisterFormType -> XMPP.JID -> Session +stage4 formType gatewayJid sid iqID from command + | [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren command, + Just sendFrom <- XMPP.parseJID $ (escapeJid $ bareTxt from) ++ s"@cheogram" = + (SessionNext $ stage5 iqID from, (XMPP.emptyIQ XMPP.IQSet) { + XMPP.iqID = Just (s"ConfigureDirectMessageRoute4" ++ sessionIDToText sid), + XMPP.iqTo = Just gatewayJid, + XMPP.iqFrom = Just sendFrom, -- domain gets rewritten by main cheogram program + XMPP.iqPayload = Just $ + case formType of + DataForm -> Element (s"{jabber:iq:register}query") [] [NodeElement form] + LegacyRegistration -> convertFormToLegacyRegistration form + }) + | otherwise = (SessionCancel, iqError (Just iqID) (Just from) "modify" "bad-request" (Just "bad-payload")) + +stage3 :: Text -> XMPP.JID -> Session +stage3 stage2iqID stage2from sid iqID from query + | [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query = processForm DataForm form + | otherwise = processForm LegacyRegistration (convertQueryToForm query) + where + processForm typ form = + (SessionNext $ stage4 typ from, (XMPP.emptyIQ XMPP.IQResult) { + XMPP.iqID = Just stage2iqID, + XMPP.iqTo = Just stage2from, + XMPP.iqPayload = Just $ commandStage sid form + }) + +stage2 :: Session +stage2 sid iqID from command + | [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren command, + Just gatewayJid <- XMPP.parseJID =<< getFormField form (s"gateway-jid") = + (SessionNext $ stage3 iqID from, (XMPP.emptyIQ XMPP.IQGet) { + XMPP.iqID = Just (s"ConfigureDirectMessageRoute2" ++ sessionIDToText sid), + XMPP.iqTo = Just gatewayJid, + XMPP.iqPayload = Just $ Element (s"{jabber:iq:register}query") [] [] + }) + | otherwise = (SessionCancel, iqError (Just iqID) (Just from) "modify" "bad-request" (Just "bad-payload")) + +stage1 :: XMPP.JID -> Text -> SessionID -> XMPP.IQ +stage1 iqTo iqID sid = (XMPP.emptyIQ XMPP.IQResult) { + XMPP.iqTo = Just iqTo, + XMPP.iqID = Just iqID, + XMPP.iqPayload = Just $ commandStage sid $ + Element (fromString "{jabber:x:data}x") [ + (fromString "{jabber:x:data}type", [ContentText $ s"form"]) + ] [ + NodeElement $ Element (fromString "{jabber:x:data}title") [] [NodeContent $ ContentText $ s"Configure Direct Message Route"], + NodeElement $ Element (fromString "{jabber:x:data}instructions") [] [ + NodeContent $ ContentText $ s"Enter the JID of a gateway to use for routing your direct messages over SMS." + ], + NodeElement $ Element (fromString "{jabber:x:data}field") [ + (fromString "{jabber:x:data}type", [ContentText $ s"jid-single"]), + (fromString "{jabber:x:data}var", [ContentText $ s"gateway-jid"]), + (fromString "{jabber:x:data}label", [ContentText $ s"Gateway JID"]) + ] [] + ] +} + +commandStage :: SessionID -> Element -> Element +commandStage sid el = Element (s"{http://jabber.org/protocol/commands}command") + [ + (s"{http://jabber.org/protocol/commands}node", [ContentText nodeName]), + (s"{http://jabber.org/protocol/commands}sessionid", [ContentText $ sessionIDToText sid]), + (s"{http://jabber.org/protocol/commands}status", [ContentText $ s"executing"]) + ] + [ + NodeElement $ Element (s"{http://jabber.org/protocol/commands}actions") [ + (s"{http://jabber.org/protocol/commands}execute", [ContentText $ s"next"]) + ] [ + NodeElement $ Element (s"{http://jabber.org/protocol/commands}next") [] [] + ], + NodeElement el + ] + +newSession :: IO (SessionID, Session) +newSession = UUID.nextUUID >>= go + where + go (Just uuid) = return (SessionID uuid, stage2) + go Nothing = do + log "ConfigureDirectMessageRoute.newSession" "UUID generation failed" + UUID.nextUUID >>= go + +sessionIDFromText :: Text -> Maybe SessionID +sessionIDFromText txt = SessionID <$> UUID.fromString (textToString txt) + +sessionIDToText :: SessionID -> Text +sessionIDToText (SessionID uuid) = fromString $ UUID.toString uuid + +nodeName :: Text +nodeName = s"configure-direct-message-route" + +iqError :: Maybe Text -> Maybe XMPP.JID -> String -> String -> Maybe String -> XMPP.IQ +iqError iqID to typ xmpp command = (XMPP.emptyIQ XMPP.IQError) { + XMPP.iqID = iqID, + XMPP.iqTo = to, + XMPP.iqPayload = Just $ + Element (s"{jabber:component:accept}error") + [(s"{jabber:component:accept}type", [ContentText $ fromString typ])] + ( + (NodeElement $ Element (fromString $ "{urn:ietf:params:xml:ns:xmpp-stanzas}" ++ xmpp) [] []) : + map (\name -> + NodeElement $ Element (fromString $ "{http://jabber.org/protocol/commands}" ++ name) [] [] + ) (toList command) + ) +} + +convertFormToLegacyRegistration :: Element -> Element +convertFormToLegacyRegistration form = + Element (s"{jabber:iq:register}query") [] $ + map (NodeElement . uncurry legacyEl . varAndValue) fields + where + legacyEl var value = Element (fromString $ "{jabber:iq:register}" ++ T.unpack var) [] [NodeContent $ ContentText value] + varAndValue field = ( + fromMaybe mempty $ attributeText (s"var") field, + mconcat $ elementText =<< isNamed (s"{jabber:x:data}value") =<< elementChildren field + ) + fields = isNamed (s"{jabber:x:data}field") =<< elementChildren form + +convertQueryToForm :: Element -> Element +convertQueryToForm query = + Element (s"{jabber:x:data}x") [ + (s"{jabber:x:data}type", [ContentText $ s"form"]) + ] ([ + NodeElement $ Element (fromString "{jabber:x:data}title") [] [NodeContent $ ContentText $ s"Register"], + NodeElement $ Element (fromString "{jabber:x:data}instructions") [] [NodeContent $ ContentText instructions] + ] ++ map (NodeElement . field) vars) + where + field var = + Element (fromString "{jabber:x:data}field") [ + (s"{jabber:x:data}type", [ContentText $ if var == s"password" then s"text-private" else s"text-single"]), + (s"{jabber:x:data}var", [ContentText var]), + (s"{jabber:x:data}label", [ContentText var]) + ] [] + instructions = mconcat $ elementText =<< isNamed (s"{jabber:iq:register}instructions") =<< elementChildren query + vars = + map snd $ + filter (\(ns, var) -> ns == s"jabber:iq:register" && var `notElem` [s"registered", s"instructions"]) $ + mapMaybe (\el -> let name = elementName el in (,) <$> nameNamespace name <*> pure (nameLocalName name)) $ + elementChildren query diff --git a/Main.hs b/Main.hs index b3e51f2..ae49de2 100644 --- a/Main.hs +++ b/Main.hs @@ -24,14 +24,12 @@ import qualified Data.UUID.V1 as UUID ( nextUUID ) import qualified Database.TokyoCabinet as TC import Network.Protocol.XMPP -- should import qualified +import Util +import qualified ConfigureDirectMessageRoute + instance Ord JID where compare x y = compare (show x) (show y) -log :: (Show a, MonadIO m) => String -> a -> m () -log tag x = liftIO $ do - time <- getCurrentTime - putStr (fromString $ show time <> " " <> tag <> " :: ") >> print x >> putStrLn mempty - data StanzaRec = StanzaRec (Maybe JID) (Maybe JID) (Maybe Text) (Maybe Text) [Element] Element deriving (Show) mkStanzaRec x = StanzaRec (stanzaTo x) (stanzaFrom x) (stanzaID x) (stanzaLang x) (stanzaPayloads x) (stanzaToElement x) instance Stanza StanzaRec where @@ -84,18 +82,6 @@ fillFormField var value form = form { ) (elementNodes form) } -getFormField form var = - listToMaybe $ mapMaybe (\node -> - case node of - NodeElement el - | elementName el == fromString "{jabber:x:data}field" && - (attributeText (fromString "{jabber:x:data}var") el == Just var || - attributeText (fromString "var") el == Just var) -> - Just $ mconcat $ - elementText =<< isNamed (fromString "{jabber:x:data}value") =<< elementChildren el - _ -> Nothing - ) (elementNodes form) - data Invite = Invite { inviteMUC :: JID, inviteFrom :: JID, @@ -138,9 +124,6 @@ forkXMPP kid = do session <- getSession liftIO $ forkIO $ void $ runXMPP session kid -bareTxt (JID (Just node) domain _) = mconcat [strNode node, fromString "@", strDomain domain] -bareTxt (JID Nothing domain _) = strDomain domain - nickFor db jid existingRoom | fmap bareTxt existingRoom == Just bareFrom = return $ fromMaybe (fromString "nonick") resourceFrom | Just tel <- normalizeTel =<< strNode <$> jidNode jid = do @@ -476,12 +459,12 @@ handleRegister _ _ iq _ = do log "HANDLEREGISTER UNKNOWN" iq return [] -componentStanza _ _ _ _ _ _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) +componentStanza _ _ _ _ _ _ _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) | [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< messagePayloads m, not $ null $ code "104" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do log "CODE104" (to, from) queryDisco from to -componentStanza db mapToBackend _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) +componentStanza db mapToBackend _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) | Just smsJid <- mapToBackend to = do log "RECEIVEDMESSAGE" m existingRoom <- tcGetJID db to "joined" @@ -519,7 +502,7 @@ componentStanza db mapToBackend _ _ _ componentJid (ReceivedMessage (m@Message { }] where resourceFrom = strResource <$> jidResource from -componentStanza _ mapToBackend _ toRejoinManager _ componentJid (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to, presenceID = Just id })) +componentStanza _ mapToBackend _ toRejoinManager _ _ componentJid (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to, presenceID = Just id })) | fromString "CHEOGRAMREJOIN%" `T.isPrefixOf` id = do log "FAILED TO REJOIN, try again in 10s" p void $ forkIO $ threadDelay 10000000 >> atomically (writeTChan toRejoinManager $ ForceRejoin from to) @@ -530,7 +513,7 @@ componentStanza _ mapToBackend _ toRejoinManager _ componentJid (ReceivedPresenc isNamed (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}text") =<< elementChildren =<< isNamed (fromString "{jabber:component:accept}error") =<< presencePayloads p return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "* Failed to join " <> bareTxt from <> errorText)] -componentStanza db mapToBackend toRoomPresences toRejoinManager toJoinPartDebouncer componentJid (ReceivedPresence (Presence { +componentStanza db mapToBackend toRoomPresences toRejoinManager toJoinPartDebouncer _ componentJid (ReceivedPresence (Presence { presenceType = typ, presenceFrom = Just from, presenceTo = Just to, @@ -540,7 +523,7 @@ componentStanza db mapToBackend toRoomPresences toRejoinManager toJoinPartDeboun existingRoom <- tcGetJID db to "joined" log "JOIN PART ROOM" (from, to, typ, existingRoom, payloads) handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads (typ == PresenceAvailable) -componentStanza _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do +componentStanza _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do log "APPROVE SUBSCRIPTION" (from, to) log "SUBSCRIBE" (from, to) return [ @@ -553,7 +536,7 @@ componentStanza _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = Presenc presenceFrom = Just to } ] -componentStanza _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do +componentStanza _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do log "RESPOND TO PROBES" (from, to) return [mkStanzaRec $ (emptyPresence PresenceAvailable) { presenceTo = Just from, @@ -567,12 +550,21 @@ componentStanza _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = Presenc ] [] ] }] -componentStanza db _ _ _ _ componentJid (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p })) +componentStanza _ _ _ _ _ processDirectMessageRouteConfig componentJid (ReceivedIQ iq@(IQ { iqTo = Just to, iqPayload = payload })) + | (jidNode to == Nothing && fmap elementName payload == Just (s"{http://jabber.org/protocol/commands}command")) || + fmap strResource (jidResource to) == Just ConfigureDirectMessageRoute.nodeName = do + log "PART OF COMMAND" iq + replyIQ <- processDirectMessageRouteConfig iq + let fromLocalpart = maybe mempty (\localpart -> localpart++s"@") (fmap strNode . jidNode =<< iqFrom replyIQ) + return [mkStanzaRec $ replyIQ { + iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/" ++ ConfigureDirectMessageRoute.nodeName) + }] +componentStanza db _ _ _ _ _ componentJid (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p })) | iqType iq `elem` [IQGet, IQSet], [query] <- isNamed (fromString "{jabber:iq:register}query") p = do log "LOOKS LIKE REGISTRATION" iq handleRegister db componentJid iq query -componentStanza _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p })) +componentStanza _ _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p })) | Nothing <- jidNode to, [_] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do log "DISCO ON US" (from, to, p) @@ -598,7 +590,25 @@ componentStanza _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from ] [] ] }] -componentStanza _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p })) + | Nothing <- jidNode to, + [s"http://jabber.org/protocol/commands"] == + mapMaybe (attributeText (s"node")) (isNamed (fromString "{http://jabber.org/protocol/disco#items}query") p) = do + log "componentStanza QUERY FOR COMMAND LIST" to + return [mkStanzaRec $ (emptyIQ IQResult) { + iqTo = Just from, + iqFrom = Just to, + iqID = id, + iqPayload = Just $ Element (s"{http://jabber.org/protocol/disco#items}query") + [(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])] + [ + NodeElement $ Element (s"{http://jabber.org/protocol/disco#items}item") [ + (s"{http://jabber.org/protocol/disco#items}jid", [ContentText $ formatJID componentJid ++ s"/" ++ ConfigureDirectMessageRoute.nodeName]), + (s"{http://jabber.org/protocol/disco#items}node", [ContentText $ ConfigureDirectMessageRoute.nodeName]), + (s"{http://jabber.org/protocol/disco#items}name", [ContentText $ s"Configure direct message route"]) + ] [] + ] + }] +componentStanza _ _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p })) | Just _ <- jidNode to, [_] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do log "DISCO ON USER" (from, to, p) @@ -619,7 +629,7 @@ componentStanza _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from ] [] ] }] -componentStanza _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQSet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p })) +componentStanza _ _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQSet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p })) | [query] <- isNamed (fromString "{jabber:iq:gateway}query") p, [prompt] <- isNamed (fromString "{jabber:iq:gateway}prompt") =<< elementChildren query = do log "jabber:iq:gateway submit" (from, to, p) @@ -646,7 +656,7 @@ componentStanza _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQSet, iqFr [NodeContent $ ContentText $ fromString "Only US/Canada telephone numbers accepted"] ] }] -componentStanza _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p })) +componentStanza _ _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just (to@JID {jidNode = Nothing}), iqID = id, iqPayload = Just p })) | [_] <- isNamed (fromString "{jabber:iq:gateway}query") p = do log "jabber:iq:gateway query" (from, to, p) return [mkStanzaRec $ (emptyIQ IQResult) { @@ -659,7 +669,7 @@ componentStanza _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from NodeElement $ Element (fromString "{jabber:iq:gateway}prompt") [ ] [NodeContent $ ContentText $ fromString "Phone Number"] ] }] -componentStanza db _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) +componentStanza db _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) | (strNode <$> jidNode to) == Just (fromString "create"), Just resource <- strResource <$> jidResource to = do log "create@ ERROR" (from, to, iq) @@ -672,7 +682,7 @@ componentStanza db _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQError, i leaveRoom db cheoJid "Joined a different room." <*> joinRoom db cheoJid room _ -> return [] -- Invalid packet, ignore -componentStanza _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to })) +componentStanza _ _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to })) | (strNode <$> jidNode to) == Just (fromString "create"), Just resource <- strResource <$> jidResource to = do log "create@ RESULT" (from, to, iq) @@ -682,21 +692,21 @@ componentStanza _ _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQResult, i (cheoJidT:name:servers) | Just cheoJid <- parseJID cheoJidT -> createRoom componentJid servers cheoJid name _ -> return [] -- Invalid packet, ignore -componentStanza _ _ _ toRejoinManager _ _ (ReceivedIQ (iq@IQ { iqType = IQResult, iqID = Just id, iqFrom = Just from })) +componentStanza _ _ _ toRejoinManager _ _ _ (ReceivedIQ (iq@IQ { iqType = IQResult, iqID = Just id, iqFrom = Just from })) | fromString "CHEOGRAMPING%" `T.isPrefixOf` id = do log "PING RESULT" from atomically $ writeTChan toRejoinManager (PingReply from) return [] -componentStanza _ _ _ toRejoinManager _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqID = Just id, iqFrom = Just from })) +componentStanza _ _ _ toRejoinManager _ _ _ (ReceivedIQ (iq@IQ { iqType = IQError, iqID = Just id, iqFrom = Just from })) | fromString "CHEOGRAMPING%" `T.isPrefixOf` id = do log "PING ERROR RESULT" from atomically $ writeTChan toRejoinManager (PingError from) return [] -componentStanza _ mapToBackend _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) +componentStanza _ mapToBackend _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQError, iqFrom = Just from, iqTo = Just to })) | Just smsJid <- mapToBackend to = do log "IQ ERROR" iq return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "Error while querying or configuring " <> formatJID from)] -componentStanza _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p })) +componentStanza _ _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id, iqPayload = Just p })) | [query] <- isNamed (fromString "{http://jabber.org/protocol/muc#owner}query") p, [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query = do log "DISCO RESULT" (from, to, p) @@ -715,14 +725,14 @@ componentStanza _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQResult, iqFrom = Just f form { elementAttributes = [(fromString "{jabber:x:data}type", [ContentText $ fromString "submit"])] } ] }] -componentStanza _ mapToBackend _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id })) +componentStanza _ mapToBackend _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType = IQResult, iqFrom = Just from, iqTo = Just to, iqID = Just id })) | Just smsJid <- mapToBackend to, fromString "CHEOGRAMCREATE%" `T.isPrefixOf` id = do log "CHEOGRAMCREATE RESULT YOU HAVE CREATED" (from, to, iq) fmap (((mkStanzaRec $ mkSMS componentJid smsJid (mconcat [fromString "* You have created ", bareTxt from])):) . concat . toList) $ forM (parseJID $ bareTxt to <> fromString "/create") $ queryDisco from -componentStanza db _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p })) +componentStanza db _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to, iqFrom = Just from, iqPayload = Just p })) | Just _ <- strNode <$> jidNode to, [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do log "DISCO RESULT" (from, to, p) @@ -736,7 +746,7 @@ componentStanza db _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQResult, iqT sendInvite db jid (Invite from to Nothing Nothing) else return [] -componentStanza _ _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqPayload = Just p })) +componentStanza _ _ _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqPayload = Just p })) | not $ null $ isNamed (fromString "{urn:xmpp:ping}ping") p = do log "urn:xmpp:ping" (from, to) return [mkStanzaRec $ iq { @@ -745,7 +755,7 @@ componentStanza _ _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = IQGet, iqFrom = Just f iqType = IQResult, iqPayload = Nothing }] -componentStanza _ _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = typ })) +componentStanza _ _ _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = typ })) | typ `elem` [IQGet, IQSet] = do log "REPLY WITH IQ ERROR" iq return [mkStanzaRec $ iq { @@ -756,7 +766,7 @@ componentStanza _ _ _ _ _ _ (ReceivedIQ (iq@IQ { iqType = typ })) [(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])] [NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented") [] []] }] -componentStanza _ _ _ _ _ _ s = do +componentStanza _ _ _ _ _ _ _ s = do log "UNKNOWN STANZA" s return [] @@ -766,7 +776,7 @@ participantJid payloads = elementChildren =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads -component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toComponent componentJid conferenceServers = do +component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toComponent processDirectMessageRouteConfig componentJid conferenceServers = do thread <- forkXMPP $ forever $ flip catchError (log "component EXCEPTION") $ do stanza <- liftIO $ atomically $ readTChan toComponent log "COMPONENT OUT" stanza @@ -796,7 +806,7 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC (_, Just txt, Just cheoJid) -> mapM_ sendToComponent =<< processSMS db componentJid conferenceServers from cheoJid txt _ -> - mapM_ sendToComponent =<< componentStanza db (mapToBackend backendHost) toRoomPresences toRejoinManager toJoinPartDebouncer componentJid s + mapM_ sendToComponent =<< componentStanza db (mapToBackend backendHost) toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid s where mapToComponent = mapToBackend (formatJID componentJid) sendToComponent = atomically . writeTChan toComponent @@ -1289,10 +1299,16 @@ main = do void $ forkIO $ forever $ atomically (writeTChan toRejoinManager CheckPings) >> threadDelay 120000000 void $ forkIO $ rejoinManager db (atomically . writeTChan sendToComponent) name toRoomPresences toRejoinManager + processDirectMessageRouteConfig <- ConfigureDirectMessageRoute.main (\userJid gatewayJid -> do + log "SETTING DIRECT MESSAGE ROUTE" (userJid, gatewayJid) + True <- TC.runTCM $ TC.put db (T.unpack (bareTxt userJid) ++ "\0direct-message-route") (T.unpack $ formatJID gatewayJid) + return () + ) + forever $ do log "" "runComponent STARTING" (log "runComponent ENDED" <=< (runEitherT . syncIO)) $ runComponent (Server componentJid host (PortNumber $ fromIntegral (read port :: Int))) (fromString secret) - (component db (fromString backendHost) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent componentJid (map fromString conferences)) + (component db (fromString backendHost) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent processDirectMessageRouteConfig componentJid (map fromString conferences)) _ -> log "ERROR" "Bad arguments" diff --git a/Util.hs b/Util.hs new file mode 100644 index 0000000..ab09ac2 --- /dev/null +++ b/Util.hs @@ -0,0 +1,48 @@ +module Util where + +import Prelude () +import BasicPrelude + +import Data.Time (getCurrentTime) +import Data.XML.Types (Element(..), Node(NodeElement), isNamed, elementText, elementChildren, attributeText) +import qualified Data.Text as T +import qualified Network.Protocol.XMPP as XMPP + +log :: (Show a, MonadIO m) => String -> a -> m () +log tag x = liftIO $ do + time <- getCurrentTime + putStr (show time ++ s" " ++ fromString tag ++ s" :: ") >> print x >> putStrLn mempty + +s :: (IsString a) => String -> a +s = fromString + +escapeJid :: Text -> Text +escapeJid txt = T.concatMap (\char -> + case char of + ' ' -> s"\\20" + '"' -> s"\\22" + '&' -> s"\\26" + '\'' -> s"\\27" + '/' -> s"\\2f" + ':' -> s"\\3a" + '<' -> s"\\3c" + '>' -> s"\\3e" + '@' -> s"\\40" + '\\' -> s"\\5c" + c -> T.singleton c + ) txt + +bareTxt (XMPP.JID (Just node) domain _) = mconcat [XMPP.strNode node, s"@", XMPP.strDomain domain] +bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain + +getFormField form var = + listToMaybe $ mapMaybe (\node -> + case node of + NodeElement el + | elementName el == s"{jabber:x:data}field" && + (attributeText (s"{jabber:x:data}var") el == Just var || + attributeText (s"var") el == Just var) -> + Just $ mconcat $ + elementText =<< isNamed (s"{jabber:x:data}value") =<< elementChildren el + _ -> Nothing + ) (elementNodes form) diff --git a/cheogram.cabal b/cheogram.cabal index b20623c..11b2d53 100644 --- a/cheogram.cabal +++ b/cheogram.cabal @@ -29,6 +29,7 @@ executable cheogram case-insensitive, containers, errors < 2.0.0, + monad-loops, monads-tf, network, network-protocol-xmpp == 0.4.8, -- 2.38.5