Session, some bug fixes

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

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 [])

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})

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
              )

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

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

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

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
 

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})

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.

src/Network/XMPPConduit.hs

@@ -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
-

xmpp-lib.cabal

@@ -0,0 +1,58 @@
+Name: xmpp-lib
+Version: 0.0.0.1
+License: MIT
+License-File: LICENSE
+Author: Philipp Balzarek <p.balzarek@googlemail.com>
+Maintainer: Philipp Balzarek <p.balzarek@googlemail.com>
+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