removed sConPush, session now starts without connection, added inline connection method

xml-types-pickle updated

src/Network/XMPP.hs

@@ -40,8 +40,8 @@ module Network.XMPP
   , module Network.XMPP.Types
   , module Network.XMPP.Presence
   , module Network.XMPP.Message
---  , connectXMPP
-  , sessionConnect
+  , xmppConnect
+  , xmppNewSession
   ) where
 
 import Data.Text as Text
@@ -58,35 +58,8 @@ import Network.XMPP.Stream
 import Network.XMPP.TLS
 import Network.XMPP.Types
 
-import System.IO
-
---fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState)
--- fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a
---             -> IO ((), XMPPState)
--- fromHandle handle hostname username rsrc password a =
---   xmppFromHandle handle hostname username rsrc $ do
---       xmppStartStream
---       -- this will check whether the server supports tls
---       -- on it's own
---       xmppStartTLS exampleParams
---       xmppSASL password
---       xmppBind rsrc
---       xmppSession
---       _ <- runThreaded a
---       return ()
-
--- connectXMPP  :: HostName -> Text -> Text -> Maybe Text
---                 -> Text -> XMPPThread a -> IO ((), XMPPState)
--- connectXMPP host hostname username rsrc passwd a = do
---   con <- connectTo host (PortNumber 5222)
---   hSetBuffering con NoBuffering
---   fromHandle con hostname username rsrc passwd a
-
-sessionConnect  :: HostName -> Text -> Text
-                   -> Maybe Text -> XMPPThread a -> IO (a, XMPPConState)
-sessionConnect host hostname username rsrc a = do
-  con <- connectTo host (PortNumber 5222)
-  hSetBuffering con NoBuffering
-  xmppFromHandle con hostname username rsrc $
-    xmppStartStream >> runThreaded a
+xmppConnect :: HostName -> Text -> XMPPConMonad ()
+xmppConnect  address hostname = xmppRawConnect address hostname >> xmppStartStream
 
+xmppNewSession :: XMPPThread a -> IO (a, XMPPConState)
+xmppNewSession = withNewSession . runThreaded

src/Network/XMPP/Concurrent/Monad.hs

@@ -162,7 +162,6 @@ withConnection a = do
     putTMVar stateRef s'
   return res
 
-
 sendPresence :: Presence -> XMPPThread ()
 sendPresence = sendS . PresenceS
 

src/Network/XMPP/Concurrent/Threads.hs

@@ -109,9 +109,7 @@ writeWorker stCh writeR = forever $ do
   (write, next) <- atomically $ (,) <$>
                      takeTMVar writeR <*>
                      readTChan stCh
-  outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next)
-             $= XR.renderBytes def $$ CL.consume
-  _ <- forM outBS write
+  _ <- write $ renderElement (pickleElem stanzaP next)
   atomically $ putTMVar writeR write
 
 -- Two streams: input and output. Threads read from input stream and write to output stream.

src/Network/XMPP/Monad.hs

@@ -3,9 +3,11 @@
 module Network.XMPP.Monad where
 
 import Control.Applicative((<$>))
+import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 --import Control.Monad.Trans.Resource
+import Control.Concurrent
 import Control.Monad.Trans.State
 
 import Data.ByteString as BS
@@ -30,16 +32,16 @@ import Text.XML.Stream.Render as XR
 
 pushN :: Element -> XMPPConMonad ()
 pushN x = do
-  sink <- gets sConPush
-  lift . sink $ elementToEvents x
+  sink <- gets sConPushBS
+  liftIO . sink $ renderElement x
 
 push :: Stanza -> XMPPConMonad ()
 push = pushN . pickleElem stanzaP
 
 pushOpen :: Element -> XMPPConMonad ()
 pushOpen e = do
-  sink <- gets sConPush
-  lift . sink $ openElementToEvents e
+  sink <- gets sConPushBS
+  liftIO . sink $ renderOpenElement e
   return ()
 
 pulls :: Sink Event IO b -> XMPPConMonad b
@@ -71,14 +73,12 @@ xmppFromHandle handle hostname username res f = do
   let st = XMPPConState
              src
              (raw)
-             (\xs -> CL.sourceList xs
-                     $$ XR.renderBytes def =$ sinkHandle' handle)
              (BS.hPut handle)
              (Just handle)
              (SF Nothing [] [])
              False
-             hostname
-             username
+             (Just hostname)
+             (Just username)
              res
   runStateT f st
 
@@ -108,8 +108,24 @@ sinkHandle' h =
         (return ())
     close = return ()
 
-xmppConnect :: HostName -> Text -> XMPPConMonad ()
-xmppConnect host hostname = do
+zeroSource :: Source IO output
+zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000)
+
+xmppZeroConState :: XMPPConState
+xmppZeroConState = XMPPConState
+               { sConSrc    = zeroSource
+               , sRawSrc    = zeroSource
+               , sConPushBS = (\_ -> return ())
+               , sConHandle = Nothing
+               , sFeatures  = SF Nothing [] []
+               , sHaveTLS   = False
+               , sHostname  = Nothing
+               , sUsername  = Nothing
+               , sResource  = Nothing
+               }
+
+xmppRawConnect :: HostName -> Text -> XMPPConMonad ()
+xmppRawConnect host hostname = do
   uname <- gets sUsername
   con <- liftIO $ do
       con <- connectTo host (PortNumber 5222)
@@ -120,15 +136,15 @@ xmppConnect host hostname = do
   let st = XMPPConState
              src
              (raw)
-             (\xs -> CL.sourceList xs
-                     $$ XR.renderBytes def =$ sinkHandle' con)
              (BS.hPut con)
              (Just con)
              (SF Nothing [] [])
              False
-             hostname
+             (Just hostname)
              uname
              Nothing
   put st
-  return ()
 
+withNewSession :: XMPPConMonad a -> IO (a, XMPPConState)
+withNewSession action = do
+  runStateT action xmppZeroConState

src/Network/XMPP/Pickle.hs

@@ -10,6 +10,7 @@ module Network.XMPP.Pickle where
 import Data.XML.Types
 import Data.XML.Pickle
 
+import Text.XML.Stream.Elements
 
 mbToBool :: Maybe t -> Bool
 mbToBool (Just _) = True
@@ -51,14 +52,11 @@ right :: Either [Char] t -> t
 right (Left l) = error l
 right (Right r) = r
 
-
 unpickleElem :: PU [Node] c -> Element -> c
 unpickleElem p x = case unpickle (xpNodeElem p) x of
-  Left l -> error $ l ++ "\n  saw: " ++ show x
+  Left l -> error $ l ++ "\n  saw: " ++ ppElement x
   Right r -> r
 
 pickleElem :: PU [Node] a -> a -> Element
 pickleElem p = pickle  $ xpNodeElem p
 
-
-

src/Network/XMPP/SASL.hs

@@ -48,14 +48,27 @@ saslResponse2E =
     []
     []
 
-xmppSASL  :: Text -> XMPPConMonad ()
-xmppSASL passwd = do
+xmppSASL:: Text -> Text -> XMPPConMonad (Either String Text)
+xmppSASL uname passwd = do
+    realm <- gets sHostname
+    case realm of
+      Just realm' -> do
+          xmppStartSASL realm' uname passwd
+          modify (\s -> s{sUsername = Just uname})
+          return $ Right uname
+      Nothing -> return $ Left "No connection found"
+
+xmppStartSASL  :: Text
+               -> Text
+               -> Text
+               -> XMPPConMonad ()
+xmppStartSASL realm username passwd = do
   mechanisms <- gets $ saslMechanisms . sFeatures
   unless ("DIGEST-MD5" `elem` mechanisms) .  error $ "No usable auth mechanism: " ++ show mechanisms
   pushN $ saslInitE "DIGEST-MD5"
   Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle
   let Right pairs = toPairs challenge
-  pushN . saslResponseE =<< createResponse passwd pairs
+  pushN . saslResponseE =<< createResponse realm username passwd pairs
   challenge2 <- pullPickle (xpEither failurePickle challengePickle)
   case challenge2 of
     Left x -> error $ show x
@@ -65,13 +78,17 @@ xmppSASL passwd = do
   xmppRestartStream
   return ()
 
-createResponse :: Text -> [(BS8.ByteString, BS8.ByteString)] -> XMPPConMonad Text
-createResponse passwd' pairs = do
+createResponse :: Text
+               -> Text
+               -> Text
+               -> [(BS8.ByteString, BS8.ByteString)]
+               -> XMPPConMonad Text
+createResponse hostname username passwd' pairs = do
   let Just qop = L.lookup "qop" pairs
   let Just nonce = L.lookup "nonce" pairs
-  uname <- Text.encodeUtf8 <$> gets sUsername
+  let uname = Text.encodeUtf8 username
   let passwd = Text.encodeUtf8 passwd'
-  realm <- Text.encodeUtf8 <$> gets sHostname
+  let realm = Text.encodeUtf8 hostname
   g <- liftIO $ Random.newStdGen
   let cnonce = BS.tail . BS.init .
                B64.encode . BS.pack . take 8 $ Random.randoms g

src/Network/XMPP/Stream.hs

@@ -40,7 +40,7 @@ openElementFromEvents = do
 xmppStartStream :: XMPPConMonad ()
 xmppStartStream = do
   hostname <- gets sHostname
-  pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname)
+  pushOpen $ pickleElem pickleStream ("1.0",Nothing, hostname)
   features <- pulls xmppStream
   modify (\s -> s {sFeatures = features})
   return ()

src/Network/XMPP/TLS.hs

@@ -26,7 +26,8 @@ starttlsE =
   Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
 
 exampleParams :: TLS.TLSParams
-exampleParams = TLS.TLSParams { pConnectVersion    = TLS.TLS10
+exampleParams = TLS.defaultParams
+                      {pConnectVersion    = TLS.TLS10
                       , pAllowedVersions   = [TLS.SSL3, TLS.TLS10, TLS.TLS11]
                       , pCiphers           = [TLS.cipher_AES128_SHA1]
                       , pCompressions      = [TLS.nullCompression]
@@ -35,7 +36,8 @@ exampleParams = TLS.TLSParams { pConnectVersion    = TLS.TLS10
                       , pCertificates      = [] -- TODO
                       , pLogging           = TLS.defaultLogging -- TODO
                       , onCertificatesRecv = \ certificate ->
-                                             return TLS.CertificateUsageAccept }
+                                             return TLS.CertificateUsageAccept
+                      }
 
 xmppStartTLS :: TLS.TLSParams -> XMPPConMonad ()
 xmppStartTLS params = do
@@ -49,8 +51,6 @@ xmppStartTLS params = do
                      { sRawSrc = raw
 --                   , sConSrc =  -- Note: this momentarily leaves us in an
                                   -- inconsistent state
-                     , sConPush = \xs -> CL.sourceList xs
-                     $$ XR.renderBytes def =$ snk
                      , sConPushBS = psh
                      })
       xmppRestartStream

src/Network/XMPP/Types.hs

@@ -610,13 +610,12 @@ data ServerFeatures = SF
 data XMPPConState = XMPPConState
                { sConSrc    :: Source IO Event
                , sRawSrc    :: Source IO BS.ByteString
-               , sConPush   :: [Event] -> IO ()
                , sConPushBS :: BS.ByteString -> IO ()
                , sConHandle :: Maybe Handle
                , sFeatures  :: ServerFeatures
                , sHaveTLS   :: Bool
-               , sHostname  :: Text
-               , sUsername  :: Text
+               , sHostname  :: Maybe Text
+               , sUsername  :: Maybe Text
                , sResource  :: Maybe Text
                }
 

src/Tests.hs

@@ -1,7 +1,6 @@
-{-# LANGUAGE PackageImports, OverloadedStrings #-}
+{-# LANGUAGE PackageImports, OverloadedStrings, NoMonomorphismRestriction #-}
 module Example where
 
-import           Network.XMPP
 import           Control.Concurrent
 import           Control.Concurrent.STM
 import           Control.Monad
@@ -13,9 +12,11 @@ import qualified Data.Text as Text
 import           Data.XML.Pickle
 import           Data.XML.Types
 
+import           Network.XMPP
 import           Network.XMPP.Pickle
 
 import           System.Environment
+import Text.XML.Stream.Elements
 
 testUser1 :: JID
 testUser1 = read "testuser1@species64739.dyndns.org/bot1"
@@ -72,6 +73,9 @@ expect debug x y | x == y = debug "Ok."
                             sendUser failMSG
 
 
+wait3 :: MonadIO m => m ()
+wait3 = liftIO $ threadDelay 1000000
+
 runMain :: (String -> STM ()) -> Int -> IO ()
 runMain debug number = do
   let (we, them, active) = case number of
@@ -80,16 +84,21 @@ runMain debug number = do
                              _ -> error "Need either 1 or 2"
   let debug' = liftIO . atomically .
                debug . (("Thread " ++ show number ++ ":") ++)
-  sessionConnect "localhost"
-                 "species64739.dyndns.org"
-                 (fromJust $ node we) (resource we) $ do
-      withConnection $ xmppSASL "pwd"
+  xmppNewSession $ do
+      debug' "running"
+      withConnection $ do
+        xmppConnect "localhost" "species64739.dyndns.org"
+        xmppStartTLS exampleParams
+        saslResponse <- xmppSASL (fromJust $ node we) "pwd"
+        case saslResponse of
+          Right _ -> return ()
+          Left e -> error e
       xmppThreadedBind (resource we)
       withConnection $ xmppSession
+      debug' "session standing"
       sendPresence presenceOnline
       forkXMPP autoAccept
       forkXMPP iqResponder
-      -- sendS . SPresence $ Presence Nothing (Just them) Nothing (Just Subscribe) Nothing Nothing Nothing  []
       when active . void . forkXMPP $ do
         forM [1..10] $ \count -> do
             let message = Text.pack . show $ node we
@@ -99,7 +108,7 @@ runMain debug number = do
             let answerPayload = unpickleElem payloadP
                                   (fromJust $ iqResultPayload answer)
             expect debug' (invertPayload payload) answerPayload
-            liftIO $ threadDelay 500000
+            liftIO $ threadDelay 100000
         sendUser "All tests done"
       liftIO  . forever $ threadDelay 10000000
       return ()

src/Text/XML/Stream/Elements.hs

@@ -4,20 +4,23 @@ import Control.Applicative ((<$>))
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Resource as R
 
-import Data.Text as T
-import Text.XML.Unresolved
+import qualified Data.ByteString as BS
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
 import           Data.XML.Types
+import qualified Text.XML.Stream.Render as TXSR
+import           Text.XML.Unresolved as TXU
 
 import           Data.Conduit as C
 import           Data.Conduit.List as CL
 
-import Text.XML.Stream.Parse
+import           System.IO.Unsafe(unsafePerformIO)
 
 compressNodes :: [Node] -> [Node]
 compressNodes [] = []
 compressNodes [x] = [x]
 compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) =
-    compressNodes $ NodeContent (ContentText $ x `T.append` y) : z
+    compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z
 compressNodes (x:xs) = x : compressNodes xs
 
 elementFromEvents :: R.MonadThrow m => C.Sink Event m Element
@@ -27,7 +30,7 @@ elementFromEvents = do
             Just (EventBeginElement n as) -> goE n as
             _ -> lift $ R.monadThrow $ InvalidEventStream $ "not an element: " ++ show x
   where
-    many f =
+    many' f =
         go id
       where
         go front = do
@@ -38,7 +41,7 @@ elementFromEvents = do
     dropReturn x = CL.drop 1 >> return x
     goE n as = do
         CL.drop 1
-        ns <- many goN
+        ns <- many' goN
         y <- CL.head
         if y == Just (EventEndElement n)
             then return $ Element n as $ compressNodes ns
@@ -57,15 +60,10 @@ elementFromEvents = do
 openElementToEvents :: Element -> [Event]
 openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns []
   where
-    goM [] = id
-    goM [x] = (goM' x :)
-    goM (x:xs) = (goM' x :) . goM xs
-    goM' (MiscInstruction i) = EventInstruction i
-    goM' (MiscComment t) = EventComment t
-    goE (Element name as ns) =
-          (EventBeginElement name as :)
-        . goN ns
-        . (EventEndElement name :)
+    goE (Element name' as' ns') =
+          (EventBeginElement name' as' :)
+        . goN ns'
+        . (EventEndElement name' :)
     goN [] = id
     goN [x] = goN' x
     goN (x:xs) = goN' x . goN xs
@@ -76,3 +74,15 @@ openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns []
 
 elementToEvents :: Element -> [Event]
 elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name]
+
+
+renderOpenElement :: Element -> BS.ByteString
+renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
+    $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume
+
+renderElement :: Element -> BS.ByteString
+renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
+    $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume
+
+ppElement :: Element -> String
+ppElement = Text.unpack . Text.decodeUtf8 . renderElement

xml-types-pickle

@@ -1 +1 @@
-Subproject commit e417f9ddc6cc74dc06fabadad810da10b8e25d84
+Subproject commit 73f8caedfe389646647354badc7700eccf40442f