M examples/echo.hs => examples/echo.hs +2 -2
@@ 21,7 21,6 @@
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.
-{-# LANGUAGE OverloadedStrings #-}
module Main where
-- XMPP imports
@@ 30,6 29,7 @@ import Network.Protocol.XMPP
import Data.XML.Types
-- other imports
+import Data.String (fromString)
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
@@ 147,7 147,7 @@ sendPings seconds s = forever send where
}
pingName :: Name
-pingName = Name "ping" (Just "urn:xmpp:ping") Nothing
+pingName = fromString "{urn:xmpp:ping}ping"
main :: IO ()
main = do
M lib/Network/Protocol/XMPP/Client.hs => lib/Network/Protocol/XMPP/Client.hs +8 -9
@@ 1,5 1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
@@ 37,6 35,7 @@ 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.String (s)
runClient :: C.Server
-> J.JID -- ^ Client JID
@@ 52,7 51,7 @@ runClient server jid username password xmpp = do
let handle = H.PlainHandle rawHandle
-- Open the initial stream and authenticate
- M.startXMPP handle "jabber:client" $ do
+ M.startXMPP handle (s"jabber:client") $ do
features <- newStream sjid
tryTLS sjid features $ \tlsFeatures -> do
let mechanisms = authenticationMechanisms tlsFeatures
@@ 61,7 60,7 @@ runClient server jid username password xmpp = do
newStream :: J.JID -> M.XMPP [F.Feature]
newStream jid = do
- M.putBytes (C.xmlHeader "jabber:client" jid)
+ M.putBytes (C.xmlHeader (s"jabber:client") jid)
void (M.readEvents C.startOfStream)
F.parseFeatures `fmap` M.getElement
@@ 96,7 95,7 @@ bindJID jid = do
bindResult <- M.getStanza
let getJID =
X.elementChildren
- >=> X.isNamed "{urn:ietf:params:xml:ns:xmpp-bind}jid"
+ >=> X.isNamed (s"{urn:ietf:params:xml:ns:xmpp-bind}jid")
>=> X.elementNodes
>=> X.isContent
>=> return . X.contentText
@@ 126,14 125,14 @@ bindJID jid = do
bindStanza :: Maybe J.Resource -> IQ
bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
- payload = X.element "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] requested
+ payload = X.element (s"{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 (s"resource") [] [X.NodeContent (X.ContentText x)])]
sessionStanza :: IQ
sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where
- payload = X.element "{urn:ietf:params:xml:ns:xmpp-session}session" [] []
+ payload = X.element (s"{urn:ietf:params:xml:ns:xmpp-session}session") [] []
streamSupportsTLS :: [F.Feature] -> Bool
streamSupportsTLS = any isStartTLS where
@@ 141,7 140,7 @@ streamSupportsTLS = any isStartTLS where
isStartTLS _ = False
xmlStartTLS :: X.Element
-xmlStartTLS = X.element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
+xmlStartTLS = X.element (s"{urn:ietf:params:xml:ns:xmpp-tls}starttls") [] []
void :: Monad m => m a -> m ()
void m = m >> return ()
M lib/Network/Protocol/XMPP/Client/Authentication.hs => lib/Network/Protocol/XMPP/Client/Authentication.hs +10 -11
@@ 1,5 1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- Copyright (C) 2009-2011 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
@@ 34,6 32,7 @@ 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.String (s)
data Result = Success | Failure X.Element
deriving (Show, Eq)
@@ 73,12 72,12 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
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.PropertyService (s"xmpp")
SASL.setProperty SASL.PropertyHostname (encodeUtf8 hostname)
- (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))]
+ (b64text, rc) <- SASL.step64 Data.ByteString.Char8.empty
+ putElement ctx $ X.element (s"{urn:ietf:params:xml:ns:xmpp-sasl}auth")
+ [(s"mechanism", Data.Text.pack (Data.ByteString.Char8.unpack mechBytes))]
[X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))]
case rc of
@@ 96,11 95,11 @@ saslLoop ctx = do
let challenge = concatMap Data.Text.unpack challengeTexts
case X.elementName e of
-- The server needs more data before it can authenticate this client.
- n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" -> do
+ n | n == s"{urn:ietf:params:xml:ns:xmpp-sasl}challenge" -> do
when (null challenge) (saslError "Received empty challenge")
(b64text, rc) <- SASL.step64 (Data.ByteString.Char8.pack challenge)
putElement ctx (X.element
- "{urn:ietf:params:xml:ns:xmpp-sasl}response"
+ (s"{urn:ietf:params:xml:ns:xmpp-sasl}response")
[]
[X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))])
case rc of
@@ 109,7 108,7 @@ saslLoop ctx = do
-- The server has authenticated this client, but the client-side
-- SASL protocol wants more data from the server.
- n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}success" -> do
+ n | n == s"{urn:ietf:params:xml:ns:xmpp-sasl}success" -> do
when (null challenge) (saslError "Received empty challenge")
(_, rc) <- SASL.step64 (Data.ByteString.Char8.pack challenge)
case rc of
@@ 117,14 116,14 @@ saslLoop ctx = do
SASL.NeedsMore -> saslError "Server didn't provide enough SASL data."
-- The server has rejected this client's credentials.
- n | n == "{urn:ietf:params:xml:ns:xmpp-sasl}failure" -> return (Failure e)
+ n | n == s"{urn:ietf:params:xml:ns:xmpp-sasl}failure" -> return (Failure e)
_ -> saslError "Server sent unexpected element during authentication."
saslFinish :: M.Session -> SASL.Session Result
saslFinish ctx = do
elemt <- getElement ctx
- return $ if X.elementName elemt == "{urn:ietf:params:xml:ns:xmpp-sasl}success"
+ return $ if X.elementName elemt == s"{urn:ietf:params:xml:ns:xmpp-sasl}success"
then Success
else Failure elemt
M lib/Network/Protocol/XMPP/Client/Features.hs => lib/Network/Protocol/XMPP/Client/Features.hs +5 -6
@@ 1,5 1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
@@ 21,12 19,12 @@ module Network.Protocol.XMPP.Client.Features
, parseFeature
) where
-import Data.Maybe (fromMaybe)
import Control.Arrow ((&&&))
import qualified Data.ByteString.Char8
import Data.ByteString (ByteString)
import qualified Data.Text
import qualified Network.Protocol.XMPP.XML as X
+import Network.Protocol.XMPP.String (s)
data Feature =
FeatureStartTLS Bool
@@ 44,7 42,8 @@ parseFeatures e =
parseFeature :: X.Element -> Feature
parseFeature elemt = feature where
- unpackName = (fromMaybe "" . X.nameNamespace) &&& X.nameLocalName
+ unpackName = (maybe "" Data.Text.unpack . X.nameNamespace) &&&
+ (Data.Text.unpack . X.nameLocalName)
feature = case unpackName (X.elementName elemt) of
("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS elemt
("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL elemt
@@ 65,7 64,7 @@ parseFeatureSASL e = FeatureSASL $
>>= X.isContent
nameMechanism :: X.Name
-nameMechanism = "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism"
+nameMechanism = s"{urn:ietf:params:xml:ns:xmpp-sasl}mechanism"
nameFeatures :: X.Name
-nameFeatures = "{http://etherx.jabber.org/streams}features"
+nameFeatures = s"{http://etherx.jabber.org/streams}features"
M lib/Network/Protocol/XMPP/Component.hs => lib/Network/Protocol/XMPP/Component.hs +7 -8
@@ 1,5 1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- Copyright (C) 2010 Stephan Maka <stephan@spaceboyz.net>
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
--
@@ 39,6 37,7 @@ 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.String (s)
runComponent :: C.Server
-> Text -- ^ Server secret
@@ 49,14 48,14 @@ runComponent server password xmpp = do
rawHandle <- connectTo host port
IO.hSetBuffering rawHandle IO.NoBuffering
let handle = H.PlainHandle rawHandle
- M.startXMPP handle "jabber:component:accept" $ do
+ M.startXMPP handle (s"jabber:component:accept") $ do
streamID <- beginStream jid
authenticate streamID password
xmpp
beginStream :: JID -> M.XMPP Text
beginStream jid = do
- M.putBytes $ C.xmlHeader "jabber:component:accept" jid
+ M.putBytes $ C.xmlHeader (s"jabber:component:accept") jid
events <- M.readEvents C.startOfStream
case parseStreamID $ last events of
Nothing -> throwError M.NoComponentStreamID
@@ 66,17 65,17 @@ parseStreamID :: X.Event -> Maybe Text
parseStreamID (X.EventBeginElement name attrs) = withNS <|> withoutNS
where
-- Hack to allow for global namespace without implementing full handling
- withoutNS = X.attributeText "id" (X.Element name attrs [])
- withNS = X.attributeText "{jabber:component:accept}id" (X.Element name attrs [])
+ withoutNS = X.attributeText (s"id") (X.Element name attrs [])
+ withNS = X.attributeText (s"{jabber:component:accept}id") (X.Element name attrs [])
parseStreamID _ = Nothing
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)])
+ M.putElement (X.element (s"handshake") [] [X.NodeContent (X.ContentText digest)])
result <- M.getElement
- let nameHandshake = "{jabber:component:accept}handshake"
+ let nameHandshake = s"{jabber:component:accept}handshake"
when (null (X.isNamed nameHandshake result)) (throwError (M.AuthenticationFailure result))
buildSecret :: Text -> Text -> ByteString
M lib/Network/Protocol/XMPP/Connections.hs => lib/Network/Protocol/XMPP/Connections.hs +8 -9
@@ 1,5 1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
@@ 30,6 28,7 @@ import Data.Text.Encoding (encodeUtf8)
import qualified Network.Protocol.XMPP.XML as X
import Network.Protocol.XMPP.JID (JID, formatJID)
+import Network.Protocol.XMPP.String (s)
data Server = Server
{ serverJID :: JID
@@ 42,13 41,13 @@ data Server = Server
-- attributes.
xmlHeader :: Text -> JID -> ByteString
xmlHeader ns jid = encodeUtf8 header where
- attr x = Data.Text.concat ["\"", X.escape x, "\""]
+ attr x = Data.Text.concat [s"\"", X.escape x, s"\""]
header = Data.Text.concat
- [ "<?xml version='1.0'?>\n"
- , "<stream:stream xmlns=" , attr ns
- , " to=", attr (formatJID jid)
- , " version=\"1.0\""
- , " xmlns:stream=\"http://etherx.jabber.org/streams\">"
+ [ s"<?xml version='1.0'?>\n"
+ , s"<stream:stream xmlns=" , attr ns
+ , s" to=", attr (formatJID jid)
+ , s" version=\"1.0\""
+ , s" xmlns:stream=\"http://etherx.jabber.org/streams\">"
]
startOfStream :: Integer -> X.Event -> Bool
@@ 57,4 56,4 @@ startOfStream depth event = case (depth, event) of
_ -> False
qnameStream :: X.Name
-qnameStream = "{http://etherx.jabber.org/streams}stream"
+qnameStream = s"{http://etherx.jabber.org/streams}stream"
M lib/Network/Protocol/XMPP/Handle.hs => lib/Network/Protocol/XMPP/Handle.hs +5 -6
@@ 1,5 1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
@@ 34,13 32,14 @@ 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.String (s)
data Handle =
PlainHandle IO.Handle
| SecureHandle IO.Handle TLS.Session
liftTLS :: TLS.Session -> TLS.TLS a -> ErrorT Text IO a
-liftTLS s = liftTLS' . TLS.runTLS s
+liftTLS session = liftTLS' . TLS.runTLS session
liftTLS' :: IO (Either TLS.Error a) -> ErrorT Text IO a
liftTLS' io = do
@@ 50,7 49,7 @@ liftTLS' io = do
Right x -> return x
startTLS :: Handle -> ErrorT Text IO Handle
-startTLS (SecureHandle _ _) = E.throwError "Can't start TLS on a secure handle"
+startTLS (SecureHandle _ _) = E.throwError $ s"Can't start TLS on a secure handle"
startTLS (PlainHandle h) = liftTLS' $ TLS.runClient (TLS.handleTransport h) $ do
TLS.setCredentials =<< TLS.certificateCredentials
TLS.handshake
@@ 58,12 57,12 @@ startTLS (PlainHandle h) = liftTLS' $ TLS.runClient (TLS.handleTransport h) $ do
hPutBytes :: Handle -> ByteString -> ErrorT Text IO ()
hPutBytes (PlainHandle h) = liftIO . Data.ByteString.hPut h
-hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes . toLazy where
+hPutBytes (SecureHandle _ session) = liftTLS session . TLS.putBytes . toLazy where
toLazy bytes = Data.ByteString.Lazy.fromChunks [bytes]
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
+hGetBytes (SecureHandle h session) n = liftTLS session $ do
pending <- TLS.checkPending
let wait = void $ IO.hWaitForInput h (- 1)
when (pending == 0) (liftIO wait)
M lib/Network/Protocol/XMPP/JID.hs => lib/Network/Protocol/XMPP/JID.hs +4 -5
@@ 1,4 1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
@@ 76,11 75,11 @@ parseJID :: Text -> Maybe JID
parseJID str = maybeJID where
(node, postNode) = case textSpanBy (/= '@') str of
(x, y) -> if Data.Text.null y
- then ("", x)
+ then (Data.Text.empty, x)
else (x, Data.Text.drop 1 y)
(domain, resource) = case textSpanBy (/= '/') postNode of
(x, y) -> if Data.Text.null y
- then (x, "")
+ then (x, Data.Text.empty)
else (x, Data.Text.drop 1 y)
nullable x f = if Data.Text.null x
then Just Nothing
@@ 103,8 102,8 @@ parseJID_ = fromMaybe (error "Malformed JID") . parseJID
formatJID :: JID -> Text
formatJID (JID node (Domain domain) resource) = formatted where
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
+ node' = maybe Data.Text.empty (\(Node x) -> Data.Text.snoc x '@') node
+ resource' = maybe Data.Text.empty (\(Resource x) -> Data.Text.cons '/' x) resource
-- Similar to 'comparing'
equaling :: Eq a => (b -> a) -> b -> b -> Bool
M lib/Network/Protocol/XMPP/Monad.hs => lib/Network/Protocol/XMPP/Monad.hs +8 -8
@@ 1,5 1,4 @@
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings #-}
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
--
@@ 55,6 54,7 @@ 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
+import Network.Protocol.XMPP.String (s)
data Error
-- | The remote host refused the specified authentication credentials.
@@ 115,7 115,7 @@ instance MonadFix XMPP where
mfix f = XMPP (mfix (unXMPP . f))
runXMPP :: Session -> XMPP a -> IO (Either Error a)
-runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s
+runXMPP session xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) session
startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)
startXMPP h ns xmpp = do
@@ 128,14 128,14 @@ restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
restartXMPP newH xmpp = do
Session oldH ns _ readLock writeLock <- getSession
sax <- liftIO X.newParser
- let s = Session (fromMaybe oldH newH) ns sax readLock writeLock
- XMPP (R.local (const s) (unXMPP xmpp))
+ let session = Session (fromMaybe oldH newH) ns sax readLock writeLock
+ XMPP (R.local (const session) (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))
+ session <- getSession
+ let mvar = getLock session
+ res <- liftIO (M.withMVar mvar (const $ runXMPP session xmpp))
case res of
Left err -> E.throwError err
Right x -> return x
@@ 187,7 187,7 @@ getElement = xmpp where
events <- readEvents endOfTree
case X.eventsToElement events of
Just x -> return x
- Nothing -> E.throwError (TransportError "getElement: invalid event list")
+ Nothing -> E.throwError (TransportError $ s"getElement: invalid event list")
endOfTree 0 (X.EventEndElement _) = True
endOfTree _ _ = False
M lib/Network/Protocol/XMPP/Stanza.hs => lib/Network/Protocol/XMPP/Stanza.hs +13 -13
@@ 1,5 1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
@@ 33,12 31,14 @@ module Network.Protocol.XMPP.Stanza
, elementToStanza
) where
+import Data.String (fromString)
import Data.Maybe (listToMaybe)
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.String (s)
class Stanza a where
stanzaTo :: a -> Maybe JID
@@ 186,19 186,19 @@ emptyIQ t = IQ
, iqPayload = Nothing
}
-stanzaToElement' :: Stanza a => a -> X.Name -> Text -> X.Element
-stanzaToElement' stanza name typeStr = X.element name attrs payloads where
+stanzaToElement' :: Stanza a => a -> String -> String -> X.Element
+stanzaToElement' stanza name typeStr = X.element (fromString name) attrs payloads where
payloads = map X.NodeElement (stanzaPayloads stanza)
attrs = concat
[ mattr "to" (fmap formatJID . stanzaTo)
, mattr "from" (fmap formatJID . stanzaFrom)
, mattr "id" stanzaID
, mattr "xml:lang" stanzaLang
- , if Data.Text.null typeStr then [] else [("type", typeStr)]
+ , mattr "type" (const $ fromString <$> if null typeStr then Nothing else Just typeStr)
]
mattr label f = case f stanza of
Nothing -> []
- Just text -> [(label, text)]
+ Just text -> [(fromString label, text)]
elementToStanza :: Text -> X.Element -> Maybe ReceivedStanza
elementToStanza ns elemt = do
@@ 206,27 206,27 @@ elementToStanza ns elemt = do
when (elemNS /= Just ns) Nothing
let elemName = X.nameLocalName (X.elementName elemt)
- case elemName of
+ case Data.Text.unpack elemName of
"message" -> ReceivedMessage `fmap` parseMessage elemt
"presence" -> ReceivedPresence `fmap` parsePresence elemt
"iq" -> ReceivedIQ `fmap` parseIQ elemt
_ -> Nothing
parseStanzaCommon ::
- (Maybe Text -> Maybe t)
+ (Maybe String -> Maybe t)
-> (t -> Maybe JID -> Maybe JID -> Maybe Text -> Maybe Text -> [X.Element] -> s)
-> X.Element
-> Maybe s
parseStanzaCommon parseType mk elemt = do
- to <- xmlJID "to" elemt
- from <- xmlJID "from" elemt
- typ <- parseType $ X.attributeText "type" elemt
+ to <- xmlJID (s"to") elemt
+ from <- xmlJID (s"from") elemt
+ typ <- parseType $ Data.Text.unpack <$> X.attributeText (s"type") elemt
return $ mk
typ
to
from
- (X.attributeText "id" elemt)
- (X.attributeText "lang" elemt)
+ (X.attributeText (s"id") elemt)
+ (X.attributeText (s"lang") elemt)
(X.elementChildren elemt)
parseMessage :: X.Element -> Maybe Message
A lib/Network/Protocol/XMPP/String.hs => lib/Network/Protocol/XMPP/String.hs +6 -0
@@ 0,0 1,6 @@
+module Network.Protocol.XMPP.String (s) where
+
+import Data.String (IsString, fromString)
+
+s :: (IsString s) => String -> s
+s = fromString
M lib/Network/Protocol/XMPP/XML.hs => lib/Network/Protocol/XMPP/XML.hs +15 -15
@@ 1,5 1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
@@ 43,23 41,25 @@ import Data.XML.Types
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Text.XML.LibXML.SAX as SAX
+import Network.Protocol.XMPP.String (s)
+
contentText :: Content -> Text
contentText (ContentText t) = t
-contentText (ContentEntity e) = Data.Text.concat ["&", e, ";"]
+contentText (ContentEntity e) = Data.Text.concat [s"&", e, s";"]
escape :: Text -> Text
escape = Data.Text.concatMap escapeChar where
escapeChar c = case c of
- '&' -> "&"
- '<' -> "<"
- '>' -> ">"
- '"' -> """
- '\'' -> "'"
+ '&' -> s"&"
+ '<' -> s"<"
+ '>' -> s">"
+ '"' -> s"""
+ '\'' -> s"'"
_ -> Data.Text.singleton c
escapeContent :: Content -> Text
escapeContent (ContentText t) = escape t
-escapeContent (ContentEntity e) = Data.Text.concat ["&", escape e, ";"]
+escapeContent (ContentEntity e) = Data.Text.concat [s"&", escape e, s";"]
element :: Name -> [(Name, Text)] -> [Node] -> Element
element name attrs = Element name (map mkattr attrs)
@@ 72,20 72,20 @@ mkattr (n, val) = (n, [ContentText val])
-- TODO: better namespace / prefix handling
serialiseElement :: Element -> Text
serialiseElement e = text where
- text = Data.Text.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
+ text = Data.Text.concat [s"<", eName, s" ", attrs, s">", contents, s"</", eName, s">"]
eName = formatName (elementName e)
formatName = escape . nameLocalName
- attrs = Data.Text.intercalate " " (map attr (elementAttributes e ++ nsattr))
- attr (n, c) = Data.Text.concat ([formatName n, "=\""] ++ map escapeContent c ++ ["\""])
+ attrs = Data.Text.intercalate (s" ") (map attr (elementAttributes e ++ nsattr))
+ attr (n, c) = Data.Text.concat ([formatName n, s"=\""] ++ map escapeContent c ++ [s"\""])
nsattr = case nameNamespace $ elementName e of
Nothing -> []
- Just ns -> [mkattr ("xmlns", ns)]
+ Just ns -> [mkattr (s"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 _) = ""
+ serialiseNode (NodeComment _) = Data.Text.empty
+ serialiseNode (NodeInstruction _) = Data.Text.empty
-- quick-and-dirty imitation of libxml-sax-0.4 API; later, this should
-- probably be rewritten to use ST and discard the list parsing
M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +1 -0
@@ 57,3 57,4 @@ library
Network.Protocol.XMPP.Monad
Network.Protocol.XMPP.Stanza
Network.Protocol.XMPP.XML
+ Network.Protocol.XMPP.String