diff --git a/Network/Protocol/XMPP.hs b/Network/Protocol/XMPP.hs --- a/Network/Protocol/XMPP.hs +++ b/Network/Protocol/XMPP.hs @@ -1,4 +1,4 @@ --- Copyright (C) 2010 John Millikin +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,7 +13,6 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . - module Network.Protocol.XMPP ( -- * JIDs @@ -65,9 +64,10 @@ , getSession , runXMPP ) where -import Network.Protocol.XMPP.Client -import Network.Protocol.XMPP.Component -import Network.Protocol.XMPP.Connections -import Network.Protocol.XMPP.JID -import Network.Protocol.XMPP.Monad -import Network.Protocol.XMPP.Stanza + +import Network.Protocol.XMPP.Client +import Network.Protocol.XMPP.Component +import Network.Protocol.XMPP.Connections +import Network.Protocol.XMPP.JID +import Network.Protocol.XMPP.Monad +import Network.Protocol.XMPP.Stanza diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs --- a/Network/Protocol/XMPP/Client.hs +++ b/Network/Protocol/XMPP/Client.hs @@ -1,4 +1,6 @@ --- Copyright (C) 2010 John Millikin +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,17 +15,17 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.Client ( runClient , bindJID ) where -import Control.Monad ((>=>)) -import Control.Monad.Error (throwError) -import Control.Monad.Trans (liftIO) -import Data.ByteString (ByteString) -import qualified Data.Text.Lazy as T -import Network (connectTo) + +import Control.Monad ((>=>)) +import Control.Monad.Error (throwError) +import Control.Monad.Trans (liftIO) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Network (connectTo) import qualified System.IO as IO import qualified Network.Protocol.XMPP.Client.Authentication as A @@ -33,13 +35,13 @@ import qualified Network.Protocol.XMPP.JID as J import qualified Network.Protocol.XMPP.Monad as M import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.ErrorT -import Network.Protocol.XMPP.Stanza +import Network.Protocol.XMPP.ErrorT +import Network.Protocol.XMPP.Stanza runClient :: C.Server -> J.JID -- ^ Client JID - -> T.Text -- ^ Username - -> T.Text -- ^ Password + -> Text -- ^ Username + -> Text -- ^ Password -> M.XMPP a -> IO (Either M.Error a) runClient server jid username password xmpp = do @@ -59,7 +61,7 @@ newStream :: J.JID -> M.XMPP [F.Feature] newStream jid = do - M.putBytes $ C.xmlHeader "jabber:client" jid + M.putBytes (C.xmlHeader "jabber:client" jid) void (M.readEvents C.startOfStream) F.parseFeatures `fmap` M.getElement @@ -70,10 +72,10 @@ M.putElement xmlStartTLS void M.getElement h <- M.getHandle - eitherTLS <- liftIO $ runErrorT $ H.startTLS h + eitherTLS <- liftIO (runErrorT (H.startTLS h)) case eitherTLS of - Left err -> throwError $ M.TransportError err - Right tls -> M.restartXMPP (Just tls) $ newStream sjid >>= m + Left err -> throwError (M.TransportError err) + Right tls -> M.restartXMPP (Just tls) (newStream sjid >>= m) authenticationMechanisms :: [F.Feature] -> [ByteString] authenticationMechanisms = step where @@ -90,11 +92,11 @@ bindJID :: J.JID -> M.XMPP J.JID bindJID jid = do -- Bind - M.putStanza . bindStanza . J.jidResource $ jid + M.putStanza (bindStanza (J.jidResource jid)) bindResult <- M.getStanza let getJID = X.elementChildren - >=> X.isNamed (X.Name "jid" (Just "urn:ietf:params:xml:ns:xmpp-bind") Nothing) + >=> X.isNamed "{urn:ietf:params:xml:ns:xmpp-bind}jid" >=> X.elementNodes >=> X.isContent >=> return . X.contentText @@ -111,28 +113,27 @@ returnedJID <- case maybeJID of Just x -> return x - Nothing -> throwError $ M.InvalidBindResult bindResult + Nothing -> throwError (M.InvalidBindResult bindResult) -- Session M.putStanza sessionStanza void M.getStanza - M.putStanza $ emptyPresence PresenceAvailable + M.putStanza (emptyPresence PresenceAvailable) void M.getStanza return returnedJID bindStanza :: Maybe J.Resource -> IQ bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where - payload = X.nselement "urn:ietf:params:xml:ns:xmpp-bind" "bind" [] requested + payload = X.element "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] requested requested = case fmap J.strResource resource of Nothing -> [] - Just x -> [X.NodeElement $ X.element "resource" [] - [X.NodeContent $ X.ContentText x]] + Just x -> [X.NodeElement (X.element "resource" [] [X.NodeContent (X.ContentText x)])] sessionStanza :: IQ sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where - payload = X.nselement "urn:ietf:params:xml:ns:xmpp-session" "session" [] [] + payload = X.element "{urn:ietf:params:xml:ns:xmpp-session}session" [] [] streamSupportsTLS :: [F.Feature] -> Bool streamSupportsTLS = any isStartTLS where @@ -140,7 +141,7 @@ isStartTLS _ = False xmlStartTLS :: X.Element -xmlStartTLS = X.nselement "urn:ietf:params:xml:ns:xmpp-tls" "starttls" [] [] +xmlStartTLS = X.element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] void :: Monad m => m a -> m () void m = m >> return () diff --git a/Network/Protocol/XMPP/Client/Authentication.hs b/Network/Protocol/XMPP/Client/Authentication.hs --- a/Network/Protocol/XMPP/Client/Authentication.hs +++ b/Network/Protocol/XMPP/Client/Authentication.hs @@ -1,4 +1,7 @@ --- Copyright (C) 2009-2010 John Millikin +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- Copyright (C) 2009-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,50 +16,49 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} module Network.Protocol.XMPP.Client.Authentication ( Result (..) , authenticate ) where + import qualified Control.Exception as Exc -import Control.Monad (when, (>=>)) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad (when, (>=>)) +import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Control.Monad.Error as E -import qualified Data.ByteString.Char8 as B -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Data.Typeable (Typeable) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 +import qualified Data.Text +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (Typeable) import qualified Network.Protocol.SASL.GNU as SASL import qualified Network.Protocol.XMPP.Monad as M import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.JID (JID, formatJID, jidResource) +import Network.Protocol.XMPP.JID (JID, formatJID, jidResource) data Result = Success | Failure deriving (Show, Eq) -data AuthException = XmppError M.Error | SaslError TL.Text +data AuthException = XmppError M.Error | SaslError Text deriving (Typeable, Show) instance Exc.Exception AuthException -authenticate :: [B.ByteString] -- ^ Mechanisms +authenticate :: [ByteString] -- ^ Mechanisms -> JID -- ^ User JID -> JID -- ^ Server JID - -> TL.Text -- ^ Username - -> TL.Text -- ^ Password + -> Text -- ^ Username + -> Text -- ^ Password -> M.XMPP () authenticate xmppMechanisms userJID serverJID username password = xmpp where mechanisms = map SASL.Mechanism xmppMechanisms - authz = formatJID $ userJID { jidResource = Nothing } + authz = formatJID (userJID { jidResource = Nothing }) hostname = formatJID serverJID - utf8 = TE.encodeUtf8 . T.concat . TL.toChunks xmpp = do ctx <- M.getSession - res <- liftIO $ Exc.try $ SASL.runSASL $ do + res <- liftIO . Exc.try . SASL.runSASL $ do suggested <- SASL.clientSuggestMechanism mechanisms case suggested of Nothing -> saslError "No supported authentication mechanism" @@ -65,21 +67,21 @@ Right Success -> return () Right Failure -> E.throwError M.AuthenticationFailure Left (XmppError err) -> E.throwError err - Left (SaslError err) -> E.throwError $ M.AuthenticationError err + Left (SaslError err) -> E.throwError (M.AuthenticationError err) authSasl ctx mechanism = do let (SASL.Mechanism mechBytes) = mechanism sessionResult <- SASL.runClient mechanism $ do - SASL.setProperty SASL.PropertyAuthzID $ utf8 authz - SASL.setProperty SASL.PropertyAuthID $ utf8 username - SASL.setProperty SASL.PropertyPassword $ utf8 password - SASL.setProperty SASL.PropertyService $ B.pack "xmpp" - SASL.setProperty SASL.PropertyHostname $ utf8 hostname + SASL.setProperty SASL.PropertyAuthzID (encodeUtf8 authz) + SASL.setProperty SASL.PropertyAuthID (encodeUtf8 username) + SASL.setProperty SASL.PropertyPassword (encodeUtf8 password) + SASL.setProperty SASL.PropertyService "xmpp" + SASL.setProperty SASL.PropertyHostname (encodeUtf8 hostname) - (b64text, rc) <- SASL.step64 $ B.pack "" - putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "auth" - [("mechanism", TL.pack $ B.unpack mechBytes)] - [X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text] + (b64text, rc) <- SASL.step64 "" + putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" + [("mechanism", Data.Text.pack (Data.ByteString.Char8.unpack mechBytes))] + [X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))] case rc of SASL.Complete -> saslFinish ctx @@ -87,23 +89,23 @@ case sessionResult of Right x -> return x - Left err -> saslError $ TL.pack $ show err + Left err -> saslError (Data.Text.pack (show err)) saslLoop :: M.Session -> SASL.Session Result saslLoop ctx = do elemt <- getElement ctx - let name = X.Name "challenge" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing + let name = "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" let getChallengeText = X.isNamed name >=> X.elementNodes >=> X.isContent >=> return . X.contentText let challengeText = getChallengeText elemt - when (null challengeText) $ saslError "Received empty challenge" + when (null challengeText) (saslError "Received empty challenge") - (b64text, rc) <- SASL.step64 . B.pack . concatMap TL.unpack $ challengeText - putElement ctx $ X.nselement "urn:ietf:params:xml:ns:xmpp-sasl" "response" - [] [X.NodeContent $ X.ContentText $ TL.pack $ B.unpack b64text] + (b64text, rc) <- SASL.step64 (Data.ByteString.Char8.pack (concatMap Data.Text.unpack challengeText)) + putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}response" + [] [X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))] case rc of SASL.Complete -> saslFinish ctx SASL.NeedsMore -> saslLoop ctx @@ -111,23 +113,23 @@ saslFinish :: M.Session -> SASL.Session Result saslFinish ctx = do elemt <- getElement ctx - let name = X.Name "success" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing + let name = "{urn:ietf:params:xml:ns:xmpp-sasl}success" let success = X.isNamed name elemt - return $ if null success then Failure else Success + return (if null success then Failure else Success) putElement :: M.Session -> X.Element -> SASL.Session () putElement ctx elemt = liftIO $ do - res <- M.runXMPP ctx $ M.putElement elemt + res <- M.runXMPP ctx (M.putElement elemt) case res of - Left err -> Exc.throwIO $ XmppError err + Left err -> Exc.throwIO (XmppError err) Right x -> return x getElement :: M.Session -> SASL.Session X.Element getElement ctx = liftIO $ do res <- M.runXMPP ctx M.getElement case res of - Left err -> Exc.throwIO $ XmppError err + Left err -> Exc.throwIO (XmppError err) Right x -> return x -saslError :: MonadIO m => TL.Text -> m a +saslError :: MonadIO m => Text -> m a saslError = liftIO . Exc.throwIO . SaslError diff --git a/Network/Protocol/XMPP/Client/Features.hs b/Network/Protocol/XMPP/Client/Features.hs --- a/Network/Protocol/XMPP/Client/Features.hs +++ b/Network/Protocol/XMPP/Client/Features.hs @@ -1,4 +1,6 @@ --- Copyright (C) 2010 John Millikin +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,20 +15,21 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.Client.Features ( Feature (..) , parseFeatures , parseFeature ) where -import Control.Arrow ((&&&)) -import qualified Data.ByteString.Char8 as B -import qualified Data.Text.Lazy as TL + +import Control.Arrow ((&&&)) +import qualified Data.ByteString.Char8 +import Data.ByteString (ByteString) +import qualified Data.Text import qualified Network.Protocol.XMPP.XML as X data Feature = FeatureStartTLS Bool - | FeatureSASL [B.ByteString] + | FeatureSASL [ByteString] | FeatureRegister | FeatureBind | FeatureSession @@ -59,10 +62,10 @@ >>= X.isNamed nameMechanism >>= X.elementNodes >>= X.isContent - >>= return . B.pack . TL.unpack . X.contentText + >>= return . Data.ByteString.Char8.pack . Data.Text.unpack . X.contentText nameMechanism :: X.Name -nameMechanism = X.Name "mechanism" (Just "urn:ietf:params:xml:ns:xmpp-sasl") Nothing +nameMechanism = "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" nameFeatures :: X.Name -nameFeatures = X.Name "features" (Just "http://etherx.jabber.org/streams") Nothing +nameFeatures = "{http://etherx.jabber.org/streams}features" diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs --- a/Network/Protocol/XMPP/Component.hs +++ b/Network/Protocol/XMPP/Component.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} + -- Copyright (C) 2010 Stephan Maka --- Copyright (C) 2010 John Millikin +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -14,30 +16,31 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.Component ( runComponent ) where -import Control.Monad (when) -import Control.Monad.Error (throwError) -import Data.Bits (shiftR, (.&.)) -import Data.Char (intToDigit) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.Encoding as TE -import Network (connectTo) -import Network.Protocol.SASL.GNU (sha1) + +import Control.Monad (when) +import Control.Monad.Error (throwError) +import Data.Bits (shiftR, (.&.)) +import Data.Char (intToDigit) +import qualified Data.ByteString +import Data.ByteString (ByteString) +import qualified Data.Text +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Network (connectTo) +import Network.Protocol.SASL.GNU (sha1) import qualified System.IO as IO import qualified Network.Protocol.XMPP.Connections as C import qualified Network.Protocol.XMPP.Handle as H import qualified Network.Protocol.XMPP.Monad as M import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.JID (JID) +import Network.Protocol.XMPP.JID (JID) runComponent :: C.Server - -> T.Text -- ^ Server secret + -> Text -- ^ Server secret -> M.XMPP a -> IO (Either M.Error a) runComponent server password xmpp = do @@ -50,7 +53,7 @@ authenticate streamID password xmpp -beginStream :: JID -> M.XMPP T.Text +beginStream :: JID -> M.XMPP Text beginStream jid = do M.putBytes $ C.xmlHeader "jabber:component:accept" jid events <- M.readEvents C.startOfStream @@ -58,30 +61,25 @@ Nothing -> throwError M.NoComponentStreamID Just x -> return x -parseStreamID :: X.SaxEvent -> Maybe T.Text -parseStreamID (X.BeginElement _ attrs) = sid where - sid = case idAttrs of - (x:_) -> Just . X.attributeText $ x - _ -> Nothing - idAttrs = filter (matchingName . X.attributeName) attrs - matchingName = (== X.Name "jid" (Just "jabber:component:accept") Nothing) +parseStreamID :: X.Event -> Maybe Text +parseStreamID (X.EventBeginElement name attrs) = X.attributeText + "{jabber:component:accept}jid" + (X.Element name attrs []) parseStreamID _ = Nothing -authenticate :: T.Text -> T.Text -> M.XMPP () +authenticate :: Text -> Text -> M.XMPP () authenticate streamID password = do let bytes = buildSecret streamID password - let digest = showDigest $ sha1 bytes - M.putElement $ X.element "handshake" [] [X.NodeContent $ X.ContentText digest] + let digest = showDigest (sha1 bytes) + M.putElement (X.element "handshake" [] [X.NodeContent (X.ContentText digest)]) result <- M.getElement - let nameHandshake = X.Name "handshake" (Just "jabber:component:accept") Nothing - when (null (X.isNamed nameHandshake result)) $ - throwError M.AuthenticationFailure + let nameHandshake = "{jabber:component:accept}handshake" + when (null (X.isNamed nameHandshake result)) (throwError M.AuthenticationFailure) -buildSecret :: T.Text -> T.Text -> B.ByteString -buildSecret sid password = B.concat . BL.toChunks $ bytes where - bytes = TE.encodeUtf8 $ X.escape $ T.append sid password +buildSecret :: Text -> Text -> ByteString +buildSecret sid password = encodeUtf8 (X.escape (Data.Text.append sid password)) -showDigest :: B.ByteString -> T.Text -showDigest = T.pack . concatMap wordToHex . B.unpack where - wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF] +showDigest :: ByteString -> Text +showDigest = Data.Text.pack . concatMap wordToHex . Data.ByteString.unpack where + wordToHex x = [hexDig (shiftR x 4), hexDig (x .&. 0xF)] hexDig = intToDigit . fromIntegral diff --git a/Network/Protocol/XMPP/Connections.hs b/Network/Protocol/XMPP/Connections.hs --- a/Network/Protocol/XMPP/Connections.hs +++ b/Network/Protocol/XMPP/Connections.hs @@ -1,4 +1,6 @@ --- Copyright (C) 2010 John Millikin +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,20 +15,21 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.Connections ( Server (..) , xmlHeader , startOfStream , qnameStream ) where -import Network (HostName, PortID) -import qualified Data.ByteString.Lazy as B -import qualified Data.Text.Lazy as T -import Data.Text.Lazy.Encoding (encodeUtf8) +import Network (HostName, PortID) +import Data.ByteString (ByteString) +import qualified Data.Text +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) + import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.JID (JID, formatJID) +import Network.Protocol.XMPP.JID (JID, formatJID) data Server = Server { serverJID :: JID @@ -37,10 +40,10 @@ -- Since only the opening tag should be written, normal XML -- serialization cannot be used. Be careful to escape any embedded -- attributes. -xmlHeader :: T.Text -> JID -> B.ByteString +xmlHeader :: Text -> JID -> ByteString xmlHeader ns jid = encodeUtf8 header where - attr x = T.concat ["\"", X.escape x, "\""] - header = T.concat + attr x = Data.Text.concat ["\"", X.escape x, "\""] + header = Data.Text.concat [ "\n" , "" ] -startOfStream :: Integer -> X.SaxEvent -> Bool +startOfStream :: Integer -> X.Event -> Bool startOfStream depth event = case (depth, event) of - (1, (X.BeginElement elemName _)) -> qnameStream == elemName + (1, (X.EventBeginElement elemName _)) -> qnameStream == elemName _ -> False qnameStream :: X.Name -qnameStream = X.Name "stream" (Just "http://etherx.jabber.org/streams") Nothing +qnameStream = "{http://etherx.jabber.org/streams}stream" diff --git a/Network/Protocol/XMPP/ErrorT.hs b/Network/Protocol/XMPP/ErrorT.hs --- a/Network/Protocol/XMPP/ErrorT.hs +++ b/Network/Protocol/XMPP/ErrorT.hs @@ -1,4 +1,6 @@ --- Copyright (C) 2010 John Millikin +{-# LANGUAGE TypeFamilies #-} + +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,16 +15,15 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE TypeFamilies #-} module Network.Protocol.XMPP.ErrorT ( ErrorT (..) , mapErrorT ) where -import Control.Monad (liftM) -import Control.Monad.Fix (MonadFix, mfix) -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad (liftM) +import Control.Monad.Fix (MonadFix, mfix) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad.Trans.Class (MonadTrans, lift) import qualified Control.Monad.Error as E import qualified Control.Monad.Reader as R @@ -38,8 +39,8 @@ (>>=) m k = ErrorT $ do x <- runErrorT m case x of - Left l -> return $ Left l - Right r -> runErrorT $ k r + Left l -> return (Left l) + Right r -> runErrorT (k r) instance Monad m => E.MonadError (ErrorT e m) where type E.ErrorType (ErrorT e m) = e @@ -47,8 +48,8 @@ catchError m h = ErrorT $ do x <- runErrorT m case x of - Left l -> runErrorT $ h l - Right r -> return $ Right r + Left l -> runErrorT (h l) + Right r -> return (Right r) instance MonadTrans (ErrorT e) where lift = ErrorT . liftM Right @@ -69,4 +70,4 @@ mapErrorT :: (m (Either e a) -> n (Either e' b)) -> ErrorT e m a -> ErrorT e' n b -mapErrorT f m = ErrorT $ f (runErrorT m) +mapErrorT f m = ErrorT (f (runErrorT m)) diff --git a/Network/Protocol/XMPP/Handle.hs b/Network/Protocol/XMPP/Handle.hs --- a/Network/Protocol/XMPP/Handle.hs +++ b/Network/Protocol/XMPP/Handle.hs @@ -1,4 +1,6 @@ --- Copyright (C) 2010 John Millikin +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,7 +15,6 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.Handle ( Handle (..) , startTLS @@ -21,30 +22,33 @@ , hGetBytes ) where -import Control.Monad (when) +import Control.Monad (when) import qualified Control.Monad.Error as E -import Control.Monad.Trans (liftIO) -import qualified Data.ByteString.Lazy as B -import qualified Data.Text.Lazy as T +import Control.Monad.Trans (liftIO) +import qualified Data.ByteString +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy +import qualified Data.Text +import Data.Text (Text) import qualified System.IO as IO import qualified Network.Protocol.TLS.GNU as TLS -import Network.Protocol.XMPP.ErrorT +import Network.Protocol.XMPP.ErrorT data Handle = PlainHandle IO.Handle | SecureHandle IO.Handle TLS.Session -liftTLS :: TLS.Session -> TLS.TLS a -> ErrorT T.Text IO a +liftTLS :: TLS.Session -> TLS.TLS a -> ErrorT Text IO a liftTLS s = liftTLS' . TLS.runTLS s -liftTLS' :: IO (Either TLS.Error a) -> ErrorT T.Text IO a +liftTLS' :: IO (Either TLS.Error a) -> ErrorT Text IO a liftTLS' io = do eitherX <- liftIO io case eitherX of - Left err -> E.throwError $ T.pack $ show err + Left err -> E.throwError (Data.Text.pack (show err)) Right x -> return x -startTLS :: Handle -> ErrorT T.Text IO Handle +startTLS :: Handle -> ErrorT Text IO Handle startTLS (SecureHandle _ _) = E.throwError "Can't start TLS on a secure handle" startTLS (PlainHandle h) = liftTLS' $ TLS.runClient (TLS.handleTransport h) $ do TLS.setPriority [TLS.X509] @@ -52,14 +56,16 @@ TLS.handshake SecureHandle h `fmap` TLS.getSession -hPutBytes :: Handle -> B.ByteString -> ErrorT T.Text IO () -hPutBytes (PlainHandle h) = liftIO . B.hPut h -hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes +hPutBytes :: Handle -> ByteString -> ErrorT Text IO () +hPutBytes (PlainHandle h) = liftIO . Data.ByteString.hPut h +hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes . toLazy where + toLazy bytes = Data.ByteString.Lazy.fromChunks [bytes] -hGetBytes :: Handle -> Integer -> ErrorT T.Text IO B.ByteString -hGetBytes (PlainHandle h) n = liftIO $ B.hGet h $ fromInteger n +hGetBytes :: Handle -> Integer -> ErrorT Text IO ByteString +hGetBytes (PlainHandle h) n = liftIO (Data.ByteString.hGet h (fromInteger n)) hGetBytes (SecureHandle h s) n = liftTLS s $ do pending <- TLS.checkPending let wait = IO.hWaitForInput h (- 1) >> return () when (pending == 0) (liftIO wait) - TLS.getBytes n + lazy <- TLS.getBytes n + return (Data.ByteString.concat (Data.ByteString.Lazy.toChunks lazy)) diff --git a/Network/Protocol/XMPP/JID.hs b/Network/Protocol/XMPP/JID.hs --- a/Network/Protocol/XMPP/JID.hs +++ b/Network/Protocol/XMPP/JID.hs @@ -1,4 +1,7 @@ --- Copyright (C) 2010 John Millikin +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,8 +16,6 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} module Network.Protocol.XMPP.JID ( JID (..) , Node (..) @@ -25,10 +26,11 @@ , parseJID_ , formatJID ) where -import qualified Data.Text.Lazy as TL -import Data.Text.Lazy (Text) + +import qualified Data.Text +import Data.Text (Text) import qualified Data.Text.IDN.StringPrep as SP -import Data.String (IsString, fromString) +import Data.String (IsString, fromString) newtype Node = Node { strNode :: Text } newtype Domain = Domain { strDomain :: Text } @@ -72,25 +74,27 @@ parseJID :: Text -> Maybe JID parseJID str = maybeJID where (node, postNode) = case textSpanBy (/= '@') str of - (x, y) -> if TL.null y + (x, y) -> if Data.Text.null y then ("", x) - else (x, TL.drop 1 y) + else (x, Data.Text.drop 1 y) (domain, resource) = case textSpanBy (/= '/') postNode of - (x, y) -> if TL.null y + (x, y) -> if Data.Text.null y then (x, "") - else (x, TL.drop 1 y) - nullable x f = if TL.null x then Just Nothing else fmap Just $ f x + else (x, Data.Text.drop 1 y) + nullable x f = if Data.Text.null x + then Just Nothing + else fmap Just (f x) maybeJID = do - preppedNode <- nullable node $ stringprepM SP.xmppNode + preppedNode <- nullable node (stringprepM SP.xmppNode) preppedDomain <- stringprepM SP.nameprep domain - preppedResource <- nullable resource $ stringprepM SP.xmppResource + preppedResource <- nullable resource (stringprepM SP.xmppResource) return $ JID (fmap Node preppedNode) (Domain preppedDomain) (fmap Resource preppedResource) - stringprepM p x = case SP.stringprep p SP.defaultFlags (TL.toStrict x) of + stringprepM p x = case SP.stringprep p SP.defaultFlags x of Left _ -> Nothing - Right y -> Just (TL.fromStrict y) + Right y -> Just y parseJID_ :: Text -> JID parseJID_ text = case parseJID text of @@ -99,9 +103,9 @@ formatJID :: JID -> Text formatJID (JID node (Domain domain) resource) = formatted where - formatted = TL.concat [node', domain, resource'] - node' = maybe "" (\(Node x) -> TL.append x "@") node - resource' = maybe "" (\(Resource x) -> TL.append "/" x) resource + formatted = Data.Text.concat [node', domain, resource'] + node' = maybe "" (\(Node x) -> Data.Text.append x "@") node + resource' = maybe "" (\(Resource x) -> Data.Text.append "/" x) resource -- Similar to 'comparing' equaling :: Eq a => (b -> a) -> b -> b -> Bool @@ -110,7 +114,7 @@ -- multi-version 'text' compatibility textSpanBy :: (Char -> Bool) -> Text -> (Text, Text) #if MIN_VERSION_text(0,11,0) -textSpanBy = TL.span +textSpanBy = Data.Text.span #else -textSpanBy = TL.spanBy +textSpanBy = Data.Text.spanBy #endif diff --git a/Network/Protocol/XMPP/Monad.hs b/Network/Protocol/XMPP/Monad.hs --- a/Network/Protocol/XMPP/Monad.hs +++ b/Network/Protocol/XMPP/Monad.hs @@ -1,4 +1,7 @@ --- Copyright (C) 2010 John Millikin +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,8 +16,6 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.Monad ( XMPP (..) , Error (..) @@ -34,18 +35,20 @@ , putElement , putStanza ) where + import qualified Control.Applicative as A import qualified Control.Concurrent.MVar as M -import Control.Monad (ap) -import Control.Monad.Fix (MonadFix, mfix) -import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad (ap) +import Control.Monad.Fix (MonadFix, mfix) +import Control.Monad.Trans (MonadIO, liftIO) import qualified Control.Monad.Error as E import qualified Control.Monad.Reader as R -import qualified Data.ByteString.Lazy.Char8 as B -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.ByteString +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) -import Network.Protocol.XMPP.ErrorT +import Network.Protocol.XMPP.ErrorT import qualified Network.Protocol.XMPP.Handle as H import qualified Network.Protocol.XMPP.Stanza as S import qualified Network.Protocol.XMPP.XML as X @@ -87,7 +90,7 @@ instance Monad XMPP where return = XMPP . return - m >>= f = XMPP $ unXMPP m >>= unXMPP . f + m >>= f = XMPP (unXMPP m >>= unXMPP . f) instance MonadIO XMPP where liftIO = XMPP . liftIO @@ -95,14 +98,14 @@ instance E.MonadError XMPP where type E.ErrorType XMPP = Error throwError = XMPP . E.throwError - catchError m h = XMPP $ E.catchError (unXMPP m) (unXMPP . h) + catchError m h = XMPP (E.catchError (unXMPP m) (unXMPP . h)) instance A.Applicative XMPP where pure = return (<*>) = ap instance MonadFix XMPP where - mfix f = XMPP $ mfix $ unXMPP . f + mfix f = XMPP (mfix (unXMPP . f)) runXMPP :: Session -> XMPP a -> IO (Either Error a) runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s @@ -117,15 +120,15 @@ restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a restartXMPP newH xmpp = do Session oldH ns _ readLock writeLock <- getSession - sax <- liftIO $ X.newParser + sax <- liftIO X.newParser let s = Session (maybe oldH id newH) ns sax readLock writeLock - XMPP $ R.local (const s) (unXMPP xmpp) + XMPP (R.local (const s) (unXMPP xmpp)) withLock :: (Session -> M.MVar ()) -> XMPP a -> XMPP a withLock getLock xmpp = do s <- getSession let mvar = getLock s - res <- liftIO $ M.withMVar mvar $ \_ -> runXMPP s xmpp + res <- liftIO (M.withMVar mvar (\_ -> runXMPP s xmpp)) case res of Left err -> E.throwError err Right x -> return x @@ -138,15 +141,15 @@ liftTLS :: ErrorT Text IO a -> XMPP a liftTLS io = do - res <- liftIO $ runErrorT io + res <- liftIO (runErrorT io) case res of - Left err -> E.throwError $ TransportError err + Left err -> E.throwError (TransportError err) Right x -> return x -putBytes :: B.ByteString -> XMPP () +putBytes :: ByteString -> XMPP () putBytes bytes = do h <- getHandle - liftTLS $ H.hPutBytes h bytes + liftTLS (H.hPutBytes h bytes) putElement :: X.Element -> XMPP () putElement = putBytes . encodeUtf8 . X.serialiseElement @@ -154,17 +157,17 @@ putStanza :: S.Stanza a => a -> XMPP () putStanza = withLock sessionWriteLock . putElement . S.stanzaToElement -readEvents :: (Integer -> X.SaxEvent -> Bool) -> XMPP [X.SaxEvent] +readEvents :: (Integer -> X.Event -> Bool) -> XMPP [X.Event] readEvents done = xmpp where xmpp = do Session h _ p _ _ <- getSession let nextEvents = do -- TODO: read in larger increments - bytes <- liftTLS $ H.hGetBytes h 1 - let eof = B.length bytes == 0 - parsed <- liftIO $ X.parse p bytes eof + bytes <- liftTLS (H.hGetBytes h 1) + let eof = Data.ByteString.null bytes + parsed <- liftIO (X.parse p bytes eof) case parsed of - Left err -> E.throwError $ TransportError err + Left err -> E.throwError (TransportError err) Right events -> return events X.readEvents done nextEvents @@ -174,9 +177,9 @@ events <- readEvents endOfTree case X.eventsToElement events of Just x -> return x - Nothing -> E.throwError $ TransportError "getElement: invalid event list" + Nothing -> E.throwError (TransportError "getElement: invalid event list") - endOfTree 0 (X.EndElement _) = True + endOfTree 0 (X.EventEndElement _) = True endOfTree _ _ = False getStanza :: XMPP S.ReceivedStanza @@ -185,4 +188,4 @@ Session _ ns _ _ _ <- getSession case S.elementToStanza ns elemt of Just x -> return x - Nothing -> E.throwError $ InvalidStanza elemt + Nothing -> E.throwError (InvalidStanza elemt) diff --git a/Network/Protocol/XMPP/Stanza.hs b/Network/Protocol/XMPP/Stanza.hs --- a/Network/Protocol/XMPP/Stanza.hs +++ b/Network/Protocol/XMPP/Stanza.hs @@ -1,4 +1,6 @@ --- Copyright (C) 2010 John Millikin +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,7 +15,6 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.Stanza ( Stanza (..) @@ -32,16 +33,17 @@ , elementToStanza ) where -import Control.Monad (when) -import qualified Data.Text.Lazy as T +import Control.Monad (when) +import qualified Data.Text +import Data.Text (Text) import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.JID (JID, parseJID, formatJID) +import Network.Protocol.XMPP.JID (JID, parseJID, formatJID) class Stanza a where stanzaTo :: a -> Maybe JID stanzaFrom :: a -> Maybe JID - stanzaID :: a -> Maybe T.Text - stanzaLang :: a -> Maybe T.Text + stanzaID :: a -> Maybe Text + stanzaLang :: a -> Maybe Text stanzaPayloads :: a -> [X.Element] stanzaToElement :: a -> X.Element @@ -55,8 +57,8 @@ { messageType :: MessageType , messageTo :: Maybe JID , messageFrom :: Maybe JID - , messageID :: Maybe T.Text - , messageLang :: Maybe T.Text + , messageID :: Maybe Text + , messageLang :: Maybe Text , messagePayloads :: [X.Element] } deriving (Show) @@ -97,8 +99,8 @@ { presenceType :: PresenceType , presenceTo :: Maybe JID , presenceFrom :: Maybe JID - , presenceID :: Maybe T.Text - , presenceLang :: Maybe T.Text + , presenceID :: Maybe Text + , presenceLang :: Maybe Text , presencePayloads :: [X.Element] } deriving (Show) @@ -145,8 +147,8 @@ { iqType :: IQType , iqTo :: Maybe JID , iqFrom :: Maybe JID - , iqID :: Maybe T.Text - , iqLang :: Maybe T.Text + , iqID :: Maybe Text + , iqLang :: Maybe Text , iqPayload :: Maybe X.Element } deriving (Show) @@ -183,26 +185,26 @@ , iqPayload = Nothing } -stanzaToElement' :: Stanza a => a -> T.Text -> T.Text -> X.Element +stanzaToElement' :: Stanza a => a -> X.Name -> Text -> X.Element stanzaToElement' stanza name typeStr = X.element name attrs payloads where - payloads = map X.NodeElement $ stanzaPayloads stanza + payloads = map X.NodeElement (stanzaPayloads stanza) attrs = concat - [ mattr "to" $ fmap formatJID . stanzaTo - , mattr "from" $ fmap formatJID . stanzaFrom + [ mattr "to" (fmap formatJID . stanzaTo) + , mattr "from" (fmap formatJID . stanzaFrom) , mattr "id" stanzaID , mattr "xml:lang" stanzaLang - , if T.null typeStr then [] else [("type", typeStr)] + , if Data.Text.null typeStr then [] else [("type", typeStr)] ] mattr label f = case f stanza of Nothing -> [] Just text -> [(label, text)] -elementToStanza :: T.Text -> X.Element -> Maybe ReceivedStanza +elementToStanza :: Text -> X.Element -> Maybe ReceivedStanza elementToStanza ns elemt = do - let elemNS = X.nameNamespace . X.elementName $ elemt + let elemNS = X.nameNamespace (X.elementName elemt) when (elemNS /= Just ns) Nothing - let elemName = X.nameLocalName . X.elementName $ elemt + let elemName = X.nameLocalName (X.elementName elemt) case elemName of "message" -> ReceivedMessage `fmap` parseMessage elemt "presence" -> ReceivedPresence `fmap` parsePresence elemt @@ -211,7 +213,7 @@ parseMessage :: X.Element -> Maybe Message parseMessage elemt = do - typeStr <- X.getattr (X.name "type") elemt + typeStr <- X.attributeText "type" elemt msgType <- case typeStr of "normal" -> Just MessageNormal "chat" -> Just MessageChat @@ -221,14 +223,14 @@ _ -> Nothing msgTo <- xmlJID "to" elemt msgFrom <- xmlJID "from" elemt - let msgID = X.getattr (X.name "id") elemt - let msgLang = X.getattr (X.name "lang") elemt + let msgID = X.attributeText "id" elemt + let msgLang = X.attributeText "lang" elemt let payloads = X.elementChildren elemt - return $ Message msgType msgTo msgFrom msgID msgLang payloads + return (Message msgType msgTo msgFrom msgID msgLang payloads) parsePresence :: X.Element -> Maybe Presence parsePresence elemt = do - let typeStr = maybe "" id $ X.getattr (X.name "type") elemt + let typeStr = maybe "" id (X.attributeText "type" elemt) pType <- case typeStr of "" -> Just PresenceAvailable "unavailable" -> Just PresenceUnavailable @@ -242,14 +244,14 @@ msgTo <- xmlJID "to" elemt msgFrom <- xmlJID "from" elemt - let msgID = X.getattr (X.name "id") elemt - let msgLang = X.getattr (X.name "lang") elemt + let msgID = X.attributeText "id" elemt + let msgLang = X.attributeText "lang" elemt let payloads = X.elementChildren elemt - return $ Presence pType msgTo msgFrom msgID msgLang payloads + return (Presence pType msgTo msgFrom msgID msgLang payloads) parseIQ :: X.Element -> Maybe IQ parseIQ elemt = do - typeStr <- X.getattr (X.name "type") elemt + typeStr <- X.attributeText "type" elemt iqType <- case typeStr of "get" -> Just IQGet "set" -> Just IQSet @@ -259,15 +261,15 @@ msgTo <- xmlJID "to" elemt msgFrom <- xmlJID "from" elemt - let msgID = X.getattr (X.name "id") elemt - let msgLang = X.getattr (X.name "lang") elemt + let msgID = X.attributeText "id" elemt + let msgLang = X.attributeText "lang" elemt let payload = case X.elementChildren elemt of [] -> Nothing child:_ -> Just child - return $ IQ iqType msgTo msgFrom msgID msgLang payload + return (IQ iqType msgTo msgFrom msgID msgLang payload) -xmlJID :: T.Text -> X.Element -> Maybe (Maybe JID) -xmlJID name elemt = case X.getattr (X.name name) elemt of +xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID) +xmlJID name elemt = case X.attributeText name elemt of Nothing -> Just Nothing Just raw -> case parseJID raw of Just jid -> Just (Just jid) diff --git a/Network/Protocol/XMPP/XML.hs b/Network/Protocol/XMPP/XML.hs --- a/Network/Protocol/XMPP/XML.hs +++ b/Network/Protocol/XMPP/XML.hs @@ -1,4 +1,6 @@ --- Copyright (C) 2010 John Millikin +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by @@ -13,96 +15,73 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE OverloadedStrings #-} module Network.Protocol.XMPP.XML ( module Data.XML.Types -- * Constructors - , name - , nsname , element - , nselement -- * Misc - , getattr , contentText - , attributeText , escape , serialiseElement , readEvents -- * libxml-sax-0.4 API imitation , Parser - , SaxEvent (..) , newParser , parse , eventsToElement ) where -import Control.Monad (when) -import qualified Data.ByteString.Lazy as B -import qualified Data.Text.Lazy as T -import Data.XML.Types -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import qualified Text.XML.LibXML.SAX as SAX -getattr :: Name -> Element -> Maybe T.Text -getattr n e = case elementAttributes e >>= isNamed n of - [] -> Nothing - attr:_ -> Just $ attributeText attr +import Control.Monad (when) +import Data.ByteString (ByteString) +import qualified Data.Text +import Data.Text (Text) +import Data.XML.Types +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Text.XML.LibXML.SAX as SAX -contentText :: Content -> T.Text +contentText :: Content -> Text contentText (ContentText t) = t -contentText (ContentEntity e) = T.concat ["&", e, ";"] - -attributeText :: Attribute -> T.Text -attributeText = T.concat . map contentText . attributeContent - -name :: T.Text -> Name -name t = Name t Nothing Nothing - -nsname :: T.Text -> T.Text -> Name -nsname ns n = Name n (Just ns) Nothing +contentText (ContentEntity e) = Data.Text.concat ["&", e, ";"] -escape :: T.Text -> T.Text -escape = T.concatMap escapeChar where +escape :: Text -> Text +escape = Data.Text.concatMap escapeChar where escapeChar c = case c of '&' -> "&" '<' -> "<" '>' -> ">" '"' -> """ '\'' -> "'" - _ -> T.singleton c + _ -> Data.Text.singleton c -escapeContent :: Content -> T.Text +escapeContent :: Content -> Text escapeContent (ContentText t) = escape t -escapeContent (ContentEntity e) = T.concat ["&", escape e, ";"] - -element :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Element -element elemName attrs children = Element (name elemName) attrs' children where - attrs' = map (uncurry mkattr) attrs +escapeContent (ContentEntity e) = Data.Text.concat ["&", escape e, ";"] -nselement :: T.Text -> T.Text -> [(T.Text, T.Text)] -> [Node] -> Element -nselement ns ln attrs children = Element (nsname ns ln) attrs' children where +element :: Name -> [(Name, Text)] -> [Node] -> Element +element name attrs children = Element name attrs' children where attrs' = map (uncurry mkattr) attrs -mkattr :: T.Text -> T.Text -> Attribute -mkattr n val = Attribute (name n) [ContentText val] +mkattr :: Name -> Text -> (Name, [Content]) +mkattr n val = (n, [ContentText val]) -- A somewhat primitive serialisation function -- -- TODO: better namespace / prefix handling -serialiseElement :: Element -> T.Text +serialiseElement :: Element -> Text serialiseElement e = text where - text = T.concat ["<", eName, " ", attrs, ">", contents, ""] - eName = formatName $ elementName e + text = Data.Text.concat ["<", eName, " ", attrs, ">", contents, ""] + eName = formatName (elementName e) formatName = escape . nameLocalName - attrs = T.intercalate " " $ map attr $ elementAttributes e ++ nsattr - attr (Attribute n c) = T.concat $ [formatName n, "=\""] ++ map escapeContent c ++ ["\""] + attrs = Data.Text.intercalate " " (map attr (elementAttributes e ++ nsattr)) + attr (n, c) = Data.Text.concat ([formatName n, "=\""] ++ map escapeContent c ++ ["\""]) nsattr = case nameNamespace $ elementName e of Nothing -> [] Just ns -> [mkattr "xmlns" ns] - contents = T.concat $ map serialiseNode $ elementNodes e + contents = Data.Text.concat (map serialiseNode (elementNodes e)) serialiseNode (NodeElement e') = serialiseElement e' serialiseNode (NodeContent c) = escape (contentText c) @@ -111,14 +90,12 @@ -- quick-and-dirty imitation of libxml-sax-0.4 API; later, this should -- probably be rewritten to use ST and discard the list parsing -data Parser = Parser (SAX.Parser IO) (IORef (Either T.Text [SaxEvent])) +data Parser = Parser (SAX.Parser IO) (IORef (Either Text [Event])) newParser :: IO Parser newParser = do - let toLazy t = T.fromChunks [t] - ref <- newIORef (Right []) - p <- SAX.newParserIO (\err -> writeIORef ref (Left $ toLazy err)) Nothing + p <- SAX.newParserIO Nothing let addEvent e = do x <- readIORef ref @@ -127,35 +104,29 @@ Right es -> writeIORef ref (Right (e:es)) return True - SAX.setCallback p SAX.parsedBeginElement (\name' attrs -> addEvent $ BeginElement name' attrs) - SAX.setCallback p SAX.parsedEndElement (\name' -> addEvent $ EndElement name') - SAX.setCallback p SAX.parsedCharacters (\txt -> addEvent $ Characters $ toLazy txt) - SAX.setCallback p SAX.parsedComment (\txt -> addEvent $ Comment $ toLazy txt) - SAX.setCallback p SAX.parsedInstruction (\i -> addEvent $ ProcessingInstruction i) + SAX.setCallback p SAX.parsedBeginElement (\name attrs -> addEvent (EventBeginElement name attrs)) + SAX.setCallback p SAX.parsedEndElement (addEvent . EventEndElement) + SAX.setCallback p SAX.parsedCharacters (addEvent . EventContent . ContentText) + SAX.setCallback p SAX.parsedComment (addEvent . EventComment) + SAX.setCallback p SAX.parsedInstruction (addEvent . EventInstruction) + SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left err) >> return False) - return $ Parser p ref + return (Parser p ref) -parse :: Parser -> B.ByteString -> Bool -> IO (Either T.Text [SaxEvent]) +parse :: Parser -> ByteString -> Bool -> IO (Either Text [Event]) parse (Parser p ref) bytes finish = do writeIORef ref (Right []) - SAX.parseLazyBytes p bytes - when finish $ SAX.parseComplete p + SAX.parseBytes p bytes + when finish (SAX.parseComplete p) eitherEvents <- readIORef ref return $ case eitherEvents of Left err -> Left err - Right events -> Right $ reverse events - -data SaxEvent - = BeginElement Name [Attribute] - | EndElement Name - | Characters T.Text - | Comment T.Text - | ProcessingInstruction Instruction + Right events -> Right (reverse events) readEvents :: Monad m - => (Integer -> SaxEvent -> Bool) - -> m [SaxEvent] - -> m [SaxEvent] + => (Integer -> Event -> Bool) + -> m [Event] + -> m [Event] readEvents done nextEvents = readEvents' 0 [] where readEvents' depth acc = do events <- nextEvents @@ -167,28 +138,28 @@ step [] depth acc = (False, depth, acc) step (e:es) depth acc = let depth' = depth + case e of - (BeginElement _ _) -> 1 - (EndElement _) -> (- 1) + (EventBeginElement _ _) -> 1 + (EventEndElement _) -> (- 1) _ -> 0 acc' = e : acc in if done depth' e then (True, depth', reverse acc') else step es depth' acc' --- | Convert a list of events to a single 'X.Element'. If the events do not +-- | Convert a list of events to a single 'Element'. If the events do not -- contain at least one valid element, 'Nothing' will be returned instead. -eventsToElement :: [SaxEvent] -> Maybe Element +eventsToElement :: [Event] -> Maybe Element eventsToElement es = case eventsToNodes es >>= isElement of (e:_) -> Just e _ -> Nothing -eventsToNodes :: [SaxEvent] -> [Node] +eventsToNodes :: [Event] -> [Node] eventsToNodes = concatMap blockToNodes . splitBlocks -- Split event list into a sequence of "blocks", which are the events including -- and between a pair of tags. and are both -- single blocks. -splitBlocks :: [SaxEvent] -> [[SaxEvent]] +splitBlocks :: [Event] -> [[Event]] splitBlocks es = ret where (_, _, ret) = foldl splitBlocks' (0, [], []) es @@ -199,17 +170,17 @@ accum' = accum ++ [e] depth' :: Integer depth' = depth + case e of - (BeginElement _ _) -> 1 - (EndElement _) -> (- 1) + (EventBeginElement _ _) -> 1 + (EventEndElement _) -> (- 1) _ -> 0 -blockToNodes :: [SaxEvent] -> [Node] +blockToNodes :: [Event] -> [Node] blockToNodes [] = [] blockToNodes (begin:rest) = nodes where end = last rest nodes = case (begin, end) of - (BeginElement name' attrs, EndElement _) -> [node name' attrs] - (Characters t, _) -> [NodeContent (ContentText t)] + (EventBeginElement name attrs, EventEndElement _) -> [node name attrs] + (EventContent c, _) -> [NodeContent c] _ -> [] - node n as = NodeElement $ Element n as $ eventsToNodes $ init rest + node n as = NodeElement (Element n as (eventsToNodes (init rest))) diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal --- a/network-protocol-xmpp.cabal +++ b/network-protocol-xmpp.cabal @@ -1,5 +1,5 @@ name: network-protocol-xmpp -version: 0.3.3 +version: 0.4 synopsis: Client->Server XMPP license: GPL-3 license-file: License.txt @@ -31,8 +31,8 @@ , network >= 2.2 && < 2.4 , transformers >= 0.2 && < 0.3 , monads-tf >= 0.1 && < 0.2 - , libxml-sax >= 0.6 && < 0.7 - , xml-types >= 0.1 && < 0.2 + , libxml-sax >= 0.7 && < 0.8 + , xml-types >= 0.3 && < 0.4 exposed-modules: Network.Protocol.XMPP