pontarius-xmpp 0.1.0.1 → 0.1.0.2
raw patch · 5 files changed
+210/−65 lines, 5 files
Files
- examples/EchoClient.hs +0/−58
- pontarius-xmpp.cabal +6/−7
- source/Network/Xmpp/IM/Message.hs +121/−0
- source/Network/Xmpp/IM/Presence.hs +74/−0
- source/Network/Xmpp/Sasl/Mechanisms.hs +9/−0
− examples/EchoClient.hs
@@ -1,58 +0,0 @@-{---Copyright © 2010-2012 Jon Kristensen.--This file (EchoClient.hs) illustrates how to connect, authenticate, set a simple-presence, receive message stanzas, and echo them back to whoever is sending-them, using Pontarius. The contents of this file may be used freely, as if it is-in the public domain.---}---{-# LANGUAGE OverloadedStrings #-}---module Main (main) where--import Control.Monad (forever)-import Control.Monad.IO.Class (liftIO)-import Data.Maybe (fromJust, isJust)--import Network.Xmpp-import Network.Xmpp.IM----- Server and authentication details.--hostname = "localhost"---- portNumber = 5222 -- TODO-username = ""-password = ""-resource = Nothing----- TODO: Incomplete code, needs documentation, etc.-main :: IO ()-main = do- session <- newSession- withConnection (simpleConnect hostname username password resource) session- sendPresence presenceOnline session- echo session- return ()---- Pull message stanzas, verify that they originate from a `full' XMPP--- address, and, if so, `echo' the message back.-echo :: Session -> IO ()-echo session = forever $ do- result <- pullMessage session- case result of- Right message ->- if (isJust $ messageFrom message) &&- (isFull $ fromJust $ messageFrom message) then do- -- TODO: May not set from.- sendMessage (Message Nothing (messageTo message) (messageFrom message) Nothing (messageType message) (messagePayload message)) session- liftIO $ putStrLn "Message echoed!"- else liftIO $ putStrLn "Message sender is not set or is bare!"- Left exception -> liftIO $ putStrLn "Error: "
pontarius-xmpp.cabal view
@@ -1,5 +1,5 @@ Name: pontarius-xmpp-Version: 0.1.0.1+Version: 0.1.0.2 Cabal-Version: >= 1.6 Build-Type: Simple License: OtherLicense@@ -11,7 +11,7 @@ Stability: alpha Homepage: http://www.pontarius.org/ 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.2/pontarius-xmpp-0.1.0.2.tar.gz Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) Description: Pontarius is a work in progress implementation of RFC 6120 (XMPP: Core).@@ -56,12 +56,15 @@ , Network.Xmpp.Bind , Network.Xmpp.Concurrent , Network.Xmpp.IM+ , Network.Xmpp.IM.Message+ , Network.Xmpp.IM.Presence , Network.Xmpp.Marshal , Network.Xmpp.Monad , Network.Xmpp.Message , Network.Xmpp.Pickle , Network.Xmpp.Presence , Network.Xmpp.Sasl+ , Network.Xmpp.Sasl.Mechanisms , Network.Xmpp.Sasl.Mechanisms.Plain , Network.Xmpp.Sasl.Mechanisms.DigestMd5 , Network.Xmpp.Sasl.Mechanisms.Scram@@ -85,10 +88,6 @@ , Network.Xmpp.Errors GHC-Options: -Wall -Executable pontarius-xmpp-echoclient- hs-source-dirs: examples- Main-Is: EchoClient.hs- Source-Repository head Type: git Location: git://github.com/jonkri/pontarius-xmpp.git@@ -97,5 +96,5 @@ Type: git -- Module: Location: git://github.com/jonkri/pontarius-xmpp.git- Tag: 0.1.0.0+ Tag: 0.1.0.2 -- Subdir:
+ source/Network/Xmpp/IM/Message.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Xmpp.IM.Message+ where++import Control.Applicative ((<$>))++import Data.Maybe (maybeToList)+import Data.Text (Text)+import Data.XML.Pickle+import Data.XML.Types++import Network.Xmpp.Types+import Network.Xmpp.Pickle++data MessageBody = MessageBody (Maybe LangTag) Text+data MessageThread = MessageThread+ Text -- Thread ID+ (Maybe Text) -- Parent Thread+data MessageSubject = MessageSubject (Maybe LangTag) Text++xpMessageSubject :: PU [Element] MessageSubject+xpMessageSubject = xpUnliftElems .+ xpWrap (\(l, s) -> MessageSubject l s)+ (\(MessageSubject l s) -> (l,s))+ $ xpElem "{jabber:client}subject" xpLangTag $ xpContent xpId++xpMessageBody :: PU [Element] MessageBody+xpMessageBody = xpUnliftElems .+ xpWrap (\(l, s) -> MessageBody l s)+ (\(MessageBody l s) -> (l,s))+ $ xpElem "{jabber:client}body" xpLangTag $ xpContent xpId++xpMessageThread :: PU [Element] MessageThread+xpMessageThread = xpUnliftElems+ . xpWrap (\(t, p) -> MessageThread p t)+ (\(MessageThread p t) -> (t,p))+ $ xpElem "{jabber:client}thread"+ (xpAttrImplied "parent" xpId)+ (xpContent xpId)++-- | Get the subject elements of a message (if any). Messages may+-- contain multiple subjects if each of them has a distinct xml:lang+-- attribute+subject :: Message -> [MessageSubject]+subject m = ms+ where+ -- xpFindMatches will _always_ return Right+ Right ms = unpickle (xpFindMatches xpMessageSubject) $ messagePayload m++-- | Get the thread elements of a message (if any). The thread of a+-- message is considered opaque, that is, no meaning, other than it's+-- literal identity, may be derived from it and it is not human+-- readable+thread :: Message -> Maybe MessageThread+thread m = ms+ where+ -- xpFindMatches will _always_ return Right+ Right ms = unpickle (xpOption xpMessageThread) $ messagePayload m++-- | Get the body elements of a message (if any). Messages may contain+-- multiple bodies if each of them has a distinct xml:lang attribute+body :: Message -> [MessageBody]+body m = ms+ where+ -- xpFindMatches will _always_ return Right+ Right ms = unpickle (xpFindMatches xpMessageBody) $ messagePayload m++-- | Generate a new instant message+newIM+ :: Jid+ -> Maybe StanzaId+ -> Maybe LangTag+ -> MessageType+ -> Maybe MessageSubject+ -> Maybe MessageThread+ -> Maybe MessageBody+ -> [Element]+ -> Message+newIM t i lang tp sbj thrd bdy payload = Message+ { messageID = i+ , messageFrom = Nothing+ , messageTo = Just t+ , messageLangTag = lang+ , messageType = tp+ , messagePayload = concat $+ maybeToList (pickle xpMessageSubject <$> sbj)+ ++ maybeToList (pickle xpMessageThread <$> thrd)+ ++ maybeToList (pickle xpMessageBody <$> bdy)+ ++ [payload]+ }++-- | Generate a simple instance message+simpleIM :: Jid -> Text -> Message+simpleIM t bd = newIM+ t+ Nothing+ Nothing+ Normal+ Nothing+ Nothing+ (Just $ MessageBody Nothing bd)+ []++-- | Generate an answer from a received message. The recepient is+-- taken from the original sender, the sender is set to Nothing,+-- message ID, language tag, message type as well as subject and+-- thread are inherited, the remaining payload is replaced by the+-- given one+answerIM :: Maybe MessageBody -> [Element] -> Message -> Message+answerIM bd payload msg = Message+ { messageID = messageID msg+ , messageFrom = Nothing+ , messageTo = messageFrom msg+ , messageLangTag = messageLangTag msg+ , messageType = messageType msg+ , messagePayload = concat $+ (pickle xpMessageSubject <$> subject msg)+ ++ maybeToList (pickle xpMessageThread <$> thread msg)+ ++ maybeToList (pickle xpMessageBody <$> bd)+ ++ [payload]+ }
+ source/Network/Xmpp/IM/Presence.hs view
@@ -0,0 +1,74 @@+module Network.Xmpp.IM.Presence where++import Data.Text(Text)+import Network.Xmpp.Types++-- | An empty presence.+presence :: Presence+presence = Presence { presenceID = Nothing+ , presenceFrom = Nothing+ , presenceTo = Nothing+ , presenceLangTag = Nothing+ , presenceType = Nothing+ , presencePayload = []+ }++-- | Request subscription with an entity.+presenceSubscribe :: Jid -> Presence+presenceSubscribe to = presence { presenceTo = Just to+ , presenceType = Just Subscribe+ }++-- | Is presence a subscription request?+isPresenceSubscribe :: Presence -> Bool+isPresenceSubscribe pres = presenceType pres == (Just Subscribe)++-- | Approve a subscripton of an entity.+presenceSubscribed :: Jid -> Presence+presenceSubscribed to = presence { presenceTo = Just to+ , presenceType = Just Subscribed+ }++-- | Is presence a subscription approval?+isPresenceSubscribed :: Presence -> Bool+isPresenceSubscribed pres = presenceType pres == (Just Subscribed)++-- | End a subscription with an entity.+presenceUnsubscribe :: Jid -> Presence+presenceUnsubscribe to = presence { presenceTo = Just to+ , presenceType = Just Unsubscribed+ }++-- | Is presence an unsubscription request?+isPresenceUnsubscribe :: Presence -> Bool+isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe)++-- | Signal to the server that the client is available for communication.+presenceOnline :: Presence+presenceOnline = presence++-- | Signal to the server that the client is no longer available for+-- communication.+presenceOffline :: Presence+presenceOffline = presence {presenceType = Just Unavailable}++---- Change your status+--status+-- :: Maybe Text -- ^ Status message+-- -> Maybe ShowType -- ^ Status Type+-- -> Maybe Int -- ^ Priority+-- -> Presence+--status txt showType prio = presence { presenceShowType = showType+-- , presencePriority = prio+-- , presenceStatus = txt+-- }++-- | Set the current availability status. This implicitly sets the client's+-- status online.+--presenceAvail :: ShowType -> Presence+--presenceAvail showType = status Nothing (Just showType) Nothing++-- | Set the current status message. This implicitly sets the client's status+-- online.+--presenceMessage :: Text -> Presence+--presenceMessage txt = status (Just txt) Nothing Nothing
+ source/Network/Xmpp/Sasl/Mechanisms.hs view
@@ -0,0 +1,9 @@+module Network.Xmpp.Sasl.Mechanisms+ ( module Network.Xmpp.Sasl.Mechanisms.DigestMd5+ , module Network.Xmpp.Sasl.Mechanisms.Scram+ , module Network.Xmpp.Sasl.Mechanisms.Plain+ ) where++import Network.Xmpp.Sasl.Mechanisms.DigestMd5+import Network.Xmpp.Sasl.Mechanisms.Scram+import Network.Xmpp.Sasl.Mechanisms.Plain