From 41fd64db3f25b4e3f25b79c755cee45d71c694b1 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 19 Feb 2013 16:05:56 +0100 Subject: [PATCH] remove superfluous modules --- source/Network/Xmpp/Basic.hs | 23 -- .../Network/Xmpp/Concurrent/Channels/Types.hs | 32 -- source/Network/Xmpp/Connection_.hs | 285 ------------------ source/Network/Xmpp/Errors.hs | 49 --- source/Network/Xmpp/Pickle.hs | 45 --- source/Network/Xmpp/Session.hs | 116 ------- 6 files changed, 550 deletions(-) delete mode 100644 source/Network/Xmpp/Basic.hs delete mode 100644 source/Network/Xmpp/Concurrent/Channels/Types.hs delete mode 100644 source/Network/Xmpp/Connection_.hs delete mode 100644 source/Network/Xmpp/Errors.hs delete mode 100644 source/Network/Xmpp/Pickle.hs delete mode 100644 source/Network/Xmpp/Session.hs diff --git a/source/Network/Xmpp/Basic.hs b/source/Network/Xmpp/Basic.hs deleted file mode 100644 index 121e980..0000000 --- a/source/Network/Xmpp/Basic.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Network.Xmpp.Basic - ( Connection(..) - , ConnectionState(..) - , connectTcp - , simpleConnect - , startTLS - , exampleParams - , simpleAuth - , auth - , scramSha1 - , digestMd5 - , plain - , pushStanza - , pullStanza - ) - - where - -import Network.Xmpp.Connection -import Network.Xmpp.Sasl -import Network.Xmpp.Session -import Network.Xmpp.TLS -import Network.Xmpp.Types diff --git a/source/Network/Xmpp/Concurrent/Channels/Types.hs b/source/Network/Xmpp/Concurrent/Channels/Types.hs deleted file mode 100644 index 1be179e..0000000 --- a/source/Network/Xmpp/Concurrent/Channels/Types.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.Concurrent.Channels.Types where - -import Control.Concurrent.STM -import Data.IORef -import qualified Data.Map as Map -import Data.Text (Text) -import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Types - --- | An XMPP session context -data Session = Session - { context :: Context - , stanzaCh :: TChan Stanza -- All stanzas - , outCh :: TChan Stanza - , iqHandlers :: TVar IQHandlers - -- Writing lock, so that only one thread could write to the stream at any - -- given time. - } - --- | IQHandlers holds the registered channels for incomming IQ requests and --- TMVars of and TMVars for expected IQ responses -type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) - , Map.Map StanzaID (TMVar IQResponse) - ) - --- | Contains whether or not a reply has been sent, and the IQ request body to --- reply to. -data IQRequestTicket = IQRequestTicket - { sentRef :: (TVar Bool) - , iqRequestBody :: IQRequest - } diff --git a/source/Network/Xmpp/Connection_.hs b/source/Network/Xmpp/Connection_.hs deleted file mode 100644 index a577175..0000000 --- a/source/Network/Xmpp/Connection_.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Xmpp.Connection_ where - -import Control.Applicative((<$>)) -import Control.Concurrent (forkIO, threadDelay) -import System.IO.Error (tryIOError) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class ---import Control.Monad.Trans.Resource -import qualified Control.Exception.Lifted as Ex -import qualified GHC.IO.Exception as GIE -import Control.Monad.State.Strict - -import Data.ByteString as BS -import Data.ByteString.Char8 as BSC8 -import Data.Conduit -import Data.Conduit.Binary as CB -import Data.Conduit.Internal as DCI -import qualified Data.Conduit.List as CL -import Data.IORef -import Data.Text(Text) -import qualified Data.Text as T -import Data.XML.Pickle -import Data.XML.Types - -import Network -import Network.Xmpp.Types -import Network.Xmpp.Marshal -import Network.Xmpp.Pickle - -import System.IO - -import Text.Xml.Stream.Elements -import Text.XML.Stream.Parse as XP -import Text.XML.Unresolved(InvalidEventStream(..)) - -import System.Log.Logger -import Data.ByteString.Base64 - -import Control.Concurrent.STM.TMVar -import Control.Monad.Error - --- Enable/disable debug output --- This will dump all incoming and outgoing network taffic to the console, --- prefixed with "in: " and "out: " respectively -debug :: Bool -debug = False - --- TODO: Can the TLS send/recv functions throw something other than an IO error? - -wrapIOException :: IO a -> StateT Connection IO (Either XmppFailure a) -wrapIOException action = do - r <- liftIO $ tryIOError action - case r of - Right b -> return $ Right b - Left e -> return $ Left $ XmppIOException e - -pushElement :: Element -> StateT Connection IO (Either XmppFailure Bool) -pushElement x = do - send <- gets (cSend . cHandle) - wrapIOException $ send $ renderElement x - --- | Encode and send stanza -pushStanza :: Stanza -> TMVar Connection -> IO (Either XmppFailure Bool) -pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s - --- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. --- UTF-8 is the only supported XMPP encoding. The standalone document --- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in --- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. -pushXmlDecl :: StateT Connection IO (Either XmppFailure Bool) -pushXmlDecl = do - con <- gets cHandle - wrapIOException $ (cSend con) "" - -pushOpenElement :: Element -> StateT Connection IO (Either XmppFailure Bool) -pushOpenElement e = do - sink <- gets (cSend . cHandle) - wrapIOException $ sink $ renderOpenElement e - --- `Connect-and-resumes' the given sink to the connection source, and pulls a --- `b' value. -runEventsSink :: Sink Event IO b -> StateT Connection IO (Either XmppFailure b) -runEventsSink snk = do -- TODO: Wrap exceptions? - source <- gets cEventSource - (src', r) <- lift $ source $$++ snk - modify (\s -> s{cEventSource = src'}) - return $ Right r - -pullElement :: StateT Connection IO (Either XmppFailure Element) -pullElement = do - Ex.catches (do - e <- runEventsSink (elements =$ await) - case e of - Left f -> return $ Left f - Right Nothing -> return $ Left XmppOtherFailure -- TODO - Right (Just r) -> return $ Right r - ) - [ Ex.Handler (\StreamEnd -> return $ Left StreamEndFailure) - , Ex.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag - -> return $ Left XmppOtherFailure) -- TODO: Log: s - , Ex.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception - -> return $ Left XmppOtherFailure -- TODO: Log: (show e) - ] - --- Pulls an element and unpickles it. -pullUnpickle :: PU [Node] a -> StateT Connection IO (Either XmppFailure a) -pullUnpickle p = do - elem <- pullElement - case elem of - Left e -> return $ Left e - Right elem' -> do - let res = unpickleElem p elem' - case res of - Left e -> return $ Left XmppOtherFailure -- TODO: Log - Right r -> return $ Right r - --- | Pulls a stanza (or stream error) from the stream. -pullStanza :: TMVar Connection -> IO (Either XmppFailure Stanza) -pullStanza = withConnection' $ do - res <- pullUnpickle xpStreamStanza - case res of - Left e -> return $ Left e - Right (Left e) -> return $ Left $ StreamErrorFailure e - Right (Right r) -> return $ Right r - --- Performs the given IO operation, catches any errors and re-throws everything --- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead -catchPush :: IO () -> IO Bool -catchPush p = Ex.catch - (p >> return True) - (\e -> case GIE.ioe_type e of - GIE.ResourceVanished -> return False - GIE.IllegalOperation -> return False - _ -> Ex.throwIO e - ) - --- Connection state used when there is no connection. -xmppNoConnection :: Connection -xmppNoConnection = Connection - { cHandle = ConnectionHandle { cSend = \_ -> return False - , cRecv = \_ -> Ex.throwIO - XmppOtherFailure - , cFlush = return () - , cClose = return () - } - , cEventSource = DCI.ResumableSource zeroSource (return ()) - , cFeatures = SF Nothing [] [] - , cState = ConnectionClosed - , cHostName = Nothing - , cJid = Nothing - , cStreamLang = Nothing - , cStreamId = Nothing - , cPreferredLang = Nothing - , cToJid = Nothing - , cJidWhenPlain = False - , cFrom = Nothing - } - where - zeroSource :: Source IO output - zeroSource = liftIO . Ex.throwIO $ XmppOtherFailure - -connectTcp :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Connection)) -connectTcp host port hostname = do - let PortNumber portNumber = port - debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ - (show portNumber) ++ " through the realm " ++ (T.unpack hostname) ++ "." - h <- connectTo host port - debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." - hSetBuffering h NoBuffering - let eSource = DCI.ResumableSource - ((sourceHandle h $= logConduit) $= XP.parseBytes def) - (return ()) - let hand = ConnectionHandle { cSend = \d -> do - let d64 = encode d - debugM "Pontarius.Xmpp" $ - "Sending TCP data: " ++ (BSC8.unpack d64) - ++ "." - catchPush $ BS.hPut h d - , cRecv = \n -> do - d <- BS.hGetSome h n - let d64 = encode d - debugM "Pontarius.Xmpp" $ - "Received TCP data: " ++ - (BSC8.unpack d64) ++ "." - return d - , cFlush = hFlush h - , cClose = hClose h - } - let con = Connection - { cHandle = hand - , cEventSource = eSource - , cFeatures = (SF Nothing [] []) - , cState = ConnectionPlain - , cHostName = (Just hostname) - , cJid = Nothing - , cPreferredLang = Nothing -- TODO: Allow user to set - , cStreamLang = Nothing - , cStreamId = Nothing - , cToJid = Nothing -- TODO: Allow user to set - , cJidWhenPlain = False -- TODO: Allow user to set - , cFrom = Nothing - } - con' <- mkConnection con - return $ Right con' - where - logConduit :: Conduit ByteString IO ByteString - logConduit = CL.mapM $ \d -> do - let d64 = encode d - debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d64) ++ - "." - return d - - --- Closes the connection and updates the XmppConMonad Connection state. --- killConnection :: TMVar Connection -> IO (Either Ex.SomeException ()) -killConnection :: TMVar Connection -> IO (Either XmppFailure ()) -killConnection = withConnection $ do - cc <- gets (cClose . cHandle) - err <- wrapIOException cc - -- (Ex.try cc :: IO (Either Ex.SomeException ())) - put xmppNoConnection - return err - --- Sends an IQ request and waits for the response. If the response ID does not --- match the outgoing ID, an error is thrown. -pushIQ' :: StanzaID - -> Maybe Jid - -> IQRequestType - -> Maybe LangTag - -> Element - -> TMVar Connection - -> IO (Either XmppFailure (Either IQError IQResult)) -pushIQ' iqID to tp lang body con = do - pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) con - res <- pullStanza con - case res of - Left e -> return $ Left e - Right (IQErrorS e) -> return $ Right $ Left e - Right (IQResultS r) -> do - unless - (iqID == iqResultID r) . liftIO . Ex.throwIO $ - XmppOtherFailure - -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ - -- " /= " ++ show (iqResultID r) ++ " .") - return $ Right $ Right r - _ -> return $ Left XmppOtherFailure - -- TODO: Log: "sendIQ': unexpected stanza type " - --- | Send "" and wait for the server to finish processing and to --- close the connection. Any remaining elements from the server are returned. --- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. -closeStreams :: TMVar Connection -> IO (Either XmppFailure [Element]) -closeStreams = withConnection $ do - send <- gets (cSend . cHandle) - cc <- gets (cClose . cHandle) - liftIO $ send "" - void $ liftIO $ forkIO $ do - threadDelay 3000000 -- TODO: Configurable value - (Ex.try cc) :: IO (Either Ex.SomeException ()) - return () - collectElems [] - where - -- Pulls elements from the stream until the stream ends, or an error is - -- raised. - collectElems :: [Element] -> StateT Connection IO (Either XmppFailure [Element]) - collectElems es = do - result <- pullElement - case result of - Left StreamEndFailure -> return $ Right es - Left e -> return $ Left $ StreamCloseError (es, e) - Right e -> collectElems (e:es) - -debugConduit :: Pipe l ByteString ByteString u IO b -debugConduit = forever $ do - s' <- await - case s' of - Just s -> do - liftIO $ BS.putStrLn (BS.append "in: " s) - yield s - Nothing -> return () diff --git a/source/Network/Xmpp/Errors.hs b/source/Network/Xmpp/Errors.hs deleted file mode 100644 index 9dbecb3..0000000 --- a/source/Network/Xmpp/Errors.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Errors where - -import Control.Applicative ((<$>)) -import Control.Monad(unless) -import Control.Monad.Error -import Control.Monad.Error.Class -import qualified Data.Text as Text -import Data.XML.Types -import Network.Xmpp.Types -import Network.Xmpp.Pickle - - --- Finds unpickling problems. Not to be used for data validation -findStreamErrors :: Element -> StreamError -findStreamErrors (Element name attrs children) - | (nameLocalName name /= "stream") - = StreamNotStreamElement $ nameLocalName name - | (nameNamespace name /= Just "http://etherx.jabber.org/streams") - = StreamInvalidStreamNamespace $ nameNamespace name - | otherwise = checkchildren (flattenAttrs attrs) - where - checkchildren children = - let to' = lookup "to" children - ver' = lookup "version" children - xl = lookup xmlLang children - in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') - -> StreamWrongTo to' - | Nothing == ver' - -> StreamWrongVersion Nothing - | Just (Nothing :: Maybe LangTag) == - (safeRead <$> xl) - -> StreamWrongLangTag xl - | otherwise - -> StreamUnknownError - safeRead x = case reads $ Text.unpack x of - [] -> Nothing - ((y,_):_) -> Just y - -flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] -flattenAttrs attrs = map (\(name, content) -> - ( name - , Text.concat $ map uncontentify content) - ) - attrs - where - uncontentify (ContentText t) = t - uncontentify _ = "" diff --git a/source/Network/Xmpp/Pickle.hs b/source/Network/Xmpp/Pickle.hs deleted file mode 100644 index b9291d0..0000000 --- a/source/Network/Xmpp/Pickle.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - --- Marshalling between XML and Native Types - - -module Network.Xmpp.Pickle - ( xmlLang - , xpLangTag - , unpickleElem' - , unpickleElem - , pickleElem - ) - where - -import Data.XML.Types -import Data.XML.Pickle - -import Network.Xmpp.Types - -import Text.Xml.Stream.Elements - -xmlLang :: Name -xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") - -xpLangTag :: PU [Attribute] (Maybe LangTag) -xpLangTag = xpAttrImplied xmlLang xpPrim - --- Given a pickler and an element, produces an object. -unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a -unpickleElem p x = unpickle p [NodeElement x] - -unpickleElem' :: PU [Node] c -> Element -> c -unpickleElem' p x = case unpickleElem p x of - Left l -> error $ (show l) ++ "\n saw: " ++ ppElement x - Right r -> r - --- Given a pickler and an object, produces an Element. -pickleElem :: PU [Node] a -> a -> Element -pickleElem p x = case pickle p x of - [NodeElement e] -> e - _ -> error "pickleElem: Pickler didn't return a single element." diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs deleted file mode 100644 index 3378468..0000000 --- a/source/Network/Xmpp/Session.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Session where - -import qualified Control.Exception as Ex -import Control.Monad.Error -import Data.Text as Text -import Data.XML.Pickle -import Data.XML.Types(Element) -import Network -import qualified Network.TLS as TLS -import Network.Xmpp.Bind -import Network.Xmpp.Concurrent.Types -import Network.Xmpp.Concurrent -import Network.Xmpp.Connection_ -import Network.Xmpp.Marshal -import Network.Xmpp.Pickle -import Network.Xmpp.Sasl -import Network.Xmpp.Sasl.Mechanisms -import Network.Xmpp.Sasl.Types -import Network.Xmpp.Stream -import Network.Xmpp.Tls -import Network.Xmpp.Types -import Control.Concurrent.STM.TMVar -import Data.Maybe - --- | Creates a 'Session' object by setting up a connection with an XMPP server. --- --- Will connect to the specified host. If the fourth parameters is a 'Just' --- value, @session@ will attempt to secure the connection with TLS. If the fifth --- parameters is a 'Just' value, @session@ will attempt to authenticate and --- acquire an XMPP resource. -session :: HostName -- ^ Host to connect to - -> Text -- ^ The realm host name (to - -- distinguish the XMPP service) - -> PortID -- ^ Port to connect to - -> Maybe TLS.TLSParams -- ^ TLS settings, if securing the - -- connection to the server is - -- desired - -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired - -- JID resource (or Nothing to let - -- the server decide) - -> IO (Either XmppFailure (Session, Maybe AuthFailure)) -session hostname realm port tls sasl = runErrorT $ do - con <- ErrorT $ connect hostname port realm - case tls of - Just tls' -> ErrorT $ startTls tls' con - Nothing -> return () - aut <- case sasl of - Just sasl' -> ErrorT $ auth (fst sasl) (snd sasl) con - Nothing -> return Nothing - ses <- ErrorT $ newSession con - return (ses, aut) - --- | Connects to the XMPP server and opens the XMPP stream against the given --- host name, port, and realm. -connect :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Connection)) -connect address port hostname = do - con <- connectTcp address port hostname - case con of - Right con' -> do - result <- withConnection startStream con' - return $ Right con' - Left e -> do - return $ Left e - -sessionXml :: Element -sessionXml = pickleElem - (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") - () - -sessionIQ :: Stanza -sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" - , iqRequestFrom = Nothing - , iqRequestTo = Nothing - , iqRequestLangTag = Nothing - , iqRequestType = Set - , iqRequestPayload = sessionXml - } - --- Sends the session IQ set element and waits for an answer. Throws an error if --- if an IQ error stanza is returned from the server. -startSession :: TMVar Connection -> IO () -startSession con = do - answer <- pushIQ' "session" Nothing Set Nothing sessionXml con - case answer of - Left e -> error $ show e - Right _ -> return () - --- | Authenticate to the server using the first matching method and bind a --- resource. -auth :: [SaslHandler] - -> Maybe Text - -> TMVar Connection - -> IO (Either XmppFailure (Maybe AuthFailure)) -auth mechanisms resource con = runErrorT $ do - ErrorT $ xmppSasl mechanisms con - jid <- lift $ xmppBind resource con - lift $ startSession con - return Nothing - --- | Authenticate to the server with the given username and password --- and bind a resource. --- --- Prefers SCRAM-SHA1 over DIGEST-MD5. -simpleAuth :: Text.Text -- ^ The username - -> Text.Text -- ^ The password - -> Maybe Text -- ^ The desired resource or 'Nothing' to let the - -- server assign one - -> TMVar Connection - -> IO (Either XmppFailure (Maybe AuthFailure)) -simpleAuth username passwd resource = flip auth resource $ - [ -- TODO: scramSha1Plus - scramSha1 username Nothing passwd - , digestMd5 username Nothing passwd - ]