@@ 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
@@ 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"