~singpolyma/cheogram

a7337c029a57331d3e177d2509d9bfd007934d48 — Stephen Paul Weber 3 years ago 65dd07e
Experimental start to the tel discovery/verification
3 files changed, 35 insertions(+), 5 deletions(-)

M Main.hs
M Util.hs
M cheogram.cabal
M Main.hs => Main.hs +25 -5
@@ 918,8 918,8 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC
	flip catchError (\e -> liftIO (log "component part 2 EXCEPTION" e >> killThread thread)) $ forever $ do
		stanza <- getStanza
		log "COMPONENT  IN" stanza
		liftIO $ case (stanzaFrom $ receivedStanza stanza, stanzaTo $ receivedStanza stanza, mapToBackend backendHost =<< stanzaTo (receivedStanza stanza), fmap strNode . jidNode =<< stanzaTo (receivedStanza stanza)) of
			(Just from, Just to, _, _)
		liftIO $ case (stanzaFrom $ receivedStanza stanza, stanzaTo $ receivedStanza stanza, mapToBackend backendHost =<< stanzaTo (receivedStanza stanza), fmap strNode . jidNode =<< stanzaTo (receivedStanza stanza), stanza) of
			(Just from, Just to, _, _, _)
				| strDomain (jidDomain from) == backendHost,
				  to == componentJid ->
					case stanza of


@@ 930,7 930,19 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC
							  Just cheoJid <- mapToComponent from ->
								mapM_ sendToComponent =<< processSMS db componentJid conferenceServers from cheoJid txt
						_ -> log "backend no match" stanza
			(Just from, Just to, Nothing, Just localpart)
			(Just from, Just to, Nothing, Just localpart, ReceivedMessage m)
				| Just txt <- getBody "jabber:component:accept" m,
				  T.length txt == 146 -> do -- the length of our token messages
					log "POSSIBLE TOKEN" (from, to, txt)
					maybeRoute <- TC.runTCM $ TC.get db (T.unpack (unescapeJid localpart) ++ "\0direct-message-route")
					when (Just (formatJID from) == fmap fromString maybeRoute || bareTxt from == unescapeJid localpart) $ do
						maybeToken <- TC.runTCM $ TC.get db (T.unpack (unescapeJid localpart) ++ "\0addtoken")
						case (fmap (first parseJID) (readZ =<< maybeToken), parseJID $ unescapeJid localpart) of
							(Just (Just cheoJid, token), Just owner) | (s"CHEOGRAM"++token) == txt -> do
								log "SET OWNER" (cheoJid, owner)
								tcPutJID db cheoJid "owner" owner
							_ -> log "NO TOKEN FOUND, or mismatch" maybeToken
			(Just from, Just to, Nothing, Just localpart, _)
				| 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")


@@ 956,7 968,7 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC
								Element (fromString "{jabber:component:accept}error")
								[(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
								[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}item-not-found") [] []]
			(_, _, backendTo, _) ->
			(_, _, backendTo, _, _) ->
				mapM_ sendToComponent =<< componentStanza db backendTo toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid stanza
	where
	mapToComponent = mapToBackend (formatJID componentJid)


@@ 1030,7 1042,7 @@ stripCIPrefix prefix str
	where
	(prefix', rest) = T.splitAt (T.length $ CI.original prefix) str

data Command = Help | Create Text | Join JID | JoinInvited | JoinInvitedWrong | Debounce Int | Send Text | Who | List | Leave | InviteCmd JID | SetNick Text | Whisper JID Text
data Command = Help | Create Text | Join JID | JoinInvited | JoinInvitedWrong | Debounce Int | Send Text | Who | List | Leave | InviteCmd JID | SetNick Text | Whisper JID Text | AddJid JID
	deriving (Show, Eq)

parseCommand txt room nick componentJid


@@ 1041,6 1053,8 @@ parseCommand txt room nick componentJid
		)
	| Just room <- stripCIPrefix (fromString "/join ") txt =
		Join <$> (parseJID (room <> fromString "/" <> nick) <|> parseJID room)
	| Just addjid <- stripCIPrefix (fromString "/addjid ") txt =
		AddJid <$> parseJID addjid
	| Just t <- stripCIPrefix (fromString "/create ") txt = Just $ Create t
	| Just nick <- stripCIPrefix (fromString "/nick ") txt = Just $ SetNick nick
	| Just input <- stripCIPrefix (fromString "/msg ") txt =


@@ 1278,6 1292,12 @@ processSMS db componentJid conferenceServers smsJid cheoJid txt = do
						"More info: http://cheogram.com"
					]
			]
		Just (AddJid addjid) -> do
			token <- genToken 100
			True <- TC.runTCM $ TC.put db (T.unpack (bareTxt addjid) ++ "\0addtoken") (show (formatJID cheoJid, token))
			return [
					mkStanzaRec $ mkSMS componentJid smsJid (s"CHEOGRAM" ++ token)
				]
		Nothing -> return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "You sent an invalid message")]

syncCall chan req = do

M Util.hs => Util.hs +8 -0
@@ 6,7 6,10 @@ import Control.Applicative (many)

import Data.Time (getCurrentTime)
import Data.XML.Types (Element(..), Node(NodeElement), isNamed, elementText, elementChildren, attributeText)
import Crypto.Random (getSystemDRG, withRandomBytes)
import Data.ByteString.Base58 (bitcoinAlphabet, encodeBase58)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.Protocol.XMPP as XMPP
import qualified Data.Attoparsec.Text as Atto



@@ 68,3 71,8 @@ getFormField form var =
						elementText =<< isNamed (s"{jabber:x:data}value") =<< elementChildren el
				_ -> Nothing
		) (elementNodes form)

genToken :: Int -> IO Text
genToken n = do
	g <- getSystemDRG
	return $ fst $ withRandomBytes g n (T.decodeUtf8 . encodeBase58 bitcoinAlphabet)

M cheogram.cabal => cheogram.cabal +2 -0
@@ 27,10 27,12 @@ executable cheogram
                base == 4.*,
                basic-prelude <= 0.3.5.0,
                attoparsec,
                base58-bytestring,
                base64-bytestring,
                bytestring >= 0.10.0.0,
                case-insensitive,
                containers,
                cryptonite,
                errors < 2.0.0,
                monad-loops,
                monads-tf,