From 188cc252d3e437c1ae0487afb0f693ce12059a28 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sun, 13 May 2012 20:22:59 +0200 Subject: [PATCH] Eq instance for JID, PLAIN now base64-encoded, EchoClient compiles, isBare/Full functions exposed --- examples/EchoClient.hs | 80 +++++++++++++++---------------- pontarius.cabal | 3 ++ source/Network/XMPP.hs | 2 + source/Network/XMPP/JID.hs | 2 +- source/Network/XMPP/SASL.hs | 1 + source/Network/XMPP/SASL/PLAIN.hs | 2 +- 6 files changed, 48 insertions(+), 42 deletions(-) diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs index 8d2d8c0..8a7d607 100644 --- a/examples/EchoClient.hs +++ b/examples/EchoClient.hs @@ -2,62 +2,62 @@ Copyright © 2010-2012 Jon Kristensen. -This file (EchoClient.hs) illustrates how to connect, authenticate, -set a simple presence, receive message stanzas, and echo them back to -whoever is sending them, using Pontarius. The contents of this file -may be used freely, as if it is in the public domain. +This file (EchoClient.hs) illustrates how to connect, authenticate, set a simple +presence, receive message stanzas, and echo them back to whoever is sending +them, using Pontarius. The contents of this file may be used freely, as if it is +in the public domain. -} -module Examples.EchoClient () where +{-# LANGUAGE OverloadedStrings #-} + + +module Main (main) where + +import Control.Monad (forever) +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromJust, isJust) import Network.XMPP +import Network.XMPP.IM -- Server and authentication details. hostName = "nejla.com" portNumber = 5222 -userName = "test" -password = "" - +userName = "jon" +password = "G2D9%b4S3" -- TODO --- Start an XMPP session with the default settings, open the streams --- to the XMPP server, authenticate, send a simple presence, and start --- the `echo' XMPP thread. +-- TODO: Incomplete code, needs documentation, etc. main :: IO () - -main = session default $ do - liftIO $ putStrLn "Welcome to the Pontarius EchoClient example!" - openStreamsResult <- openStreams "nejla.com" - case openStreamsResult of - Nothing -> do - liftIO $ putStrLn "Streams opened, now authenticating!" - authenticateResult <- authenticate userName password Nothing - case authenticateResult of - Right _ -> do -- Ignore XMPP address - liftIO $ putStrLn "Authenticating, now sending presence!" - sendPresence Nothing Nothing [] Nothing -- Simple presence - liftIO $ putStrLn "Echoing..." - fork echo - Left error -> liftIO $ putStrLn "Error: " ++ $ show exception - Just error -> liftIO $ putStrLn "Error: " ++ $ show exception - +main = do + withNewSession $ do + withConnection $ do + connect "xmpp.nejla.com" "nejla.com" + -- startTLS exampleParams + saslResponse <- auth userName password (Just "echo-client") + case saslResponse of + Right _ -> return () + Left e -> error $ show e + sendPresence presenceOnline + fork echo + return () + return () -- Pull message stanzas, verify that they originate from a `full' XMPP -- address, and, if so, `echo' the message back. - -echo :: XMPPThread () -- TODO: XMPP ()? XMPP? - +echo :: XMPP () echo = forever $ do - result <- pullMessage - case result of - Right message -> - if messageFrom message /= Nothing && isFull $ messageFrom message - then do - sendMessage (messageFrom message) (messageType message) Nothing [] - liftIO $ putStrLn "Message echoed!" - else liftIO $ putStrLn "Message sender is not set or is bare!" - Left exception -> liftIO $ putStrLn "Error: " ++ $ show exception \ No newline at end of file + result <- pullMessage + case result of + Right message -> + if (isJust $ messageFrom message) && + (isFull $ fromJust $ messageFrom message) then do + -- TODO: May not set from. + sendMessage $ Message Nothing (messageTo message) (messageFrom message) Nothing (messageType message) (messagePayload message) + liftIO $ putStrLn "Message echoed!" + else liftIO $ putStrLn "Message sender is not set or is bare!" + Left exception -> liftIO $ putStrLn "Error: " \ No newline at end of file diff --git a/pontarius.cabal b/pontarius.cabal index 06183c6..cee1054 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -75,6 +75,9 @@ Library , Data.Conduit.TLS GHC-Options: -Wall +Executable pontarius-echoclient + hs-source-dirs: source + Main-Is: ../examples/EchoClient.hs Source-Repository head Type: git diff --git a/source/Network/XMPP.hs b/source/Network/XMPP.hs index 91c9eb6..82c75a1 100644 --- a/source/Network/XMPP.hs +++ b/source/Network/XMPP.hs @@ -38,6 +38,8 @@ module Network.XMPP -- for addressing entities in the network. It is somewhat similar to an e-mail -- address but contains three parts instead of two: , JID(..) + , isBare + , isFull -- * Stanzas -- | @Stanzas@ are the the smallest unit of communication in @XMPP@. They come -- in 3 flavors: diff --git a/source/Network/XMPP/JID.hs b/source/Network/XMPP/JID.hs index 42e2566..67348de 100644 --- a/source/Network/XMPP/JID.hs +++ b/source/Network/XMPP/JID.hs @@ -54,7 +54,7 @@ data JID = JID { -- | The @localpart@ of a JID is an optional identifier placed -- the entity associated with an XMPP localpart at a domain -- (i.e., @localpart\@domainpart/resourcepart@). , resourcepart :: !(Maybe Text) - } + } deriving Eq instance Show JID where show (JID nd dmn res) = diff --git a/source/Network/XMPP/SASL.hs b/source/Network/XMPP/SASL.hs index 3ce2d1f..d876758 100644 --- a/source/Network/XMPP/SASL.hs +++ b/source/Network/XMPP/SASL.hs @@ -63,4 +63,5 @@ xmppSASL creds = runErrorT $ do -- the XMPP mechanism attribute. credsToName :: SASLCredentials -> Text credsToName (DIGEST_MD5Credentials _ _ _) = "DIGEST-MD5" + credsToName (PLAINCredentials _ _ _) = "PLAIN" credsToName c = error $ "credsToName failed for " ++ (show c) \ No newline at end of file diff --git a/source/Network/XMPP/SASL/PLAIN.hs b/source/Network/XMPP/SASL/PLAIN.hs index 6c1ca3e..ae44a7d 100644 --- a/source/Network/XMPP/SASL/PLAIN.hs +++ b/source/Network/XMPP/SASL/PLAIN.hs @@ -51,7 +51,7 @@ xmppPLAIN :: Maybe T.Text -> XMPPConMonad (Either AuthError ()) xmppPLAIN authzid authcid passwd = runErrorT $ do _ <- lift . pushElement $ saslInitE "PLAIN" $ -- TODO: Check boolean? - Just $ plainMessage authzid authcid passwd + Just $ Text.decodeUtf8 $ B64.encode $ Text.encodeUtf8 $ plainMessage authzid authcid passwd lift $ pushElement saslResponse2E e <- lift pullElement case e of