diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs deleted file mode 100644 --- a/examples/EchoClient.hs +++ /dev/null @@ -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: " diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -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: diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/Message.hs @@ -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] + } diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM/Presence.hs @@ -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 diff --git a/source/Network/Xmpp/Sasl/Mechanisms.hs b/source/Network/Xmpp/Sasl/Mechanisms.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Mechanisms.hs @@ -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