A Adhoc.hs => Adhoc.hs +220 -0
@@ 0,0 1,220 @@
+module Adhoc(adhocBotSession, commandList, queryCommandList) where
+
+import Prelude ()
+import BasicPrelude hiding (log)
+import Control.Concurrent.STM
+import Control.Error (hush)
+import Data.XML.Types as XML (Element(..), Node(NodeContent, NodeElement), Content(ContentText), isNamed, elementText, elementChildren, attributeText)
+
+import Network.Protocol.XMPP (JID(..), parseJID, formatJID, IQ(..), IQType(..), emptyIQ, Message(..))
+import qualified Network.Protocol.XMPP as XMPP
+
+import qualified Data.Attoparsec.Text as Atto
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.UUID as UUID ( toString )
+import qualified Data.UUID.V1 as UUID ( nextUUID )
+import qualified Database.TokyoCabinet as TC
+import qualified UnexceptionalIO as UIO
+
+import StanzaRec
+import UniquePrefix
+import Util
+import qualified ConfigureDirectMessageRoute
+
+botHelp :: IQ -> Maybe Message
+botHelp (IQ { iqTo = Just to, iqFrom = Just from, iqPayload = Just payload }) =
+ Just $ mkSMS from to $ (s"Help:\n\t") ++ intercalate (s"\n\t") (map (\item ->
+ fromMaybe mempty (attributeText (s"node") item) ++ s": " ++
+ fromMaybe mempty (attributeText (s"name") item)
+ ) items)
+ where
+ items = isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren payload
+botHelp _ = Nothing
+
+commandList :: JID -> Maybe Text -> JID -> JID -> [Element] -> IQ
+commandList componentJid qid from to extras =
+ (emptyIQ IQResult) {
+ iqTo = Just to,
+ iqFrom = Just from,
+ iqID = qid,
+ 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"jid", [ContentText $ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName]),
+ (s"node", [ContentText $ ConfigureDirectMessageRoute.nodeName]),
+ (s"name", [ContentText $ s"Configure direct message route"])
+ ] []
+ ] ++ extraItems)
+ }
+ where
+ extraItems = map (\el ->
+ NodeElement $ el {
+ elementAttributes = map (\(aname, acontent) ->
+ if aname == s"{http://jabber.org/protocol/disco#items}jid" || aname == s"jid" then
+ (aname, [ContentText $ formatJID componentJid])
+ else
+ (aname, acontent)
+ ) (elementAttributes el)
+ }
+ ) extras
+
+queryCommandList' :: JID -> JID -> IQ
+queryCommandList' to from =
+ (emptyIQ IQGet) {
+ iqTo = Just to,
+ iqFrom = Just from,
+ iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#items}query") [
+ (s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])
+ ] []
+ }
+
+queryCommandList :: JID -> JID -> IO [StanzaRec]
+queryCommandList to from = do
+ uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
+ return [mkStanzaRec $ (queryCommandList' to from) {iqID = uuid}]
+
+
+untilParse :: (UIO.Unexceptional m) => STM Message -> STM () -> Atto.Parser b -> m b
+untilParse getText onFail parser = do
+ text <- atomicUIO $ (fromMaybe mempty . getBody "jabber:component:accept") <$> getText
+ case Atto.parseOnly parser text of
+ Right v -> return v
+ Left _ -> do
+ atomicUIO onFail
+ untilParse getText onFail parser
+
+adhocBotAnswerListMulti :: (UIO.Unexceptional m) => JID -> (XMPP.Message -> STM ()) -> STM XMPP.Message -> JID -> Element -> m [Element]
+adhocBotAnswerListMulti componentJid sendMessage getMessage from field = do
+ case attributeText (s"var") field of
+ Just var -> do
+ let label = fromMaybe (s"Select") $ attributeText (s"label") field
+ let options = zip [1..] $ isNamed(s"{jabber:x:data}option") =<< elementChildren field
+ let optionsText = fmap (\(n, v) -> tshow n <> s". " <> optionText v) options
+ atomicUIO $ sendMessage $ mkSMS componentJid from $ unlines $ [label <> s": (enter numbers with commas or spaces between them)"] <> optionsText
+ values <- untilParse getMessage (sendMessage $ mkSMS componentJid from helperText) parser
+ let selectedOptions = fmap snd $ filter (\(x, _) -> x `elem` values) options
+ return [Element (s"{jabber:x:data}field") [(s"var", [ContentText var])] $ flip fmap selectedOptions $ \option ->
+ NodeElement $ Element (s"{jabber:x:data}value") [] [NodeContent $ ContentText $ optionValue option]
+ ]
+ _ -> log "ADHOC BOT FIELD WITHOUT VAR" field >> return []
+ where
+ parser = Atto.skipMany Atto.space *> Atto.sepBy (Atto.decimal :: Atto.Parser Int) (Atto.skipMany $ Atto.choice [Atto.space, Atto.char ',']) <* Atto.skipMany Atto.space <* Atto.endOfInput
+ helperText = s"I didn't understand your answer. Please send the numbers you want, separated by commas or spaces like \"1, 3\" or \"1 3\". Blank (or just spaces) to pick nothing."
+
+adhocBotAnswerListSingle :: (UIO.Unexceptional m) => JID -> (XMPP.Message -> STM ()) -> STM XMPP.Message -> JID -> Element -> m [Element]
+adhocBotAnswerListSingle componentJid sendMessage getMessage from field = do
+ case attributeText (s"var") field of
+ Just var -> do
+ let label = fromMaybe (s"Select") $ attributeText (s"label") field
+ let options = zip [1..] $ isNamed(s"{jabber:x:data}option") =<< elementChildren field
+ let optionsText = fmap (\(n, v) -> tshow n <> s". " <> optionText v) options
+ atomicUIO $ sendMessage $ mkSMS componentJid from $ unlines $ [label <> s": (enter one number)"] <> optionsText
+ value <- untilParse getMessage (sendMessage $ mkSMS componentJid from helperText) (Atto.skipMany Atto.space *> (Atto.decimal :: Atto.Parser Int) <* Atto.skipMany Atto.space)
+ let maybeOption = fmap snd $ find (\(x, _) -> x == value) options
+ case maybeOption of
+ Just option -> return [Element (s"{jabber:x:data}field") [(s"var", [ContentText var])] [
+ NodeElement $ Element (s"{jabber:x:data}value") [] [NodeContent $ ContentText $ optionValue option]
+ ]]
+ Nothing -> do
+ atomicUIO $ sendMessage $ mkSMS componentJid from $ s"Please pick one of the given options"
+ adhocBotAnswerListSingle componentJid sendMessage getMessage from field
+ _ -> log "ADHOC BOT FIELD WITHOUT VAR" field >> return []
+ where
+ helperText = s"I didn't understand your answer. Please just send the number of the one item you want to pick, like \"1\""
+
+adhocBotAnswerForm :: (UIO.Unexceptional m) => JID -> (XMPP.Message -> STM ()) -> STM XMPP.Message -> JID -> Element -> m Element
+adhocBotAnswerForm componentJid sendMessage getMessage from form = do
+ fields <- forM (elementChildren form) $ \field -> do
+ case field of
+ _
+ | elementName field == s"{jabber:x:data}instructions" -> atomicUIO (sendMessage $ mkSMS componentJid from $ mconcat $ elementText field) >> return []
+ _
+ | elementName field == s"{jabber:x:data}field",
+ attributeText (s"type") field == Just (s"list-single") ->
+ adhocBotAnswerListSingle componentJid sendMessage getMessage from field
+ _
+ | elementName field == s"{jabber:x:data}field",
+ attributeText (s"type") field == Just (s"list-multi") ->
+ adhocBotAnswerListMulti componentJid sendMessage getMessage from field
+ -- XXX: Should I pass a logger in here?
+ c -> fromIO_ (print c) >> return []
+ return $ Element (s"{jabber:x:data}x") [(s"type", [ContentText $ s"submit"])] $ NodeElement <$> mconcat fields
+
+optionText :: Element -> Text
+optionText element = fromMaybe (optionValue element) $ attributeText (s"label") element
+
+optionValue :: Element -> Text
+optionValue element = mconcat $ elementText =<< isNamed(s"{jabber:x:data}value") =<< elementChildren element
+
+adhocBotRunCommand :: (UIO.Unexceptional m) => JID -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> STM XMPP.Message -> JID -> Text -> [Element] -> m ()
+adhocBotRunCommand componentJid routeFrom sendMessage sendIQ getMessage from body cmdEls = do
+ let (nodes, cmds) = unzip $ mapMaybe (\el -> (,) <$> attributeText (s"node") el <*> pure el) cmdEls
+ case snd <$> find (\(prefixes, _) -> Set.member body prefixes) (zip (uniquePrefix nodes) cmds) of
+ Just cmd -> do
+ let cmdIQ = (emptyIQ IQSet) {
+ iqFrom = Just routeFrom,
+ iqTo = parseJID =<< attributeText (s"jid") cmd,
+ iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") [(s"node", [ContentText $ fromMaybe mempty $ attributeText (s"node") cmd])] []
+ }
+ sendAndRespondTo cmdIQ
+ Nothing -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs. Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
+ where
+ sendAndRespondTo cmdIQ = do
+ mcmdResult <- atomicUIO =<< UIO.lift (sendIQ cmdIQ)
+ case mcmdResult of
+ Just resultIQ
+ | IQResult == iqType resultIQ,
+ Just payload <- iqPayload resultIQ,
+ [note] <- isNamed (s"{http://jabber.org/protocol/commands}note") =<< elementChildren payload ->
+ atomicUIO $ sendMessage $ mkSMS componentJid from $ mconcat $ elementText note
+ | IQResult == iqType resultIQ,
+ Just payload <- iqPayload resultIQ,
+ Just sessionid <- attributeText (s"sessionid") payload,
+ [form] <- isNamed (s"{jabber:x:data}x") =<< elementChildren payload -> do
+ returnForm <- adhocBotAnswerForm componentJid sendMessage getMessage from form
+ let actions = listToMaybe $ isNamed(s"{http://jabber.org/protocol/commands}actions") =<< elementChildren payload
+ -- The standard says if actions is present, with no "execute" attribute, that the default is "next"
+ -- But if there is no actions, the default is "execute"
+ let defaultAction = maybe (s"execute") (fromMaybe (s"next") . attributeText (s"execute")) actions
+ let cmdIQ' = (emptyIQ IQSet) {
+ iqFrom = Just routeFrom,
+ iqTo = iqFrom resultIQ,
+ iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") [(s"node", [ContentText $ fromMaybe mempty $ attributeText (s"node") payload]), (s"sessionid", [ContentText sessionid]), (s"action", [ContentText defaultAction])] [NodeElement returnForm]
+ }
+ sendAndRespondTo cmdIQ'
+ | otherwise -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Command error")
+ Nothing -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Command timed out")
+
+adhocBotSession :: (UIO.Unexceptional m, TC.TCDB db) => db -> JID -> (XMPP.Message -> STM ()) -> (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,
+ body == s"help" = 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
+ Just route -> do
+ mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
+ let helpMessage = botHelp $ commandList componentJid Nothing componentJid from $
+ isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren =<< maybeToList (XMPP.iqPayload =<< mfilter ((== XMPP.IQResult) . XMPP.iqType) mreply)
+ case helpMessage of
+ Just msg -> atomicUIO $ sendMessage msg
+ Nothing -> log "INVALID HELP MESSAGE" mreply
+ Nothing ->
+ case botHelp $ commandList componentJid Nothing componentJid from [] of
+ Just msg -> atomicUIO $ sendMessage msg
+ Nothing -> log "INVALID HELP MESSAGE" ()
+ | 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
+ Just route -> do
+ mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
+ case iqPayload =<< mfilter ((==IQResult) . iqType) mreply of
+ Just reply -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ getMessage from body (elementChildren reply)
+ Nothing -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ getMessage from body (elementChildren =<< maybeToList (iqPayload $ commandList componentJid Nothing componentJid from []))
+ Nothing -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ getMessage from body (elementChildren =<< maybeToList (iqPayload $ commandList componentJid Nothing componentJid from []))
+ | otherwise =
+ atomicUIO $ sendMessage $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs. Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
+ where
+ Just routeFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/adhocbot"
+adhocBotSession _ _ _ _ _ m = log "BAD ADHOC BOT MESSAGE" m
M Main.hs => Main.hs +22 -122
@@ 10,7 10,7 @@ import Control.Concurrent.STM
import Data.Foldable (forM_, mapM_, toList)
import Data.Traversable (forM, mapM)
import System.Environment (getArgs)
-import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe, headZ, hush)
+import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe, headZ)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Network (PortID(PortNumber))
import Network.URI (parseURI, uriPath)
@@ 25,7 25,6 @@ import qualified Network.StatsD as StatsD
import "monads-tf" Control.Monad.Error (catchError) -- ick
import Data.XML.Types as XML (Element(..), Node(NodeContent, NodeElement), Name(Name), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText, attributeContent, hasAttribute, nameNamespace)
import qualified UnexceptionalIO as UIO
-import qualified Data.Set as Set
import qualified Dhall
import qualified Dhall.Core as Dhall hiding (Decoder)
import qualified Jingle
@@ 44,33 43,17 @@ import qualified Database.TokyoCabinet as TC
import qualified Database.Redis as Redis
import qualified Text.Regex.PCRE.Light as PCRE
import Network.Protocol.XMPP as XMPP -- should import qualified
-import Network.Protocol.XMPP.Internal -- should import qualified
import Util
-import UniquePrefix
import IQManager
import qualified RedisURL
import qualified ConfigureDirectMessageRoute
+import Adhoc (adhocBotSession, commandList, queryCommandList)
+import StanzaRec
instance Ord JID where
compare x y = compare (show x) (show y)
-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
- stanzaTo (StanzaRec to _ _ _ _ _) = to
- stanzaFrom (StanzaRec _ from _ _ _ _) = from
- stanzaID (StanzaRec _ _ id _ _ _) = id
- stanzaLang (StanzaRec _ _ _ lang _ _) = lang
- stanzaPayloads (StanzaRec _ _ _ _ payloads _) = payloads
- stanzaToElement (StanzaRec _ _ _ _ _ element) = element
-
-mkSMS from to txt = (emptyMessage MessageChat) {
- messageTo = Just to,
- messageFrom = Just from,
- messagePayloads = [Element (fromString "{jabber:component:accept}body") [] [NodeContent $ ContentText txt]]
-}
-
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)
@@ 81,8 64,6 @@ tcPut db cheoJid key val = liftIO $ do
True <- TC.runTCM (TC.put db tck val)
return ()
-getBody ns = listToMaybe . fmap (mconcat . elementText) . (isNamed (Name (fromString "body") (Just $ fromString ns) Nothing) <=< messagePayloads)
-
queryDisco to from = queryDiscoWithNode Nothing to from
queryDiscoWithNode node to from = do
@@ 94,19 75,6 @@ queryDiscoWithNode node to from = do
iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") (map (\node -> (s"{http://jabber.org/protocol/disco#info}node", [ContentText node])) $ maybeToList node) []
}]
-queryCommandList' to from =
- (emptyIQ IQGet) {
- iqTo = Just to,
- iqFrom = Just from,
- iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#items}query") [
- (s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])
- ] []
- }
-
-queryCommandList to from = do
- uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
- return [mkStanzaRec $ (queryCommandList' to from) {iqID = uuid}]
-
fillFormField var value form = form {
elementNodes = map (\node ->
case node of
@@ 250,41 218,6 @@ telDiscoInfo q id from to disco =
) (sort $ nub $ telDiscoFeatures ++ disco)
}
-botHelp commandListIq@(IQ { iqTo = Just to, iqFrom = Just from, iqPayload = Just payload }) =
- mkSMS from to $ (s"Help:\n\t") ++ intercalate (s"\n\t") (map (\item ->
- fromMaybe mempty (attributeText (s"node") item) ++ s": " ++
- fromMaybe mempty (attributeText (s"name") item)
- ) items)
- where
- items = isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren payload
-
-commandList componentJid id from to extras =
- (emptyIQ IQResult) {
- iqTo = Just to,
- iqFrom = Just from,
- 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"jid", [ContentText $ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName]),
- (s"node", [ContentText $ ConfigureDirectMessageRoute.nodeName]),
- (s"name", [ContentText $ s"Configure direct message route"])
- ] []
- ] ++ extraItems)
- }
- where
- extraItems = map (\el ->
- NodeElement $ el {
- elementAttributes = map (\(aname, acontent) ->
- if aname == s"{http://jabber.org/protocol/disco#items}jid" || aname == s"jid" then
- (aname, [ContentText $ formatJID componentJid])
- else
- (aname, acontent)
- ) (elementAttributes el)
- }
- ) extras
-
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
@@ 1838,61 1771,28 @@ joinPartDebouncer db backendHost sendToComponent componentJid toRoomPresences to
| t == time -> sendPart cheoJid from time >> return state'
(_, state') -> return state'
-adhocBotRunCommand :: (UIO.Unexceptional m) => JID -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> JID -> Text -> [Element] -> m ()
-adhocBotRunCommand componentJid routeFrom sendMessage sendIQ from body cmdEls = do
- let (nodes, cmds) = unzip $ mapMaybe (\el -> (,) <$> attributeText (s"node") el <*> pure el) cmdEls
- case snd <$> (find (\(prefixes, _) -> Set.member body prefixes) $ zip (uniquePrefix nodes) cmds) of
- Just cmd -> do
- let cmdIQ = (emptyIQ IQSet) {
- iqFrom = Just routeFrom,
- iqTo = parseJID =<< (attributeText (s"jid") cmd),
- iqPayload = Just $ Element (s"{http://jabber.org/protocol/commands}command") [(s"node", [ContentText $ fromMaybe mempty $ attributeText (s"node") cmd])] []
- }
- mcmdResult <- atomicUIO =<< (UIO.lift $ sendIQ $ cmdIQ)
- case mcmdResult of
- Just resultIQ
- | IQResult == iqType resultIQ,
- Just payload <- iqPayload resultIQ,
- [note] <- isNamed (s"{http://jabber.org/protocol/commands}note") =<< elementChildren payload ->
- atomicUIO $ sendMessage $ mkSMS componentJid from $ mconcat $ elementText note
- | otherwise -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Command error")
- Nothing -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Command timed out")
- Nothing -> atomicUIO $ sendMessage $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs. Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
-
-adhocBotSession :: (UIO.Unexceptional m, TC.TCDB db) => db -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> XMPP.Message -> m ()
-adhocBotSession db componentJid sendMessage sendIQ message@(XMPP.Message { XMPP.messageFrom = Just from })
- | Just body <- getBody "jabber:component:accept" message,
- body == s"help" = do
- maybeRoute <- fmap (join . hush) $ UIO.fromIO $ TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
- (atomicUIO . sendMessage) =<< case parseJID =<< fmap fromString maybeRoute of
- Just route -> do
- mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
- return $ botHelp $ commandList componentJid Nothing componentJid from $
- isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren =<< maybeToList (XMPP.iqPayload =<< mfilter ((== XMPP.IQResult) . XMPP.iqType) mreply)
- Nothing ->
- return $ botHelp $ commandList componentJid Nothing componentJid 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
- Just route -> do
- mreply <- atomicUIO =<< (UIO.lift . sendIQ) (queryCommandList' route routeFrom)
- case (iqPayload =<< mfilter ((==IQResult) . iqType) mreply) of
- Just reply -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ from body (elementChildren reply)
- Nothing -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ from body (elementChildren =<< (maybeToList $ iqPayload $ commandList componentJid Nothing componentJid from []))
- Nothing -> adhocBotRunCommand componentJid routeFrom sendMessage sendIQ from body (elementChildren =<< (maybeToList $ iqPayload $ commandList componentJid Nothing componentJid from []))
- | otherwise =
- atomicUIO $ sendMessage $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs. Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
- where
- Just routeFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/adhocbot"
-adhocBotSession _ _ _ _ m = log "BAD ADHOC BOT MESSAGE" m
adhocBotManager :: (UIO.Unexceptional m, TC.TCDB db) => db -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> (STM XMPP.Message) -> m ()
adhocBotManager db componentJid sendMessage sendIQ messages = do
- forever $ do
- message <- atomicUIO messages
- -- Lookup from map based on message from for a thread to send to
- -- If no thread, make new one
- UIO.fork $ adhocBotSession db componentJid sendMessage sendIQ message
+ cleanupChan <- atomicUIO newTChan
+ statefulManager cleanupChan Map.empty
+ where
+ statefulManager cleanupChan sessions = do
+ join $ atomicUIO $ (processMessage cleanupChan sessions <$> messages) <|> (cleanupSession cleanupChan sessions <$> readTChan cleanupChan)
+
+ cleanupSession cleanupChan sessions sessionToClean = statefulManager cleanupChan $! (Map.delete sessionToClean sessions)
+
+ processMessage cleanupChan sessions message = do
+ -- XXX: At some point this should not include resource, but it makes it easy to test for now
+ let key = bareTxt <$> (XMPP.stanzaFrom message)
+ sessions' <- case Map.lookup key sessions of
+ Just input -> input message >> return sessions
+ Nothing -> do
+ newChan <- atomicUIO newTChan
+ UIO.forkFinally (adhocBotSession db componentJid sendMessage sendIQ (readTChan newChan) message) (\_ -> atomicUIO $ writeTChan cleanupChan key)
+ let writer = (atomicUIO . writeTChan newChan)
+ return $ Map.insert key writer sessions
+ statefulManager cleanupChan sessions'
openTokyoCabinet :: (TC.TCDB a) => String -> IO a
openTokyoCabinet pth = TC.runTCM $ do
A StanzaRec.hs => StanzaRec.hs +20 -0
@@ 0,0 1,20 @@
+module StanzaRec (StanzaRec(..), mkStanzaRec) where
+
+import BasicPrelude
+import qualified Data.XML.Types as XML
+import qualified Network.Protocol.XMPP as XMPP
+import Network.Protocol.XMPP.Internal (Stanza(..))
+
+data StanzaRec = StanzaRec (Maybe XMPP.JID) (Maybe XMPP.JID) (Maybe Text) (Maybe Text) [XML.Element] XML.Element deriving (Show)
+
+instance Stanza StanzaRec where
+ stanzaTo (StanzaRec to _ _ _ _ _) = to
+ stanzaFrom (StanzaRec _ from _ _ _ _) = from
+ stanzaID (StanzaRec _ _ sid _ _ _) = sid
+ stanzaLang (StanzaRec _ _ _ lang _ _) = lang
+ stanzaPayloads (StanzaRec _ _ _ _ payloads _) = payloads
+ stanzaToElement (StanzaRec _ _ _ _ _ element) = element
+
+mkStanzaRec :: (Stanza s) => s -> StanzaRec
+mkStanzaRec x = StanzaRec (stanzaTo x) (stanzaFrom x) (stanzaID x) (stanzaLang x) (stanzaPayloads x) (stanzaToElement x)
+
M Util.hs => Util.hs +13 -1
@@ 9,7 9,7 @@ import Data.Char (isDigit)
import Control.Applicative (many)
import Control.Error (hush)
import Data.Time (getCurrentTime)
-import Data.XML.Types as XML (Name, Element(..), Node(NodeElement), isNamed, elementText, elementChildren, attributeText)
+import Data.XML.Types as XML (Name(Name), Element(..), Node(NodeElement, NodeContent), Content(ContentText), isNamed, elementText, elementChildren, attributeText)
import Crypto.Random (getSystemDRG, withRandomBytes)
import Data.ByteString.Base58 (bitcoinAlphabet, encodeBase58)
import Data.Digest.Pure.SHA (sha1, bytestringDigest)
@@ 124,9 124,11 @@ parsePhoneContext txt = hush $ Atto.parseOnly (
<* Atto.endOfInput
) txt
+bareTxt :: XMPP.JID -> Text
bareTxt (XMPP.JID (Just node) domain _) = mconcat [XMPP.strNode node, s"@", XMPP.strDomain domain]
bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain
+getFormField :: XML.Element -> Text -> Maybe Text
getFormField form var =
listToMaybe $ mapMaybe (\node ->
case node of
@@ 206,3 208,13 @@ discoToCaps query =
discoToCapsHash :: XML.Element -> ByteString
discoToCapsHash query =
LZ.toStrict $ bytestringDigest $ sha1 $ LZ.fromStrict $ T.encodeUtf8 $ discoToCaps query
+
+getBody :: String -> XMPP.Message -> Maybe Text
+getBody ns = listToMaybe . fmap (mconcat . XML.elementText) . (XML.isNamed (XML.Name (fromString "body") (Just $ fromString ns) Nothing) <=< XMPP.messagePayloads)
+
+mkSMS :: XMPP.JID -> XMPP.JID -> Text -> XMPP.Message
+mkSMS from to txt = (XMPP.emptyMessage XMPP.MessageChat) {
+ XMPP.messageTo = Just to,
+ XMPP.messageFrom = Just from,
+ XMPP.messagePayloads = [XML.Element (fromString "{jabber:component:accept}body") [] [XML.NodeContent $ XML.ContentText txt]]
+}
M cheogram.cabal => cheogram.cabal +1 -1
@@ 21,7 21,7 @@ extra-source-files:
executable cheogram
main-is: Main.hs
- other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix
+ other-modules: ConfigureDirectMessageRoute, Util, RedisURL, IQManager, UniquePrefix, StanzaRec, Adhoc
default-language: Haskell2010
ghc-options: -Wno-tabs -Wno-orphans