~singpolyma/network-protocol-xmpp

8150ebe081f71ed4dd543956598a889c6adfc754 — John Millikin 12 years ago bd216cc
Fix a few stylistic issues found by HLint.
M Network/Protocol/XMPP/Client/Features.hs => Network/Protocol/XMPP/Client/Features.hs +9 -9
@@ 19,7 19,7 @@ module Network.Protocol.XMPP.Client.Features
	, parseFeature
	) where
import qualified Data.ByteString.Char8 as B
import Text.XML.HXT.Arrow ((>>>))
import Text.XML.HXT.Arrow ((>>>), (&&&))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN


@@ 35,15 35,15 @@ data Feature =
	deriving (Show, Eq)

parseFeatures :: DOM.XmlTree -> [Feature]
parseFeatures t =
	A.runLA (A.getChildren
		>>> A.hasQName qnameFeatures
		>>> A.getChildren
		>>> A.arrL (\t' -> [parseFeature t'])) t
parseFeatures = A.runLA $
	A.getChildren
	>>> A.hasQName qnameFeatures
	>>> A.getChildren
	>>> A.arrL (\t' -> [parseFeature t'])

parseFeature :: DOM.XmlTree -> Feature
parseFeature t = feature where
	mkPair = maybe ("", "") $ \n -> (DOM.namespaceUri n, DOM.localPart n)
	mkPair = maybe ("", "") $ DOM.namespaceUri &&& DOM.localPart
	feature = case mkPair (XN.getName t) of
		("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS t
		("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL t


@@ 56,12 56,12 @@ parseFeatureTLS :: DOM.XmlTree -> Feature
parseFeatureTLS t = FeatureStartTLS True -- TODO: detect whether or not required

parseFeatureSASL :: DOM.XmlTree -> Feature
parseFeatureSASL t = FeatureSASL $ A.runLA (
parseFeatureSASL = FeatureSASL . A.runLA (
	A.getChildren
	>>> A.hasQName qnameMechanism
	>>> A.getChildren
	>>> A.getText
	>>> A.arr B.pack) t
	>>> A.arr B.pack)

qnameMechanism :: DOM.QName
qnameMechanism = qname "urn:ietf:params:xml:ns:xmpp-sasl" "mechanism"

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +3 -3
@@ 21,6 21,7 @@ module Network.Protocol.XMPP.Component
	, componentStreamID
	, connectComponent
	) where
import Control.Monad (when)
import Data.Bits (shiftR, (.&.))
import Data.Char (intToDigit)
import qualified Data.ByteString as B


@@ 100,9 101,8 @@ authenticate stream password = do
	let accepted = A.runLA $
		A.getChildren
		>>> A.hasQName (qname "jabber:component:accept" "handshake")
	if null (accepted result)
		then error "Component handshake failed" -- TODO: throwIO
		else return ()
	when (null (accepted result)) $
		error "Component handshake failed" -- TODO: throwIO

buildSecret :: T.Text -> T.Text -> B.ByteString
buildSecret sid password = bytes where

M Network/Protocol/XMPP/Handle.hs => Network/Protocol/XMPP/Handle.hs +5 -6
@@ 20,6 20,7 @@ module Network.Protocol.XMPP.Handle
	, hGetChar
	) where

import Control.Monad (when)
import qualified System.IO as IO
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B


@@ 46,7 47,7 @@ startTLS (PlainHandle h) = do
hPutBytes :: Handle -> B.ByteString -> IO ()
hPutBytes (PlainHandle h)          bytes = B.hPut h bytes
hPutBytes (SecureHandle _ session) bytes = useLoop where
	useLoop = B.unsafeUseAsCStringLen bytes $ \(ptr, len) -> loop ptr len
	useLoop = B.unsafeUseAsCStringLen bytes $ uncurry loop
	loop ptr len = do
		r <- GnuTLS.tlsSend session ptr len
		case len - r of


@@ 57,11 58,9 @@ hGetChar :: Handle -> IO Char
hGetChar (PlainHandle h) = IO.hGetChar h
hGetChar (SecureHandle h session) = allocaBytes 1 $ \ptr -> do
	pending <- GnuTLS.tlsCheckPending session
	if pending == 0
		then do
			IO.hWaitForInput h (-1)
			return ()
		else return ()
	when (pending == 0) $ do
		IO.hWaitForInput h (-1)
		return ()
	
	len <- GnuTLS.tlsRecv session ptr 1
	[char] <- peekCAStringLen (ptr, len)

M Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +2 -2
@@ 73,7 73,7 @@ parseJID str = maybeJID where
	(domain, resource) = case T.spanBy (/= '/') postNode of
		(x, y) -> if T.null y
			then (x, "")
			else (x, T.drop 1 $ y)
			else (x, T.drop 1 y)
	mNode = if T.null node then Nothing else Just (Node node)
	mResource = if T.null resource then Nothing else Just (Resource resource)
	maybeJID = do


@@ 94,7 94,7 @@ nodePrep = SP.Profile
	, SP.shouldNormalize = True
	, SP.prohibited = [ SP.c11, SP.c12, SP.c21, SP.c22
	                  , SP.c3, SP.c4, SP.c5, SP.c6, SP.c7, SP.c8, SP.c9
	                  , map single $ "\"&'/:<>@"
	                  , map single "\"&'/:<>@"
	                  ]
	, SP.shouldCheckBidi = True
	}

M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +2 -2
@@ 77,10 77,10 @@ readEventsStep done (e:es) depth accum = let

-- This function assumes the input list is valid. No validation is performed.
eventsToTree :: [SAX.Event] -> DOM.XmlTree
eventsToTree es = XN.mkRoot [] (eventsToTrees es)
eventsToTree = XN.mkRoot [] . eventsToTrees

eventsToTrees :: [SAX.Event] -> [DOM.XmlTree]
eventsToTrees es = concatMap blockToTrees (splitBlocks es)
eventsToTrees = concatMap blockToTrees . splitBlocks

-- Split event list into a sequence of "blocks", which are the events including
-- and between a pair of tags. <start><start2/></start> and <start/> are both