~singpolyma/network-protocol-xmpp

b8cf87e3728869ce9610aead3ff843ad43c427d1 — Stephen Paul Weber 2 months ago 635de44
No more monads-tf
M lib/Network/Protocol/XMPP.hs => lib/Network/Protocol/XMPP.hs +2 -0
@@ 58,6 58,8 @@ module Network.Protocol.XMPP
	, putStanza
	, getStanza
	, bindJID
	, throwE
	, catchE

	-- ** Resuming sessions
	, Session

M lib/Network/Protocol/XMPP/Client.hs => lib/Network/Protocol/XMPP/Client.hs +5 -6
@@ 19,8 19,8 @@ module Network.Protocol.XMPP.Client
	) where

import           Control.Monad ((>=>))
import           Control.Monad.Except (throwError)
import           Control.Monad.Trans (liftIO)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (runExceptT)
import           Data.ByteString (ByteString)
import           Data.Text (Text)
import qualified System.IO as IO


@@ 32,7 32,6 @@ import qualified Network.Protocol.XMPP.Handle as H
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.String (s)



@@ 70,9 69,9 @@ tryTLS sjid features m
		M.putElement xmlStartTLS
		void M.getElement
		h <- M.getHandle
		eitherTLS <- liftIO (runErrorT (H.startTLS h))
		eitherTLS <- liftIO (runExceptT (H.startTLS h))
		case eitherTLS of
			Left err -> throwError (M.TransportError err)
			Left err -> M.throwE (M.TransportError err)
			Right tls -> M.restartXMPP (Just tls) (newStream sjid >>= m)

authenticationMechanisms :: [F.Feature] -> [ByteString]


@@ 111,7 110,7 @@ bindJID jid = do

	returnedJID <- case maybeJID of
		Just x -> return x
		Nothing -> throwError (M.InvalidBindResult bindResult)
		Nothing -> M.throwE (M.InvalidBindResult bindResult)

	-- Session
	M.putStanza sessionStanza

M lib/Network/Protocol/XMPP/Client/Authentication.hs => lib/Network/Protocol/XMPP/Client/Authentication.hs +3 -4
@@ 21,7 21,6 @@ module Network.Protocol.XMPP.Client.Authentication
import qualified Control.Exception as Exc
import           Control.Monad (when)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.Except as E
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8
import qualified Data.Text


@@ 62,9 61,9 @@ authenticate xmppMechanisms userJID serverJID username password = xmpp where
				Just mechanism -> authSasl ctx mechanism
		case res of
			Right Success -> return ()
			Right (Failure e) -> E.throwError (M.AuthenticationFailure e)
			Left (XmppError err) -> E.throwError err
			Left (SaslError err) -> E.throwError (M.AuthenticationError err)
			Right (Failure e) -> M.throwE (M.AuthenticationFailure e)
			Left (XmppError err) -> M.throwE err
			Left (SaslError err) -> M.throwE (M.AuthenticationError err)

	authSasl ctx mechanism = do
		let (SASL.Mechanism mechBytes) = mechanism

M lib/Network/Protocol/XMPP/Component.hs => lib/Network/Protocol/XMPP/Component.hs +2 -3
@@ 20,7 20,6 @@ module Network.Protocol.XMPP.Component

import           Control.Applicative ((<|>))
import           Control.Monad (when)
import           Control.Monad.Except (throwError)
import           Data.Bits (shiftR, (.&.))
import           Data.Char (intToDigit)
import qualified Data.ByteString


@@ 57,7 56,7 @@ beginStream jid = do
	M.putBytes $ C.xmlHeader (s"jabber:component:accept") jid
	events <- M.readEvents C.startOfStream
	case parseStreamID $ last events of
		Nothing -> throwError M.NoComponentStreamID
		Nothing -> M.throwE M.NoComponentStreamID
		Just x -> return x

parseStreamID :: X.Event -> Maybe Text


@@ 75,7 74,7 @@ authenticate streamID password = do
	M.putElement (X.element (s"handshake") [] [X.NodeContent (X.ContentText digest)])
	result <- M.getElement
	let nameHandshake = s"{jabber:component:accept}handshake"
	when (null (X.isNamed nameHandshake result)) (throwError (M.AuthenticationFailure result))
	when (null (X.isNamed nameHandshake result)) (M.throwE (M.AuthenticationFailure result))

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

D lib/Network/Protocol/XMPP/ErrorT.hs => lib/Network/Protocol/XMPP/ErrorT.hs +0 -87
@@ 1,87 0,0 @@
{-# LANGUAGE TypeFamilies #-}

-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
-- 
-- 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
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Network.Protocol.XMPP.ErrorT
	( ErrorT (..)
	, mapErrorT
	) where

import           Control.Applicative (Applicative, pure, (<*>))
import           Control.Monad.Fix (MonadFix, mfix)
import           Control.Monad.Trans (MonadIO, liftIO)
import           Control.Monad.Trans.Class (MonadTrans, lift)
import qualified Control.Monad.Except as E
import           Control.Monad.Except (ErrorType)
import qualified Control.Monad.Reader as R
import           Control.Monad.Reader (EnvType)

-- A custom version of ErrorT, without the 'Error' class restriction.

newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }

instance Functor m => Functor (ErrorT e m) where
	fmap f = ErrorT . fmap (fmap f) . runErrorT

instance (Functor m, Monad m) => Applicative (ErrorT e m) where
	pure a  = ErrorT $ return (Right a)
	f <*> v = ErrorT $ do
		mf <- runErrorT f
		case mf of
			Left  e -> return (Left e)
			Right k -> do
				mv <- runErrorT v
				case mv of
					Left  e -> return (Left e)
					Right x -> return (Right (k x))

instance Monad m => Monad (ErrorT e m) where
	return = ErrorT . return . Right
	(>>=) m k = ErrorT $ do
		x <- runErrorT m
		case x of
			Left l -> return (Left l)
			Right r -> runErrorT (k r)

instance Monad m => E.MonadError (ErrorT e m) where
	type ErrorType (ErrorT e m) = e
	throwError = ErrorT . return . Left
	catchError m h = ErrorT $ do
		x <- runErrorT m
		case x of
			Left l -> runErrorT (h l)
			Right r -> return (Right r)

instance MonadTrans (ErrorT e) where
	lift = ErrorT . fmap Right

instance R.MonadReader m => R.MonadReader (ErrorT e m) where
	type EnvType (ErrorT e m) = EnvType m
	ask = lift R.ask
	local = mapErrorT . R.local

instance MonadIO m => MonadIO (ErrorT e m) where
	liftIO = lift . liftIO

instance MonadFix m => MonadFix (ErrorT e m) where
	mfix f = ErrorT $ mfix $ \ex -> runErrorT $ f $ case ex of
		Right x -> x
		_        -> error "empty mfix parameter"

mapErrorT :: (m (Either e a) -> n (Either e' b))
           -> ErrorT e m a
           -> ErrorT e' n b
mapErrorT f m = ErrorT (f (runErrorT m))

M lib/Network/Protocol/XMPP/Handle.hs => lib/Network/Protocol/XMPP/Handle.hs +11 -12
@@ 22,8 22,8 @@ module Network.Protocol.XMPP.Handle
	) where

import           Control.Monad (when, void)
import qualified Control.Monad.Except as E
import           Control.Monad.Trans (liftIO)
import qualified Control.Monad.Trans.Except as E
import           Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy


@@ 31,36 31,35 @@ 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.String (s)

data Handle =
	  PlainHandle IO.Handle
	| SecureHandle IO.Handle TLS.Session

liftTLS :: TLS.Session -> TLS.TLS a -> ErrorT Text IO a
liftTLS :: TLS.Session -> TLS.TLS a -> E.ExceptT Text IO a
liftTLS session = liftTLS' . TLS.runTLS session

liftTLS' :: IO (Either TLS.Error a) -> ErrorT Text IO a
liftTLS' :: IO (Either TLS.Error a) -> E.ExceptT Text IO a
liftTLS' io = do
	eitherX <- liftIO io
	case eitherX of
		Left err -> E.throwError (Data.Text.pack (show err))
		Left err -> E.throwE (Data.Text.pack (show err))
		Right x -> return x

startTLS :: Handle -> ErrorT Text IO Handle
startTLS (SecureHandle _ _) = E.throwError $ s"Can't start TLS on a secure handle"
startTLS :: Handle -> E.ExceptT Text IO Handle
startTLS (SecureHandle _ _) = E.throwE $ 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
	SecureHandle h `fmap` TLS.getSession

hPutBytes :: Handle -> ByteString -> ErrorT Text IO ()
hPutBytes :: Handle -> ByteString -> E.ExceptT Text IO ()
hPutBytes (PlainHandle h)  = liftIO . Data.ByteString.hPut h
hPutBytes (SecureHandle _ session) = liftTLS session . TLS.putBytes . toLazy where
	toLazy bytes = Data.ByteString.Lazy.fromChunks [bytes]

hGetBytes :: Handle -> Integer -> ErrorT Text IO ByteString
hGetBytes :: Handle -> Integer -> E.ExceptT Text IO ByteString
hGetBytes (PlainHandle h) n = liftIO (Data.ByteString.hGet h (fromInteger n))
hGetBytes (SecureHandle h session) n = liftTLS session $ do
	pending <- TLS.checkPending


@@ 68,9 67,9 @@ hGetBytes (SecureHandle h session) n = liftTLS session $ do
	when (pending == 0) (liftIO wait)
	Data.ByteString.concat . Data.ByteString.Lazy.toChunks <$> getBytes
	where
	getBytes = TLS.getBytes n `E.catchError` handleGetBytesErr
	getBytes = TLS.getBytes n `E.catchE` handleGetBytesErr
	handleGetBytesErr (TLS.Error (-28)) = getBytes
	handleGetBytesErr e = E.throwError e
	handleGetBytesErr e = E.throwE e

handleIsSecure :: Handle -> Bool
handleIsSecure PlainHandle{} = False

M lib/Network/Protocol/XMPP/Monad.hs => lib/Network/Protocol/XMPP/Monad.hs +23 -23
@@ 1,5 1,3 @@
{-# LANGUAGE TypeFamilies #-}

-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify


@@ 22,6 20,8 @@ module Network.Protocol.XMPP.Monad
	, runXMPP
	, startXMPP
	, restartXMPP
        , throwE
        , catchE

	, getHandle
	, getSession


@@ 41,16 41,15 @@ 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 qualified Control.Monad.Except as E
import           Control.Monad.Except (ErrorType)
import qualified Control.Monad.Reader as R
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.Except as E
import qualified Control.Monad.Trans.Reader as R
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
import qualified Network.Protocol.XMPP.Stanza as S
import qualified Network.Protocol.XMPP.XML as X


@@ 90,7 89,7 @@ data Session = Session
	, sessionWriteLock :: M.MVar ()
	}

newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Session IO) a }
newtype XMPP a = XMPP { unXMPP :: E.ExceptT Error (R.ReaderT Session IO) a }

instance Functor XMPP where
	fmap f = XMPP . fmap f . unXMPP


@@ 102,11 101,6 @@ instance Monad XMPP where
instance MonadIO XMPP where
	liftIO = XMPP . liftIO

instance E.MonadError XMPP where
	type ErrorType XMPP = Error
	throwError = XMPP . E.throwError
	catchError m h = XMPP (E.catchError (unXMPP m) (unXMPP . h))

instance A.Applicative XMPP where
	pure = return
	(<*>) = ap


@@ 115,7 109,7 @@ instance MonadFix XMPP where
	mfix f = XMPP (mfix (unXMPP . f))

runXMPP :: Session -> XMPP a -> IO (Either Error a)
runXMPP session xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) session
runXMPP session xmpp = R.runReaderT (E.runExceptT (unXMPP xmpp)) session

startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)
startXMPP h ns xmpp = do


@@ 129,7 123,7 @@ restartXMPP newH xmpp = do
	Session oldH ns _ readLock writeLock <- getSession
	sax <- liftIO X.newParser
	let session = Session (fromMaybe oldH newH) ns sax readLock writeLock
	XMPP (R.local (const session) (unXMPP xmpp))
	XMPP $ E.ExceptT $ (R.local (const session) (E.runExceptT $ unXMPP xmpp))

withLock :: (Session -> M.MVar ()) -> XMPP a -> XMPP a
withLock getLock xmpp = do


@@ 137,11 131,11 @@ withLock getLock xmpp = do
	let mvar = getLock session
	res <- liftIO (M.withMVar mvar (const $ runXMPP session xmpp))
	case res of
		Left err -> E.throwError err
		Left err -> XMPP $ E.throwE err
		Right x -> return x

getSession :: XMPP Session
getSession = XMPP R.ask
getSession = XMPP $ lift $ R.ask

getHandle :: XMPP H.Handle
getHandle = fmap sessionHandle getSession


@@ 149,11 143,11 @@ getHandle = fmap sessionHandle getSession
sessionIsSecure :: XMPP Bool
sessionIsSecure = H.handleIsSecure <$> getHandle

liftTLS :: ErrorT Text IO a -> XMPP a
liftTLS :: E.ExceptT Text IO a -> XMPP a
liftTLS io = do
	res <- liftIO (runErrorT io)
	res <- liftIO (E.runExceptT io)
	case res of
		Left err -> E.throwError (TransportError err)
		Left err -> XMPP $ E.throwE (TransportError err)
		Right x -> return x

putBytes :: ByteString -> XMPP ()


@@ 177,7 171,7 @@ readEvents done = xmpp where
			let eof = Data.ByteString.null bytes
			parsed <- liftIO (X.parse p bytes eof)
			case parsed of
				Left err -> E.throwError (TransportError err)
				Left err -> XMPP $ E.throwE (TransportError err)
				Right events -> return events
		X.readEvents done nextEvents



@@ 187,7 181,7 @@ getElement = xmpp where
		events <- readEvents endOfTree
		case X.eventsToElement events of
			Just x -> return x
			Nothing -> E.throwError (TransportError $ s"getElement: invalid event list")
			Nothing -> XMPP $ E.throwE (TransportError $ s"getElement: invalid event list")

	endOfTree 0 (X.EventEndElement _) = True
	endOfTree _ _ = False


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

throwE :: Error -> XMPP a
throwE = XMPP . E.throwE

catchE :: XMPP a -> (Error -> XMPP a) -> XMPP a
catchE (XMPP m) h = XMPP (m `E.catchE` (unXMPP . h))

M network-protocol-xmpp.cabal => network-protocol-xmpp.cabal +0 -2
@@ 35,7 35,6 @@ library
    , gnutls >= 0.1.4 && < 0.3
    , gsasl >= 0.3 && < 0.4
    , libxml-sax >= 0.7 && < 0.8
    , monads-tf >= 0.1 && < 0.2
    , network >= 3.0 && < 4.0
    , network-simple >= 0.4 && < 0.5
    , text >= 0.10


@@ 52,7 51,6 @@ library
    Network.Protocol.XMPP.Client.Features
    Network.Protocol.XMPP.Component
    Network.Protocol.XMPP.Connections
    Network.Protocol.XMPP.ErrorT
    Network.Protocol.XMPP.Handle
    Network.Protocol.XMPP.JID
    Network.Protocol.XMPP.Monad