From 4dfe5b8c3d62bfae1a0e5b00c478e2be78b4916d Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Sat, 21 Nov 2015 14:50:35 -0500 Subject: [PATCH] Initial --- Main.hs | 175 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 175 insertions(+) create mode 100644 Main.hs diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..0a1c684 --- /dev/null +++ b/Main.hs @@ -0,0 +1,175 @@ +import System.Environment +import Data.String +import Network +import Network.Protocol.XMPP +import Data.List +import Data.Foldable (forM_) +import Control.Monad hiding (forM_) +import Control.Monad.IO.Class +import Data.String +import Data.XML.Types +import Control.Applicative +import Data.Monoid +import Data.Maybe +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.STM.TChan +import Data.Text (Text) +import qualified Data.UUID as UUID +import qualified Data.UUID.V1 as UUID +import qualified Data.Text as T +import qualified Database.TokyoCabinet as TC + +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 + +writeStanzaChan chan = atomically . writeTChan chan . mkStanzaRec + +getBody ns = listToMaybe . fmap (mconcat . elementText) . (isNamed (Name (fromString "body") (Just $ fromString ns) Nothing) <=< messagePayloads) + +forkXMPP :: XMPP () -> XMPP ThreadId +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 + +code110 status = + hasAttributeText (fromString "{http://jabber.org/protocol/muc#user}code") (== (fromString "110")) status + <> + hasAttributeText (fromString "code") (== (fromString "110")) status + +componentMessage db toVitelity MessageGroupChat mid existingRoom bareFrom resourceFrom tel body = do + if fmap bareTxt existingRoom == Just bareFrom && ( + existingRoom /= parseJID (bareFrom <> fromString "/" <> fromMaybe mempty resourceFrom) || + not (fromString "GROUPSMS%" `T.isPrefixOf` mid)) then + writeStanzaChan toVitelity $ (emptyMessage MessageChat) { + messageTo = parseJID (tel <> fromString "@sms"), + messagePayloads = [Element (fromString "{jabber:client}body") [] [NodeContent $ ContentText txt]] + } + else + return () -- TODO: Error? + where + txt = mconcat [fromString "(", fromMaybe (fromString "nonick") resourceFrom, fromString ") ", body] +componentMessage _ toVitelity _ _ existingRoom bareFrom resourceFrom tel body = + writeStanzaChan toVitelity ((emptyMessage MessageChat) { + messageTo = parseJID (tel <> fromString "@sms"), + messagePayloads = [Element (fromString "{jabber:client}body") [] [NodeContent $ ContentText txt]] + }) + where + txt = mconcat [fromString "(", fromNick, fromString " whispers) ", body] + fromNick + | fmap bareTxt existingRoom == Just bareFrom = fromMaybe (fromString "nonick") resourceFrom + | otherwise = bareFrom + +componentStanza db toVitelity (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) + | Just tel <- strNode <$> jidNode to, + Just body <- getBody "jabber:component:accept" m = do + existingRoom <- (parseJID . fromString =<<) <$> TC.runTCM (TC.get db $ T.unpack tel) + componentMessage db toVitelity (messageType m) (fromMaybe mempty $ messageID m) existingRoom (bareTxt from) resourceFrom tel body + where + resourceFrom = strResource <$> jidResource from +componentStanza db toVitelity (ReceivedPresence p@(Presence { presenceFrom = Just from, presenceTo = Just to })) + | Just tel <- strNode <$> jidNode to, + [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< presencePayloads p, + [status] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x, + (_:_) <- code110 status = do + writeStanzaChan toVitelity $ (emptyMessage MessageChat) { + messageTo = parseJID (tel <> fromString "@sms"), + messagePayloads = [Element (fromString "{jabber:client}body") [] [NodeContent $ ContentText $ fromString "You have joined " <> bareMUC <> fromString " as " <> roomNick]] + } + + True <- TC.runTCM (TC.put db (T.unpack tel) (T.unpack $ formatJID from)) + return () + where + bareMUC = bareTxt from + roomNick = fromMaybe mempty (strResource <$> jidResource from) +componentStanza _ _ _ = return () + +component db toVitelity toComponent = do + forkXMPP $ forever $ do + stanza <- liftIO $ atomically $ readTChan toComponent + putStanza $ stanza + + --forever $ getStanza >>= liftIO . componentStanza db toVitelity + forever $ do + s <- getStanza + liftIO $ componentStanza db toVitelity s + +data Command = Join JID | Send Text + deriving (Show, Eq) + +parseCommand txt nick + | Just room <- T.stripPrefix (fromString "/join ") txt = + Join <$> parseJID (room <> fromString "/" <> nick) + | otherwise = Just $ Send txt + +getMessage (ReceivedMessage m) = Just m +getMessage _ = Nothing + +viteltiy db toVitelity toComponent = do + bindJID (fromString "2266669991@s.ms/theone") + putStanza $ emptyPresence PresenceAvailable + + forkXMPP $ forever $ do + stanza <- liftIO $ atomically $ readTChan toVitelity + putStanza $ stanza + + forever $ do + m <- getMessage <$> getStanza + liftIO $ case (strNode <$> (jidNode =<< messageFrom =<< m), getBody "jabber:client" =<< m) of + (Just tel, Just txt) -> case parseCommand txt (fromString "thenick") of + Just (Join room) -> do + existingRoom <- (parseJID . fromString =<<) <$> TC.runTCM (TC.get db $ T.unpack tel) + forM_ existingRoom $ \leaveRoom -> + writeStanzaChan toComponent $ (emptyPresence PresenceUnavailable) { + presenceTo = Just leaveRoom, + presenceFrom = parseJID $ tel <> fromString "@sms.singpolyma.net", + presencePayloads = [Element (fromString "{jabber:component:accept}status") [] [NodeContent $ ContentText $ fromString "Joined a different room."]] + } + + writeStanzaChan toComponent $ (emptyPresence PresenceAvailable) { + presenceTo = Just room, + presenceFrom = parseJID $ tel <> fromString "@sms.singpolyma.net", + presencePayloads = [Element (fromString "{http://jabber.org/protocol/muc}x") [] [ + NodeElement $ Element (fromString "{http://jabber.org/protocol/muc}history") [(fromString "{http://jabber.org/protocol/muc}maxchars", [ContentText $ fromString "0"])] [] + ]] + } + Just (Send msg) -> do + existingRoom <- (parseJID . fromString =<<) <$> TC.runTCM (TC.get db $ T.unpack tel) + case existingRoom of + Just room -> do + uuid <- (fmap.fmap) UUID.toString UUID.nextUUID + writeStanzaChan toComponent $ (emptyMessage MessageGroupChat) { + messageTo = parseJID $ bareTxt room, + messageFrom = parseJID $ tel <> fromString "@sms.singpolyma.net", + messageID = Just $ fromString ("GROUPSMS%" <> fromMaybe "UUIDFAIL" uuid), + messagePayloads = [Element (fromString "{jabber:component:accept}body") [] [NodeContent $ ContentText msg]] + } + Nothing -> print "ERROR" + Nothing -> print "ERROR" + _ -> return () + +openTokyoCabinet :: (TC.TCDB a) => FilePath -> IO a +openTokyoCabinet pth = TC.runTCM $ do + db <- TC.new + True <- TC.open db pth [TC.OREADER, TC.OWRITER, TC.OCREAT] + return db + +main = do + [name, host, port, secret, vitelityJid, vitelityPassword] <- getArgs + db <- openTokyoCabinet "./db.tcdb" :: IO TC.HDB + toVitelity <- atomically newTChan + toComponent <- atomically newTChan + forkIO $ void $ runComponent (Server (fromString name) host (PortNumber $ fromIntegral (read port :: Int))) (fromString secret) (component db toVitelity toComponent) + + let Just vitelityParsedJid = parseJID $ fromString vitelityJid + runClient (Server (fromString "s.ms") "s.ms" (PortNumber 5222)) vitelityParsedJid (fromMaybe mempty $ strNode <$> jidNode vitelityParsedJid) (fromString vitelityPassword) $ viteltiy db toVitelity toComponent -- 2.38.5