From 40c40f32587e09c1c5c1abe41a8c7e9345fa36ff Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 21 Mar 2012 19:39:40 +0100 Subject: [PATCH] Session, some bug fixes --- src/Data/Conduit/Hexpat.hs | 3 +- src/Data/Conduit/TLS.hs | 9 +++--- src/Network/XMPP/Bind.hs | 2 -- src/Network/XMPP/Marshal.hs | 12 ++++---- src/Network/XMPP/Monad.hs | 18 +++++++----- src/Network/XMPP/Pickle.hs | 5 ++-- src/Network/XMPP/SASL.hs | 7 ++--- src/Network/XMPP/Stream.hs | 2 +- src/Network/XMPP/TLS.hs | 5 ++-- src/Network/XMPP/Types.hs | 22 +++++++------- src/Network/XMPPConduit.hs | 43 --------------------------- xmpp-lib.cabal | 58 +++++++++++++++++++++++++++++++++++++ 12 files changed, 100 insertions(+), 86 deletions(-) delete mode 100644 src/Network/XMPPConduit.hs diff --git a/src/Data/Conduit/Hexpat.hs b/src/Data/Conduit/Hexpat.hs index 191bee1..e62de16 100644 --- a/src/Data/Conduit/Hexpat.hs +++ b/src/Data/Conduit/Hexpat.hs @@ -5,7 +5,8 @@ module Data.Conduit.Hexpat where import Control.Applicative((<$>)) import Control.Exception import Control.Monad -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import qualified Data.ByteString as BS import Data.Conduit as C diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index e0a2565..261464b 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -6,7 +6,8 @@ module Data.Conduit.TLS where import Control.Applicative -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Crypto.Random @@ -32,9 +33,9 @@ tlsinit tlsParams handle = do handshake clientContext let src = sourceIO (return clientContext) - (\_ -> putStrLn "tls closed") + (bye) (\con -> IOOpen <$> recvData con) - return (src $= conduitStdout + return (src , \s -> sendData clientContext $ BL.fromChunks [s] ) -- TODO: remove @@ -45,6 +46,6 @@ conduitStdout = conduitIO (return ()) (\_ -> return ()) (\_ bs -> do - liftIO $ BS.hPut stdout bs + liftIO $ BS.putStrLn bs return $ IOProducing [bs]) (const $ return []) \ No newline at end of file diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index aba68c5..b56d055 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -2,7 +2,6 @@ module Network.XMPP.Bind where -import Control.Monad.Trans import Control.Monad.Trans.State import Data.Text as Text @@ -28,7 +27,6 @@ xmppBind = do res <- gets sResource push $ bindReqIQ res answer <- pull - liftIO $ print answer let SIQ (IQ Nothing Nothing _ Result b) = answer let (JID n d (Just r)) = unpickleElem jidP b modify (\s -> s{sResource = Just r}) diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 5eedc1b..48695d2 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -4,8 +4,6 @@ module Network.XMPP.Marshal where import Control.Applicative((<$>)) -import Control.Monad.State - import Data.Maybe import qualified Data.Text as Text @@ -25,10 +23,10 @@ stanzaP = xpAlt stanzaSel , xpWrap (SIQ , (\(SIQ i) -> i)) iqP ] -messageP = xpWrap ( (\((from, to, id, tp),(body, sub, thr,ext)) - -> Message from to id tp body sub thr ext) - , (\(Message from to id tp body sub thr ext) - -> ((from, to, id, tp), (body, sub, thr,ext))) +messageP = xpWrap ( (\((from, to, id, tp),(sub, body, thr,ext)) + -> Message from to id tp sub body thr ext) + , (\(Message from to id tp sub body thr ext) + -> ((from, to, id, tp), (sub, body, thr,ext))) ) $ xpElem "message" (xp4Tuple @@ -38,8 +36,8 @@ messageP = xpWrap ( (\((from, to, id, tp),(body, sub, thr,ext)) (xpAttrImplied "type" xpPrim) ) (xp4Tuple - (xpOption . xpElemNodes "body" $ xpContent xpText) (xpOption . xpElemNodes "subject" $ xpContent xpText) + (xpOption . xpElemNodes "body" $ xpContent xpText) (xpOption . xpElemNodes "thread" $ xpContent xpText) xpTrees ) diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index b9c6302..262bad9 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -5,10 +5,12 @@ module Network.XMPP.Monad where import Control.Applicative((<$>)) import Control.Monad -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.State import Data.ByteString as BS +import Data.Text(Text) import Data.Conduit import Data.Conduit.Binary as CB @@ -16,7 +18,6 @@ import Data.Conduit.Hexpat as HXC import Data.Conduit.List as CL import Data.Conduit.Text as CT -import Data.Default import qualified Data.Text as Text import Network.XMPP.Types @@ -33,17 +34,17 @@ parseOpts = ParseOptions (Just UTF8) Nothing pushN :: Element -> XMPPMonad () pushN x = do - sink <- gets sConSink - lift . sink $ formatNode' x + sink <- gets sConPush + liftIO . sink $ formatNode' x push :: Stanza -> XMPPMonad () push = pushN . pickleElem stanzaP pushOpen :: Element -> XMPPMonad () pushOpen (Element name attrs children) = do - sink <- gets sConSink + sink <- gets sConPush let sax = StartElement name attrs - lift . sink $ formatSAX' [sax] + liftIO . sink $ formatSAX' [sax] forM children pushN return () @@ -55,7 +56,6 @@ pulls snk = do pullE :: XMPPMonad Element pullE = do - source <- gets sConSrc pulls elementFromEvents pullPickle p = unpickleElem p <$> pullE @@ -66,6 +66,10 @@ pull = pullPickle stanzaP -- pull :: XMPPMonad Stanza -- pull = elementToStanza <$> pullE +xmppFromHandle + :: Handle -> Text -> Text -> Maybe Text + -> XMPPMonad a + -> IO (a, XMPPState) xmppFromHandle handle hostname username resource f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering raw <- bufferSource $ CB.sourceHandle handle diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 2b4ff42..3b39058 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -1,8 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} -- Marshalling between XML and Native Types @@ -56,6 +53,8 @@ xpEither l r = xpAlt eitherSel eitherSel (Left _) = 0 eitherSel (Right _) = 1 + + xpElemNs name ns attrs nodes = xpWrap (\(((),a),n) -> (a,n), \(a,n) -> (((),a),n)) $ xpElem name diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 885223f..a8aaf67 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -3,7 +3,8 @@ module Network.XMPP.SASL where import Control.Applicative import Control.Monad -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.State import qualified Crypto.Classes as CC @@ -31,8 +32,6 @@ import Numeric -- import qualified System.Random as Random -import Text.XML.Stream.Elements - import Text.XML.Expat.Pickle import Text.XML.Expat.Tree @@ -56,9 +55,7 @@ saslResponse2E = xmppSASL passwd = do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" - liftIO $ putStrLn "saslinit" pushN $ saslInitE "DIGEST-MD5" - liftIO $ putStrLn "saslinit sent" Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle let Right pairs = toPairs challenge pushN . saslResponseE =<< createResponse passwd pairs diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index d91d4f3..f21beab 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -5,7 +5,7 @@ module Network.XMPP.Stream where import Control.Applicative((<$>)) import Control.Monad(unless) -import Control.Monad.Trans +import Control.Monad.Trans.Class import Control.Monad.Trans.State import Control.Monad.IO.Class diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index ddd69b7..a9d2a57 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -3,7 +3,8 @@ module Network.XMPP.TLS where import Control.Monad -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.State import Network.XMPP.Monad @@ -36,7 +37,7 @@ xmppStartTLS params = do { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state - , sConSink = liftIO . snk + , sConPush = liftIO . snk }) xmppRestartStream modify (\s -> s{sHaveTLS = True}) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index c10f3cc..846e757 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Network.XMPP.Types where -- proudly "borrowed" from haskell-xmpp @@ -9,7 +7,6 @@ import Control.Monad.Trans.State import qualified Data.ByteString as BS import Data.Conduit -import Data.Default import Data.List.Split as L import Data.Maybe import Data.Text as Text @@ -32,14 +29,17 @@ data JID = JID { node :: Maybe Text -- ^ Resource name } instance Show JID where - show = Text.unpack . toText + show (JID nd domain res) = + maybe "" ((++ "@") . Text.unpack) nd ++ + (Text.unpack domain) ++ + maybe "" (('/' :) . Text.unpack) res type XMPPMonad a = StateT XMPPState (ResourceT IO) a data XMPPState = XMPPState { sConSrc :: BufferedSource IO Event , sRawSrc :: BufferedSource IO BS.ByteString - , sConSink :: BS.ByteString -> ResourceT IO () + , sConPush :: BS.ByteString -> IO () , sConHandle :: Maybe Handle , sFeatures :: ServerFeatures , sHaveTLS :: Bool @@ -54,12 +54,12 @@ data ServerFeatures = SF , other :: [Element] } deriving Show -instance Default ServerFeatures where - def = SF - { stls = Nothing - , saslMechanisms = [] - , other = [] - } + +def = SF + { stls = Nothing + , saslMechanisms = [] + , other = [] + } -- Ugh, that smells a bit. diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs deleted file mode 100644 index 1b1be17..0000000 --- a/src/Network/XMPPConduit.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} -module Network.XMPPConduit where - -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Trans.State - -import qualified Data.ByteString as BS -import Data.Text as Text - -import Network -import Network.XMPP.Monad -import Network.XMPP.TLS -import Network.XMPP.Stream -import Network.XMPP.SASL -import Network.XMPP.Types -import Network.XMPP.Bind - - -import System.IO - -fromHandle :: Handle -> Text -> Text -> Text -> Maybe Text -> IO ((), XMPPState) -fromHandle handle hostname username password resource = - xmppFromHandle handle hostname username resource $ do - xmppStartStream - -- this will check whether the server supports tls - -- on it's own - xmppStartTLS exampleParams - xmppSASL password - xmppBind - gets sResource >>= liftIO . print - gets sHaveTLS >>= liftIO . print - forever $ pullE >>= liftIO . print - return () - -main = do - con <- connectTo "localhost" (PortNumber 5222) - hSetBuffering con NoBuffering - (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" (Just "botr") - print $ sHaveTLS st - putStrLn "" - hGetContents con >>= putStrLn - diff --git a/xmpp-lib.cabal b/xmpp-lib.cabal index e69de29..ae42c30 100644 --- a/xmpp-lib.cabal +++ b/xmpp-lib.cabal @@ -0,0 +1,58 @@ +Name: xmpp-lib +Version: 0.0.0.1 +License: MIT +License-File: LICENSE +Author: Philipp Balzarek +Maintainer: Philipp Balzarek +Category: Network +Copyright: (c) 2012 Philipp Balzarek +Stability: Experimental +Cabal-version: >=1.6 +Tested-with: GHC==7.4.1 +Build-type: Simple +Bug-reports: mailto: p.balzarek@googlemail.com +Extra-source-files: README + +Synopsis: Haskell XMPP (eXtensible Message Passing Protocol, a.k.a. Jabber) library +Description: Haskell XMPP (eXtensible Message Passing Protocol, a.k.a. Jabber) library + . + This library is not yet stable + +source-repository head + type: git + location: https://github.com/Philonous/xmpp-lib + +library + hs-source-dirs: src + Build-Depends: base >3 && <5 + , conduit -any + , random -any + , hexpat -any + , hexpat-pickle -any + , tls -any + , tls-extra -any + , pureMD5 -any + , base64-bytestring -any + , binary -any + , attoparsec -any + , crypto-api -any + , text -any + , bytestring -any + , transformers -any + , network -any + , split -any + , stm -any + Exposed-modules: Network.XMPP + , Network.XMPP.Types + , Network.XMPP.SASL + , Network.XMPP.Stream + , Network.XMPP.Pickle + , Network.XMPP.Marshal + , Network.XMPP.Monad + , Network.XMPP.Concurrent + , Network.XMPP.TLS + , Network.XMPP.Bind + , Network.XMPP.Session + , Data.Conduit.Hexpat + , Data.Conduit.TLS + GHC-Options: -Wall