diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index 6b28fe1..0000000 --- a/.gitmodules +++ /dev/null @@ -1,6 +0,0 @@ -[submodule "stringprep-hs"] - path = stringprep-hs - url = git@github.com:Philonous/stringprep-hs.git -[submodule "xml-picklers"] - path = xml-picklers - url = git@github.com:Philonous/xml-picklers.git diff --git a/build.sh b/build.sh deleted file mode 100644 index 8029b43..0000000 --- a/build.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -git submodule init -git submodule update -cabal-dev install ./xml-types-pickle -cabal-dev install ./stringprep-hs -cabal-dev install-deps -cabal-dev configure -cabal-dev build diff --git a/documentation/manual.md b/documentation/manual.md deleted file mode 100644 index e69de29..0000000 diff --git a/documentation/tutorial.md b/documentation/tutorial.md deleted file mode 100644 index e69de29..0000000 diff --git a/examples/Example.hs b/examples/Example.hs deleted file mode 100644 index 9f3e8f3..0000000 --- a/examples/Example.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE PackageImports, OverloadedStrings #-} -module Example where - -import Data.Text as T - -import Network.Xmpp -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.IO.Class - -philonous :: JID -philonous = read "uart14@species64739.dyndns.org" - -attXmpp :: STM a -> XmppThread a -attXmpp = liftIO . atomically - -autoAccept :: XmppThread () -autoAccept = forever $ do - st <- pullPresence - case st of - Presence from _ idq (Just Subscribe) _ _ _ _ -> - sendS . SPresence $ - Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] - _ -> return () - -mirror :: XmppThread () -mirror = forever $ do - st <- pullMessage - case st of - Message (Just from) _ idq tp subject (Just bd) thr _ -> - sendS . SMessage $ - Message Nothing from idq tp subject - (Just $ "you wrote: " `T.append` bd) thr [] - _ -> return () - - -main :: IO () -main = do - sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do --- singleThreaded $ xmppStartTLS exampleParams - singleThreaded $ xmppSASL "pwd" - xmppThreadedBind (Just "botsi") --- singleThreaded $ xmppBind (Just "botsi") - singleThreaded $ xmppContext - forkXmpp autoAccept - forkXmpp mirror - sendS . SPresence $ Presence Nothing Nothing Nothing Nothing - (Just Available) Nothing Nothing [] - sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing - (Just "bla") Nothing [] - liftIO . forever $ threadDelay 1000000 - return () - return () - diff --git a/examples/IBR.hs b/examples/IBR.hs deleted file mode 100644 index 68b9f88..0000000 --- a/examples/IBR.hs +++ /dev/null @@ -1,46 +0,0 @@ -{- - -Copyright © 2010-2012 Jon Kristensen. - -This file (IBR.hs) illustrates how to connect and perform an XEP-0077: -In-Band Registration registration using Pontarius. The contents of -this file may be used freely, as if it is in the public domain. - --} - - -module Examples.IBR () where - -import Network.Xmpp - - --- Server and authentication details. - -hostName = "nejla.com" -portNumber = 5222 -userName = "test" -password = "" - - --- Start an XMPP session with the default settings, open the streams --- to the XMPP server, send the `register' IQ, wait for and interpret --- the response, and destroy the session. - -main :: IO () - -main = session default $ do - liftIO $ putStrLn "Welcome to the Pontarius IBR example!" - openStreamsResult <- openStreams "nejla.com" - case openStreamsResult of - Nothing -> do - liftIO $ putStrLn "Streams opened, now registering!" - pushIQReq Nothing Set query Nothing $ \reply -> do - case reply of - Right (IQResponse {}) -> liftIO $ putStrLn "Registered!" -- TODO: iqRequestPayload may be empty! - Right (IQError {}) -> liftIO $ putStrLn "Registration error!" -- TODO: More details from error stanza - Left _ -> liftIO $ putStrLn "Registration error!" -- TODO: More details from error - destroy - Just error -> liftIO $ putStrLn "Error: " ++ $ show exception - where - query :: Element - query = undefined -- TODO: userNamepassword \ No newline at end of file diff --git a/examples/EchoClient.hs b/examples/echoclient/EchoClient.hs similarity index 96% rename from examples/EchoClient.hs rename to examples/echoclient/EchoClient.hs index 6cb384b..6b44404 100644 --- a/examples/EchoClient.hs +++ b/examples/echoclient/EchoClient.hs @@ -31,8 +31,6 @@ import System.Log.Handler.Simple import System.Log.Logger -- Server and authentication details. -host = "localhost" -port = PortNumber 5222 realm = "species64739.dyndns.org" username = "echo" password = "pwd" @@ -57,9 +55,7 @@ main = do updateGlobalLogger "Pontarius.Xmpp" (addHandler handler) sess' <- session - host realm - port Nothing -- (Just defaultParamsClient) (Just ([scramSha1 username Nothing password], resource)) sess <- case sess' of diff --git a/examples/echoclient/echoclient.cabal b/examples/echoclient/echoclient.cabal new file mode 100755 index 0000000..bc5724b --- /dev/null +++ b/examples/echoclient/echoclient.cabal @@ -0,0 +1,12 @@ +Name: echoclient +Version: 0.0.0.0 +Cabal-Version: >= 1.6 +Build-Type: Simple +License: OtherLicense +Copyright: Mahdi Abdinejadi, Jon Kristensen, Philipp Balzarek +Maintainer: info@jonkri.com +Synopsis: Echo client test program for Pontarius XMPP + +Executable echoclient + Build-Depends: base, hslogger, mtl, pontarius-xmpp, text, tls + Main-Is: EchoClient.hs \ No newline at end of file diff --git a/import_visualisation-new-full.png b/import_visualisation-new-full.png deleted file mode 100644 index 75b6ba9..0000000 Binary files a/import_visualisation-new-full.png and /dev/null differ diff --git a/import_visualisation-new.png b/import_visualisation-new.png deleted file mode 100644 index f8c7bdc..0000000 Binary files a/import_visualisation-new.png and /dev/null differ diff --git a/import_visualisation.png b/import_visualisation.png deleted file mode 100644 index 001b160..0000000 Binary files a/import_visualisation.png and /dev/null differ diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 4442d9e..79a2b11 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -36,6 +36,7 @@ Library , crypto-random-api >=0.2 , cryptohash >=0.6.1 , data-default >=0.2 + , dns , hslogger >=1.1.0 , lifted-base >=0.1.0.1 , mtl >=2.0.0.0 diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index d9f2512..451bb97 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -132,10 +132,7 @@ writeWorker stCh writeR = forever $ do -- value, @session@ will attempt to secure the connection with TLS. If the fifth -- parameters is a 'Just' value, @session@ will attempt to authenticate and -- acquire an XMPP resource. -session :: HostName -- ^ Host to connect to - -> Text -- ^ The realm host name (to - -- distinguish the XMPP service) - -> PortID -- ^ Port to connect to +session :: Text -- ^ The realm host name -> Maybe TLS.TLSParams -- ^ TLS settings, if securing the -- connection to the server is -- desired @@ -143,8 +140,8 @@ session :: HostName -- ^ Host to connect to -- JID resource (or Nothing to let -- the server decide) -> IO (Either XmppFailure (Session, Maybe AuthFailure)) -session hostname realm port mbTls mbSasl = runErrorT $ do - con <- ErrorT $ openStream hostname port realm def +session realm mbTls mbSasl = runErrorT $ do + con <- ErrorT $ openStream realm def case mbTls of Nothing -> return () Just tls -> ErrorT $ startTls tls con diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 08b263d..5b9e913 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -78,13 +78,13 @@ xmppSasl handlers = withStream $ do cs <- gets streamState case cs of Closed -> return . Left $ XmppNoStream - _ -> do - r <- runErrorT handler + _ -> runErrorT $ do + r <- ErrorT handler case r of - Left ae -> return $ Right $ Just ae - Right a -> do - _ <- runErrorT $ ErrorT restartStream - return $ Right $ Nothing + Just ae -> return $ Just ae + Nothing -> do + _ <- ErrorT restartStream + return Nothing -- | Authenticate to the server using the first matching method and bind a -- resource. diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index bca3ab5..dfb9710 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -127,6 +127,12 @@ digestMd5 :: Text -- ^ Authentication identity (authcid or username) -> Maybe Text -- ^ Authorization identity (authzid) -> Text -- ^ Password -> SaslHandler -digestMd5 authcid authzid password = ( "DIGEST-MD5" - , xmppDigestMd5 authcid authzid password - ) +digestMd5 authcid authzid password = + ( "DIGEST-MD5" + , do + r <- runErrorT $ xmppDigestMd5 authcid authzid password + case r of + Left (AuthStreamFailure e) -> return $ Left e + Left e -> return $ Right $ Just e + Right () -> return $ Right Nothing + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index 3e85a50..e2833ce 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -77,4 +77,12 @@ plain :: Text.Text -- ^ authentication ID (username) -> Maybe Text.Text -- ^ authorization ID -> Text.Text -- ^ password -> SaslHandler -plain authcid authzid passwd = ("PLAIN", xmppPlain authcid authzid passwd) +plain authcid authzid passwd = + ( "PLAIN" + , do + r <- runErrorT $ xmppPlain authcid authzid passwd + case r of + Left (AuthStreamFailure e) -> return $ Left e + Left e -> return $ Right $ Just e + Right () -> return $ Right Nothing + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index c9905e8..177ce3b 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -164,6 +164,11 @@ scramSha1 :: Text.Text -- ^ username -> Text.Text -- ^ password -> SaslHandler scramSha1 authcid authzid passwd = - ("SCRAM-SHA-1" - , scram (hashToken :: Crypto.SHA1) authcid authzid passwd + ( "SCRAM-SHA-1" + , do + r <- runErrorT $ scram (hashToken :: Crypto.SHA1) authcid authzid passwd + case r of + Left (AuthStreamFailure e) -> return $ Left e + Left e -> return $ Right $ Just e + Right () -> return $ Right Nothing ) diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index e418cd2..e3273da 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -34,4 +34,4 @@ type Pairs = [(ByteString, ByteString)] -- | Tuple defining the SASL Handler's name, and a SASL mechanism computation. -- The SASL mechanism is a stateful @Stream@ computation, which has the -- possibility of resulting in an authentication error. -type SaslHandler = (Text.Text, ErrorT AuthFailure (StateT Stream IO) ()) +type SaslHandler = (Text.Text, StateT Stream IO (Either XmppFailure (Maybe AuthFailure))) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 7ce9ba7..22a464b 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -44,6 +44,9 @@ import Text.XML.Unresolved(InvalidEventStream(..)) import Control.Monad.Trans.Resource as R import Network.Xmpp.Utilities +import Network.DNS hiding (encode, lookup) + + -- import Text.XML.Stream.Elements mbl :: Maybe [a] -> [a] @@ -249,17 +252,43 @@ streamS expectedTo = do Just r -> streamUnpickleElem xpStreamFeatures r -- | Connects to the XMPP server and opens the XMPP stream against the given --- host name, port, and realm. -openStream :: HostName -> PortID -> Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) -openStream address port hostname config = do - stream <- connectTcp address port hostname config - case stream of - Right stream' -> do - result <- withStream startStream stream' - liftIO $ print result - return $ Right stream' - Left e -> do - return $ Left e +-- realm. +openStream :: Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) +openStream realm config = runErrorT $ do + (address, port) <- case hardcodedTcpDetails config of + Nothing -> dnsLookup realm (resolvConf config) + Just (address, port) -> return (address, port) + stream' <- connectTcp (Text.unpack address) port realm config + result <- liftIO $ withStream startStream stream' + return stream' + +dnsLookup :: Text -> ResolvConf -> ErrorT XmppFailure IO (Text, PortID) +dnsLookup realm resolvConf = ErrorT $ do + resolvSeed <- makeResolvSeed resolvConf + withResolver resolvSeed $ \resolver -> do + debugM "Pontarius.Xmpp" "Performing SRV lookup..." + srvResult <- lookupSRV resolver (BSC8.pack $ Text.unpack realm) + debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) + + -- TODO: Use SRV result. Is list always empty? + + -- TODO: Attempt to connect over IPv6 if it is resolvable. + -- TODO: Setting field to disable IPv6 lookup. + + -- aaaaResult <- lookupAAAA resolver (BSC8.pack $ Text.unpack realm) + -- debugM "Pontarius.Xmpp" $ "AAAA result: " ++ (show aaaaResult) + -- if isJust aaaaResult && (Prelude.length $ fromJust aaaaResult) > 0 + -- then return $ Right (Text.pack $ show $ Prelude.head $ fromJust aaaaResult, (PortNumber 5222)) + -- else + + do + aResult <- lookupA resolver (BSC8.pack $ Text.unpack realm) + debugM "Pontarius.Xmpp" $ "A result: " ++ (show aResult) + case aResult of + Nothing -> return $ Left DnsLookupFailed + Just r | Prelude.length r == 0 -> return $ Left DnsLookupFailed + -- Is it safe to ignore tail of A records? + | otherwise -> return $ Right (Text.pack $ show $ Prelude.head r, (PortNumber 5222)) -- | Send "" and wait for the server to finish processing and to -- close the connection. Any remaining elements from the server are returned. @@ -400,14 +429,14 @@ xmppNoStream = Stream { , streamId = Nothing , streamLang = Nothing , streamJid = Nothing - , streamConfiguration = StreamConfiguration Nothing Nothing + , streamConfiguration = def } where zeroSource :: Source IO output zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure "zeroSource" -connectTcp :: HostName -> PortID -> Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) -connectTcp host port hostname config = do +connectTcp :: HostName -> PortID -> Text -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) +connectTcp host port hostname config = ErrorT $ do let PortNumber portNumber = port debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ (show portNumber) ++ " through the realm " ++ (Text.unpack hostname) ++ "." @@ -418,17 +447,15 @@ connectTcp host port hostname config = do ((sourceHandle h $= logConduit) $= XP.parseBytes def) (return ()) let hand = StreamHandle { streamSend = \d -> do - let d64 = encode d debugM "Pontarius.Xmpp" $ - "Sending TCP data: " ++ (BSC8.unpack d64) + "Sending TCP data: " ++ (BSC8.unpack d) ++ "." catchPush $ BS.hPut h d , streamReceive = \n -> do d <- BS.hGetSome h n - let d64 = encode d debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ - (BSC8.unpack d64) ++ "." + (BSC8.unpack d) ++ "." return d , streamFlush = hFlush h , streamClose = hClose h diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 29a9e56..131c6b7 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -78,6 +78,9 @@ import Data.String (IsString(..)) import qualified Text.NamePrep as SP import qualified Text.StringPrep as SP +import Network +import Network.DNS + import Data.Default -- | @@ -653,6 +656,8 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream -- constructor wraps the -- elements collected so -- far. + | DnsLookupFailed -- ^ An IP address to connect to could not be + -- resolved. | TlsError TLS.TLSError -- ^ An error occurred in the -- TLS layer | TlsNoServerSupport -- ^ The server does not support @@ -1016,10 +1021,18 @@ data StreamConfiguration = -- boolean is set to 'True', then the JID is also -- included when the 'ConnectionState' is 'Plain' , toJid :: !(Maybe (Jid, Bool)) + -- | By specifying these details, Pontarius XMPP will + -- connect to the provided address and port, and will + -- not perform a DNS look-up + , hardcodedTcpDetails :: Maybe (Text, PortID) + -- | DNS resolver configuration + , resolvConf :: ResolvConf } instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing + , hardcodedTcpDetails = Nothing + , resolvConf = defaultResolvConf } diff --git a/stringprep-hs b/stringprep-hs deleted file mode 160000 index 7a6ca46..0000000 --- a/stringprep-hs +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 7a6ca463b5e6d6636abf266bc9a782ede4e76b06 diff --git a/xml-picklers b/xml-picklers deleted file mode 160000 index 1117559..0000000 --- a/xml-picklers +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 1117559380711ed30d1b83a9fcfc636e20be2fd5