haskell-xmpp (empty) → 1.0
raw patch · 24 files changed
+2325/−0 lines, 24 filesdep +HaXmldep +arraydep +basesetup-changed
Dependencies added: HaXml, array, base, html, mtl, network, polyparse, pretty, random, regex-compat, stm, utf8-string
Files
- LICENSE +23/−0
- README +14/−0
- Setup.hs +3/−0
- examples/Test.hs +126/−0
- haskell-xmpp.cabal +64/−0
- src/Network/XMPP.hs +41/−0
- src/Network/XMPP/Base64.hs +281/−0
- src/Network/XMPP/Concurrent.hs +114/−0
- src/Network/XMPP/Core.hs +83/−0
- src/Network/XMPP/Helpers.hs +55/−0
- src/Network/XMPP/IM/Presence.hs +60/−0
- src/Network/XMPP/IQ.hs +45/−0
- src/Network/XMPP/JID.hs +51/−0
- src/Network/XMPP/MD5.hs +374/−0
- src/Network/XMPP/Print.hs +96/−0
- src/Network/XMPP/Sasl.hs +114/−0
- src/Network/XMPP/Stanza.hs +137/−0
- src/Network/XMPP/Stream.hs +153/−0
- src/Network/XMPP/Types.hs +224/−0
- src/Network/XMPP/UTF8.hs +53/−0
- src/Network/XMPP/Utils.hs +90/−0
- src/Network/XMPP/XEP/Delayed.hs +30/−0
- src/Network/XMPP/XEP/MUC.hs +50/−0
- src/Network/XMPP/XEP/Version.hs +44/−0
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright 2005-2011, Dmitry Astapov+All Rights Reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistribution of source code must retain the above copyright notice,+this list of conditions and the following disclamer.++- Redistribution in binary form must reproduce the above copyright notice,+this list of conditions and the following disclamer in the documentation+and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,14 @@+Attempt to write an XMPP bindings for haskell++Alpha-version/work in progress++To build, obtain and install latest HaXml +(darcs get http://www.cs.york.ac.uk/fp/darcs/HaXml)+, then use supplied rebuild.sh++Questions or proposals?+Contact dastapov at gmail.com (via mail),+adept at jabber.kiev.ua (via XMPP :)+or adept at #haskell (via IRC)++Patches? "darcs send" them to dastapov@gmail.com
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ examples/Test.hs view
@@ -0,0 +1,126 @@+module Main where++import Control.Monad.Trans (liftIO)+import Data.List++import Network.XMPP+import Network.XMPP.IQ+import Network.XMPP.XEP.MUC+import Network.XMPP.XEP.Version+import Network.XMPP.Concurrent+import Control.Monad+import qualified Text.XML.HaXml.Pretty as P (content)+import Text.XML.HaXml.Xtract.Parse (xtract)++iqVersionT1 :: XmppThreadT ()+iqVersionT1 = do+ st <- readChanS + liftIO $ putStrLn ("thread1 got message! ")+ when (isVersionReq st) $ do + writeChanS $ presAway "abcd"+ liftIO $ putStrLn ("thread1 SENT message!")+ iqVersionT1++iqVersionT2 :: XmppThreadT ()+iqVersionT2 = do+ st <- readChanS + liftIO $ putStrLn ("thread2 got message! ")+ when (isVersionReq st) $ do + writeChanS $ presAway "AAAAAAAA!!!!"+ liftIO $ putStrLn ("thread2 SENT message!")+ iqVersionT2 ++iqVersion :: XmppThreadT ()+iqVersion =+ loop $ iqReplyTo isVersionReq (versionAnswer "Network.XMPP test" version "Linux")+ +main = + do let user = "testbot"+ let pass = "testing"+ let server = "xmpp.org.ru"+ let resource = "haskell-xmpp-devel"+ let room = "testing@conference.jabber.ru" + withNewStream $ + do h <- liftIO $ connectViaTcp server 5222+ (jid,_) <- initiateStream h server user pass resource+ liftIO $ putStrLn $ "My jid is " ++ show jid+ outStanza $ presAvailable "Hello, world!"+ runThreaded $ do+ withNewThread $ iqVersion+ withNewThread $ iqVersionT2+ return ()+{- + -- Query and dump roster+ --out $ iq ! [ id_ "roster-get", type_ "get" ] << query_ "jabber:iq:roster"+ --roster <- xtractM "/iq[@type='result' & @id='roster-get']/query"+ --liftIO $ do putStrLn "Your roster:"+ -- putStrLn $ show $ map P.content roster+ out $ iq ! [ id_ "roster-get", type_ "get" ] << query_ "jabber:iq:roster"+ roster <- parseM+ liftIO $ putStrLn $ show roster+-}+ -- Set presence to defalt + + mucJoin (read "testing@conference.jabber.ru/testbot")+ mucLeave (read "testing@conference.jabber.ru/testbot")+{- + -- Sit in MUC room, echoing all messages+ -- We echo all messages sent to MUC room or private chat,+ -- except messages sent by us and history messages sent upon entering the room+ let addr_sel = concat [ "@to=",show jid," & @from!=", show (room++"/"++user) ]+ -- FIXME: For some reason, negated conditions will have to be last in the xtract query, otherwise+ -- it behaves in odd way+ let all_msgs_to_me_xtract = concat [ "/message[", addr_sel," & @type='groupchat' & ~(x/@xmlns='jabber:x:delay')]"]+ liftIO $ putStrLn $ "Will select messages with filter: " ++ all_msgs_to_me_xtract++ let plugins = [ Plugin all_msgs_to_me_xtract (echo room)+ , Plugin (concat ["/message[",addr_sel," & @type='chat' & ~(x/@xmlns='jabber:x:delay')]"]) privecho+ , Plugin "/iq[@type='get']/query[@xmlns='jabber:iq:version']" iq_version+ ]++ loopWithPlugins plugins+-}++{-+echo room m = + do let text = getText_ $ xtract id "/message/body/-" m+ if ("lambdabot:" `isPrefixOf` text)+ then do i <- getNextId+ out $ message ! [ to room, type_ "groupchat", id_ (show i), xmllang "en" ] << body_ << ("Echo: " ++ text)+ else return ()++privecho m = + do let text = getText_ $ xtract id "/message/body/-" m+ let sender = getText_ $ xtract id "/message/@from" m+ i <- getNextId+ out $ message ! [ to sender, type_ "chat", id_ (show i), xmllang "en" ] << body_ << ("Echo: " ++ text)++iq_version m =+ do let sender = getText_ $ xtract id "/iq/@from" m+ let i = getText_ $ xtract id "/iq/@id" m+ out $ iq ! [ id_ i , to sender, type_ "result", xmllang "en" ]+ << fullquery "jabber:iq:version" << ( name_ << "lambdabot"+ +++ version_ << "0.1"+ +++ os << "Debian GNU/Linux testing/unstable 2.6.16-1-686" )+-}++{-+IN(1,adept@jabber.kiev.ua/work):+<iq from='devel@conference.jabber.ru/sulci'+ to='adept@jabber.kiev.ua/work'+ id='stoat_10787'+ type='get'>+ <query xmlns='jabber:iq:version'/>+</iq>+OUT(1,adept@jabber.kiev.ua/work):+<iq id='stoat_10787'+ to='devel@conference.jabber.ru/sulci'+ type='result'+ xml:lang='en'>+ <query xmlns='jabber:iq:version'>+ <name>Tkabber</name>+ <version>0.9.8-alpha-20060521 (Tcl/Tk 8.4.12)</version>+ <os>Debian GNU/Linux testing/unstable 2.6.16-1-686</os>+ </query>+</iq>+-}
+ haskell-xmpp.cabal view
@@ -0,0 +1,64 @@+Name: haskell-xmpp+Version: 1.0+License: BSD3+License-File: LICENSE+Author: Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>+Maintainer: Dmitry Astapov <dastapov@gmail.com>+Homepage: http://adept.linux.kiev.ua/repos/xmpp+Category: Network+Copyright: (c) 2005-2011 Dmitry Astapov, k.pierre+Stability: Stable+Cabal-version: >=1.6+Tested-with: GHC==6.10.4, GHC==6.12.1+Build-type: Simple +Bug-reports: mailto: dastapov@gmail.com+Extra-source-files: README examples/Test.hs++Synopsis: Haskell XMPP (eXtensible Message Passing Protocol, a.k.a. Jabber) library+Description: Haskell XMPP (eXtensible Message Passing Protocol, a.k.a. Jabber) library+ .+ Unlike package network-protocol-xmpp, which uses libxml-sax, this library uses HaXml and supports MUC.+ However, MUC support of the moment is worse than that in package XMPP.+ .+ This library make extensive use of STM and threads to simplify writing message-handling code.++source-repository head+ type: darcs+ location: adept@patch-tag.com:/r/adept/haskell-xmpp++flag examples+ description: Build examples+ default: False++library+ Hs-Source-Dirs: ./src+ Build-Depends: base > 3 && <=5, random, pretty, array, HaXml >= 1.20.2, mtl >= 1.0, network, html, polyparse, regex-compat, stm, utf8-string+ Exposed-modules: Network.XMPP+ , Network.XMPP.Sasl+ , Network.XMPP.Core+ , Network.XMPP.Types+ , Network.XMPP.Print+ , Network.XMPP.Helpers+ , Network.XMPP.Stream+ , Network.XMPP.Stanza+ , Network.XMPP.Utils+ , Network.XMPP.IM.Presence+ , Network.XMPP.JID+ , Network.XMPP.IQ+ , Network.XMPP.UTF8+ , Network.XMPP.MD5+ , Network.XMPP.Base64+ , Network.XMPP.XEP.MUC+ , Network.XMPP.XEP.Delayed+ , Network.XMPP.XEP.Version+ , Network.XMPP.Concurrent+ GHC-Options: -Wall -fno-warn-name-shadowing -fno-warn-orphans++Executable haskell-xmpp-test+ Hs-Source-Dirs: ./examples+ if flag(examples)+ build-depends: base > 3 && <=5+ else+ buildable: False+ Main-Is: Test.hs+ GHC-Options: -Wall -fno-warn-name-shadowing -fno-warn-orphans
+ src/Network/XMPP.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP+-- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Convenience module that re-exports all things XMPP+--+-----------------------------------------------------------------------------++module Network.XMPP + ( module Network.XMPP.JID+ , module Network.XMPP.Sasl+ , module Network.XMPP.Core+ , module Network.XMPP.Helpers+ , module Network.XMPP.Print+ , module Network.XMPP.Types+ , module Network.XMPP.Stream+ , module Network.XMPP.Stanza+ , module Network.XMPP.IM.Presence+ , version+ ) where++import Network.XMPP.JID+import Network.XMPP.Sasl+import Network.XMPP.Core+import Network.XMPP.Helpers+import Network.XMPP.Print+import Network.XMPP.Types+import Network.XMPP.Stream+import Network.XMPP.Stanza++-- IM utilities modules+import Network.XMPP.IM.Presence++version :: String+version = "0.4-alpha"
+ src/Network/XMPP/Base64.hs view
@@ -0,0 +1,281 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Base64+-- Copyright : (c) Dmitry Astapov 2006, Dominic Steinitz 2005, Warrick Gray 2002+-- License : BSD-style (see the file ReadMe.tex)+--+-- Maintainer : dastapov@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> +-- and <http://www.faqs.org/rfcs/rfc2045.html>.+--+-----------------------------------------------------------------------------++module Network.XMPP.Base64 (+ encode,+ decode,+ chop72+) where++++{------------------------------------------------------------------------+This is what RFC2045 had to say:++6.8. Base64 Content-Transfer-Encoding++ The Base64 Content-Transfer-Encoding is designed to represent+ arbitrary sequences of octets in a form that need not be humanly+ readable. The encoding and decoding algorithms are simple, but the+ encoded data are consistently only about 33 percent larger than the+ unencoded data. This encoding is virtually identical to the one used+ in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421.++ A 65-character subset of US-ASCII is used, enabling 6 bits to be+ represented per printable character. (The extra 65th character, "=",+ is used to signify a special processing function.)++ NOTE: This subset has the important property that it is represented+ identically in all versions of ISO 646, including US-ASCII, and all+ characters in the subset are also represented identically in all+ versions of EBCDIC. Other popular encodings, such as the encoding+ used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and+ the base85 encoding specified as part of Level 2 PostScript, do not+ share these properties, and thus do not fulfill the portability+ requirements a binary transport encoding for mail must meet.++ The encoding process represents 24-bit groups of input bits as output+ strings of 4 encoded characters. Proceeding from left to right, a+ 24-bit input group is formed by concatenating 3 8bit input groups.+ These 24 bits are then treated as 4 concatenated 6-bit groups, each+ of which is translated into a single digit in the base64 alphabet.+ When encoding a bit stream via the base64 encoding, the bit stream+ must be presumed to be ordered with the most-significant-bit first.+ That is, the first bit in the stream will be the high-order bit in+ the first 8bit byte, and the eighth bit will be the low-order bit in+ the first 8bit byte, and so on.++ Each 6-bit group is used as an index into an array of 64 printable+ characters. The character referenced by the index is placed in the+ output string. These characters, identified in Table 1, below, are+ selected so as to be universally representable, and the set excludes+ characters with particular significance to SMTP (e.g., ".", CR, LF)+ and to the multipart boundary delimiters defined in RFC 2046 (e.g.,+ "-").++++ Table 1: The Base64 Alphabet++ Value Encoding Value Encoding Value Encoding Value Encoding+ 0 A 17 R 34 i 51 z+ 1 B 18 S 35 j 52 0+ 2 C 19 T 36 k 53 1+ 3 D 20 U 37 l 54 2+ 4 E 21 V 38 m 55 3+ 5 F 22 W 39 n 56 4+ 6 G 23 X 40 o 57 5+ 7 H 24 Y 41 p 58 6+ 8 I 25 Z 42 q 59 7+ 9 J 26 a 43 r 60 8+ 10 K 27 b 44 s 61 9+ 11 L 28 c 45 t 62 ++ 12 M 29 d 46 u 63 /+ 13 N 30 e 47 v+ 14 O 31 f 48 w (pad) =+ 15 P 32 g 49 x+ 16 Q 33 h 50 y++ The encoded output stream must be represented in lines of no more+ than 76 characters each. All line breaks or other characters not+ found in Table 1 must be ignored by decoding software. In base64+ data, characters other than those in Table 1, line breaks, and other+ white space probably indicate a transmission error, about which a+ warning message or even a message rejection might be appropriate+ under some circumstances.++ Special processing is performed if fewer than 24 bits are available+ at the end of the data being encoded. A full encoding quantum is+ always completed at the end of a body. When fewer than 24 input bits+ are available in an input group, zero bits are added (on the right)+ to form an integral number of 6-bit groups. Padding at the end of+ the data is performed using the "=" character. Since all base64+ input is an integral number of octets, only the following cases can+ arise: (1) the final quantum of encoding input is an integral+ multiple of 24 bits; here, the final unit of encoded output will be+ an integral multiple of 4 characters with no "=" padding, (2) the+ final quantum of encoding input is exactly 8 bits; here, the final+ unit of encoded output will be two characters followed by two "="+ padding characters, or (3) the final quantum of encoding input is+ exactly 16 bits; here, the final unit of encoded output will be three+ characters followed by one "=" padding character.++ Because it is used only for padding at the end of the data, the+ occurrence of any "=" characters may be taken as evidence that the+ end of the data has been reached (without truncation in transit). No+ such assurance is possible, however, when the number of octets+ transmitted was a multiple of three and no "=" characters are+ present.++ Any characters outside of the base64 alphabet are to be ignored in+ base64-encoded data.++ Care must be taken to use the proper octets for line breaks if base64+ encoding is applied directly to text material that has not been+ converted to canonical form. In particular, text line breaks must be+ converted into CRLF sequences prior to base64 encoding. The+ important thing to note is that this may be done directly by the+ encoder rather than in a prior canonicalization step in some+ implementations.++ NOTE: There is no need to worry about quoting potential boundary+ delimiters within base64-encoded bodies within multipart entities+ because no hyphen characters are used in the base64 encoding.+++----------------------------------------------------------------------------}+++{-++The following properties should hold:++ decode . encode = id+ decode . chop72 . encode = id++I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input,+the second variation corresponds better with the RFC above, but outside of+MIME applications might be undesireable.++++But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only + 8 significant bits, which is more than enough for US-ASCII. +-}+++++import Data.Array+import Data.Bits+import Data.Int+import Data.Char (chr,ord)++encodeArray :: Array Int Char+encodeArray = array (0,64) + [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') + , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') + , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R')+ , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X')+ , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')+ , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j')+ , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p')+ , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v')+ , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1')+ , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7')+ , (60,'8'), (61,'9'), (62,'+'), (63,'/') ]+++-- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits)+-- clearly the upmost/leftmost 8 bits of the answer are 0.+-- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3.+-- 0 represents a 4 :(+int4_char3 :: [Int] -> [Char]+int4_char3 (a:b:c:d:t) = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d)+ in (chr (n `shiftR` 16 .&. 0xff))+ : (chr (n `shiftR` 8 .&. 0xff))+ : (chr (n .&. 0xff)) : int4_char3 t++int4_char3 [a,b,c] =+ let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6)+ in [ (chr (n `shiftR` 16 .&. 0xff))+ , (chr (n `shiftR` 8 .&. 0xff)) ]++int4_char3 [a,b] = + let n = (a `shiftL` 18 .|. b `shiftL` 12)+ in [ (chr (n `shiftR` 16 .&. 0xff)) ]++int4_char3 [] = [] +++++-- Convert triplets of characters to+-- 4 base64 integers. The last entries+-- in the list may not produce 4 integers,+-- a trailing 2 character group gives 3 integers,+-- while a trailing single character gives 2 integers.+char3_int4 :: [Char] -> [Int]+char3_int4 (a:b:c:t) + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c)+ in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t++char3_int4 [a,b]+ = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8)+ in [ (n `shiftR` 18 .&. 0x3f)+ , (n `shiftR` 12 .&. 0x3f)+ , (n `shiftR` 6 .&. 0x3f) ]+ +char3_int4 [a]+ = let n = (ord a `shiftL` 16)+ in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]++char3_int4 [] = []+++-- Retrieve base64 char, given an array index integer in the range [0..63]+enc1 :: Int -> Char+enc1 ch = encodeArray!ch+++-- | Cut up a string into 72 char lines, each line terminated by CRLF.++chop72 :: String -> String+chop72 str = let (bgn,end) = splitAt 70 str+ in if null end then bgn else "\r\n" ++ chop72 end+++-- Pads a base64 code to a multiple of 4 characters, using the special+-- '=' character.+quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t+quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit+quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit+quadruplets [] = [] -- 24bit tail unit+++enc :: [Int] -> [Char]+enc = quadruplets . map enc1+++dcd [] = []+dcd (h:t)+ | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t+ | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t+ | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t+ | h == '+' = 62 : dcd t+ | h == '/' = 63 : dcd t+ | h == '=' = [] -- terminate data stream+ | otherwise = dcd t+++-- Principal encoding and decoding functions.++encode :: String -> String+encode = enc . char3_int4++{-+prop_base64 os =+ os == (f . g . h) os+ where types = (os :: [Word8])+ f = map (fromIntegral. ord)+ g = decode . encode+ h = map (chr . fromIntegral)+-}++decode :: String -> String+decode = int4_char3 . dcd
+ src/Network/XMPP/Concurrent.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Concurrent+-- Copyright : (c) pierre, 2007+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : k.pierre.k@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Concurrent actions over single IO channel+--+-----------------------------------------------------------------------------+module Network.XMPP.Concurrent+ ( Thread+ , XmppThreadT+ , runThreaded+ , readChanS+ , writeChanS+ , withNewThread+ , loop+ , waitFor+ ) where++import Network.XMPP.Stream+import Network.XMPP.Stanza+import Network.XMPP.Types+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TChan+import Control.Monad.Trans (liftIO)+import Control.Monad+import Control.Monad.State +import Control.Monad.Reader +import Data.Maybe+import Network.XMPP.XEP.Version +import Network.XMPP.IM.Presence +import Network.XMPP.Utils++import System.IO+ +data Thread = Thread { inCh :: TChan Stanza+ , outCh :: TChan Stanza+ }++type XmppThreadT a = ReaderT Thread IO a+ +-- Two streams: input and output. Threads read from input stream and write to output stream.+-- | Runs thread in XmppState monad+runThreaded :: XmppThreadT () -> XmppStateT ()+runThreaded a = do+ in' <- liftIO $ atomically $ newTChan+ out' <- liftIO $ atomically $ newTChan+ liftIO $ forkIO $ runReaderT a (Thread in' out')+ s <- get+ liftIO $ forkIO $ loopWrite s out'+ liftIO $ forkIO $ connPersist (handle s)+ loopRead in' + where + loopRead in' = loop $ + do + st <- parseM+ liftIO $ atomically $ writeTChan in' st+ loopWrite s out' =+ do+ withNewStream $ do+ put s+ loop $ do+ st <- liftIO $ atomically $ readTChan out'+ outStanza st+ return () + loop = sequence_ . repeat+ +readChanS :: XmppThreadT Stanza+readChanS = do+ c <- asks inCh + st <- liftIO $ atomically $ readTChan c+ return st ++writeChanS :: Stanza -> XmppThreadT ()+writeChanS a = do+ c <- asks outCh+ st <- liftIO $ atomically $ writeTChan c a + return ()++-- | Runs specified action in parallel+withNewThread :: XmppThreadT () -> XmppThreadT ThreadId+withNewThread a = do+ in' <- asks inCh+ out' <- asks outCh+ newin <- liftIO $ atomically $ dupTChan in'+ liftIO $ forkIO $ runReaderT a (Thread newin out')++-- | Turns action into infinite loop+loop :: XmppThreadT () -> XmppThreadT ()+loop a = do+ a+ loop a++waitFor :: (Stanza -> Bool) -> XmppThreadT Stanza+waitFor f = do+ s <- readChanS+ if (f s) then + return s+ else do+ waitFor f++connPersist :: Handle -> IO ()+connPersist h = do+ hPutStr h " "+ putStrLn "<space added>"+ threadDelay 30000000+ connPersist h+
+ src/Network/XMPP/Core.hs view
@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Core+-- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Implementation of XMPP Core Protocol (RFC 3920)+--+-----------------------------------------------------------------------------++module Network.XMPP.Core+ ( initiateStream+ ) where++import Control.Monad.State+import System.IO++import Network.XMPP.Sasl (saslAuth)+import Network.XMPP.Print+import Network.XMPP.Stream+import Network.XMPP.Types+import Network.XMPP.JID+import Network.XMPP.IQ+import Network.XMPP.Utils++-- | Open connection to specified server and return `Stream' coming from it+initiateStream :: Handle+ -> String -- ^ Server (hostname) we are connecting to+ -> String -- ^ Username to use+ -> String -- ^ Password to use+ -> String -- ^ Resource to use+ -> XmppStateT (JID, Stream) -- ^ Return (jid, stream)+initiateStream h server username password resrc =+ do liftIO $ hSetBuffering h NoBuffering+ resetStreamHandle h+ out $ toContent $+ stream Client server+ attrs <- startM+ case (lookupAttr "version" attrs) of+ Just "1.0" -> return ()+ Nothing ->+ -- TODO: JEP 0078+ -- in case of absent of version we wont process stream:features+ error "No version"+ _ -> error "unknown version"+ + debug "Stream started"+ --debug $ "Observing: " ++ render (P.content m)+ m <- xtractM "/stream:features/mechanisms/mechanism/-"+ let mechs = map getText m+ debug $ "Mechanisms: " ++ show mechs++ -- Handle the authentication+ saslAuth mechs server username password++ out $ toContent $+ stream Client server+ + startM+ + -- Bind this session to resource+ xtractM "/stream:features/bind" -- `catch` (fail "Binding is not proposed") ++ iqSend "bind1" Set + [ ptag "bind" [ xmlns "urn:ietf:params:xml:ns:xmpp-bind" ]+ [ ptag "resource" []+ [ literal $ resrc ]+ ]+ ]+ + my_jid <- textractM "/iq[@type='result' & @id='bind1']/bind/jid/-"++ iqSend "session1" Set + [ itag "session" [xmlns "urn:ietf:params:xml:ns:xmpp-session" ] ]++ xtractM "/iq[@type='result' & @id='session1']" -- (error "Session binding failed")++ stream <- get + return (read $ my_jid, stream)
+ src/Network/XMPP/Helpers.hs view
@@ -0,0 +1,55 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Helpers+-- Copyright : (c) Dmitry Astapov, 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Various "connection helpers" that let user obtain a handle to pass to 'initiateStream'+--+-----------------------------------------------------------------------------++module Network.XMPP.Helpers + ( connectViaHttpProxy+ , connectViaTcp+ , openStreamFile+ ) where++import System.IO (Handle, hPutStrLn, hPutStr, hGetLine, openFile, IOMode(..))+import Network (connectTo, PortID(..) )+import Network.Socket+import Network.BSD+import Control.Concurrent (threadDelay, forkIO)+import Control.Monad.Trans (liftIO)++-- | Connect to XMPP server on specified host \/ port+connectViaTcp :: String -- ^ Server (hostname) to connect to+ -> Int -- ^ Port to connect to+ -> IO Handle+connectViaTcp server port = do+ host <- getHostByName server+ sock <- socket AF_INET Stream 0+ setSocketOption sock KeepAlive 1+ connect sock (SockAddrInet (fromIntegral port) (head $ hostAddresses host))+ socketToHandle sock ReadWriteMode ++-- | Connect to XMPP server on specified host \/ port+-- via HTTP 1.0 proxy+connectViaHttpProxy proxy_server proxy_port server port =+ do h <- connectTo proxy_server (PortNumber (fromIntegral proxy_port))+ hPutStrLn h $ unlines [ concat ["CONNECT ",server,":",show port," HTTP/1.0"]+ , "Connection: Keep-Alive" ]+ dropHeaders h+ liftIO $ forkIO $ pinger h+ return h+ where dropHeaders h = do l <- hGetLine h+ putStrLn $ "Got: " ++ l+ if words l /= [] then dropHeaders h+ else return ()+ pinger h = hPutStr h " " >> threadDelay (30 * 10^6) >> pinger h++-- | Open file with pre-captured server-to-client XMPP stream. For debugging+openStreamFile fname = openFile fname ReadMode
+ src/Network/XMPP/IM/Presence.hs view
@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.IM.Presence+-- Copyright : (c) pierre, 2007+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : k.pierre.k@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- XMPP presence utilities+--+-----------------------------------------------------------------------------+module Network.XMPP.IM.Presence+ (+ presAvailable+ , presUnavailable+ , presAway+ , presXa+ , presChat+ , presDND+ ) where++import Network.XMPP.Types++-- | Default presence, should be sent at first+presAvailable :: String -- ^ Status message+ -> Stanza+presAvailable status = Presence Nothing Nothing "" Default Available status (Just 0) []++-- | Should be sent at last+presUnavailable :: String -> Stanza+presUnavailable status = mkPresenceU Available status++presAway :: String -> Stanza+presAway status = mkPresenceD Away status+ +presXa :: String -> Stanza+presXa status = mkPresenceD XAway status++presChat :: String -> Stanza+presChat status = mkPresenceD FreeChat status++presDND :: String -> Stanza+presDND status = mkPresenceD DND status++-- | Helper to contruct presence Stanza with required attrs+mkPresence :: PresenceType -> ShowType -> String -> Stanza+mkPresence typ showType status = + Presence Nothing -- pFrom+ Nothing -- PTo+ "" -- pId+ typ+ showType+ status+ (Just 0) -- pPriority :: Maybe Integer+ [] -- pExt :: [Content Posn]++mkPresenceD = mkPresence Default+mkPresenceU = mkPresence Unavailable
+ src/Network/XMPP/IQ.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.IQ+-- Copyright : (c) pierre, 2007+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : k.pierre.k@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- XMPP IQ utilites+--+-----------------------------------------------------------------------------++module Network.XMPP.IQ+ ( iqSend+ , iqReplyTo+ ) where ++import Network.XMPP.Types+import Network.XMPP.Stanza+import Network.XMPP.Utils+import Network.XMPP.Concurrent+ +import Text.XML.HaXml+import Text.XML.HaXml.Posn ++-- | Send IQ of specified type with supplied data+iqSend :: String -- ^ ID to use+ -> IQType -- ^ IQ type+ -> [CFilter Posn] -- ^ request contents + -> XmppStateT ()+iqSend id t d = do+ outStanza $ IQ Nothing Nothing id t (map toContent d) ++-- Extract IQ reply that matches the supplied predicate from the event stream and send it (transformed) +iqReplyTo :: (Stanza -> Bool) -- ^ Predicate used to match required IQ reply+ -> (Stanza -> [CFilter Posn]) -- ^ transformer function+ -> XmppThreadT ()+iqReplyTo p t = do+ s <- waitFor (\x -> p x && isIQ x)+ writeChanS (transform t s)+ where+ transform t s@(IQ from' to' id' type' body') =+ IQ to' from' id' Result (map toContent $ t s)
+ src/Network/XMPP/JID.hs view
@@ -0,0 +1,51 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.JID+-- Copyright : (c) pierre, 2006+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : pierre <k.pierre.k@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- JID datatype and functions+--+-----------------------------------------------------------------------------+++-- jid components and functions+-- probably import Stringprep++module Network.XMPP.JID+ ( JID(..)+ ) where++import Text.Regex++-- | Jabber ID (JID) datatype+data JID = JID { name :: String+ -- ^ Account name+ , server :: String+ -- ^ Server adress+ , resource :: String+ -- ^ Resource name+ }++instance Read JID where+ -- Reads JID from string (name@server\/resource)+ readsPrec a str = case matchRegexAll regex str of + Just (_,_,after,(_:name:_:server:_:_:resource:_:[])) -> [((JID name server resource), after)]+ Just _ -> []+ Nothing -> []+ where+ regex = mkRegex $ + "((([^@])+)@)?" +++ "(([^/])+)" +++ "(/((.)+))?"++instance Show JID where+ -- Shows JID+ show a = (if (name a) /= "" then (name a)++"@" else "") +++ (server a)+++ (if (resource a) /= "" then "/"++(resource a) else "") +
+ src/Network/XMPP/MD5.hs view
@@ -0,0 +1,374 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.MD5+-- Copyright : (c) Dmitry Astapov 20006, Ian Lynagh 2001+-- License : BSD-style (see the file ReadMe.tex)+-- +-- Maintainer : dastapov@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Takes the MD5 module supplied by Ian Lynagh and strips it a bit to reduce +-- number of imports+-- See <http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/>+-- and <http://www.ietf.org/rfc/rfc1321.txt>.+--+-----------------------------------------------------------------------------+module Network.XMPP.MD5+ (md5, md5s, md5i,+ MD5(..), ABCD(..), + Zord64, Str(..), BoolList(..), WordList(..)) where++import Data.Char+import Data.Bits+import Data.Word++{-+Nasty kludge to create a type Zord64 which is really a Word64 but works+how we want in hugs ands nhc98 too...+Also need a rotate left function that actually works.++#ifdef __GLASGOW_HASKELL__+#define rotL rotateL+#include "Zord64_EASY.hs"+#else++> import Zord64_HARD+ +> rotL :: Word32 -> Rotation -> Word32+> rotL a s = shiftL a s .|. shiftL a (s-32)++#endif+-}++rotL x = rotateL x+type Zord64 = Word64++-- ===================== TYPES AND CLASS DEFINTIONS ========================+++type XYZ = (Word32, Word32, Word32)+type Rotation = Int+newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show)+newtype Str = Str String+newtype BoolList = BoolList [Bool]+newtype WordList = WordList ([Word32], Zord64)++-- Anything we want to work out the MD5 of must be an instance of class MD5++class MD5 a where+ get_next :: a -> ([Word32], Int, a) -- get the next blocks worth+ -- \ \ \------ the rest of the input+ -- \ \--------- the number of bits returned+ -- \--------------- the bits returned in 32bit words+ len_pad :: Zord64 -> a -> a -- append the padding and length+ finished :: a -> Bool -- Have we run out of input yet?+++-- Mainly exists because it's fairly easy to do MD5s on input where the+-- length is not a multiple of 8++instance MD5 BoolList where+ get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs)+ where (ys, zs) = splitAt 512 s+ len_pad l (BoolList bs)+ = BoolList (bs ++ [True]+ ++ replicate (fromIntegral $ (447 - l) .&. 511) False+ ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])]+ )+ where mangle [] = []+ mangle xs = reverse ys ++ mangle zs+ where (ys, zs) = splitAt 8 xs+ finished (BoolList s) = s == []+++-- The string instance is fairly straightforward++instance MD5 Str where+ get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs)+ where (ys, zs) = splitAt 64 s+ len_pad c64 (Str s) = Str (s ++ padding ++ l)+ where padding = '\128':replicate (fromIntegral zeros) '\000'+ zeros = shiftR ((440 - c64) .&. 511) 3+ l = length_to_chars 8 c64+ finished (Str s) = s == ""+++-- YA instance that is believed will be useful++instance MD5 WordList where+ get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken))+ where (xs, ys) = splitAt 16 ws+ taken = if l > 511 then 512 else l .&. 511+ len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen)+ where beginning = if length ws > 0 then start ++ lastone' else []+ start = init ws+ lastone = last ws+ offset = c64 .&. 31+ lastone' = [if offset > 0 then lastone + theone else lastone]+ theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7))+ (fromIntegral $ offset .&. (31 - 7))+ nextish = if offset == 0 then [128] else []+ c64' = c64 + (32 - offset)+ num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5)+ blanks = replicate num_blanks 0+ lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1)+ topsize = fromIntegral $ shiftR c64 32+ size = [lowsize, topsize]+ newlen = l .&. (complement 511)+ + if c64 .&. 511 >= 448 then 1024 else 512+ finished (WordList (_, z)) = z == 0+++instance Num ABCD where+ ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2)+ ABCD (a1, b1, c1, d1) * ABCD (a2, b2, c2, d2) = undefined+ abs (x) = x+ signum _ = undefined+ fromInteger _ = undefined++-- ===================== EXPORTED FUNCTIONS ========================+++-- The simplest function, gives you the MD5 of a string as 4-tuple of+-- 32bit words.++md5 :: (MD5 a) => a -> ABCD+md5 m = md5_main False 0 magic_numbers m+++-- Returns a hex number ala the md5sum program++md5s :: (MD5 a) => a -> String+md5s = abcd_to_string . md5+++-- Returns an integer equivalent to the above hex number++md5i :: (MD5 a) => a -> Integer+md5i = abcd_to_integer . md5+++-- ===================== THE CORE ALGORITHM ========================+++-- Decides what to do. The first argument indicates if padding has been+-- added. The second is the length mod 2^64 so far. Then we have the+-- starting state, the rest of the string and the final state.++md5_main :: (MD5 a) =>+ Bool -- Have we added padding yet?+ -> Zord64 -- The length so far mod 2^64+ -> ABCD -- The initial state+ -> a -- The non-processed portion of the message+ -> ABCD -- The resulting state+md5_main padded ilen abcd m+ = if finished m && padded+ then abcd+ else md5_main padded' (ilen + 512) (abcd + abcd') m''+ where (m16, l, m') = get_next m+ len' = ilen + fromIntegral l+ ((m16', _, m''), padded') = if not padded && l < 512+ then (get_next $ len_pad len' m, True)+ else ((m16, l, m'), padded)+ abcd' = md5_do_block abcd m16'+++-- md5_do_block processes a 512 bit block by calling md5_round 4 times to+-- apply each round with the correct constants and permutations of the+-- block++md5_do_block :: ABCD -- Initial state+ -> [Word32] -- The block to be processed - 16 32bit words+ -> ABCD -- Resulting state+md5_do_block abcd0 w = abcd4+ where (r1, r2, r3, r4) = rounds+ {-+ map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12]+ -- [(5 * x + 1) `mod` 16 | x <- [0..15]]+ map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2]+ -- [(3 * x + 5) `mod` 16 | x <- [0..15]]+ map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9]+ -- [(7 * x) `mod` 16 | x <- [0..15]]+ -}+ perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]+ = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12]+ perm5 _ = error "broke at perm5"+ perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]+ = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2]+ perm3 _ = error "broke at perm3"+ perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]+ = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9]+ perm7 _ = error "broke at perm7"+ abcd1 = md5_round md5_f abcd0 w r1+ abcd2 = md5_round md5_g abcd1 (perm5 w) r2+ abcd3 = md5_round md5_h abcd2 (perm3 w) r3+ abcd4 = md5_round md5_i abcd3 (perm7 w) r4+++-- md5_round does one of the rounds. It takes an auxiliary function and foldls+-- (md5_inner_function f) to repeatedly apply it to the initial state with the+-- correct constants++md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I+ -- for those of you with a copy of+ -- the prayer book^W^WRFC)+ -> ABCD -- Initial state+ -> [Word32] -- The 16 32bit words of input+ -> [(Rotation, Word32)] -- The list of 16 rotations and+ -- additive constants+ -> ABCD -- Resulting state+md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns'+ where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns+++-- Apply one of the functions md5_[fghi] and put the new ABCD together++md5_inner_function :: (XYZ -> Word32) -- Auxiliary function+ -> ABCD -- Initial state+ -> (Rotation, Word32) -- The rotation and additive+ -- constant (X[i] + T[j])+ -> ABCD -- Resulting state+md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c)+ where mid_a = a + f(b,c,d) + ki+ rot_a = rotL mid_a s+ a' = b + rot_a+++-- The 4 auxiliary functions++md5_f :: XYZ -> Word32+md5_f (x, y, z) = z `xor` (x .&. (y `xor` z))+{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -}++md5_g :: XYZ -> Word32+md5_g (x, y, z) = md5_f (z, x, y)+{- was: (x .&. z) .|. (y .&. (complement z)) -}++md5_h :: XYZ -> Word32+md5_h (x, y, z) = x `xor` y `xor` z++md5_i :: XYZ -> Word32+md5_i (x, y, z) = y `xor` (x .|. (complement z))+++-- The magic numbers from the RFC.++magic_numbers :: ABCD+magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476)+++-- The 4 lists of (rotation, additive constant) tuples, one for each round++rounds :: ([(Rotation, Word32)],+ [(Rotation, Word32)],+ [(Rotation, Word32)],+ [(Rotation, Word32)])+rounds = (r1, r2, r3, r4)+ where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db),+ (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a),+ (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8),+ (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be),+ (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e),+ (s14, 0x49b40821)]+ r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51),+ (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453),+ (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6),+ (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed),+ (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9),+ (s24, 0x8d2a4c8a)]+ r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122),+ (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9),+ (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6),+ (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05),+ (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8),+ (s34, 0xc4ac5665)]+ r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7),+ (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92),+ (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f),+ (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1),+ (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb),+ (s44, 0xeb86d391)]+ s11 = 7+ s12 = 12+ s13 = 17+ s14 = 22+ s21 = 5+ s22 = 9+ s23 = 14+ s24 = 20+ s31 = 4+ s32 = 11+ s33 = 16+ s34 = 23+ s41 = 6+ s42 = 10+ s43 = 15+ s44 = 21+++-- ===================== CONVERSION FUNCTIONS ========================+++-- Turn the 4 32 bit words into a string representing the hex number they+-- represent.++abcd_to_string :: ABCD -> String+abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d]+++-- Split the 32 bit word up, swap the chunks over and convert the numbers+-- to their hex equivalents.++display_32bits_as_hex :: Word32 -> String+display_32bits_as_hex w = swap_pairs cs+ where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7]+ getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n)+ swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs+ swap_pairs _ = []++-- Convert to an integer, performing endianness magic as we go++abcd_to_integer :: ABCD -> Integer+abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int)+ + rev_num b * 2^(64 :: Int)+ + rev_num c * 2^(32 :: Int)+ + rev_num d++rev_num :: Word32 -> Integer+rev_num i = toInteger j `mod` (2^(32 :: Int))+ -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~+ where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255))+ 0 [0,8,16,24]++-- Used to convert a 64 byte string to 16 32bit words++string_to_word32s :: String -> [Word32]+string_to_word32s "" = []+string_to_word32s ss = this:string_to_word32s ss'+ where (s, ss') = splitAt 4 ss+ this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s+++-- Used to convert a list of 512 bools to 16 32bit words++bools_to_word32s :: [Bool] -> [Word32]+bools_to_word32s [] = []+bools_to_word32s bs = this:bools_to_word32s rest+ where (bs1, bs1') = splitAt 8 bs+ (bs2, bs2') = splitAt 8 bs1'+ (bs3, bs3') = splitAt 8 bs2'+ (bs4, rest) = splitAt 8 bs3'+ this = boolss_to_word32 [bs1, bs2, bs3, bs4]+ bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0+ boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0+++-- Convert the size into a list of characters used by the len_pad function+-- for strings++length_to_chars :: Int -> Zord64 -> String+length_to_chars 0 _ = []+length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8)+ where this = chr $ fromIntegral $ n .&. 255+
+ src/Network/XMPP/Print.hs view
@@ -0,0 +1,96 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Print+-- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- An XMPP pretty-printing combinators+-- Ported from Text.HTML to HaXML combinatiors+--+-----------------------------------------------------------------------------+module Network.XMPP.Print+ ( -- Top-level rendering functions+ renderXmpp+ , putXmppLn+ , hPutXmpp+ -- XMPP primitives: tags+ , stream+ , streamEnd+ -- XMPP primitives: attributes+ , to+ , xmlns+ , xmllang+ , language+ , stream_version+ , mechanism+ , type_+ , id_+ , from+ ) where++import System.IO+import Text.XML.HaXml hiding (tag)+import qualified Text.XML.HaXml.Pretty as P+import Text.PrettyPrint.HughesPJ + +import Network.XMPP.UTF8+import Network.XMPP.Types+import Network.XMPP.Utils++-- | Convert the internal representation (built using HaXml combinators) into string, +-- and print it out+putXmppLn :: XmppMessage -> IO ()+putXmppLn = putStrLn . renderXmpp++-- | Convert the internal representation (built using HaXml combinators) into string, +-- and print it to the specified Handle, without trailing newline+hPutXmpp :: Handle -> XmppMessage -> IO ()+hPutXmpp h msg = + do let str = renderXmpp msg+ putStrLn $ "Sending: " ++ str+ hPutStr h $ toUTF8 str++-- | Render HaXML combinators into string, hacked for XMPP+renderXmpp :: XmppMessage -> String+renderXmpp theXml =+ case theXml of+ -- stupid hack for <stream:stream> and </stream:stream>+ xml@(CElem (Elem "stream:stream" _ _) _) ->+ (:) '<' $ takeWhile (/= '<') $ tail $ render $ P.content xml+ xml ->+ render $ P.content xml++---+--- XMPP construction combinators, based on the Text.Html+---++stream typ server =+ ptag "stream:stream"+ [ strAttr "xmlns:stream" "http://etherx.jabber.org/streams"+ , strAttr "xml:language" "en"+ , strAttr "version" "1.0"+ , strAttr "to" server+ , xmlns (show typ)+ ]+ [ itag "" [] ] ++streamEnd =+ ptag "/stream:stream" [] [ itag "" [] ]++---+--- Predefined XMPP attributes+---+to = strAttr "to"+xmlns = strAttr "xmlns"+language = strAttr "xml:language" +xmllang = strAttr "xml:lang" +stream_version = strAttr "version"+mechanism = strAttr "mechanism"+type_ = strAttr "type"+id_ = strAttr "id"+from = strAttr "from"+
+ src/Network/XMPP/Sasl.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Sasl+-- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- SASL Authentication for XMPP+--+-----------------------------------------------------------------------------++module Network.XMPP.Sasl+ ( saslAuth+ ) where++import Control.Monad (when,unless)+import Control.Monad.State (liftIO)+import Data.Char (chr,ord)+import Data.List+import Numeric (showHex)+import System.Random (newStdGen, randoms)+import Text.XML.HaXml.Combinators hiding (when)++import Network.XMPP.Base64 as B64+import Network.XMPP.MD5 +import Network.XMPP.Print+import Network.XMPP.Stream+import Network.XMPP.Types+import Network.XMPP.Utils++-- | Perform authentication over already-open channel+saslAuth :: [String] -- ^ List of auth mechanism available from server, currently only "DIGEST-MD5" is supported+ -> String -- ^ Server we are connectint to (hostname)+ -> String -- ^ Username to connect as+ -> String -- ^ Password+ -> XmppStateT ()+saslAuth mechanisms server username password+ | "DIGEST-MD5" `elem` mechanisms = saslDigest server username password+ | otherwise = error $ "Dont know how to do auth! Available mechanisms are: " ++ show mechanisms++saslDigest server username password = + do out $ toContent $+ ptag "auth"+ [ xmlns "urn:ietf:params:xml:ns:xmpp-sasl",+ mechanism "DIGEST-MD5" ] []+ ch_text <- withNextM getChallenge+ resp <- liftIO $ saslDigestResponse ch_text username server password+ out $ toContent $+ ptag "response"+ [ xmlns "urn:ietf:params:xml:ns:xmpp-sasl" ]+ [ literal $ resp ]+ m <- nextM+ when (not $ null $ tag "failure" $ m) (error "Auth failure")+ let chl_text = getChallenge m+ saslDigestRspAuth chl_text+ out $ toContent $+ ptag "response"+ [ xmlns "urn:ietf:params:xml:ns:xmpp-sasl" ] [] + m <- nextM+ unless (not $ null $ tag "success" m) (error "Auth failed")+ where+ getChallenge c = + case (tag "challenge" /> txt) c of+ [] -> error "Wheres challenge?"+ x -> getText_ x++saslDigestResponse chl username server password =+ let pairs = get_pairs $ B64.decode chl+ Just qop = lookup "qop" pairs+ Just nonce = lookup "nonce" pairs+ nc = "00000001"+ digest_uri ="xmpp/" ++ server+ realm = server + in do cnonce <- make_cnonce+ let a1 = semi_sep [ md5raw (Str (semi_sep [username,realm,password])), nonce, cnonce]+ let a2 = "AUTHENTICATE:" ++ digest_uri+ let t = semi_sep [ md5s (Str a1), nonce, nc, cnonce, qop, md5s (Str a2) ]+ let response = md5s (Str t)+ let resp = concat [ "username=", show username+ , ",realm=", show realm+ , ",nonce=", show nonce+ , ",cnonce=", show cnonce+ , ",nc=", nc+ , ",qop=", qop+ , ",digest-uri=", show digest_uri+ , ",response=", response+ ]+ return $ B64.encode resp+ where+ md5raw = map (chr . read . ("0x"++ ) . take 2) . takeWhile (not.null) . iterate (drop 2) . md5s+ hexa str = foldr showHex "" $ map ord str+ semi_sep = concat . intersperse ":"+ make_cnonce = do g <- newStdGen+ return $ hexa $ map (chr.(`mod` 256)) $ take 8 $ randoms g++-- | Split aaa=bbb,foo="bar" into [("aaa","bbb"),("foo","bar")]+get_pairs str = + let chunks = map (takeWhile (/=',')) $ takeWhile (not.null) $ iterate (drop 1 . dropWhile (/=',')) str+ (keys, values) = unzip $ map (break (=='=')) chunks+ in zip keys $ map trim values+ where+ -- | Trim leading '=' and surrounding quotes (if any) from value+ trim str = case dropWhile (=='=') str of+ x@('\"':rest) -> read x+ x -> x++saslDigestRspAuth chl =+ let pairs = get_pairs $ B64.decode chl+ in case lookup "rspauth" pairs of+ Just _ -> return ()+ Nothing -> error "NO rspauth in SASL digest rspauth!"
+ src/Network/XMPP/Stanza.hs view
@@ -0,0 +1,137 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Stanza+-- Copyright : (c) pierre, 2007+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : k.pierre.k@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- XMPP stanzas parsing +--+-----------------------------------------------------------------------------++module Network.XMPP.Stanza+ (+ parse+ , parseM+ , outStanza+ ) where ++import Text.XML.HaXml.Xtract.Parse (xtract)++import Control.Monad.State++import Network.XMPP.Types+import Network.XMPP.Print+import Network.XMPP.Stream+import Network.XMPP.Utils++import Data.Maybe++-- | Parses XML element producing Stanza+parse :: XmppMessage -> Stanza+parse m | xtractp id "/message" m = parseMessage m+ | xtractp id "/presence" m = parsePresence m+ | xtractp id "/iq" m = parseIQ m+ | otherwise = error "Can't read stanza"+ where+ xtractp f p m = not . null $ xtract f p m++-- | Gets next message from stream and parses it+parseM :: XmppStateT Stanza+parseM = do+ m <- nextM+ let pm = parse m in do+ debug $ "parseM: Got element: " ++ show pm+ return pm++parseMessage :: XmppMessage -> Stanza+parseMessage m = Message from to id' messageType subject body thread x+ where+ from = mread $ txt "/message/@from" m+ to = read $ getText_ $ xtract id "/message/@to" m+ id' = getText_ $ xtract id "/message/@id" m+ messageType = read $ getText_ $ xtract id "/message/@type" m+ subject = getText_ $ xtract id "/message/subject/-" m+ body = getText_ $ xtract id "/message/body/-" m+ thread = getText_ $ xtract id "/message/thread/-" m+ x = xtract id "/message/*" m++parsePresence :: XmppMessage -> Stanza+parsePresence m = Presence from to id' presenceType showType status priority x+ where+ from = mread $ txt "/presence/@from" m+ to = mread $ txt "/presence/@to" m+ id' = txt "/presence/@id" m+ presenceType = read $ txt "/presence/@type" m + showType = read $ txt "/presence/show/-" m+ status = txt "/presence/status/-" m+ priority = mread $ txt "/presence/priority/-" m+ x = xtract id "/presence/*" m++parseIQ :: XmppMessage -> Stanza+parseIQ m = IQ from to id' iqType body+ where+ from = mread $ txt "/iq/@from" m+ to = mread $ txt "/iq/@to" m+ id' = txt "/iq/@id" m+ iqType = read $ txt "/iq/@type" m+ body = [m]++-- | Extract text from `XmppMessage' with supplied pattern+txt :: String -- ^ xtract-like pattern to match+ -> XmppMessage -- ^ message being processed+ -> String -- ^ result of extraction+txt p m = getText_ $ xtract id p m++-- | Converts stanza to XML and outputs it +outStanza :: Stanza -> XmppStateT ()+outStanza s = case s of+ a@(Message _ _ _ _ _ _ _ _) -> outMessage a+ a@(Presence _ _ _ _ _ _ _ _) -> outPresence a+ a@(IQ _ _ _ _ _) -> outIQ a++outMessage :: Stanza -> XmppStateT ()+outMessage (Message from' to' id' mtype' subject' body' thread' x') =+ out $ toContent $ + ptag "message"+ ( (mattr "from" from') ++ + [ strAttr "to" (show to'),+ strAttr "id" id',+ strAttr "type" (show mtype'),+ xmllang "en" ] )+ ([ ptag "body" [] [literal body'] ] +++ (if subject' /= "" then [ ptag "subject" [] [literal subject'] ] else []) ++ + (if thread' /= "" then [ ptag "thread" [] [literal thread'] ] else []) +++ (map toFilter x'))+outMessage _ = error "Stanza isn't message"++outPresence :: Stanza -> XmppStateT ()+outPresence (Presence from' to' id' ptype' stype' status' priority' x') =+ out $ toContent $+ ptag "presence"+ ((mattr "from" from') +++ (mattr "to" to') +++ (if id' /= "" then [strAttr "id" id'] else []) +++ (if ptype' /= Default then [strAttr "type" (show ptype')] else []) +++ [xmllang "en" ]) + ((if stype' /= Available then [ ptag "show" [] [literal $ show stype'] ] else []) +++ (if status' /= "" then [ ptag "status" [] [ literal status' ] ] else []) +++ (if isJust priority' then [ ptag "priority" [] [ literal $ show (fromJust priority') ] ] else []) +++ (map toFilter x'))+outPresence _ = error "Stanza isn't presence"++outIQ :: Stanza -> XmppStateT ()+outIQ (IQ from' to' id' itype' body') =+ out $ toContent $+ ptag "iq"+ ((mattr "from" from') +++ (mattr "to" to') ++ + [ strAttr "id" id',+ sattr "type" (show itype'),+ xmllang "en" ])+ (map toFilter body') +outIQ _ = error "Stanza isn't IQ"+
+ src/Network/XMPP/Stream.hs view
@@ -0,0 +1,153 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Stream+-- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- An XMPP stream: means to create and use one+--+-----------------------------------------------------------------------------+module Network.XMPP.Stream+ ( + out+ , startM+ , nextM + , withNextM+ , selectM+ , xtractM+ , textractM+ , withSelectM+ , withNewStream+ , withStream+ , resetStreamHandle+ , getText+ , getText_+ , loopWithPlugins+ , Plugin(..)+ , getNextId+ , lookupAttr+ , newStream+ ) where++import Control.Monad.State+import Foreign hiding (new)+import System.IO+import Text.ParserCombinators.Poly.State (onFail)+import Text.XML.HaXml.Lex (xmlLex)+import Text.XML.HaXml.Parse+import Text.XML.HaXml.Posn (noPos)+import Text.XML.HaXml.Types+import qualified Text.XML.HaXml.Pretty as P (content)+import Text.XML.HaXml.Xtract.Parse (xtract)++import Network.XMPP.Print+import Network.XMPP.Utils+import Network.XMPP.Types+import Network.XMPP.UTF8++-- For a definition of 'Stream' see Network.XMPP.Types.++-- In the beginning, all Stream buffers are empty, and by default it is bound to stdin.+-- Functions like 'openStreamTo' or 'openStreamViaProxyTo' could override this.+newStream :: Stream +newStream = Stream { handle=stdin, idx=0, lexemes=[] }++-- Main 'workhorses' for Stream are 'out', 'nextM', 'peekM' and 'selectM':+-- | Sends message into Stream+out :: XmppMessage -> XmppStateT ()+out xmpp = do h <- gets handle+ liftIO $ hPutXmpp h xmpp++-- | Selects next messages from stream+nextM :: XmppStateT XmppMessage+nextM = + do ls <- gets lexemes+ let (elem, rest) = xmlParseWith element ls+ case elem of + (Left err) -> error $ "Failed to parse next element: " ++ show err+ (Right e) -> do let msg = CElem e noPos+ debug $ "nextM: Got element: " ++ show (P.content msg)+ modify (\stream -> stream { lexemes = rest } )+ return msg++-- | Selects next message matching predicate+selectM :: (XmppMessage -> Bool) -> XmppStateT XmppMessage+selectM p =+ do m <- nextM+ if p m then return m+ else error "Failed to select message"++-- | Pass in xtract query, return query result from the first message where it returns non-empty results+xtractM :: String -> XmppStateT [XmppMessage]+xtractM q = + do m <- selectM (not . null . (xtract id q))+ return $ xtract id q m++textractM :: String -> XmppStateT String+textractM q = do res <- xtractM q+ return $ case res of+ [] -> ""+ x -> getText_ x++-- All accessor functions have a convenience wrappers:+withM acc f = do m <- acc; return (f m)+withNextM = withM nextM+withSelectM p = withM (selectM p)++-- | startM is a special accessor case, since it has to retrieve only opening tag of the '<stream>' message,+-- which encloses the whole XMPP stream. That's why it does it's own parsing, and does not rely on 'nextM'+startM :: XmppStateT [Attribute]+startM =+ do ls <- gets lexemes+ let (starter, rest) = xmlParseWith streamStart ls+ case starter of+ Left e -> error e+ Right (ElemTag "stream:stream" attrs) -> do modify (\stream -> stream { lexemes=rest })+ return attrs+ Right x -> error $ "Unexpected element at the beginning of XMPP stream!"+ where+ streamStart = do ( processinginstruction >> return () ) `onFail` return ()+ elemOpenTag++-- | Convenience wrappers which allow for nicer code like:+-- withNewStream $ do ...+withNewStream :: XmppStateT a -> IO (a, Stream)+withNewStream f = + do let stream = newStream+ f `runStateT` stream+withStream :: Stream -> XmppStateT a -> IO (a, Stream)+withStream s f = f `runStateT` s++-- | Replaces contents of the Stream with the contents+-- coming from given handle.+resetStreamHandle h =+ do c <- liftIO $ hGetContents h+ modify (\stream -> stream { handle=h , lexemes = xmlLex "stream" (fromUTF8 c) })++-------------------------------+-- Basic plugin support+data Plugin = Plugin { trigger::String, body::(XmppMessage -> XmppStateT ()) }++loopWithPlugins :: [Plugin] -> XmppStateT ()+loopWithPlugins ps =+ let loop = do m <- nextM+ sequence_ [ (body p) m | p <- ps, not (null (xtract id (trigger p) m)) ]+ loop+ in loop++getNextId :: XmppStateT Int+getNextId =+ do i <- gets idx+ modify (\stream -> stream { idx = i+1 })+ return i++lookupAttr k lst =+ do x <- lookup k lst+ case x of+ AttValue [Left str] -> Just str+ AttValue _ -> Nothing+
+ src/Network/XMPP/Types.hs view
@@ -0,0 +1,224 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Types+-- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Network.XMPP.Types+ ( XmppMessage+ , XmppStateT+ , Stream(..)+ , StreamType(..)+ , Stanza(..)+ , MessageType(..), PresenceType(..), IQType(..), ShowType(..)+ , defaultStreamBlockSize+ , isMessage, isPresence, isIQ+ ) where++import System.IO (Handle)+import Control.Monad.State (StateT)++import Text.XML.HaXml.Types (Content)+import Text.XML.HaXml.Posn (Posn)+import Text.XML.HaXml.Lex (Token)+ +import Text.PrettyPrint.HughesPJ (render, hcat)+import qualified Text.XML.HaXml.Pretty as P (content)++import Network.XMPP.JID++-- | XMPP message in the parsed form+type XmppMessage = Content Posn ++-- | XMPP stream, used as a state in XmppStateT state transformer+data Stream = Stream { handle::Handle + -- ^ IO handle to the underlying file or socket+ , idx :: !Int+ -- ^ id of the next message (if needed)+ , lexemes :: [Token]+ -- ^ Stream of the lexemes coming from server+ }++-- | Since XMPP is network-oriented, block size is equal to maximal MTU+defaultStreamBlockSize :: Int+defaultStreamBlockSize = 1500++-- | XmppStateT is a state transformer over IO monad, using Stream as a "state holder".+-- For API, look into 'Network.XMPP.Stream'+type XmppStateT a = StateT Stream IO a++-- | XMPP Stream type, used in 'stream' pretty-printing combinator and the likes+data StreamType = Client -- ^ Client-to-server+ | ComponentAccept -- ^ FIXME+ | ComponentConnect -- ^ FIXME++instance Show StreamType where+ show Client = "jabber:client"+ show ComponentAccept = "jabber:component:accept"+ show ComponentConnect = "jabber:component:connect"++-- | Roster item type (7.1)+data RosterItem = RosterItem { jid :: JID+ -- ^ Entry's JID+ , subscribtion :: SubscribtionType+ -- ^ Subscribtion type + , name :: Maybe String+ -- ^ Entry's nickname+ , groups :: [String]+ -- ^ <group> elements+ }++data SubscribtionType = None | To | From | Both deriving Eq++instance Show SubscribtionType where+ show None = "none"+ show To = "to"+ show From = "from"+ show Both = "both"++instance Read SubscribtionType where+ readsPrec _ "none" = [(None, "")]+ readsPrec _ "to" = [(To, "")]+ readsPrec _ "from" = [(From, "")]+ readsPrec _ "both" = [(Both, "")]+ readsPrec _ "" = [(None, "")] + readsPrec _ _ = error "incorrect subscribtion type"++-- | Generic XMPP stream atom+data Stanza = Message { mFrom :: Maybe JID+ , mTo :: JID+ , mId :: String+ -- ^ Message 'from', 'to', 'id' attributes + , mType :: MessageType+ -- ^ Message type (2.1.1)+ , mSubject :: String+ -- ^ Subject element (2.1.2.1)+ , mBody :: String+ -- ^ Body element (2.1.2.2)+ , mThread :: String+ -- ^ Thread element (2.1.2.3)+ , mExt :: [Content Posn]+ -- ^ Additional contents, used for extensions+ }+ | Presence { pFrom :: Maybe JID+ , pTo :: Maybe JID+ , pId :: String+ -- ^ Presence 'from', 'to', 'id' attributes+ , pType :: PresenceType+ -- ^ Presence type (2.2.1)+ , pShowType :: ShowType+ -- ^ Show element (2.2.2.1)+ , pStatus :: String+ -- ^ Status element (2.2.2.2)+ , pPriority :: Maybe Integer+ -- ^ Presence priority (2.2.2.3)+ , pExt :: [Content Posn]+ -- ^ Additional contents, used for extensions+ }+ | IQ { iqFrom :: Maybe JID+ , iqTo :: Maybe JID+ , iqId :: String+ -- ^ IQ id (Core-9.2.3)+ , iqType :: IQType+ -- ^ IQ type (Core-9.2.3)+ , iqBody :: [Content Posn]+ -- ^ Child element (Core-9.2.3)+ } deriving Show+ +data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving Eq+ +data PresenceType = Default | Unavailable | Subscribe | Subscribed | Unsubscribe | Unsubscribed | Probe | PresenceError deriving Eq++data IQType = Get | Result | Set | IQError deriving Eq++data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq++instance Show (Content a) where+ show = render . P.content++instance Show MessageType where+ show Chat = "chat"+ show GroupChat = "groupchat"+ show Headline = "headline"+ show Normal = "normal"+ show MessageError = "error"++instance Show PresenceType where+ show Default = ""+ show Unavailable = "unavailable"+ show Subscribe = "subscribe"+ show Subscribed = "subscribed"+ show Unsubscribe = "unsubscribe"+ show Unsubscribed = "unsubscribed"+ show Probe = "probe"+ show PresenceError = "error"++instance Show IQType where+ show Get = "get"+ show Result = "result"+ show Set = "set"+ show IQError = "error"++instance Show ShowType where+ show Available = ""+ show Away = "away"+ show FreeChat = "chat"+ show DND = "dnd"+ show XAway = "xa"++instance Read MessageType where+ readsPrec _ "chat" = [(Chat, "")]+ readsPrec _ "groupchat" = [(GroupChat, "")]+ readsPrec _ "headline" = [(Headline, "")]+ readsPrec _ "normal" = [(Normal, "")]+ readsPrec _ "error" = [(MessageError, "")]+ readsPrec _ "" = [(Chat, "")] + readsPrec _ _ = error "incorrect message type"++instance Read PresenceType where+ readsPrec _ "" = [(Default, "")]+ readsPrec _ "available" = [(Default, "")]+ readsPrec _ "unavailable" = [(Unavailable, "")]+ readsPrec _ "subscribe" = [(Subscribe, "")]+ readsPrec _ "subscribed" = [(Subscribed, "")]+ readsPrec _ "unsubscribe" = [(Unsubscribe, "")]+ readsPrec _ "unsubscribed" = [(Unsubscribed, "")]+ readsPrec _ "probe" = [(Probe, "")]+ readsPrec _ "error" = [(PresenceError, "")]+ readsPrec _ _ = error "incorrect presence type"+ +instance Read IQType where+ readsPrec _ "get" = [(Get, "")]+ readsPrec _ "result" = [(Result, "")]+ readsPrec _ "set" = [(Set, "")]+ readsPrec _ "error" = [(IQError, "")]+ readsPrec _ "" = [(Get, "")]+ readsPrec _ _ = error "incorrect iq type"++instance Read ShowType where+ readsPrec _ "" = [(Available, "")]+ readsPrec _ "available" = [(Available, "")]+ readsPrec _ "away" = [(Away, "")]+ readsPrec _ "chat" = [(FreeChat, "")]+ readsPrec _ "dnd" = [(DND, "")]+ readsPrec _ "xa" = [(XAway, "")] + readsPrec _ "invisible" = [(Available, "")]+ readsPrec _ _ = error "incorrect <show> value"++-- | Utility functions +isMessage :: Stanza -> Bool+isMessage (Message _ _ _ _ _ _ _ _) = True+isMessage _ = False++isPresence :: Stanza -> Bool+isPresence (Presence _ _ _ _ _ _ _ _) = True+isPresence _ = False++isIQ :: Stanza -> Bool+isIQ (IQ _ _ _ _ _) = True+isIQ _ = False
+ src/Network/XMPP/UTF8.hs view
@@ -0,0 +1,53 @@+{-++Copyright (c) 2002, members of the Haskell Internationalisation Working+Group All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+* Neither the name of the Haskell Internationalisation Working Group nor+ the names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.++This module provides lazy stream encoding/decoding facilities for UTF-8,+the Unicode Transformation Format with 8-bit words.++2002-09-02 Sven Moritz Hallberg <pesco@gmx.de>++-}++{-++2007-04-30 Henning Thielemann:+Slight changes to make decode lazy.+The calls of 'reverse' in the original version have broken laziness+and thus had memory leaks.++-}++module Network.XMPP.UTF8+ ( fromUTF8, toUTF8+ ) where++import Codec.Binary.UTF8.String++fromUTF8 = decodeString+toUTF8 = encodeString
+ src/Network/XMPP/Utils.hs view
@@ -0,0 +1,90 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.Utils+-- Copyright : (c) pierre, 2007+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Various XMPP\/XML utilities +--+-----------------------------------------------------------------------------++module Network.XMPP.Utils+ (+ toContent+ , toFilter+ , noelem+ , sattr+ , strAttr+ , ptag+ , itag+ , getVals+ , isVal+ , getText+ , getText_+ , mread+ , mattr+ , mattr'+ , debug+ , literal -- from HaXML+ ) where++import Control.Monad.State++import Text.XML.HaXml hiding (tag)+import Text.XML.HaXml.Posn +import qualified Text.XML.HaXml.Pretty as P+import Text.PrettyPrint.HughesPJ (render, hcat)+import Text.XML.HaXml.Xtract.Parse (xtract)+ +import Network.XMPP.Types++-- | Conversion from\/to HaXML's Content and CFilter +toContent :: CFilter Posn -> Content Posn+toContent filter =+ head $ filter (CElem noelem noPos) ++toFilter :: Content Posn -> CFilter Posn+toFilter x = (\_ -> [x])++noelem = + Elem "root" [] []++strAttr s d = (s, literal d)+sattr = strAttr++ptag = mkElemAttr+itag s att = mkElemAttr s att []++-- | Returns strings extracted by xtract query +getVals :: String ->+ [Content Posn] ->+ [String]+getVals q ext = map (\x -> getText_ $ xtract id q x) ext++-- | Queries xml for specific value+-- @isVal str = any (== str) . getVals@+isVal :: String -> String -> [Content Posn] -> Bool+isVal str cont = any (== str) . (getVals cont)++-- +getText cs@(CString _ s _) = render . P.content $ cs+getText cs@(CRef _ _) = render . P.content $ cs+getText x = error $ "Attempt to extract text from content that is not a string: " ++ render ( P.content x )++getText_ = render . hcat . map P.content+ +mread "" = Nothing+mread a = Just $ read a++mattr s (Just a) = [ strAttr s (show a) ]+mattr s Nothing = []++mattr' s (Just a) = [ strAttr s a ]+mattr' s Nothing = []++debug :: String -> XmppStateT ()+debug = liftIO . putStrLn
+ src/Network/XMPP/XEP/Delayed.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.XEP.Delayed+-- Copyright : (c) pierre, 2007+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- XEP-0091, old delayed delivery+--+-----------------------------------------------------------------------------+module Network.XMPP.XEP.Delayed+ (+ isDelayed+ ) where++import Network.XMPP.Stanza+import Network.XMPP.Stream+import Network.XMPP.Types+import Network.XMPP.Print +import Network.XMPP.JID++import Text.XML.HaXml.Xtract.Parse (xtract)++-- | True, if stanza is delivered delayed+isDelayed :: Stanza -> Bool+isDelayed (Message _ _ _ _ _ _ _ ext) =+ any (== "jabber:x:delay") $ map (\x -> getText_ $ xtract id "/x/@xmlns" x) ext
+ src/Network/XMPP/XEP/MUC.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.XEP.MUC+-- Copyright : (c) pierre, 2007+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- XEP-0045, join\/kick\/ban\/leave functionality+--+-----------------------------------------------------------------------------+module Network.XMPP.XEP.MUC+ (+ mucJoin+ , mucLeave+ , mucJoinStanza+ , mucLeaveStanza+ ) where++import Network.XMPP.Stanza+import Network.XMPP.Stream+import Network.XMPP.Types+import Network.XMPP.Print +import Network.XMPP.JID+import Network.XMPP.Utils++-- | Joins MUC room named by JID (conference\@server\/nick)+mucJoin :: JID -> XmppStateT ()+mucJoin jid = do+ outStanza $ mucJoinStanza jid++-- | Leaves MUC room named by JID (conference\@server\/nick)+mucLeave :: JID -> XmppStateT ()+mucLeave jid = do+ outStanza $ mucLeaveStanza jid++-- | Stanza sent by 'mucJoin'+mucJoinStanza :: JID -> Stanza+mucJoinStanza jid =+ Presence Nothing (Just jid) "123" Default Available "" Nothing + [ toContent $+ itag "x" [ xmlns "http://jabber.org/protocol/muc" ]+ ]++-- | Stanza sent by 'mucLeave'+mucLeaveStanza :: JID -> Stanza+mucLeaveStanza jid =+ Presence Nothing (Just jid) "" Unavailable Available "" Nothing []
+ src/Network/XMPP/XEP/Version.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.XMPP.XEP.Version+-- Copyright : (c) pierre, 2007+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- XEP-0092, version request+--+-----------------------------------------------------------------------------+module Network.XMPP.XEP.Version+ ( isVersionReq+ , versionAnswer + ) where++import Network.XMPP.Stanza+import Network.XMPP.Stream+import Network.XMPP.Types+import Network.XMPP.Print +import Network.XMPP.JID+import Network.XMPP.Utils ++import Text.XML.HaXml+import Text.XML.HaXml.Posn + +-- | True, if stanza is a version request+isVersionReq :: Stanza -> Bool +isVersionReq (IQ { iqBody = ext }) =+ isVal "jabber:iq:version" "/iq/query/@xmlns" ext+isVersionReq _ = False++-- | Replies to version request+versionAnswer :: String -> String -> String -> (Stanza -> [CFilter i])+versionAnswer name version os s@(IQ { }) =+ [ ptag "query"+ [ xmlns "jabber:iq:version" ]+ [ ptag "name" [] [literal name],+ ptag "version" [] [literal version],+ ptag "os" [] [literal os]+ ]+ ]