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

Merge remote-tracking branch 'remotes/nejla/master' 

Conflicts:
	source/Network/Xmpp.hs
	source/Network/Xmpp/Concurrent/Threads.hs
master
Philipp Balzarek 13 years ago
parent
c0af09d40c 8ef30ac78b
commit
3b2b934376
6 changed files with 61 additions and 50 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. 17
      examples/EchoClient.hs
  2. 58
      pontarius-xmpp.cabal
  3. 16
      source/Network/Xmpp.hs
  4. 11
      source/Network/Xmpp/Concurrent/Monad.hs
  5. 7
      source/Network/Xmpp/Jid.hs
  6. 2
      source/Network/Xmpp/Stream.hs

17
examples/EchoClient.hs
Unescape View File

@ -36,24 +36,23 @@ resource = Nothing
-- TODO: Incomplete code, needs documentation, etc. -- TODO: Incomplete code, needs documentation, etc.
main :: IO () main :: IO ()
main = do main = do
withNewSession $ do session <- newSession
withConnection $ simpleConnect hostname username password resource withConnection (simpleConnect hostname username password resource) session
sendPresence presenceOnline sendPresence presenceOnline session
echo echo session
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 :: Session -> IO ()
echo = forever $ do echo session = forever $ do
result <- pullMessage result <- pullMessage session
case result of case result of
Right message -> Right message ->
if (isJust $ messageFrom message) && if (isJust $ messageFrom message) &&
(isFull $ fromJust $ messageFrom message) then do (isFull $ fromJust $ messageFrom message) then do
-- TODO: May not set from. -- TODO: May not set from.
sendMessage $ Message Nothing (messageTo message) (messageFrom message) Nothing (messageType message) (messagePayload message) sendMessage (Message Nothing (messageTo message) (messageFrom message) Nothing (messageType message) (messagePayload message)) session
liftIO $ putStrLn "Message echoed!" liftIO $ putStrLn "Message echoed!"
else liftIO $ putStrLn "Message sender is not set or is bare!" else liftIO $ putStrLn "Message sender is not set or is bare!"
Left exception -> liftIO $ putStrLn "Error: " Left exception -> liftIO $ putStrLn "Error: "

58
pontarius-xmpp.cabal
Unescape View File

@ -2,7 +2,7 @@ Name: pontarius-xmpp
Version: 0.1.0.0 Version: 0.1.0.0
Cabal-Version: >= 1.6 Cabal-Version: >= 1.6
Build-Type: Simple Build-Type: Simple
-- License: License: OtherLicense
License-File: LICENSE License-File: LICENSE
Copyright: Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen, Copyright: Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen,
IETF Trust, Philipp Balzarek IETF Trust, Philipp Balzarek
@ -14,7 +14,7 @@ Bug-Reports: mailto:info@jonkri.com
Package-URL: http://hackage.haskell.org/packages/archive/pontarius-xmpp/0.1.0.0/pontarius-xmpp-0.1.0.0.tar.gz Package-URL: http://hackage.haskell.org/packages/archive/pontarius-xmpp/0.1.0.0/pontarius-xmpp-0.1.0.0.tar.gz
Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core)
Description: Pontarius is a work in progress implementation of Description: Pontarius is a work in progress implementation of
RFC 6120 (XMPP: Core). RFC 6120 (XMPP: Core).
Category: Network Category: Network
Tested-With: GHC ==7.0.4, GHC ==7.4.1 Tested-With: GHC ==7.0.4, GHC ==7.4.1
-- Data-Files: -- Data-Files:
@ -25,33 +25,33 @@ Tested-With: GHC ==7.0.4, GHC ==7.4.1
Library Library
hs-source-dirs: source hs-source-dirs: source
Exposed: True Exposed: True
Build-Depends: base >4 && <5 Build-Depends: base >4 && <5
, conduit >= 0.5 , conduit >=0.5
, void -any , void >=0.5.5
, resourcet -any , resourcet >=0.3.0
, containers -any , containers >=0.4.0.0
, random -any , random >=1.0.0.0
, tls -any , tls >=1.0.0
, tls-extra -any , tls-extra >=0.5.0
, pureMD5 -any , pureMD5 >=2.1.2.1
, base64-bytestring -any , base64-bytestring >=0.1.0.0
, binary -any , binary >=0.4.1
, attoparsec -any , attoparsec >=0.10.0.3
, crypto-api -any , crypto-api >=0.9
, cryptohash -any , cryptohash >=0.6.1
, text -any , text >=0.11.1.5
, bytestring -any , bytestring >=0.9.1.9
, transformers -any , transformers >=0.2.2.0
, mtl -any , mtl >=2.0.0.0
, network -any , network >=2.3
, lifted-base -any , lifted-base >=0.1.0.1
, split -any , split >=0.1.2.3
, stm -any , stm >=2.1.2.1
, xml-types -any , xml-types >=0.3.1
, xml-conduit >= 1.0 , xml-conduit >=1.0
, xml-picklers >= 0.2.2 , xml-picklers >=0.2.2
, data-default -any , data-default >=0.2
, stringprep >= 0.1.5 , stringprep >=0.1.3
Exposed-modules: Network.Xmpp Exposed-modules: Network.Xmpp
, Network.Xmpp.Bind , Network.Xmpp.Bind
, Network.Xmpp.Concurrent , Network.Xmpp.Concurrent

16
source/Network/Xmpp.hs
Unescape View File

@ -4,7 +4,7 @@
-- Core). -- Core).
-- License: Apache License 2.0 -- License: Apache License 2.0
-- --
-- Maintainer: jon.kristensen@nejla.com -- Maintainer: info@jonkri.com
-- Stability: unstable -- Stability: unstable
-- Portability: portable -- Portability: portable
-- --
@ -85,11 +85,11 @@ module Network.Xmpp
, Message(..) , Message(..)
, MessageError(..) , MessageError(..)
, MessageType(..) , MessageType(..)
-- *** creating -- *** Creating
, answerMessage , answerMessage
-- *** sending -- *** Sending
, sendMessage , sendMessage
-- *** receiving -- *** Receiving
, pullMessage , pullMessage
, waitForMessage , waitForMessage
, waitForMessageError , waitForMessageError
@ -101,9 +101,9 @@ module Network.Xmpp
-- communication primitive: the presence stanza. -- communication primitive: the presence stanza.
, Presence(..) , Presence(..)
, PresenceError(..) , PresenceError(..)
-- *** creating -- *** Creating
, module Network.Xmpp.Presence , module Network.Xmpp.Presence
-- *** sending -- *** Sending
-- | Sends a presence stanza. In general, the presence stanza should have no -- | Sends a presence stanza. In general, the presence stanza should have no
-- 'to' attribute, in which case the server to which the client is connected -- 'to' attribute, in which case the server to which the client is connected
-- will broadcast that stanza to all subscribed entities. However, a -- will broadcast that stanza to all subscribed entities. However, a
@ -111,7 +111,7 @@ module Network.Xmpp
-- which case the server will route or deliver that stanza to the intended -- which case the server will route or deliver that stanza to the intended
-- recipient. -- recipient.
, sendPresence , sendPresence
-- *** receiving -- *** Receiving
, pullPresence , pullPresence
, waitForPresence , waitForPresence
-- ** IQ -- ** IQ
@ -141,7 +141,7 @@ module Network.Xmpp
, iqResultPayload , iqResultPayload
-- * Threads -- * Threads
, forkChans , forkChans
-- * Misc -- * Miscellaneous
, LangTag(..) , LangTag(..)
, exampleParams , exampleParams
) where ) where

11
source/Network/Xmpp/Concurrent/Monad.hs
Unescape View File

@ -6,6 +6,7 @@ import Network.Xmpp.Types
import Control.Applicative((<$>)) import Control.Applicative((<$>))
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar)
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Reader import Control.Monad.Reader
@ -151,7 +152,7 @@ waitForPresence f chans = 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 XmppConMonad 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.
@ -205,6 +206,14 @@ sendMessage m chans = sendStanza (MessageS m) chans
-- | Executes a function to update the event handlers. -- | Executes a function to update the event handlers.
modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO () modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO ()
modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f
where
-- Borrowing modifyTVar from
-- http://hackage.haskell.org/packages/archive/stm/2.4/doc/html/src/Control-Concurrent-STM-TVar.html
-- as it's not available in GHC 7.0.
modifyTVar :: TVar a -> (a -> a) -> STM ()
modifyTVar var f = do
x <- readTVar var
writeTVar var (f x)
-- | 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 -> Session -> IO ()) -> Session -> IO () setConnectionClosedHandler :: (StreamError -> Session -> IO ()) -> Session -> IO ()

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

@ -23,6 +23,9 @@ import qualified Data.Text as Text
import qualified Text.NamePrep as SP import qualified Text.NamePrep as SP
import qualified Text.StringPrep as SP import qualified Text.StringPrep as SP
-- | A JID is XMPP\'s native format for addressing entities in the network. It
-- is somewhat similar to an e-mail address but contains three parts instead of
-- two.
data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed
-- before the domainpart and separated from the latter by a -- before the domainpart and separated from the latter by a
-- \'\@\' character. Typically a localpart uniquely identifies -- \'\@\' character. Typically a localpart uniquely identifies
@ -105,12 +108,12 @@ fromStrings l d r = do
validPartLength :: Text -> Bool validPartLength :: Text -> Bool
validPartLength p = Text.length p > 0 && Text.length p < 1024 validPartLength p = Text.length p > 0 && Text.length p < 1024
-- | Returns True if the JID is /bare/, and False otherwise. -- | Returns 'True' if the JID is /bare/, and 'False' otherwise.
isBare :: Jid -> Bool isBare :: Jid -> Bool
isBare j | resourcepart j == Nothing = True isBare j | resourcepart j == Nothing = True
| otherwise = False | otherwise = False
-- | Returns True if the JID is 'full', and False otherwise. -- | Returns 'True' if the JID is /full/, and 'False' otherwise.
isFull :: Jid -> Bool isFull :: Jid -> Bool
isFull = not . isBare isFull = not . isBare

2
source/Network/Xmpp/Stream.hs
Unescape View File

@ -15,7 +15,7 @@ import Data.Maybe (fromJust, isJust, isNothing)
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 Data.Void(Void) import Data.Void (Void)
import Network.Xmpp.Monad import Network.Xmpp.Monad
import Network.Xmpp.Pickle import Network.Xmpp.Pickle

Write Preview
Loading…
Cancel
Save