2 files changed, 67 insertions(+), 32 deletions(-)

M Main.hs
M cheogram.cabal

@@ 13,14 13,18 @@ import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
 import Network (PortID(PortNumber))
 import System.Random (Random(randomR), getStdRandom)
 import System.Random.Shuffle (shuffleM)
+import Data.Digest.Pure.SHA (sha1, bytestringDigest)
 
 import "monads-tf" Control.Monad.Error (catchError) -- ick
 import Data.XML.Types (Element(..), Node(NodeContent, NodeElement), Name(Name), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import qualified Data.Map as Map
 import qualified Data.UUID as UUID ( toString )
 import qualified Data.UUID.V1 as UUID ( nextUUID )
+import qualified Data.ByteString.Lazy as LZ
+import qualified Data.ByteString.Base64 as Base64
 import qualified Database.TokyoCabinet as TC
 import Network.Protocol.XMPP -- should import qualified
 


@@ 156,27 160,57 @@ cheogramAvailable from to =
 	}
 
 telDiscoFeatures = [
-		"http://jabber.org/protocol/muc",
-		"jabber:x:conference",
-		"urn:xmpp:ping"
+		s"http://jabber.org/protocol/muc",
+		s"jabber:x:conference",
+		s"urn:xmpp:ping"
 	]
 
+telCapsStr extraVars =
+	s"client/sms//Cheogram<" ++ mconcat (intersperse (s"<") (sort (nub (telDiscoFeatures ++ extraVars)))) ++ s"<"
+
 telAvailable from to disco =
 	(emptyPresence PresenceAvailable) {
 		presenceTo = Just to,
 		presenceFrom = Just from,
-		presencePayloads = []
+		presencePayloads = [
+			Element (s"{http://jabber.org/protocol/caps}c") [
+				(s"{http://jabber.org/protocol/caps}hash", [ContentText $ fromString "sha-1"]),
+				(s"{http://jabber.org/protocol/caps}node", [ContentText $ fromString "xmpp:cheogram.com"]),
+				(s"{http://jabber.org/protocol/caps}ver", [ContentText hash])
+			] []
+		]
+	}
+	where
+	hash = T.decodeUtf8 $ Base64.encode $ LZ.toStrict $ bytestringDigest $ sha1 $ LZ.fromStrict $ T.encodeUtf8 $ telCapsStr disco
+
+telDiscoInfo id from to disco =
+	(emptyIQ IQResult) {
+		iqTo = Just to,
+		iqFrom = Just from,
+		iqID = Just id,
+		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] $
+			[
+				NodeElement $ Element (s"{http://jabber.org/protocol/disco#info}identity") [
+					(s"{http://jabber.org/protocol/disco#info}category", [ContentText $ s"client"]),
+					(s"{http://jabber.org/protocol/disco#info}type", [ContentText $ s"sms"]),
+					(s"{http://jabber.org/protocol/disco#info}name", [ContentText $ s"Cheogram"])
+				] []
+			] ++ map (\var ->
+				NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [
+					(fromString "{http://jabber.org/protocol/disco#info}var", [ContentText var])
+				] []
+			) (sort $ nub $ telDiscoFeatures ++ disco)
 	}
 
-routeDiscoOrPresenceReply db componentJid from to smsJid = do
+routeDiscoOrReply db componentJid from smsJid resource reply = do
 	maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
 	case (fmap fromString maybeRoute, maybeRouteFrom) of
 		(Just route, Just routeFrom) ->
 				let routeTo = fromMaybe componentJid $ parseJID $ (fromMaybe mempty $ strNode <$> jidNode smsJid) ++ s"@" ++ route in
 				queryDisco routeTo routeFrom
-		_ -> return [mkStanzaRec $ telAvailable to from []]
+		_ -> return [mkStanzaRec $ reply]
 	where
-	maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/query-then-send-presence"
+	maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/" ++ (fromString resource)
 
 componentMessage _ componentJid (m@Message { messageType = MessageError }) _ _ _ smsJid body = do
 	log "MESSAGE ERROR"  m


@@ 555,7 589,7 @@ componentStanza _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = Prese
 		]
 componentStanza db (Just smsJid) _ _ _ _ componentJid (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Just _ } })) = do
 	log "SUBSCRIBE TEL" (from, to)
-	stanzas <- routeDiscoOrPresenceReply db componentJid from to smsJid
+	stanzas <- routeDiscoOrReply db componentJid from smsJid "CHEOGRAM%query-then-send-presence" $ telAvailable to from []
 	return $ [
 			mkStanzaRec $ (emptyPresence PresenceSubscribed) {
 				presenceTo = Just from,


@@ 571,15 605,15 @@ componentStanza _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = Prese
 	return [mkStanzaRec $ cheogramAvailable to from]
 componentStanza db (Just smsJid) _ _ _ _ componentJid (ReceivedPresence (Presence { presenceType = PresenceProbe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Just _ } })) = do
 	log "RESPOND TO TEL PROBES" smsJid
-	routeDiscoOrPresenceReply db componentJid from to smsJid
+	routeDiscoOrReply db componentJid from smsJid "CHEOGRAM%query-then-send-presence" $ telAvailable to from []
 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
+	  fmap strResource (jidResource to) == Just (s"CHEOGRAM%" ++ 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)
+			iqFrom = parseJID (fromLocalpart ++ formatJID componentJid ++ s"/CHEOGRAM%" ++ ConfigureDirectMessageRoute.nodeName)
 		}]
 componentStanza db _ _ _ _ _ componentJid (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p }))
 	| iqType iq `elem` [IQGet, IQSet],


@@ 630,27 664,15 @@ componentStanza _ _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqFro
 					] []
 				]
 		}]
-componentStanza _ _ _ _ _ _ _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p }))
+componentStanza db (Just smsJid) _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = Just 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)
-		return [mkStanzaRec $ (emptyIQ IQResult) {
-			iqTo = Just from,
-			iqFrom = Just to,
-			iqID = id,
-			iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] $
-				[
-					NodeElement $ Element (s"{http://jabber.org/protocol/disco#info}identity") [
-						(s"{http://jabber.org/protocol/disco#info}category", [ContentText $ s"client"]),
-						(s"{http://jabber.org/protocol/disco#info}type", [ContentText $ s"sms"]),
-						(s"{http://jabber.org/protocol/disco#info}name", [ContentText $ s"Cheogram"])
-					] []
-				] ++ map (\var ->
-					NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [
-						(fromString "{http://jabber.org/protocol/disco#info}var", [ContentText $ fromString "http://jabber.org/protocol/muc"])
-					] []
-				) telDiscoFeatures
-		}]
+		routeDiscoOrReply db componentJid from smsJid ("CHEOGRAM%query-then-send-disco-info%" ++ extra) $
+			telDiscoInfo id to from []
+	where
+	extra = T.unpack $ escapeJid $ T.pack $ show (id, fromMaybe mempty resourceFrom)
+	resourceFrom = strResource <$> jidResource from
 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


@@ 753,7 775,18 @@ componentStanza _ (Just smsJid) _ _ _ _ componentJid (ReceivedIQ (iq@IQ { iqType
 			forM (parseJID $ bareTxt to <> fromString "/create") $
 				queryDisco from
 componentStanza db _ _ _ _ _ componentJid (ReceivedIQ (IQ { iqType = IQResult, iqTo = Just to@(JID { jidNode = Just toNode }), iqFrom = Just from, iqPayload = Just p }))
-	| fmap strResource (jidResource to) == Just (s"query-then-send-presence"),
+	| Just idAndResource <- T.stripPrefix (s"CHEOGRAM%query-then-send-disco-info%") . strResource =<< jidResource to,
+	  Just (iqID, resource) <- readZ $ T.unpack $ unescapeJid idAndResource,
+	  [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p,
+	  Just routeTo <- parseJID (unescapeJid (strNode toNode) ++ if T.null resource then mempty else s"/" ++ resource),
+	  Just fromNode <- jidNode from,
+	  Just routeFrom <- parseJID (strNode fromNode ++ s"@" ++ formatJID componentJid) = do
+		log "DISCO RESULT, NOW SEND INFO ONWARD" (from, to, routeFrom, routeTo)
+		return [
+				mkStanzaRec $ telDiscoInfo iqID routeFrom routeTo $ mapMaybe (attributeText (fromString "var")) $
+				isNamed (fromString "{http://jabber.org/protocol/disco#info}feature") =<< elementChildren query
+			]
+	| fmap strResource (jidResource to) == Just (s"CHEOGRAM%query-then-send-presence"),
 	  [query] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p,
 	  Just routeTo <- parseJID (unescapeJid (strNode toNode)),
 	  Just fromNode <- jidNode from,


@@ 839,8 872,7 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC
 								mapM_ sendToComponent =<< processSMS db componentJid conferenceServers from cheoJid txt
 						_ -> log "backend no match" stanza
 			(Just from, Just to, Nothing, Just localpart)
-				| fmap strResource (jidResource to) /= Just ConfigureDirectMessageRoute.nodeName,
-				  fmap strResource (jidResource to) /= Just (s"query-then-send-presence") -> do
+				| fmap (((s"CHEOGRAM%") `T.isPrefixOf`) . strResource) (jidResource to) /= Just True -> 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

@@ 27,6 27,8 @@ executable cheogram
                 base == 4.*,
                 basic-prelude <= 0.3.5.0,
                 attoparsec,
+                base64-bytestring,
+                bytestring,
                 case-insensitive,
                 containers,
                 errors < 2.0.0,


@@ 36,6 38,7 @@ executable cheogram
                 network-protocol-xmpp == 0.4.8,
                 random,
                 random-shuffle,
+                SHA,
                 stm,
                 text,
                 time,