asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

replace XMPP with Xmpp everywhere to unify style 

replace SASL with Sasl
replace DIGEST_MD5 with DigestMD5
replace PLAIN with Plain
master
Philipp Balzarek 14 years ago
parent
188cc252d3
commit
d23ae0f149
32 changed files with 258 additions and 255 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 8
      examples/EchoClient.hs
  2. 12
      examples/Example.hs
  3. 2
      examples/IBR.hs
  4. 41
      pontarius.cabal
  5. 13
      source/Network/XMPP/Concurrent.hs
  6. 7
      source/Network/XMPP/IM.hs
  7. 34
      source/Network/Xmpp.hs
  8. 10
      source/Network/Xmpp/Bind.hs
  9. 13
      source/Network/Xmpp/Concurrent.hs
  10. 14
      source/Network/Xmpp/Concurrent/IQ.hs
  11. 60
      source/Network/Xmpp/Concurrent/Monad.hs
  12. 22
      source/Network/Xmpp/Concurrent/Threads.hs
  13. 14
      source/Network/Xmpp/Concurrent/Types.hs
  14. 7
      source/Network/Xmpp/IM.hs
  15. 6
      source/Network/Xmpp/IM/Message.hs
  16. 4
      source/Network/Xmpp/IM/Presence.hs
  17. 2
      source/Network/Xmpp/JID.hs
  18. 6
      source/Network/Xmpp/Marshal.hs
  19. 4
      source/Network/Xmpp/Message.hs
  20. 36
      source/Network/Xmpp/Monad.hs
  21. 4
      source/Network/Xmpp/Pickle.hs
  22. 4
      source/Network/Xmpp/Presence.hs
  23. 24
      source/Network/Xmpp/Sasl.hs
  24. 24
      source/Network/Xmpp/Sasl/DigestMD5.hs
  25. 16
      source/Network/Xmpp/Sasl/Plain.hs
  26. 6
      source/Network/Xmpp/Sasl/Sasl.hs
  27. 4
      source/Network/Xmpp/Sasl/Types.hs
  28. 14
      source/Network/Xmpp/Session.hs
  29. 12
      source/Network/Xmpp/Stream.hs
  30. 20
      source/Network/Xmpp/TLS.hs
  31. 30
      source/Network/Xmpp/Types.hs
  32. 4
      source/Network/Xmpp/Utilities.hs

8
examples/EchoClient.hs
Unescape View File

@ -19,8 +19,8 @@ import Control.Monad (forever)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromJust, isJust) import Data.Maybe (fromJust, isJust)
import Network.XMPP import Network.Xmpp
import Network.XMPP.IM import Network.Xmpp.IM
-- Server and authentication details. -- Server and authentication details.
@ -47,9 +47,9 @@ main = do
return () return ()
return () return ()
-- Pull message stanzas, verify that they originate from a `full' XMPP -- Pull message stanzas, verify that they originate from a `full' Xmpp
-- address, and, if so, `echo' the message back. -- address, and, if so, `echo' the message back.
echo :: XMPP () echo :: Xmpp ()
echo = forever $ do echo = forever $ do
result <- pullMessage result <- pullMessage
case result of case result of

12
examples/Example.hs
Unescape View File

@ -3,7 +3,7 @@ module Example where
import Data.Text as T import Data.Text as T
import Network.XMPP import Network.Xmpp
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad import Control.Monad
@ -12,10 +12,10 @@ import Control.Monad.IO.Class
philonous :: JID philonous :: JID
philonous = read "uart14@species64739.dyndns.org" philonous = read "uart14@species64739.dyndns.org"
attXmpp :: STM a -> XMPPThread a attXmpp :: STM a -> XmppThread a
attXmpp = liftIO . atomically attXmpp = liftIO . atomically
autoAccept :: XMPPThread () autoAccept :: XmppThread ()
autoAccept = forever $ do autoAccept = forever $ do
st <- pullPresence st <- pullPresence
case st of case st of
@ -24,7 +24,7 @@ autoAccept = forever $ do
Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing []
_ -> return () _ -> return ()
mirror :: XMPPThread () mirror :: XmppThread ()
mirror = forever $ do mirror = forever $ do
st <- pullMessage st <- pullMessage
case st of case st of
@ -43,8 +43,8 @@ main = do
xmppThreadedBind (Just "botsi") xmppThreadedBind (Just "botsi")
-- singleThreaded $ xmppBind (Just "botsi") -- singleThreaded $ xmppBind (Just "botsi")
singleThreaded $ xmppSession singleThreaded $ xmppSession
forkXMPP autoAccept forkXmpp autoAccept
forkXMPP mirror forkXmpp mirror
sendS . SPresence $ Presence Nothing Nothing Nothing Nothing sendS . SPresence $ Presence Nothing Nothing Nothing Nothing
(Just Available) Nothing Nothing [] (Just Available) Nothing Nothing []
sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing

2
examples/IBR.hs
Unescape View File

@ -11,7 +11,7 @@ this file may be used freely, as if it is in the public domain.
module Examples.IBR () where module Examples.IBR () where
import Network.XMPP import Network.Xmpp
-- Server and authentication details. -- Server and authentication details.

41
pontarius.cabal
Unescape View File

@ -50,26 +50,29 @@ Library
, xml-types-pickle -any , xml-types-pickle -any
, data-default -any , data-default -any
, stringprep >= 0.1.5 , stringprep >= 0.1.5
Exposed-modules: Network.XMPP Exposed-modules: Network.Xmpp
, Network.XMPP.Bind , Network.Xmpp.Bind
, Network.XMPP.Concurrent , Network.Xmpp.Concurrent
, Network.XMPP.IM , Network.Xmpp.IM
, Network.XMPP.Marshal , Network.Xmpp.Marshal
, Network.XMPP.Monad , Network.Xmpp.Monad
, Network.XMPP.Message , Network.Xmpp.Message
, Network.XMPP.Pickle , Network.Xmpp.Pickle
, Network.XMPP.Presence , Network.Xmpp.Presence
, Network.XMPP.SASL , Network.Xmpp.Sasl
, Network.XMPP.Session , Network.Xmpp.Sasl.Plain
, Network.XMPP.Stream , Network.Xmpp.Sasl.DigestMD5
, Network.XMPP.TLS , Network.Xmpp.Sasl.Types
, Network.XMPP.Types , Network.Xmpp.Session
, Network.Xmpp.Stream
, Network.Xmpp.TLS
, Network.Xmpp.Types
Other-modules: Other-modules:
Network.XMPP.JID Network.Xmpp.JID
, Network.XMPP.Concurrent.Types , Network.Xmpp.Concurrent.Types
, Network.XMPP.Concurrent.IQ , Network.Xmpp.Concurrent.IQ
, Network.XMPP.Concurrent.Threads , Network.Xmpp.Concurrent.Threads
, Network.XMPP.Concurrent.Monad , Network.Xmpp.Concurrent.Monad
, Text.XML.Stream.Elements , Text.XML.Stream.Elements
, Data.Conduit.BufferedSource , Data.Conduit.BufferedSource
, Data.Conduit.TLS , Data.Conduit.TLS

13
source/Network/XMPP/Concurrent.hs
Unescape View File

@ -1,13 +0,0 @@
module Network.XMPP.Concurrent
( Session
, XMPP
, module Network.XMPP.Concurrent.Monad
, module Network.XMPP.Concurrent.Threads
, module Network.XMPP.Concurrent.IQ
) where
import Network.XMPP.Concurrent.Types
import Network.XMPP.Concurrent.Monad
import Network.XMPP.Concurrent.Threads
import Network.XMPP.Concurrent.IQ

7
source/Network/XMPP/IM.hs
Unescape View File

@ -1,7 +0,0 @@
module Network.XMPP.IM
( module Network.XMPP.IM.Message
, module Network.XMPP.IM.Presence
) where
import Network.XMPP.IM.Message
import Network.XMPP.IM.Presence

34
source/Network/XMPP.hs → source/Network/Xmpp.hs
Unescape View File

@ -21,7 +21,7 @@
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
module Network.XMPP module Network.Xmpp
( -- * Session management ( -- * Session management
withNewSession withNewSession
, withSession , withSession
@ -96,7 +96,7 @@ module Network.XMPP
, Presence(..) , Presence(..)
, PresenceError(..) , PresenceError(..)
-- *** creating -- *** creating
, module Network.XMPP.Presence , module Network.Xmpp.Presence
-- *** sending -- *** sending
, sendPresence , sendPresence
-- *** receiving -- *** receiving
@ -127,7 +127,7 @@ module Network.XMPP
, iqRequestPayload , iqRequestPayload
, iqResultPayload , iqResultPayload
-- * Threads -- * Threads
, XMPP , Xmpp
, fork , fork
, forkSession , forkSession
-- * Misc -- * Misc
@ -138,23 +138,23 @@ import Data.Text as Text
import Network import Network
import qualified Network.TLS as TLS import qualified Network.TLS as TLS
import Network.XMPP.Bind import Network.Xmpp.Bind
import Network.XMPP.Concurrent import Network.Xmpp.Concurrent
import Network.XMPP.Concurrent.Types import Network.Xmpp.Concurrent.Types
import Network.XMPP.Message import Network.Xmpp.Message
import Network.XMPP.Monad import Network.Xmpp.Monad
import Network.XMPP.Presence import Network.Xmpp.Presence
import Network.XMPP.SASL import Network.Xmpp.Sasl
import Network.XMPP.SASL.Types import Network.Xmpp.Sasl.Types
import Network.XMPP.Session import Network.Xmpp.Session
import Network.XMPP.Stream import Network.Xmpp.Stream
import Network.XMPP.TLS import Network.Xmpp.TLS
import Network.XMPP.Types import Network.Xmpp.Types
import Control.Monad.Error import Control.Monad.Error
-- | Connect to host with given address. -- | Connect to host with given address.
connect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) connect :: HostName -> Text -> XmppConMonad (Either StreamError ())
connect address hostname = xmppRawConnect address hostname >> xmppStartStream connect address hostname = xmppRawConnect address hostname >> xmppStartStream
-- | Authenticate to the server with the given username and password -- | Authenticate to the server with the given username and password
@ -163,7 +163,7 @@ auth :: Text.Text -- ^ The username
-> Text.Text -- ^ The password -> Text.Text -- ^ The password
-> Maybe Text -- ^ The desired resource or 'Nothing' to let the server -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server
-- assign one -- assign one
-> XMPPConMonad (Either AuthError Text.Text) -> XmppConMonad (Either AuthError Text.Text)
auth username passwd resource = runErrorT $ do auth username passwd resource = runErrorT $ do
ErrorT $ xmppSASL [DIGEST_MD5Credentials Nothing username passwd] ErrorT $ xmppSASL [DIGEST_MD5Credentials Nothing username passwd]
res <- lift $ xmppBind resource res <- lift $ xmppBind resource

10
source/Network/XMPP/Bind.hs → source/Network/Xmpp/Bind.hs
Unescape View File

@ -2,16 +2,16 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.XMPP.Bind where module Network.Xmpp.Bind where
import Data.Text as Text import Data.Text as Text
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Network.XMPP.Types import Network.Xmpp.Types
import Network.XMPP.Pickle import Network.Xmpp.Pickle
import Network.XMPP.Monad import Network.Xmpp.Monad
-- Produces a `bind' element, optionally wrapping a resource. -- Produces a `bind' element, optionally wrapping a resource.
bindBody :: Maybe Text -> Element bindBody :: Maybe Text -> Element
@ -24,7 +24,7 @@ bindBody = pickleElem $
-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated -- Sends a (synchronous) IQ set request for a (`Just') given or server-generated
-- resource and extract the JID from the non-error response. -- resource and extract the JID from the non-error response.
xmppBind :: Maybe Text -> XMPPConMonad Text xmppBind :: Maybe Text -> XmppConMonad Text
xmppBind rsrc = do xmppBind rsrc = do
answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc)
let Right IQResult{iqResultPayload = Just b} = answer -- TODO: Error handling let Right IQResult{iqResultPayload = Just b} = answer -- TODO: Error handling

13
source/Network/Xmpp/Concurrent.hs
Unescape View File

@ -0,0 +1,13 @@
module Network.Xmpp.Concurrent
( Session
, Xmpp
, module Network.Xmpp.Concurrent.Monad
, module Network.Xmpp.Concurrent.Threads
, module Network.Xmpp.Concurrent.IQ
) where
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Concurrent.Monad
import Network.Xmpp.Concurrent.Threads
import Network.Xmpp.Concurrent.IQ

14
source/Network/XMPP/Concurrent/IQ.hs → source/Network/Xmpp/Concurrent/IQ.hs
Unescape View File

@ -1,4 +1,4 @@
module Network.XMPP.Concurrent.IQ where module Network.Xmpp.Concurrent.IQ where
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -7,9 +7,9 @@ import Control.Monad.Trans.Reader
import Data.XML.Types import Data.XML.Types
import qualified Data.Map as Map import qualified Data.Map as Map
import Network.XMPP.Concurrent.Types import Network.Xmpp.Concurrent.Types
import Network.XMPP.Concurrent.Monad import Network.Xmpp.Concurrent.Monad
import Network.XMPP.Types import Network.Xmpp.Types
-- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound -- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound
-- IQ with a matching ID that has type @result@ or @error@. -- IQ with a matching ID that has type @result@ or @error@.
@ -18,7 +18,7 @@ sendIQ :: Maybe JID -- ^ Recipient (to)
-> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for -> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for
-- default) -- default)
-> Element -- ^ The IQ body (there has to be exactly one) -> Element -- ^ The IQ body (there has to be exactly one)
-> XMPP (TMVar IQResponse) -> Xmpp (TMVar IQResponse)
sendIQ to tp lang body = do -- TODO: Add timeout sendIQ to tp lang body = do -- TODO: Add timeout
newId <- liftIO =<< asks idGenerator newId <- liftIO =<< asks idGenerator
handlers <- asks iqHandlers handlers <- asks iqHandlers
@ -36,14 +36,14 @@ sendIQ' :: Maybe JID
-> IQRequestType -> IQRequestType
-> Maybe LangTag -> Maybe LangTag
-> Element -> Element
-> XMPP IQResponse -> Xmpp IQResponse
sendIQ' to tp lang body = do sendIQ' to tp lang body = do
ref <- sendIQ to tp lang body ref <- sendIQ to tp lang body
liftIO . atomically $ takeTMVar ref liftIO . atomically $ takeTMVar ref
answerIQ :: IQRequestTicket answerIQ :: IQRequestTicket
-> Either StanzaError (Maybe Element) -> Either StanzaError (Maybe Element)
-> XMPP Bool -> Xmpp Bool
answerIQ (IQRequestTicket answerIQ (IQRequestTicket
sentRef sentRef
(IQRequest iqid from _to lang _tp bd)) (IQRequest iqid from _to lang _tp bd))

60
source/Network/XMPP/Concurrent/Monad.hs → source/Network/Xmpp/Concurrent/Monad.hs
Unescape View File

@ -1,6 +1,6 @@
module Network.XMPP.Concurrent.Monad where module Network.Xmpp.Concurrent.Monad where
import Network.XMPP.Types import Network.Xmpp.Types
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
@ -13,8 +13,8 @@ import Data.IORef
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Text(Text) import Data.Text(Text)
import Network.XMPP.Concurrent.Types import Network.Xmpp.Concurrent.Types
import Network.XMPP.Monad import Network.Xmpp.Monad
-- | Register a new IQ listener. IQ requests matching the type and namespace -- | Register a new IQ listener. IQ requests matching the type and namespace
@ -24,7 +24,7 @@ import Network.XMPP.Monad
-- combination was alread handled. -- combination was alread handled.
listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@)
-> Text -- ^ Namespace of the child element -> Text -- ^ Namespace of the child element
-> XMPP (Maybe (TChan IQRequestTicket)) -> Xmpp (Maybe (TChan IQRequestTicket))
listenIQChan tp ns = do listenIQChan tp ns = do
handlers <- asks iqHandlers handlers <- asks iqHandlers
liftIO . atomically $ do liftIO . atomically $ do
@ -41,7 +41,7 @@ listenIQChan tp ns = do
Just _iqCh' -> Nothing Just _iqCh' -> Nothing
-- | Get a duplicate of the stanza channel -- | Get a duplicate of the stanza channel
getStanzaChan :: XMPP (TChan Stanza) getStanzaChan :: Xmpp (TChan Stanza)
getStanzaChan = do getStanzaChan = do
shadow <- asks sShadow shadow <- asks sShadow
liftIO $ atomically $ dupTChan shadow liftIO $ atomically $ dupTChan shadow
@ -49,7 +49,7 @@ getStanzaChan = do
-- | Get the inbound stanza channel, duplicates from master if necessary. Please -- | Get the inbound stanza channel, duplicates from master if necessary. Please
-- note that once duplicated it will keep filling up, call 'dropMessageChan' to -- note that once duplicated it will keep filling up, call 'dropMessageChan' to
-- allow it to be garbage collected. -- allow it to be garbage collected.
getMessageChan :: XMPP (TChan (Either MessageError Message)) getMessageChan :: Xmpp (TChan (Either MessageError Message))
getMessageChan = do getMessageChan = do
mChR <- asks messagesRef mChR <- asks messagesRef
mCh <- liftIO $ readIORef mChR mCh <- liftIO $ readIORef mChR
@ -62,7 +62,7 @@ getMessageChan = do
Just mCh' -> return mCh' Just mCh' -> return mCh'
-- | Analogous to 'getMessageChan'. -- | Analogous to 'getMessageChan'.
getPresenceChan :: XMPP (TChan (Either PresenceError Presence)) getPresenceChan :: Xmpp (TChan (Either PresenceError Presence))
getPresenceChan = do getPresenceChan = do
pChR <- asks presenceRef pChR <- asks presenceRef
pCh <- liftIO $ readIORef pChR pCh <- liftIO $ readIORef pChR
@ -76,33 +76,33 @@ getPresenceChan = do
-- | Drop the local end of the inbound stanza channel from our context so it can -- | Drop the local end of the inbound stanza channel from our context so it can
-- be GC-ed. -- be GC-ed.
dropMessageChan :: XMPP () dropMessageChan :: Xmpp ()
dropMessageChan = do dropMessageChan = do
r <- asks messagesRef r <- asks messagesRef
liftIO $ writeIORef r Nothing liftIO $ writeIORef r Nothing
-- | Analogous to 'dropMessageChan'. -- | Analogous to 'dropMessageChan'.
dropPresenceChan :: XMPP () dropPresenceChan :: Xmpp ()
dropPresenceChan = do dropPresenceChan = do
r <- asks presenceRef r <- asks presenceRef
liftIO $ writeIORef r Nothing liftIO $ writeIORef r Nothing
-- | Read an element from the inbound stanza channel, acquiring a copy of the -- | Read an element from the inbound stanza channel, acquiring a copy of the
-- channel as necessary. -- channel as necessary.
pullMessage :: XMPP (Either MessageError Message) pullMessage :: Xmpp (Either MessageError Message)
pullMessage = do pullMessage = do
c <- getMessageChan c <- getMessageChan
liftIO $ atomically $ readTChan c liftIO $ atomically $ readTChan c
-- | Read an element from the inbound stanza channel, acquiring a copy of the -- | Read an element from the inbound stanza channel, acquiring a copy of the
-- channel as necessary. -- channel as necessary.
pullPresence :: XMPP (Either PresenceError Presence) pullPresence :: Xmpp (Either PresenceError Presence)
pullPresence = do pullPresence = do
c <- getPresenceChan c <- getPresenceChan
liftIO $ atomically $ readTChan c liftIO $ atomically $ readTChan c
-- | Send a stanza to the server. -- | Send a stanza to the server.
sendStanza :: Stanza -> XMPP () sendStanza :: Stanza -> Xmpp ()
sendStanza a = do sendStanza a = do
out <- asks outCh out <- asks outCh
liftIO . atomically $ writeTChan out a liftIO . atomically $ writeTChan out a
@ -116,7 +116,7 @@ forkSession sess = do
return $ sess {messagesRef = mCH', presenceRef = pCH'} return $ sess {messagesRef = mCH', presenceRef = pCH'}
-- | Fork a new thread. -- | Fork a new thread.
fork :: XMPP () -> XMPP ThreadId fork :: Xmpp () -> Xmpp ThreadId
fork a = do fork a = do
sess <- ask sess <- ask
sess' <- liftIO $ forkSession sess sess' <- liftIO $ forkSession sess
@ -125,7 +125,7 @@ fork a = do
-- | Pulls a message and returns it if the given predicate returns @True@. -- | Pulls a message and returns it if the given predicate returns @True@.
filterMessages :: (MessageError -> Bool) filterMessages :: (MessageError -> Bool)
-> (Message -> Bool) -> (Message -> Bool)
-> XMPP (Either MessageError Message) -> Xmpp (Either MessageError Message)
filterMessages f g = do filterMessages f g = do
s <- pullMessage s <- pullMessage
case s of case s of
@ -136,7 +136,7 @@ filterMessages f g = do
-- | Pulls a (non-error) message and returns it if the given predicate returns -- | Pulls a (non-error) message and returns it if the given predicate returns
-- @True@. -- @True@.
waitForMessage :: (Message -> Bool) -> XMPP Message waitForMessage :: (Message -> Bool) -> Xmpp Message
waitForMessage f = do waitForMessage f = do
s <- pullMessage s <- pullMessage
case s of case s of
@ -145,7 +145,7 @@ waitForMessage f = do
| otherwise -> waitForMessage f | otherwise -> waitForMessage f
-- | Pulls an error message and returns it if the given predicate returns @True@. -- | Pulls an error message and returns it if the given predicate returns @True@.
waitForMessageError :: (MessageError -> Bool) -> XMPP MessageError waitForMessageError :: (MessageError -> Bool) -> Xmpp MessageError
waitForMessageError f = do waitForMessageError f = do
s <- pullMessage s <- pullMessage
case s of case s of
@ -155,7 +155,7 @@ waitForMessageError f = do
-- | Pulls a (non-error) presence and returns it if the given predicate returns -- | Pulls a (non-error) presence and returns it if the given predicate returns
-- @True@. -- @True@.
waitForPresence :: (Presence -> Bool) -> XMPP Presence waitForPresence :: (Presence -> Bool) -> Xmpp Presence
waitForPresence f = do waitForPresence f = do
s <- pullPresence s <- pullPresence
case s of case s of
@ -165,11 +165,11 @@ waitForPresence f = do
-- TODO: Wait for presence error? -- TODO: Wait for presence error?
-- | Run an XMPPMonad action in isolation. Reader and writer workers will be -- | Run an XmppMonad action in isolation. Reader and writer workers will be
-- temporarily stopped and resumed with the new session details once the action -- temporarily stopped and resumed with the new session details once the action
-- returns. The action will run in the calling thread. Any uncaught exceptions -- returns. The action will run in the calling thread. Any uncaught exceptions
-- will be interpreted as connection failure. -- will be interpreted as connection failure.
withConnection :: XMPPConMonad a -> XMPP (Either StreamError a) withConnection :: XmppConMonad a -> Xmpp (Either StreamError a)
withConnection a = do withConnection a = do
readerId <- asks readerThread readerId <- asks readerThread
stateRef <- asks conStateRef stateRef <- asks conStateRef
@ -193,7 +193,7 @@ withConnection a = do
(\e -> atomically (putTMVar wait ()) >> (\e -> atomically (putTMVar wait ()) >>
Ex.throwIO (e :: Ex.SomeException) Ex.throwIO (e :: Ex.SomeException)
) )
-- Run the XMPPMonad action, save the (possibly updated) states, release -- Run the XmppMonad action, save the (possibly updated) states, release
-- the locks, and return the result. -- the locks, and return the result.
Ex.catches Ex.catches
(do (do
@ -211,44 +211,44 @@ withConnection a = do
] ]
-- | Send a presence stanza. -- | Send a presence stanza.
sendPresence :: Presence -> XMPP () sendPresence :: Presence -> Xmpp ()
sendPresence = sendStanza . PresenceS sendPresence = sendStanza . PresenceS
-- | Send a message stanza. -- | Send a message stanza.
sendMessage :: Message -> XMPP () sendMessage :: Message -> Xmpp ()
sendMessage = sendStanza . MessageS sendMessage = sendStanza . MessageS
-- | Executes a function to update the event handlers. -- | Executes a function to update the event handlers.
modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPP () modifyHandlers :: (EventHandlers -> EventHandlers) -> Xmpp ()
modifyHandlers f = do modifyHandlers f = do
eh <- asks eventHandlers eh <- asks eventHandlers
liftIO . atomically $ writeTVar eh . f =<< readTVar eh liftIO . atomically $ writeTVar eh . f =<< readTVar eh
-- | Sets the handler to be executed when the session ends. -- | Sets the handler to be executed when the session ends.
setSessionEndHandler :: XMPP () -> XMPP () setSessionEndHandler :: Xmpp () -> Xmpp ()
setSessionEndHandler eh = do setSessionEndHandler eh = do
r <- ask r <- ask
modifyHandlers (\s -> s{sessionEndHandler = runReaderT eh r}) modifyHandlers (\s -> s{sessionEndHandler = runReaderT eh r})
-- | Sets the handler to be executed when the server connection is closed. -- | Sets the handler to be executed when the server connection is closed.
setConnectionClosedHandler :: (StreamError -> XMPP ()) -> XMPP () setConnectionClosedHandler :: (StreamError -> Xmpp ()) -> Xmpp ()
setConnectionClosedHandler eh = do setConnectionClosedHandler eh = do
r <- ask r <- ask
modifyHandlers (\s -> s{connectionClosedHandler = \e -> runReaderT (eh e) r}) modifyHandlers (\s -> s{connectionClosedHandler = \e -> runReaderT (eh e) r})
-- | Run an event handler. -- | Run an event handler.
runHandler :: (EventHandlers -> IO a) -> XMPP a runHandler :: (EventHandlers -> IO a) -> Xmpp a
runHandler h = do runHandler h = do
eh <- liftIO . atomically . readTVar =<< asks eventHandlers eh <- liftIO . atomically . readTVar =<< asks eventHandlers
liftIO $ h eh liftIO $ h eh
-- | End the current XMPP session. -- | End the current Xmpp session.
endSession :: XMPP () endSession :: Xmpp ()
endSession = do -- TODO: This has to be idempotent (is it?) endSession = do -- TODO: This has to be idempotent (is it?)
void $ withConnection xmppKillConnection void $ withConnection xmppKillConnection
liftIO =<< asks stopThreads liftIO =<< asks stopThreads
runHandler sessionEndHandler runHandler sessionEndHandler
-- | Close the connection to the server. -- | Close the connection to the server.
closeConnection :: XMPP () closeConnection :: Xmpp ()
closeConnection = void $ withConnection xmppKillConnection closeConnection = void $ withConnection xmppKillConnection

22
source/Network/XMPP/Concurrent/Threads.hs → source/Network/Xmpp/Concurrent/Threads.hs
Unescape View File

@ -1,8 +1,8 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.Concurrent.Threads where module Network.Xmpp.Concurrent.Threads where
import Network.XMPP.Types import Network.Xmpp.Types
import Control.Applicative((<$>),(<*>)) import Control.Applicative((<$>),(<*>))
import Control.Concurrent import Control.Concurrent
@ -20,10 +20,10 @@ import Data.Maybe
import Data.XML.Types import Data.XML.Types
import Network.XMPP.Monad import Network.Xmpp.Monad
import Network.XMPP.Marshal import Network.Xmpp.Marshal
import Network.XMPP.Pickle import Network.Xmpp.Pickle
import Network.XMPP.Concurrent.Types import Network.Xmpp.Concurrent.Types
import Text.XML.Stream.Elements import Text.XML.Stream.Elements
@ -193,7 +193,7 @@ startThreads = do
, connectionClosedHandler = \_ -> return () , connectionClosedHandler = \_ -> return ()
} }
-- | Creates and initializes a new XMPP session. -- | Creates and initializes a new Xmpp session.
newSession :: IO Session newSession :: IO Session
newSession = do newSession = do
(mC, pC, sC, hand, outC, stopThreads', writeR, conS, rdr, eh) <- startThreads (mC, pC, sC, hand, outC, stopThreads', writeR, conS, rdr, eh) <- startThreads
@ -219,15 +219,15 @@ newSession = do
eh eh
stopThreads' stopThreads'
-- | Creates a new session and runs the given XMPP computation. -- | Creates a new session and runs the given Xmpp computation.
withNewSession :: XMPP b -> IO (Session, b) withNewSession :: Xmpp b -> IO (Session, b)
withNewSession a = do withNewSession a = do
sess <- newSession sess <- newSession
ret <- runReaderT a sess ret <- runReaderT a sess
return (sess, ret) return (sess, ret)
-- | Runs the given XMPP computation in the given session. -- | Runs the given Xmpp computation in the given session.
withSession :: Session -> XMPP a -> IO a withSession :: Session -> Xmpp a -> IO a
withSession = flip runReaderT withSession = flip runReaderT
-- Acquires the write lock, pushes a space, and releases the lock. -- Acquires the write lock, pushes a space, and releases the lock.

14
source/Network/XMPP/Concurrent/Types.hs → source/Network/Xmpp/Concurrent/Types.hs
Unescape View File

@ -1,7 +1,7 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
module Network.XMPP.Concurrent.Types where module Network.Xmpp.Concurrent.Types where
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Concurrent import Control.Concurrent
@ -14,7 +14,7 @@ import qualified Data.Map as Map
import Data.Text(Text) import Data.Text(Text)
import Data.Typeable import Data.Typeable
import Network.XMPP.Types import Network.Xmpp.Types
-- Map between the IQ request type and the "query" namespace pair, and the TChan -- Map between the IQ request type and the "query" namespace pair, and the TChan
-- for the IQ request and "sent" boolean pair. -- for the IQ request and "sent" boolean pair.
@ -22,14 +22,14 @@ type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket)
, Map.Map StanzaId (TMVar IQResponse) , Map.Map StanzaId (TMVar IQResponse)
) )
-- Handlers to be run when the XMPP session ends and when the XMPP connection is -- Handlers to be run when the Xmpp session ends and when the Xmpp connection is
-- closed. -- closed.
data EventHandlers = EventHandlers data EventHandlers = EventHandlers
{ sessionEndHandler :: IO () { sessionEndHandler :: IO ()
, connectionClosedHandler :: StreamError -> IO () , connectionClosedHandler :: StreamError -> IO ()
} }
-- The Session object is the XMPP (ReaderT) state. -- The Session object is the Xmpp (ReaderT) state.
data Session = Session data Session = Session
{ -- The original master channels that the reader puts stanzas { -- The original master channels that the reader puts stanzas
-- into. These are cloned by @get{STanza,Message,Presence}Chan -- into. These are cloned by @get{STanza,Message,Presence}Chan
@ -51,14 +51,14 @@ data Session = Session
, readerThread :: ThreadId , readerThread :: ThreadId
, idGenerator :: IO StanzaId , idGenerator :: IO StanzaId
-- Lock (used by withConnection) to make sure that a maximum of one -- Lock (used by withConnection) to make sure that a maximum of one
-- XMPPConMonad calculation is executed at any given time. -- XmppConMonad calculation is executed at any given time.
, conStateRef :: TMVar XmppConnection , conStateRef :: TMVar XmppConnection
, eventHandlers :: TVar EventHandlers , eventHandlers :: TVar EventHandlers
, stopThreads :: IO () , stopThreads :: IO ()
} }
-- XMPP is a monad for concurrent XMPP usage. -- Xmpp is a monad for concurrent Xmpp usage.
type XMPP a = ReaderT Session IO a type Xmpp a = ReaderT Session IO a
-- Interrupt is used to signal to the reader thread that it should stop. -- Interrupt is used to signal to the reader thread that it should stop.
data Interrupt = Interrupt (TMVar ()) deriving Typeable data Interrupt = Interrupt (TMVar ()) deriving Typeable

7
source/Network/Xmpp/IM.hs
Unescape View File

@ -0,0 +1,7 @@
module Network.Xmpp.IM
( module Network.Xmpp.IM.Message
, module Network.Xmpp.IM.Presence
) where
import Network.Xmpp.IM.Message
import Network.Xmpp.IM.Presence

6
source/Network/XMPP/IM/Message.hs → source/Network/Xmpp/IM/Message.hs
Unescape View File

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.IM.Message module Network.Xmpp.IM.Message
where where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
@ -9,8 +9,8 @@ import Data.Text (Text)
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Network.XMPP.Types import Network.Xmpp.Types
import Network.XMPP.Pickle import Network.Xmpp.Pickle
data MessageBody = MessageBody (Maybe LangTag) Text data MessageBody = MessageBody (Maybe LangTag) Text
data MessageThread = MessageThread data MessageThread = MessageThread

4
source/Network/XMPP/IM/Presence.hs → source/Network/Xmpp/IM/Presence.hs
Unescape View File

@ -1,7 +1,7 @@
module Network.XMPP.IM.Presence where module Network.Xmpp.IM.Presence where
import Data.Text(Text) import Data.Text(Text)
import Network.XMPP.Types import Network.Xmpp.Types
-- | An empty presence. -- | An empty presence.
presence :: Presence presence :: Presence

2
source/Network/XMPP/JID.hs → source/Network/Xmpp/JID.hs
Unescape View File

@ -3,7 +3,7 @@
-- This module deals with JIDs, also known as XMPP addresses. For more -- This module deals with JIDs, also known as XMPP addresses. For more
-- information on JIDs, see RFC 6122: XMPP: Address Format. -- information on JIDs, see RFC 6122: XMPP: Address Format.
module Network.XMPP.JID module Network.Xmpp.JID
( JID(..) ( JID(..)
, fromText , fromText
, fromStrings , fromStrings

6
source/Network/XMPP/Marshal.hs → source/Network/Xmpp/Marshal.hs
Unescape View File

@ -6,13 +6,13 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.XMPP.Marshal where module Network.Xmpp.Marshal where
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Network.XMPP.Pickle import Network.Xmpp.Pickle
import Network.XMPP.Types import Network.Xmpp.Types
xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza)
xpStreamStanza = xpEither xpStreamError xpStanza xpStreamStanza = xpEither xpStreamError xpStanza

4
source/Network/XMPP/Message.hs → source/Network/Xmpp/Message.hs
Unescape View File

@ -1,5 +1,5 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Network.XMPP.Message module Network.Xmpp.Message
( Message(..) ( Message(..)
, MessageError(..) , MessageError(..)
, MessageType(..) , MessageType(..)
@ -9,7 +9,7 @@ module Network.XMPP.Message
import Data.XML.Types import Data.XML.Types
import Network.XMPP.Types import Network.Xmpp.Types
-- | An empty message. -- | An empty message.
message :: Message message :: Message

36
source/Network/XMPP/Monad.hs → source/Network/Xmpp/Monad.hs
Unescape View File

@ -1,7 +1,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.Monad where module Network.Xmpp.Monad where
import Control.Applicative((<$>)) import Control.Applicative((<$>))
import Control.Monad import Control.Monad
@ -22,9 +22,9 @@ import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Network import Network
import Network.XMPP.Types import Network.Xmpp.Types
import Network.XMPP.Marshal import Network.Xmpp.Marshal
import Network.XMPP.Pickle import Network.Xmpp.Pickle
import System.IO import System.IO
@ -32,28 +32,28 @@ import Text.XML.Stream.Elements
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
import Text.XML.Unresolved(InvalidEventStream(..)) import Text.XML.Unresolved(InvalidEventStream(..))
pushElement :: Element -> XMPPConMonad Bool pushElement :: Element -> XmppConMonad Bool
pushElement x = do pushElement x = do
sink <- gets sConPushBS sink <- gets sConPushBS
liftIO . sink $ renderElement x liftIO . sink $ renderElement x
pushStanza :: Stanza -> XMPPConMonad Bool pushStanza :: Stanza -> XmppConMonad Bool
pushStanza = pushElement . pickleElem xpStanza pushStanza = pushElement . pickleElem xpStanza
pushOpenElement :: Element -> XMPPConMonad Bool pushOpenElement :: Element -> XmppConMonad Bool
pushOpenElement e = do pushOpenElement e = do
sink <- gets sConPushBS sink <- gets sConPushBS
liftIO . sink $ renderOpenElement e liftIO . sink $ renderOpenElement e
-- `Connect-and-resumes' the given sink to the connection source, and pulls a -- `Connect-and-resumes' the given sink to the connection source, and pulls a
-- `b' value. -- `b' value.
pullToSink :: Sink Event IO b -> XMPPConMonad b pullToSink :: Sink Event IO b -> XmppConMonad b
pullToSink snk = do pullToSink snk = do
source <- gets sConSrc source <- gets sConSrc
(_, r) <- lift $ source $$+ snk (_, r) <- lift $ source $$+ snk
return r return r
pullElement :: XMPPConMonad Element pullElement :: XmppConMonad Element
pullElement = do pullElement = do
Ex.catch (do Ex.catch (do
e <- pullToSink (elements =$ CL.head) e <- pullToSink (elements =$ CL.head)
@ -64,7 +64,7 @@ pullElement = do
(\(InvalidEventStream s) -> liftIO . Ex.throwIO $ StreamXMLError s) (\(InvalidEventStream s) -> liftIO . Ex.throwIO $ StreamXMLError s)
-- Pulls an element and unpickles it. -- Pulls an element and unpickles it.
pullPickle :: PU [Node] a -> XMPPConMonad a pullPickle :: PU [Node] a -> XmppConMonad a
pullPickle p = do pullPickle p = do
res <- unpickleElem p <$> pullElement res <- unpickleElem p <$> pullElement
case res of case res of
@ -72,7 +72,7 @@ pullPickle p = do
Right r -> return r Right r -> return r
-- Pulls a stanza from the stream. Throws an error on failure. -- Pulls a stanza from the stream. Throws an error on failure.
pullStanza :: XMPPConMonad Stanza pullStanza :: XmppConMonad Stanza
pullStanza = do pullStanza = do
res <- pullPickle xpStreamStanza res <- pullPickle xpStreamStanza
case res of case res of
@ -108,8 +108,8 @@ xmppNoConnection = XmppConnection
zeroSource = liftIO . Ex.throwIO $ StreamConnectionError zeroSource = liftIO . Ex.throwIO $ StreamConnectionError
-- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and -- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and
-- updates the XMPPConMonad XmppConnection state. -- updates the XmppConMonad XmppConnection state.
xmppRawConnect :: HostName -> Text -> XMPPConMonad () xmppRawConnect :: HostName -> Text -> XmppConMonad ()
xmppRawConnect host hostname = do xmppRawConnect host hostname = do
uname <- gets sUsername uname <- gets sUsername
con <- liftIO $ do con <- liftIO $ do
@ -131,12 +131,12 @@ xmppRawConnect host hostname = do
(hClose con) (hClose con)
put st put st
-- Execute a XMPPConMonad computation. -- Execute a XmppConMonad computation.
xmppNewSession :: XMPPConMonad a -> IO (a, XmppConnection) xmppNewSession :: XmppConMonad a -> IO (a, XmppConnection)
xmppNewSession action = runStateT action xmppNoConnection xmppNewSession action = runStateT action xmppNoConnection
-- Closes the connection and updates the XMPPConMonad XmppConnection state. -- Closes the connection and updates the XmppConMonad XmppConnection state.
xmppKillConnection :: XMPPConMonad () xmppKillConnection :: XmppConMonad ()
xmppKillConnection = do xmppKillConnection = do
cc <- gets sCloseConnection cc <- gets sCloseConnection
void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ()))
@ -149,7 +149,7 @@ xmppSendIQ' :: StanzaId
-> IQRequestType -> IQRequestType
-> Maybe LangTag -> Maybe LangTag
-> Element -> Element
-> XMPPConMonad (Either IQError IQResult) -> XmppConMonad (Either IQError IQResult)
xmppSendIQ' iqID to tp lang body = do xmppSendIQ' iqID to tp lang body = do
pushStanza . IQRequestS $ IQRequest iqID Nothing to lang tp body pushStanza . IQRequestS $ IQRequest iqID Nothing to lang tp body
res <- pullPickle $ xpEither xpIQError xpIQResult res <- pullPickle $ xpEither xpIQError xpIQResult

4
source/Network/XMPP/Pickle.hs → source/Network/Xmpp/Pickle.hs
Unescape View File

@ -5,7 +5,7 @@
-- Marshalling between XML and Native Types -- Marshalling between XML and Native Types
module Network.XMPP.Pickle module Network.Xmpp.Pickle
( mbToBool ( mbToBool
, xpElemEmpty , xpElemEmpty
, xmlLang , xmlLang
@ -24,7 +24,7 @@ module Network.XMPP.Pickle
import Data.XML.Types import Data.XML.Types
import Data.XML.Pickle import Data.XML.Pickle
import Network.XMPP.Types import Network.Xmpp.Types
import Text.XML.Stream.Elements import Text.XML.Stream.Elements

4
source/Network/XMPP/Presence.hs → source/Network/Xmpp/Presence.hs
Unescape View File

@ -1,9 +1,9 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.XMPP.Presence where module Network.Xmpp.Presence where
import Data.Text(Text) import Data.Text(Text)
import Network.XMPP.Types import Network.Xmpp.Types
-- | Add a recipient to a presence notification. -- | Add a recipient to a presence notification.
presTo :: Presence -> JID -> Presence presTo :: Presence -> JID -> Presence

24
source/Network/XMPP/SASL.hs → source/Network/Xmpp/Sasl.hs
Unescape View File

@ -1,6 +1,6 @@
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
module Network.XMPP.SASL where module Network.Xmpp.Sasl where
import Control.Applicative import Control.Applicative
import Control.Arrow (left) import Control.Arrow (left)
@ -23,25 +23,25 @@ import qualified Data.Text as Text
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
import Network.XMPP.Monad import Network.Xmpp.Monad
import Network.XMPP.Stream import Network.Xmpp.Stream
import Network.XMPP.Types import Network.Xmpp.Types
import Network.XMPP.Pickle import Network.Xmpp.Pickle
import qualified System.Random as Random import qualified System.Random as Random
import Network.XMPP.SASL.SASL import Network.Xmpp.Sasl.Sasl
import Network.XMPP.SASL.DIGEST_MD5 import Network.Xmpp.Sasl.DigestMD5
import Network.XMPP.SASL.PLAIN import Network.Xmpp.Sasl.Plain
import Network.XMPP.SASL.Types import Network.Xmpp.Sasl.Types
-- Uses the first supported mechanism to authenticate, if any. Updates the -- Uses the first supported mechanism to authenticate, if any. Updates the
-- XMPPConMonad state with non-password credentials and restarts the stream upon -- XmppConMonad state with non-password credentials and restarts the stream upon
-- success. This computation wraps an ErrorT computation, which means that -- success. This computation wraps an ErrorT computation, which means that
-- catchError can be used to catch any errors. -- catchError can be used to catch any errors.
xmppSASL :: [SASLCredentials] -- ^ Acceptable authentication mechanisms and xmppSASL :: [SASLCredentials] -- ^ Acceptable authentication mechanisms and
-- their corresponding credentials -- their corresponding credentials
-> XMPPConMonad (Either AuthError ()) -> XmppConMonad (Either AuthError ())
xmppSASL creds = runErrorT $ do xmppSASL creds = runErrorT $ do
-- Chooses the first mechanism that is acceptable by both the client and the -- Chooses the first mechanism that is acceptable by both the client and the
-- server. -- server.
@ -49,7 +49,7 @@ xmppSASL creds = runErrorT $ do
let cred = L.find (\cred -> credsToName cred `elem` mechanisms) creds let cred = L.find (\cred -> credsToName cred `elem` mechanisms) creds
unless (isJust cred) (throwError $ AuthMechanismError mechanisms) unless (isJust cred) (throwError $ AuthMechanismError mechanisms)
case fromJust cred of case fromJust cred of
DIGEST_MD5Credentials authzid authcid passwd -> ErrorT $ xmppDIGEST_MD5 DIGEST_MD5Credentials authzid authcid passwd -> ErrorT $ xmppDigestMD5
authzid authzid
authcid authcid
passwd passwd

24
source/Network/XMPP/SASL/DIGEST_MD5.hs → source/Network/Xmpp/Sasl/DigestMD5.hs
Unescape View File

@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.SASL.DIGEST_MD5 where module Network.Xmpp.Sasl.DigestMD5 where
import Control.Applicative import Control.Applicative
import Control.Arrow (left) import Control.Arrow (left)
@ -29,21 +29,21 @@ import qualified Data.ByteString as BS
import Data.XML.Types import Data.XML.Types
import Network.XMPP.Monad import Network.Xmpp.Monad
import Network.XMPP.Stream import Network.Xmpp.Stream
import Network.XMPP.Types import Network.Xmpp.Types
import Network.XMPP.Pickle import Network.Xmpp.Pickle
import qualified System.Random as Random import qualified System.Random as Random
import Network.XMPP.SASL.SASL import Network.Xmpp.Sasl.Sasl
import Network.XMPP.SASL.Types import Network.Xmpp.Sasl.Types
xmppDIGEST_MD5 :: Maybe Text -- Authorization identity (authzid) xmppDigestMD5 :: Maybe Text -- Authorization identity (authzid)
-> Text -- Authentication identity (authzid) -> Text -- Authentication identity (authzid)
-> Text -- Password (authzid) -> Text -- Password (authzid)
-> XMPPConMonad (Either AuthError ()) -> XmppConMonad (Either AuthError ())
xmppDIGEST_MD5 authzid authcid passwd = runErrorT $ do xmppDigestMD5 authzid authcid passwd = runErrorT $ do
realm <- gets sHostname realm <- gets sHostname
case realm of case realm of
Just realm' -> do Just realm' -> do
@ -53,9 +53,9 @@ xmppDIGEST_MD5 authzid authcid passwd = runErrorT $ do
Nothing -> throwError AuthConnectionError Nothing -> throwError AuthConnectionError
where where
xmppDIGEST_MD5' :: Text -- ^ SASL realm xmppDIGEST_MD5' :: Text -- ^ SASL realm
-> XMPPConMonad (Either AuthError ()) -> XmppConMonad (Either AuthError ())
xmppDIGEST_MD5' realm = runErrorT $ do xmppDIGEST_MD5' realm = runErrorT $ do
-- Push element and receive the challenge (in XMPPConMonad). -- Push element and receive the challenge (in XmppConMonad).
_ <- lift . pushElement $ saslInitE "DIGEST-MD5" Nothing -- TODO: Check boolean? _ <- lift . pushElement $ saslInitE "DIGEST-MD5" Nothing -- TODO: Check boolean?
challenge' <- lift $ B64.decode . Text.encodeUtf8 <$> challenge' <- lift $ B64.decode . Text.encodeUtf8 <$>
pullPickle challengePickle pullPickle challengePickle

16
source/Network/XMPP/SASL/PLAIN.hs → source/Network/Xmpp/Sasl/Plain.hs
Unescape View File

@ -3,7 +3,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.SASL.PLAIN where module Network.Xmpp.Sasl.Plain where
import Control.Applicative import Control.Applicative
import Control.Arrow (left) import Control.Arrow (left)
@ -32,23 +32,23 @@ import qualified Data.ByteString as BS
import Data.XML.Types import Data.XML.Types
import Network.XMPP.Monad import Network.Xmpp.Monad
import Network.XMPP.Stream import Network.Xmpp.Stream
import Network.XMPP.Types import Network.Xmpp.Types
import Network.XMPP.Pickle import Network.Xmpp.Pickle
import qualified System.Random as Random import qualified System.Random as Random
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Text as T import qualified Data.Text as T
import Network.XMPP.SASL.SASL import Network.Xmpp.Sasl.Sasl
import Network.XMPP.SASL.Types import Network.Xmpp.Sasl.Types
xmppPLAIN :: Maybe T.Text xmppPLAIN :: Maybe T.Text
-> T.Text -> T.Text
-> T.Text -> T.Text
-> XMPPConMonad (Either AuthError ()) -> XmppConMonad (Either AuthError ())
xmppPLAIN authzid authcid passwd = runErrorT $ do xmppPLAIN authzid authcid passwd = runErrorT $ do
_ <- lift . pushElement $ saslInitE "PLAIN" $ -- TODO: Check boolean? _ <- lift . pushElement $ saslInitE "PLAIN" $ -- TODO: Check boolean?
Just $ Text.decodeUtf8 $ B64.encode $ Text.encodeUtf8 $ plainMessage authzid authcid passwd Just $ Text.decodeUtf8 $ B64.encode $ Text.encodeUtf8 $ plainMessage authzid authcid passwd

6
source/Network/XMPP/SASL/SASL.hs → source/Network/Xmpp/Sasl/Sasl.hs
Unescape View File

@ -1,8 +1,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.SASL.SASL where module Network.Xmpp.Sasl.Sasl where
import Network.XMPP.Types import Network.Xmpp.Types
import Control.Monad.Error import Control.Monad.Error
import Data.Text import Data.Text
@ -12,7 +12,7 @@ import Data.XML.Types
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Network.XMPP.Pickle import Network.Xmpp.Pickle
-- The <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element, with an -- The <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element, with an
-- optional round-trip value. -- optional round-trip value.

4
source/Network/XMPP/SASL/Types.hs → source/Network/Xmpp/Sasl/Types.hs
Unescape View File

@ -1,8 +1,8 @@
module Network.XMPP.SASL.Types where module Network.Xmpp.Sasl.Types where
import Control.Monad.Error import Control.Monad.Error
import Data.Text import Data.Text
import Network.XMPP.Types import Network.Xmpp.Types
data AuthError = AuthXmlError data AuthError = AuthXmlError
| AuthMechanismError [Text] -- ^ Wraps mechanisms offered | AuthMechanismError [Text] -- ^ Wraps mechanisms offered

14
source/Network/XMPP/Session.hs → source/Network/Xmpp/Session.hs
Unescape View File

@ -1,14 +1,14 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.Session where module Network.Xmpp.Session where
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types(Element) import Data.XML.Types(Element)
import Network.XMPP.Monad import Network.Xmpp.Monad
import Network.XMPP.Pickle import Network.Xmpp.Pickle
import Network.XMPP.Types import Network.Xmpp.Types
import Network.XMPP.Concurrent import Network.Xmpp.Concurrent
sessionXML :: Element sessionXML :: Element
sessionXML = pickleElem sessionXML = pickleElem
@ -26,7 +26,7 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess"
-- Sends the session IQ set element and waits for an answer. Throws an error if -- 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. -- if an IQ error stanza is returned from the server.
xmppStartSession :: XMPPConMonad () xmppStartSession :: XmppConMonad ()
xmppStartSession = do xmppStartSession = do
answer <- xmppSendIQ' "session" Nothing Set Nothing sessionXML answer <- xmppSendIQ' "session" Nothing Set Nothing sessionXML
case answer of case answer of
@ -35,7 +35,7 @@ xmppStartSession = do
-- Sends the session IQ set element and waits for an answer. Throws an error if -- 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. -- if an IQ error stanza is returned from the server.
startSession :: XMPP () startSession :: Xmpp ()
startSession = do startSession = do
answer <- sendIQ' Nothing Set Nothing sessionXML answer <- sendIQ' Nothing Set Nothing sessionXML
case answer of case answer of

12
source/Network/XMPP/Stream.hs → source/Network/Xmpp/Stream.hs
Unescape View File

@ -1,7 +1,7 @@
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Network.XMPP.Stream where module Network.Xmpp.Stream where
import qualified Control.Exception as Ex import qualified Control.Exception as Ex
import Control.Monad.Error import Control.Monad.Error
@ -15,9 +15,9 @@ import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Data.Void(Void) import Data.Void(Void)
import Network.XMPP.Monad import Network.Xmpp.Monad
import Network.XMPP.Pickle import Network.Xmpp.Pickle
import Network.XMPP.Types import Network.Xmpp.Types
import Text.XML.Stream.Elements import Text.XML.Stream.Elements
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
@ -56,7 +56,7 @@ openElementFromEvents = do
_ -> throwError $ StreamConnectionError _ -> throwError $ StreamConnectionError
-- Sends the initial stream:stream element and pulls the server features. -- Sends the initial stream:stream element and pulls the server features.
xmppStartStream :: XMPPConMonad (Either StreamError ()) xmppStartStream :: XmppConMonad (Either StreamError ())
xmppStartStream = runErrorT $ do xmppStartStream = runErrorT $ do
hostname' <- gets sHostname hostname' <- gets sHostname
case hostname' of case hostname' of
@ -69,7 +69,7 @@ xmppStartStream = runErrorT $ do
-- Creates a new connection source (of Events) using the raw source (of bytes) -- Creates a new connection source (of Events) using the raw source (of bytes)
-- and calls xmppStartStream. -- and calls xmppStartStream.
xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream :: XmppConMonad (Either StreamError ())
xmppRestartStream = do xmppRestartStream = do
raw <- gets sRawSrc raw <- gets sRawSrc
newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def

20
source/Network/XMPP/TLS.hs → source/Network/Xmpp/TLS.hs
Unescape View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.TLS where module Network.Xmpp.TLS where
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad import Control.Monad
@ -12,10 +12,10 @@ import Data.Conduit.TLS as TLS
import Data.Typeable import Data.Typeable
import Data.XML.Types import Data.XML.Types
import Network.XMPP.Monad import Network.Xmpp.Monad
import Network.XMPP.Pickle(ppElement) import Network.Xmpp.Pickle(ppElement)
import Network.XMPP.Stream import Network.Xmpp.Stream
import Network.XMPP.Types import Network.Xmpp.Types
starttlsE :: Element starttlsE :: Element
starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
@ -35,19 +35,19 @@ exampleParams = TLS.defaultParams
} }
-- | Error conditions that may arise during TLS negotiation. -- | Error conditions that may arise during TLS negotiation.
data XMPPTLSError = TLSError TLSError data XmppTLSError = TLSError TLSError
| TLSNoServerSupport | TLSNoServerSupport
| TLSNoConnection | TLSNoConnection
| TLSStreamError StreamError | TLSStreamError StreamError
| XMPPTLSError -- General instance used for the Error instance | XmppTLSError -- General instance used for the Error instance
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Error XMPPTLSError where instance Error XmppTLSError where
noMsg = XMPPTLSError noMsg = XmppTLSError
-- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and -- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and
-- restarts the stream. May throw errors. -- restarts the stream. May throw errors.
startTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) startTLS :: TLS.TLSParams -> XmppConMonad (Either XmppTLSError ())
startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do
features <- lift $ gets sFeatures features <- lift $ gets sFeatures
handle' <- lift $ gets sConHandle handle' <- lift $ gets sConHandle

30
source/Network/XMPP/Types.hs → source/Network/Xmpp/Types.hs
Unescape View File

@ -6,7 +6,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.XMPP.Types module Network.Xmpp.Types
( IQError(..) ( IQError(..)
, IQRequest(..) , IQRequest(..)
, IQRequestType(..) , IQRequestType(..)
@ -32,13 +32,13 @@ module Network.XMPP.Types
, StanzaId(..) , StanzaId(..)
, StreamError(..) , StreamError(..)
, Version(..) , Version(..)
, XMPPConMonad , XmppConMonad
, XmppConnection(..) , XmppConnection(..)
, XmppConnectionState(..) , XmppConnectionState(..)
, XMPPT(..) , XmppT(..)
, XmppStreamError(..) , XmppStreamError(..)
, parseLangTag , parseLangTag
, module Network.XMPP.JID , module Network.Xmpp.JID
) )
where where
@ -60,13 +60,13 @@ import Data.XML.Types
import qualified Network as N import qualified Network as N
import Network.XMPP.JID import Network.Xmpp.JID
import System.IO import System.IO
-- | -- |
-- Wraps a string of random characters that, when using an appropriate -- Wraps a string of random characters that, when using an appropriate
-- @IDGenerator@, is guaranteed to be unique for the XMPP session. -- @IDGenerator@, is guaranteed to be unique for the Xmpp session.
data StanzaId = SI !Text deriving (Eq, Ord) data StanzaId = SI !Text deriving (Eq, Ord)
@ -79,7 +79,7 @@ instance Read StanzaId where
instance IsString StanzaId where instance IsString StanzaId where
fromString = SI . Text.pack fromString = SI . Text.pack
-- | The XMPP communication primities (Message, Presence and Info/Query) are -- | The Xmpp communication primities (Message, Presence and Info/Query) are
-- called stanzas. -- called stanzas.
data Stanza = IQRequestS IQRequest data Stanza = IQRequestS IQRequest
| IQResultS IQResult | IQResultS IQResult
@ -221,7 +221,7 @@ data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaId
, presenceErrorPayload :: [Element] , presenceErrorPayload :: [Element]
} deriving Show } deriving Show
-- | @PresenceType@ holds XMPP presence types. The "error" message type is left -- | @PresenceType@ holds Xmpp presence types. The "error" message type is left
-- out as errors are using @PresenceError@. -- out as errors are using @PresenceError@.
data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence
Subscribed | -- ^ Sender has approved the subscription Subscribed | -- ^ Sender has approved the subscription
@ -278,7 +278,7 @@ instance Read PresenceType where
-- readsPrec _ _ = [] -- readsPrec _ _ = []
-- | All stanzas (IQ, message, presence) can cause errors, which in the XMPP -- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp
-- stream looks like <stanza-kind to='sender' type='error'>. These errors are -- stream looks like <stanza-kind to='sender' type='error'>. These errors are
-- wrapped in the @StanzaError@ type. -- wrapped in the @StanzaError@ type.
-- TODO: Sender XML is (optional and is) not yet included. -- TODO: Sender XML is (optional and is) not yet included.
@ -661,14 +661,14 @@ data XmppConnection = XmppConnection
} }
-- | -- |
-- The XMPP monad transformer. Contains internal state in order to -- The Xmpp monad transformer. Contains internal state in order to
-- work with Pontarius. Pontarius clients needs to operate in this -- work with Pontarius. Pontarius clients needs to operate in this
-- context. -- context.
newtype XMPPT m a = XMPPT { runXMPPT :: StateT XmppConnection m a } deriving (Monad, MonadIO) newtype XmppT m a = XmppT { runXmppT :: StateT XmppConnection m a } deriving (Monad, MonadIO)
-- | Low-level and single-threaded XMPP monad. See @XMPP@ for a concurrent -- | Low-level and single-threaded Xmpp monad. See @Xmpp@ for a concurrent
-- implementation. -- implementation.
type XMPPConMonad a = StateT XmppConnection IO a type XmppConMonad a = StateT XmppConnection IO a
-- Make XMPPT derive the Monad and MonadIO instances. -- Make XmppT derive the Monad and MonadIO instances.
deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XMPPT m) deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XmppT m)

4
source/Network/XMPP/Utilities.hs → source/Network/Xmpp/Utilities.hs
Unescape View File

@ -7,9 +7,9 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.Utilities (idGenerator) where module Network.Xmpp.Utilities (idGenerator) where
import Network.XMPP.Types import Network.Xmpp.Types
import Control.Monad.STM import Control.Monad.STM
import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TVar
Write Preview
Loading…
Cancel
Save