packages feed

xml-push 0.0.0.2 → 0.0.0.3

raw patch · 22 files changed

+86/−62 lines, 22 files

Files

examples/TestPusher.hs view
@@ -14,7 +14,7 @@ import Network.XmlPush  testPusher :: XmlPusher xp =>-	xp Handle -> NumOfHandle xp Handle -> PusherArgs xp -> IO ()+	xp Handle -> NumOfHandle xp Handle -> PusherArgs xp Handle -> IO () testPusher tp hs as = do 	xp <- (`asTypeOf` tp) <$> generate hs as 	void . forkIO . runPipe_ $ readFrom xp
examples/httpPullCl.hs view
@@ -10,9 +10,12 @@ main :: IO () main = do 	h <- connectTo "localhost" $ PortNumber 80-	testPusher (undefined :: HttpPullCl Handle) (One h)-		(HttpPullClArgs "localhost" 80 "/" gtPth (XmlNode-			(nullQ "poll") [] [] []) pendingQ (Just 10000000) drtn)+	testPusher (undefined :: HttpPullCl Handle) (One h) (HttpPullClArgs+		"localhost" 80 "/" gtPth mkPoll pendingQ (Just 10000000) drtn)++mkPoll :: IO XmlNode+mkPoll = do+	return $ XmlNode (nullQ "poll") [] [] []  pendingQ :: XmlNode -> Bool pendingQ (XmlNode (_, "nothing") _ [] []) = False
examples/httpPullTlsCl.hs view
@@ -14,11 +14,13 @@ 	ca <- readCertificateStore ["certs/cacert.sample_pem"] 	k <- readKey "certs/yoshikuni.sample_key" 	c <- readCertificateChain ["certs/yoshikuni.sample_crt"]-	testPusher (undefined :: HttpPullTlsCl Handle) (One h) (-		HttpPullClArgs "localhost" 443 "/" gtPth (XmlNode-			(nullQ "poll") [] [] []) pendingQ (Just 10000000) drtn,-		TlsArgs "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]-		)+	testPusher (undefined :: HttpPullTlsCl Handle) (One h) (HttpPullTlsClArgs+		(HttpPullClArgs "localhost" 443 "/" gtPth mkPoll+			pendingQ (Just 10000000) drtn)+		(TlsArgs "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]) )++mkPoll :: IO XmlNode+mkPoll = return $ XmlNode (nullQ "poll") [] [] []  pendingQ :: XmlNode -> Bool pendingQ (XmlNode (_, "nothing") _ [] []) = False
examples/httpPullTlsSv.hs view
@@ -21,8 +21,10 @@ 	forever $ do 		(h, _, _) <- accept soc 		void . forkIO $ testPusher (undefined :: HttpPullTlsSv Handle)-			(One h) (HttpPullSvArgs isPll endPoll, TlsArgs gtNm-				["TLS_RSA_WITH_AES_128_CBC_SHA"] (Just ca) [(k, c)])+			(One h) (HttpPullTlsSvArgs+				(HttpPullSvArgs isPll endPoll)+				(TlsArgs gtNm ["TLS_RSA_WITH_AES_128_CBC_SHA"]+					(Just ca) [(k, c)]))  isPll :: XmlNode -> Bool isPll (XmlNode (_, "poll") _ _ _) = True
examples/httpPushTlsE.hs view
@@ -18,11 +18,12 @@ 	ch <- connectTo "localhost" $ PortNumber 80 	soc <- listenOn $ PortNumber 8080 	(sh, _, _) <- accept soc-	testPusher (undefined :: HttpPushTls Handle) (Two ch sh) (-		HttpPushArgs "localhost" 80 "" gtPth wntRspns,-		tlsArgsCl "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca-			[(k', c')],-		tlsArgsSv gtNm ["TLS_RSA_WITH_AES_128_CBC_SHA"] (Just ca) [(k', c')] )+	testPusher (undefined :: HttpPushTls Handle) (Two ch sh) (HttpPushTlsArgs+		(HttpPushArgs "localhost" 80 "" gtPth wntRspns)+		(tlsArgsCl "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca+			[(k', c')])+		(tlsArgsSv gtNm ["TLS_RSA_WITH_AES_128_CBC_SHA"]+			(Just ca) [(k', c')]) )  wntRspns :: XmlNode -> Bool wntRspns (XmlNode (_, "monologue") _ [] []) = False
examples/httpPushTlsT.hs view
@@ -20,12 +20,14 @@ 	forever  $ do 		(sh, _, _) <- accept soc 		ch <- connectTo "localhost" $ PortNumber 8080-		testPusher (undefined :: HttpPushTls Handle) (Two ch sh) (-			HttpPushArgs "Yoshikuni" 8080 "" gtPth wntRspns,-			tlsArgsCl "Yoshikuni"-				["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k', c')],-			tlsArgsSv gtNm ["TLS_RSA_WITH_AES_128_CBC_SHA"]-				(Just ca) [(k', c')] )+		testPusher (undefined :: HttpPushTls Handle) (Two ch sh)+			(HttpPushTlsArgs+				(HttpPushArgs "Yoshikuni" 8080 "" gtPth wntRspns)+				(tlsArgsCl "Yoshikuni"+					["TLS_RSA_WITH_AES_128_CBC_SHA"]+						ca [(k', c')])+				(tlsArgsSv gtNm ["TLS_RSA_WITH_AES_128_CBC_SHA"]+					(Just ca) [(k', c')]) )  wntRspns :: XmlNode -> Bool wntRspns (XmlNode (_, "monologue") _ [] []) = False
examples/xmppTls.hs view
@@ -20,10 +20,10 @@ 	ca <- readCertificateStore ["certs/cacert.sample_pem"] 	k <- readKey "certs/yoshikuni.sample_key" 	c <- readCertificateChain ["certs/yoshikuni.sample_crt"]-	testPusher (undefined :: XmppTls Handle) (One h) (-		XmppArgs ["EXTERNAL", "SCRAM-SHA-1", "DIGEST-MD5", "PLAIN"]-			(toJid me) ps (toJid you) iNdRspns wntRspns,-		TlsArgs "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)] )+	testPusher (undefined :: XmppTls Handle) (One h) (XmppTlsArgs+		(XmppArgs ["EXTERNAL", "SCRAM-SHA-1", "DIGEST-MD5", "PLAIN"]+			(toJid me) ps (toJid you) iNdRspns wntRspns)+		(TlsArgs "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]) )  wntRspns :: XmlNode -> Bool wntRspns (XmlNode (_, "monologue") _ [] []) = False
src/Network/XmlPush.hs view
@@ -12,12 +12,12 @@  class XmlPusher xp where 	type NumOfHandle xp :: * -> *-	type PusherArgs xp+	type PusherArgs xp :: * -> * 	generate :: ( 		ValidateHandle h, MonadBaseControl IO (HandleMonad h), 		MonadError (HandleMonad h), Error (ErrorType (HandleMonad h)) 		) =>-		NumOfHandle xp h -> PusherArgs xp -> HandleMonad h (xp h)+		NumOfHandle xp h -> PusherArgs xp h -> HandleMonad h (xp h) 	readFrom :: (HandleLike h, MonadBase IO (HandleMonad h)) => 		xp h -> Pipe () XmlNode (HandleMonad h) () 	writeTo :: (HandleLike h, MonadBase IO (HandleMonad h)) =>
src/Network/XmlPush/HttpPull/Client.hs view
@@ -27,8 +27,9 @@ 	writeTo (HttpPullCl _ w) = w  makeHttpPull :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	One h -> HttpPullClArgs -> HandleMonad h (HttpPullCl h)+	One h -> HttpPullClArgs h -> HandleMonad h (HttpPullCl h) makeHttpPull (One h) (HttpPullClArgs hn pn fp gp pl ip d gdr) = do 	dr <- liftBase . atomically $ newTVar d-	(inc, otc) <- talkC h hn pn fp gp pl ip dr gdr+	pll <- pl+	(inc, otc) <- talkC h hn pn fp gp pll ip dr gdr 	return $ HttpPullCl (fromTChan inc) (toTChan otc)
src/Network/XmlPush/HttpPull/Client/Common.hs view
@@ -22,12 +22,12 @@  import qualified Data.ByteString.Lazy as LBS -data HttpPullClArgs = HttpPullClArgs {+data HttpPullClArgs h = HttpPullClArgs { 	hostName :: String, 	portNumber :: Int, 	basePath :: FilePath, 	getPath :: XmlNode -> FilePath,-	poll :: XmlNode,+	poll :: HandleMonad h XmlNode, 	isPending :: XmlNode -> Bool, 	duration :: Maybe Int, 	getDuration :: XmlNode -> Maybe Int
src/Network/XmlPush/HttpPull/Server.hs view
@@ -25,7 +25,7 @@ 	writeTo (HttpPullSv _ w) = w  makeHttpPull :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	One h -> HttpPullSvArgs -> HandleMonad h (HttpPullSv h)+	One h -> HttpPullSvArgs h -> HandleMonad h (HttpPullSv h) makeHttpPull (One h) (HttpPullSvArgs ip ep) = do 	(inc, otc) <- runXml h ip ep (convert id) 	return $ HttpPullSv (fromTChan inc) (toTChan otc)
src/Network/XmlPush/HttpPull/Server/Common.hs view
@@ -18,7 +18,7 @@  import qualified Data.ByteString.Lazy as LBS -data HttpPullSvArgs = HttpPullSvArgs {+data HttpPullSvArgs h = HttpPullSvArgs { 	isPoll :: XmlNode -> Bool, 	noPending :: XmlNode 	}
src/Network/XmlPush/HttpPull/Tls/Client.hs view
@@ -2,7 +2,7 @@ 	PackageImports #-}  module Network.XmlPush.HttpPull.Tls.Client (-	HttpPullTlsCl, HttpPullClArgs(..), TlsArgs(..)) where+	HttpPullTlsCl, HttpPullTlsClArgs(..), HttpPullClArgs(..), TlsArgs(..)) where  import Prelude hiding (filter) @@ -28,9 +28,11 @@ 	(Pipe () XmlNode (HandleMonad h) ()) 	(Pipe XmlNode () (HandleMonad h) ()) +data HttpPullTlsClArgs h = HttpPullTlsClArgs (HttpPullClArgs h) TlsArgs+ instance XmlPusher HttpPullTlsCl where 	type NumOfHandle HttpPullTlsCl = One-	type PusherArgs HttpPullTlsCl = (HttpPullClArgs, TlsArgs)+	type PusherArgs HttpPullTlsCl = HttpPullTlsClArgs 	generate = makeHttpPull 	readFrom (HttpPullTlsCl r _) = r 	writeTo (HttpPullTlsCl _ w) = w@@ -73,12 +75,13 @@ 	else (bs `BS.append`) <$> getBS i (n - BS.length bs)  makeHttpPull :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>-	One h -> (HttpPullClArgs, TlsArgs) -> HandleMonad h (HttpPullTlsCl h)-makeHttpPull (One h)-	(HttpPullClArgs hn pn fp gp pl ip d gd, TlsArgs dn cs ca kcs) = do+	One h -> HttpPullTlsClArgs h -> HandleMonad h (HttpPullTlsCl h)+makeHttpPull (One h) (HttpPullTlsClArgs+	(HttpPullClArgs hn pn fp gp pl ip d gd) (TlsArgs dn cs ca kcs)) = do 	dr <- liftBase . atomically $ newTVar d 	(inc, otc) <- do 		(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool 		(ic, oc) <- open' h dn cs kcs ca g-		liftBase $ talkC (TChanHandle ic oc) hn pn fp gp pl ip dr gd+		pll <- pl+		liftBase $ talkC (TChanHandle ic oc) hn pn fp gp pll ip dr gd 	return $ HttpPullTlsCl (fromTChan inc) (toTChan otc)
src/Network/XmlPush/HttpPull/Tls/Server.hs view
@@ -2,7 +2,8 @@ 	PackageImports #-}  module Network.XmlPush.HttpPull.Tls.Server (-	HttpPullTlsSv, HttpPullSvArgs(..), TlsArgs(..) ) where+	HttpPullTlsSv, HttpPullTlsSvArgs(..), HttpPullSvArgs(..), TlsArgs(..)+	) where  import Prelude hiding (filter) @@ -26,17 +27,19 @@ 	(Pipe () XmlNode (HandleMonad h) ()) 	(Pipe XmlNode () (HandleMonad h) ()) +data HttpPullTlsSvArgs h = HttpPullTlsSvArgs (HttpPullSvArgs h) TlsArgs+ instance XmlPusher HttpPullTlsSv where 	type NumOfHandle HttpPullTlsSv = One-	type PusherArgs HttpPullTlsSv = (HttpPullSvArgs, TlsArgs)+	type PusherArgs HttpPullTlsSv = HttpPullTlsSvArgs 	generate = makeHttpPull 	readFrom (HttpPullTlsSv r _) = r 	writeTo (HttpPullTlsSv _ w) = w  makeHttpPull :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>-	One h -> (HttpPullSvArgs, TlsArgs) ->-	HandleMonad h (HttpPullTlsSv h)-makeHttpPull (One h) (HttpPullSvArgs ip ep, TlsArgs gn cs mca kcs) = do+	One h -> HttpPullTlsSvArgs h -> HandleMonad h (HttpPullTlsSv h)+makeHttpPull (One h) (HttpPullTlsSvArgs+	(HttpPullSvArgs ip ep) (TlsArgs gn cs mca kcs)) = do 	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG) 	(inc, otc) <- (`run` g) $ do 		t <- open h cs kcs mca
src/Network/XmlPush/HttpPush.hs view
@@ -45,7 +45,7 @@ 			(const True, clientWriteChan hp) ]  makeHttpPush :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>-	h -> h -> HttpPushArgs -> HandleMonad h (HttpPush h)+	h -> h -> HttpPushArgs h -> HandleMonad h (HttpPush h) makeHttpPush ch sh (HttpPushArgs hn pn pt gp wr) = do 	v <- liftBase . atomically $ newTVar False 	(ci, co) <- clientC ch hn pn pt gp
src/Network/XmlPush/HttpPush/Common.hs view
@@ -23,7 +23,7 @@  import qualified Data.ByteString.Lazy as LBS -data HttpPushArgs = HttpPushArgs {+data HttpPushArgs h = HttpPushArgs { 	hostName :: String, 	portNumber :: Int, 	basePath :: FilePath,
src/Network/XmlPush/HttpPush/Tls.hs view
@@ -3,7 +3,7 @@ 	PackageImports #-}  module Network.XmlPush.HttpPush.Tls (-	HttpPushTls, HttpPushArgs(..),+	HttpPushTls, HttpPushTlsArgs(..), HttpPushArgs(..), 	TlsArgsCl, tlsArgsCl, TlsArgsSv, tlsArgsSv) where  import Prelude hiding (filter)@@ -56,9 +56,11 @@ 	serverReadChan :: TChan (XmlNode, Bool), 	serverWriteChan :: TChan (Maybe XmlNode) } +data HttpPushTlsArgs h = HttpPushTlsArgs (HttpPushArgs h) TC.TlsArgs TS.TlsArgs+ instance XmlPusher HttpPushTls where 	type NumOfHandle HttpPushTls = Two-	type PusherArgs HttpPushTls = (HttpPushArgs, TC.TlsArgs, TS.TlsArgs)+	type PusherArgs HttpPushTls = HttpPushTlsArgs 	generate (Two ch sh) = makeHttpPushTls ch sh 	readFrom hp = fromTChans [clientReadChan hp, serverReadChan hp] =$= 		setNeedReply (needReply hp)@@ -70,10 +72,9 @@ 			(const True, clientWriteChan hp) ]  makeHttpPushTls :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>-	h -> h -> (HttpPushArgs, TC.TlsArgs, TS.TlsArgs) ->-	HandleMonad h (HttpPushTls h)-makeHttpPushTls ch sh (HttpPushArgs hn pn pt gp wr,-	TC.TlsArgs dn cs ca kcs, TS.TlsArgs gn cs' mca' kcs') = do+	h -> h -> HttpPushTlsArgs h -> HandleMonad h (HttpPushTls h)+makeHttpPushTls ch sh (HttpPushTlsArgs (HttpPushArgs hn pn pt gp wr)+	(TC.TlsArgs dn cs ca kcs) (TS.TlsArgs gn cs' mca' kcs')) = do 	when (dn /= hn) $ error "makeHttpPushTls: conflicted domain name" 	v <- liftBase . atomically $ newTVar False 	(ci, co) <- clientC ch hn pn pt gp cs ca kcs
src/Network/XmlPush/Simple.hs view
@@ -16,9 +16,11 @@ 	(Pipe () XmlNode (HandleMonad h) ()) 	(Pipe XmlNode () (HandleMonad h) ()) +data SimplePusherArgs h = SimplePusherArgsNull+ instance XmlPusher SimplePusher where 	type NumOfHandle SimplePusher = One-	type PusherArgs SimplePusher = ()+	type PusherArgs SimplePusher = SimplePusherArgs 	generate (One h) _ = simplePusher h 	readFrom (SimplePusher r _) = r 	writeTo (SimplePusher _ w) = w
src/Network/XmlPush/Xmpp.hs view
@@ -48,7 +48,7 @@ makeXmpp :: ( 	HandleLike h, MonadBaseControl IO (HandleMonad h), 	MonadError (HandleMonad h), Error (ErrorType (HandleMonad h))-	) => One h -> XmppArgs -> HandleMonad h (Xmpp h)+	) => One h -> XmppArgs h -> HandleMonad h (Xmpp h) makeXmpp (One h) (XmppArgs ms me ps you inr wr) = do 	nr <- liftBase $ atomically newTChan 	wc <- liftBase $ atomically newTChan
src/Network/XmlPush/Xmpp/Common.hs view
@@ -26,7 +26,7 @@  import qualified Data.ByteString as BS -data XmppArgs = XmppArgs {+data XmppArgs h = XmppArgs { 	mechanisms :: [BS.ByteString], 	myJid :: Jid, passowrd :: BS.ByteString, 	yourJid :: Jid,
src/Network/XmlPush/Xmpp/Tls.hs view
@@ -2,7 +2,8 @@ 	TypeFamilies, FlexibleContexts, ScopedTypeVariables, 	PackageImports #-} -module Network.XmlPush.Xmpp.Tls (XmppTls, XmppArgs(..), TlsArgs(..)) where+module Network.XmlPush.Xmpp.Tls (+	XmppTls, XmppTlsArgs(..), XmppArgs(..), TlsArgs(..)) where  import Prelude hiding (filter) @@ -37,9 +38,11 @@ 	(Pipe () Mpi (HandleMonad h) ()) 	(TChan (Either BS.ByteString XmlNode)) +data XmppTlsArgs h = XmppTlsArgs (XmppArgs h) TlsArgs+ instance XmlPusher XmppTls where 	type NumOfHandle XmppTls = One-	type PusherArgs XmppTls = (XmppArgs, TlsArgs)+	type PusherArgs XmppTls = XmppTlsArgs 	generate = makeXmppTls 	readFrom (XmppTls wr nr r wc) = r 		=$= pushId wr nr wc@@ -51,8 +54,9 @@ makeXmppTls :: ( 	ValidateHandle h, MonadBaseControl IO (HandleMonad h), 	MonadError (HandleMonad h), Error (ErrorType (HandleMonad h))-	) => One h -> (XmppArgs, TlsArgs) -> HandleMonad h (XmppTls h)-makeXmppTls (One h) (XmppArgs ms me ps you inr wr, TlsArgs dn cs ca kcs) = do+	) => One h -> XmppTlsArgs h -> HandleMonad h (XmppTls h)+makeXmppTls (One h)+	(XmppTlsArgs (XmppArgs ms me ps you inr wr) (TlsArgs dn cs ca kcs)) = do 	nr <- liftBase $ atomically newTChan 	wc <- liftBase $ atomically newTChan 	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool
xml-push.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		xml-push-version:	0.0.0.2+version:	0.0.0.3 stability:	Experimenmtal author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -100,7 +100,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/xml-push.git-    tag:	xml-push-0.0.0.2+    tag:	xml-push-0.0.0.3  library     hs-source-dirs:	src