xml-push (empty) → 0.0.0.0

raw patch · 40 files changed

+1758/−0 lines, 40 filesdep +basedep +bytestringdep +crypto-randomsetup-changed

Dependencies added: base, bytestring, crypto-random, handle-like, monad-control, monads-tf, peyotls, random, sasl, simple-pipe, stm, tighttp, transformers-base, uuid, x509, x509-store, xml-pipe, xmpipe

Files

LICENSE +27/−0
Setup.hs +1/−0
certs/cacert.sample_pem +60/−0
certs/localhost.sample_crt +17/−0
certs/localhost.sample_key +15/−0
certs/yoshikuni.sample_crt +17/−0
certs/yoshikuni.sample_key +15/−0
examples/FilePusher.hs +37/−0
examples/TestPusher.hs +27/−0
examples/TestSimple.hs +25/−0
examples/httpPullCl.hs +33/−0
examples/httpPullSv.hs +26/−0
examples/httpPullTlsCl.hs +37/−0
examples/httpPullTlsSv.hs +36/−0
examples/httpPushE.hs +24/−0
examples/httpPushT.hs +26/−0
examples/httpPushTlsE.hs +37/−0
examples/httpPushTlsT.hs +40/−0
examples/simple.hs +9/−0
examples/simpleClient.hs +5/−0
examples/simpleServer.hs +12/−0
examples/xmpp.hs +31/−0
examples/xmppTls.hs +35/−0
src/Network/XmlPush.hs +28/−0
src/Network/XmlPush/HttpPull/Client.hs +34/−0
src/Network/XmlPush/HttpPull/Client/Common.hs +100/−0
src/Network/XmlPush/HttpPull/Server.hs +31/−0
src/Network/XmlPush/HttpPull/Server/Common.hs +68/−0
src/Network/XmlPush/HttpPull/Tls/Client.hs +84/−0
src/Network/XmlPush/HttpPull/Tls/Server.hs +57/−0
src/Network/XmlPush/HttpPush.hs +87/−0
src/Network/XmlPush/HttpPush/Common.hs +61/−0
src/Network/XmlPush/HttpPush/Tls.hs +139/−0
src/Network/XmlPush/Simple.hs +42/−0
src/Network/XmlPush/Tls/Client.hs +14/−0
src/Network/XmlPush/Tls/Server.hs +15/−0
src/Network/XmlPush/Xmpp.hs +71/−0
src/Network/XmlPush/Xmpp/Common.hs +134/−0
src/Network/XmlPush/Xmpp/Tls.hs +74/−0
xml-push.cabal +127/−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

+ certs/cacert.sample_pem view

@@ -0,0 +1,60 @@+Certificate:+    Data:+        Version: 3 (0x2)+        Serial Number:+            a6:ea:4f:7c:d6:d9:87:67+    Signature Algorithm: sha1WithRSAEncryption+        Issuer: C=JP, ST=Gunma, O=Yoshikuni Co.,Ltd., CN=skami4592.iocikun.jp+        Validity+            Not Before: Apr 26 02:13:01 2014 GMT+            Not After : Apr 25 02:13:01 2017 GMT+        Subject: C=JP, ST=Gunma, O=Yoshikuni Co.,Ltd., CN=skami4592.iocikun.jp+        Subject Public Key Info:+            Public Key Algorithm: rsaEncryption+                Public-Key: (1024 bit)+                Modulus:+                    00:f4:d1:4b:f7:1f:99:65:73:ea:df:4f:66:9d:90:+                    2a:1b:e5:31:b3:da:6c:35:07:a7:ff:3d:de:69:ff:+                    cc:24:fd:1c:58:c1:de:c5:33:c8:4d:60:06:a6:cf:+                    d9:30:bf:05:47:01:63:db:90:92:df:48:b5:8b:6d:+                    4a:00:d5:4e:66:47:a5:3b:c0:5f:f4:ea:34:71:f1:+                    fa:c5:0d:dd:c9:69:ef:20:ef:e0:a7:1c:c0:3a:9f:+                    6c:42:8b:cd:bb:82:44:e7:aa:e1:11:8e:34:f3:b7:+                    c7:73:2d:c6:c8:98:8a:66:68:68:30:1d:f2:0c:f7:+                    72:e6:06:76:fd:05:7d:ef:e9+                Exponent: 65537 (0x10001)+        X509v3 extensions:+            X509v3 Subject Key Identifier: +                50:46:D5:F3:87:0B:5C:51:D0:A3:68:44:41:DB:D4:E3:89:DE:78:38+            X509v3 Authority Key Identifier: +                keyid:50:46:D5:F3:87:0B:5C:51:D0:A3:68:44:41:DB:D4:E3:89:DE:78:38++            X509v3 Basic Constraints: +                CA:TRUE+            X509v3 Key Usage: +                Certificate Sign, CRL Sign+    Signature Algorithm: sha1WithRSAEncryption+         98:24:01:e7:4a:fa:7c:72:22:bc:eb:88:3d:6f:3e:8f:b0:9c:+         ed:98:93:95:09:7d:d5:cb:ba:fe:7b:7f:59:e0:6d:5a:cc:c6:+         df:98:1b:0b:5b:cc:a0:f8:ee:1b:c4:8c:a5:f2:ba:4c:54:b3:+         ff:3f:cc:b1:81:74:0a:5a:30:76:a8:99:fc:67:d4:27:6e:5c:+         a4:a2:30:93:f2:45:86:8c:0b:bc:cb:58:75:3e:05:cf:db:84:+         e8:39:04:f2:9c:e1:44:26:2b:93:5d:ce:e6:61:13:58:dd:45:+         38:39:33:66:71:ea:5b:d4:0e:40:32:94:83:b6:0f:2d:2a:29:+         9e:b4+-----BEGIN CERTIFICATE-----+MIICjTCCAfagAwIBAgIJAKbqT3zW2YdnMA0GCSqGSIb3DQEBBQUAMFkxCzAJBgNV+BAYTAkpQMQ4wDAYDVQQIDAVHdW5tYTEbMBkGA1UECgwSWW9zaGlrdW5pIENvLixM+dGQuMR0wGwYDVQQDDBRza2FtaTQ1OTIuaW9jaWt1bi5qcDAeFw0xNDA0MjYwMjEz+MDFaFw0xNzA0MjUwMjEzMDFaMFkxCzAJBgNVBAYTAkpQMQ4wDAYDVQQIDAVHdW5t+YTEbMBkGA1UECgwSWW9zaGlrdW5pIENvLixMdGQuMR0wGwYDVQQDDBRza2FtaTQ1+OTIuaW9jaWt1bi5qcDCBnzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEA9NFL9x+Z+ZXPq309mnZAqG+Uxs9psNQen/z3eaf/MJP0cWMHexTPITWAGps/ZML8FRwFj25CS+30i1i21KANVOZkelO8Bf9Oo0cfH6xQ3dyWnvIO/gpxzAOp9sQovNu4JE56rhEY40+87fHcy3GyJiKZmhoMB3yDPdy5gZ2/QV97+kCAwEAAaNdMFswHQYDVR0OBBYEFFBG+1fOHC1xR0KNoREHb1OOJ3ng4MB8GA1UdIwQYMBaAFFBG1fOHC1xR0KNoREHb1OOJ+3ng4MAwGA1UdEwQFMAMBAf8wCwYDVR0PBAQDAgEGMA0GCSqGSIb3DQEBBQUAA4GB+AJgkAedK+nxyIrzriD1vPo+wnO2Yk5UJfdXLuv57f1ngbVrMxt+YGwtbzKD47hvE+jKXyukxUs/8/zLGBdApaMHaomfxn1CduXKSiMJPyRYaMC7zLWHU+Bc/bhOg5BPKc+4UQmK5NdzuZhE1jdRTg5M2Zx6lvUDkAylIO2Dy0qKZ60+-----END CERTIFICATE-----

+ certs/localhost.sample_crt view

@@ -0,0 +1,17 @@+-----BEGIN CERTIFICATE-----+MIICszCCAhygAwIBAgIJAKbqT3zW2YdoMA0GCSqGSIb3DQEBBQUAMFkxCzAJBgNV+BAYTAkpQMQ4wDAYDVQQIDAVHdW5tYTEbMBkGA1UECgwSWW9zaGlrdW5pIENvLixM+dGQuMR0wGwYDVQQDDBRza2FtaTQ1OTIuaW9jaWt1bi5qcDAeFw0xNDA0MjYwMjE1+MDZaFw0xNTA0MjYwMjE1MDZaMGExCzAJBgNVBAYTAkpQMQ4wDAYDVQQIDAVHdW5t+YTERMA8GA1UEBwwIVGFrYXNha2kxGzAZBgNVBAoMEllvc2hpa3VuaSBDby4sTHRk+LjESMBAGA1UEAwwJbG9jYWxob3N0MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB+gQDKDeMfXFUK9YCNC4J+BVghnmxDH1lVmjQdZnVEy9zaBQ+pUeTV8XkTlfvMvFpo+JBxhXGijGD24HE2nHnLYjICxnah5Bg2LPAqOcze2JESZx0oUCTiNX0Co0Na80hoM+vXZgU9FfJp4D0Fb+t85QHbJ8Cfke2xv1nOwXo2s+iY1+OwIDAQABo3sweTAJBgNV+HRMEAjAAMCwGCWCGSAGG+EIBDQQfFh1PcGVuU1NMIEdlbmVyYXRlZCBDZXJ0aWZp+Y2F0ZTAdBgNVHQ4EFgQUCZmhAC/aukdc2wFKdtgSj8nGW1kwHwYDVR0jBBgwFoAU+UEbV84cLXFHQo2hEQdvU44neeDgwDQYJKoZIhvcNAQEFBQADgYEAoYLLedvBcYBh+zTqormeGuSTxTgM92hLHm21YCDSkeYNSik1LLsm3vxo/mwKFhGaoOvtiX4z1CCKX++qic0X4XOyhXADg/WS29h06A2E4JaAnhOn4ZhtayaBa0uS8I047VmhfpiySAcg36+SaMp6HRIBsK1zUrTrFEhpT+XXeOnHaY=+-----END CERTIFICATE-----

+ certs/localhost.sample_key view

@@ -0,0 +1,15 @@+-----BEGIN RSA PRIVATE KEY-----+MIICXQIBAAKBgQDKDeMfXFUK9YCNC4J+BVghnmxDH1lVmjQdZnVEy9zaBQ+pUeTV+8XkTlfvMvFpoJBxhXGijGD24HE2nHnLYjICxnah5Bg2LPAqOcze2JESZx0oUCTiN+X0Co0Na80hoMvXZgU9FfJp4D0Fb+t85QHbJ8Cfke2xv1nOwXo2s+iY1+OwIDAQAB+AoGBAMHBMWO4ScC5jS0ztU2dWFbcsRporGTe+0yaHKf9CepzYgJPCq5x4VX7xDse+/17QCfr+/0QukbjEQ16XXy/zA9AZUtIwzFXYZGu3+0pDIIfKQH7MzIuOCghncxwI+YwSN4cibgt3m9z+2xAHuY6R/dwzpDjz8el4VjJR7yMjRdj4pAkEA9ZJjCN1HuhKA+IsvdJKGrCfspAsvEu7ma62Fj43LFC3tvaHuqT6NX5YH3hD/fadCETooicrXafx7j+r+AG3T/3pwJBANKia6HTWz/OTUwUMVn1lq3cP5kjqJ1QJDmxR285vlY057t4FMN4+c2Sm1vxUVgqEFXn97v2lmwujntB+hJNwF00CQQClccdI/JPLV5V+W+yUNlseMVkS+6ieT9drag9WhMfxw3OtU8CPw3XJlTGducP3as0HADC5jLAOVq0Doh7z4KJV3AkAM+fVEAgXXRrLvsnO3oNaW/nWWwAOtImK3tNdPUhooAtpZfCVnB1WySNUpeH+oSKY7U+cvgu1hkBcaxDFJ1r2KOpAkBbhCr5rDXRmHy0j+Txb4DbyIpjpP9lCRPiiPrN43Xh+8a+/mVx3mz2aaJkQV74JbcqyO4RUV5JOti8doh1Wpp7L+-----END RSA PRIVATE KEY-----

+ certs/yoshikuni.sample_crt view

@@ -0,0 +1,17 @@+-----BEGIN CERTIFICATE-----+MIICqjCCAhOgAwIBAgIJAKbqT3zW2YdrMA0GCSqGSIb3DQEBBQUAMFkxCzAJBgNV+BAYTAkpQMQ4wDAYDVQQIDAVHdW5tYTEbMBkGA1UECgwSWW9zaGlrdW5pIENvLixM+dGQuMR0wGwYDVQQDDBRza2FtaTQ1OTIuaW9jaWt1bi5qcDAeFw0xNDA1MDcwMzIx+MTdaFw0xNTA1MDcwMzIxMTdaMFgxCzAJBgNVBAYTAkpQMQ4wDAYDVQQIDAVHdW5t+YTERMA8GA1UEBwwIVGFrYXNha2kxEjAQBgNVBAoMCVlvc2hpa3VuaTESMBAGA1UE+AwwJWW9zaGlrdW5pMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDUZ8SMZSKO+9MSHkydQKqAvNe2UClkhEedTw4iu13NQMmaB0Oy1H2qaNKkJXqVM0nOJi2/J9dNF+gSenOr4Yqmit7kCSlsTqCpFCN81FcIcsF+gpujeSRgZktJFe5dPNjw38wTWzofx9+Pid/36978+Y4T+kg7EZSVQQ0tkrJQWRJvwIDAQABo3sweTAJBgNVHRMEAjAAMCwG+CWCGSAGG+EIBDQQfFh1PcGVuU1NMIEdlbmVyYXRlZCBDZXJ0aWZpY2F0ZTAdBgNV+HQ4EFgQU3RXgXkT0Tw1FxYgNhipYgeCAzLkwHwYDVR0jBBgwFoAUUEbV84cLXFHQ+o2hEQdvU44neeDgwDQYJKoZIhvcNAQEFBQADgYEAUMIzOZIIQe7QMKakuLjCN/XC++gViRzIPL4lh6X6N9kwW0onHXyo6nTJ7Lv4FXePRJyV9ApjTjmriu0Wyyer6frB3+ey1EXw+XreNwveo6op0wSvpJhATGo2XjikT1G5DBDokO6EKKKFPQzsHfJWHwXz/r+AlKFnCmiYMcIlDrHidA=+-----END CERTIFICATE-----

+ certs/yoshikuni.sample_key view

@@ -0,0 +1,15 @@+-----BEGIN RSA PRIVATE KEY-----+MIICXAIBAAKBgQDUZ8SMZSKO9MSHkydQKqAvNe2UClkhEedTw4iu13NQMmaB0Oy1+H2qaNKkJXqVM0nOJi2/J9dNFgSenOr4Yqmit7kCSlsTqCpFCN81FcIcsF+gpujeS+RgZktJFe5dPNjw38wTWzofx9Pid/36978+Y4T+kg7EZSVQQ0tkrJQWRJvwIDAQAB+AoGAFcNoHSaDqvgjZuzJ+2nSreOtqxyAU2YdOLTxPVDwDMiNPkHk7w4AAzrgEwiy+kTODCRXTZ3MbqaR5JqZbMfXL8c5s9VT5FQ+y7n46prseiUlv5vojdG2I0iO/Y/xm+8hn26jvMLAwBKeuxX8CMzcEKA65Iw7uYsWMJW6EX2Tq2hBkCQQD603V52o83DoS1+1x094v5AOrYa1sxUT2UAcoYKJk26VlSpyY0zJi8hNw9DA+89xWJKCWJ/l9ogu4KL+XdWVraZzAkEA2Mlrku4qdKjRhDSRH2q2GOZaue8HZyBFQeuK+sBGa5Jm/MIzdulL+JRYgjil11+BhM2orhUFIwCtQvqLnTBvwhQJBAMpIAOS9q2QWdFaF3lJLnwpDjxtE+AVM5GFZtBcZnr6XH+81V+2a1s6qQ0eEU6jsh1SuqN+J4n3RoZFZq3VYxzhsCQBX2+0l9gogyPziqG6O018p0zOZ39CdL5AgtbwgkF0hy0CJszUeOKX4Kyazn8GWR152M++Loqhwq01tkiaWLTtX8ECQC2INLRdNa6+ySZZnvKfLHrx3umU0VFnq4QNH6KAFuUr+cU6zXjWkciN6fzXBSV5Ib9g+TIr7ghy5D15pRt6L4Rs=+-----END RSA PRIVATE KEY-----

+ examples/FilePusher.hs view

@@ -0,0 +1,37 @@+{-# LANGUAGE TupleSections, TypeFamilies, FlexibleContexts #-}++module FilePusher (SimplePusher(..)) where++import Control.Monad+import Data.Maybe+import Data.HandleLike+import Control.Monad.Trans.Control+import Data.Pipe+import Data.Pipe.ByteString+import Text.XML.Pipe++import Network.XmlPush++data SimplePusher h = SimplePusher+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++instance XmlPusher SimplePusher where+	type PusherArgs SimplePusher = (FilePath, FilePath)+	type NumOfHandle SimplePusher = Zero+	generate = const $ uncurry simplePusher+	readFrom (SimplePusher r _) = r+	writeTo (SimplePusher _ w) = w++simplePusher :: MonadBaseControl IO (HandleMonad h) =>+	FilePath -> FilePath -> HandleMonad h (SimplePusher h)+simplePusher rf wf = return $ SimplePusher (readXml rf) (writeXml wf)++readXml :: MonadBaseControl IO m => FilePath -> Pipe () XmlNode m ()+readXml rf = fromFile rf+	=$= xmlEvent+	=$= convert fromJust+	=$= void (xmlNode [])++writeXml :: MonadBaseControl IO m => FilePath -> Pipe XmlNode () m ()+writeXml wf = convert (xmlString . (: []))  =$= toFile wf

+ examples/TestPusher.hs view

@@ -0,0 +1,27 @@+{-# LANGUAGE TupleSections, TypeFamilies, FlexibleContexts #-}++module TestPusher (XmlPusher(..), Zero(..), One(..), Two(..), testPusher) where++import Control.Applicative+import Control.Monad+import Control.Concurrent+import Data.Maybe+import Data.Pipe+import Data.Pipe.ByteString+import System.IO+import Text.XML.Pipe++import Network.XmlPush++testPusher :: XmlPusher xp =>+	xp Handle -> NumOfHandle xp Handle -> PusherArgs xp -> IO ()+testPusher tp hs as = do+	xp <- (`asTypeOf` tp) <$> generate hs as+	void . forkIO . runPipe_ $ readFrom xp+		=$= convert (xmlString . (: []))+		=$= toHandle stdout+	runPipe_ $ fromHandle stdin+		=$= xmlEvent+		=$= convert fromJust+		=$= xmlNode []+		=$= writeTo xp

+ examples/TestSimple.hs view

@@ -0,0 +1,25 @@+{-# LANGUAGE ScopedTypeVariables #-}++module TestSimple (testSimple) where++import Control.Monad+import Control.Concurrent+import Data.Maybe+import Data.Pipe+import Data.Pipe.ByteString+import System.IO+import Text.XML.Pipe+import Network.XmlPush+import Network.XmlPush.Simple++testSimple :: Handle -> IO ()+testSimple h = do+	(sp :: SimplePusher Handle) <- generate (One h) ()+	void . forkIO . runPipe_ $ readFrom sp+		=$= convert (xmlString . (: []))+		=$= toHandle stdout+	runPipe_ $ fromHandle stdin+		=$= xmlEvent+		=$= convert fromJust+		=$= xmlNode []+		=$= writeTo sp

+ examples/httpPullCl.hs view

@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}++import System.IO+import Text.XML.Pipe+import Network++import Network.XmlPush.HttpPull.Client+import TestPusher++main :: IO ()+main = do+	h <- connectTo "localhost" $ PortNumber 80+	testPusher (undefined :: HttpPullCl Handle) (One h)+		(HttpPullClArgs "localhost" 80 "/" gtPth+			(XmlNode (nullQ "poll") [] [] []) pendingQ drtn)++pendingQ :: XmlNode -> Bool+pendingQ (XmlNode (_, "nothing") _ [] []) = False+pendingQ _ = True++drtn :: XmlNode -> Maybe Int+drtn (XmlNode (_, "slow") _ [] []) = Just 20000000+drtn (XmlNode (_, "medium") _ [] []) = Just 10000000+drtn (XmlNode (_, "fast") _ [] []) = Just 5000000+drtn (XmlNode (_, "very_fast") _ [] []) = Just 1000000+drtn (XmlNode (_, "fastest") _ [] []) = Just 100000+drtn _ = Nothing++gtPth :: XmlNode -> FilePath+gtPth (XmlNode (_, "father") _ [] []) = "family"+gtPth (XmlNode (_, "mother") _ [] []) = "family"+gtPth (XmlNode (_, "children") _ [] []) = "family"+gtPth _ = "others"

+ examples/httpPullSv.hs view

@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad+import Control.Concurrent+import System.IO+import Text.XML.Pipe+import Network++import Network.XmlPush.HttpPull.Server+import TestPusher++main :: IO ()+main = do+	soc <- listenOn $ PortNumber 80+	forever $ do+		(h, _, _) <- accept soc+		void . forkIO $ testPusher+			(undefined :: HttpPullSv Handle) (One h)+			(HttpPullSvArgs isPll endPoll)++isPll :: XmlNode -> Bool+isPll (XmlNode (_, "poll") _ _ _) = True+isPll _ = False++endPoll :: XmlNode+endPoll = XmlNode (nullQ "nothing") [] [] []

+ examples/httpPullTlsCl.hs view

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++import System.IO+import Text.XML.Pipe+import Network+import Network.PeyoTLS.ReadFile++import Network.XmlPush.HttpPull.Tls.Client+import TestPusher++main :: IO ()+main = do+	h <- connectTo "localhost" $ PortNumber 443+	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 drtn,+		TlsArgs "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]+		)++pendingQ :: XmlNode -> Bool+pendingQ (XmlNode (_, "nothing") _ [] []) = False+pendingQ _ = True++drtn :: XmlNode -> Maybe Int+drtn (XmlNode (_, "slow") _ [] []) = Just 20000000+drtn (XmlNode (_, "medium") _ [] []) = Just 10000000+drtn (XmlNode (_, "fast") _ [] []) = Just 5000000+drtn (XmlNode (_, "very_fast") _ [] []) = Just 1000000+drtn (XmlNode (_, "fastest") _ [] []) = Just 100000+drtn _ = Nothing++gtPth :: XmlNode -> FilePath+gtPth (XmlNode (_, "father") _ [] []) = "family"+gtPth _ = "others"

+ examples/httpPullTlsSv.hs view

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad+import Control.Concurrent+import System.IO+import Text.XML.Pipe+import Network+import Network.PeyoTLS.ReadFile++import Network.XmlPush.HttpPull.Tls.Server+import TestPusher++import qualified Data.ByteString.Char8 as BSC++main :: IO ()+main = do+	soc <- listenOn $ PortNumber 443+	ca <- readCertificateStore ["certs/cacert.sample_pem"]+	k <- readKey "certs/localhost.sample_key"+	c <- readCertificateChain ["certs/localhost.sample_crt"]+	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)])++isPll :: XmlNode -> Bool+isPll (XmlNode (_, "poll") _ _ _) = True+isPll _ = False++endPoll :: XmlNode+endPoll = XmlNode (nullQ "nothing") [] [] []++gtNm :: XmlNode -> Maybe String+gtNm (XmlNode (_, "name") _ _ [XmlCharData n]) = Just $ BSC.unpack n+gtNm _ = Nothing

+ examples/httpPushE.hs view

@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++import System.IO+import Text.XML.Pipe+import Network++import Network.XmlPush.HttpPush+import TestPusher++main :: IO ()+main = do+	ch <- connectTo "localhost" $ PortNumber 80+	soc <- listenOn $ PortNumber 8080+	(sh, _, _) <- accept soc+	testPusher (undefined :: HttpPush Handle) (Two ch sh)+		(HttpPushArgs "localhost" 80 "/" gtPth wntRspns)++wntRspns :: XmlNode -> Bool+wntRspns (XmlNode (_, "monologue") _ [] []) = False+wntRspns _ = True++gtPth :: XmlNode -> FilePath+gtPth (XmlNode (_, "father") _ [] []) = "family"+gtPth _ = "others"

+ examples/httpPushT.hs view

@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad+import System.IO+import Text.XML.Pipe+import Network++import Network.XmlPush.HttpPush+import TestPusher++main :: IO ()+main = do+	soc <- listenOn $ PortNumber 80+	forever  $ do+		(sh, _, _) <- accept soc+		ch <- connectTo "localhost" $ PortNumber 8080+		testPusher (undefined :: HttpPush Handle) (Two ch sh)+			(HttpPushArgs "localhost" 8080 "/" gtPth wntRspns)++wntRspns :: XmlNode -> Bool+wntRspns (XmlNode (_, "monologue") _ [] []) = False+wntRspns _ = True++gtPth :: XmlNode -> FilePath+gtPth (XmlNode (_, "father") _ [] []) = "family"+gtPth _ = "others"

+ examples/httpPushTlsE.hs view

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++import System.IO+import Text.XML.Pipe+import Network+import Network.PeyoTLS.ReadFile+import Network.XmlPush.HttpPush.Tls++import qualified Data.ByteString.Char8 as BSC++import TestPusher++main :: IO ()+main = do+	ca <- readCertificateStore ["certs/cacert.sample_pem"]+	k' <- readKey "certs/yoshikuni.sample_key"+	c' <- readCertificateChain ["certs/yoshikuni.sample_crt"]+	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')] )++wntRspns :: XmlNode -> Bool+wntRspns (XmlNode (_, "monologue") _ [] []) = False+wntRspns _ = True++gtPth :: XmlNode -> FilePath+gtPth (XmlNode (_, "father") _ [] []) = "family"+gtPth _ = "others"++gtNm :: XmlNode -> Maybe String+gtNm (XmlNode (_, "name") _ _ [XmlCharData n]) = Just $ BSC.unpack n+gtNm _ = Nothing

+ examples/httpPushTlsT.hs view

@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad+import System.IO+import Text.XML.Pipe+import Network+import Network.XmlPush.HttpPush.Tls+import Network.PeyoTLS.ReadFile++import qualified Data.ByteString.Char8 as BSC++import TestPusher++main :: IO ()+main = do+	soc <- listenOn $ PortNumber 80+	ca <- readCertificateStore ["certs/cacert.sample_pem"]+	k' <- readKey "certs/localhost.sample_key"+	c' <- readCertificateChain ["certs/localhost.sample_crt"]+	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')] )++wntRspns :: XmlNode -> Bool+wntRspns (XmlNode (_, "monologue") _ [] []) = False+wntRspns _ = True++gtPth :: XmlNode -> FilePath+gtPth (XmlNode (_, "father") _ [] []) = "family"+gtPth _ = "others"++gtNm :: XmlNode -> Maybe String+gtNm (XmlNode (_, "name") _ _ [XmlCharData n]) = Just $ BSC.unpack n+gtNm _ = Nothing

+ examples/simple.hs view

@@ -0,0 +1,9 @@+import TestPusher+import FilePusher+import System.IO++main :: IO ()+main = testPusher+	(undefined :: SimplePusher Handle)+	Zero+	("xml/read.xml", "tmp/write.xml")

+ examples/simpleClient.hs view

@@ -0,0 +1,5 @@+import Network+import TestSimple++main :: IO ()+main = testSimple =<< connectTo "localhost" (PortNumber 54492)

+ examples/simpleServer.hs view

@@ -0,0 +1,12 @@+import Control.Monad+import Control.Concurrent+import Network++import TestSimple++main :: IO ()+main = forever . (void . forkIO . testSimple . fst3 =<<) . accept+	=<< listenOn (PortNumber 54492)++fst3 :: (a, b, c) -> a+fst3 (x, _, _) = x

+ examples/xmpp.hs view

@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative+import System.IO+import System.Environment+import Text.XML.Pipe+import Network+import Network.XMPiPe.Core.C2S.Client++import qualified Data.ByteString.Char8 as BSC++import Network.XmlPush+import Network.XmlPush.Xmpp+import TestPusher++main :: IO ()+main = do+	me : ps : you : _ <- map BSC.pack <$> getArgs+	h <- connectTo "localhost" $ PortNumber 5222+	testPusher (undefined :: Xmpp Handle) (One h)+		(XmppArgs ["SCRAM-SHA-1", "DIGEST-MD5"]+			(toJid me) ps (toJid you) iNdRspns wntRspns)++wntRspns :: XmlNode -> Bool+wntRspns (XmlNode (_, "monologue") _ [] []) = False+wntRspns (XmlNode (_, "message") _ [] []) = False+wntRspns _ = True++iNdRspns :: XmlNode -> Bool+iNdRspns (XmlNode (_, "message") _ [] []) = False+iNdRspns _ = True

+ examples/xmppTls.hs view

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative+import System.IO+import System.Environment+import Text.XML.Pipe+import Network+import Network.XMPiPe.Core.C2S.Client+import Network.PeyoTLS.ReadFile++import qualified Data.ByteString.Char8 as BSC++import Network.XmlPush.Xmpp.Tls+import TestPusher++main :: IO ()+main = do+	me : ps : you : _ <- map BSC.pack <$> getArgs+	h <- connectTo "localhost" $ PortNumber 5222+	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)] )++wntRspns :: XmlNode -> Bool+wntRspns (XmlNode (_, "monologue") _ [] []) = False+wntRspns (XmlNode (_, "message") _ [] []) = False+wntRspns _ = True++iNdRspns :: XmlNode -> Bool+iNdRspns (XmlNode (_, "message") _ [] []) = False+iNdRspns _ = True

+ src/Network/XmlPush.hs view

@@ -0,0 +1,28 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, PackageImports #-}++module Network.XmlPush (XmlPusher(..), Zero(..), One(..), Two(..)) where++import "monads-tf" Control.Monad.Error+import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.HandleLike+import Data.Pipe+import Text.XML.Pipe+import Network.PeyoTLS.Client++class XmlPusher xp where+	type NumOfHandle 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)+	readFrom :: (HandleLike h, MonadBase IO (HandleMonad h)) =>+		xp h -> Pipe () XmlNode (HandleMonad h) ()+	writeTo :: (HandleLike h, MonadBase IO (HandleMonad h)) =>+		xp h -> Pipe XmlNode () (HandleMonad h) ()++data Zero a = Zero deriving Show+data One a = One a deriving Show+data Two a = Two a a deriving Show

+ src/Network/XmlPush/HttpPull/Client.hs view

@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}++module Network.XmlPush.HttpPull.Client (HttpPullCl, HttpPullClArgs(..)) where++import Prelude hiding (filter)++import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent.STM+import Data.HandleLike+import Data.Pipe+import Data.Pipe.TChan+import Text.XML.Pipe++import Network.XmlPush+import Network.XmlPush.HttpPull.Client.Common++data HttpPullCl h = HttpPullCl+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++instance XmlPusher HttpPullCl where+	type NumOfHandle HttpPullCl = One+	type PusherArgs HttpPullCl = HttpPullClArgs+	generate = makeHttpPull+	readFrom (HttpPullCl r _) = r+	writeTo (HttpPullCl _ w) = w++makeHttpPull :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	One h -> HttpPullClArgs -> HandleMonad h (HttpPullCl h)+makeHttpPull (One h) (HttpPullClArgs hn pn fp gp pl ip gdr) = do+	dr <- liftBase . atomically $ newTVar Nothing+	(inc, otc) <- talkC h hn pn fp gp pl ip dr gdr+	return $ HttpPullCl (fromTChan inc) (toTChan otc)

+ src/Network/XmlPush/HttpPull/Client/Common.hs view

@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleContexts, PackageImports #-}++module Network.XmlPush.HttpPull.Client.Common (+	HttpPullClArgs(..),+	talkC,+	) where++import Control.Monad+import "monads-tf" Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent hiding (yield)+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.TChan+import System.IO+import Text.XML.Pipe+import Network.TigHTTP.Client+import Network.TigHTTP.Types++import qualified Data.ByteString.Lazy as LBS++data HttpPullClArgs = HttpPullClArgs {+	hostName :: String,+	portNumber :: Int,+	basePath :: FilePath,+	getPath :: XmlNode -> FilePath,+	poll :: XmlNode,+	isPending :: XmlNode -> Bool,+	getDuration :: XmlNode -> Maybe Int+	}++talkC :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	h -> String -> Int -> FilePath -> (XmlNode -> FilePath) ->+	XmlNode -> (XmlNode -> Bool) ->+	TVar (Maybe Int) -> (XmlNode -> Maybe Int) ->+	HandleMonad h (TChan XmlNode, TChan XmlNode)+talkC h addr pn pth gp pl ip dr gdr = do+	lock <- liftBase $ atomically newTChan+	liftBase . atomically $ writeTChan lock ()+	inc <- liftBase $ atomically newTChan+	inc' <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	otc' <- liftBase $ atomically newTChan+	void . liftBaseDiscard forkIO . runPipe_ $ fromTChan otc+		=$= conversation lock h addr pn pth gp dr gdr+		=$= toTChan inc+	void . liftBaseDiscard forkIO . runPipe_ $ fromTChan otc'+		=$= conversation lock h addr pn pth gp dr gdr+		=$= toTChan inc'+	void . liftBaseDiscard forkIO . forever $ do+		d <- liftBase . atomically $ do+			md <- readTVar dr+			case md of+				Just d -> return d+				_ -> retry+		liftBase $ threadDelay d+		liftBase $ polling pl ip inc' inc otc'+	return (inc, otc)++conversation :: (HandleLike h, MonadBase IO (HandleMonad h)) =>+	TChan () -> h -> String -> Int ->+	FilePath -> (XmlNode -> FilePath) ->+	TVar (Maybe a) -> (XmlNode -> Maybe a) ->+	Pipe XmlNode XmlNode (HandleMonad h) ()+conversation lock h addr pn pth gp dr gdr =+	talk lock h addr pn pth gp =$= setDuration dr gdr++setDuration :: MonadBase IO m => TVar (Maybe a) -> (o -> Maybe a) -> Pipe o o m ()+setDuration dr gdr = (await >>=) . maybe (return ()) $ \n -> case gdr n of+	Just d -> do+		lift . liftBase . atomically $ writeTVar dr (Just d)+		yield n >> setDuration dr gdr+	_ -> yield n >> setDuration dr gdr++polling :: XmlNode -> (XmlNode -> Bool) ->+	TChan XmlNode -> TChan XmlNode -> TChan XmlNode -> IO ()+polling pl ip i i' o = do+	atomically $ writeTChan o pl+	r <- atomically $ readTChan i+	hFlush stdout+	when (ip r) $ atomically (writeTChan i' r) >> polling pl ip i i' o++talk :: (MonadBase IO (HandleMonad h), HandleLike h) =>+	TChan () -> h -> String -> Int ->+	FilePath -> (XmlNode -> FilePath) ->+	Pipe XmlNode XmlNode (HandleMonad h) ()+talk lock h addr pn pth gp = (await >>=) . maybe (return ()) $ \n -> do+	let m = LBS.fromChunks [xmlString [n]]+	lift . liftBase . atomically $ readTChan lock+	r <- lift . request h $ post addr pn (pth ++ "/" ++ gp n) (Nothing, m)+	void $ return ()+		=$= responseBody r+		=$= xmlEvent+		=$= convert fromJust+		=$= xmlNode []+	lift . liftBase . atomically $ writeTChan lock ()+	talk lock h addr pn pth gp

+ src/Network/XmlPush/HttpPull/Server.hs view

@@ -0,0 +1,31 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}++module Network.XmlPush.HttpPull.Server (HttpPullSv, HttpPullSvArgs(..)) where++import Prelude hiding (filter)++import Control.Monad.Trans.Control+import Data.HandleLike+import Data.Pipe+import Data.Pipe.TChan+import Text.XML.Pipe++import Network.XmlPush+import Network.XmlPush.HttpPull.Server.Common++data HttpPullSv h = HttpPullSv+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++instance XmlPusher HttpPullSv where+	type NumOfHandle HttpPullSv = One+	type PusherArgs HttpPullSv = HttpPullSvArgs+	generate = makeHttpPull+	readFrom (HttpPullSv r _) = r+	writeTo (HttpPullSv _ w) = w++makeHttpPull :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	One h -> HttpPullSvArgs -> 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

@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleContexts, PackageImports #-}++module Network.XmlPush.HttpPull.Server.Common (HttpPullSvArgs(..), runXml) where++import "monads-tf" Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent hiding (yield)+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.List+import Data.Pipe.TChan+import Text.XML.Pipe+import Network.TigHTTP.Server+import Network.TigHTTP.Types++import qualified Data.ByteString.Lazy as LBS++data HttpPullSvArgs = HttpPullSvArgs {+	isPoll :: XmlNode -> Bool,+	noPending :: XmlNode+	}++runXml :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	h -> (XmlNode -> Bool) -> XmlNode ->+	Pipe XmlNode XmlNode (HandleMonad h) () ->+	HandleMonad h (TChan XmlNode, TChan XmlNode)+runXml h ip ep cn = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	_ <- liftBaseDiscard forkIO . runPipe_ $ talk h ip ep inc otc cn+	return (inc, otc)++talk :: (HandleLike h, MonadBase IO (HandleMonad h)) =>+	h -> (XmlNode -> Bool) -> XmlNode ->+	TChan XmlNode -> TChan XmlNode -> Pipe XmlNode XmlNode (HandleMonad h) () ->+	Pipe () () (HandleMonad h) ()+talk h ip ep inc otc cn = do+	r <- lift $ getRequest h+	lift . liftBase . print $ requestPath r+	rns <- requestBody r+		=$= xmlEvent+		=$= convert fromJust+		=$= xmlNode []+		=$= cn+		=$= toList+	if case rns of [n] -> ip n; _ -> False+	then (flushOr otc ep =$=) . (await >>=) . maybe (return ()) $ \n ->+		lift . putResponse h . responseP $ LBS.fromChunks [xmlString [n]]+	else do	mapM_ yield rns =$= toTChan inc+		(fromTChan otc =$=) . (await >>=) . maybe (return ()) $ \n ->+			lift . putResponse h . responseP+				$ LBS.fromChunks [xmlString [n]]+	talk h ip ep inc otc cn++responseP :: (HandleLike h, MonadBase IO (HandleMonad h)) =>+	LBS.ByteString -> Response Pipe h+responseP = response++flushOr :: MonadBase IO m => TChan XmlNode -> XmlNode -> Pipe () XmlNode m ()+flushOr c ep = do+	e <- lift . liftBase . atomically $ isEmptyTChan c+	lift . liftBase $ print e+	if e then yield ep else do+		po <- lift . liftBase . atomically $ readTChan c+		yield po

+ src/Network/XmlPush/HttpPull/Tls/Client.hs view

@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, ScopedTypeVariables,+	PackageImports #-}++module Network.XmlPush.HttpPull.Tls.Client (+	HttpPullTlsCl, HttpPullClArgs(..), TlsArgs(..)) where++import Prelude hiding (filter)++import Control.Applicative+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent.STM+import Data.HandleLike+import Data.Pipe+import Data.Pipe.TChan+import Text.XML.Pipe+import Network.PeyoTLS.TChan.Client+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++import Network.XmlPush+import Network.XmlPush.HttpPull.Client.Common+import Network.XmlPush.Tls.Client++data HttpPullTlsCl h = HttpPullTlsCl+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++instance XmlPusher HttpPullTlsCl where+	type NumOfHandle HttpPullTlsCl = One+	type PusherArgs HttpPullTlsCl = (HttpPullClArgs, TlsArgs)+	generate = makeHttpPull+	readFrom (HttpPullTlsCl r _) = r+	writeTo (HttpPullTlsCl _ w) = w++data TChanHandle = TChanHandle (TChan BS.ByteString) (TChan BS.ByteString)++instance HandleLike TChanHandle where+	type HandleMonad TChanHandle = IO+	hlPut (TChanHandle _ o) = atomically . writeTChan o+	hlGet (TChanHandle i _) = atomically . getBS i+	hlGetLine (TChanHandle i _) = atomically $ bsGetLine i+	hlGetContent (TChanHandle i _) = atomically $ readTChan i+	hlDebug _ "critical" = BSC.putStrLn+	hlDebug _ _ = const $ return ()+	hlClose = const $ return ()++bsGetLine :: TChan BS.ByteString -> STM BS.ByteString+bsGetLine c = do+	bs <- readTChan c+	case BSC.span (/= '\n') bs of+		(_, "") -> (bs `BS.append`) <$> bsGetLine c+		(l, r) -> do+			unGetTChan c $ BS.tail r+			return $ chomp l++chomp :: BS.ByteString -> BS.ByteString+chomp bs = case (BSC.null bs, BSC.init bs, BSC.last bs) of+	(True, _, _) -> bs+	(_, ln, '\r') -> ln+	_ -> bs++getBS :: TChan BS.ByteString -> Int -> STM BS.ByteString+getBS _ 0 = return ""+getBS i n = do+	bs <- readTChan i+	if BS.length bs > n+	then do	let (rtn, rst) = BS.splitAt n bs+		unGetTChan i rst+		return rtn+	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 gd, TlsArgs dn cs ca kcs) = do+	dr <- liftBase . atomically $ newTVar Nothing+	(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+	return $ HttpPullTlsCl (fromTChan inc) (toTChan otc)

+ src/Network/XmlPush/HttpPull/Tls/Server.hs view

@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts,+	PackageImports #-}++module Network.XmlPush.HttpPull.Tls.Server (+	HttpPullTlsSv, HttpPullSvArgs(..), TlsArgs(..) ) where++import Prelude hiding (filter)++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.HandleLike+import Data.Pipe+import Data.Pipe.TChan+import Text.XML.Pipe+import Network.PeyoTLS.Server+import "crypto-random" Crypto.Random++import Network.XmlPush+import Network.XmlPush.HttpPull.Server.Common+import Network.XmlPush.Tls.Server++data HttpPullTlsSv h = HttpPullTlsSv+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++instance XmlPusher HttpPullTlsSv where+	type NumOfHandle HttpPullTlsSv = One+	type PusherArgs HttpPullTlsSv = (HttpPullSvArgs, TlsArgs)+	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+	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG)+	(inc, otc) <- (`run` g) $ do+		t <- open h cs kcs mca+		runXml t ip ep $ checkName t gn+	return $ HttpPullTlsSv (fromTChan inc) (toTChan otc)++checkName :: HandleLike h => TlsHandle h g -> (XmlNode -> Maybe String) ->+	Pipe XmlNode XmlNode (TlsM h g) ()+checkName t gn = (await >>=) . maybe (return ()) $ \n -> do+	ok <- maybe (return True) (lift . svCheckName t) $ gn n+	unless ok $ error "checkName: bad client name"+	yield n+	checkName t gn++svCheckName :: HandleLike h => TlsHandle h g -> String -> TlsM h g Bool+svCheckName t n = do+	ns <- getNames t+	return $ n `elem` ns

+ src/Network/XmlPush/HttpPush.hs view

@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings, TupleSections, TypeFamilies, FlexibleContexts,+	PackageImports #-}++module Network.XmlPush.HttpPush (HttpPush, HttpPushArgs(..)) where++import Prelude hiding (filter)++import Control.Monad+import "monads-tf" Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent hiding (yield)+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.Flow+import Data.Pipe.TChan+import Text.XML.Pipe+import Network.TigHTTP.Server++import qualified Data.ByteString.Lazy as LBS++import Network.XmlPush+import Network.XmlPush.HttpPush.Common++data HttpPush h = HttpPush {+	needReply :: TVar Bool,+	clientReadChan :: TChan (XmlNode, Bool),+	clientWriteChan :: TChan (Maybe XmlNode),+	serverReadChan :: TChan (XmlNode, Bool),+	serverWriteChan :: TChan (Maybe XmlNode) }++instance XmlPusher HttpPush where+	type NumOfHandle HttpPush = Two+	type PusherArgs HttpPush = HttpPushArgs+	generate (Two ch sh) = makeHttpPush ch sh+	readFrom hp = fromTChans [clientReadChan hp, serverReadChan hp] =$=+		setNeedReply (needReply hp)+	writeTo hp = (convert ((() ,) . Just) =$=) . toTChansM $ do+		nr <- liftBase . atomically . readTVar $ needReply hp+		liftBase . atomically $ writeTVar (needReply hp) False+		return [+			(const nr, serverWriteChan hp),+			(const True, clientWriteChan hp) ]++makeHttpPush :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	h -> h -> HttpPushArgs -> 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+	(si, so) <- talk wr sh+	return $ HttpPush v ci co si so++clientC :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	h -> String -> Int -> FilePath -> (XmlNode -> FilePath) ->+	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))+clientC h hn pn pt gp = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	void . liftBaseDiscard forkIO . runPipe_ $ fromTChan otc+		=$= filter isJust+		=$= convert fromJust+		=$= clientLoop h hn pn pt gp+		=$= convert (, False)+		=$= toTChan inc+	return (inc, otc)++talk :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	(XmlNode -> Bool) ->+	h -> HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))+talk wr h = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	void . liftBaseDiscard forkIO . runPipe_ . forever $ do+		req <- lift $ getRequest h+		requestBody req+			=$= xmlEvent+			=$= convert fromJust+			=$= xmlNode []+			=$= checkReply wr otc+			=$= toTChan inc+		fromTChan otc =$= await >>= maybe (return ()) (\mn ->+			lift . putResponse h . responseP $ case mn of+				Just n -> LBS.fromChunks [xmlString [n]]+				_ -> "")+	return (inc, otc)

+ src/Network/XmlPush/HttpPush/Common.hs view

@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleContexts, PackageImports #-}++module Network.XmlPush.HttpPush.Common (+	HttpPushArgs(..),+	setNeedReply,+	clientLoop,+	checkReply,+	responseP,+	) where++import Control.Monad+import "monads-tf" Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Text.XML.Pipe+import Network.TigHTTP.Client+import Network.TigHTTP.Server+import Network.TigHTTP.Types++import qualified Data.ByteString.Lazy as LBS++data HttpPushArgs = HttpPushArgs {+	hostName :: String,+	portNumber :: Int,+	basePath :: FilePath,+	getPath :: XmlNode -> FilePath,+	youNeedResponse :: XmlNode -> Bool+	}++setNeedReply :: MonadBase IO m => TVar Bool -> Pipe (a, Bool) a m ()+setNeedReply nr = await >>= maybe (return ()) (\(x, b) ->+	lift (liftBase . atomically $ writeTVar nr b) >> yield x >> setNeedReply nr)++clientLoop :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) =>+	h -> String -> Int -> FilePath -> (XmlNode -> FilePath) ->+	Pipe XmlNode XmlNode (HandleMonad h) ()+clientLoop h hn pn pt gp = (await >>=) . maybe (return ()) $ \n -> do+	r <- lift . request h $ post hn pn (pt ++ "/" ++ gp n)+		(Nothing, LBS.fromChunks [xmlString [n]])+	return ()+		=$= responseBody r+		=$= xmlEvent+		=$= convert fromJust+		=$= void (xmlNode [])+	clientLoop h hn pn pt gp++checkReply :: MonadBase IO m => (XmlNode -> Bool) -> TChan (Maybe XmlNode) ->+	Pipe XmlNode (XmlNode, Bool) m ()+checkReply wr o = (await >>=) . maybe (return ()) $ \n ->+	if wr n+	then yield (n, True) >> checkReply wr o+	else do	lift (liftBase . atomically $ writeTChan o Nothing)+		yield (n, False)+		checkReply wr o++responseP :: HandleLike h => LBS.ByteString -> Response Pipe h+responseP = response

+ src/Network/XmlPush/HttpPush/Tls.hs view

@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables,+	TypeFamilies, FlexibleContexts,+	PackageImports #-}++module Network.XmlPush.HttpPush.Tls (+	HttpPushTls, HttpPushArgs(..),+	TlsArgsCl, tlsArgsCl, TlsArgsSv, tlsArgsSv) where++import Prelude hiding (filter)++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent hiding (yield)+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.Flow+import Data.Pipe.TChan+import Data.X509+import Data.X509.CertificateStore+import Text.XML.Pipe+import Network.TigHTTP.Server+import Network.PeyoTLS.ReadFile+import Network.PeyoTLS.Client (ValidateHandle)+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Lazy as LBS+import qualified Network.PeyoTLS.Client as Cl+import qualified Network.PeyoTLS.Server as Sv++import Network.XmlPush+import Network.XmlPush.HttpPush.Common+import Network.XmlPush.Tls.Client as TC+import Network.XmlPush.Tls.Server as TS++type TlsArgsCl = TC.TlsArgs++tlsArgsCl :: String -> [Cl.CipherSuite] -> CertificateStore ->+	[(CertSecretKey, CertificateChain)] -> TlsArgsCl+tlsArgsCl = TC.TlsArgs++type TlsArgsSv = TS.TlsArgs++tlsArgsSv :: (XmlNode -> Maybe String) -> [Cl.CipherSuite] ->+	Maybe CertificateStore -> [(CertSecretKey, CertificateChain)] -> TlsArgsSv+tlsArgsSv = TS.TlsArgs++data HttpPushTls h = HttpPushTls {+	needReply :: TVar Bool,+	clientReadChan :: TChan (XmlNode, Bool),+	clientWriteChan :: TChan (Maybe XmlNode),+	serverReadChan :: TChan (XmlNode, Bool),+	serverWriteChan :: TChan (Maybe XmlNode) }++instance XmlPusher HttpPushTls where+	type NumOfHandle HttpPushTls = Two+	type PusherArgs HttpPushTls = (HttpPushArgs, TC.TlsArgs, TS.TlsArgs)+	generate (Two ch sh) = makeHttpPushTls ch sh+	readFrom hp = fromTChans [clientReadChan hp, serverReadChan hp] =$=+		setNeedReply (needReply hp)+	writeTo hp = (convert (((), ) . Just) =$=) . toTChansM $ do+		nr <- liftBase . atomically . readTVar $ needReply hp+		liftBase . atomically $ writeTVar (needReply hp) False+		return [+			(const nr, serverWriteChan hp),+			(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+	when (dn /= hn) $ error "makeHttpPushTls: conflicted domain name"+	v <- liftBase . atomically $ newTVar False+	(ci, co) <- clientC ch hn pn pt gp cs ca kcs+	(si, so) <- talk wr sh gn cs' mca' kcs'+	return $ HttpPushTls v ci co si so++clientC :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>+	h -> String -> Int -> FilePath -> (XmlNode -> FilePath) ->+	[Cl.CipherSuite] -> CertificateStore ->+	[(CertSecretKey, CertificateChain)] ->+	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))+clientC h hn pn pt gp cs ca kcs = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool+	void . liftBaseDiscard forkIO . (`Cl.run` g) $ do+		t <- Cl.open' h hn cs kcs ca+		runPipe_ $ fromTChan otc+			=$= filter isJust+			=$= convert fromJust+			=$= clientLoop t hn pn pt gp+			=$= convert (, False)+			=$= toTChan inc+	return (inc, otc)++talk :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>+	(XmlNode -> Bool) -> h ->+	(XmlNode -> Maybe String) -> [Sv.CipherSuite] ->+	Maybe CertificateStore -> [(CertSecretKey, CertificateChain)] ->+	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))+talk wr h gn cs mca kcs = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG)+	void . liftBaseDiscard forkIO . (`Sv.run` g) $ do+		t <- Sv.open h cs kcs mca+		runPipe_ . forever $ do+			req <- lift $ getRequest t+			requestBody req+				=$= xmlEvent+				=$= convert fromJust+				=$= xmlNode []+				=$= checkName t gn+				=$= checkReply wr otc+				=$= toTChan inc+			fromTChan otc =$= await >>= maybe (return ()) (\mn ->+				lift . putResponse t . responseP $ case mn of+					Just n -> LBS.fromChunks [xmlString [n]]+					_ -> "")+	return (inc, otc)++checkName :: HandleLike h => Sv.TlsHandle h g -> (XmlNode -> Maybe String) ->+	Pipe XmlNode XmlNode (Sv.TlsM h g) ()+checkName t gn = (await >>=) . maybe (return ()) $ \n -> do+	ok <- maybe (return True) (lift . svCheckName t) $ gn n+	unless ok $ error "checkName: bad client name"+	yield n+	checkName t gn++svCheckName :: HandleLike h => Sv.TlsHandle h g -> String -> Sv.TlsM h g Bool+svCheckName t n = do+	ns <- Sv.getNames t+	return $ n `elem` ns

+ src/Network/XmlPush/Simple.hs view

@@ -0,0 +1,42 @@+{-# LANGUAGE TypeFamilies, PackageImports #-}++module Network.XmlPush.Simple (SimplePusher) where++import "monads-tf" Control.Monad.Trans+import Control.Monad+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Text.XML.Pipe+import Network.XmlPush++import qualified Data.ByteString as BS++data SimplePusher h = SimplePusher+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++instance XmlPusher SimplePusher where+	type NumOfHandle SimplePusher = One+	type PusherArgs SimplePusher = ()+	generate (One h) _ = simplePusher h+	readFrom (SimplePusher r _) = r+	writeTo (SimplePusher _ w) = w++simplePusher :: HandleLike h => h -> HandleMonad h (SimplePusher h)+simplePusher h = return $ SimplePusher (readXml h) (writeXml h)++readXml :: HandleLike h => h -> Pipe () XmlNode (HandleMonad h) ()+readXml h = fromHandleLike h+	=$= xmlEvent+	=$= convert fromJust+	=$= void (xmlNode [])++writeXml :: HandleLike h => h -> Pipe XmlNode () (HandleMonad h) ()+writeXml h = convert (xmlString . (: [])) =$= toHandleLike h++fromHandleLike :: HandleLike h => h -> Pipe () BS.ByteString (HandleMonad h) ()+fromHandleLike h = lift (hlGetContent h) >>= yield >> fromHandleLike h++toHandleLike :: HandleLike h => h -> Pipe BS.ByteString () (HandleMonad h) ()+toHandleLike h = await >>= maybe (return ()) ((>> toHandleLike h) . lift . hlPut h)

+ src/Network/XmlPush/Tls/Client.hs view

@@ -0,0 +1,14 @@+module Network.XmlPush.Tls.Client (+	TlsArgs(..)+	) where++import Data.X509+import Data.X509.CertificateStore+import Network.PeyoTLS.Client++data TlsArgs = TlsArgs {+	serverName :: String,+	cipherSuites :: [CipherSuite],+	certificateAuthorities :: CertificateStore,+	keyChains :: [(CertSecretKey, CertificateChain)]+	}

+ src/Network/XmlPush/Tls/Server.hs view

@@ -0,0 +1,15 @@+module Network.XmlPush.Tls.Server (+	TlsArgs(..)+	) where++import Data.X509+import Data.X509.CertificateStore+import Network.PeyoTLS.Client+import Text.XML.Pipe++data TlsArgs = TlsArgs {+	getClientName :: XmlNode -> Maybe String,+	cipherSuites :: [CipherSuite],+	certificateAuthorities :: Maybe CertificateStore,+	keyChains :: [(CertSecretKey, CertificateChain)]+	}

+ src/Network/XmlPush/Xmpp.hs view

@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings,+	TypeFamilies, FlexibleContexts, ScopedTypeVariables,+	PackageImports #-}++module Network.XmlPush.Xmpp (Xmpp, XmppArgs(..)) where++import Prelude hiding (filter)++import Control.Applicative+import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Writer+import "monads-tf" Control.Monad.Error+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent hiding (yield)+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.Flow+import Data.Pipe.TChan+import Text.XML.Pipe+import Network.XMPiPe.Core.C2S.Client+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS++import Network.XmlPush+import Network.XmlPush.Xmpp.Common++data Xmpp h = Xmpp+	(XmlNode -> Bool)+	(TChan (Maybe BS.ByteString))+	(Pipe () Mpi (HandleMonad h) ())+	(TChan (Either BS.ByteString XmlNode))++instance XmlPusher Xmpp where+	type NumOfHandle Xmpp = One+	type PusherArgs Xmpp = XmppArgs+	generate = makeXmpp+	readFrom (Xmpp wr nr r wc) = r+		=$= pushId wr nr wc+		=$= convert fromMessage+		=$= filter isJust+		=$= convert fromJust+	writeTo (Xmpp _ _ _ w) = convert Right =$= toTChan w++makeXmpp :: (+	HandleLike h, MonadBaseControl IO (HandleMonad h),+	MonadError (HandleMonad h), Error (ErrorType (HandleMonad h))+	) => One h -> XmppArgs -> HandleMonad h (Xmpp h)+makeXmpp (One h) (XmppArgs ms me ps you inr wr) = do+	nr <- liftBase $ atomically newTChan+	wc <- liftBase $ atomically newTChan+	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool+	let	(cn, _g') = cprgGenerate 32 g+		(Jid un d (Just rsc)) = me+		ss = St [+			("username", un), ("authcid", un), ("password", ps),+			("cnonce", cn) ]+	void . (`evalStateT` ss) . runPipe $ fromHandleLike (THandle h)+		=$= sasl d ms+		=$= toHandleLike (THandle h)+	(Just ns, _fts) <- runWriterT . runPipe $ fromHandleLike (THandle h)+		=$= bind d rsc+		=@= toHandleLike (THandle h)+	runPipe_ $ yield (Presence tagsNull []) =$= output =$= toHandleLike h+	(>> return ()) . liftBaseDiscard forkIO . runPipe_ $ fromTChan wc+		=$= addRandom =$= makeResponse inr you nr =$= output =$= toHandleLike h+	let	r = fromHandleLike h =$= input ns+	return $ Xmpp wr nr r wc

+ src/Network/XmlPush/Xmpp/Common.hs view

@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings, KindSignatures,+	TypeFamilies, FlexibleContexts, UndecidableInstances,+	PackageImports #-}++module Network.XmlPush.Xmpp.Common (+	XmppArgs(..),+	pushId,+	fromMessage,+	addRandom,+	makeResponse,+	fromHandleLike, toHandleLike,+	St(..), THandle(..),+	) where++import Control.Applicative+import "monads-tf" Control.Monad.State+import Control.Monad.Base+import Control.Concurrent.STM+import Data.HandleLike+import Data.Pipe+import Data.UUID+import System.Random+import Text.XML.Pipe+import Network.XMPiPe.Core.C2S.Client+import Network.Sasl++import qualified Data.ByteString as BS++data XmppArgs = XmppArgs {+	mechanisms :: [BS.ByteString],+	myJid :: Jid, passowrd :: BS.ByteString,+	yourJid :: Jid,+	iNeedResponse :: XmlNode -> Bool,+	youNeedResponse :: XmlNode -> Bool+	}++pushId :: MonadBase IO m => (XmlNode -> Bool) -> TChan (Maybe BS.ByteString) ->+	TChan (Either BS.ByteString XmlNode) -> Pipe Mpi Mpi m ()+pushId wr nr wc = (await >>=) . maybe (return ()) $ \mpi -> case mpi of+	Iq Tags { tagType = Just "get", tagId = Just i } [n]+		| wr n -> do+			lift . liftBase . atomically . writeTChan nr $ Just i+			yield mpi >> pushId wr nr wc+		| otherwise -> do+			lift . liftBase . atomically . writeTChan wc $ Left i+			yield mpi >> pushId wr nr wc+	Iq Tags { tagType = Just "set", tagId = Just i } [n]+		| wr n -> do+			lift . liftBase . atomically . writeTChan nr $ Just i+			yield mpi >> pushId wr nr wc+		| otherwise -> do+			lift . liftBase . atomically . writeTChan wc $ Left i+			yield mpi >> pushId wr nr wc+	Message _ [n]+		| wr n -> do+			lift . liftBase . atomically $ writeTChan nr Nothing+			yield mpi >> pushId wr nr wc+		| otherwise -> yield mpi >> pushId wr nr wc+	_ -> yield mpi >> pushId wr nr wc++fromMessage :: Mpi -> Maybe XmlNode+fromMessage (Message _ts [n]) = Just n+fromMessage (Iq _ts [n]) = Just n+fromMessage _ = Nothing++addRandom :: (MonadBase IO m, Random r) => Pipe a (a, r) m ()+addRandom = (await >>=) . maybe (return ()) $ \x -> do+	r <- lift $ liftBase randomIO+	yield (x, r)+	addRandom++makeResponse :: MonadBase IO m =>+	(XmlNode -> Bool) -> Jid ->+	TChan (Maybe BS.ByteString) ->+	Pipe (Either BS.ByteString XmlNode, UUID) Mpi m ()+makeResponse inr you nr = (await >>=) . maybe (return ()) $ \(mn, r) -> do+	case mn of+		Left i | not $ BS.null i -> either (const $ return ()) yield $+			toResponse you mn (Just i) undefined+		_ -> do	e <- lift . liftBase . atomically $ isEmptyTChan nr+			uuid <- lift $ liftBase randomIO+			if e+			then either (const $ return ())+				(yield . makeIqMessage inr you r uuid) mn+			else do	i <- lift . liftBase . atomically $ readTChan nr+				either (const $ return ()) yield $+					toResponse you mn i uuid+	makeResponse inr you nr++makeIqMessage :: (XmlNode -> Bool) -> Jid -> UUID -> UUID -> XmlNode -> Mpi+makeIqMessage inr you r uuid n =+	if inr n then toIq you n r else toMessage you n uuid++toResponse ::+	Jid -> Either BS.ByteString XmlNode -> Maybe BS.ByteString -> UUID -> Either BS.ByteString Mpi+toResponse you mn (Just i) _ = case mn of+	Right n -> Right $+		Iq (tagsType "result") { tagId = Just i, tagTo = Just you } [n]+	_ -> Right $ Iq (tagsType "result") { tagId = Just i, tagTo = Just you } []+toResponse you mn _ uuid = flip (toMessage you) uuid <$> mn++toIq :: Jid -> XmlNode -> UUID -> Mpi+toIq you n r = Iq+	(tagsType "get") { tagId = Just $ toASCIIBytes r, tagTo = Just you } [n]++toMessage :: Jid -> XmlNode -> UUID -> Mpi+toMessage you n r = Message+	(tagsType "chat") { tagId = Just $ toASCIIBytes r, tagTo = Just you } [n]++fromHandleLike :: HandleLike h => h -> Pipe () BS.ByteString (HandleMonad h) ()+fromHandleLike h = lift (hlGetContent h) >>= yield >> fromHandleLike h++toHandleLike :: HandleLike h => h -> Pipe BS.ByteString () (HandleMonad h) ()+toHandleLike h = await >>= maybe (return ()) ((>> toHandleLike h) . lift . hlPut h)++data St = St [(BS.ByteString, BS.ByteString)]+instance SaslState St where getSaslState (St ss) = ss; putSaslState ss _ = St ss++data SHandle s h = SHandle h deriving Show++instance HandleLike h => HandleLike (SHandle s h) where+	type HandleMonad (SHandle s h) = StateT s (HandleMonad h)+	hlPut (SHandle h) = lift . hlPut h+	hlGet (SHandle h) = lift . hlGet h+	hlClose (SHandle h) = lift $ hlClose h++data THandle (t :: (* -> *) -> * -> *) h = THandle h deriving Show++instance (MonadTrans t, HandleLike h, Monad (t (HandleMonad h))) =>+	HandleLike (THandle t h) where+	type HandleMonad (THandle t h) = t (HandleMonad h)+	hlPut (THandle h) = lift . hlPut h+	hlGet (THandle h) = lift . hlGet h+	hlClose (THandle h) = lift $ hlClose h

+ src/Network/XmlPush/Xmpp/Tls.hs view

@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings,+	TypeFamilies, FlexibleContexts, ScopedTypeVariables,+	PackageImports #-}++module Network.XmlPush.Xmpp.Tls (XmppTls, XmppArgs(..), TlsArgs(..)) where++import Prelude hiding (filter)++import Control.Applicative+import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Writer+import "monads-tf" Control.Monad.Error+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent hiding (yield)+import Control.Concurrent.STM+import Data.Maybe+import Data.HandleLike+import Data.Pipe+import Data.Pipe.Flow+import Data.Pipe.TChan+import Text.XML.Pipe+import Network.XMPiPe.Core.C2S.Client+import Network.PeyoTLS.TChan.Client+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++import Network.XmlPush+import Network.XmlPush.Xmpp.Common+import Network.XmlPush.Tls.Client++data XmppTls h = XmppTls+	(XmlNode -> Bool)+	(TChan (Maybe BS.ByteString))+	(Pipe () Mpi (HandleMonad h) ())+	(TChan (Either BS.ByteString XmlNode))++instance XmlPusher XmppTls where+	type NumOfHandle XmppTls = One+	type PusherArgs XmppTls = (XmppArgs, TlsArgs)+	generate = makeXmppTls+	readFrom (XmppTls wr nr r wc) = r+		=$= pushId wr nr wc+		=$= convert fromMessage+		=$= filter isJust+		=$= convert fromJust+	writeTo (XmppTls _ _nr _ w) = convert Right =$= toTChan w++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+	nr <- liftBase $ atomically newTChan+	wc <- liftBase $ atomically newTChan+	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool+	let	(Jid un d (Just rsc)) = me+		(cn, g') = cprgGenerate 32 g+		ss = St [+			("username", un), ("authcid", un), ("password", ps),+			("cnonce", cn) ]+	runPipe_ $ fromHandleLike h =$= starttls (BSC.pack dn) =$= toHandleLike h+	(inc, otc) <- open' h dn cs kcs ca g'+	(`evalStateT` ss) . runPipe_ $ fromTChan inc =$= sasl d ms =$= toTChan otc+	(Just ns, _fts) <- runWriterT . runPipe $ fromTChan inc+		=$= bind d rsc+		=@= toTChan otc+	runPipe_ $ yield (Presence tagsNull []) =$= output =$= toTChan otc+	(>> return ()) . liftBaseDiscard forkIO . runPipe_ $ fromTChan wc+		=$= addRandom =$= makeResponse inr you nr =$= output =$= toTChan otc+	let	r = fromTChan inc =$= input ns+	return $ XmppTls wr nr r wc

+ xml-push.cabal view

@@ -0,0 +1,127 @@+build-type:	Simple+cabal-version:	>= 1.8++name:		xml-push+version:	0.0.0.0+stability:	Experimenmtal+author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>+homepage:	https://github.com/YoshikuniJujo/xml-push/wiki++license:	BSD3+license-file:	LICENSE++category:	Network+synopsis:	Push XML from/to client to/from server over XMPP or HTTP+description:+    examples/TestSimple.hs+    .+    extensions+    .+    * ScopedTypeVariables+    .+    > module TestSimple (testSimple) where+    >+    > import Control.Monad+    > import Control.Concurrent+    > import Data.Maybe+    > import Data.Pipe+    > import Data.Pipe.ByteString+    > import System.IO+    > import Text.XML.Pipe+    > import Network.XmlPush+    > import Network.XmlPush.Simple+    >+    > testSimple :: Handle -> IO ()+    > testSimple h = do+    > 	(sp :: SimplePusher Handle) <- generate (One h) ()+    > 	void . forkIO . runPipe_ $ readFrom sp+    > 		=$= convert (xmlString . (: []))+    > 		=$= toHandle stdout+    > 	runPipe_ $ fromHandle stdin+    > 		=$= xmlEvent+    > 		=$= convert fromJust+    > 		=$= xmlNode []+    > 		=$= writeTo sp+    .+    examples/simpleClient+    .+    > import Network+    > import TestSimple+    >+    > main :: IO ()+    > main = testSimple =<< connectTo "localhost" (PortNumber 54492)+    .+    examples/simpleServer+    .+    > import Control.Monad+    > import Control.Concurrent+    > import Network+    >+    > import TestSimple+    >+    > main :: IO ()+    > main = forever . (void . forkIO . testSimple . fst3 =<<) . accept+    > 	=<< listenOn (PortNumber 54492)+    >+    > fst3 :: (a, b, c) -> a+    > fst3 (x, _, _) = x+    .++extra-source-files:+    examples/simpleClient.hs+    examples/simpleServer.hs+    examples/TestSimple.hs+    examples/TestPusher.hs+    examples/FilePusher.hs+    examples/simple.hs+    examples/xmpp.hs+    examples/xmppTls.hs+    examples/httpPullCl.hs+    examples/httpPullSv.hs+    examples/httpPullTlsCl.hs+    examples/httpPullTlsSv.hs+    examples/httpPushT.hs+    examples/httpPushE.hs+    examples/httpPushTlsT.hs+    examples/httpPushTlsE.hs++data-files:+    certs/cacert.sample_pem+    certs/localhost.sample_key+    certs/localhost.sample_crt+    certs/yoshikuni.sample_key+    certs/yoshikuni.sample_crt++source-repository	head+    type:	git+    location:	git://github.com/YoshikuniJujo/xml-push.git++source-repository	this+    type:	git+    location:	git://github.com/YoshikuniJujo/xml-push.git+    tag:	xml-push-0.0.0.0++library+    hs-source-dirs:	src+    exposed-modules:+        Network.XmlPush, Network.XmlPush.Simple+        Network.XmlPush.Xmpp, Network.XmlPush.Xmpp.Tls+        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+    other-modules:+        Network.XmlPush.Tls.Client+        Network.XmlPush.Tls.Server+        Network.XmlPush.Xmpp.Common+        Network.XmlPush.HttpPull.Client.Common+        Network.XmlPush.HttpPull.Server.Common+        Network.XmlPush.HttpPush.Common+    build-depends:+        base == 4.*, peyotls == 0.1.*, simple-pipe == 0.0.*, xml-pipe == 0.0.*,+        handle-like == 0.1.*, monad-control == 0.3.*, transformers-base == 0.4.*,+        monads-tf == 0.1.*, bytestring == 0.10.*, xmpipe == 0.0.*, sasl == 0.0.*,+        random == 1.0.*, uuid == 1.3.*, stm == 2.4.*, crypto-random == 0.0.*,+        x509 == 1.4.*, x509-store == 1.4.*, tighttp == 0.0.*+    ghc-options:	-Wall+    extensions:		DoAndIfThenElse