From e0b97dacf817d4bbc9f7142bc826f1de753a0f42 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 14 Apr 2012 21:39:43 +0200 Subject: [PATCH] removed sConPush, session now starts without connection, added inline connection method xml-types-pickle updated --- src/Network/XMPP.hs | 39 +++---------------- src/Network/XMPP/Concurrent/Monad.hs | 1 - src/Network/XMPP/Concurrent/Threads.hs | 4 +- src/Network/XMPP/Monad.hs | 44 +++++++++++++++------- src/Network/XMPP/Pickle.hs | 6 +-- src/Network/XMPP/SASL.hs | 31 +++++++++++---- src/Network/XMPP/Stream.hs | 2 +- src/Network/XMPP/TLS.hs | 8 ++-- src/Network/XMPP/Types.hs | 5 +-- src/Tests.hs | 25 +++++++++---- src/Text/XML/Stream/Elements.hs | 52 +++++++++++++++----------- xml-types-pickle | 2 +- 12 files changed, 119 insertions(+), 100 deletions(-) diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index d2e96b5..51c84d7 100644 --- a/src/Network/XMPP.hs +++ b/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 \ No newline at end of file diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index a92af43..a7ccb62 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -162,7 +162,6 @@ withConnection a = do putTMVar stateRef s' return res - sendPresence :: Presence -> XMPPThread () sendPresence = sendS . PresenceS diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index db9b0ca..40669e3 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/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. diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 50ef734..c080f53 100644 --- a/src/Network/XMPP/Monad.hs +++ b/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 diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index c1b15c9..a999956 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/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 - - diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index d893150..53b6c2e 100644 --- a/src/Network/XMPP/SASL.hs +++ b/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 diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 3bc4188..b95706a 100644 --- a/src/Network/XMPP/Stream.hs +++ b/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 () diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index a536bb8..55884d5 100644 --- a/src/Network/XMPP/TLS.hs +++ b/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 diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 49cac1f..e948756 100644 --- a/src/Network/XMPP/Types.hs +++ b/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 } diff --git a/src/Tests.hs b/src/Tests.hs index b9d553d..e3438f3 100644 --- a/src/Tests.hs +++ b/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 () diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs index 3812752..952854d 100644 --- a/src/Text/XML/Stream/Elements.hs +++ b/src/Text/XML/Stream/Elements.hs @@ -1,23 +1,26 @@ module Text.XML.Stream.Elements where -import Control.Applicative ((<$>)) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Resource as R +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 Data.XML.Types +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 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 \ No newline at end of file diff --git a/xml-types-pickle b/xml-types-pickle index e417f9d..73f8cae 160000 --- a/xml-types-pickle +++ b/xml-types-pickle @@ -1 +1 @@ -Subproject commit e417f9ddc6cc74dc06fabadad810da10b8e25d84 +Subproject commit 73f8caedfe389646647354badc7700eccf40442f