xmpipe: XMPP implementation using simple-PIPE

This is a package candidate release! Here you can preview how this package release will appear once published to the main package index (which can be accomplished via the 'maintain' link below). Please note that once a package has been published to the main package index it cannot be undone! Please consult the package uploading documentation for more information.

[maintain] [Publish]

This package includes XMPP libraries. Now this contains only core (RFC 6120). This package needs more improvement yet. It has following features.

C2S

S2S

It does not have following features yet.

S2S

Example programs

Client

examples/simpleClient.hs

% runhaskell simpleClient.hs yoshikuni@localhost/im password yoshio@localhost
Hello, my name is Yoshikuni!
yoshio@localhost: Hi, I'm Yoshio.
yoshio@localhost: I am busy.
Good-bye!
/quit

extensions

replace

import Prelude hiding (filter)

import Control.Applicative
import "monads-tf" Control.Monad.State
import "monads-tf" Control.Monad.Writer
import Control.Concurrent hiding (yield)
import Data.Maybe
import Data.Pipe
import Data.Pipe.Flow
import Data.Pipe.ByteString
import System.IO
import System.Environment
import Text.XML.Pipe
import Network
import Network.Sasl
import Network.XMPiPe.Core.C2S.Client

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

mechanisms :: [BS.ByteString]
mechanisms = ["SCRAM-SHA-1", "DIGEST-MD5", "PLAIN"]

data St = St [(BS.ByteString, BS.ByteString)]
instance SaslState St where getSaslState (St ss) = ss; putSaslState ss _ = St ss

main :: IO ()
main = do
	(me_ : pw : you_ : _) <- map BSC.pack <$> getArgs
	let	me@(Jid un d (Just rsc)) = toJid me_; you = toJid you_
		ss = St [
			("username", un), ("authcid", un), ("password", pw),
			("cnonce", "00DEADBEEF00") ]
	h <- connectTo (BSC.unpack d) $ PortNumber 5222
	void . (`evalStateT` ss) . runPipe $
		fromHandle h =$= sasl d mechanisms =$= toHandle h
	(Just ns, _fts) <- runWriterT . runPipe $
		fromHandle h =$= bind d rsc =@= toHandle h
	void . forkIO . void . runPipe $ fromHandle h =$= input ns
		=$= convert fromMessage =$= filter isJust =$= convert fromJust
		=$= toHandleLn stdout
	void . (`runStateT` 0) . runPipe $ do
		yield (presence me) =$= output =$= toHandle h
		fromHandleLn stdin =$= before (== "/quit")
			=$= mkMessage you =$= output =$= toHandle h
		yield End =$= output =$= toHandle h

presence :: Jid -> Mpi
presence me = Presence
	(tagsNull &#123; tagFrom = Just me &#125;) [XmlNode (nullQ "presence") [] [] []]

mkMessage :: Jid -> Pipe BS.ByteString Mpi (StateT Int IO) ()
mkMessage you = (await >>=) . maybe (return ()) $ \m -> do
	n <- get; modify succ
	yield $ toM n m
	mkMessage you
	where toM n msg = Message (tagsType "chat") &#123;
			tagId = Just . BSC.pack . ("msg_" ++) $ show n,
			tagTo = Just you &#125;
		[XmlNode (nullQ "body") [] [] [XmlCharData msg]]

fromMessage :: Mpi -> Maybe BS.ByteString
fromMessage (Message ts [XmlNode _ [] [] [XmlCharData m]])
	| Just (Jid n d _) <- tagFrom ts = Just $ BS.concat [n, "@", d, ": ", m]
fromMessage _ = Nothing

Server

examples/simpleServer.hs

This simple server can process only chat between same domain (localhost) users. Because this code use only C2S modules. You can implement S2S connection by S2S modules. But now this package contain only EXTERNAL authentification. This package is not contain DIALBACK yet. S2S examples which use EXTERNAL are comming soon.

extensions

replace

import Control.Applicative
import Control.Arrow
import Control.Monad
import "monads-tf" Control.Monad.State
import "monads-tf" Control.Monad.Error
import Control.Concurrent hiding (yield)
import Control.Concurrent.STM
import Data.Pipe
import Data.Pipe.ByteString
import Data.Pipe.TChan
import Network
import Network.Sasl
import Network.XMPiPe.Core.C2S.Server

import qualified Data.ByteString as BS
import qualified Network.Sasl.DigestMd5.Server as DM5
import qualified Network.Sasl.ScramSha1.Server as SS1

main :: IO ()
main = do
	userlist <- atomically $ newTVar []
	soc <- listenOn $ PortNumber 5222
	forever $ accept soc >>= \(h, _, _) -> forkIO $ do
		c <- atomically newTChan
		(Just ns, st) <- (`runStateT` initXSt) . runPipe $ do
			fromHandle h =$= sasl "localhost" retrieves =$= toHandle h
			fromHandle h =$= bind "localhost" [] =@= toHandle h
		let u = user st; sl = selector userlist
		atomically $ modifyTVar userlist ((u, c) :)
		void . forkIO . runPipe_ $ fromTChan c =$= output =$= toHandle h
		runPipe_ $ fromHandle h =$= input ns =$= select u =$= toTChansM sl

selector :: TVar [(Jid, TChan Mpi)] -> IO [(Jid -> Bool, TChan Mpi)]
selector ul = map (first eq) <$> atomically (readTVar ul)
	where
	eq (Jid u d _) (Jid v e Nothing) = u == v && d == e
	eq j k = j == k

select :: Monad m => Jid -> Pipe Mpi (Jid, Mpi) m ()
select f = (await >>=) . maybe (return ()) $ \mpi -> case mpi of
	End -> yield (f, End)
	Message tgs@(Tags &#123; tagTo = Just to &#125;) b ->
		yield (to, Message tgs &#123; tagFrom = Just f &#125; b) >> select f
	_ -> select f

initXSt :: XSt
initXSt = XSt &#123;
	user = Jid "" "localhost" Nothing, rands = repeat "00DEADBEEF00",
	sSt = [	("realm", "localhost"), ("qop", "auth"), ("charset", "utf-8"),
		("algorithm", "md5-sess") ] &#125;

retrieves :: (
	MonadState m, SaslState (StateType m),
	MonadError m, SaslError (ErrorType m) ) => [Retrieve m]
retrieves = [RTPlain retrievePln, RTDigestMd5 retrieveDM5, RTScramSha1 retrieveSS1]

retrievePln :: (
	MonadState m, SaslState (StateType m),
	MonadError m, SaslError (ErrorType m) ) =>
	BS.ByteString -> BS.ByteString -> BS.ByteString -> m ()
retrievePln "" "yoshikuni" "password" = return ()
retrievePln "" "yoshio" "password" = return ()
retrievePln _ _ _ = throwError $ fromSaslError NotAuthorized "auth failure"

retrieveDM5 :: (
	MonadState m, SaslState (StateType m),
	MonadError m, SaslError (ErrorType m) ) => BS.ByteString -> m BS.ByteString
retrieveDM5 "yoshikuni" = return $ DM5.mkStored "yoshikuni" "localhost" "password"
retrieveDM5 "yoshio" = return $ DM5.mkStored "yoshio" "localhost" "password"
retrieveDM5 _ = throwError $ fromSaslError NotAuthorized "auth failure"

retrieveSS1 :: (
	MonadState m, SaslState (StateType m),
	MonadError m, SaslError (ErrorType m) ) => BS.ByteString ->
	m (BS.ByteString, BS.ByteString, BS.ByteString, Int)
retrieveSS1 "yoshikuni" = return (slt, stk, svk, i)
	where slt = "pepper"; i = 4492; (stk, svk) = SS1.salt "password" slt i
retrieveSS1 "yoshio" = return (slt, stk, svk, i)
	where slt = "sugar"; i = 4492; (stk, svk) = SS1.salt "password" slt i
retrieveSS1 _ = throwError $ fromSaslError NotAuthorized "auth failure"

type Pairs a = [(a, a)]
data XSt = XSt &#123; user :: Jid, rands :: [BS.ByteString], sSt :: Pairs BS.ByteString &#125;

instance XmppState XSt where
	getXmppState xs = (user xs, rands xs)
	putXmppState (usr, rl) xs = xs &#123; user = usr, rands = rl &#125;

instance SaslState XSt where
	getSaslState XSt &#123; user = Jid n _ _, rands = nnc : _, sSt = ss &#125; =
		("username", n) : ("nonce", nnc) : ("snonce", nnc) : ss
	getSaslState _ = error "XSt.getSaslState: null random list"
	putSaslState ss xs@XSt &#123; user = Jid _ d r, rands = _ : rs &#125; =
		xs &#123; user = Jid n d r, rands = rs, sSt = ss &#125;
		where Just n = lookup "username" ss
	putSaslState _ _ = error "XSt.getSaslState: null random list"

Properties

Versions 0.0.0.0, 0.0.0.0, 0.0.0.1, 0.0.0.2, 0.0.0.3, 0.0.0.4
Change log None available
Dependencies base (>=4 && <5), base64-bytestring (>=1.0 && <1.1), bytestring (>=0.10 && <0.11), handle-like (>=0.1 && <0.2), monads-tf (>=0.1 && <0.2), sasl (>=0.0.0 && <0.0.1), simple-pipe (>=0.0.0 && <0.0.1), uuid (>=1.3 && <1.4), xml-pipe (>=0.0.0 && <0.0.1) [details]
License BSD-3-Clause
Author Yoshikuni Jujo <PAF01143@nifty.ne.jp>
Maintainer Yoshikuni Jujo <PAF01143@nifty.ne.jp>
Category Network
Home page https://github.com/YoshikuniJujo/xmpipe/wiki
Uploaded by YoshikuniJujo at 2014-08-27T06:46:25Z

Modules

Downloads

Maintainer's Corner

Package maintainers

For package maintainers and hackage trustees