~singpolyma/network-protocol-xmpp

f804d3610851f37b047c457769ef114513adce52 — John Millikin 11 years ago 3a40e58
Reduce use of the ($) operator.
M Network/Protocol/XMPP/Client.hs => Network/Protocol/XMPP/Client.hs +8 -9
@@ 61,7 61,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 "jabber:client" jid)
	void (M.readEvents C.startOfStream)
	F.parseFeatures `fmap` M.getElement



@@ 72,10 72,10 @@ tryTLS sjid features m
		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


@@ 92,7 92,7 @@ authenticationMechanisms = step where
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


@@ 113,13 113,13 @@ bindJID jid = do
	
	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


@@ 129,8 129,7 @@ bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where
	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

M Network/Protocol/XMPP/Client/Authentication.hs => Network/Protocol/XMPP/Client/Authentication.hs +22 -21
@@ 25,7 25,8 @@ import qualified Control.Exception as Exc
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           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8
import qualified Data.Text
import           Data.Text (Text)
import           Data.Text.Encoding (encodeUtf8)


@@ 44,7 45,7 @@ data AuthException = XmppError M.Error | SaslError Text

instance Exc.Exception AuthException

authenticate :: [B.ByteString] -- ^ Mechanisms
authenticate :: [ByteString] -- ^ Mechanisms
             -> JID -- ^ User JID
             -> JID -- ^ Server JID
             -> Text -- ^ Username


@@ 52,12 53,12 @@ authenticate :: [B.ByteString] -- ^ Mechanisms
             -> 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
	
	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"


@@ 66,21 67,21 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
			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 $ 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 $ encodeUtf8 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 ""
			(b64text, rc) <- SASL.step64 ""
			putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
				[("mechanism", Data.Text.pack $ B.unpack mechBytes)]
				[X.NodeContent $ X.ContentText $ Data.Text.pack $ B.unpack b64text]
				[("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


@@ 88,7 89,7 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
			
		case sessionResult of
			Right x -> return x
			Left err -> saslError $ Data.Text.pack $ show err
			Left err -> saslError (Data.Text.pack (show err))

saslLoop :: M.Session -> SASL.Session Result
saslLoop ctx = do


@@ 100,11 101,11 @@ saslLoop ctx = do
		>=> 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 Data.Text.unpack $ challengeText
	(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 $ B.unpack b64text]
		[] [X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))]
	case rc of
		SASL.Complete -> saslFinish ctx
		SASL.NeedsMore -> saslLoop ctx


@@ 114,20 115,20 @@ saslFinish ctx = do
	elemt <- getElement ctx
	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 => Text -> m a

M Network/Protocol/XMPP/Component.hs => Network/Protocol/XMPP/Component.hs +4 -5
@@ 70,17 70,16 @@ 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]
	let digest = showDigest (sha1 bytes)
	M.putElement (X.element "handshake" [] [X.NodeContent (X.ContentText digest)])
	result <- M.getElement
	let nameHandshake = "{jabber:component:accept}handshake"
	when (null (X.isNamed nameHandshake result)) $
		throwError M.AuthenticationFailure
	when (null (X.isNamed nameHandshake result)) (throwError M.AuthenticationFailure)

buildSecret :: Text -> Text -> ByteString
buildSecret sid password = encodeUtf8 (X.escape (Data.Text.append sid password))

showDigest :: ByteString -> Text
showDigest = Data.Text.pack . concatMap wordToHex . Data.ByteString.unpack where
	wordToHex x = [hexDig $ shiftR x 4, hexDig $ x .&. 0xF]
	wordToHex x = [hexDig (shiftR x 4), hexDig (x .&. 0xF)]
	hexDig = intToDigit . fromIntegral

M Network/Protocol/XMPP/ErrorT.hs => Network/Protocol/XMPP/ErrorT.hs +5 -5
@@ 39,8 39,8 @@ instance Monad m => Monad (ErrorT e m) where
	(>>=) 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


@@ 48,8 48,8 @@ instance Monad m => E.MonadError (ErrorT e m) where
	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


@@ 70,4 70,4 @@ instance MonadFix m => MonadFix (ErrorT e m) where
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))

M Network/Protocol/XMPP/Handle.hs => Network/Protocol/XMPP/Handle.hs +2 -2
@@ 45,7 45,7 @@ liftTLS' :: IO (Either TLS.Error a) -> ErrorT Text IO a
liftTLS' io = do
	eitherX <- liftIO io
	case eitherX of
		Left err -> E.throwError $ Data.Text.pack $ show err
		Left err -> E.throwError (Data.Text.pack (show err))
		Right x -> return x

startTLS :: Handle -> ErrorT Text IO Handle


@@ 62,7 62,7 @@ hPutBytes (SecureHandle _ s) = liftTLS s . 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 (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 ()

M Network/Protocol/XMPP/JID.hs => Network/Protocol/XMPP/JID.hs +5 -3
@@ 81,11 81,13 @@ parseJID str = maybeJID where
		(x, y) -> if Data.Text.null y
			then (x, "")
			else (x, Data.Text.drop 1 y)
	nullable x f = if Data.Text.null x then Just Nothing else fmap Just $ f x
	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)

M Network/Protocol/XMPP/Monad.hs => Network/Protocol/XMPP/Monad.hs +15 -15
@@ 90,7 90,7 @@ instance Functor XMPP where

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


@@ 98,14 98,14 @@ instance MonadIO XMPP where
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


@@ 120,15 120,15 @@ startXMPP h ns xmpp = do
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


@@ 141,15 141,15 @@ getHandle = fmap sessionHandle getSession

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 :: 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


@@ 163,11 163,11 @@ readEvents done = xmpp where
		Session h _ p _ _ <- getSession
		let nextEvents = do
			-- TODO: read in larger increments
			bytes <- liftTLS $ H.hGetBytes h 1
			let eof = Data.ByteString.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



@@ 177,7 177,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 "getElement: invalid event list")
	
	endOfTree 0 (X.EventEndElement _) = True
	endOfTree _ _ = False


@@ 188,4 188,4 @@ getStanza = withLock sessionReadLock $ do
	Session _ ns _ _ _ <- getSession
	case S.elementToStanza ns elemt of
		Just x -> return x
		Nothing -> E.throwError $ InvalidStanza elemt
		Nothing -> E.throwError (InvalidStanza elemt)

M Network/Protocol/XMPP/Stanza.hs => Network/Protocol/XMPP/Stanza.hs +9 -9
@@ 187,10 187,10 @@ emptyIQ t = IQ

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 Data.Text.null typeStr then [] else [("type", typeStr)]


@@ 201,10 201,10 @@ stanzaToElement' stanza name typeStr = X.element name attrs payloads where

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


@@ 226,11 226,11 @@ parseMessage elemt = do
	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.attributeText "type" elemt
	let typeStr = maybe "" id (X.attributeText "type" elemt)
	pType <- case typeStr of
		""             -> Just PresenceAvailable
		"unavailable"  -> Just PresenceUnavailable


@@ 247,7 247,7 @@ parsePresence elemt = do
	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


@@ 266,7 266,7 @@ parseIQ elemt = do
	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 :: X.Name -> X.Element -> Maybe (Maybe JID)
xmlJID name elemt = case X.attributeText name elemt of

M Network/Protocol/XMPP/XML.hs => Network/Protocol/XMPP/XML.hs +12 -12
@@ 74,14 74,14 @@ mkattr n val = (n, [ContentText val])
serialiseElement :: Element -> Text
serialiseElement e = text where
	text = Data.Text.concat ["<", eName, " ", attrs, ">", contents, "</", eName, ">"]
	eName = formatName $ elementName e
	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 " " (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 = Data.Text.concat $ map serialiseNode $ elementNodes e
	contents = Data.Text.concat (map serialiseNode (elementNodes e))
	
	serialiseNode (NodeElement e') = serialiseElement e'
	serialiseNode (NodeContent c) = escape (contentText c)


@@ 105,23 105,23 @@ newParser = do
		return True
	
	SAX.setCallback p SAX.parsedBeginElement (\name attrs -> addEvent (EventBeginElement name attrs))
	SAX.setCallback p SAX.parsedEndElement (\name -> addEvent (EventEndElement name))
	SAX.setCallback p SAX.parsedCharacters (\txt -> addEvent (EventContent (ContentText txt)))
	SAX.setCallback p SAX.parsedComment (\txt -> addEvent (EventComment txt))
	SAX.setCallback p SAX.parsedInstruction (\i -> addEvent (EventInstruction i))
	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 -> ByteString -> Bool -> IO (Either Text [Event])
parse (Parser p ref) bytes finish = do
	writeIORef ref (Right [])
	SAX.parseBytes p bytes
	when finish $ SAX.parseComplete p
	when finish (SAX.parseComplete p)
	eitherEvents <- readIORef ref
	return $ case eitherEvents of
		Left err -> Left err
		Right events -> Right $ reverse events
		Right events -> Right (reverse events)

readEvents :: Monad m
           => (Integer -> Event -> Bool)


@@ 183,4 183,4 @@ blockToNodes (begin:rest) = nodes where
		(EventContent c, _) -> [NodeContent c]
		_ -> []
	
	node n as = NodeElement $ Element n as $ eventsToNodes $ init rest
	node n as = NodeElement (Element n as (eventsToNodes (init rest)))