From cebc4688526520c46e3fa941c636f07bee3c1902 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 19 Mar 2012 19:18:06 +0100 Subject: [PATCH] bind --- src/Network/TLSConduit.hs | 18 ++++++++++-- src/Network/XMPP/Bind.hs | 30 +++++++++++++++++++ src/Network/XMPP/Marshal.hs | 58 +++++++++++++++++++++++-------------- src/Network/XMPP/Monad.hs | 40 ++++++++++++++++--------- src/Network/XMPP/SASL.hs | 14 ++++----- src/Network/XMPP/TLS.hs | 14 ++++----- src/Network/XMPPConduit.hs | 11 ++++--- 7 files changed, 129 insertions(+), 56 deletions(-) create mode 100644 src/Network/XMPP/Bind.hs diff --git a/src/Network/TLSConduit.hs b/src/Network/TLSConduit.hs index 7eedcf4..e1faf1a 100644 --- a/src/Network/TLSConduit.hs +++ b/src/Network/TLSConduit.hs @@ -10,7 +10,7 @@ import Control.Monad.Trans import Crypto.Random -import Data.ByteString +import Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Conduit @@ -20,6 +20,8 @@ import Network.TLS.Extra as TLSExtra import System.IO(Handle) import System.Random +import System.IO + tlsinit :: (MonadIO m, ResourceIO m1) => TLSParams -> Handle @@ -37,4 +39,16 @@ tlsinit tlsParams handle = do (\_ -> return ()) (\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing) (\_ -> return ()) - return (src, snk) + return (src $= conduitStdout , snk) + +-- TODO: remove + +conduitStdout :: ResourceIO m + => Conduit BS.ByteString m BS.ByteString +conduitStdout = conduitIO + (return ()) + (\_ -> return ()) + (\_ bs -> do + liftIO $ BS.hPut stdout 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 new file mode 100644 index 0000000..1cdaa77 --- /dev/null +++ b/src/Network/XMPP/Bind.hs @@ -0,0 +1,30 @@ +module Network.XMPP.Bind where + +import Control.Monad.Trans.State + +import Data.Text as Text +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Types +import Network.XMPP.Marshal + +bindSt resource= SIQ $ IQ Nothing Nothing "bind" Set + (Element "{urn:ietf:params:xml:ns:xmpp-bind}bind" + [] + (maybe [] (return . textToNode) resource)) + + +xmppBind = do + res <- gets sResource + push $ bindSt res + SIQ (IQ Nothing Nothing _ Result r) <- pull + (JID n d (Just r)) <- case r of + Element "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] + [NodeElement + jid@(Element "{urn:ietf:params:xml:ns:xmpp-bind}jid" [] _)] -> + return . fromText . Text.concat . elementText $ jid + _ -> error $ "bind failed:" ++ show r + modify (\s -> s{sResource = Just r}) + + diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index ea9bbf1..8b136e5 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -13,6 +13,18 @@ import Data.XML.Types import Network.XMPP.Types +stanzaToElement (SMessage m) = messageToElement m +stanzaToElement (SPresence m) = presenceToElement m +stanzaToElement (SIQ m) = iqToElement m + +elementToStanza e@(Element (Name n ns Nothing) _ _) = + if (ns `elem` [Nothing, Just "jabber:client"]) then + case n of + "message" -> SMessage $ elementToMessage e + "presence" -> SPresence $ elementToPresence e + "iq" -> SIQ $ elementToIQ e + s -> error $ "unknown stanza type :" ++ show e + else error $ "unknown namespace: " ++ show ns -- create attribute from Just matr _ Nothing = [] @@ -54,23 +66,23 @@ elementToMessage e@(Element "message" _ _) = -- Oh dear, this is HORRIBLE. TODO: come up with something sane in grabFrom (elementChildren e) $ do -- TODO multiple bodies (different languages) - body <- maybeGrabNamed "body" - -- TODO multiple subjects (different languages) - subject <- maybeGrabNamed "subject" - thread <- maybeGrabNamed "thread" - ext <- grabRest - return $ Message - from - to - ident - tp - (elementToText <$>subject) - (elementToText <$> body) - (elementToText <$> thread) - ext - -presenceTOXML (Presence from to id tp stp stat pri exts) = - Element "message" + body <- maybeGrabNamed "body" + -- TODO multiple subjects (different languages) + subject <- maybeGrabNamed "subject" + thread <- maybeGrabNamed "thread" + ext <- grabRest + return $ Message + from + to + ident + tp + (elementToText <$>subject) + (elementToText <$> body) + (elementToText <$> thread) + ext + +presenceToElement (Presence from to id tp stp stat pri exts) = + Element "presence" (map contentify . concat $ [ matr "from" (toText <$> from) , matr "to" (toText <$> to) @@ -85,7 +97,7 @@ presenceTOXML (Presence from to id tp stp stat pri exts) = ]) -- Marshal XML element to message -elementToPresence e@(Element "message" _ _) = +elementToPresence e@(Element (Name "message" _ _) _ _) = let from = fromText <$> attributeText "from" e to = fromText <$> attributeText "to" e ident = attributeText "id" e @@ -108,7 +120,7 @@ elementToPresence e@(Element "message" _ _) = iqToElement (IQ from to id tp body) = - Element "message" + Element "iq" (map contentify . concat $ [ matr "from" (toText <$> from) , matr "to" (toText <$> to ) @@ -117,7 +129,7 @@ iqToElement (IQ from to id tp body) = ]) [ NodeElement body ] -elementToIQ e@(Element "iq" _ _) = +elementToIQ e@(Element (Name "iq" _ _) _ _ ) = let from = fromText <$> attributeText "from" e to = fromText <$> attributeText "to" e Just ident= attributeText "id" e @@ -143,7 +155,7 @@ takeAllFromList pred l = let (l', xs) = go pred [] l in (reverse l', xs) -- elements from a "pool" (list) -- Put a list of elements into the pool and start grabbing -grabFrom l = flip runState l +grabFrom l = fst . flip runState l -- grab all elements matching predicate out of the pool grabAll p = do @@ -167,4 +179,6 @@ grabRest = do hasName x e = x == elementName e -elementToText = Text.concat . elementText \ No newline at end of file +elementToText = Text.concat . elementText + +textToNode t = NodeContent (ContentText t) \ No newline at end of file diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 204a4d5..37d77af 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -1,5 +1,7 @@ module Network.XMPP.Monad where +import Control.Applicative((<$>)) + import Control.Monad.Trans import Control.Monad.Trans.State @@ -12,6 +14,9 @@ import Data.XML.Types import Data.Default import Data.Text +import Network.XMPP.Types +import Network.XMPP.Marshal + import System.IO import Text.XML.Stream.Elements @@ -21,14 +26,14 @@ import Text.XML.Stream.Parse type XMPPMonad a = StateT XMPPState (ResourceT IO) a data XMPPState = XMPPState - { conSrc :: BufferedSource IO Event - , conSink :: Sink Event IO () - , conHandle :: Maybe Handle + { sConSrc :: BufferedSource IO Event + , sConSink :: Sink Event IO () + , sConHandle :: Maybe Handle , sFeatures :: ServerFeatures - , haveTLS :: Bool + , sHaveTLS :: Bool , sHostname :: Text - , username :: Text - , resource :: Text + , sUsername :: Text + , sResource :: Maybe Text } data ServerFeatures = SF @@ -46,27 +51,34 @@ instance Default ServerFeatures where , other = [] } -push :: Element -> XMPPMonad () -push x = do - sink <- gets conSink + +pushE :: Element -> XMPPMonad () +pushE x = do + sink <- gets sConSink lift $ CL.sourceList (elementToEvents x) $$ sink +push :: Stanza -> XMPPMonad () +push = pushE . stanzaToElement + pushOpen :: Element -> XMPPMonad () pushOpen x = do - sink <- gets conSink + sink <- gets sConSink lift $ CL.sourceList (elementToEvents' x) $$ sink pulls :: Sink Event IO a -> XMPPMonad a pulls snk = do - source <- gets conSrc + source <- gets sConSrc lift $ source $$ snk -pull :: XMPPMonad Element -pull = do - source <- gets conSrc +pullE :: XMPPMonad Element +pullE = do + source <- gets sConSrc pulls elementFromEvents +pull :: XMPPMonad Stanza +pull = elementToStanza <$> pullE + xmppFromHandle handle hostname username resource f = runResourceT $ do liftIO $ hSetBuffering handle NoBuffering src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 886cb83..ec891b1 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -48,24 +48,24 @@ saslResponse2E = xmppSASL passwd = do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" - push $ saslInitE "DIGEST-MD5" + pushE $ saslInitE "DIGEST-MD5" Element "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" [] - [NodeContent (ContentText content)] <- pull + [NodeContent (ContentText content)] <- pullE let (Right challenge) = B64.decode . Text.encodeUtf8 $ content let Right pairs = toPairs challenge - push . saslResponseE =<< createResponse passwd pairs - Element name attrs content <- pull + pushE . saslResponseE =<< createResponse passwd pairs + Element name attrs content <- pullE when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $ (error $ show content) - push saslResponse2E - Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pull + pushE saslResponse2E + Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE xmppStartStream return () createResponse passwd' pairs = do let Just qop = L.lookup "qop" pairs let Just nonce = L.lookup "nonce" pairs - uname <- Text.encodeUtf8 <$> gets username + uname <- Text.encodeUtf8 <$> gets sUsername let passwd = Text.encodeUtf8 passwd' realm <- Text.encodeUtf8 <$> gets sHostname g <- liftIO $ Random.newStdGen diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index c351acc..4404529 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -29,16 +29,16 @@ exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} xmppStartTLS params = do features <- gets sFeatures when (stls features) $ do - push starttlsE - Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pull - Just handle <- gets conHandle + pushE starttlsE + Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE + Just handle <- gets sConHandle (src', snk) <- lift $ TLS.tlsinit params handle src <- lift . bufferSource $ src' $= CT.decode CT.utf8 $= parseText def modify (\x -> x - { conSrc = src - , conSink = XR.renderBytes def =$ snk + { sConSrc = src + , sConSink = XR.renderBytes def =$ snk }) xmppStartStream - modify (\s -> s{haveTLS = True}) - gets haveTLS + modify (\s -> s{sHaveTLS = True}) + gets sHaveTLS diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs index b99135a..5c11a6d 100644 --- a/src/Network/XMPPConduit.hs +++ b/src/Network/XMPPConduit.hs @@ -13,27 +13,30 @@ import Network.XMPP.Monad import Network.XMPP.TLS import Network.XMPP.Stream import Network.XMPP.SASL +import Network.XMPP.Bind import System.IO fromHandle :: Handle -> Text -> Text -> Text -> IO ((), XMPPState) fromHandle handle hostname username password = - xmppFromHandle handle hostname username "" $ do + xmppFromHandle handle hostname username Nothing $ do xmppStartStream -- this will check whether the server supports tls -- on it's own xmppStartTLS exampleParams xmppSASL password - gets haveTLS >>= liftIO . print - forever $ pull >>= liftIO . print + 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" - print $ haveTLS st + print $ sHaveTLS st putStrLn "" hGetContents con >>= putStrLn