packages feed

network-protocol-xmpp 0.4.10 → 0.5.2

raw patch · 9 files changed

Files

lib/Network/Protocol/XMPP.hs view
@@ -58,6 +58,8 @@ 	, putStanza 	, getStanza 	, bindJID+	, throwE+	, catchE  	-- ** Resuming sessions 	, Session
lib/Network/Protocol/XMPP/Client.hs view
@@ -19,8 +19,8 @@ 	) where  import           Control.Monad ((>=>))-import           Control.Monad.Error (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.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 @@ 		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 @@  	returnedJID <- case maybeJID of 		Just x -> return x-		Nothing -> throwError (M.InvalidBindResult bindResult)+		Nothing -> M.throwE (M.InvalidBindResult bindResult)  	-- Session 	M.putStanza sessionStanza
lib/Network/Protocol/XMPP/Client/Authentication.hs view
@@ -21,7 +21,6 @@ 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           Data.ByteString (ByteString) import qualified Data.ByteString.Char8 import qualified Data.Text@@ -49,7 +48,8 @@              -> Text -- ^ Password              -> M.XMPP () authenticate xmppMechanisms userJID serverJID username password = xmpp where-	mechanisms = map SASL.Mechanism xmppMechanisms+	-- Filter out PLUS mechanisms because we haven't implemented channel binding+	mechanisms = map SASL.Mechanism $ filter (not . ((Data.ByteString.Char8.pack "PLUS") `Data.ByteString.Char8.isSuffixOf`)) xmppMechanisms 	authz = formatJID (userJID { jidResource = Nothing }) 	hostname = formatJID serverJID @@ -62,9 +62,9 @@ 				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
lib/Network/Protocol/XMPP/Component.hs view
@@ -20,7 +20,8 @@  import           Control.Applicative ((<|>)) import           Control.Monad (when)-import           Control.Monad.Error (throwError)+import           Control.Monad.IO.Class (liftIO)+import qualified Control.Monad.Trans.Except as E import           Data.Bits (shiftR, (.&.)) import           Data.Char (intToDigit) import qualified Data.ByteString@@ -28,8 +29,8 @@ import qualified Data.Text import           Data.Text (Text) import           Data.Text.Encoding (encodeUtf8)-import           Network.Protocol.SASL.GNU (sha1) import qualified System.IO as IO+import qualified Network.Protocol.TLS.GNU as TLS (DigestAlgorithm(SHA1), hash)  import qualified Network.Protocol.XMPP.Connections as C import qualified Network.Protocol.XMPP.Handle as H@@ -57,7 +58,7 @@ 	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@@ -71,11 +72,15 @@ authenticate :: Text -> Text -> M.XMPP () authenticate streamID password = do 	let bytes = buildSecret streamID password-	let digest = showDigest (sha1 bytes)-	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))+	msha1 <- liftIO $ E.runExceptT $ TLS.hash TLS.SHA1 bytes+        case msha1 of+		Left e -> M.throwE (M.AuthenticationError (Data.Text.pack $ show e))+                Right sha1 -> do+			let digest = showDigest sha1+			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)) (M.throwE (M.AuthenticationFailure result))  buildSecret :: Text -> Text -> ByteString buildSecret sid password = encodeUtf8 (X.escape (Data.Text.append sid password))
− lib/Network/Protocol/XMPP/ErrorT.hs 
@@ -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.Error as E-import           Control.Monad.Error (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))
lib/Network/Protocol/XMPP/Handle.hs view
@@ -22,8 +22,8 @@ 	) where  import           Control.Monad (when, void)-import qualified Control.Monad.Error 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           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 @@ 	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
lib/Network/Protocol/XMPP/JID.hs view
@@ -30,6 +30,7 @@ import qualified Data.Text import           Data.Text (Text) import qualified Data.Text.IDN.StringPrep as SP+import qualified Data.Text.IDN.IDNA as IDNA import           Data.String (IsString, fromString)  newtype Node = Node { strNode :: Text }@@ -73,28 +74,32 @@  parseJID :: Text -> Maybe JID parseJID str = maybeJID where-	(node, postNode) = case textSpanBy (/= '@') str of+	(bare, resource) = case textSpanBy (/= '/') str of 		(x, y) -> if Data.Text.null y-			then (Data.Text.empty, x)-			else (x, Data.Text.drop 1 y)-	(domain, resource) = case textSpanBy (/= '/') postNode of+			then (x, Nothing)+			else (x, Just $ Data.Text.drop 1 y)+	(node, domain) = case textSpanBy (/= '@') bare of 		(x, y) -> if Data.Text.null y-			then (x, Data.Text.empty)-			else (x, Data.Text.drop 1 y)-	nullable x f = if Data.Text.null x-		then Just Nothing+			then (Nothing, x)+			else (Just x, Data.Text.drop 1 y)+	nullable Nothing _ = Just Nothing+	nullable (Just x) f = if Data.Text.null x+		then Nothing 		else fmap Just (f x) 	maybeJID = do 		preppedNode <- nullable node (stringprepM SP.xmppNode)-		preppedDomain <- stringprepM SP.nameprep domain+		preppedDomain <- fmap (IDNA.toUnicode IDNA.defaultFlags)+			(rightToJust $ IDNA.toASCII IDNA.defaultFlags domain) 		preppedResource <- nullable resource (stringprepM SP.xmppResource)-		return $ JID-			(fmap Node preppedNode)-			(Domain preppedDomain)-			(fmap Resource preppedResource)-	stringprepM p x = case SP.stringprep p SP.defaultFlags x of-		Left _ -> Nothing-		Right y -> Just y+		if Data.Text.null preppedDomain+			then Nothing+			else return $ JID+				(fmap Node preppedNode)+				(Domain preppedDomain)+				(fmap Resource preppedResource)+	rightToJust (Left _) = Nothing+	rightToJust (Right y) = Just y+	stringprepM p x = rightToJust $ SP.stringprep p SP.defaultFlags x  parseJID_ :: Text -> JID parseJID_ = fromMaybe (error "Malformed JID") . parseJID
lib/Network/Protocol/XMPP/Monad.hs view
@@ -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 @@ 	, runXMPP 	, startXMPP 	, restartXMPP+        , throwE+        , catchE  	, getHandle 	, getSession@@ -41,16 +41,15 @@ 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.Error as E-import           Control.Monad.Error (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 @@ 	, 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 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 @@ 	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 @@ 	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 @@ 	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 @@ 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 @@ 			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 @@ 		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 @@ 	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))
network-protocol-xmpp.cabal view
@@ -1,5 +1,5 @@ name: network-protocol-xmpp-version: 0.4.10+version: 0.5.2 license: GPL-3 license-file: COPYING author: John Millikin <jmillikin@gmail.com>, Stephan Maka <stephan@spaceboyz.net>@@ -21,7 +21,7 @@ source-repository this   type: git   location: https://git.sr.ht/~singpolyma/network-protocol-xmpp-  tag: 0.4.9+  tag: 0.5.2  library   default-language: Haskell2010@@ -32,10 +32,9 @@       base >= 4.0 && < 5.0     , bytestring >= 0.9     , gnuidn >= 0.2 && < 0.3-    , gnutls >= 0.1.4 && < 0.3-    , gsasl >= 0.3 && < 0.4+    , gnutls >= 0.1.4 && < 0.5+    , gsasl >= 0.3 && < 0.6     , 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 @@     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