xmpipe (empty) → 0.0.0.0
raw patch · 14 files changed
+1516/−0 lines, 14 filesdep +basedep +base64-bytestringdep +bytestringsetup-changed
Dependencies added: base, base64-bytestring, bytestring, handle-like, monads-tf, sasl, simple-pipe, uuid, xml-pipe
Files
- LICENSE +27/−0
- Setup.hs +1/−0
- core/Network/XMPiPe/Core/C2S/Client.hs +116/−0
- core/Network/XMPiPe/Core/C2S/Server.hs +112/−0
- core/Network/XMPiPe/Core/S2S/Client.hs +86/−0
- core/Network/XMPiPe/Core/S2S/Server.hs +128/−0
- core/SaslClient.hs +52/−0
- core/SaslServer.hs +96/−0
- core/Tools.hs +45/−0
- core/Xmpp.hs +79/−0
- core/XmppType.hs +340/−0
- examples/simpleClient.hs +67/−0
- examples/simpleServer.hs +98/−0
- xmpipe.cabal +269/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Yoshikuni Jujo+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 Yoshikuni Jujo 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 EVEN SHALL THE COPYRIGHT HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,1 @@+import Distribution.Simple; main = defaultMain
+ core/Network/XMPiPe/Core/C2S/Client.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies,+ FlexibleContexts, PackageImports #-}++module Network.XMPiPe.Core.C2S.Client (+ -- * Types and Values+ Mpi(..), Feature, Jid(..), toJid,+ Tags(..), tagsNull, tagsType,+ -- * Functions+ starttls, sasl, bind, input, output,+ ) where++import Control.Monad+import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Writer+import "monads-tf" Control.Monad.Error+import Data.Maybe+import Data.List+import Data.Pipe+import Text.XML.Pipe++import qualified Data.ByteString as BS++import Xmpp hiding (input, output, Feature)+import qualified Xmpp as X+import qualified SaslClient as SASL++input :: Monad m => [Xmlns] -> Pipe BS.ByteString Mpi m ()+input = inputMpi++output :: Monad m => Pipe Mpi BS.ByteString m ()+output = outputMpi++begin :: Monad m => BS.ByteString -> BS.ByteString -> Pipe Xmpp Xmpp m ()+begin h l = do+ yield XCDecl+ yield $ XCBegin [(To, h), (TagRaw $ nullQ "version", "1.0"), (Lang, l)]++starttls :: Monad m => BS.ByteString -> Pipe BS.ByteString BS.ByteString m ()+starttls hst = inputP3 =$= (begin hst "en" >> starttls_) =$= X.output++starttls_ :: Monad m => Pipe Xmpp Xmpp m ()+starttls_ = do+ Just (XCBegin _as) <- await+ Just (XCFeatures fs) <- await+ unless (any isSt fs) $ fail "starttls_: not support tls"+ yield XCStarttls+ Just XCProceed <- await+ return ()+ where isSt (FtStarttls _) = True; isSt _ = False++sasl :: (+ MonadState m, SASL.SaslState (StateType m),+ MonadError m, Error (ErrorType m)) =>+ BS.ByteString -> [BS.ByteString] -> Pipe BS.ByteString BS.ByteString m ()+sasl hst ms = inputP2 =$= sasl' hst ms =$= X.output++sasl' :: (+ MonadState m, SASL.SaslState (StateType m),+ MonadError m, Error (ErrorType m)) =>+ BS.ByteString -> [BS.ByteString] -> Pipe Xmpp Xmpp m ()+sasl' hst ms = begin hst "en" >> sasl_ ms++sasl_ :: (Monad m, MonadState m, SASL.SaslState (StateType m), MonadError m, Error (ErrorType m) ) =>+ [BS.ByteString] -> Pipe Xmpp Xmpp m ()+sasl_ sl = do+ Just (XCBegin _as) <- await+ Just (XCFeatures fs) <- await+ let Just (FtMechanisms ms) = find isFtMechanisms fs+ Just n = listToMaybe $ sl `intersect` ms+ SASL.sasl n+ where+ isFtMechanisms (FtMechanisms _) = True+ isFtMechanisms _ = False++bind :: (Monad m,+ MonadWriter m, [Feature] ~ WriterType m,+ MonadError m, Error (ErrorType m) ) =>+ BS.ByteString -> BS.ByteString -> Pipe BS.ByteString BS.ByteString m [Xmlns]+bind hst r = inputP3 =@= (begin hst "en" >> bind_ r) =$= X.output++bind_ :: (+ MonadWriter m, [Feature] ~ (WriterType m),+ MonadError m, Error (ErrorType m) ) =>+ BS.ByteString -> Pipe Xmpp Xmpp m ()+bind_ r = await >>= \mr -> case mr of+ Just (XCFeatures fs) -> do+ let (b, fs') = sepBind fs+ mapM_ yield . catMaybes $+ map (responseToFeature r) $ filter notFtSession b+ tell $ map getFeature fs'+ bind_ r+ Just _ -> bind_ r+ _ -> return ()++type Feature = XmlNode++getFeature :: X.Feature -> Feature+getFeature (FtRaw ft) = ft+getFeature _ = error "Network.XMPiPe.Core.C2S.Client.getFeature: bad"++sepBind :: [X.Feature] -> ([X.Feature], [X.Feature])+sepBind = partition notFtRaw++notFtSession :: X.Feature -> Bool+notFtSession (FtSession _) = False+notFtSession _ = True++notFtRaw :: X.Feature -> Bool+notFtRaw (FtRaw _) = False+notFtRaw _ = True++responseToFeature :: BS.ByteString -> X.Feature -> Maybe Xmpp+responseToFeature r (FtBind _) = Just+ . SRIqBind [(Type, "set"), (Id, "_xmpp_bind1")] . IqBind Nothing+ $ Resource r+responseToFeature _ _ = Nothing
+ core/Network/XMPiPe/Core/C2S/Server.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts,+ PackageImports #-}++module Network.XMPiPe.Core.C2S.Server (+ -- * Types and Values+ Mpi(..), Feature, Jid(..), Tags(..), tagsType,+ XmppState(..), Retrieve(..),+ -- * Functions+ starttls, sasl, bind, input, output,+ ) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Pipe+import Text.XML.Pipe++import Xmpp hiding (input, output, Feature)+import qualified Xmpp as X+import SaslServer++import qualified Data.ByteString as BS++type Feature = XmlNode++input :: Monad m => [Xmlns] -> Pipe BS.ByteString Mpi m ()+input = inputMpi++output :: Monad m => Pipe Mpi BS.ByteString m ()+output = outputMpi++starttls :: (MonadState m, [BS.ByteString] ~ StateType m) =>+ BS.ByteString -> Pipe BS.ByteString BS.ByteString m ()+starttls hst = inputP3 =$= processTls hst =$= X.output++processTls :: (MonadState m, [BS.ByteString] ~ StateType m) =>+ BS.ByteString -> Pipe Xmpp Xmpp m ()+processTls hst = await >>= \mx -> case mx of+ Just (XCBegin _as) -> do+ u : us <- get+ put us+ yield XCDecl+ yield $ XCBegin [+ (Id, u), (From, hst),+ (TagRaw $ nullQ "version", "1.0"), (Lang, "en") ]+ yield $ XCFeatures [FtStarttls Required]+ processTls hst+ Just XCStarttls -> yield XCProceed+ Just _ -> error "processTls: bad"+ _ -> return ()++sasl :: (+ MonadState m, XmppState (StateType m),+ MonadError m, SaslError (ErrorType m)) =>+ BS.ByteString -> [Retrieve m] -> Pipe BS.ByteString BS.ByteString m ()+sasl hst rt = inputP2 =$= makeSasl hst rt =$= X.output++makeSasl :: (+ MonadState m, XmppState (StateType m),+ MonadError m, SaslError (ErrorType m)) =>+ BS.ByteString -> [Retrieve m] -> Pipe Xmpp Xmpp m ()+makeSasl hst rt = await >>= \p -> case p of+ Just (XCBegin _) -> do+ yield XCDecl+ lift nextUuid >>= \u -> yield $ XCBegin [+ (Id, u), (From, hst),+ (TagRaw $ nullQ "version", "1.0"), (Lang, "en") ]+ runSasl rt+ _ -> return ()++class SaslState xs => XmppState xs where+ getXmppState :: xs -> (Jid, [BS.ByteString])+ putXmppState :: (Jid, [BS.ByteString]) -> xs -> xs++nextUuid :: (MonadState m, XmppState (StateType m)) => m BS.ByteString+nextUuid = do+ xs <- get+ let (r, u : us) = getXmppState xs+ modify $ putXmppState (r, us)+ return u++setResource :: XmppState xs => BS.ByteString -> xs -> xs+setResource r xs | (Jid a d _, ul) <- getXmppState xs =+ putXmppState (Jid a d $ Just r, ul) xs++bind :: (+ MonadState m, XmppState (StateType m),+ MonadError m, SaslError (ErrorType m)) =>+ BS.ByteString -> [Feature] -> Pipe BS.ByteString BS.ByteString m [Xmlns]+bind hst fts = inputP3 =@= makeBind hst fts =$= X.output++makeBind :: (+ MonadState m, XmppState (StateType m),+ MonadError m, SaslError (ErrorType m)) =>+ BS.ByteString -> [Feature] -> Pipe Xmpp Xmpp m ()+makeBind hst fts = await >>= \p -> case p of+ Just (XCBegin _) -> do+ yield XCDecl+ lift nextUuid >>= \u -> yield $ XCBegin [+ (Id, u),+ (From, hst),+ (TagRaw $ nullQ "version", "1.0"),+ (Lang, "en") ]+ yield . XCFeatures . (FtBind Required :) $ map FtRaw fts+ makeBind hst fts+ Just (SRIqBind ts (IqBind (Just Required) (Resource n)))+ | Just "set" <- lookup Type ts, Just i <- lookup Id ts -> do+ lift . modify $ setResource n+ j <- lift $ fst `liftM` gets getXmppState+ yield . SRIqBind [(Type, "result"), (Id, i)]+ . IqBind Nothing $ BJid j+ makeBind hst fts+ _ -> return ()
+ core/Network/XMPiPe/Core/S2S/Client.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.XMPiPe.Core.S2S.Client (+ -- * Types and Values+ Mpi(..), Jid(..), Tags(..), tagsNull, tagsType,+ -- * Functions+ starttls, sasl, begin, input, output,+ ) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Pipe+import Text.XML.Pipe++import qualified Data.ByteString as BS++import SaslClient hiding (sasl)+import qualified SaslClient as S+import Xmpp hiding (input, output)++input :: Monad m => [Xmlns] -> Pipe BS.ByteString Mpi m ()+input = inputMpi++output :: Monad m => Pipe Mpi BS.ByteString m ()+output = outputMpi++starttls :: Monad m =>+ BS.ByteString -> BS.ByteString -> Pipe BS.ByteString BS.ByteString m ()+starttls fr to = inputP3 =$= processTls fr to =$= outputS++processTls :: Monad m => BS.ByteString -> BS.ByteString -> Pipe Xmpp Xmpp m ()+processTls fr to = do+ yield XCDecl+ yield $ XCBegin [(From, fr), (To, to), (TagRaw $ nullQ "version", "1.0")]+ procTls++procTls :: Monad m => Pipe Xmpp Xmpp m ()+procTls = await >>= \mx -> case mx of+ Just (XCBegin _as) -> procTls+ Just (XCFeatures [FtStarttls _]) -> do+ yield XCStarttls+ procTls+ Just XCProceed -> return ()+ Just _ -> return ()+ _ -> return ()++sasl :: (+ MonadState m, SaslState (StateType m),+ MonadError m, Error (ErrorType m) ) =>+ BS.ByteString -> BS.ByteString -> Pipe BS.ByteString BS.ByteString m ()+sasl fr to = inputP3 =$= processSasl fr to =$= outputS++processSasl :: (+ MonadState m, SaslState (StateType m),+ MonadError m, Error (ErrorType m) ) =>+ BS.ByteString -> BS.ByteString -> Pipe Xmpp Xmpp m ()+processSasl fr to = do+ yield XCDecl+ yield $ XCBegin [ (From, fr), (To, to), (TagRaw $ nullQ "version", "1.0")]+ procSasl++procSasl :: (+ MonadState m, SaslState (StateType m),+ MonadError m, Error (ErrorType m)+ ) => Pipe Xmpp Xmpp m ()+procSasl = await >>= \mx -> case mx of+ Just (XCBegin _as) -> procSasl+ Just (XCFeatures [FtMechanisms ["EXTERNAL"]]) -> do+ st <- lift $ gets getSaslState+ lift . modify . putSaslState $ ("username", "") : st+ S.sasl "EXTERNAL"+ lift . modify $ putSaslState st+ _ -> return ()++begin :: Monad m =>+ BS.ByteString -> BS.ByteString -> Pipe BS.ByteString BS.ByteString m [Xmlns]+begin fr to = inputFeature =@= process fr to =$= outputS++process :: Monad m => BS.ByteString -> BS.ByteString -> Pipe Xmpp Xmpp m ()+process fr to = do+ yield XCDecl+ yield $ XCBegin [(From, fr), (To, to), (TagRaw $ nullQ "version", "1.0")]+ Just (XCBegin _as) <- await+ Just (XCFeatures []) <- await+ _ <- await+ return ()
+ core/Network/XMPiPe/Core/S2S/Server.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}++module Network.XMPiPe.Core.S2S.Server (+ -- * Types and Values+ Mpi(..), XmppState(..), Tags(..), tagsNull, tagsType, SaslState, SaslError,+ -- * Functions+ starttls, sasl, begin, input, output,+ ) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Maybe+import Data.Pipe+import Text.XML.Pipe++import Xmpp hiding (input, output)+import SaslServer++import qualified Data.ByteString as BS++input :: Monad m => [Xmlns] -> Pipe BS.ByteString Mpi m ()+input = inputMpi++output :: Monad m => Pipe Mpi BS.ByteString m ()+output = outputMpi++starttls :: (MonadState m, XmppState ~ StateType m) =>+ Pipe BS.ByteString BS.ByteString m ()+starttls = inputP3 =$= processTls =$= outputS++processTls :: (MonadState m, XmppState ~ StateType m) => Pipe Xmpp Xmpp m ()+processTls = await >>= \mx -> case mx of+ Just (XCBegin _as) -> do+ yield XCDecl+ nextUuid >>= yield . begin_+ yield $ XCFeatures [FtStarttls Required]+ processTls+ Just XCStarttls -> yield XCProceed+ _ -> return ()++begin_ :: BS.ByteString -> Xmpp+begin_ u = XCBegin [+ (From, "otherhost"), (To, "localhost"),+ (TagRaw $ nullQ "version", "1.0"), (Id, u) ]++nextUuid :: (MonadState m, StateType m ~ XmppState) => Pipe a b m BS.ByteString+nextUuid = lift $ do+ u <- gets $ head . xsUuid+ modify dropUuid+ return u++data XmppState = XmppState {+ xsDomainName :: Maybe BS.ByteString,+ xsUuid :: [BS.ByteString] }+ deriving Show++instance SaslState XmppState where+ getSaslState _ = [("username", "")]+ putSaslState _ = id++dropUuid :: XmppState -> XmppState+dropUuid xs = xs { xsUuid = tail $ xsUuid xs }++sasl :: (+ MonadState m, StateType m ~ XmppState,+ MonadError m, SaslError (ErrorType m) ) =>+ (BS.ByteString -> Bool) -> Pipe BS.ByteString BS.ByteString m ()+sasl rt = inputP2 =$= processSasl rt' =$= outputS+ where+ rt' n = if rt n then return () else+ throwError $ fromSaslError NotAuthorized n++processSasl :: (+ MonadState m, StateType m ~ XmppState,+ MonadError m, SaslError (ErrorType m) ) =>+ (BS.ByteString -> m ()) -> Pipe Xmpp Xmpp m ()+processSasl rt = await >>= \mx -> case mx of+ Just (XCBegin as) -> do+ modify $ \st -> st { xsDomainName = lookup From as }+ yield XCDecl+ nextUuid >>= yield . begin_+ yield $ XCFeatures [FtMechanisms ["EXTERNAL"]]+ Just (XCAuth "EXTERNAL" i) <- await+ flip sasl_ i . fromJust . lookup "EXTERNAL" . mkSaslServers+ . (: []) . RTExternal+ . rt' . fromJust $ lookup From as+ _ -> return ()+ where+ rt' d "" = rt d+ rt' _ hn = throwError $ fromSaslError NotAuthorized hn++sasl_ :: (+ MonadState m, SaslState (StateType m),+ MonadError m, SaslError (ErrorType m) ) =>+ (Bool, Pipe BS.ByteString (Either Success BS.ByteString) m ())+ -> Maybe BS.ByteString -> Pipe Xmpp Xmpp m ()+sasl_ r i = let (b, s) = r in saslPipe b i s++saslPipe :: (MonadState m, SaslState (StateType m)) => Bool+ -> Maybe BS.ByteString+ -> Pipe BS.ByteString (Either Success BS.ByteString) m ()+ -> Pipe Xmpp Xmpp m ()+saslPipe True (Just i) s =+ (yield i >> convert (\(SRResponse r) -> r)) =$= s =$= outputScram+saslPipe True _ s =+ convert (\(SRResponse r) -> r) =$= s =$= (yield (SRChallenge "") >> outputScram)+saslPipe False Nothing s = convert (\(SRResponse r) -> r) =$= s =$= outputScram+saslPipe _ _ _ = error "saslPipe: no need of initial data"++outputScram :: (MonadState m, SaslState (StateType m)) =>+ Pipe (Either Success BS.ByteString) Xmpp m ()+outputScram = await >>= \mch -> case mch of+ Just (Right r) -> yield (SRChallenge r) >> outputScram+ Just (Left (Success r)) -> yield $ XCSaslSuccess r+ Nothing -> return ()++begin :: (MonadState m, StateType m ~ XmppState) =>+ Pipe BS.ByteString BS.ByteString m [Xmlns]+begin = inputBegin =@= process =$= outputS++process :: (MonadState m, StateType m ~ XmppState) => Pipe Xmpp Xmpp m ()+process = await >>= \mx -> case mx of+ Just (XCBegin _as) -> do+ yield XCDecl+ nextUuid >>= yield . begin_+ yield $ XCFeatures []+ process+ _ -> return ()
+ core/SaslClient.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, PackageImports #-}++module SaslClient (SaslState(..), sasl) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Maybe+import Data.List+import Data.Pipe++import qualified Data.ByteString as BS++import Network.Sasl+import qualified Network.Sasl.Plain.Client as Pln+import qualified Network.Sasl.External.Client as Ext+import qualified Network.Sasl.DigestMd5.Client as DM5+import qualified Network.Sasl.ScramSha1.Client as SS1+import XmppType++saslClients :: (+ MonadState m, SaslState (StateType m),+ MonadError m, Error (ErrorType m) ) => [(+ BS.ByteString,+ (Bool, Pipe (Either Success BS.ByteString) BS.ByteString m ()) )]+saslClients = [DM5.sasl, SS1.sasl, Pln.sasl, Ext.sasl]++sasl :: (Monad m,+ MonadState m, SaslState (StateType m),+ MonadError m, Error (ErrorType m)+ ) => BS.ByteString -> Pipe Xmpp Xmpp m ()+sasl n = saslPipe . fromJust $ find ((== n) . fst) saslClients++saslPipe :: (Monad m, MonadState m, SaslState (StateType m)) => (+ BS.ByteString,+ (Bool, Pipe (Either Success BS.ByteString) BS.ByteString m ())+ ) -> Pipe Xmpp Xmpp m ()+saslPipe m =+ inputScramSha1 =$= snd (snd m) =$= outputScramSha1 (fst (snd m)) (fst m)++inputScramSha1 :: Monad m => Pipe Xmpp (Either Success BS.ByteString) m ()+inputScramSha1 = await >>= \mc -> case mc of+ Just (SRChallenge c) -> yield (Right c) >> inputScramSha1+ Just (XCSaslSuccess d) -> yield . Left $ Network.Sasl.Success d+ _ -> error "inputScramSha1: bad"++outputScramSha1 :: Monad m =>+ Bool -> BS.ByteString -> Pipe BS.ByteString Xmpp m ()+outputScramSha1 ci mn = do+ if ci+ then await >>= maybe (return ()) (yield . XCAuth mn . Just)+ else yield $ XCAuth mn Nothing+ convert SRResponse
+ core/SaslServer.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}++module SaslServer (+ SaslState(..), SaslError(..),+-- saslServers,+ SaslErrorType(..), Success(..),+ mkSaslServers, Retrieve(..),++ runSasl,+ ) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Pipe+import Network.Sasl++import qualified Data.ByteString as BS+import qualified Network.Sasl.Plain.Server as Pln+import qualified Network.Sasl.External.Server as Ext+import qualified Network.Sasl.DigestMd5.Server as DM5+import qualified Network.Sasl.ScramSha1.Server as SS1++import XmppType++{-+sampleRetrieves :: (+ MonadState m, SaslState (StateType m),+ MonadError m, SaslError (ErrorType m)) => [Retrieve m]+sampleRetrieves = [+ RTPlain retrievePln, RTExternal retrieveEx,+ RTDigestMd5 retrieveDM5, RTScramSha1 retrieveSS1 ]+ -}++runSasl :: (+ MonadState m, SaslState (StateType m),+ MonadError m, SaslError (ErrorType m) ) =>+ [Retrieve m] -> Pipe Xmpp Xmpp m ()+runSasl rt = do+ yield $ XCFeatures [FtMechanisms $ map getMechanism rt]+ await >>= \a -> case a of+ Just (XCAuth m i) -> sasl_ rt m i+ _ -> throwError $ fromSaslError+ (SaslErrorType "EOF") "unexpected EOF"++sasl_ :: (+ MonadState m, SaslState (StateType m),+ MonadError m, SaslError (ErrorType m) ) =>+ [Retrieve m] -> BS.ByteString -> Maybe BS.ByteString -> Pipe Xmpp Xmpp m ()+sasl_ rt n i = case lookup n $ mkSaslServers rt of+ Just (b, s) -> saslPipe b i s+ _ -> throwError $ fromSaslError InvalidMechanism "no such mechanisms"++saslPipe :: (+ MonadState m, SaslState (StateType m),+ MonadError m, SaslError (ErrorType m) ) => Bool+ -> Maybe BS.ByteString+ -> Pipe BS.ByteString (Either Success BS.ByteString) m ()+ -> Pipe Xmpp Xmpp m ()+saslPipe True (Just i) s =+ (yield i >> convert (\(SRResponse r) -> r)) =$= s =$= saslOutput+saslPipe True _ s = convert (\(SRResponse r) -> r) =$= s+ =$= (yield (SRChallenge "") >> saslOutput)+saslPipe False Nothing s = convert (\(SRResponse r) -> r) =$= s =$= saslOutput+saslPipe _ _ _ = throwError $+ fromSaslError MalformedRequest "no need of initial data"++saslOutput :: (MonadState m, SaslState (StateType m)) =>+ Pipe (Either Success BS.ByteString) Xmpp m ()+saslOutput = await >>= \mch -> case mch of+ Just (Right r) -> yield (SRChallenge r) >> saslOutput+ Just (Left (Success r)) -> yield $ XCSaslSuccess r+ _ -> return ()++data Retrieve m+ = RTPlain (BS.ByteString -> BS.ByteString -> BS.ByteString -> m ())+ | RTExternal (BS.ByteString -> m ())+ | RTDigestMd5 (BS.ByteString -> m BS.ByteString)+ | RTScramSha1 (BS.ByteString ->+ m (BS.ByteString, BS.ByteString, BS.ByteString, Int))++getMechanism :: Retrieve m -> BS.ByteString+getMechanism (RTPlain _) = "PLAIN"+getMechanism (RTExternal _) = "EXTERNAL"+getMechanism (RTDigestMd5 _) = "DIGEST-MD5"+getMechanism (RTScramSha1 _) = "SCRAM-SHA-1"++mkSaslServers :: (+ MonadState m, SaslState (StateType m),+ MonadError m, SaslError (ErrorType m)) => [Retrieve m] -> [(+ BS.ByteString,+ (Bool, Pipe BS.ByteString (Either Success BS.ByteString) m ()) )]+mkSaslServers = map $ \rts -> case rts of+ RTPlain rt -> Pln.sasl rt+ RTExternal rt -> Ext.sasl rt+ RTDigestMd5 rt -> DM5.sasl rt+ RTScramSha1 rt -> SS1.sasl rt
+ core/Tools.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings, TupleSections, TypeFamilies, PackageImports #-}++module Tools (+ SHandle(..),+ fromHandleLike, toHandleLike,+ hlpDebug, voidM, nullQ, myFromJust,+ ) where++import "monads-tf" Control.Monad.State+import Data.Pipe+import Data.HandleLike+import Text.XML.Pipe++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++fromHandleLike :: HandleLike h => h -> Pipe () BS.ByteString (HandleMonad h) ()+fromHandleLike h = lift (hlGetContent h) >>= ((>> fromHandleLike h) . yield)++toHandleLike :: HandleLike h => h -> Pipe BS.ByteString () (HandleMonad h) ()+toHandleLike h = await >>= maybe (return ()) ((>> toHandleLike h) . lift . hlPut h)++hlpDebug :: (HandleLike h, Show a) => h -> Pipe a a (HandleMonad h) ()+hlpDebug h = await >>= maybe (return ())+ (\x -> lift (hlPrint h x) >> yield x >> hlpDebug h)++hlPrint :: (HandleLike h, Show a) => h -> a -> HandleMonad h ()+hlPrint h = hlDebug h "critical" . BSC.pack . (++ "\n") . show++data SHandle s h = SHandle h++instance HandleLike h => HandleLike (SHandle s h) where+ type HandleMonad (SHandle s h) = StateT s (HandleMonad h)+ type DebugLevel (SHandle s h) = DebugLevel h+ hlPut (SHandle h) = lift . hlPut h+ hlGet (SHandle h) = lift . hlGet h+ hlClose (SHandle h) = lift $ hlClose h+ hlDebug (SHandle h) = (lift .) . hlDebug h++voidM :: Monad m => m a -> m ()+voidM = (>> return ())++myFromJust :: String -> Maybe a -> a+myFromJust _ (Just x) = x+myFromJust msg _ = error msg
+ core/Xmpp.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}++module Xmpp (+ inputBegin, inputFeature, inputP2, inputP3, input, output, outputS, inputMpi, outputMpi,+ Mpi(..),++ Xmpp(..), fromCommon,+ Tags(..),+ Jid(..), toJid, fromJid,+ Side(..),+ Feature(..), Tag(..),+ Query(..), Bind(..), Requirement(..), toRequirement, fromRequirement,++ voidM, hlpDebug, SHandle(..),++ nullQ, tagsNull, tagsType,++ fromHandleLike, toHandleLike,+ ) where++import Debug.Trace++import Data.Maybe+import Data.Pipe+import Text.XML.Pipe++import qualified Data.ByteString as BS++import XmppType+import Tools (voidM, hlpDebug, SHandle(..), fromHandleLike, toHandleLike)++tagsNull :: Tags+tagsNull = Tags Nothing Nothing Nothing Nothing Nothing []++tagsType :: BS.ByteString -> Tags+tagsType tp = tagsNull { tagType = Just tp }++inputP2 :: Monad m => Pipe BS.ByteString Xmpp m ()+inputP2 = xmlEvent =$= convert fromJust =$= mapOut toCommon xmlReborn++isSaslSuccess :: XmlNode -> Bool+isSaslSuccess (XmlNode ((_, Just "jabber:client"), "iq")+ _ _ [XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-bind"), "bind") _ _ _]) = True+isSaslSuccess _ = False++isFeature :: XmlNode -> Bool+isFeature (XmlNode+ ((_, Just "http://etherx.jabber.org/streams"), "features") _ [] []) = True+isFeature n = trace ("isFeature: " ++ show n) False++inputBegin :: Monad m => Pipe BS.ByteString Xmpp m [Xmlns]+inputBegin = xmlEvent =$= convert fromJust =$= mapOut toCommon xmlBegin++inputFeature :: Monad m => Pipe BS.ByteString Xmpp m [Xmlns]+inputFeature = xmlEvent =$= convert fromJust =$= mapOut toCommon xmlFeature++inputP3 :: Monad m => Pipe BS.ByteString Xmpp m [Xmlns]+inputP3 = xmlEvent =$= convert fromJust =$= mapOut toCommon xmlPipe++xmlPipe :: Monad m => Pipe XmlEvent XmlNode m [Xmlns]+xmlPipe = xmlBegin >>= \ns -> xmlNodeUntil isSaslSuccess ns >> return ns++xmlFeature :: Monad m => Pipe XmlEvent XmlNode m [Xmlns]+xmlFeature = xmlBegin >>= \ns -> xmlNodeUntil isFeature ns >> return ns++input :: Monad m => [Xmlns] -> Pipe BS.ByteString Xmpp m ()+input ns = xmlEvent =$= convert fromJust =$= xmlNode ns =$= convert toCommon++inputMpi :: Monad m => [Xmlns] -> Pipe BS.ByteString Mpi m ()+inputMpi ns = xmlEvent =$= convert fromJust =$= xmlNode ns =$= convert toMpi++output :: Monad m => Pipe Xmpp BS.ByteString m ()+output = convert $ xmlString . (: []) . fromCommon Client++outputS :: Monad m => Pipe Xmpp BS.ByteString m ()+outputS = convert $ xmlString . (: []) . fromCommon Server++outputMpi :: Monad m => Pipe Mpi BS.ByteString m ()+outputMpi = convert $ xmlString . (: []) . fromMpi
+ core/XmppType.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE OverloadedStrings, TupleSections #-}++module XmppType (+ Xmpp(..), toCommon, fromCommon,+ Tags(..),+ Jid(..), toJid, fromJid,+ Side(..),+ Tag(..), toTag, fromTag,+ Feature(..),+ Query(..), Bind(..),+ Requirement(..), toRequirement, fromRequirement,++ Mpi(..), toMpi, fromMpi,+ ) where++import Control.Applicative+import Control.Arrow+import Data.Maybe+import Text.XML.Pipe++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Base64 as B64++data Xmpp+ = XCDecl+ | XCBegin [(Tag, BS.ByteString)]+ | XCEnd+ | XCFeatures [Feature]+ | XCStarttls+ | XCProceed++ | XCAuth BS.ByteString (Maybe BS.ByteString)+ | SRChallenge BS.ByteString+ | SRResponse BS.ByteString+ | XCSaslSuccess (Maybe BS.ByteString)++ | SRIqBind [(Tag, BS.ByteString)] Query++ | SRMessage Tags [XmlNode]+ | SRPresence Tags [XmlNode]+ | SRIq Tags [XmlNode]+-- | SRIq [(Tag, BS.ByteString)] [XmlNode]++ | XCRaw XmlNode+ deriving (Eq, Show)++data Mpi+ = Message Tags [XmlNode]+ | Presence Tags [XmlNode]+ | Iq Tags [XmlNode]+ | End+ | MpiRaw XmlNode+ deriving (Eq, Show)++data Tags = Tags {+ tagId :: Maybe BS.ByteString,+ tagType :: Maybe BS.ByteString,+ tagFrom :: Maybe Jid,+ tagTo :: Maybe Jid,+ tagLang :: Maybe BS.ByteString,+ tagOthers :: [(QName, BS.ByteString)] } deriving (Eq, Show)++toTags :: [(QName, BS.ByteString)] -> Tags+toTags as = Tags {+ tagId = i, tagType = tp, tagFrom = fr, tagTo = to, tagLang = ln,+ tagOthers = ot }+ where+ ts = map (first toTag) as+ i = lookup Id ts+ tp = lookup Type ts+ fr = toJid <$> lookup From ts+ to = toJid <$> lookup To ts+ ln = lookup Lang ts+ ot = map (first $ \(TagRaw a) -> a) $ filter (isTagRaw . fst) ts++fromTags :: Tags -> [(QName, BS.ByteString)]+fromTags Tags { tagId = i, tagType = tp, tagFrom = fr, tagTo = to, tagLang = ln,+ tagOthers = ot } = (++ ot) . map (first fromTag) $ catMaybes [+ (Id ,) <$> i, (Type ,) <$> tp, (From ,) . fromJid <$> fr,+ (To ,) . fromJid <$> to, (Lang ,) <$> ln ]++data Query = IqBind (Maybe Requirement) Bind deriving (Eq, Show)++data Bind+ = Resource BS.ByteString+ | BJid Jid+ | BindRaw XmlNode+ deriving (Eq, Show)++data Tag+ = Id | Type | From | To | Lang | TagRaw QName+ deriving (Eq, Show)++isTagRaw :: Tag -> Bool+isTagRaw (TagRaw _) = True+isTagRaw _ = False++toTag :: QName -> Tag+toTag ((_, Just "jabber:client"), "id") = Id+toTag ((_, Just "jabber:server"), "id") = Id+toTag ((_, Just "jabber:client"), "type") = Type+toTag ((_, Just "jabber:server"), "type") = Type+toTag ((_, Just "jabber:client"), "from") = From+toTag ((_, Just "jabber:server"), "from") = From+toTag ((_, Just "jabber:client"), "to") = To+toTag ((_, Just "jabber:server"), "to") = To+toTag (("xml", Nothing), "lang") = Lang+toTag n = TagRaw n++fromTag :: Tag -> QName+fromTag Id = nullQ "id"+fromTag Type = nullQ "type"+fromTag From = nullQ "from"+fromTag To = nullQ "to"+fromTag Lang = (("xml", Nothing), "lang")+fromTag (TagRaw n) = n++data Requirement = Optional | Required | NoRequirement [XmlNode]+ deriving (Eq, Ord, Show)++toRequirement :: [XmlNode] -> Requirement+toRequirement [XmlNode (_, "optional") _ [] []] = Optional+toRequirement [XmlNode (_, "required") _ [] []] = Required+toRequirement n = NoRequirement n++fromRequirement :: Requirement -> XmlNode+fromRequirement Optional = XmlNode (nullQ "optional") [] [] []+fromRequirement Required = XmlNode (nullQ "required") [] [] []+fromRequirement (NoRequirement _) = undefined++data Feature+ = FtMechanisms [BS.ByteString]+ | FtStarttls Requirement+ | FtBind Requirement+ | FtSession Requirement+ | FtRaw XmlNode+ deriving (Eq, Ord, Show)++toFeature :: XmlNode -> Feature+toFeature (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-tls"), "starttls")+ _ [] r) = FtStarttls $ toRequirement r+toFeature (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "mechanisms")+ _ [] ns) = FtMechanisms $ map toMechanism ns+toFeature (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-bind"), "bind") _ [] r) =+ FtBind $ toRequirement r+toFeature (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-session"), "session")+ _ [] r) = FtSession $ toRequirement r+toFeature n = FtRaw n++fromFeature :: Feature -> XmlNode+fromFeature (FtStarttls r) = XmlNode (nullQ "starttls")+ [("", "urn:ietf:params:xml:ns:xmpp-tls")] [] [fromRequirement r]+fromFeature (FtMechanisms ms) = XmlNode (nullQ "mechanisms")+ [("", "urn:ietf:params:xml:ns:xmpp-sasl")] [] $+ map fromMechanism ms+fromFeature (FtBind r) = XmlNode (nullQ "bind")+ [("", "urn:ietf:params:xml:ns:xmpp-bind")] [] [fromRequirement r]+fromFeature (FtSession r) = XmlNode (nullQ "session")+ [("", "urn:ietf:params:xml:ns:xmpp-session")] [] [fromRequirement r]+fromFeature (FtRaw n) = n++toMechanism :: XmlNode -> BS.ByteString+toMechanism (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "mechanism")+ _ [] [XmlCharData m]) = m+toMechanism _ = error "toMechanism: bad"++fromMechanism :: BS.ByteString -> XmlNode+fromMechanism m = XmlNode (nullQ "mechanism") [] [] [XmlCharData m]++data Jid = Jid BS.ByteString BS.ByteString (Maybe BS.ByteString) deriving (Eq, Show)++fromJid :: Jid -> BS.ByteString+fromJid (Jid a d r) = a `BS.append` "@" `BS.append` d `BS.append`+ maybe "" ("/" `BS.append`) r++toJid :: BS.ByteString -> Jid+toJid j = case rst of+ "" -> Jid "" a Nothing+ _ -> Jid a d (if BS.null r then Nothing else Just $ BS.tail r)+ where+ (a, rst) = BSC.span (/= '@') j+ (d, r) = BSC.span (/= '/') $ BS.tail rst++toCommon :: XmlNode -> Xmpp+toCommon (XmlDecl (1, 0)) = XCDecl+toCommon (XmlStart ((_, Just "http://etherx.jabber.org/streams"), "stream") _ as) =+ XCBegin $ map (first toTag) as+toCommon (XmlEnd ((_, Just "http://etherx.jabber.org/streams"), "stream")) = XCEnd+toCommon (XmlNode ((_, Just "http://etherx.jabber.org/streams"), "features")+ _ [] nds) = XCFeatures $ map toFeature nds+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-tls"), "starttls")+ _ [] []) = XCStarttls+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-tls"), "proceed")+ _ [] []) = XCProceed+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "auth")+ _ as [])+ | [(((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "mechanism"), m)] <- as =+ XCAuth m Nothing+-- toTag ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "mechanism") = Mechanism+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "auth")+ _ as [XmlCharData i])+ | [(((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "mechanism"), m)] <- as =+-- | [(Mechanism, m)] <- map (first toTag) as =+ XCAuth m . Just . (\(Right r) -> r) $ case i of+ "=" -> Right ""+ _ -> B64.decode i+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "success")+ _ [] []) = XCSaslSuccess Nothing+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "success")+ _ [] [XmlCharData d]) =+ XCSaslSuccess . Just . (\(Right r) -> r) $ B64.decode d+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "challenge")+ _ [] []) = SRChallenge ""+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "challenge")+ _ [] [XmlCharData c]) = let Right d = B64.decode c in SRChallenge d+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "response")+ _ [] [XmlCharData cd]) = let Right s = B64.decode cd in SRResponse s+toCommon (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-sasl"), "response")+ _ [] []) = SRResponse ""++toCommon (XmlNode ((_, Just q), "message") _ as ns)+ | q `elem` ["jabber:client", "jabber:server"] =+ SRMessage (toTags as) ns+toCommon (XmlNode ((_, Just q), "iq") _ as ns)+ | q `elem` ["jabber:client", "jabber:server"], Just b <- toIqBody ns =+ SRIqBind ts b+ where ts = map (first toTag) as+toCommon (XmlNode ((_, Just q), "iq") _ as ns)+ | q `elem` ["jabber:client", "jabber:server"] = SRIq ts ns+ where ts = toTags as+toCommon (XmlNode ((_, Just "jabber:client"), "presence") _ as ns) =+ SRPresence (toTags as) ns+toCommon (XmlNode ((_, Just "jabber:server"), "presence") _ as ns) =+ SRPresence (toTags as) ns++toCommon n = XCRaw n++toMpi :: XmlNode -> Mpi+toMpi (XmlNode ((_, Just q), "message") _ as ns)+ | q `elem` ["jabber:client", "jabber:server"] = Message (toTags as) ns+toMpi (XmlNode ((_, Just q), "iq") _ as ns)+ | q `elem` ["jabber:client", "jabber:server"] = Iq ts ns+ where ts = toTags as+toMpi (XmlNode ((_, Just "jabber:client"), "presence") _ as ns) =+ Presence (toTags as) ns+toMpi (XmlNode ((_, Just "jabber:server"), "presence") _ as ns) =+ Presence (toTags as) ns+toMpi (XmlEnd ((_, Just "http://etherx.jabber.org/streams"), "stream")) = End+toMpi n = MpiRaw n++toIqBody :: [XmlNode] -> Maybe Query+toIqBody [XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-bind"), "bind") _ []+ [n]] = Just . IqBind Nothing $ toBind n+toIqBody [XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-bind"), "bind") _ []+ [n, n']] | r <- toRequirement [n] = Just . IqBind (Just r) $ toBind n'+toIqBody _ = Nothing++toBind :: XmlNode -> Bind+toBind (XmlNode ((_, Just "urn:ietf:params:xml:ns:xmpp-bind"), "resource") [] []+ [XmlCharData cd]) = Resource cd+toBind n = BindRaw n++fromBind :: Bind -> [XmlNode]+fromBind (BJid _) = error "fromBind: not implemented"+fromBind (Resource r) = [+ XmlNode (nullQ "bind") [("", "urn:ietf:params:xml:ns:xmpp-bind")] []+ [XmlNode (nullQ "required") [] [] [], resource r]+ ]+fromBind (BindRaw n) = [n]++resource :: BS.ByteString -> XmlNode+resource r = XmlNode (nullQ "resource") [] [] [XmlCharData r]++data Side = Client | Server deriving Show++jabberQ :: Side -> BS.ByteString+jabberQ Client = "jabber:client"+jabberQ Server = "jabber:server"++fromCommon :: Side -> Xmpp -> XmlNode+fromCommon _ (XCDecl) = XmlDecl (1, 0)+fromCommon s (XCBegin ts) = XmlStart (("stream", Nothing), "stream")+ [ ("", jabberQ s),+ ("stream", "http://etherx.jabber.org/streams") ]+ (map (first fromTag) ts)+fromCommon _ XCEnd = XmlEnd (("stream", Nothing), "stream")+fromCommon _ (XCFeatures fs) =+ XmlNode (("stream", Nothing), "features") [] [] $ map fromFeature fs+fromCommon _ XCStarttls = XmlNode (nullQ "starttls")+ [("", "urn:ietf:params:xml:ns:xmpp-tls")] [] []+fromCommon _ XCProceed = XmlNode (nullQ "proceed")+ [("", "urn:ietf:params:xml:ns:xmpp-tls")] [] []+fromCommon _ (XCAuth m Nothing) = XmlNode (nullQ "auth")+ [("", "urn:ietf:params:xml:ns:xmpp-sasl")]+ [(nullQ "mechanism", m)] []+fromCommon _ (XCAuth m (Just i)) = XmlNode (nullQ "auth")+ [("", "urn:ietf:params:xml:ns:xmpp-sasl")]+ [(nullQ "mechanism", m)]+ [XmlCharData $ case i of "" -> "="; _ -> B64.encode i]+fromCommon _ (XCSaslSuccess Nothing) =+ XmlNode (nullQ "success") [("", "urn:ietf:params:xml:ns:xmpp-sasl")] [] []+fromCommon _ (XCSaslSuccess (Just d)) =+ XmlNode (nullQ "success") [("", "urn:ietf:params:xml:ns:xmpp-sasl")] []+ [XmlCharData $ B64.encode d]+fromCommon _ (SRChallenge "") = XmlNode (nullQ "challenge")+ [("", "urn:ietf:params:xml:ns:xmpp-sasl")] [] []+fromCommon _ (SRChallenge c) = XmlNode (nullQ "challenge")+ [("", "urn:ietf:params:xml:ns:xmpp-sasl")] [] .+ (: []) . XmlCharData $ B64.encode c+fromCommon _ (SRResponse "") = drnToXmlNode+fromCommon _ (SRResponse s) = drToXmlNode s+fromCommon _ (SRMessage ts ns) =+ XmlNode (nullQ "message") [] (fromTags ts) ns+fromCommon _ (SRIqBind ts q) = XmlNode (nullQ "iq") [] (map (first fromTag) ts)+ (fromQuery q)+fromCommon _ (SRIq ts q) = XmlNode (nullQ "iq") [] (fromTags ts) q+fromCommon _ (SRPresence ts c) = XmlNode (nullQ "presence") [] (fromTags ts) c+fromCommon _ (XCRaw n) = n++fromMpi :: Mpi -> XmlNode+fromMpi (Message ts ns) = XmlNode (nullQ "message") [] (fromTags ts) ns+fromMpi (Iq ts q) = XmlNode (nullQ "iq") [] (fromTags ts) q+fromMpi (Presence ts c) = XmlNode (nullQ "presence") [] (fromTags ts) c+fromMpi End = XmlEnd (("stream", Nothing), "stream")+fromMpi (MpiRaw n) = n++drToXmlNode :: BS.ByteString -> XmlNode+drToXmlNode dr = XmlNode (nullQ "response")+ [("", "urn:ietf:params:xml:ns:xmpp-sasl")] []+ [XmlCharData $ B64.encode dr]++drnToXmlNode :: XmlNode+drnToXmlNode = XmlNode (nullQ "response")+ [("", "urn:ietf:params:xml:ns:xmpp-sasl")] [] []++fromQuery :: Query -> [XmlNode]+fromQuery (IqBind Nothing (BJid j)) =+ [XmlNode (nullQ "jid") [] [] [XmlCharData $ fromJid j]]+fromQuery (IqBind r b) = maybe id ((:) . fromRequirement) r $ fromBind b
+ examples/simpleClient.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++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
+ examples/simpleServer.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++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"
+ xmpipe.cabal view
@@ -0,0 +1,269 @@+build-type: Simple+cabal-version: >= 1.8++name: xmpipe+version: 0.0.0.0+stability: Experimental+author: Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>+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 <https://hackage.haskell.org/package/peyotls> (sample programs are coming soon)+ .+ * SASL: PLAIN, DIGEST-MD5, SCRAM-SHA-1, EXTERNAL (XEP-0178)+ .+ S2S+ .+ * TLS: use package <https://hackage.haskell.org/package/peyotls> (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