diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,1 @@ +import Distribution.Simple; main = defaultMain diff --git a/certs/cacert.sample_pem b/certs/cacert.sample_pem new file mode 100644 --- /dev/null +++ b/certs/cacert.sample_pem @@ -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----- diff --git a/certs/localhost.sample_crt b/certs/localhost.sample_crt new file mode 100644 --- /dev/null +++ b/certs/localhost.sample_crt @@ -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----- diff --git a/certs/localhost.sample_key b/certs/localhost.sample_key new file mode 100644 --- /dev/null +++ b/certs/localhost.sample_key @@ -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----- diff --git a/certs/yoshikuni.sample_crt b/certs/yoshikuni.sample_crt new file mode 100644 --- /dev/null +++ b/certs/yoshikuni.sample_crt @@ -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----- diff --git a/certs/yoshikuni.sample_key b/certs/yoshikuni.sample_key new file mode 100644 --- /dev/null +++ b/certs/yoshikuni.sample_key @@ -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----- diff --git a/examples/FilePusher.hs b/examples/FilePusher.hs new file mode 100644 --- /dev/null +++ b/examples/FilePusher.hs @@ -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 diff --git a/examples/TestPusher.hs b/examples/TestPusher.hs new file mode 100644 --- /dev/null +++ b/examples/TestPusher.hs @@ -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 diff --git a/examples/TestSimple.hs b/examples/TestSimple.hs new file mode 100644 --- /dev/null +++ b/examples/TestSimple.hs @@ -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 diff --git a/examples/httpPullCl.hs b/examples/httpPullCl.hs new file mode 100644 --- /dev/null +++ b/examples/httpPullCl.hs @@ -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" diff --git a/examples/httpPullSv.hs b/examples/httpPullSv.hs new file mode 100644 --- /dev/null +++ b/examples/httpPullSv.hs @@ -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") [] [] [] diff --git a/examples/httpPullTlsCl.hs b/examples/httpPullTlsCl.hs new file mode 100644 --- /dev/null +++ b/examples/httpPullTlsCl.hs @@ -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" diff --git a/examples/httpPullTlsSv.hs b/examples/httpPullTlsSv.hs new file mode 100644 --- /dev/null +++ b/examples/httpPullTlsSv.hs @@ -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 diff --git a/examples/httpPushE.hs b/examples/httpPushE.hs new file mode 100644 --- /dev/null +++ b/examples/httpPushE.hs @@ -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" diff --git a/examples/httpPushT.hs b/examples/httpPushT.hs new file mode 100644 --- /dev/null +++ b/examples/httpPushT.hs @@ -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" diff --git a/examples/httpPushTlsE.hs b/examples/httpPushTlsE.hs new file mode 100644 --- /dev/null +++ b/examples/httpPushTlsE.hs @@ -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 diff --git a/examples/httpPushTlsT.hs b/examples/httpPushTlsT.hs new file mode 100644 --- /dev/null +++ b/examples/httpPushTlsT.hs @@ -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 diff --git a/examples/simple.hs b/examples/simple.hs new file mode 100644 --- /dev/null +++ b/examples/simple.hs @@ -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") diff --git a/examples/simpleClient.hs b/examples/simpleClient.hs new file mode 100644 --- /dev/null +++ b/examples/simpleClient.hs @@ -0,0 +1,5 @@ +import Network +import TestSimple + +main :: IO () +main = testSimple =<< connectTo "localhost" (PortNumber 54492) diff --git a/examples/simpleServer.hs b/examples/simpleServer.hs new file mode 100644 --- /dev/null +++ b/examples/simpleServer.hs @@ -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 diff --git a/examples/xmpp.hs b/examples/xmpp.hs new file mode 100644 --- /dev/null +++ b/examples/xmpp.hs @@ -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 diff --git a/examples/xmppTls.hs b/examples/xmppTls.hs new file mode 100644 --- /dev/null +++ b/examples/xmppTls.hs @@ -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 diff --git a/src/Network/XmlPush.hs b/src/Network/XmlPush.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPull/Client.hs b/src/Network/XmlPush/HttpPull/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPull/Client.hs @@ -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) diff --git a/src/Network/XmlPush/HttpPull/Client/Common.hs b/src/Network/XmlPush/HttpPull/Client/Common.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPull/Client/Common.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPull/Server.hs b/src/Network/XmlPush/HttpPull/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPull/Server.hs @@ -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) diff --git a/src/Network/XmlPush/HttpPull/Server/Common.hs b/src/Network/XmlPush/HttpPull/Server/Common.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPull/Server/Common.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPull/Tls/Client.hs b/src/Network/XmlPush/HttpPull/Tls/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPull/Tls/Client.hs @@ -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) diff --git a/src/Network/XmlPush/HttpPull/Tls/Server.hs b/src/Network/XmlPush/HttpPull/Tls/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPull/Tls/Server.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPush.hs b/src/Network/XmlPush/HttpPush.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPush.hs @@ -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) diff --git a/src/Network/XmlPush/HttpPush/Common.hs b/src/Network/XmlPush/HttpPush/Common.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPush/Common.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPush/Tls.hs b/src/Network/XmlPush/HttpPush/Tls.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPush/Tls.hs @@ -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 diff --git a/src/Network/XmlPush/Simple.hs b/src/Network/XmlPush/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/Simple.hs @@ -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) diff --git a/src/Network/XmlPush/Tls/Client.hs b/src/Network/XmlPush/Tls/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/Tls/Client.hs @@ -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)] + } diff --git a/src/Network/XmlPush/Tls/Server.hs b/src/Network/XmlPush/Tls/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/Tls/Server.hs @@ -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)] + } diff --git a/src/Network/XmlPush/Xmpp.hs b/src/Network/XmlPush/Xmpp.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/Xmpp.hs @@ -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 diff --git a/src/Network/XmlPush/Xmpp/Common.hs b/src/Network/XmlPush/Xmpp/Common.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/Xmpp/Common.hs @@ -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 diff --git a/src/Network/XmlPush/Xmpp/Tls.hs b/src/Network/XmlPush/Xmpp/Tls.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/Xmpp/Tls.hs @@ -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 diff --git a/xml-push.cabal b/xml-push.cabal new file mode 100644 --- /dev/null +++ b/xml-push.cabal @@ -0,0 +1,127 @@ +build-type: Simple +cabal-version: >= 1.8 + +name: xml-push +version: 0.0.0.0 +stability: Experimenmtal +author: Yoshikuni Jujo +maintainer: Yoshikuni Jujo +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