From d11434f18f86ab5983046945c537f034b98000fc Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 21 Mar 2012 12:13:17 +0100 Subject: [PATCH] switched to hexpat --- src/Data/Conduit/Hexpat.hs | 184 ++++++++++++++ .../TLSConduit.hs => Data/Conduit/TLS.hs} | 16 +- src/Network/XMPP/Bind.hs | 36 ++- src/Network/XMPP/Marshal.hs | 230 +++++------------- src/Network/XMPP/Monad.hs | 79 +++--- src/Network/XMPP/Pickle.hs | 66 +++++ src/Network/XMPP/SASL.hs | 57 +++-- src/Network/XMPP/Stream.hs | 115 +++++---- src/Network/XMPP/TLS.hs | 32 +-- src/Network/XMPP/Types.hs | 227 +++++++++-------- src/Network/XMPPConduit.hs | 9 +- src/Text/XML/Stream/Elements.hs | 76 ------ src/Utils.hs | 7 + 13 files changed, 636 insertions(+), 498 deletions(-) create mode 100644 src/Data/Conduit/Hexpat.hs rename src/{Network/TLSConduit.hs => Data/Conduit/TLS.hs} (70%) create mode 100644 src/Network/XMPP/Pickle.hs delete mode 100644 src/Text/XML/Stream/Elements.hs create mode 100644 src/Utils.hs diff --git a/src/Data/Conduit/Hexpat.hs b/src/Data/Conduit/Hexpat.hs new file mode 100644 index 0000000..191bee1 --- /dev/null +++ b/src/Data/Conduit/Hexpat.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DeriveDataTypeable, NoMonomorphismRestriction #-} + +module Data.Conduit.Hexpat where + +import Control.Applicative((<$>)) +import Control.Exception +import Control.Monad +import Control.Monad.Trans + +import qualified Data.ByteString as BS +import Data.Conduit as C +import Data.Conduit.List as CL +import Data.Maybe +import Data.Typeable + +import Text.XML.Expat.Internal.IO hiding (parse) +import Text.XML.Expat.SAX +import Text.XML.Expat.Tree + +import Foreign.Ptr + +import Data.IORef +-- adapted from parseG + +-- | Parse a generalized list of ByteStrings containing XML to SAX events. +-- In the event of an error, FailDocument is the last element of the output list. +-- parseG :: forall tag text l . (GenericXMLString tag, GenericXMLString text, List l) => +-- ParseOptions tag text -- ^ Parse options +-- -> l ByteString -- ^ Input text (a lazy ByteString) +-- -> l (SAXEvent tag text) +-- parseG opts inputBlocks = runParser inputBlocks parser queueRef cacheRef +-- where + +data HexpatParser tag text a = HexpatParser + { hParser :: Parser + , hQueueRef :: IORef [SAXEvent tag text] + } + +createParser + :: (GenericXMLString tag, GenericXMLString text) => + ParseOptions tag text -> IO (HexpatParser tag text a) +createParser opts = do + let enc = overrideEncoding opts + let mEntityDecoder = entityDecoder opts + + parser <- newParser enc + queueRef <- newIORef [] + + case mEntityDecoder of + Just deco -> setEntityDecoder parser deco $ \_ txt -> do + modifyIORef queueRef (CharacterData txt:) + Nothing -> return () + + setXMLDeclarationHandler parser $ \_ cVer cEnc cSd -> do + ver <- textFromCString cVer + mEnc <- if cEnc == nullPtr + then return Nothing + else Just <$> textFromCString cEnc + let sd = if cSd < 0 + then Nothing + else Just $ if cSd /= 0 then True else False + modifyIORef queueRef (XMLDeclaration ver mEnc sd:) + return True + + setStartElementHandler parser $ \_ cName cAttrs -> do + name <- textFromCString cName + attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do + attrName <- textFromCString cAttrName + attrValue <- textFromCString cAttrValue + return (attrName, attrValue) + modifyIORef queueRef (StartElement name attrs:) + return True + + setEndElementHandler parser $ \_ cName -> do + name <- textFromCString cName + modifyIORef queueRef (EndElement name:) + return True + + setCharacterDataHandler parser $ \_ cText -> do + txt <- gxFromCStringLen cText + modifyIORef queueRef (CharacterData txt:) + return True + + setStartCDataHandler parser $ \_ -> do + modifyIORef queueRef (StartCData :) + return True + + setEndCDataHandler parser $ \_ -> do + modifyIORef queueRef (EndCData :) + return True + + setProcessingInstructionHandler parser $ \_ cTarget cText -> do + target <- textFromCString cTarget + txt <- textFromCString cText + modifyIORef queueRef (ProcessingInstruction target txt :) + return True + + setCommentHandler parser $ \_ cText -> do + txt <- textFromCString cText + modifyIORef queueRef (Comment txt :) + return True + + return (HexpatParser parser queueRef) + +data HexpatParseException = HexpatParseExceptio String deriving (Typeable, Show) +instance Exception HexpatParseException + +parseBS + :: (GenericXMLString text, GenericXMLString tag) => + ParseOptions tag text + -> Conduit BS.ByteString IO (SAXEvent tag text) +parseBS opts = conduitIO + (createParser opts) + (\_ -> return ()) + (\(HexpatParser parser queueRef) input -> do + error <- withParser parser $ \pp -> parseChunk pp input False + case error of + Nothing -> return () + Just (XMLParseError err _) -> + resourceThrow $ HexpatParseExceptio err + queue <- readIORef queueRef + writeIORef queueRef [] + return . IOProducing $ reverse queue + ) + (\(HexpatParser parser queueRef) -> do + error <- withParser parser $ \pp -> parseChunk pp BS.empty True + case error of + Nothing -> return () + Just (XMLParseError err _) -> + resourceThrow $ HexpatParseExceptio err + queue <- readIORef queueRef + writeIORef queueRef [] + return $ reverse queue + ) + +whileJust :: Monad m => m (Maybe a) -> m [a] +whileJust f = do + f' <- f + case f' of + Just x -> liftM (x :) $ whileJust f + Nothing -> return [] + + + +data StreamUnfinishedException = StreamUnfinishedException deriving (Typeable, Show) +instance Exception StreamUnfinishedException + + +elementFromEvents + :: (Eq tag, Show tag, MonadIO m, Resource m) => + Sink (SAXEvent tag text) m (NodeG [] tag text) +elementFromEvents = do + Just (StartElement name attrs) <- CL.head + children <- liftM catMaybes . whileJust $ do + next' <- CL.peek + next <- case next' of + Nothing -> liftIO . throwIO $ StreamUnfinishedException + Just n -> return n + case next of + StartElement _ _ -> Just . Just <$> elementFromEvents + EndElement n -> if n == name then CL.drop 1 >> return Nothing + else error $ "closing wrong element: " + ++ show n ++ " instead of " ++ show name + CharacterData txt -> CL.drop 1 >> (return . Just . Just $ Text txt) + _ -> return $ Just Nothing + return $ Element name attrs children + +openElementFromEvents + :: Resource m => Sink (SAXEvent tag text) m (NodeG [] tag text) +openElementFromEvents = do + throwOutJunk + Just (StartElement name attrs) <- CL.head + return $ Element name attrs [] + +throwOutJunk :: Resource m => Sink (SAXEvent t t1) m () +throwOutJunk = do + next <- peek + case next of + Nothing -> return () + Just (StartElement _ _) -> return () + _ -> CL.drop 1 >> throwOutJunk + +saxToElements = C.sequence $ throwOutJunk >> elementFromEvents + diff --git a/src/Network/TLSConduit.hs b/src/Data/Conduit/TLS.hs similarity index 70% rename from src/Network/TLSConduit.hs rename to src/Data/Conduit/TLS.hs index e1faf1a..e0a2565 100644 --- a/src/Network/TLSConduit.hs +++ b/src/Data/Conduit/TLS.hs @@ -1,4 +1,4 @@ -module Network.TLSConduit +module Data.Conduit.TLS ( tlsinit , module TLS , module TLSExtra @@ -10,7 +10,7 @@ import Control.Monad.Trans import Crypto.Random -import Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Conduit @@ -25,21 +25,17 @@ import System.IO tlsinit :: (MonadIO m, ResourceIO m1) => TLSParams -> Handle - -> m (Source m1 ByteString, Sink ByteString m1 ()) + -> m (Source m1 BS.ByteString, (BS.ByteString -> IO ())) tlsinit tlsParams handle = do gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? clientContext <- client tlsParams gen handle handshake clientContext let src = sourceIO (return clientContext) - bye + (\_ -> putStrLn "tls closed") (\con -> IOOpen <$> recvData con) - let snk = sinkIO - (return clientContext) - (\_ -> return ()) - (\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing) - (\_ -> return ()) - return (src $= conduitStdout , snk) + return (src $= conduitStdout + , \s -> sendData clientContext $ BL.fromChunks [s] ) -- TODO: remove diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 1cdaa77..aba68c5 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -1,30 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + module Network.XMPP.Bind where +import Control.Monad.Trans 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.Pickle 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)) +import Text.XML.Expat.Pickle + +bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set + (pickleElem + (bindP . xpOption + $ xpElemNodes "resource" (xpContent xpText)) + resource + ) +jidP :: PU [Node Text Text] JID +jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) 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 + 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}) +bindP c = ignoreAttrs $ xpElemNs "bind" "urn:ietf:params:xml:ns:xmpp-bind" + xpUnit + c + diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 8b136e5..5eedc1b 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -9,176 +9,68 @@ import Control.Monad.State import Data.Maybe import qualified Data.Text as Text -import Data.XML.Types +import Network.XMPP.Pickle import Network.XMPP.Types -stanzaToElement (SMessage m) = messageToElement m -stanzaToElement (SPresence m) = presenceToElement m -stanzaToElement (SIQ m) = iqToElement m +import Text.XML.Expat.Pickle + +stanzaSel (SMessage _ )= 0 +stanzaSel (SPresence _ )= 1 +stanzaSel (SIQ _ )= 2 + +stanzaP = xpAlt stanzaSel + [ xpWrap (SMessage , (\(SMessage m) -> m)) messageP + , xpWrap (SPresence , (\(SPresence p) -> p)) presenceP + , 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))) + ) $ + xpElem "message" + (xp4Tuple + (xpAttrImplied "from" xpPrim) + (xpAttr "to" xpPrim) + (xpAttrImplied "id" xpText) + (xpAttrImplied "type" xpPrim) + ) + (xp4Tuple + (xpOption . xpElemNodes "body" $ xpContent xpText) + (xpOption . xpElemNodes "subject" $ xpContent xpText) + (xpOption . xpElemNodes "thread" $ xpContent xpText) + xpTrees + ) + +presenceP = xpWrap ( (\((from, to, id, tp),(shw, stat, prio, ext)) + -> Presence from to id tp shw stat prio ext) + , (\(Presence from to id tp shw stat prio ext) + -> ((from, to, id, tp), (shw, stat, prio, ext))) + ) $ + xpElem "presence" + (xp4Tuple + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + (xpAttrImplied "id" xpText) + (xpAttrImplied "type" xpPrim) + ) + (xp4Tuple + (xpOption . xpElemNodes "show" $ xpContent xpPrim) + (xpOption . xpElemNodes "status" $ xpContent xpText) + (xpOption . xpElemNodes "priority" $ xpContent xpPrim) + xpTrees + ) + +iqP = xpWrap ( (\((from, to, id, tp),body) -> IQ from to id tp body) + , (\(IQ from to id tp body) -> ((from, to, id, tp), body)) + ) $ + xpElem "iq" + (xp4Tuple + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + (xpAttr "id" xpText) + (xpAttr "type" xpPrim)) + (xpTree) -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 = [] -matr n (Just x) = [(n,x)] - --- Child if text is not empty -nech _ "" = [] -nech n x = [ NodeElement (Element n [] [NodeContent (ContentText x) ]) ] - --- Child if text is not Nothing -mnech _ Nothing = [] -mnech n (Just x) = [ NodeElement (Element n [] [NodeContent (ContentText x) ]) ] - --- make Attributes from text -contentify (x,y) = (x, [ContentText y]) - --- Marshal Message to XML Element -messageToElement (Message from to ident tp sub body thread exts) = - Element "message" - (map contentify . concat $ - [ matr "from" (toText <$> from) - , [("to", toText to)] - , matr "id" ident - , [("type", toText tp)] - ]) - (concat $ - [ mnech "subject" sub - , mnech "body" body - , mnech "thread" thread - , map NodeElement exts - ]) - --- Marshal XML element to message -elementToMessage e@(Element "message" _ _) = - let from = fromText <$> attributeText "from" e - Just to = fromText <$> attributeText "to" e - ident = attributeText "id" e - Just tp = fromText <$> attributeText "type" e - -- 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 - -presenceToElement (Presence from to id tp stp stat pri exts) = - Element "presence" - (map contentify . concat $ - [ matr "from" (toText <$> from) - , matr "to" (toText <$> to) - , matr "id" id - , matr "type" ( toText <$> tp) - ]) - (concat $ - [ mnech "show" (toText <$> stp) - , mnech "status" stat - , mnech "priority" (Text.pack . show <$> pri) - , map NodeElement exts - ]) - --- Marshal XML element to message -elementToPresence e@(Element (Name "message" _ _) _ _) = - let from = fromText <$> attributeText "from" e - to = fromText <$> attributeText "to" e - ident = attributeText "id" e - tp = fromText <$> attributeText "type" e - in grabFrom (elementChildren e) $ do - pshow <- maybeGrabNamed "show" - -- TODO multiple status (different languages) - stat <- maybeGrabNamed "status" - prio <- maybeGrabNamed "priority" - ext <- grabRest - return $ Presence - from - to - ident - tp - (fromText . elementToText <$> pshow) - (elementToText <$> stat) - (read . Text.unpack . elementToText <$> prio) - ext - - -iqToElement (IQ from to id tp body) = - Element "iq" - (map contentify . concat $ - [ matr "from" (toText <$> from) - , matr "to" (toText <$> to ) - , [("id" , id)] - , [("type", toText tp)] - ]) - [ NodeElement body ] - -elementToIQ e@(Element (Name "iq" _ _) _ _ ) = - let from = fromText <$> attributeText "from" e - to = fromText <$> attributeText "to" e - Just ident= attributeText "id" e - Just tp = fromText <$> attributeText "type" e - [ext] = elementChildren e - in IQ - from - to - ident - tp - ext - --- take and remove all elements matching a predicate from the list -takeAllFromList pred l = let (l', xs) = go pred [] l in (reverse l', xs) - where - go pred ys [] = (ys, []) - go pred ys (x:xs) = - case pred x of - True -> let (ys', rs) = go pred ys xs in (ys', x:rs) - False -> go pred (x:ys) xs - --- The "Grab Monad" : sucessively take and remove ("grab") --- elements from a "pool" (list) - --- Put a list of elements into the pool and start grabbing -grabFrom l = fst . flip runState l - --- grab all elements matching predicate out of the pool -grabAll p = do - l <- get - let (l', xs) = takeAllFromList p l - put l' - return xs - --- grab XML-elements by exact name -grabNamed = grabAll . hasName - --- This throws away all elements after the first one --- TODO: Be more stricy here -maybeGrabNamed = liftM listToMaybe . grabAll . hasName - --- grab all remaining elements from the pool -grabRest = do - l <- get - put [] - return l - -hasName x e = x == elementName e - -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 37d77af..b9c6302 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -1,69 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + module Network.XMPP.Monad where import Control.Applicative((<$>)) +import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.State +import Data.ByteString as BS + import Data.Conduit -import Data.Conduit.Text as CT import Data.Conduit.Binary as CB +import Data.Conduit.Hexpat as HXC import Data.Conduit.List as CL -import Data.XML.Types +import Data.Conduit.Text as CT import Data.Default -import Data.Text +import qualified Data.Text as Text import Network.XMPP.Types import Network.XMPP.Marshal +import Network.XMPP.Pickle import System.IO -import Text.XML.Stream.Elements -import Text.XML.Stream.Render as XR -import Text.XML.Stream.Parse - -type XMPPMonad a = StateT XMPPState (ResourceT IO) a - -data XMPPState = XMPPState - { sConSrc :: BufferedSource IO Event - , sConSink :: Sink Event IO () - , sConHandle :: Maybe Handle - , sFeatures :: ServerFeatures - , sHaveTLS :: Bool - , sHostname :: Text - , sUsername :: Text - , sResource :: Maybe Text - } - -data ServerFeatures = SF - { stls :: Bool - , stlsRequired :: Bool - , saslMechanisms :: [Text] - , other :: [Element] - } deriving Show - -instance Default ServerFeatures where - def = SF - { stls = False - , stlsRequired = False - , saslMechanisms = [] - , other = [] - } - - -pushE :: Element -> XMPPMonad () -pushE x = do +import Text.XML.Expat.SAX +import Text.XML.Expat.Tree +import Text.XML.Expat.Format + +parseOpts = ParseOptions (Just UTF8) Nothing + +pushN :: Element -> XMPPMonad () +pushN x = do sink <- gets sConSink - lift $ CL.sourceList (elementToEvents x) $$ sink + lift . sink $ formatNode' x push :: Stanza -> XMPPMonad () -push = pushE . stanzaToElement +push = pushN . pickleElem stanzaP pushOpen :: Element -> XMPPMonad () -pushOpen x = do +pushOpen (Element name attrs children) = do sink <- gets sConSink - lift $ CL.sourceList (elementToEvents' x) $$ sink + let sax = StartElement name attrs + lift . sink $ formatSAX' [sax] + forM children pushN + return () pulls :: Sink Event IO a -> XMPPMonad a @@ -76,15 +58,22 @@ pullE = do source <- gets sConSrc pulls elementFromEvents +pullPickle p = unpickleElem p <$> pullE + pull :: XMPPMonad Stanza -pull = elementToStanza <$> pullE +pull = pullPickle stanzaP + +-- 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 + raw <- bufferSource $ CB.sourceHandle handle + src <- bufferSource $ raw $= HXC.parseBS parseOpts let st = XMPPState src - (XR.renderBytes def =$ CB.sinkHandle handle) + raw + (liftIO . BS.hPut handle) (Just handle) def False diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs new file mode 100644 index 0000000..2b4ff42 --- /dev/null +++ b/src/Network/XMPP/Pickle.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} + +-- Marshalling between XML and Native Types + + +module Network.XMPP.Pickle where + +import Control.Applicative((<$>)) + +import qualified Data.ByteString as BS + +import Data.Text as Text +import Data.Text.Encoding as Text + +import Network.XMPP.Types + +import Text.XML.Expat.Pickle +import Text.XML.Expat.Tree + + +mbToBool (Just _) = True +mbToBool _ = False + +xpElemEmpty name = xpWrap (\((),()) -> () , + \() -> ((),())) $ + xpElem name xpUnit xpUnit + +xpElemExists name = xpWrap (\x -> mbToBool x + ,\x -> if x then Just () else Nothing) $ + xpOption (xpElemEmpty name) + +ignoreAttrs = xpWrap (snd, ((),)) + +mbl (Just l) = l +mbl Nothing = [] + +lmb [] = Nothing +lmb x = Just x + +right (Left l) = error l +right (Right r) = r + +unpickleElem p = right . unpickleTree' (xpRoot p) +pickleElem p = pickleTree $ xpRoot p + +xpEither l r = xpAlt eitherSel + [xpWrap (\x -> Left x, \(Left x) -> x) l + ,xpWrap (\x -> Right x, \(Right x) -> x) r + ] + where + eitherSel (Left _) = 0 + eitherSel (Right _) = 1 + +xpElemNs name ns attrs nodes = + xpWrap (\(((),a),n) -> (a,n), \(a,n) -> (((),a),n)) $ + xpElem name + (xpPair + (xpAttrFixed "xmlns" ns) + attrs + ) + nodes \ No newline at end of file diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index ec891b1..885223f 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -18,13 +18,14 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.List as L import qualified Data.Digest.Pure.MD5 as MD5 import Data.List -import Data.XML.Types import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Network.XMPP.Monad +import Network.XMPP.Pickle import Network.XMPP.Stream +import Network.XMPP.Types import Numeric -- @@ -32,34 +33,42 @@ import qualified System.Random as Random import Text.XML.Stream.Elements +import Text.XML.Expat.Pickle +import Text.XML.Expat.Tree + saslInitE mechanism = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" - [("mechanism", [ContentText mechanism]) + Element "auth" + [ ("xmlns","urn:ietf:params:xml:ns:xmpp-sasl") + , ("mechanism", mechanism) ] [] saslResponseE resp = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] - [NodeContent $ ContentText resp] + Element "response" + [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] + [Text resp] saslResponse2E = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] [] + Element "response" + [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] + [] xmppSASL passwd = do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" - pushE $ saslInitE "DIGEST-MD5" - Element "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" [] - [NodeContent (ContentText content)] <- pullE - let (Right challenge) = B64.decode . Text.encodeUtf8 $ content + liftIO $ putStrLn "saslinit" + pushN $ saslInitE "DIGEST-MD5" + liftIO $ putStrLn "saslinit sent" + Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle let Right pairs = toPairs challenge - pushE . saslResponseE =<< createResponse passwd pairs - Element name attrs content <- pullE - when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $ - (error $ show content) - pushE saslResponse2E - Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE - xmppStartStream + pushN . saslResponseE =<< createResponse passwd pairs + challenge2 <- pullPickle (xpEither failurePickle challengePickle) + case challenge2 of + Left x -> error $ show x + Right c -> return () + pushN saslResponse2E + Element "success" [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] [] <- pullE + xmppRestartStream return () createResponse passwd' pairs = do @@ -119,3 +128,17 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= ha2 = hash ["AUTHENTICATE", digestURI] in hash [ha1,nonce, nc, cnonce,qop,ha2] + +-- Pickling + +failurePickle = ignoreAttrs $ + xpElem "failure" + (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") + (xpTree) + +challengePickle :: PU [Node Text.Text Text.Text] Text.Text +challengePickle = ignoreAttrs $ + xpElem "challenge" + (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") + (xpContent xpText0) + diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 70ea683..d91d4f3 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -1,79 +1,94 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Network.XMPP.Stream where +import Control.Applicative((<$>)) import Control.Monad(unless) +import Control.Monad.Trans import Control.Monad.Trans.State +import Control.Monad.IO.Class import Network.XMPP.Monad +import Network.XMPP.Pickle +import Network.XMPP.Types import Data.Conduit +import Data.Conduit.Hexpat as HXC import Data.Conduit.List as CL import qualified Data.List as L import Data.Text as T -import Data.XML.Types -import Text.XML.Stream.Elements +import Text.XML.Expat.Pickle + +-- import Text.XML.Stream.Elements + xmppStartStream = do hostname <- gets sHostname - pushOpen $ streamE hostname + pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) features <- pulls xmppStream modify (\s -> s {sFeatures = features}) return () +xmppRestartStream = do + raw <- gets sRawSrc + src <- gets sConSrc + newsrc <- lift (bufferSource $ raw $= HXC.parseBS parseOpts) + modify (\s -> s{sConSrc = newsrc}) + xmppStartStream + -xmppStream :: ResourceThrow m => Sink Event m ServerFeatures +xmppStream :: Sink Event IO ServerFeatures xmppStream = do xmppStreamHeader xmppStreamFeatures - -xmppStreamHeader :: Resource m => Sink Event m () +xmppStreamHeader :: Sink Event IO () xmppStreamHeader = do - hd <- CL.peek - case hd of - Just EventBeginDocument -> CL.drop 1 - _ -> return () - Just (EventBeginElement "{http://etherx.jabber.org/streams}stream" streamAttrs) <- CL.head - unless (checkVersion streamAttrs) $ error "Not XMPP version 1.0 " - return () - where - checkVersion = L.any (\x -> (fst x == "version") && (snd x == [ContentText "1.0"])) - - -xmppStreamFeatures - :: ResourceThrow m => Sink Event m ServerFeatures -xmppStreamFeatures = do - Element "{http://etherx.jabber.org/streams}features" [] features' <- elementFromEvents - let features = do - f <- features' - case f of - NodeElement e -> [e] - _ -> [] - let starttls = features >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}starttls" - let starttlsRequired = starttls - >>= elementChildren - >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}required" - let mechanisms = features - >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" - >>= elementChildren - >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" - >>= elementText - return SF { stls = not $ L.null starttls - , stlsRequired = not $ L.null starttlsRequired - , saslMechanisms = mechanisms - , other = features - } - -streamE :: T.Text -> Element -streamE hostname = - Element (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - [ - ("xml:language" , [ContentText "en"]) - , ("version", [ContentText "1.0"]) - , ("to", [ContentText hostname]) - ] - [] + throwOutJunk + (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents + unless (ver == "1.0") $ error "Not XMPP version 1.0 " + return() + + +xmppStreamFeatures :: Sink Event IO ServerFeatures +xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents + + +-- Pickling + +pickleStream = xpWrap (snd, (((),()),)) . + xpElemAttrs "stream:stream" $ + xpPair + (xpPair + (xpAttrFixed "xmlns" "jabber:client" ) + (xpAttrFixed "xmlns:stream" "http://etherx.jabber.org/streams" ) + ) + (xpTriple + (xpAttr "version" xpText) + (xpOption $ xpAttr "from" xpText) + (xpOption $ xpAttr "to" xpText) + ) + +pickleTLSFeature = ignoreAttrs $ + xpElem "starttls" + (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls") + (xpElemExists "required") + +pickleSaslFeature = ignoreAttrs $ + xpElem "mechanisms" + (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") + (xpList0 $ + xpElemNodes "mechanism" (xpContent xpText) ) +pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest + , (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) + ) $ + xpElemNodes "stream:features" + (xpTriple + (xpOption pickleTLSFeature) + (xpOption pickleSaslFeature) + xpTrees + ) diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 4404529..ddd69b7 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -2,43 +2,43 @@ module Network.XMPP.TLS where -import Control.Monad(when) +import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.State import Network.XMPP.Monad import Network.XMPP.Stream -import Network.TLSConduit as TLS +import Network.XMPP.Types import Data.Conduit +import Data.Conduit.Hexpat as HX import Data.Conduit.Text as CT +import Data.Conduit.TLS as TLS import Data.Conduit.List as CL import qualified Data.List as L -import Data.XML.Types - -import Text.XML.Stream.Elements -import Text.XML.Stream.Parse -import Text.XML.Stream.Render as XR +import Text.XML.Expat.Tree starttlsE = - Element (Name "starttls" (Just "urn:ietf:params:xml:ns:xmpp-tls") Nothing ) [] [] + Element "starttls" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} xmppStartTLS params = do features <- gets sFeatures - when (stls features) $ do - pushE starttlsE - Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE + unless (stls features == Nothing) $ do + pushN starttlsE + Element "proceed" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] <- pullE Just handle <- gets sConHandle - (src', snk) <- lift $ TLS.tlsinit params handle - src <- lift . bufferSource $ src' $= CT.decode CT.utf8 $= parseText def + (raw', snk) <- lift $ TLS.tlsinit params handle + raw <- lift . bufferSource $ raw' modify (\x -> x - { sConSrc = src - , sConSink = XR.renderBytes def =$ snk + { sRawSrc = raw +-- , sConSrc = -- Note: this momentarily leaves us in an + -- inconsistent state + , sConSink = liftIO . snk }) - xmppStartStream + xmppRestartStream modify (\s -> s{sHaveTLS = True}) gets sHaveTLS diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 5dc6d13..c10f3cc 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -5,17 +5,23 @@ module Network.XMPP.Types where import Control.Applicative((<$>)) import Control.Monad +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 import Data.String as Str -import Data.XML.Types -class ToText a where - toText :: a -> Text +import System.IO -class FromText a where - fromText :: Text -> a +import Text.XML.Expat.SAX +import Text.XML.Expat.Tree + +type Element = Node Text.Text Text.Text +type Event = SAXEvent Text.Text Text.Text -- | Jabber ID (JID) datatype data JID = JID { node :: Maybe Text @@ -25,31 +31,50 @@ data JID = JID { node :: Maybe Text , resource :: Maybe Text -- ^ Resource name } -instance ToText JID where - toText (JID n d r) = - let n' = maybe "" (`append` "@" ) n - r' = maybe "" ("/" `append` ) r - in Text.concat [n', d, r'] - -instance FromText JID where - fromText = parseJID - instance Show JID where show = Text.unpack . toText +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 () + , sConHandle :: Maybe Handle + , sFeatures :: ServerFeatures + , sHaveTLS :: Bool + , sHostname :: Text.Text + , sUsername :: Text.Text + , sResource :: Maybe Text.Text + } + +data ServerFeatures = SF + { stls :: Maybe Bool + , saslMechanisms :: [Text.Text] + , other :: [Element] + } deriving Show + +instance Default ServerFeatures where + def = SF + { stls = Nothing + , saslMechanisms = [] + , other = [] + } + + -- Ugh, that smells a bit. parseJID jid = - let (jid', rst) = case Text.splitOn "@" jid of + let (jid', rst) = case L.splitOn "@" jid of [rest] -> (JID Nothing, rest) - [node,rest] -> (JID (Just node), rest) - _ -> error $ "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\"" - in case Text.splitOn "/" rst of - [domain] -> jid' domain Nothing - [domain, resource] -> jid' domain (Just resource) - _ -> error $ "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\"" + [node,rest] -> (JID (Just (Text.pack node)), rest) + _ -> error $ "Couldn't parse JID: \"" ++ jid ++ "\"" + in case L.splitOn "/" rst of + [domain] -> jid' (Text.pack domain) Nothing + [domain, resource] -> jid' (Text.pack domain) (Just (Text.pack resource)) + _ -> error $ "Couldn't parse JID: \"" ++ jid ++ "\"" -instance IsString JID where - fromString = parseJID . Text.pack +instance Read JID where + readsPrec _ x = [(parseJID x,"")] -- should we factor from, to and id out, even though they are @@ -59,7 +84,7 @@ data Message = Message , mTo :: JID , mId :: Maybe Text -- ^ Message 'from', 'to', 'id' attributes - , mType :: MessageType + , mType :: Maybe MessageType -- ^ Message type (2.1.1) , mSubject :: Maybe Text -- ^ Subject element (2.1.2.1) @@ -86,7 +111,7 @@ data Presence = Presence -- ^ Presence priority (2.2.2.3) , pExt :: [Element] -- ^ Additional contents, used for extensions - } + } deriving Show data IQ = IQ { iqFrom :: Maybe JID @@ -97,11 +122,11 @@ data IQ = IQ -- ^ IQ type (Core-9.2.3) , iqBody :: Element -- ^ Child element (Core-9.2.3) - } + } deriving Show -data Stanza = SMessage Message | SPresence Presence | SIQ IQ -- deriving Show +data Stanza = SMessage Message | SPresence Presence | SIQ IQ deriving Show -data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving (Eq, Show) +data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving (Eq) data PresenceType = Default | Unavailable | Subscribe | Subscribed | Unsubscribe | Unsubscribed | Probe | PresenceError deriving Eq @@ -109,73 +134,79 @@ data IQType = Get | Result | Set | IQError deriving Eq data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq -instance ToText MessageType where - toText Chat = "chat" - toText GroupChat = "groupchat" - toText Headline = "headline" - toText Normal = "normal" - toText MessageError = "error" - -instance ToText PresenceType where - toText Default = "" - toText Unavailable = "unavailable" - toText Subscribe = "subscribe" - toText Subscribed = "subscribed" - toText Unsubscribe = "unsubscribe" - toText Unsubscribed = "unsubscribed" - toText Probe = "probe" - toText PresenceError = "error" - -instance ToText IQType where - toText Get = "get" - toText Result = "result" - toText Set = "set" - toText IQError = "error" - -instance ToText ShowType where - toText Available = "" - toText Away = "away" - toText FreeChat = "chat" - toText DND = "dnd" - toText XAway = "xa" - - -instance FromText MessageType where - fromText "chat" = Chat - fromText "groupchat" = GroupChat - fromText "headline" = Headline - fromText "normal" = Normal - fromText "error" = MessageError - fromText "" = Chat - fromText _ = error "incorrect message type" - -instance FromText PresenceType where - fromText "" = Default - fromText "available" = Default - fromText "unavailable" = Unavailable - fromText "subscribe" = Subscribe - fromText "subscribed" = Subscribed - fromText "unsubscribe" = Unsubscribe - fromText "unsubscribed" = Unsubscribed - fromText "probe" = Probe - fromText "error" = PresenceError - fromText _ = error "incorrect presence type" - -instance FromText IQType where - fromText "get" = Get - fromText "result" = Result - fromText "set" = Set - fromText "error" = IQError - fromText "" = Get - fromText _ = error "incorrect iq type" - -instance FromText ShowType where - fromText "" = Available - fromText "available" = Available - fromText "away" = Away - fromText "chat" = FreeChat - fromText "dnd" = DND - fromText "xa" = XAway - fromText "invisible" = Available - fromText _ = error "incorrect value" - +instance Show MessageType where + show Chat = "chat" + show GroupChat = "groupchat" + show Headline = "headline" + show Normal = "normal" + show MessageError = "error" + +instance Show PresenceType where + show Default = "" + show Unavailable = "unavailable" + show Subscribe = "subscribe" + show Subscribed = "subscribed" + show Unsubscribe = "unsubscribe" + show Unsubscribed = "unsubscribed" + show Probe = "probe" + show PresenceError = "error" + +instance Show IQType where + show Get = "get" + show Result = "result" + show Set = "set" + show IQError = "error" + +instance Show ShowType where + show Available = "" + show Away = "away" + show FreeChat = "chat" + show DND = "dnd" + show XAway = "xa" + + +instance Read MessageType where + readsPrec _ "chat" = [( Chat ,"")] + readsPrec _ "groupchat" = [( GroupChat ,"")] + readsPrec _ "headline" = [( Headline ,"")] + readsPrec _ "normal" = [( Normal ,"")] + readsPrec _ "error" = [( MessageError ,"")] + readsPrec _ "" = [( Chat ,"")] + readsPrec _ _ = error "incorrect message type" + +instance Read PresenceType where + readsPrec _ "" = [( Default ,"")] + readsPrec _ "available" = [( Default ,"")] + readsPrec _ "unavailable" = [( Unavailable ,"")] + readsPrec _ "subscribe" = [( Subscribe ,"")] + readsPrec _ "subscribed" = [( Subscribed ,"")] + readsPrec _ "unsubscribe" = [( Unsubscribe ,"")] + readsPrec _ "unsubscribed" = [( Unsubscribed ,"")] + readsPrec _ "probe" = [( Probe ,"")] + readsPrec _ "error" = [( PresenceError ,"")] + readsPrec _ _ = error "incorrect presence type" + +instance Read IQType where + readsPrec _ "get" = [( Get ,"")] + readsPrec _ "result" = [( Result ,"")] + readsPrec _ "set" = [( Set ,"")] + readsPrec _ "error" = [( IQError ,"")] + readsPrec _ "" = [( Get ,"")] + readsPrec _ _ = error "incorrect iq type" + +instance Read ShowType where + readsPrec _ "" = [( Available ,"")] + readsPrec _ "available" = [( Available ,"")] + readsPrec _ "away" = [( Away ,"")] + readsPrec _ "chat" = [( FreeChat ,"")] + readsPrec _ "dnd" = [( DND ,"")] + readsPrec _ "xa" = [( XAway ,"")] + readsPrec _ "invisible" = [( Available ,"")] + readsPrec _ _ = error "incorrect value" + + +toText :: Show a => a -> Text +toText = Text.pack . show + +fromText :: Read a => Text -> a +fromText = read . Text.unpack \ No newline at end of file diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs index 5c11a6d..1b1be17 100644 --- a/src/Network/XMPPConduit.hs +++ b/src/Network/XMPPConduit.hs @@ -13,14 +13,15 @@ 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 -> IO ((), XMPPState) -fromHandle handle hostname username password = - xmppFromHandle handle hostname username Nothing $ do +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 @@ -35,7 +36,7 @@ fromHandle handle hostname username password = main = do con <- connectTo "localhost" (PortNumber 5222) hSetBuffering con NoBuffering - (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" + (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" (Just "botr") print $ sHaveTLS st putStrLn "" hGetContents con >>= putStrLn diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs deleted file mode 100644 index 8301c7c..0000000 --- a/src/Text/XML/Stream/Elements.hs +++ /dev/null @@ -1,76 +0,0 @@ -module Text.XML.Stream.Elements where - -import Control.Applicative ((<$>)) -import Control.Monad.Trans.Class - -import Data.Text as T -import Text.XML.Unresolved -import Data.XML.Types - -import Data.Conduit as C -import Data.Conduit.List as CL - -import Text.XML.Stream.Parse - -compressNodes :: [Node] -> [Node] -compressNodes [] = [] -compressNodes [x] = [x] -compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = - compressNodes $ NodeContent (ContentText $ x `T.append` y) : z -compressNodes (x:xs) = x : compressNodes xs - -elementFromEvents :: C.ResourceThrow m => C.Sink Event m Element -elementFromEvents = do - x <- CL.peek - case x of - Just (EventBeginElement n as) -> goE n as - _ -> lift $ C.resourceThrow $ InvalidEventStream $ "not an element: " ++ show x - where - many f = - go id - where - go front = do - x <- f - case x of - Nothing -> return $ front [] - Just y -> go (front . (:) y) - dropReturn x = CL.drop 1 >> return x - goE n as = do - CL.drop 1 - ns <- many goN - y <- CL.head - if y == Just (EventEndElement n) - then return $ Element n as $ compressNodes ns - else lift $ C.resourceThrow $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y - goN = do - x <- CL.peek - case x of - Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE n as - Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i - Just (EventContent c) -> dropReturn $ Just $ NodeContent c - Just (EventComment t) -> dropReturn $ Just $ NodeComment t - Just (EventCDATA t) -> dropReturn $ Just $ NodeContent $ ContentText t - _ -> return Nothing - - -elementToEvents' :: Element -> [Event] -elementToEvents' (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 :) - goN [] = id - goN [x] = goN' x - goN (x:xs) = goN' x . goN xs - goN' (NodeElement e) = goE e - goN' (NodeInstruction i) = (EventInstruction i :) - goN' (NodeContent c) = (EventContent c :) - goN' (NodeComment t) = (EventComment t :) - -elementToEvents e@(Element name _ _) = elementToEvents' e ++ [EventEndElement name] diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 0000000..ed4fd84 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,7 @@ +module Utils where + +whileJust f = do + f' <- f + case f' of + Just x -> x : whileJust f + Nothing -> []