From a7337c029a57331d3e177d2509d9bfd007934d48 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Tue, 28 Feb 2017 22:00:08 -0500 Subject: [PATCH] Experimental start to the tel discovery/verification --- Main.hs | 30 +++++++++++++++++++++++++----- Util.hs | 8 ++++++++ cheogram.cabal | 2 ++ 3 files changed, 35 insertions(+), 5 deletions(-) diff --git a/Main.hs b/Main.hs index f9fbfab..ffde67a 100644 --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/Util.hs b/Util.hs index c7caaf6..f047790 100644 --- a/Util.hs +++ b/Util.hs @@ -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) diff --git a/cheogram.cabal b/cheogram.cabal index 17e5cd3..d709ca2 100644 --- a/cheogram.cabal +++ b/cheogram.cabal @@ -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, -- 2.38.5