The xmpipe package

[Tags: bsd3, library]

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

Versions0.0.0.0, 0.0.0.1, 0.0.0.2, 0.0.0.3, 0.0.0.4
Dependenciesbase (==4.*), base64-bytestring (==1.0.*), bytestring (==0.10.*), handle-like (==0.1.*), monads-tf (==0.1.*), sasl (==0.0.0.*), simple-pipe (==0.0.0.*), uuid (==1.3.*), xml-pipe (==0.0.0.*)
LicenseBSD3
AuthorYoshikuni Jujo <PAF01143@nifty.ne.jp>
MaintainerYoshikuni Jujo <PAF01143@nifty.ne.jp>
StabilityExperimental
CategoryNetwork
Home pagehttps://github.com/YoshikuniJujo/xmpipe/wiki
UploadedSun Oct 5 22:34:43 UTC 2014 by YoshikuniJujo
DistributionsNixOS:0.0.0.4
Downloads433 total (29 in last 30 days)
StatusDocs uploaded by user
Build status unknown [no reports yet]

Modules

[Index]

Downloads

Maintainers' corner

For package maintainers and hackage trustees