diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -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
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main = defaultMain
diff --git a/examples/Test.hs b/examples/Test.hs
new file mode 100644
--- /dev/null
+++ b/examples/Test.hs
@@ -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):
+
+
+
+OUT(1,adept@jabber.kiev.ua/work):
+
+
+ Tkabber
+ 0.9.8-alpha-20060521 (Tcl/Tk 8.4.12)
+ Debian GNU/Linux testing/unstable 2.6.16-1-686
+
+
+-}
diff --git a/haskell-xmpp.cabal b/haskell-xmpp.cabal
new file mode 100644
--- /dev/null
+++ b/haskell-xmpp.cabal
@@ -0,0 +1,64 @@
+Name: haskell-xmpp
+Version: 1.0
+License: BSD3
+License-File: LICENSE
+Author: Dmitry Astapov , pierre
+Maintainer: Dmitry Astapov
+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
diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP.hs
@@ -0,0 +1,41 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Network.XMPP
+-- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Dmitry Astapov
+-- 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"
diff --git a/src/Network/XMPP/Base64.hs b/src/Network/XMPP/Base64.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Base64.hs
@@ -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
+-- and .
+--
+-----------------------------------------------------------------------------
+
+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
diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Concurrent.hs
@@ -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 ""
+ threadDelay 30000000
+ connPersist h
+
diff --git a/src/Network/XMPP/Core.hs b/src/Network/XMPP/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Core.hs
@@ -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
+-- 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)
diff --git a/src/Network/XMPP/Helpers.hs b/src/Network/XMPP/Helpers.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Helpers.hs
@@ -0,0 +1,55 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Network.XMPP.Helpers
+-- Copyright : (c) Dmitry Astapov, 2006
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Dmitry Astapov
+-- 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
diff --git a/src/Network/XMPP/IM/Presence.hs b/src/Network/XMPP/IM/Presence.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/IM/Presence.hs
@@ -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
diff --git a/src/Network/XMPP/IQ.hs b/src/Network/XMPP/IQ.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/IQ.hs
@@ -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)
diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/JID.hs
@@ -0,0 +1,51 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Network.XMPP.JID
+-- Copyright : (c) pierre, 2006
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : pierre
+-- 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 "")
+
diff --git a/src/Network/XMPP/MD5.hs b/src/Network/XMPP/MD5.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/MD5.hs
@@ -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
+-- and .
+--
+-----------------------------------------------------------------------------
+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
+
diff --git a/src/Network/XMPP/Print.hs b/src/Network/XMPP/Print.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Print.hs
@@ -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 , pierre
+-- 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 and
+ 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"
+
diff --git a/src/Network/XMPP/Sasl.hs b/src/Network/XMPP/Sasl.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Sasl.hs
@@ -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 , pierre
+-- 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!"
diff --git a/src/Network/XMPP/Stanza.hs b/src/Network/XMPP/Stanza.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Stanza.hs
@@ -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"
+
diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Stream.hs
@@ -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 , pierre
+-- 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 '' 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
+
diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Types.hs
@@ -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 , pierre
+-- 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]
+ -- ^ 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 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
diff --git a/src/Network/XMPP/UTF8.hs b/src/Network/XMPP/UTF8.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/UTF8.hs
@@ -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
+
+-}
+
+{-
+
+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
diff --git a/src/Network/XMPP/Utils.hs b/src/Network/XMPP/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/Utils.hs
@@ -0,0 +1,90 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Network.XMPP.Utils
+-- Copyright : (c) pierre, 2007
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : Dmitry Astapov , pierre
+-- 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
diff --git a/src/Network/XMPP/XEP/Delayed.hs b/src/Network/XMPP/XEP/Delayed.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/XEP/Delayed.hs
@@ -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 , pierre
+-- 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
diff --git a/src/Network/XMPP/XEP/MUC.hs b/src/Network/XMPP/XEP/MUC.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/XEP/MUC.hs
@@ -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 , pierre
+-- 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 []
diff --git a/src/Network/XMPP/XEP/Version.hs b/src/Network/XMPP/XEP/Version.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/XMPP/XEP/Version.hs
@@ -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 , pierre
+-- 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]
+ ]
+ ]