build-type: Simple cabal-version: >= 1.8 name: xmpipe version: 0.0.0.4 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo homepage: https://github.com/YoshikuniJujo/xmpipe/wiki license: BSD3 license-file: LICENSE category: Network synopsis: XMPP implementation using simple-PIPE description: This package includes XMPP libraries. Now this contains only core (RFC 6120). This package needs more improvement yet. It has following features. . C2S . * TLS: use package (sample programs are coming soon) . * SASL: PLAIN, DIGEST-MD5, SCRAM-SHA-1, EXTERNAL (XEP-0178) . S2S . * TLS: use package (sample programs are comming soon) . * SASL: EXTERNAL (XEP-0178) . It does not have following features yet. . S2S . * DIALBACK (XEP-0220) . 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 . * OverloadedStrings . * PackageImports . replace . * &#123; to '{' . * &#125; to '}' . > 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 { tagFrom = Just me }) [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") { > tagId = Just . BSC.pack . ("msg_" ++) $ show n, > tagTo = Just you } > [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 . * OverloadedStrings . * PackageImports . replace . * &#123; to '{' . * &#125; to '}' . > 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 { tagTo = Just to }) b -> > yield (to, Message tgs { tagFrom = Just f } b) >> select f > _ -> select f > > initXSt :: XSt > initXSt = XSt { > user = Jid "" "localhost" Nothing, rands = repeat "00DEADBEEF00", > sSt = [ ("realm", "localhost"), ("qop", "auth"), ("charset", "utf-8"), > ("algorithm", "md5-sess") ] } > > 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 { user :: Jid, rands :: [BS.ByteString], sSt :: Pairs BS.ByteString } > > instance XmppState XSt where > getXmppState xs = (user xs, rands xs) > putXmppState (usr, rl) xs = xs { user = usr, rands = rl } > > instance SaslState XSt where > getSaslState XSt { user = Jid n _ _, rands = nnc : _, sSt = ss } = > ("username", n) : ("nonce", nnc) : ("snonce", nnc) : ss > getSaslState _ = error "XSt.getSaslState: null random list" > putSaslState ss xs@XSt { user = Jid _ d r, rands = _ : rs } = > xs { user = Jid n d r, rands = rs, sSt = ss } > where Just n = lookup "username" ss > putSaslState _ _ = error "XSt.getSaslState: null random list" extra-source-files: examples/simpleClient.hs, examples/simpleServer.hs library hs-source-dirs: core exposed-modules: Network.XMPiPe.Core.C2S.Client, Network.XMPiPe.Core.C2S.Server, Network.XMPiPe.Core.S2S.Client, Network.XMPiPe.Core.S2S.Server other-modules: Xmpp, XmppType, Tools, SaslClient, SaslServer build-depends: base == 4.*, bytestring == 0.10.*, xml-pipe == 0.0.0.*, simple-pipe == 0.0.0.*, uuid == 1.3.*, base64-bytestring == 1.0.*, handle-like == 0.1.*, sasl == 0.0.0.*, monads-tf == 0.1.* ghc-options: -Wall extensions: PatternGuards, DoAndIfThenElse