Use strict text and bytestrings for everything.
10 files changed, 142 insertions(+), 166 deletions(-) M Network/Protocol/XMPP/Client.hs M Network/Protocol/XMPP/Client/Authentication.hs M Network/Protocol/XMPP/Client/Features.hs M Network/Protocol/XMPP/Component.hs M Network/Protocol/XMPP/Connections.hs M Network/Protocol/XMPP/Handle.hs M Network/Protocol/XMPP/JID.hs M Network/Protocol/XMPP/Monad.hs M Network/Protocol/XMPP/Stanza.hs M Network/Protocol/XMPP/XML.hs
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +4 -4
@@ 24,7 24,7 @@ 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 Data.Text (Text) import Network (connectTo) import qualified System.IO as IO @@ 40,8 40,8 @@ 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 130,7 130,7 @@ bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where requested = case fmap J.strResource resource of Nothing -> [] Just x -> [X.NodeElement $ X.element "resource" [] [X.NodeContent $ X.ContentText (T.toStrict x)]] [X.NodeContent $ X.ContentText x]] sessionStanza :: IQ sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where
M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +16 -17
@@ 26,9 26,9 @@ 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 qualified Data.Text import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Typeable (Typeable) import qualified Network.Protocol.SASL.GNU as SASL @@ 39,7 39,7 @@ 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 47,14 47,13 @@ instance Exc.Exception AuthException authenticate :: [B.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 } hostname = formatJID serverJID utf8 = TE.encodeUtf8 . T.concat . TL.toChunks xmpp = do @@ ctx <- M.getSession 72,16 71,16 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where 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.PropertyAuthzID $ encodeUtf8 authz SASL.setProperty SASL.PropertyAuthID $ encodeUtf8 username SASL.setProperty SASL.PropertyPassword $ encodeUtf8 password SASL.setProperty SASL.PropertyService $ B.pack "xmpp" SASL.setProperty SASL.PropertyHostname $ utf8 hostname SASL.setProperty SASL.PropertyHostname $ encodeUtf8 hostname (b64text, rc) <- SASL.step64 $ B.pack "" putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" [("mechanism", TL.pack $ B.unpack mechBytes)] [X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text] [("mechanism", Data.Text.pack $ B.unpack mechBytes)] [X.NodeContent $ X.ContentText $ Data.Text.pack $ B.unpack b64text] case rc of @@ SASL.Complete -> saslFinish ctx 89,7 88,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where 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 103,9 102,9 @@ saslLoop ctx = do let challengeText = getChallengeText elemt when (null challengeText) $ saslError "Received empty challenge" (b64text, rc) <- SASL.step64 . B.pack . concatMap TL.unpack $ challengeText (b64text, rc) <- SASL.step64 . B.pack . concatMap Data.Text.unpack $ challengeText putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] [X.NodeContent $ X.ContentText $ T.pack $ B.unpack b64text] [] [X.NodeContent $ X.ContentText $ Data.Text.pack $ B.unpack b64text] case rc of SASL.Complete -> saslFinish ctx @@ SASL.NeedsMore -> saslLoop ctx 131,5 130,5 @@ getElement ctx = liftIO $ do 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
M Network/Protocol/XMPP/Client/Features.hs => Network/Protocol/XMPP/Client/Features.hs +5 -4
@@ 22,13 22,14 @@ module Network.Protocol.XMPP.Client.Features ) where import Control.Arrow ((&&&)) import qualified Data.ByteString.Char8 as B import qualified Data.Text.Lazy as TL 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 61,7 62,7 @@ parseFeatureSASL e = FeatureSASL $ >>= 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 = "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism"
M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +15 -19
@@ 24,11 24,11 @@ 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.ByteString import Data.ByteString (ByteString) import qualified Data.Text import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as TE import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Network (connectTo) import Network.Protocol.SASL.GNU (sha1) @@ import qualified System.IO as IO 40,7 40,7 @@ import qualified Network.Protocol.XMPP.XML as X 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 53,7 53,7 @@ runComponent server password xmpp = do 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 61,16 61,13 @@ beginStream jid = do 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 = (== "{jabber:component:accept}jid") parseStreamID :: X.SaxEvent -> Maybe Text parseStreamID (X.BeginElement 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 80,11 77,10 @@ authenticate streamID password = do 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 -> Data.Text.Text showDigest = Data.Text.pack . concatMap wordToHex . B.unpack where 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
M Network/Protocol/XMPP/Connections.hs => Network/Protocol/XMPP/Connections.hs +7 -6
@@ 23,9 23,10 @@ module Network.Protocol.XMPP.Connections ) 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 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) 39,10 40,10 @@ data Server = Server -- 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 [ "<?xml version='1.0'?>\n" , "<stream:stream xmlns=" , attr ns , " to=", attr (formatJID jid)
M Network/Protocol/XMPP/Handle.hs => Network/Protocol/XMPP/Handle.hs +17 -12
@@ 25,8 25,11 @@ module Network.Protocol.XMPP.Handle 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 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 35,17 38,17 @@ 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] 53,14 56,16 @@ startTLS (PlainHandle h) = liftTLS' $ TLS.runClient (TLS.handleTransport h) $ do 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))
M Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +14 -14
@@ 27,8 27,8 @@ module Network.Protocol.XMPP.JID , 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) @@ 74,14 74,14 @@ instance IsString JID where 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 @@ preppedDomain <- stringprepM SP.nameprep domain 90,9 90,9 @@ parseJID str = maybeJID where (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 101,9 101,9 @@ parseJID_ text = case parseJID text of 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 112,7 112,7 @@ equaling f x y = f x == f y -- 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
M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +6 -5
@@ 43,9 43,10 @@ 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 qualified Network.Protocol.XMPP.Handle as H 145,7 146,7 @@ liftTLS io = do 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 163,7 164,7 @@ readEvents done = xmpp where let nextEvents = do -- TODO: read in larger increments bytes <- liftTLS $ H.hGetBytes h 1 let eof = B.length bytes == 0 let eof = Data.ByteString.length bytes == 0 parsed <- liftIO $ X.parse p bytes eof case parsed of Left err -> E.throwError $ TransportError err
M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +23 -22
@@ 34,15 34,16 @@ module Network.Protocol.XMPP.Stanza ) where import Control.Monad (when) import qualified Data.Text.Lazy as T import qualified Data.Text import Data.Text (Text) import qualified Network.Protocol.XMPP.XML as X 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 @@ 56,8 57,8 @@ data Message = Message { 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) 98,8 99,8 @@ data Presence = Presence { 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) 146,8 147,8 @@ data IQ = IQ { 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) 184,7 185,7 @@ emptyIQ t = IQ , iqPayload = Nothing } stanzaToElement' :: Stanza a => a -> X.Name -> 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 @@ attrs = concat 192,13 193,13 @@ stanzaToElement' stanza name typeStr = X.element name attrs payloads where , 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 @@ when (elemNS /= Just ns) Nothing 212,7 213,7 @@ elementToStanza ns elemt = do parseMessage :: X.Element -> Maybe Message parseMessage elemt = do typeStr <- X.getattr "type" elemt typeStr <- X.attributeText "type" elemt msgType <- case typeStr of "normal" -> Just MessageNormal @@ "chat" -> Just MessageChat 222,14 223,14 @@ parseMessage elemt = do _ -> Nothing msgTo <- xmlJID "to" elemt msgFrom <- xmlJID "from" elemt let msgID = X.getattr "id" elemt let msgLang = X.getattr "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 parsePresence :: X.Element -> Maybe Presence parsePresence elemt = do let typeStr = maybe "" id $ X.getattr "type" elemt let typeStr = maybe "" id $ X.attributeText "type" elemt pType <- case typeStr of "" -> Just PresenceAvailable @@ "unavailable" -> Just PresenceUnavailable 243,14 244,14 @@ parsePresence elemt = do msgTo <- xmlJID "to" elemt msgFrom <- xmlJID "from" elemt let msgID = X.getattr "id" elemt let msgLang = X.getattr "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 parseIQ :: X.Element -> Maybe IQ parseIQ elemt = do typeStr <- X.getattr "type" elemt typeStr <- X.attributeText "type" elemt iqType <- case typeStr of "get" -> Just IQGet @@ "set" -> Just IQSet 260,15 261,15 @@ parseIQ elemt = do msgTo <- xmlJID "to" elemt msgFrom <- xmlJID "from" elemt let msgID = X.getattr "id" elemt let msgLang = X.getattr "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 xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID) xmlJID name elemt = case X.getattr name elemt of xmlJID name elemt = case X.attributeText name elemt of Nothing -> Just Nothing Just raw -> case parseJID raw of Just jid -> Just (Just jid)
M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +35 -63
@@ 16,23 16,12 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. module Network.Protocol.XMPP.XML ( Element(..) , Node(..) , Content(..) , Name(Name) , Network.Protocol.XMPP.XML.nameNamespace , Network.Protocol.XMPP.XML.nameLocalName , isNamed , elementChildren , isContent , attributeName , Network.Protocol.XMPP.XML.attributeText ( module Data.XML.Types -- * Constructors , element -- * Misc , getattr , contentText , escape @@ , serialiseElement 48,78 37,61 @@ module Network.Protocol.XMPP.XML ) where import Control.Monad (when) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text.Lazy as TL import Data.XML.Types as X 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 getattr :: Name -> Element -> Maybe TL.Text getattr n e = fmap TL.fromStrict (X.attributeText n e) contentText :: Content -> Text contentText (ContentText t) = t contentText (ContentEntity e) = Data.Text.concat ["&", e, ";"] contentText :: Content -> TL.Text contentText (ContentText t) = TL.fromStrict t contentText (ContentEntity e) = TL.concat ["&", TL.fromStrict e, ";"] escape :: TL.Text -> TL.Text escape = TL.concatMap escapeChar where escape :: Text -> Text escape = Data.Text.concatMap escapeChar where escapeChar c = case c of '&' -> "&" '<' -> "<" '>' -> ">" '"' -> """ '\'' -> "'" _ -> TL.singleton c _ -> Data.Text.singleton c escapeContent :: Content -> TL.Text escapeContent (ContentText t) = escape (TL.fromStrict t) escapeContent (ContentEntity e) = TL.concat ["&", escape (TL.fromStrict e), ";"] escapeContent :: Content -> Text escapeContent (ContentText t) = escape t escapeContent (ContentEntity e) = Data.Text.concat ["&", escape e, ";"] element :: Name -> [(Name, TL.Text)] -> [Node] -> Element element :: Name -> [(Name, Text)] -> [Node] -> Element element name attrs children = Element name attrs' children where attrs' = map (uncurry mkattr) attrs mkattr :: Name -> TL.Text -> (Name, [Content]) mkattr n val = (n, [ContentText (TL.toStrict val)]) mkattr :: Name -> Text -> (Name, [Content]) mkattr n val = (n, [ContentText val]) -- A somewhat primitive serialisation function -- -- TODO: better namespace / prefix handling serialiseElement :: Element -> TL.Text serialiseElement :: Element -> Text serialiseElement e = text where text = TL.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"] text = Data.Text.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"] eName = formatName $ elementName e formatName = escape . TL.fromStrict . X.nameLocalName attrs = TL.intercalate " " $ map attr $ elementAttributes e ++ nsattr attr (n, c) = TL.concat $ [formatName n, "=\""] ++ map escapeContent c ++ ["\""] nsattr = case X.nameNamespace $ elementName e of formatName = escape . nameLocalName 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" (TL.fromStrict ns)] contents = TL.concat $ map serialiseNode $ elementNodes e Just ns -> [mkattr "xmlns" ns] contents = Data.Text.concat $ map serialiseNode $ elementNodes e serialiseNode (NodeElement e') = serialiseElement e' serialiseNode (NodeContent c) = escape (contentText c) serialiseNode (NodeComment _) = "" serialiseNode (NodeInstruction _) = "" -- lazy wrappers around strict xml-types; avoids having to break the API just -- to use xml-types 0.3 nameNamespace :: Name -> Maybe TL.Text nameNamespace = fmap TL.fromStrict . X.nameNamespace nameLocalName :: Name -> TL.Text nameLocalName = TL.fromStrict . X.nameLocalName attributeName :: (Name, [Content]) -> Name attributeName = fst attributeText :: (Name, [Content]) -> TL.Text attributeText = TL.concat . map contentText . snd -- 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 TL.Text [SaxEvent])) data Parser = Parser (SAX.Parser IO) (IORef (Either Text [SaxEvent])) newParser :: IO Parser @@ newParser = do 135,17 107,17 @@ newParser = do 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 $ TL.fromStrict txt) SAX.setCallback p SAX.parsedComment (\txt -> addEvent $ Comment $ TL.fromStrict txt) SAX.setCallback p SAX.parsedCharacters (\txt -> addEvent $ Characters txt) SAX.setCallback p SAX.parsedComment (\txt -> addEvent $ Comment txt) SAX.setCallback p SAX.parsedInstruction (\i -> addEvent $ ProcessingInstruction i) SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left $ TL.fromStrict err) >> return False) SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left err) >> return False) return $ Parser p ref parse :: Parser -> BL.ByteString -> Bool -> IO (Either TL.Text [SaxEvent]) parse :: Parser -> ByteString -> Bool -> IO (Either Text [SaxEvent]) parse (Parser p ref) bytes finish = do writeIORef ref (Right []) SAX.parseBytes p (B.concat (BL.toChunks bytes)) SAX.parseBytes p bytes when finish $ SAX.parseComplete p eitherEvents <- readIORef ref @@ return $ case eitherEvents of 155,8 127,8 @@ parse (Parser p ref) bytes finish = do data SaxEvent = BeginElement Name [(Name, [Content])] | EndElement Name | Characters TL.Text | Comment TL.Text | Characters Text | Comment Text | ProcessingInstruction Instruction @@ readEvents :: Monad m 182,7 154,7 @@ readEvents done nextEvents = readEvents' 0 [] where 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 es = case eventsToNodes es >>= isElement of 216,7 188,7 @@ blockToNodes (begin:rest) = nodes where end = last rest nodes = case (begin, end) of (BeginElement name' attrs, EndElement _) -> [node name' attrs] (Characters t, _) -> [NodeContent (ContentText (TL.toStrict t))] (Characters t, _) -> [NodeContent (ContentText t)] _ -> [] node n as = NodeElement $ Element n as $ eventsToNodes $ init rest