xml-push 0.0.0.10 → 0.0.0.11

raw patch · 6 files changed

+329/−4 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/Network/XmlPush.hs +2/−1
• src/Network/XmlPush/Xmpp.hs +1/−1
• src/Network/XmlPush/Xmpp/Server.hs +66/−0
• src/Network/XmlPush/Xmpp/Server/Common.hs +153/−0
• src/Network/XmlPush/Xmpp/Tls/Server.hs +103/−0
• xml-push.cabal +4/−2

@@ -9,13 +9,14 @@ import Data.Pipe import Text.XML.Pipe import Network.PeyoTLS.Client+import Network.Sasl  class XmlPusher xp where 	type NumOfHandle xp :: * -> * 	type PusherArgs xp :: * -> * 	generate :: ( 		ValidateHandle h, MonadBaseControl IO (HandleMonad h),-		MonadError (HandleMonad h), Error (ErrorType (HandleMonad h))+		MonadError (HandleMonad h), SaslError (ErrorType (HandleMonad h)) 		) => 		NumOfHandle xp h -> PusherArgs xp h -> HandleMonad h (xp h) 	readFrom :: (HandleLike h, MonadBase IO (HandleMonad h)) =>

@@ -57,7 +57,7 @@ 		(Jid un d (Just rsc)) = me 		ss = St [ 			("username", un), ("authcid", un), ("password", ps),-			("cnonce", cn) ]+			("cnonce", cn), ("nc", "00000001"), ("uri", "hoge") ] 	void . (`evalStateT` ss) . runPipe $ fromHandleLike (THandle h) 		=$= sasl d ms 		=$= toHandleLike (THandle h)

@@ -0,0 +1,66 @@+{-# LANGUAGE+	PatternGuards,+	OverloadedStrings, TypeFamilies, FlexibleContexts,+	PackageImports #-}++module Network.XmlPush.Xmpp.Server (+	XmppServer, XmppServerArgs(..),+	) where++import Prelude hiding (filter)++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Control.Monad.Base+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.Flow+import Data.Pipe.IO+import Text.XML.Pipe+import Network.XMPiPe.Core.C2S.Server+import Network.Sasl++import Network.XmlPush+import Network.XmlPush.Xmpp.Common+import Network.XmlPush.Xmpp.Server.Common++data XmppServer h = XmppServer+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++instance XmlPusher XmppServer where+	type NumOfHandle XmppServer = One+	type PusherArgs XmppServer = XmppServerArgs+	generate = makeXmppServer+	readFrom (XmppServer r _) = r+	writeTo (XmppServer _ w) = w++makeXmppServer :: (+	HandleLike h,+	MonadError (HandleMonad h), SaslError (ErrorType (HandleMonad h)),+	MonadBase IO (HandleMonad h) ) =>+	One h -> XmppServerArgs h -> HandleMonad h (XmppServer h)+makeXmppServer (One h) (XmppServerArgs dn ps inr ynr) = do+	rids <- liftBase $ atomically newTChan+	(Just ns, st) <- (`runStateT` initXSt dn) . runPipe $ do+		fromHandleLike (THandle h)+			=$= sasl dn (retrieves dn ps)+			=$= toHandleLike (THandle h)+		fromHandleLike (THandle h)+			=$= bind dn []+			=@= toHandleLike (THandle h)+	liftBase . print $ user st+	let	r = fromHandleLike h+			=$= input ns+			=$= debug+			=$= setIds h ynr rids+			=$= convert fromMessage+			=$= filter isJust+			=$= convert fromJust+		w = makeMpi (user st) inr rids+			=$= debug+			=$= output+			=$= toHandleLike h+	return $ XmppServer r w

@@ -0,0 +1,153 @@+{-# LANGUAGE+ 	PatternGuards,+ 	OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.XmlPush.Xmpp.Server.Common (+	XmppServerArgs(..),+	retrieves,+	initXSt, user,+	setIds,+	makeMpi,+	) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Control.Monad.Base+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.IO+import Data.UUID+import System.Random+import Text.XML.Pipe+import Network.XMPiPe.Core.C2S.Server+import Network.XMPiPe.Core.C2S.Client (toJid)+import Network.Sasl++import qualified Data.ByteString as BS+import qualified Network.Sasl.DigestMd5.Server as DM5+import qualified Network.Sasl.ScramSha1.Server as SS1++import Network.XmlPush.Xmpp.Common++data XmppServerArgs h = XmppServerArgs {+	domainName :: BS.ByteString,+	passwords :: [(BS.ByteString, BS.ByteString)],+	iNeedResponse :: XmlNode -> Bool,+	youNeedResponse :: XmlNode -> Bool+	}++retrieves :: (+	MonadState m, SaslState (StateType m),+	MonadError m, SaslError (ErrorType m) ) =>+	BS.ByteString -> [(BS.ByteString, BS.ByteString)] -> [Retrieve m]+retrieves dn ps = [+	RTPlain $ retrievePln ps,+	RTDigestMd5 $ retrieveDM5 dn ps,+	RTScramSha1 $ retrieveSS1 ps ]++retrievePln :: (+	MonadState m, SaslState (StateType m),+	MonadError m, SaslError (ErrorType m)) =>+	[(BS.ByteString, BS.ByteString)] ->+	BS.ByteString -> BS.ByteString -> BS.ByteString -> m ()+retrievePln ps "" usr pwd0+	| Just pwd <- lookup usr ps, pwd == pwd0 = return ()+retrievePln _ _ _ _ = throwError $ fromSaslError NotAuthorized "auth failure"++retrieveDM5 :: (+	MonadState m, SaslState (StateType m),+	MonadError m, SaslError (ErrorType m) ) =>+	BS.ByteString -> [(BS.ByteString, BS.ByteString)] ->+	BS.ByteString -> m BS.ByteString+retrieveDM5 dn ps usr+	| Just pwd <- lookup usr ps = return $ DM5.mkStored usr dn pwd+retrieveDM5 _ _ _ = throwError $ fromSaslError NotAuthorized "auth failure"++retrieveSS1 :: (+	MonadState m, SaslState (StateType m),+	MonadError m, SaslError (ErrorType m) ) =>+	[(BS.ByteString, BS.ByteString)] -> BS.ByteString ->+	m (BS.ByteString, BS.ByteString, BS.ByteString, Int)+retrieveSS1 ps usr | Just pwd <- lookup usr ps = let+	slt = "pepper"; i = 4492; (stk, svk) = SS1.salt pwd slt i in+	return (slt, stk, svk, i)+retrieveSS1 _ _ = throwError $ fromSaslError NotAuthorized "auth failure"++initXSt :: BS.ByteString -> XSt+initXSt dn = XSt {+	user = Jid "" dn Nothing, rands = repeat "00DEADBEEF00",+	sSt = [	("realm", dn), ("qop", "auth"), ("charset", "utf-8"),+		("algorithm", "md5-sess") ] }++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"++setIds :: (HandleLike h, MonadBase IO (HandleMonad h)) => h ->+	(XmlNode -> Bool) -> TChan BS.ByteString -> Pipe Mpi Mpi (HandleMonad h) ()+setIds h ynr rids = (await >>=) . maybe (return ()) $ \mpi -> do+	yield mpi+	if boolXmlNode ynr mpi+	then when (isGetSet mpi) . lift . liftBase . atomically+		$ writeTChan rids (fromJust $ getId mpi)+	else lift $ returnEmpty h "hoge"+	lift . liftBase . putStrLn $ "\nsetIds: " ++ show (getId mpi)+	setIds h ynr rids++isGetSet :: Mpi -> Bool+isGetSet (Iq Tags { tagType = Just "set" } _) = True+isGetSet (Iq Tags { tagType = Just "get" } _) = True+isGetSet _ = False++getId :: Mpi -> Maybe BS.ByteString+getId (Iq t _) = tagId t+getId (Message t _) = tagId t+getId _ = Nothing++boolXmlNode :: (XmlNode -> Bool) -> Mpi -> Bool+boolXmlNode f (Iq _ [n]) = f n+boolXmlNode _ _ = False++returnEmpty :: (HandleLike h, MonadBase IO (HandleMonad h)) => h -> BS.ByteString -> HandleMonad h ()+returnEmpty h i = runPipe_ $ yield e =$= output =$= debug =$= toHandleLike h+	where+	you = toJid "hoge@hogehost"+	e = Iq (tagsType "result") { tagId = Just i, tagTo = Just you } []++makeMpi :: MonadBase IO m => Jid ->+	(XmlNode -> Bool) -> TChan BS.ByteString -> Pipe XmlNode Mpi m ()+makeMpi usr inr rids = (await >>=) . maybe (return ()) $ \n -> do+	e <- lift . liftBase . atomically $ isEmptyTChan rids+	if e+	then if inr n+		then do	uuid <- lift $ liftBase randomIO+			yield $ Iq (tagsType "get") {+				tagId = Just $ toASCIIBytes uuid,+				tagTo = Just usr+				} [n]+		else do uuid <- lift $ liftBase randomIO+			yield $ Message (tagsType "chat") {+			tagId = Just $ toASCIIBytes uuid,+			tagTo = Just usr+			} [n]+	else do	i <- lift . liftBase .atomically $ readTChan rids+		lift . liftBase . putStrLn $ "makeMpi: " ++ show i+		yield $ Iq (tagsType "return") {+			tagId = Just i,+			tagTo = Just usr+			} [n]+	makeMpi usr inr rids

@@ -0,0 +1,103 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, ScopedTypeVariables,+	PackageImports #-}++module Network.XmlPush.Xmpp.Tls.Server (+	XmppTlsServer,+	XmppTlsServerArgs(..), XmppServerArgs(..), TlsArgs(..),+	) where++import Prelude hiding (filter)++import Control.Applicative+import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.Flow+import Data.Pipe.IO+import Data.Pipe.TChan+import Data.UUID+import Data.X509+import System.Random+import Text.XML.Pipe+import Network.XMPiPe.Core.C2S.Server+import Network.XmlPush+import Network.Sasl+import Network.PeyoTLS.TChan.Server+import "crypto-random" Crypto.Random++-- import qualified Data.ByteString.Char8 as BSC++import Network.XmlPush.Xmpp.Common+import Network.XmlPush.Xmpp.Server.Common+import Network.XmlPush.Tls.Server++data XmppTlsServer h = XmppTlsServer+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++data XmppTlsServerArgs h = XmppTlsServerArgs (XmppServerArgs h) TlsArgs++instance XmlPusher XmppTlsServer where+	type NumOfHandle XmppTlsServer = One+	type PusherArgs XmppTlsServer = XmppTlsServerArgs+	generate = makeXmppTlsServer+	readFrom (XmppTlsServer r _) = r+	writeTo (XmppTlsServer _ w) = w++makeXmppTlsServer :: (+	ValidateHandle h,+	MonadError (HandleMonad h), SaslError (ErrorType (HandleMonad h)),+	MonadBaseControl IO (HandleMonad h) ) =>+	One h -> XmppTlsServerArgs h -> HandleMonad h (XmppTlsServer h)+makeXmppTlsServer (One h) (XmppTlsServerArgs+	(XmppServerArgs dn ps inr ynr)+	(TlsArgs gn cc cs mca kcs)) = do+	rids <- liftBase $ atomically newTChan+	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool+	us <- liftBase $ map toASCIIBytes . randoms <$> getStdGen+	_ <- (`execStateT` us) . runPipe_ $ fromHandleLike (THandle h)+		=$= starttls dn+		=$= toHandleLike (THandle h)+	(Just (cn, c), (inp, otp)) <- open h cs kcs mca g+	(Just ns, st) <- (`runStateT` initXSt dn) . runPipe $ do+		fromTChan inp =$= sasl dn (retrieves dn ps) =$= toTChan otp+		fromTChan inp =$= bind dn [] =@= toTChan otp+	liftBase . print $ user st+	let	r = fromTChan inp+			=$= input ns+			=$= debug+			=$= setIds h ynr rids+			=$= convert fromMessage+			=$= filter isJust+			=$= convert fromJust+			=$= checkName cn gn+			=$= checkCert c cc+		w = makeMpi (user st) inr rids+			=$= debug+			=$= output+			=$= toTChan otp+	return $ XmppTlsServer r w++checkName :: Monad m => (String -> Bool) -> (XmlNode -> Maybe String) ->+	Pipe XmlNode XmlNode m ()+checkName cn gn = (await >>=) . maybe (return ()) $ \nd -> do+	case gn nd of+		Just n -> unless (cn n) $ error "checkName: bad client name"+		_ -> return ()+	yield nd+	checkName cn gn++checkCert :: Monad m =>+	SignedCertificate -> (XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	Pipe XmlNode XmlNode m ()+checkCert c cc = (await >>=) . maybe (return ()) $ \n -> do+	case cc n of+		Just ck -> unless (ck c) $ error "checkCert: bad certificate"+		_ -> return ()+	yield n+	checkCert c cc

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		xml-push-version:	0.0.0.10+version:	0.0.0.11 stability:	Experimenmtal author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -100,13 +100,14 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/xml-push.git-    tag:	xml-push-0.0.0.10+    tag:	xml-push-0.0.0.11  library     hs-source-dirs:	src     exposed-modules:         Network.XmlPush, Network.XmlPush.Simple         Network.XmlPush.Xmpp, Network.XmlPush.Xmpp.Tls+        Network.XmlPush.Xmpp.Server, Network.XmlPush.Xmpp.Tls.Server,         Network.XmlPush.HttpPull.Client, Network.XmlPush.HttpPull.Server         Network.XmlPush.HttpPull.Tls.Client, Network.XmlPush.HttpPull.Tls.Server         Network.XmlPush.HttpPush, Network.XmlPush.HttpPush.Tls@@ -114,6 +115,7 @@         Network.XmlPush.Tls.Client         Network.XmlPush.Tls.Server         Network.XmlPush.Xmpp.Common+        Network.XmlPush.Xmpp.Server.Common         Network.XmlPush.HttpPull.Client.Common         Network.XmlPush.HttpPull.Server.Common         Network.XmlPush.HttpPush.Common