peyotls (empty) → 0.0.0.0
raw patch · 37 files changed
+3412/−0 lines, 37 filesdep +asn1-encodingdep +asn1-typesdep +basesetup-changed
Dependencies added: asn1-encoding, asn1-types, base, bytable, bytestring, cipher-aes, crypto-numbers, crypto-pubkey, crypto-pubkey-types, crypto-random, cryptohash, handle-like, monads-tf, network, pem, peyotls, stm, word24, x509, x509-store, x509-validation
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- data/certs/cacert.pem +60/−0
- data/certs/client_ecdsa.sample_crt +16/−0
- data/certs/client_ecdsa.sample_key +40/−0
- data/certs/localhost.sample_crt +17/−0
- data/certs/localhost.sample_key +15/−0
- data/certs/localhost_ecdsa.sample_crt +16/−0
- data/certs/localhost_ecdsa.sample_key +40/−0
- data/certs/yoshikuni.sample_crt +17/−0
- data/certs/yoshikuni.sample_key +15/−0
- examples/clcertClient.hs +34/−0
- examples/clcertEcdsaClient.hs +36/−0
- examples/clcertServer.hs +41/−0
- examples/eccClient.hs +43/−0
- examples/eccServer.hs +53/−0
- examples/simpleClient.hs +32/−0
- examples/simpleServer.hs +40/−0
- peyotls.cabal +311/−0
- src/Network/PeyoTLS/CertSecretKey.hs +7/−0
- src/Network/PeyoTLS/Certificate.hs +103/−0
- src/Network/PeyoTLS/CipherSuite.hs +78/−0
- src/Network/PeyoTLS/Client.hs +251/−0
- src/Network/PeyoTLS/CryptoTools.hs +103/−0
- src/Network/PeyoTLS/Ecdsa.hs +131/−0
- src/Network/PeyoTLS/Extension.hs +198/−0
- src/Network/PeyoTLS/HandshakeBase.hs +246/−0
- src/Network/PeyoTLS/HandshakeMonad.hs +138/−0
- src/Network/PeyoTLS/HandshakeType.hs +230/−0
- src/Network/PeyoTLS/HashSignAlgorithm.hs +43/−0
- src/Network/PeyoTLS/Hello.hs +94/−0
- src/Network/PeyoTLS/ReadFile.hs +84/−0
- src/Network/PeyoTLS/Server.hs +252/−0
- src/Network/PeyoTLS/State.hs +137/−0
- src/Network/PeyoTLS/TlsHandle.hs +285/−0
- src/Network/PeyoTLS/TlsMonad.hs +74/−0
- test/testClient.hs +103/−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,2 @@+import Distribution.Simple+main = defaultMain
+ data/certs/cacert.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-----
+ data/certs/client_ecdsa.sample_crt view
@@ -0,0 +1,16 @@+-----BEGIN CERTIFICATE-----+MIICejCCAeOgAwIBAgIEU4zfbDANBgkqhkiG9w0BAQsFADBZMQswCQYDVQQGEwJK+UDEOMAwGA1UECAwFR3VubWExGzAZBgNVBAoMEllvc2hpa3VuaSBDby4sTHRkLjEd+MBsGA1UEAwwUc2thbWk0NTkyLmlvY2lrdW4uanAwIhgPMjAxNDA2MDIyMDMyNDda+GA8yMDE1MDYwMjIwMzI1MFowajEbMBkGA1UEAxMSeW9zaGlrdW5pIGF0IGVjZHNh+MRswGQYDVQQKExJZb3NoaWt1bmkgQ28uLEx0ZC4xETAPBgNVBAcTCFRha2FzYWtp+MQ4wDAYDVQQIEwVHdW5tYTELMAkGA1UEBhMCSlAwWTATBgcqhkjOPQIBBggqhkjO+PQMBBwNCAATTmA+J1nb24A7LOi6fGcixTNxbeC+Y7p7Fjtc0WiFrYOy4gGJiyHYl+O/D982xA/HMtPfSo/5xOpPIdSKGVg+nzo4GAMH4wDAYDVR0TAQH/BAIwADAPBgNV+HQ8BAf8EBQMDB4AAMB0GA1UdJQQWMBQGCCsGAQUFBwMCBggrBgEFBQcDAjAdBgNV+HQ4EFgQUKz9nfwiQNu9Q2EtgpC23KNTvxIgwHwYDVR0jBBgwFoAUUEbV84cLXFHQ+o2hEQdvU44neeDgwDQYJKoZIhvcNAQELBQADgYEAm/6mPqS7ec1FihD+mg9oSsb++IwjstKCqNzX1DcdQF7ND9bCApyhdxSZnULrOMfpJbpt7vPOW3p+eh3dcry2fMt7l+BC0L6W2VheyuuSjn8b3UbtRC/XOIfJCA5KSUqbHwV3YPpUsHnCyou0XcDiSsJ6ZM+MaNrntn7iAT5OrNbSSY=+-----END CERTIFICATE-----
+ data/certs/client_ecdsa.sample_key view
@@ -0,0 +1,40 @@+Public Key Info:+ Public Key Algorithm: EC+ Key Security Level: High (256 bits)++curve: SECP256R1+private key:+ 00:ea:38:bc:05:19:7d:93:72:7c:30:70:1c:51:52:+ 05:24:5d:74:b0:7c:c9:dd:d8:01:bc:98:f8:52:38:+ 4b:aa:8c:++x:+ 00:d3:98:0f:89:d6:76:f6:e0:0e:cb:3a:2e:9f:19:+ c8:b1:4c:dc:5b:78:2f:98:ee:9e:c5:8e:d7:34:5a:+ 21:6b:60:++y:+ 00:ec:b8:80:62:62:c8:76:25:3b:f0:fd:f3:6c:40:+ fc:73:2d:3d:f4:a8:ff:9c:4e:a4:f2:1d:48:a1:95:+ 83:e9:f3:+++Public Key ID: 2B:3F:67:7F:08:90:36:EF:50:D8:4B:60:A4:2D:B7:28:D4:EF:C4:88+Public key's random art:++--[ EC 256]----++| .. |+| . oo |+| . +.o= |+| . . B*.+ |+| E o.S* . |+| . o..+ |+| . oo . . |+| o. + . . |+| .+ ... |++-----------------+++-----BEGIN EC PRIVATE KEY-----+MHgCAQEEIQDqOLwFGX2TcnwwcBxRUgUkXXSwfMnd2AG8mPhSOEuqjKAKBggqhkjO+PQMBB6FEA0IABNOYD4nWdvbgDss6Lp8ZyLFM3Ft4L5junsWO1zRaIWtg7LiAYmLI+diU78P3zbED8cy099Kj/nE6k8h1IoZWD6fM=+-----END EC PRIVATE KEY-----
+ data/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-----
+ data/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-----
+ data/certs/localhost_ecdsa.sample_crt view
@@ -0,0 +1,16 @@+-----BEGIN CERTIFICATE-----+MIICiDCCAfGgAwIBAgIEU4gV+TANBgkqhkiG9w0BAQsFADBZMQswCQYDVQQGEwJK+UDEOMAwGA1UECAwFR3VubWExGzAZBgNVBAoMEllvc2hpa3VuaSBDby4sTHRkLjEd+MBsGA1UEAwwUc2thbWk0NTkyLmlvY2lrdW4uanAwIhgPMjAxNDA1MzAwNTI0MTVa+GA8yMDE1MDUzMDA1MjQyM1owYTESMBAGA1UEAxMJbG9jYWxob3N0MRswGQYDVQQK+ExJZb3NoaWt1bmkgQ28uLEx0ZC4xETAPBgNVBAcTCFRha2FzYWtpMQ4wDAYDVQQI+EwVHdW5tYTELMAkGA1UEBhMCSlAwWTATBgcqhkjOPQIBBggqhkjOPQMBBwNCAATc+ZZqbFdPI/XDy0uewzRFDqoMnD+DIhm1vpstY56bziTULcpe5Y1SuHVFAMXrvuuFN+U3+VQJXAKizqlxkYyFMko4GXMIGUMAwGA1UdEwEB/wQCMAAwDwYDVR0PAQH/BAUD+AweAADAdBgNVHSUEFjAUBggrBgEFBQcDAQYIKwYBBQUHAwEwFAYDVR0RBA0wC4IJ+bG9jYWxob3N0MB0GA1UdDgQWBBTLxAS+GsIr0CW4kgduPua15q1SAzAfBgNVHSME+GDAWgBRQRtXzhwtcUdCjaERB29Tjid54ODANBgkqhkiG9w0BAQsFAAOBgQDEJ0pl+ZwlPfM+rOw32Azp1fBn+tzb79/KgTpVYn+0eIDkAJdCztvu+H2MTGOsAY4kSwkzt+b9B61A2bR5YoUbCjZhYxrTuhsxjRQ0ww4vNarCw+WNBb8iLGHFU3jZgbrk+hX+p7+TsI+KAb7U+M5ix4e8PZAy1lFzQyUFfIFDdL3xQ==+-----END CERTIFICATE-----
+ data/certs/localhost_ecdsa.sample_key view
@@ -0,0 +1,40 @@+Public Key Info:+ Public Key Algorithm: EC+ Key Security Level: High (256 bits)++curve: SECP256R1+private key:+ 6b:d1:f3:9a:47:40:ef:1e:30:d9:5e:f5:ec:57:ea:+ 56:c7:79:d8:65:af:ad:03:4f:ae:27:04:1a:ab:f8:+ f2:33:++x:+ 00:dc:65:9a:9b:15:d3:c8:fd:70:f2:d2:e7:b0:cd:+ 11:43:aa:83:27:0f:e0:c8:86:6d:6f:a6:cb:58:e7:+ a6:f3:89:++y:+ 35:0b:72:97:b9:63:54:ae:1d:51:40:31:7a:ef:ba:+ e1:4d:53:7f:95:40:95:c0:2a:2c:ea:97:19:18:c8:+ 53:24:+++Public Key ID: CB:C4:04:BE:1A:C2:2B:D0:25:B8:92:07:6E:3E:E6:B5:E6:AD:52:03+Public key's random art:++--[ EC 256]----++| . |+| . . . |+|o . . . . |+|.E o + |+|=o* . . S |+|=. = o o . |+|.+o.o o |+|ooo.o |+| .++.. |++-----------------+++-----BEGIN EC PRIVATE KEY-----+MHcCAQEEIGvR85pHQO8eMNle9exX6lbHedhlr60DT64nBBqr+PIzoAoGCCqGSM49+AwEHoUQDQgAE3GWamxXTyP1w8tLnsM0RQ6qDJw/gyIZtb6bLWOem84k1C3KXuWNU+rh1RQDF677rhTVN/lUCVwCos6pcZGMhTJA==+-----END EC PRIVATE KEY-----
+ data/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-----
+ data/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/clcertClient.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.ReadFile+import Network.PeyoTLS.Client+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Char8 as BSC++main :: IO ()+main = do+ d : _ <- getArgs+ rk <- readKey $ d ++ "/yoshikuni.sample_key"+ rc <- readCertificateChain $ d ++ "/yoshikuni.sample_crt"+ ca <- readCertificateStore [d ++ "/cacert.pem"]+ h <- connectTo "localhost" $ PortNumber 443+ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ (`run` g) $ do+ p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca+ unless ("localhost" `elem` names p) $+ error "certificate name mismatch"+ hlPut p "GET / HTTP/1.1 \r\n"+ hlPut p "Host: localhost\r\n\r\n"+ doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+ (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x
+ examples/clcertEcdsaClient.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.ReadFile+import Network.PeyoTLS.Client+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Char8 as BSC++main :: IO ()+main = do+ d : _ <- getArgs+ rk <- readKey $ d ++ "/yoshikuni.sample_key"+ rc <- readCertificateChain $ d ++ "/yoshikuni.sample_crt"+ ek <- readKey $ d ++ "/client_ecdsa.sample_key"+ ec <- readCertificateChain $ d ++ "/client_ecdsa.sample_crt"+ ca <- readCertificateStore [d ++ "/cacert.pem"]+ h <- connectTo "localhost" $ PortNumber 443+ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ (`run` g) $ do+ p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(ek, ec), (rk, rc)] ca+ unless ("localhost" `elem` names p) $+ error "certificate name mismatch"+ hlPut p "GET / HTTP/1.1 \r\n"+ hlPut p "Host: localhost\r\n\r\n"+ doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+ (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x
+ examples/clcertServer.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.State+import Control.Concurrent+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.Server+import Network.PeyoTLS.ReadFile+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++main :: IO ()+main = do+ d : _ <- getArgs+ k <- readKey $ d ++ "/localhost.sample_key"+ c <- readCertificateChain $ d ++"/localhost.sample_crt"+ ca <- readCertificateStore [d ++ "/cacert.pem"]+ g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ soc <- listenOn $ PortNumber 443+ void . (`runStateT` g0) . forever $ do+ (h, _, _) <- liftIO $ accept soc+ g <- StateT $ return . cprgFork+ liftIO . forkIO . (`run` g) $ do+ p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+ $ Just ca+ doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ hlPut p $ BS.concat [+ "HTTP/1.1 200 OK\r\n",+ "Transfer-Encoding: chunked\r\n",+ "Content-Type: text/plain\r\n\r\n",+ "5\r\nHello0\r\n\r\n" ]+ hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+ (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x
+ examples/eccClient.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.ReadFile+import Network.PeyoTLS.Client+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Char8 as BSC++cipherSuites :: [CipherSuite]+cipherSuites = [+ "TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256",+ "TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA",+ "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256",+ "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA",+ "TLS_DHE_RSA_WITH_AES_128_CBC_SHA256",+ "TLS_DHE_RSA_WITH_AES_128_CBC_SHA",+ "TLS_RSA_WITH_AES_128_CBC_SHA256",+ "TLS_RSA_WITH_AES_128_CBC_SHA" ]++main :: IO ()+main = do+ d : _ <- getArgs+ ca <- readCertificateStore [d ++ "/cacert.pem"]+ h <- connectTo "localhost" $ PortNumber 443+ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ (`run` g) $ do+ p <- open h cipherSuites [] ca+ unless ("localhost" `elem` names p) $+ error "certificate name mismatch"+ hlPut p "GET / HTTP/1.1 \r\n"+ hlPut p "Host: localhost\r\n\r\n"+ doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+ (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x
+ examples/eccServer.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.State+import Control.Concurrent+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.Server+import Network.PeyoTLS.ReadFile+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++cipherSuites :: [CipherSuite]+cipherSuites = [+ "TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256",+ "TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA",+ "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256",+ "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA",+ "TLS_DHE_RSA_WITH_AES_128_CBC_SHA256",+ "TLS_DHE_RSA_WITH_AES_128_CBC_SHA",+ "TLS_RSA_WITH_AES_128_CBC_SHA256",+ "TLS_RSA_WITH_AES_128_CBC_SHA" ]++main :: IO ()+main = do+ d : _ <- getArgs+ rk <- readKey $ d ++ "/localhost.sample_key"+ rc <- readCertificateChain $ d ++ "/localhost.sample_crt"+ ek <- readKey $ d ++ "/localhost_ecdsa.sample_key"+ ec <- readCertificateChain $ d ++ "/localhost_ecdsa.sample_crt"+ g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ soc <- listenOn $ PortNumber 443+ void . (`runStateT` g0) . forever $ do+ (h, _, _) <- liftIO $ accept soc+ g <- StateT $ return . cprgFork+ liftIO . forkIO . (`run` g) $ do+ p <- open h cipherSuites [(rk, rc), (ek, ec)]+ Nothing+ doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ hlPut p $ BS.concat [+ "HTTP/1.1 200 OK\r\n",+ "Transfer-Encoding: chunked\r\n",+ "Content-Type: text/plain\r\n\r\n",+ "5\r\nHello0\r\n\r\n" ]+ hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+ (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x
+ examples/simpleClient.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.ReadFile+import Network.PeyoTLS.Client+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Char8 as BSC++main :: IO ()+main = do+ d : _ <- getArgs+ ca <- readCertificateStore [d ++ "/cacert.pem"]+ h <- connectTo "localhost" $ PortNumber 443+ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ (`run` g) $ do+ p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca+ unless ("localhost" `elem` names p) $+ error "certificate name mismatch"+ hlPut p "GET / HTTP/1.1 \r\n"+ hlPut p "Host: localhost\r\n\r\n"+ doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+ (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x
+ examples/simpleServer.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.State+import Control.Concurrent+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.Server+import Network.PeyoTLS.ReadFile+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++main :: IO ()+main = do+ d : _ <- getArgs+ k <- readKey $ d ++ "/localhost.sample_key"+ c <- readCertificateChain $ d ++ "/localhost.sample_crt"+ g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ soc <- listenOn $ PortNumber 443+ void . (`runStateT` g0) . forever $ do+ (h, _, _) <- liftIO $ accept soc+ g <- StateT $ return . cprgFork+ liftIO . forkIO . (`run` g) $ do+ p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+ Nothing+ doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ hlPut p $ BS.concat [+ "HTTP/1.1 200 OK\r\n",+ "Transfer-Encoding: chunked\r\n",+ "Content-Type: text/plain\r\n\r\n",+ "5\r\nHello0\r\n\r\n" ]+ hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+ (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x
+ peyotls.cabal view
@@ -0,0 +1,311 @@+build-type: Simple+cabal-version: >= 1.8++name: peyotls+version: 0.0.0.0+stability: Experimental+author: Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>+homepage: https://github.com/YoshikuniJujo/peyotls/wiki++license: BSD3+license-file: LICENSE++category: Network+synopsis: Pretty Easy YOshikuni-made TLS library+description:+ Currently implemente the TLS1.2 protocol only,+ and support the following cipher suites.+ .+ * TLS_RSA_WITH_AES_128_CBC_SHA+ .+ * TLS_RSA_WITH_AES_128_CBC_SHA256+ .+ * TLS_DHE_RSA_WITH_AES_128_CBC_SHA+ .+ * TLS_DHE_RSA_WITH_AES_128_CBC_SHA256+ .+ * TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA+ .+ * TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256+ .+ * TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA+ .+ * TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256+ .+ And support client certificate with the following algorithms.+ .+ * RSA (SHA1 or SHA256 depending on the agreed cipher suite)+ .+ * ECDSA (SHA1 or SHA256 depending on the agreed cipher suite)+ .+ Currently not implemente the following features.+ .+ * session resumption (RFC 5077)+ .+ * renegotiation (RFC 5746)+ .+ Server sample+ .+ * file: examples/simpleServer.hs+ .+ localhost.key: key file+ .+ > -----BEGIN RSA PRIVATE KEY-----+ > ...+ > -----END RSA PRIVATE KEY-----+ .+ localhost.crt: certificate file+ .+ > -----BEGIN CERTIFICATE-----+ > ...+ > -----END CERTIFICATE-----+ .+ examples/simpleServer.hs+ .+ extensions+ .+ * OverloadedStrings+ .+ * PackageImports+ .+ > import Control.Applicative+ > import Control.Monad+ > import "monads-tf" Control.Monad.State+ > import Control.Concurrent+ > import Data.HandleLike+ > import Network+ > import Network.PeyoTLS.Server+ > import Network.PeyoTLS.ReadFile+ > import "crypto-random" Crypto.Random+ > + > import qualified Data.ByteString as BS+ > import qualified Data.ByteString.Char8 as BSC+ > + > main :: IO ()+ > main = do+ > k <- readKey "localhost.key"+ > c <- readCertificateChain "localhost.crt"+ > g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ > soc <- listenOn $ PortNumber 443+ > void . (`runStateT` g0) . forever $ do+ > (h, _, _) <- liftIO $ accept soc+ > g <- StateT $ return . cprgFork+ > liftIO . forkIO . (`run` g) $ do+ > p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+ > Nothing+ > doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ > hlPut p $ BS.concat [+ > "HTTP/1.1 200 OK\r\n",+ > "Transfer-Encoding: chunked\r\n",+ > "Content-Type: text/plain\r\n\r\n",+ > "5\r\nHello0\r\n\r\n" ]+ > hlClose p+ > + > doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+ > doUntil p rd = rd >>= \x ->+ > (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x+ .+ Client sample (only show HTTP header)+ .+ * file: examples/simpleClient.hs+ .+ cacert.pem: self-signed root certificate to validate server+ .+ > -----BEGIN CERTIFICATE-----+ > ...+ > -----END CERTIFICATE-----+ .+ examples/simpleClient.hs+ .+ extensions+ .+ * OverloadedStrings+ .+ * PackageImports+ .+ > import Control.Applicative+ > import Control.Monad+ > import "monads-tf" Control.Monad.Trans+ > import Data.HandleLike+ > import Network+ > import Network.PeyoTLS.ReadFile+ > import Network.PeyoTLS.Client+ > import "crypto-random" Crypto.Random+ > + > import qualified Data.ByteString.Char8 as BSC+ > + > main :: IO ()+ > main = do+ > ca <- readCertificateStore ["cacert.pem"]+ > h <- connectTo "localhost" $ PortNumber 443+ > g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ > (`run` g) $ do+ > p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca+ > unless ("localhost" `elem` names p) $+ > error "certificate name mismatch"+ > hlPut p "GET / HTTP/1.1 \r\n"+ > hlPut p "Host: localhost\r\n\r\n"+ > doUntil BSC.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ > hlClose p+ > + > doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+ > doUntil p rd = rd >>= \x ->+ > (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x+ .+ Client certificate server+ .+ * file: examples/clcertServer.hs+ .+ > % diff examples/simpleServer.hs examples/clcertServer.hs+ > 19a20+ > > ca <- readCertificateStore ["cacert.pem"]+ > 27c28+ > < Nothing+ > ---+ > > $ Just ca+ .+ Client certificate client (RSA certificate)+ .+ * file: examples/clcertClient.hs+ .+ > % diff examples/simpleClient.hs examples/clcertClient.hs+ > 15a16,17+ > > rk <- readKey "client_rsa.key"+ > > rc <- readCertificateChain "client_rsa.crt"+ > 20c22+ > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca+ > ---+ > > p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca+ .+ Client certificate client (ECDSA or RSA certificate)+ .+ * file: examples/clcertEcdsaClient.hs+ .+ > % diff examples/clcertClient.hs examples/clcertEcdsaClient.hs+ > 17a18,19+ > > ek <- readKey "client_ecdsa.key"+ > > ec <- readCertificateChain "client_ecdsa.crt"+ > 22c24+ > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca+ > ---+ > > p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(ek, ec), (rk, rc)] ca+ .+ ECC server (use ECC or RSA depending on client)+ .+ * file: examples/eccServer.hs+ .+ > % diff examples/simpleServer.hs examples/eccServer.hs+ > 15a16,26+ > > cipherSuites :: [CipherSuite]+ > > cipherSuites = [+ > > "TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256",+ > > "TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA",+ > > "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256",+ > > "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA",+ > > "TLS_DHE_RSA_WITH_AES_128_CBC_SHA256",+ > > "TLS_DHE_RSA_WITH_AES_128_CBC_SHA",+ > > "TLS_RSA_WITH_AES_128_CBC_SHA256",+ > > "TLS_RSA_WITH_AES_128_CBC_SHA" ]+ > >+ > 18,19c29,32+ > < k <- readKey "localhost.key"+ > < c <- readCertificateChain "localhost.crt"+ > ---+ > > rk <- readKey "localhost.key"+ > > rc <- readCertificateChain "localhost.crt"+ > > ek <- readKey "localhost_ecdsa.key"+ > > ec <- readCertificateChain "localhost_ecdsa.crt"+ > 26c39+ > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+ > ---+ > > p <- open h cipherSuites [(rk, rc), (ek, ec)]+ .+ ECC client (use ECC or RSA depending on server)+ .+ * file: examples/eccClient.hs+ .+ > % diff examples/simpleClient.hs examples/eccClient.hs+ > 13a14,24+ > > cipherSuites :: [CipherSuite]+ > > cipherSuites = [+ > > "TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256",+ > > "TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA",+ > > "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256",+ > > "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA",+ > > "TLS_DHE_RSA_WITH_AES_128_CBC_SHA256",+ > > "TLS_DHE_RSA_WITH_AES_128_CBC_SHA",+ > > "TLS_RSA_WITH_AES_128_CBC_SHA256",+ > > "TLS_RSA_WITH_AES_128_CBC_SHA" ]+ > >+ > 20c31+ > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca+ > ---+ > > p <- open h cipherSuites [] ca+ .++extra-source-files:+ examples/simpleServer.hs+ examples/simpleClient.hs+ examples/clcertServer.hs+ examples/clcertClient.hs+ examples/clcertEcdsaClient.hs+ examples/eccServer.hs+ examples/eccClient.hs++data-dir: data+data-files:+ certs/cacert.pem,+ certs/localhost.sample_key,+ certs/localhost.sample_crt,+ certs/localhost_ecdsa.sample_key,+ certs/localhost_ecdsa.sample_crt,+ certs/yoshikuni.sample_key,+ certs/yoshikuni.sample_crt,+ certs/client_ecdsa.sample_key,+ certs/client_ecdsa.sample_crt++source-repository head+ type: git+ location: git://github.com/YoshikuniJujo/peyotls.git++source-repository this+ type: git+ location: git://github.com/YoshikuniJujo/peyotls.git+ tag: peyotls-0.0.0.0++library+ hs-source-dirs: src+ exposed-modules:+ Network.PeyoTLS.Client, Network.PeyoTLS.Server, Network.PeyoTLS.ReadFile+ other-modules:+ Network.PeyoTLS.HandshakeBase,+ Network.PeyoTLS.HandshakeType,+ Network.PeyoTLS.Hello, Network.PeyoTLS.Extension,+ Network.PeyoTLS.CipherSuite, Network.PeyoTLS.HashSignAlgorithm,+ Network.PeyoTLS.Certificate,+ Network.PeyoTLS.HandshakeMonad,+ Network.PeyoTLS.TlsHandle,+ Network.PeyoTLS.TlsMonad, Network.PeyoTLS.State,+ Network.PeyoTLS.CryptoTools,+ Network.PeyoTLS.Ecdsa, Network.PeyoTLS.CertSecretKey+ build-depends:+ base == 4.*, word24 == 1.0.*, bytestring == 0.10.*, monads-tf == 0.1.*,+ asn1-encoding == 0.8.*, asn1-types == 0.2.*,+ pem == 0.2.*, x509 == 1.4.*, x509-store == 1.4.*, x509-validation == 1.5.*,+ crypto-numbers == 0.2.*, crypto-random == 0.0.*,+ cryptohash == 0.11.*,+ crypto-pubkey == 0.2.*, crypto-pubkey-types == 0.4.*,+ cipher-aes == 0.2.*,+ bytable == 0.0.0.*, handle-like == 0.0.0.*+ ghc-options: -Wall+ extensions: PatternGuards, DoAndIfThenElse++test-suite stm-test+ type: exitcode-stdio-1.0+ main-is: testClient.hs+ hs-source-dirs: test+ build-depends: peyotls, handle-like == 0.0.0.*,+ base == 4.*, bytestring == 0.10.*, network == 2.4.*, stm == 2.4.*,+ x509 == 1.4.*, x509-store == 1.4.*, crypto-random == 0.0.*+ ghc-options: -Wall
+ src/Network/PeyoTLS/CertSecretKey.hs view
@@ -0,0 +1,7 @@+module Network.PeyoTLS.CertSecretKey (CertSecretKey(..)) where++import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA++data CertSecretKey = RsaKey RSA.PrivateKey | EcdsaKey ECDSA.PrivateKey+ deriving Show
+ src/Network/PeyoTLS/Certificate.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Certificate (+ CertificateRequest(..), certificateRequest, ClientCertificateType(..),+ ClientKeyExchange(..), DigitallySigned(..)) where++import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8, Word16)+import Data.Word.Word24 (Word24)++import qualified Data.ByteString as BS+import qualified Data.ASN1.Types as ASN1+import qualified Data.ASN1.Encoding as ASN1+import qualified Data.ASN1.BinaryEncoding as ASN1+import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable as B++import Network.PeyoTLS.HashSignAlgorithm (HashAlg, SignAlg)++instance B.Bytable X509.CertificateChain where+ decode = B.evalBytableM B.parse+ encode = B.addLen w24 . cmap (B.addLen w24)+ . (\(X509.CertificateChainRaw ccr) -> ccr)+ . X509.encodeCertificateChain++instance B.Parsable X509.CertificateChain where+ parse = do+ ecc <- X509.decodeCertificateChain . X509.CertificateChainRaw <$>+ (flip B.list (B.take =<< B.take 3) =<< B.take 3)+ case ecc of+ Right cc -> return cc+ Left (n, err) -> fail $ show n ++ " " ++ err++data CertificateRequest+ = CertificateRequest [ClientCertificateType]+ [(HashAlg, SignAlg)] [X509.DistinguishedName]+ | CertificateRequestRaw BS.ByteString+ deriving Show++certificateRequest :: [ClientCertificateType] -> [(HashAlg, SignAlg)] ->+ X509.CertificateStore -> CertificateRequest+certificateRequest t a = CertificateRequest t a+ . map (X509.certIssuerDN . X509.signedObject . X509.getSigned)+ . X509.listCertificates++instance B.Bytable CertificateRequest where+ encode (CertificateRequest t a n) = BS.concat [+ B.addLen w8 $ cmap B.encode t,+ B.addLen w16 . BS.concat $+ concatMap (\(h, s) -> [B.encode h, B.encode s]) a,+ B.addLen w16 . flip cmap n $ B.addLen w16 .+ ASN1.encodeASN1' ASN1.DER . flip ASN1.toASN1 [] ]+ encode (CertificateRequestRaw bs) = bs+ decode = B.evalBytableM $ do+ t <- flip B.list (B.take 1) =<< B.take 1+ a <- flip B.list ((,) <$> B.take 1 <*> B.take 1) =<< B.take 2+ n <- (B.take 2 >>=) . flip B.list $ do+ bs <- B.take =<< B.take 2+ a1 <- either (fail . show) return $+ ASN1.decodeASN1' ASN1.DER bs+ either (fail . show) (return . fst) $ ASN1.fromASN1 a1+ return $ CertificateRequest t a n++data ClientCertificateType = CTRsaSign | CTEcdsaSign | CTRaw Word8+ deriving (Show, Eq)++instance B.Bytable ClientCertificateType where+ encode CTRsaSign = "\x01"+ encode CTEcdsaSign = "\x40"+ encode (CTRaw w) = BS.pack [w]+ decode bs = case BS.unpack bs of+ [w] -> Right $ case w of+ 1 -> CTRsaSign; 64 -> CTEcdsaSign; _ -> CTRaw w+ _ -> Left "Certificate: ClientCertificateType.decode"++data ClientKeyExchange = ClientKeyExchange BS.ByteString deriving Show++instance B.Bytable ClientKeyExchange where+ decode = Right . ClientKeyExchange+ encode (ClientKeyExchange epms) = epms++data DigitallySigned+ = DigitallySigned (HashAlg, SignAlg) BS.ByteString+ | DigitallySignedRaw BS.ByteString+ deriving Show++instance B.Bytable DigitallySigned where+ decode = B.evalBytableM $+ DigitallySigned+ <$> ((,) <$> B.take 1 <*> B.take 1)+ <*> (B.take =<< B.take 2)+ encode (DigitallySigned (ha, sa) bs) = BS.concat [+ B.encode ha, B.encode sa, B.addLen w16 bs ]+ encode (DigitallySignedRaw bs) = bs++w8 :: Word8; w8 = undefined+w16 :: Word16; w16 = undefined+w24 :: Word24; w24 = undefined++cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString+cmap = (BS.concat .) . map
+ src/Network/PeyoTLS/CipherSuite.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.CipherSuite (+ CipherSuite(..), KeyExchange(..), BulkEncryption(..)) where++import Control.Arrow (first, (***))+import Data.Word (Word8)+import Data.String (IsString(..))++import qualified Data.ByteString as BS+import qualified Codec.Bytable as B++data CipherSuite+ = CipherSuite KeyExchange BulkEncryption+ | CipherSuiteRaw Word8 Word8+ deriving (Show, Read, Eq)++data KeyExchange+ = RSA+ | DHE_RSA+ | ECDHE_RSA+ | ECDHE_ECDSA+-- | ECDHE_PSK+ | KE_NULL+ deriving (Show, Read, Eq)++data BulkEncryption+ = AES_128_CBC_SHA+ | AES_128_CBC_SHA256+-- | CAMELLIA_128_CBC_SHA+-- | NULL_SHA+ | BE_NULL+ deriving (Show, Read, Eq)+++instance B.Bytable CipherSuite where+ decode = decodeCipherSuite+ encode = encodeCipherSuite++decodeCipherSuite :: BS.ByteString -> Either String CipherSuite+decodeCipherSuite bs = case BS.unpack bs of+ [w1, w2] -> Right $ case (w1, w2) of+ (0x00, 0x00) -> CipherSuite KE_NULL BE_NULL+ (0x00, 0x2f) -> CipherSuite RSA AES_128_CBC_SHA+ (0x00, 0x33) -> CipherSuite DHE_RSA AES_128_CBC_SHA+-- (0x00, 0x39) -> CipherSuite ECDHE_PSK NULL_SHA+ (0x00, 0x3c) -> CipherSuite RSA AES_128_CBC_SHA256+-- (0x00, 0x45) -> CipherSuite DHE_RSA CAMELLIA_128_CBC_SHA+ (0x00, 0x67) -> CipherSuite DHE_RSA AES_128_CBC_SHA256+ (0xc0, 0x09) -> CipherSuite ECDHE_ECDSA AES_128_CBC_SHA+ (0xc0, 0x13) -> CipherSuite ECDHE_RSA AES_128_CBC_SHA+ (0xc0, 0x23) -> CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256+ (0xc0, 0x27) -> CipherSuite ECDHE_RSA AES_128_CBC_SHA256+ _ -> CipherSuiteRaw w1 w2+ _ -> Left "CipherSuite.decodeCipherSuite: not 2 byte"++encodeCipherSuite :: CipherSuite -> BS.ByteString+encodeCipherSuite (CipherSuite KE_NULL BE_NULL) = "\x00\x00"+encodeCipherSuite (CipherSuite RSA AES_128_CBC_SHA) = "\x00\x2f"+encodeCipherSuite (CipherSuite DHE_RSA AES_128_CBC_SHA) = "\x00\x33"+-- encodeCipherSuite (CipherSuite ECDHE_PSK NULL_SHA) = "\x00\x39"+encodeCipherSuite (CipherSuite RSA AES_128_CBC_SHA256) = "\x00\x3c"+-- encodeCipherSuite (CipherSuite DHE_RSA CAMELLIA_128_CBC_SHA) = "\x00\x45"+encodeCipherSuite (CipherSuite DHE_RSA AES_128_CBC_SHA256) = "\x00\x67"+encodeCipherSuite (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA) = "\xc0\x09"+encodeCipherSuite (CipherSuite ECDHE_RSA AES_128_CBC_SHA) = "\xc0\x13"+encodeCipherSuite (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256) = "\xc0\x23"+encodeCipherSuite (CipherSuite ECDHE_RSA AES_128_CBC_SHA256) = "\xc0\x27"+encodeCipherSuite (CipherSuiteRaw w1 w2) = BS.pack [w1, w2]+encodeCipherSuite _ = error "CipherSuite.encodeCipherSuite: unknown cipher suite"++separateByWith :: String -> (String, String)+separateByWith "" = error "CipherSuite: parse error"+separateByWith ('_' : 'W' : 'I' : 'T' : 'H' : '_' : be) = ("", be)+separateByWith (k : r) = (k :) `first` separateByWith r++instance IsString CipherSuite where+ fromString = uncurry CipherSuite . (read *** read) . separateByWith . drop 4
+ src/Network/PeyoTLS/Client.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}++module Network.PeyoTLS.Client (+ run, open, names,+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ PeyotlsM, PeyotlsHandle,+ TlsM, TlsHandle,+ ValidateHandle(..), CertSecretKey ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (unless, liftM, ap)+import Data.List (find, intersect)+import Data.HandleLike (HandleLike)+import "crypto-random" Crypto.Random (CPRG)++import qualified "monads-tf" Control.Monad.Error as E+import qualified "monads-tf" Control.Monad.Error.Class as E+import qualified Data.ByteString as BS+import qualified Data.ASN1.Types as ASN1+import qualified Data.ASN1.Encoding as ASN1+import qualified Data.ASN1.BinaryEncoding as ASN1+import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable as B+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.PubKey.DH as DH+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.Prim as RSA+import qualified Crypto.Types.PubKey.ECC as ECC+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA++import Network.PeyoTLS.HandshakeBase (+ PeyotlsM, PeyotlsHandle, names,+ TlsM, run, HandshakeM, execHandshakeM, CertSecretKey(..),+ withRandom, randomByteString,+ TlsHandle,+ readHandshake, getChangeCipherSpec,+ writeHandshake, putChangeCipherSpec,+ ValidateHandle(..), handshakeValidate,+ ServerKeyExEcdhe(..), ServerKeyExDhe(..), ServerHelloDone(..),+ ClientHello(..), ServerHello(..), SessionId(..),+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ CompressionMethod(..), HashAlg(..), SignAlg(..),+ setCipherSuite,+ CertificateRequest(..), ClientCertificateType(..),+ ClientKeyExchange(..), Epms(..),+ generateKeys, encryptRsa, rsaPadding,+ DigitallySigned(..), handshakeHash, flushCipherSuite,+ Side(..), RW(..), finishedHash,+ DhParam(..), generateKs, blindSign )++open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] ->+ [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->+ TlsM h g (TlsHandle h g)+open h cscl crts ca = execHandshakeM h $ do+ (cr, sr, cs@(CipherSuite ke _)) <- hello cscl+ setCipherSuite cs+ case ke of+ RSA -> rsaHandshake cr sr crts ca+ DHE_RSA -> dheHandshake dhType cr sr crts ca+ ECDHE_RSA -> dheHandshake curveType cr sr crts ca+ ECDHE_ECDSA -> dheHandshake curveType cr sr crts ca+ _ -> error "not implemented"+ where+ dhType :: DH.Params; dhType = undefined+ curveType :: ECC.Curve; curveType = undefined++hello :: (HandleLike h, CPRG g) =>+ [CipherSuite] -> HandshakeM h g (BS.ByteString, BS.ByteString, CipherSuite)+hello cscl = do+ cr <- randomByteString 32+ writeHandshake $ ClientHello (3, 3) cr (SessionId "")+ cscl' [CompressionMethodNull] Nothing+ ServerHello _v sr _sid cs _cm _e <- readHandshake+ return (cr, sr, cs)+ where+ cscl' = if b `elem` cscl then cscl else cscl ++ [b]+ b = CipherSuite RSA AES_128_CBC_SHA++rsaHandshake :: (ValidateHandle h, CPRG g) =>+ BS.ByteString -> BS.ByteString ->+ [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->+ HandshakeM h g ()+rsaHandshake cr sr crts ca = do+ cc@(X509.CertificateChain (c : _)) <- readHandshake+ vr <- handshakeValidate ca cc+ unless (null vr) $ E.throwError "TlsClient.rsaHandshake: validate failure"+ let X509.PubKeyRSA pk =+ X509.certPubKey . X509.signedObject $ X509.getSigned c+ crt <- clientCertificate crts+ pms <- ("\x03\x03" `BS.append`) `liftM` randomByteString 46+ generateKeys Client (cr, sr) pms+ writeHandshake . Epms =<< encryptRsa pk pms+ finishHandshake crt++dheHandshake :: (ValidateHandle h, CPRG g, KeyExchangeClass ke, Show (Secret ke),+ Show (Public ke)) =>+ ke -> BS.ByteString -> BS.ByteString ->+ [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->+ HandshakeM h g ()+dheHandshake t cr sr crts ca = do+ cc@(X509.CertificateChain (c : _)) <- readHandshake+ case X509.certPubKey . X509.signedObject $ X509.getSigned c of+ X509.PubKeyRSA pk -> succeedHandshake t pk cr sr cc crts ca+ X509.PubKeyECDSA cv pnt ->+ succeedHandshake t (ek cv pnt) cr sr cc crts ca+ _ -> E.throwError "TlsClient.dheHandshake: not implemented"+ where+ ek cv pnt = ECDSA.PublicKey (ECC.getCurveByName cv) (point pnt)+ point s = let (x, y) = BS.splitAt 32 $ BS.drop 1 s in ECC.Point+ (either error id $ B.decode x)+ (either error id $ B.decode y)++succeedHandshake ::+ (ValidateHandle h, CPRG g, Verify pk, KeyExchangeClass ke, Show (Secret ke),+ Show (Public ke)) =>+ ke -> pk -> BS.ByteString -> BS.ByteString -> X509.CertificateChain ->+ [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->+ HandshakeM h g ()+succeedHandshake t pk cr sr cc crts ca = do+ vr <- handshakeValidate ca cc+ unless (null vr) $+ E.throwError "TlsClient.succeedHandshake: validate failure"+ (ps, pv, ha, _sa, sn) <- serverKeyExchange+ let _ = ps `asTypeOf` t+ unless (verify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) $+ E.throwError "TlsClient.succeedHandshake: verify failure"+ crt <- clientCertificate crts+ sv <- withRandom $ generateSecret ps+ generateKeys Client (cr, sr) $ calculateShared ps sv pv+ writeHandshake . ClientKeyExchange . B.encode $ calculatePublic ps sv+ finishHandshake crt++class (DhParam bs, B.Bytable bs, B.Bytable (Public bs)) => KeyExchangeClass bs where+ serverKeyExchange :: (HandleLike h, CPRG g) => HandshakeM h g+ (bs, Public bs, HashAlg, SignAlg, BS.ByteString)++instance KeyExchangeClass ECC.Curve where+ serverKeyExchange = do+ ServerKeyExEcdhe cv pnt ha sa sn <- readHandshake+ return (cv, pnt, ha, sa, sn)++instance KeyExchangeClass DH.Params where+ serverKeyExchange = do+ ServerKeyExDhe ps pv ha sa sn <- readHandshake+ return (ps, pv, ha, sa, sn)++class Verify pk where+ verify :: HashAlg -> pk -> BS.ByteString -> BS.ByteString -> Bool++instance Verify RSA.PublicKey where+ verify = rsaVerify++rsaVerify :: HashAlg -> RSA.PublicKey -> BS.ByteString -> BS.ByteString -> Bool+rsaVerify ha pk sn m = let+ (hs, oid0) = case ha of+ Sha1 -> (SHA1.hash, ASN1.OID [1, 3, 14, 3, 2, 26])+ Sha256 -> (SHA256.hash, ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])+ _ -> error "not implemented"+ Right [ASN1.Start ASN1.Sequence,+ ASN1.Start ASN1.Sequence, oid, ASN1.Null, ASN1.End ASN1.Sequence,+ ASN1.OctetString o, ASN1.End ASN1.Sequence ] =+ ASN1.decodeASN1' ASN1.DER . BS.tail . BS.dropWhile (== 255) .+ BS.drop 2 $ RSA.ep pk sn in+ oid == oid0 && o == hs m++instance Verify ECDSA.PublicKey where+ verify Sha1 pk = ECDSA.verify SHA1.hash pk . either error id . B.decode+ verify Sha256 pk = ECDSA.verify SHA256.hash pk . either error id . B.decode+ verify _ _ = error "TlsClient: ECDSA.PublicKey.verify: not implemented"++clientCertificate :: (HandleLike h, CPRG g) =>+ [(CertSecretKey, X509.CertificateChain)] ->+ HandshakeM h g (Maybe (CertSecretKey, X509.CertificateChain))+clientCertificate crts = do+ shd <- readHandshake+ case shd of+ Left (CertificateRequest ca hsa dn) -> do+ ServerHelloDone <- readHandshake+ case find (isMatchedCert ca hsa dn) crts of+ Just (sk, rcc) -> do+ writeHandshake rcc+ return $ Just (sk, rcc)+ _ -> E.throwError . E.strMsg $+ "TlsClient.clientCertificate: " +++ "no certificate"+ Right ServerHelloDone -> return Nothing+ _ -> E.throwError "TlsClient.clientCertificate"++isMatchedCert :: [ClientCertificateType] -> [(HashAlg, SignAlg)] ->+ [X509.DistinguishedName] -> (CertSecretKey, X509.CertificateChain) -> Bool+isMatchedCert ct hsa dn = (&&) <$> csk . fst <*> ccrt . snd+ where+ csk (RsaKey _) = CTRsaSign `elem` ct || Rsa `elem` map snd hsa+ csk (EcdsaKey _) = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa+ ccrt (X509.CertificateChain cs@(c : _)) =+ cpk pk && not (null $ intersect dn issr)+ where+ obj = X509.signedObject . X509.getSigned+ pk = X509.certPubKey $ obj c+ issr = map (X509.certIssuerDN . obj) cs+ ccrt _ = error "TlsClient.certIsOk: empty certificate chain"+ cpk X509.PubKeyRSA {} = CTRsaSign `elem` ct || Rsa `elem` map snd hsa+ cpk X509.PubKeyECDSA {} = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa+ cpk _ = False++finishHandshake :: (HandleLike h, CPRG g) =>+ Maybe (CertSecretKey, X509.CertificateChain) -> HandshakeM h g ()+finishHandshake crt = do+ hs <- handshakeHash+ case crt of+ Just (RsaKey sk, X509.CertificateChain (c : _)) ->+ writeHandshake $ digitallySigned sk (pubKey sk c) hs+ Just (EcdsaKey sk, X509.CertificateChain (c : _)) ->+ writeHandshake $ digitallySigned sk (pubKey sk c) hs+ _ -> return ()+ putChangeCipherSpec >> flushCipherSuite Write+ writeHandshake =<< finishedHash Client+ getChangeCipherSpec >> flushCipherSuite Read+ (==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless+ (E.throwError "TlsClient.finishHandshake: finished hash failure")+ where+ digitallySigned sk pk hs = DigitallySigned (algorithm sk) $ sign sk pk hs++class SecretKey sk where+ type PubKey sk+ pubKey :: sk -> X509.SignedCertificate -> PubKey sk+ sign :: sk -> PubKey sk -> BS.ByteString -> BS.ByteString+ algorithm :: sk -> (HashAlg, SignAlg)++instance SecretKey RSA.PrivateKey where+ type PubKey RSA.PrivateKey = RSA.PublicKey+ pubKey _ c = case X509.certPubKey . X509.signedObject $ X509.getSigned c of+ X509.PubKeyRSA pk -> pk+ _ -> error "TlsClient: RSA.PrivateKey.pubKey"+ sign sk pk m = let pd = rsaPadding pk m in RSA.dp Nothing sk pd+ algorithm _ = (Sha256, Rsa)++instance SecretKey ECDSA.PrivateKey where+ type PubKey ECDSA.PrivateKey = ()+ pubKey _ _ = ()+ sign sk _ m = enc $ blindSign 0 id sk (generateKs (SHA256.hash, 64) q x m) m+ where+ q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk+ x = ECDSA.private_d sk+ enc (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [+ ASN1.Start ASN1.Sequence,+ ASN1.IntVal r, ASN1.IntVal s,+ ASN1.End ASN1.Sequence]+ algorithm _ = (Sha256, Ecdsa)
+ src/Network/PeyoTLS/CryptoTools.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings, PackageImports, TupleSections #-}++module Network.PeyoTLS.CryptoTools (+ makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash) where++import Prelude hiding (splitAt, take)++import Control.Arrow (first)+import Data.Bits (xor)+import Data.Word (Word8, Word16, Word64)+import "crypto-random" Crypto.Random (CPRG, cprgGenerate)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Cipher.AES as AES++import qualified Codec.Bytable as B+import Codec.Bytable.BigEndian ()++makeKeys :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString ->+ (BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString)+makeKeys kl cr sr pms = let+ kls = [kl, kl, 16, 16]+ ms = take 48 . prf pms $ BS.concat ["master secret", cr, sr]+ ems = prf ms $ BS.concat ["key expansion", sr, cr]+ [cwmk, swmk, cwk, swk] = divide kls ems in+ (ms, cwmk, swmk, cwk, swk)+ where+ divide [] _ = []+ divide (n : ns) bs+ | BSL.null bs = []+ | otherwise = let (x, bs') = splitAt n bs in x : divide ns bs'++prf :: BS.ByteString -> BS.ByteString -> BSL.ByteString+prf sk sd = BSL.fromChunks . ph $ hm sk sd+ where+ hm = hmac SHA256.hash 64+ ph a = hm sk (a `BS.append` sd) : ph (hm sk a)++hmac :: (BS.ByteString -> BS.ByteString) -> Int ->+ BS.ByteString -> BS.ByteString -> BS.ByteString+hmac hs bls sk =+ hs . BS.append (BS.map (0x5c `xor`) k) .+ hs . BS.append (BS.map (0x36 `xor`) k)+ where+ k = pd $ if BS.length sk > bls then hs sk else sk+ pd bs = bs `BS.append` BS.replicate (bls - BS.length bs) 0++type Hash = BS.ByteString -> BS.ByteString++hashSha1, hashSha256 :: (Hash, Int)+hashSha1 = (SHA1.hash, 20)+hashSha256 = (SHA256.hash, 32)++encrypt :: CPRG g => (Hash, Int) -> BS.ByteString -> BS.ByteString -> Word64 ->+ BS.ByteString -> BS.ByteString -> g -> (BS.ByteString, g)+encrypt (hs, _) k mk sn p m g = (, g') $+ iv `BS.append` AES.encryptCBC (AES.initAES k) iv (pln `BS.append` pd)+ where+ (iv, g') = cprgGenerate 16 g+ pln = m `BS.append` calcMac hs mk sn (p `BS.append` B.addLen w16 m)+ l = 16 - (BS.length pln + 1) `mod` 16+ pd = BS.replicate (l + 1) $ fromIntegral l++decrypt :: (Hash, Int) ->+ BS.ByteString -> BS.ByteString -> Word64 ->+ BS.ByteString -> BS.ByteString -> Either String BS.ByteString+decrypt (hs, ml) k mk sn p enc = if rm == em then Right b else Left $ if BS.null enc+ then "CryptoTools.decrypt: enc is null\n"+ else "CryptoTools.decrypt: bad MAC:" +++ "\n\tsn: " ++ show sn +++ "\n\tplain: " ++ BSC.unpack pln +++ "\n\tExpected: " ++ BSC.unpack em +++ "\n\tRecieved: " ++ BSC.unpack rm +++ "\n\tml: " ++ show ml ++ "\n"+ where+ pln = uncurry (AES.decryptCBC $ AES.initAES k) $ BS.splitAt 16 enc+ up = BS.take (BS.length pln - fromIntegral (myLast "decrypt" pln) - 1) pln+ (b, rm) = BS.splitAt (BS.length up - ml) up+ em = calcMac hs mk sn $ p `BS.append` B.addLen w16 b++calcMac :: Hash -> BS.ByteString -> Word64 -> BS.ByteString -> BS.ByteString+calcMac hs mk sn m = hmac hs 64 mk $ B.encode sn `BS.append` m++finishedHash :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString+finishedHash c ms hash = take 12 . prf ms . (`BS.append` hash) $ if c+ then "client finished"+ else "server finished"++myLast :: String -> BS.ByteString -> Word8+myLast msg "" = error msg+myLast _ bs = BS.last bs++take :: Int -> BSL.ByteString -> BS.ByteString+take = (fst .) . splitAt++splitAt :: Int -> BSL.ByteString -> (BS.ByteString, BSL.ByteString)+splitAt n = first BSL.toStrict . BSL.splitAt (fromIntegral n)++w16 :: Word16; w16 = undefined
+ src/Network/PeyoTLS/Ecdsa.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Ecdsa (blindSign, generateKs) where++import Control.Applicative ((<$>), (<*>))+import Data.Maybe (mapMaybe)+import Data.Bits (shiftR, xor)+import Crypto.Number.ModArithmetic (inverse)++import qualified Data.ByteString as BS+import qualified Codec.Bytable as B+import Codec.Bytable.BigEndian ()+import qualified Crypto.Types.PubKey.ECC as ECC+import qualified Crypto.PubKey.ECC.Prim as ECC+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA++import qualified Data.ASN1.Types as ASN1+import qualified Data.ASN1.Encoding as ASN1+import qualified Data.ASN1.BinaryEncoding as ASN1++instance B.Bytable ECDSA.Signature where+ encode (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [+ ASN1.Start ASN1.Sequence,+ ASN1.IntVal r, ASN1.IntVal s, ASN1.End ASN1.Sequence ]+ decode bs = case ASN1.decodeASN1' ASN1.DER bs of+ Right [ASN1.Start ASN1.Sequence, ASN1.IntVal r, ASN1.IntVal s,+ ASN1.End ASN1.Sequence] -> Right $ ECDSA.Signature r s+ Right _ -> Left "KeyExchange.decodeSignature"+ Left err -> Left $ "KeyExchange.decodeSignature: " ++ show err++type Hash = BS.ByteString -> BS.ByteString++blindSign :: Integer -> Hash -> ECDSA.PrivateKey -> [Integer] ->+ BS.ByteString -> ECDSA.Signature+blindSign bl hs (ECDSA.PrivateKey crv d) ks m = head $ bs `mapMaybe` ks+ where+ bs k = do+ r <- case bPointMul bl crv k g of+ ECC.PointO -> Nothing+ ECC.Point 0 _ -> Nothing+ ECC.Point x _ -> return $ x `mod` n+ ki <- inverse k n+ case ki * (z + r * d) `mod` n of+ 0 -> Nothing+ s -> return $ ECDSA.Signature r s+ ECC.CurveCommon _ _ g n _ = ECC.common_curve crv+ Right e = B.decode $ hs m+ dl = qlen e - qlen n+ z = if dl > 0 then e `shiftR` dl else e++bPointMul :: Integer -> ECC.Curve -> Integer -> ECC.Point -> ECC.Point+bPointMul bl c@(ECC.CurveFP (ECC.CurvePrime _ cc)) k p =+ ECC.pointMul c (bl * ECC.ecc_n cc + k) p+bPointMul _ _ _ _ = error "Ecdsa.bPointMul: not implemented"++-- RFC 6979++generateKs :: (Hash, Int) -> Integer -> Integer -> BS.ByteString -> [Integer]+generateKs hsbl@(hs, _) q x m = filter ((&&) <$> (> 0) <*> (< q)) .+ uncurry (createKs hsbl q) . initializeKV hsbl q x $ hs m++initializeKV :: (Hash, Int) ->+ Integer -> Integer -> BS.ByteString -> (BS.ByteString, BS.ByteString)+initializeKV (hs, bls) q x h = (k2, v2)+ where+ k0 = BS.replicate (BS.length h) 0+ v0 = BS.replicate (BS.length h) 1+ k1 = hmac hs bls k0 $+ BS.concat [v0, "\x00", int2octets q x, bits2octets q h]+ v1 = hmac hs bls k1 v0+ k2 = hmac hs bls k1 $+ BS.concat [v1, "\x01", int2octets q x, bits2octets q h]+ v2 = hmac hs bls k2 v1++createKs :: (Hash, Int) -> Integer -> BS.ByteString -> BS.ByteString -> [Integer]+createKs hsbl@(hs, bls) q k v = kk : createKs hsbl q k' v''+ where+ (t, v') = createT hsbl q k v ""+ kk = bits2int q t+ k' = hmac hs bls k $ v' `BS.append` "\x00"+ v'' = hmac hs bls k' v'++createT :: (Hash, Int) -> Integer -> BS.ByteString -> BS.ByteString ->+ BS.ByteString -> (BS.ByteString, BS.ByteString)+createT hsbl@(hs, bls) q k v t+ | blen t < qlen q = createT hsbl q k v' $ t `BS.append` v'+ | otherwise = (t, v)+ where+ v' = hmac hs bls k v++hmac :: (BS.ByteString -> BS.ByteString) -> Int ->+ BS.ByteString -> BS.ByteString -> BS.ByteString+hmac hs bls sk =+ hs . BS.append (BS.map (0x5c `xor`) k) .+ hs . BS.append (BS.map (0x36 `xor`) k)+ where+ k = padd $ if BS.length sk > bls then hs sk else sk+ padd bs = bs `BS.append` BS.replicate (bls - BS.length bs) 0++qlen :: Integer -> Int+qlen 0 = 0+qlen q = succ . qlen $ q `shiftR` 1++rlen :: Integer -> Int+rlen 0 = 0+rlen q = 8 + rlen (q `shiftR` 8)++blen :: BS.ByteString -> Int+blen = (8 *) . BS.length++bits2int :: Integer -> BS.ByteString -> Integer+bits2int q bs+ | bl > ql = i `shiftR` (bl - ql)+ | otherwise = i+ where+ ql = qlen q+ bl = blen bs+ i = either error id $ B.decode bs++int2octets :: Integer -> Integer -> BS.ByteString+int2octets q i+ | bl <= rl = BS.replicate (rl - bl) 0 `BS.append` bs+ | otherwise = error "Functions.int2octets: too large integer"+ where+ rl = rlen q `div` 8+ bs = B.encode i+ bl = BS.length bs++bits2octets :: Integer -> BS.ByteString -> BS.ByteString+bits2octets q bs = int2octets q $ bits2int q bs `mod` q
+ src/Network/PeyoTLS/Extension.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Extension (Extension, SignAlg(..), HashAlg(..)) where++import Control.Applicative ((<$>), (<*>))+import Data.Bits (shiftL, (.|.))+import Data.Word (Word8, Word16)++import qualified Data.ByteString as BS+import qualified Codec.Bytable as B+import qualified Crypto.Types.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC++import Network.PeyoTLS.HashSignAlgorithm(HashAlg(..), SignAlg(..))++data Extension+ = ESName [ServerName]+ | EECurve [ECC.CurveName] | EEcPFrt [EcPointFormat]+ | ESsnTicketTls BS.ByteString+ | ENextProtoNego BS.ByteString+ | ERenegoInfo BS.ByteString+ | ERaw EType BS.ByteString+ deriving Show++instance B.Bytable Extension where+ encode = encodeE; decode = B.evalBytableM B.parse++instance B.Parsable Extension where+ parse = parseE++encodeE :: Extension -> BS.ByteString+encodeE (ESName sn) = encodeE . ERaw TSName . B.addLen w16 $ cmap B.encode sn+encodeE (EECurve ec) = encodeE . ERaw TECurve . B.addLen w16 $ cmap B.encode ec+encodeE (EEcPFrt pf) = encodeE . ERaw TEcPFrt . B.addLen w8 $ cmap B.encode pf+encodeE (ESsnTicketTls stt) = encodeE $ ERaw TSsnTicketTls stt+encodeE (ENextProtoNego npn) = encodeE $ ERaw TNextProtoNego npn+encodeE (ERenegoInfo ri) = encodeE . ERaw TRenegoInfo $ B.addLen w8 ri+encodeE (ERaw et body) = B.encode et `BS.append` B.addLen w16 body++parseE :: B.BytableM Extension+parseE = do+ (t, l) <- (,) <$> B.take 2 <*> B.take 2+ case t of+ TSName -> ESName <$> (flip B.list B.parse =<< B.take 2)+ TECurve -> EECurve <$> (flip B.list (B.take 2) =<< B.take 2)+ TEcPFrt -> EEcPFrt <$> (flip B.list (B.take 1) =<< B.take 1)+ TSsnTicketTls -> ESsnTicketTls <$> B.take l+ TNextProtoNego -> ENextProtoNego <$> B.take l+ TRenegoInfo -> ERenegoInfo <$> (B.take =<< B.take 1)+ _ -> ERaw t <$> B.take l++data EType+ = TSName | TECurve | TEcPFrt | TSsnTicketTls+ | TNextProtoNego | TRenegoInfo | TRaw Word16 deriving Show++instance B.Bytable EType where+ encode TSName = B.encode (0 :: Word16)+ encode TECurve = B.encode (10 :: Word16)+ encode TEcPFrt = B.encode (11 :: Word16)+ encode TSsnTicketTls = B.encode (35 :: Word16)+ encode TNextProtoNego = B.encode (13172 :: Word16)+ encode TRenegoInfo = B.encode (65281 :: Word16)+ encode (TRaw et) = B.encode et+ decode bs = case BS.unpack bs of+ [w1, w2] -> Right $+ case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of+ 0 -> TSName+ 10 -> TECurve+ 11 -> TEcPFrt+ 35 -> TSsnTicketTls+ 13172 -> TNextProtoNego+ 65281 -> TRenegoInfo+ et -> TRaw et+ _ -> Left "Extension: EType.decode"++data ServerName = SNHostName BS.ByteString | SNRaw NameType BS.ByteString+ deriving Show++instance B.Bytable ServerName where+ encode (SNHostName nm) = B.encode $ SNRaw NTHostName nm+ encode (SNRaw nt nm) = B.encode nt `BS.append` B.addLen w16 nm+ decode = B.evalBytableM B.parse++instance B.Parsable ServerName where+ parse = do+ (t, n) <- (,) <$> B.take 1 <*> (B.take =<< B.take 2)+ return $ case t of+ NTHostName -> SNHostName n; _ -> SNRaw t n++data NameType = NTHostName | NTRaw Word8 deriving Show++instance B.Bytable NameType where+ encode NTHostName = BS.pack [0]+ encode (NTRaw t) = BS.pack [t]+ decode bs = case BS.unpack bs of+ [t] -> Right $ case t of 0 -> NTHostName; _ -> NTRaw t+ _ -> Left "Extension: NameType.decode"++instance B.Bytable DH.Params where+ encode (DH.Params p g) =+ BS.concat [B.addLen w16 $ B.encode p, B.addLen w16 $ B.encode g]+ decode = B.evalBytableM B.parse++instance B.Parsable DH.Params where+ parse = DH.Params+ <$> (B.take =<< B.take 2)+ <*> (B.take =<< B.take 2)++instance B.Bytable DH.PublicNumber where+ encode = B.addLen w16 . B.encode . \(DH.PublicNumber pn) -> pn+ decode = B.evalBytableM B.parse++instance B.Parsable DH.PublicNumber where+ parse = fromInteger <$> (B.take =<< B.take 2)++data EcCurveType = ExplicitPrime | ExplicitChar2 | NamedCurve | ECTRaw Word8+ deriving Show++instance B.Bytable EcCurveType where+ encode ExplicitPrime = BS.pack [1]+ encode ExplicitChar2 = BS.pack [2]+ encode NamedCurve = BS.pack [3]+ encode (ECTRaw w) = BS.pack [w]+ decode = B.evalBytableM B.parse++instance B.Parsable EcCurveType where+ parse = do+ ct <- B.head+ return $ case ct of+ 1 -> ExplicitPrime+ 2 -> ExplicitChar2+ 3 -> NamedCurve+ w -> ECTRaw w++instance B.Bytable ECC.CurveName where+ encode ECC.SEC_p256r1 = B.encode (23 :: Word16)+ encode ECC.SEC_p384r1 = B.encode (24 :: Word16)+ encode ECC.SEC_p521r1 = B.encode (25 :: Word16)+ encode _ = error "Extension.encodeCN: not implemented"+ decode bs = case BS.unpack bs of+ [w1, w2] -> case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of+ (23 :: Word16) -> Right ECC.SEC_p256r1+ (24 :: Word16) -> Right ECC.SEC_p384r1+ (25 :: Word16) -> Right ECC.SEC_p521r1+ n -> Left $ "Extension: CurveName.decode: unknown curve: " +++ show n+ _ -> Left "Extension: CurveName.decode: bad format"++instance B.Parsable ECC.CurveName where+ parse = B.take 2++instance B.Bytable ECC.Curve where+ encode c+ | c == ECC.getCurveByName ECC.SEC_p256r1 =+ B.encode NamedCurve `BS.append` B.encode ECC.SEC_p256r1+ | otherwise = error "TlsServer.encodeC: not implemented"+ decode = B.evalBytableM B.parse++instance B.Parsable ECC.Curve where+ parse = ECC.getCurveByName <$> do+ NamedCurve <- B.parse+ B.parse++data EcPointFormat = EPFUncompressed | EPFRaw Word8 deriving Show++instance B.Bytable EcPointFormat where+ encode EPFUncompressed = BS.pack [0]+ encode (EPFRaw f) = BS.pack [f]+ decode bs = case BS.unpack bs of+ [f] -> Right $ case f of 0 -> EPFUncompressed; _ -> EPFRaw f+ _ -> Left "Extension: Bytable.decode"++instance B.Bytable ECC.Point where+ encode (ECC.Point x y) = B.addLen w8 $+ 4 `BS.cons` padd 32 0 (B.encode x) `BS.append`+ padd 32 0 (B.encode y)+ encode ECC.PointO = error "Extension: EC.Point.encode"+ decode = B.evalBytableM B.parse++padd :: Int -> Word8 -> BS.ByteString -> BS.ByteString+padd n w s = BS.replicate (n - BS.length s) w `BS.append` s++instance B.Parsable ECC.Point where+ parse = do+ bs <- B.take =<< B.take 1+ case BS.uncons bs of+ Just (4, rest) -> return $ let (x, y) = BS.splitAt 32 rest in+ ECC.Point+ (either error id $ B.decode x)+ (either error id $ B.decode y)+ _ -> fail "Extension: ECC.Point.parse"++w8 :: Word8; w8 = undefined+w16 :: Word16; w16 = undefined++cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString+cmap = (BS.concat .) . map
+ src/Network/PeyoTLS/HandshakeBase.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports,+ TupleSections #-}++module Network.PeyoTLS.HandshakeBase (+ PeyotlsM, PeyotlsHandle,+ debug, generateKs, blindSign, CertSecretKey(..),+ HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM,+ HM.withRandom, HM.randomByteString,+ HM.TlsHandle, HM.names,+ readHandshake, getChangeCipherSpec,+ writeHandshake, putChangeCipherSpec,+ HM.ValidateHandle(..), HM.handshakeValidate,+ HM.Alert(..), HM.AlertLevel(..), HM.AlertDesc(..),+ ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+ ServerHelloDone(..),+ ClientHello(..), ServerHello(..), SessionId(..),+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ CompressionMethod(..), HashAlg(..), SignAlg(..),+ HM.setCipherSuite,+ CertificateRequest(..), certificateRequest, ClientCertificateType(..), SecretKey(..),+ ClientKeyExchange(..), Epms(..),+ HM.generateKeys,+ HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite,+ DigitallySigned(..), HM.handshakeHash, HM.flushCipherSuite,+ HM.Side(..), HM.RW(..), finishedHash,+ DhParam(..), dh3072Modp, secp256r1, HM.throwError ) where++import Control.Applicative+import Control.Arrow (first)+import Control.Monad (liftM, ap)+import "monads-tf" Control.Monad.State (gets, lift)+import Data.Word (Word8)+import Data.HandleLike (HandleLike(..))+import System.IO (Handle)+import Numeric (readHex)+import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ASN1.Types as ASN1+import qualified Data.ASN1.Encoding as ASN1+import qualified Data.ASN1.BinaryEncoding as ASN1+import qualified Codec.Bytable as B+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.Prim as RSA+import qualified Crypto.Types.PubKey.DH as DH+import qualified Crypto.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC+import qualified Crypto.PubKey.ECC.Prim as ECC+import qualified Crypto.Types.PubKey.ECDSA as ECDSA++import Network.PeyoTLS.HandshakeType (+ Handshake, HandshakeItem(..),+ ClientHello(..), ServerHello(..), SessionId(..),+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ CompressionMethod(..),+ ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+ CertificateRequest(..), certificateRequest, ClientCertificateType(..),+ SignAlg(..), HashAlg(..),+ ServerHelloDone(..), ClientKeyExchange(..), Epms(..),+ DigitallySigned(..), Finished(..) )+import qualified Network.PeyoTLS.HandshakeMonad as HM (+ TlsM, run, HandshakeM, execHandshakeM, withRandom, randomByteString,+ ValidateHandle(..), handshakeValidate,+ TlsHandle(..), ContentType(..),+ names,+ setCipherSuite, flushCipherSuite, debugCipherSuite,+ tlsGetContentType, tlsGet, tlsPut,+ generateKeys, encryptRsa, decryptRsa, rsaPadding,+ Alert(..), AlertLevel(..), AlertDesc(..),+ Side(..), RW(..), handshakeHash, finishedHash, throwError )+import Network.PeyoTLS.Ecdsa (blindSign, generateKs)++import Network.PeyoTLS.CertSecretKey++type PeyotlsM = HM.TlsM Handle SystemRNG+type PeyotlsHandle = HM.TlsHandle Handle SystemRNG++debug :: (HandleLike h, Show a) => a -> HM.HandshakeM h g ()+debug x = do+ h <- gets $ HM.tlsHandle . fst+ lift . lift . lift . hlDebug h "moderate" . BSC.pack . (++ "\n") $ show x++readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi+readHandshake = do+ cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType+ hs <- case cnt of+ CHandshake hs -> return hs+ _ -> HM.throwError+ HM.ALFatal HM.ADUnexpectedMessage+ "HandshakeBase.readHandshake: not handshake"+ case fromHandshake hs of+ Just i -> return i+ _ -> HM.throwError+ HM.ALFatal HM.ADUnexpectedMessage $+ "HandshakeBase.readHandshake: type mismatch " ++ show hs++writeHandshake ::+ (HandleLike h, CPRG g, HandshakeItem hi) => hi -> HM.HandshakeM h g ()+writeHandshake = uncurry HM.tlsPut . encodeContent . CHandshake . toHandshake++data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show++instance B.Bytable ChangeCipherSpec where+ decode bs = case BS.unpack bs of+ [1] -> Right ChangeCipherSpec+ [w] -> Right $ ChangeCipherSpecRaw w+ _ -> Left "HandshakeBase: ChangeCipherSpec.decode"+ encode ChangeCipherSpec = BS.pack [1]+ encode (ChangeCipherSpecRaw w) = BS.pack [w]++getChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g ()+getChangeCipherSpec = do+ cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType+ case cnt of+ CCCSpec ChangeCipherSpec -> return ()+ _ -> HM.throwError+ HM.ALFatal HM.ADUnexpectedMessage $+ "HandshakeBase.getChangeCipherSpec: " +++ "not change cipher spec: " +++ show cnt++putChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g ()+putChangeCipherSpec = uncurry HM.tlsPut . encodeContent $ CCCSpec ChangeCipherSpec++data Content = CCCSpec ChangeCipherSpec | CAlert Word8 Word8 | CHandshake Handshake+ deriving Show++readContent :: Monad m => (Int -> m BS.ByteString) -> HM.ContentType -> m Content+readContent rd HM.CTCCSpec = (CCCSpec . either error id . B.decode) `liftM` rd 1+readContent rd HM.CTAlert = ((\[al, ad] -> CAlert al ad) . BS.unpack) `liftM` rd 2+readContent rd HM.CTHandshake = CHandshake `liftM` do+ (t, len) <- (,) `liftM` rd 1 `ap` rd 3+ body <- rd . either error id $ B.decode len+ return . either error id . B.decode $ BS.concat [t, len, body]+readContent _ _ = undefined++encodeContent :: Content -> (HM.ContentType, BS.ByteString)+encodeContent (CCCSpec ccs) = (HM.CTCCSpec, B.encode ccs)+encodeContent (CAlert al ad) = (HM.CTAlert, BS.pack [al, ad])+encodeContent (CHandshake hss) = (HM.CTHandshake, B.encode hss)++class SecretKey sk where+ type Blinder sk+ generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g)+ sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString+ signatureAlgorithm :: sk -> SignAlg++instance SecretKey RSA.PrivateKey where+ type Blinder RSA.PrivateKey = RSA.Blinder+ generateBlinder sk rng =+ RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk+ sign hs bl sk bs = let+ (h, oid) = first ($ bs) $ case hs of+ Sha1 -> (SHA1.hash,+ ASN1.OID [1, 3, 14, 3, 2, 26])+ Sha256 -> (SHA256.hash,+ ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])+ _ -> error $ "HandshakeBase: " +++ "not implemented bulk encryption type"+ a = [ASN1.Start ASN1.Sequence,+ ASN1.Start ASN1.Sequence,+ oid, ASN1.Null, ASN1.End ASN1.Sequence,+ ASN1.OctetString h, ASN1.End ASN1.Sequence]+ b = ASN1.encodeASN1' ASN1.DER a+ pd = BS.concat [ "\x00\x01",+ BS.replicate (125 - BS.length b) 0xff, "\NUL", b ] in+ RSA.dp (Just bl) sk pd+ signatureAlgorithm _ = Rsa++instance SecretKey ECDSA.PrivateKey where+ type Blinder ECDSA.PrivateKey = Integer+ generateBlinder _ rng = let+ (Right bl, rng') = first B.decode $ cprgGenerate 32 rng in+ (bl, rng')+ sign ha bl sk = B.encode .+ (($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id)+ where+ (hs, bls) = case ha of+ Sha1 -> (SHA1.hash, 64)+ Sha256 -> (SHA256.hash, 64)+ _ -> error $ "HandshakeBase: " +++ "not implemented bulk encryption type"+ q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk+ x = ECDSA.private_d sk+ signatureAlgorithm _ = Ecdsa++class DhParam b where+ type Secret b+ type Public b+ generateSecret :: CPRG g => b -> g -> (Secret b, g)+ calculatePublic :: b -> Secret b -> Public b+ calculateShared :: b -> Secret b -> Public b -> BS.ByteString++instance DhParam DH.Params where+ type Secret DH.Params = DH.PrivateNumber+ type Public DH.Params = DH.PublicNumber+ generateSecret = flip DH.generatePrivate+ calculatePublic = DH.calculatePublic+ calculateShared ps sn pn = B.encode .+ (\(DH.SharedKey s) -> s) $ DH.getShared ps sn pn++dh3072Modp :: DH.Params+dh3072Modp = DH.Params p 2+ where [(p, "")] = readHex $+ "ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" +++ "29024e088a67cc74020bbea63b139b22514a08798e3404dd" +++ "ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" +++ "e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" +++ "ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" +++ "c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" +++ "83655d23dca3ad961c62f356208552bb9ed529077096966d" +++ "670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" +++ "e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" +++ "de2bcbf6955817183995497cea956ae515d2261898fa0510" +++ "15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" +++ "ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" +++ "abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" +++ "f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" +++ "bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" +++ "43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff"++instance DhParam ECC.Curve where+ type Secret ECC.Curve = Integer+ type Public ECC.Curve = ECC.Point+ generateSecret c = getRangedInteger 32 1 (n - 1)+ -- first (either error id . B.decode) . cprgGenerate 64+ where+ n = ECC.ecc_n $ ECC.common_curve c+ calculatePublic cv sn =+ ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv+ calculateShared cv sn pp =+ let ECC.Point x _ = ECC.pointMul cv sn pp in B.encode x++getRangedInteger :: CPRG g => Int -> Integer -> Integer -> g -> (Integer, g)+getRangedInteger b mn mx g = let+ (n, g') = first (either error id . B.decode) $ cprgGenerate b g in+ if mn <= n && n <= mx then (n, g') else getRangedInteger b mn mx g'++secp256r1 :: ECC.Curve+secp256r1 = ECC.getCurveByName ECC.SEC_p256r1++finishedHash :: (HandleLike h, CPRG g) => HM.Side -> HM.HandshakeM h g Finished+finishedHash = (Finished `liftM`) . HM.finishedHash
+ src/Network/PeyoTLS/HandshakeMonad.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}++module Network.PeyoTLS.HandshakeMonad (+ TH.TlsM, TH.run, HandshakeM, execHandshakeM, withRandom, randomByteString,+ ValidateHandle(..), handshakeValidate,+ TH.TlsHandle(..), TH.ContentType(..),+ setCipherSuite, flushCipherSuite, debugCipherSuite,+ tlsGetContentType, tlsGet, tlsPut,+ generateKeys, encryptRsa, decryptRsa, rsaPadding,+ TH.Alert(..), TH.AlertLevel(..), TH.AlertDesc(..),+ TH.Side(..), TH.RW(..), handshakeHash, finishedHash, throwError ) where++import Prelude hiding (read)++import Control.Applicative+import qualified Data.ASN1.Types as ASN1+import Control.Arrow (first)+import Control.Monad (liftM)+import "monads-tf" Control.Monad.Trans (lift)+import "monads-tf" Control.Monad.State (StateT, execStateT, get, gets, put, modify)+import qualified "monads-tf" Control.Monad.Error as E (throwError)+import "monads-tf" Control.Monad.Error.Class (strMsg)+import Data.HandleLike (HandleLike(..))+import System.IO (Handle)+import "crypto-random" Crypto.Random (CPRG)++import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Data.X509.Validation as X509+import qualified Data.X509.CertificateStore as X509+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.PubKey.HashDescr as HD+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as RSA++import qualified Network.PeyoTLS.TlsHandle as TH (+ TlsM, Alert(..), AlertLevel(..), AlertDesc(..),+ run, withRandom, randomByteString,+ TlsHandle(..), ContentType(..),+ newHandle, getContentType, tlsGet, tlsPut, generateKeys,+ cipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite,+ Side(..), RW(..), finishedHash, handshakeHash, CipherSuite(..) )++throwError :: HandleLike h =>+ TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a+throwError al ad m = E.throwError $ TH.Alert al ad m++type HandshakeM h g = StateT (TH.TlsHandle h g, SHA256.Ctx) (TH.TlsM h g)++execHandshakeM :: HandleLike h =>+ h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle h g)+execHandshakeM h =+ liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT++withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a+withRandom = lift . TH.withRandom++randomByteString :: (HandleLike h, CPRG g) => Int -> HandshakeM h g BS.ByteString+randomByteString = lift . TH.randomByteString++class HandleLike h => ValidateHandle h where+ validate :: h -> X509.CertificateStore -> X509.CertificateChain ->+ HandleMonad h [X509.FailedReason]++instance ValidateHandle Handle where+ validate _ cs = X509.validate X509.HashSHA256 X509.defaultHooks+ validationChecks cs validationCache ("", "")+ where+ validationCache = X509.ValidationCache+ (\_ _ _ -> return X509.ValidationCacheUnknown)+ (\_ _ _ -> return ())+ validationChecks = X509.defaultChecks { X509.checkFQHN = False }++certNames :: X509.Certificate -> [String]+certNames = nms+ where+ nms c = maybe id (:) <$> nms_ <*> ans $ c+ nms_ = (ASN1.asn1CharacterToString =<<) .+ X509.getDnElement X509.DnCommonName . X509.certSubjectDN+ ans = maybe [] ((\ns -> [s | X509.AltNameDNS s <- ns])+ . \(X509.ExtSubjectAltName ns) -> ns)+ . X509.extensionGet . X509.certExtensions++handshakeValidate :: ValidateHandle h =>+ X509.CertificateStore -> X509.CertificateChain ->+ HandshakeM h g [X509.FailedReason]+handshakeValidate cs cc@(X509.CertificateChain (c : _)) = gets fst >>= \t -> do+ modify . first $ const t { TH.names = certNames $ X509.getCertificate c }+ lift . lift . lift $ validate (TH.tlsHandle t) cs cc+handshakeValidate _ _ = error "empty certificate chain"++setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g ()+setCipherSuite = modify . first . TH.setCipherSuite++flushCipherSuite :: (HandleLike h, CPRG g) => TH.RW -> HandshakeM h g ()+flushCipherSuite p =+ TH.flushCipherSuite p `liftM` gets fst >>= modify . first . const++debugCipherSuite :: HandleLike h => String -> HandshakeM h g ()+debugCipherSuite m = do t <- gets fst; lift $ TH.debugCipherSuite t m++tlsGetContentType :: (HandleLike h, CPRG g) => HandshakeM h g TH.ContentType+tlsGetContentType = gets fst >>= lift . TH.getContentType++tlsGet :: (HandleLike h, CPRG g) => Int -> HandshakeM h g BS.ByteString+tlsGet n = do ((_, bs), t') <- lift . flip TH.tlsGet n =<< get; put t'; return bs++tlsPut :: (HandleLike h, CPRG g) =>+ TH.ContentType -> BS.ByteString -> HandshakeM h g ()+tlsPut ct bs = get >>= lift . (\t -> TH.tlsPut t ct bs) >>= put++generateKeys :: HandleLike h => TH.Side ->+ (BS.ByteString, BS.ByteString) -> BS.ByteString -> HandshakeM h g ()+generateKeys p (cr, sr) pms = do+ t <- gets fst+ k <- lift $ TH.generateKeys p (TH.cipherSuite t) cr sr pms+ modify . first $ const t { TH.keys = k }++encryptRsa :: (HandleLike h, CPRG g) =>+ RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString+encryptRsa pk p = either (E.throwError . strMsg . show) return =<<+ withRandom (\g -> RSA.encrypt g pk p)++decryptRsa :: (HandleLike h, CPRG g) =>+ RSA.PrivateKey -> BS.ByteString -> HandshakeM h g BS.ByteString+decryptRsa sk e = either (E.throwError . strMsg . show) return =<<+ withRandom (\g -> RSA.decryptSafer g sk e)++rsaPadding :: RSA.PublicKey -> BS.ByteString -> BS.ByteString+rsaPadding pk bs = case RSA.padSignature (RSA.public_size pk) $+ HD.digestToASN1 HD.hashDescrSHA256 bs of+ Right pd -> pd; Left m -> error $ show m++handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString+handshakeHash = get >>= lift . TH.handshakeHash++finishedHash :: (HandleLike h, CPRG g) => TH.Side -> HandshakeM h g BS.ByteString+finishedHash p = get >>= lift . flip TH.finishedHash p
+ src/Network/PeyoTLS/HandshakeType.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.HandshakeType (+ Handshake, HandshakeItem(..),+ ClientHello(..), ServerHello(..), SessionId(..),+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ CompressionMethod(..),+ ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+ CertificateRequest(..), certificateRequest, ClientCertificateType(..),+ SignAlg(..), HashAlg(..),+ ServerHelloDone(..), ClientKeyExchange(..), Epms(..),+ DigitallySigned(..), Finished(..) ) where++import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8, Word16)+import Data.Word.Word24 (Word24)++import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Codec.Bytable as B+import qualified Crypto.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC++import Network.PeyoTLS.Hello (+ ClientHello(..), ServerHello(..), SessionId(..),+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ CompressionMethod(..), HashAlg(..), SignAlg(..) )+import Network.PeyoTLS.Certificate (+ CertificateRequest(..), certificateRequest, ClientCertificateType(..),+ ClientKeyExchange(..), DigitallySigned(..) )++data Handshake+ = HClientHello ClientHello | HServerHello ServerHello+ | HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString+ | HCertificateReq CertificateRequest | HServerHelloDone+ | HCertVerify DigitallySigned | HClientKeyEx ClientKeyExchange+ | HFinished BS.ByteString | HRaw Type BS.ByteString+ deriving Show++instance B.Bytable Handshake where+ decode = B.evalBytableM B.parse; encode = encodeH++instance B.Parsable Handshake where+ parse = do+ t <- B.take 1+ len <- B.take 3+ case t of+ TClientHello -> HClientHello <$> B.take len+ TServerHello -> HServerHello <$> B.take len+ TCertificate -> HCertificate <$> B.take len+ TServerKeyEx -> HServerKeyEx <$> B.take len+ TCertificateReq -> HCertificateReq <$> B.take len+ TServerHelloDone -> let 0 = len in return HServerHelloDone+ TCertVerify -> HCertVerify <$> B.take len+ TClientKeyEx -> HClientKeyEx <$> B.take len+ TFinished -> HFinished <$> B.take len+ _ -> HRaw t <$> B.take len++encodeH :: Handshake -> BS.ByteString+encodeH (HClientHello ch) = encodeH . HRaw TClientHello $ B.encode ch+encodeH (HServerHello sh) = encodeH . HRaw TServerHello $ B.encode sh+encodeH (HCertificate crts) = encodeH . HRaw TCertificate $ B.encode crts+encodeH (HServerKeyEx ske) = encodeH $ HRaw TServerKeyEx ske+encodeH (HCertificateReq cr) = encodeH . HRaw TCertificateReq $ B.encode cr+encodeH HServerHelloDone = encodeH $ HRaw TServerHelloDone ""+encodeH (HCertVerify ds) = encodeH . HRaw TCertVerify $ B.encode ds+encodeH (HClientKeyEx epms) = encodeH . HRaw TClientKeyEx $ B.encode epms+encodeH (HFinished bs) = encodeH $ HRaw TFinished bs+encodeH (HRaw t bs) = B.encode t `BS.append` B.addLen (undefined :: Word24) bs++class HandshakeItem hi where+ fromHandshake :: Handshake -> Maybe hi;+ toHandshake :: hi -> Handshake++instance (HandshakeItem l, HandshakeItem r) => HandshakeItem (Either l r) where+ fromHandshake hs = let+ l = fromHandshake hs+ r = fromHandshake hs in maybe (Right <$> r) (Just . Left) l+ toHandshake (Left l) = toHandshake l+ toHandshake (Right r) = toHandshake r++instance HandshakeItem ClientHello where+ fromHandshake (HClientHello ch) = Just ch+ fromHandshake _ = Nothing+ toHandshake = HClientHello++instance HandshakeItem ServerHello where+ fromHandshake (HServerHello sh) = Just sh+ fromHandshake _ = Nothing+ toHandshake = HServerHello++instance HandshakeItem X509.CertificateChain where+ fromHandshake (HCertificate cc) = Just cc+ fromHandshake _ = Nothing+ toHandshake = HCertificate++data ServerKeyExchange = ServerKeyEx BS.ByteString BS.ByteString+ HashAlg SignAlg BS.ByteString deriving Show++data ServerKeyExDhe = ServerKeyExDhe DH.Params DH.PublicNumber+ HashAlg SignAlg BS.ByteString deriving Show++data ServerKeyExEcdhe = ServerKeyExEcdhe ECC.Curve ECC.Point+ HashAlg SignAlg BS.ByteString deriving Show++instance HandshakeItem ServerKeyExchange where+ fromHandshake = undefined+ toHandshake = HServerKeyEx . B.encode++instance HandshakeItem ServerKeyExDhe where+ toHandshake = HServerKeyEx . B.encode+ fromHandshake (HServerKeyEx ske) =+ either (const Nothing) Just $ B.decode ske+ fromHandshake _ = Nothing++instance HandshakeItem ServerKeyExEcdhe where+ toHandshake = HServerKeyEx . B.encode+ fromHandshake (HServerKeyEx ske) =+ either (const Nothing) Just $ B.decode ske+ fromHandshake _ = Nothing++instance B.Bytable ServerKeyExchange where+ decode = undefined+ encode (ServerKeyEx ps pv ha sa sn) = BS.concat [+ ps, pv, B.encode ha, B.encode sa,+ B.addLen (undefined :: Word16) sn ]++instance B.Bytable ServerKeyExDhe where+ encode (ServerKeyExDhe ps pv ha sa sn) = BS.concat [+ B.encode ps, B.encode pv, B.encode ha, B.encode sa,+ B.addLen (undefined :: Word16) sn ]+ decode = B.evalBytableM B.parse++instance B.Bytable ServerKeyExEcdhe where+ encode (ServerKeyExEcdhe cv pnt ha sa sn) = BS.concat [+ B.encode cv, B.encode pnt, B.encode ha, B.encode sa,+ B.addLen (undefined :: Word16) sn ]+ decode = B.evalBytableM B.parse++instance B.Parsable ServerKeyExDhe where+ parse = do+ ps <- B.parse+ pv <- B.parse+ (ha, sa, sn) <- hasasn+ return $ ServerKeyExDhe ps pv ha sa sn++instance B.Parsable ServerKeyExEcdhe where+ parse = do+ cv <- B.parse+ pnt <- B.parse+ (ha, sa, sn) <- hasasn+ return $ ServerKeyExEcdhe cv pnt ha sa sn++hasasn :: B.BytableM (HashAlg, SignAlg, BS.ByteString)+hasasn = (,,) <$> B.parse <*> B.parse <*> (B.take =<< B.take 2)++instance HandshakeItem CertificateRequest where+ fromHandshake (HCertificateReq cr) = Just cr+ fromHandshake _ = Nothing+ toHandshake = HCertificateReq++instance HandshakeItem ServerHelloDone where+ fromHandshake HServerHelloDone = Just ServerHelloDone+ fromHandshake _ = Nothing+ toHandshake _ = HServerHelloDone++instance HandshakeItem DigitallySigned where+ fromHandshake (HCertVerify ds) = Just ds+ fromHandshake _ = Nothing+ toHandshake = HCertVerify++instance HandshakeItem ClientKeyExchange where+ fromHandshake (HClientKeyEx cke) = Just cke+ fromHandshake _ = Nothing+ toHandshake = HClientKeyEx++data Epms = Epms BS.ByteString++instance HandshakeItem Epms where+ fromHandshake (HClientKeyEx cke) = ckeToEpms cke+ fromHandshake _ = Nothing+ toHandshake = HClientKeyEx . epmsToCke++ckeToEpms :: ClientKeyExchange -> Maybe Epms+ckeToEpms (ClientKeyExchange cke) = case B.runBytableM (B.take =<< B.take 2) cke of+ Right (e, "") -> Just $ Epms e+ _ -> Nothing++epmsToCke :: Epms -> ClientKeyExchange+epmsToCke (Epms epms) = ClientKeyExchange $ B.addLen (undefined :: Word16) epms++data Finished = Finished BS.ByteString deriving (Show, Eq)++instance HandshakeItem Finished where+ fromHandshake (HFinished f) = Just $ Finished f+ fromHandshake _ = Nothing+ toHandshake (Finished f) = HFinished f++data ServerHelloDone = ServerHelloDone deriving Show++data Type+ = TClientHello | TServerHello+ | TCertificate | TServerKeyEx | TCertificateReq | TServerHelloDone+ | TCertVerify | TClientKeyEx | TFinished | TRaw Word8+ deriving Show++instance B.Bytable Type where+ decode bs = case BS.unpack bs of+ [1] -> Right TClientHello+ [2] -> Right TServerHello+ [11] -> Right TCertificate+ [12] -> Right TServerKeyEx+ [13] -> Right TCertificateReq+ [14] -> Right TServerHelloDone+ [15] -> Right TCertVerify+ [16] -> Right TClientKeyEx+ [20] -> Right TFinished+ [ht] -> Right $ TRaw ht+ _ -> Left "Handshake.decodeT"+ encode TClientHello = BS.pack [1]+ encode TServerHello = BS.pack [2]+ encode TCertificate = BS.pack [11]+ encode TServerKeyEx = BS.pack [12]+ encode TCertificateReq = BS.pack [13]+ encode TServerHelloDone = BS.pack [14]+ encode TCertVerify = BS.pack [15]+ encode TClientKeyEx = BS.pack [16]+ encode TFinished = BS.pack [20]+ encode (TRaw w) = BS.pack [w]
+ src/Network/PeyoTLS/HashSignAlgorithm.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.HashSignAlgorithm (SignAlg(..), HashAlg(..)) where++import Data.Word (Word8)++import qualified Data.ByteString as BS+import qualified Codec.Bytable as B+import Codec.Bytable.BigEndian ()++data HashAlg = Sha1 | Sha224 | Sha256 | Sha384 | Sha512 | HARaw Word8+ deriving Show++instance B.Bytable HashAlg where+ encode Sha1 = "\x02"+ encode Sha224 = "\x03"+ encode Sha256 = "\x04"+ encode Sha384 = "\x05"+ encode Sha512 = "\x06"+ encode (HARaw w) = BS.pack [w]+ decode bs = case BS.unpack bs of+ [ha] -> Right $ case ha of+ 2 -> Sha1 ; 3 -> Sha224; 4 -> Sha256+ 5 -> Sha384; 6 -> Sha512; _ -> HARaw ha+ _ -> Left "HashSignAlgorithm: Bytable.decode"++instance B.Parsable HashAlg where+ parse = B.take 1++data SignAlg = Rsa | Dsa | Ecdsa | SARaw Word8 deriving (Show, Eq)++instance B.Bytable SignAlg where+ encode Rsa = "\x01"+ encode Dsa = "\x02"+ encode Ecdsa = "\x03"+ encode (SARaw w) = BS.pack [w]+ decode bs = case BS.unpack bs of+ [sa] -> Right $ case sa of+ 1 -> Rsa; 2 -> Dsa; 3 -> Ecdsa; _ -> SARaw sa+ _ -> Left "Type.decodeSA"++instance B.Parsable SignAlg where+ parse = B.take 1
+ src/Network/PeyoTLS/Hello.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.Hello (+ ClientHello(..), ServerHello(..), SessionId(..),+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ CompressionMethod(..),+ SignAlg(..), HashAlg(..) ) where++import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8, Word16)+import Numeric (showHex)++import qualified Data.ByteString as BS+import qualified Codec.Bytable as B++import Network.PeyoTLS.Extension (Extension, SignAlg(..), HashAlg(..))+import Network.PeyoTLS.CipherSuite (+ CipherSuite(..), KeyExchange(..), BulkEncryption(..))++data ClientHello+ = ClientHello (Word8, Word8) BS.ByteString SessionId+ [CipherSuite] [CompressionMethod] (Maybe [Extension])+ | ClientHelloRaw BS.ByteString+ deriving Show++instance B.Bytable ClientHello where+ decode = B.evalBytableM $ do+ (pv, r, sid) <- (,,) <$> ((,) <$> B.head <*> B.head)+ <*> B.take 32 <*> (B.take =<< B.take 1)+ cs <- flip B.list (B.take 2) =<< B.take 2+ cm <- flip B.list (B.take 1) =<< B.take 1+ nl <- B.null+ me <- if nl then return Nothing else+ Just <$> (flip B.list B.parse =<< B.take 2)+ return $ ClientHello pv r sid cs cm me+ encode = encodeCh++encodeCh :: ClientHello -> BS.ByteString+encodeCh (ClientHello (vmjr, vmnr) r sid css cms mel) = BS.concat [+ B.encode vmjr, B.encode vmnr, B.encode r,+ B.addLen (undefined :: Word8) $ B.encode sid,+ B.addLen (undefined :: Word16) . BS.concat $ map B.encode css,+ B.addLen (undefined :: Word8) . BS.concat $ map B.encode cms,+ maybe "" (B.addLen (undefined :: Word16) . BS.concat . map B.encode) mel ]+encodeCh (ClientHelloRaw bs) = bs++data ServerHello+ = ServerHello (Word8, Word8) BS.ByteString SessionId+ CipherSuite CompressionMethod (Maybe [Extension])+ | ServerHelloRaw BS.ByteString+ deriving Show++instance B.Bytable ServerHello where+ decode = B.evalBytableM $ do+ (pv, r, sid) <- (,,) <$> ((,) <$> B.head <*> B.head)+ <*> B.take 32 <*> (B.take =<< B.take 1)+ cs <- B.take 2+ cm <- B.take 1+ e <- B.null+ me <- if e then return Nothing else do+ mel <- B.take 2+ Just <$> B.list mel B.parse+ return $ ServerHello pv r sid cs cm me+ encode = encodeSh++encodeSh :: ServerHello -> BS.ByteString+encodeSh (ServerHello (vmjr, vmnr) r sid cs cm mes) = BS.concat [+ B.encode vmjr, B.encode vmnr, B.encode r,+ B.addLen (undefined :: Word8) $ B.encode sid,+ B.encode cs, B.encode cm,+ maybe "" (B.addLen (undefined :: Word16) . BS.concat . map B.encode) mes ]+encodeSh (ServerHelloRaw sh) = sh++data CompressionMethod = CompressionMethodNull | CompressionMethodRaw Word8+ deriving (Show, Eq)++instance B.Bytable CompressionMethod where+ decode bs = case BS.unpack bs of+ [cm] -> Right $ case cm of+ 0 -> CompressionMethodNull+ _ -> CompressionMethodRaw cm+ _ -> Left "Hello.decodeCm"+ encode CompressionMethodNull = "\0"+ encode (CompressionMethodRaw cm) = BS.pack [cm]++data SessionId = SessionId BS.ByteString++instance Show SessionId where+ show (SessionId sid) = "(SessionID " +++ concatMap (`showHex` "") (BS.unpack sid) ++ ")"++instance B.Bytable SessionId where+ decode = Right . SessionId+ encode (SessionId bs) = bs
+ src/Network/PeyoTLS/ReadFile.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections #-}++module Network.PeyoTLS.ReadFile (+ CertSecretKey, readKey, readCertificateChain, readCertificateStore) where++import Control.Applicative ((<$>), (<*>))+import Control.Arrow ((***))+import Control.Monad (unless)++import qualified Data.ByteString as BS+import qualified Data.ASN1.Types as ASN1+import qualified Data.ASN1.Encoding as ASN1+import qualified Data.ASN1.BinaryEncoding as ASN1+import qualified Data.ASN1.BitArray as ASN1+import qualified Data.PEM as PEM+import qualified Data.X509 as X509+import qualified Data.X509.File as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable as B+import Codec.Bytable.BigEndian ()+import qualified Crypto.PubKey.ECC.Prim as ECC+import qualified Crypto.Types.PubKey.ECC as ECC+import qualified Crypto.Types.PubKey.ECDSA as ECDSA++import Network.PeyoTLS.CertSecretKey++readKey :: FilePath -> IO CertSecretKey+readKey fp = do+ rk <- readRsaKey fp+ maybe (readEcdsaKey fp) return rk++readRsaKey :: FilePath -> IO (Maybe CertSecretKey)+readRsaKey fp = do+ ks <- X509.readKeyFile fp+ case ks of+ [X509.PrivKeyRSA sk] -> return . Just $ RsaKey sk+ _ -> return Nothing -- error "ReadFile.readRsaKey: not single RSA key"++readEcdsaKey :: FilePath -> IO CertSecretKey+readEcdsaKey = (EcdsaKey . either error id . decodeEcdsaKey <$>) . BS.readFile++readCertificateChain :: FilePath -> IO X509.CertificateChain+readCertificateChain = (X509.CertificateChain <$>) . X509.readSignedObject++readCertificateStore :: [FilePath] -> IO X509.CertificateStore+readCertificateStore =+ (X509.makeCertificateStore . concat <$>) . mapM X509.readSignedObject++decodeEcdsaKey :: BS.ByteString -> Either String ECDSA.PrivateKey+decodeEcdsaKey bs = do+ pms <- either (Left . show) return $ PEM.pemParseBS bs+ pm <- fromSinglePem pms+ pmc <- case pm of+ PEM.PEM { PEM.pemName = "EC PRIVATE KEY", PEM.pemHeader = [],+ PEM.pemContent = c } -> return c+ _ -> Left $ msgp ++ "bad PEM structure"+ asn <- either (Left . show) return $ ASN1.decodeASN1' ASN1.DER pmc+ (sk, oid, pk) <- case asn of+ [ASN1.Start ASN1.Sequence,+ ASN1.IntVal 1,+ ASN1.OctetString s,+ ASN1.Start (ASN1.Container ASN1.Context 0),+ o, ASN1.End (ASN1.Container ASN1.Context 0),+ ASN1.Start (ASN1.Container ASN1.Context 1),+ ASN1.BitString (ASN1.BitArray _pl p),+ ASN1.End (ASN1.Container ASN1.Context 1),+ ASN1.End ASN1.Sequence] -> (, o, p) <$> B.decode s+ _ -> Left $ msgp ++ "bad ASN.1 structure"+ unless (oid == oidSecp256r1) . Left $ msgp ++ "not implemented curve"+ tpk <- case BS.uncons pk of+ Just (4, t) -> return t+ _ -> Left $ msgp ++ "not implemented point format"+ (x, y) <- (\(ex, ey) -> (,) <$> ex <*> ey) .+ (B.decode *** B.decode) $ BS.splitAt 32 tpk+ unless (ECC.Point x y == ECC.pointMul secp256r1 sk g) .+ Left $ msgp ++ "the public key not match"+ return $ ECDSA.PrivateKey secp256r1 sk+ where+ msgp = "ReadFile.decodeEcdsaKey: "+ fromSinglePem [x] = return x+ fromSinglePem _ = Left $ msgp ++ "not single PEM"+ g = ECC.ecc_g $ ECC.common_curve secp256r1+ secp256r1 = ECC.getCurveByName ECC.SEC_p256r1+ oidSecp256r1 = ASN1.OID [1, 2, 840, 10045, 3, 1, 7]
+ src/Network/PeyoTLS/Server.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, FlexibleContexts,+ PackageImports #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Server (+ run, open, names,+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ PeyotlsM, PeyotlsHandle,+ TlsM, TlsHandle,+ ValidateHandle(..), CertSecretKey ) where++import Control.Monad (unless, liftM, ap)+import "monads-tf" Control.Monad.Error (catchError)+import qualified "monads-tf" Control.Monad.Error as E (throwError)+import "monads-tf" Control.Monad.Error.Class (strMsg)+import Data.List (find)+import Data.Word (Word8)+import Data.HandleLike (HandleLike(..))+import "crypto-random" Crypto.Random (CPRG)++import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Data.X509.Validation as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable as B+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.Prim as RSA+import qualified Crypto.Types.PubKey.ECC as ECC+import qualified Crypto.Types.PubKey.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA++import Network.PeyoTLS.HandshakeBase (+ PeyotlsM, PeyotlsHandle,+ TlsM, run, HandshakeM, execHandshakeM, withRandom, randomByteString,+ TlsHandle, names,+ readHandshake, getChangeCipherSpec,+ writeHandshake, putChangeCipherSpec,+ ValidateHandle(..), handshakeValidate,+ AlertLevel(..), AlertDesc(..),+ ServerKeyExchange(..), ServerHelloDone(..),+ ClientHello(..), ServerHello(..), SessionId(..),+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ CompressionMethod(..), HashAlg(..), SignAlg(..),+ setCipherSuite,+ certificateRequest, ClientCertificateType(..), SecretKey(..),+ ClientKeyExchange(..), Epms(..),+ generateKeys, decryptRsa, rsaPadding, debugCipherSuite,+ DigitallySigned(..), handshakeHash, flushCipherSuite,+ Side(..), RW(..), finishedHash,+ DhParam(..), dh3072Modp, secp256r1, throwError,+ CertSecretKey(..) )++type Version = (Word8, Word8)++version :: Version+version = (3, 3)++filterCS :: [(CertSecretKey, X509.CertificateChain)] ->+ [CipherSuite] -> [CipherSuite]+filterCS crts cs = case find isEcdsa crts of+ Just _ -> cs+ _ -> filter (not . isEcdsaCS) cs++isEcdsa :: (CertSecretKey, X509.CertificateChain) -> Bool+isEcdsa (EcdsaKey _, _) = True+isEcdsa _ = False++isRsa :: (CertSecretKey, X509.CertificateChain) -> Bool+isRsa (RsaKey _, _) = True+isRsa _ = False++isEcdsaCS :: CipherSuite -> Bool+isEcdsaCS (CipherSuite ECDHE_ECDSA _) = True+isEcdsaCS _ = False++open :: (ValidateHandle h, CPRG g) => h ->+ [CipherSuite] ->+ [(CertSecretKey, X509.CertificateChain)] ->+ Maybe X509.CertificateStore -> TlsM h g (TlsHandle h g)+open h cssv crts mcs = execHandshakeM h $ do+ (cs@(CipherSuite ke be), cr, cv) <- clientHello $ filterCS crts cssv+ sr <- serverHello cs rcc ecc+ setCipherSuite cs+ ha <- case be of+ AES_128_CBC_SHA -> return Sha1+ AES_128_CBC_SHA256 -> return Sha256+ _ -> E.throwError+ "TlsServer.open: not implemented bulk encryption type"+ mpk <- (\kep -> kep (cr, sr) mcs) $ case ke of+ RSA -> rsaKeyExchange rsk cv+ DHE_RSA -> dhKeyExchange ha dh3072Modp rsk+ ECDHE_RSA -> dhKeyExchange ha secp256r1 rsk+ ECDHE_ECDSA -> dhKeyExchange ha secp256r1 esk+ _ -> \_ _ -> E.throwError+ "TlsServer.open: not implemented key exchange type"+ maybe (return ()) certificateVerify mpk+ getChangeCipherSpec >> flushCipherSuite Read+ fok <- (==) `liftM` finishedHash Client `ap` readHandshake+ unless fok $ throwError ALFatal ADDecryptError+ "TlsServer.open: wrong finished hash"+ putChangeCipherSpec >> flushCipherSuite Write+ writeHandshake =<< finishedHash Server+ where+ Just (RsaKey rsk, rcc) = find isRsa crts+ Just (EcdsaKey esk, ecc) = find isEcdsa crts++rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version ->+ (BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore ->+ HandshakeM h g (Maybe X509.PubKey)+rsaKeyExchange rsk cv rs mcs = return const+ `ap` requestAndCertificate mcs+ `ap` rsaClientKeyExchange rsk cv rs++dhKeyExchange :: (ValidateHandle h, CPRG g, SecretKey sk, Show (Secret dp),+ Show (Public dp),+ DhParam dp, B.Bytable dp, B.Bytable (Public dp)) =>+ HashAlg -> dp -> sk ->+ (BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore ->+ HandshakeM h g (Maybe X509.PubKey)+dhKeyExchange ha dp ssk rs mcs = do+ sv <- withRandom $ generateSecret dp+ serverKeyExchange ha dp sv ssk rs+ return const+ `ap` requestAndCertificate mcs+ `ap` dhClientKeyExchange dp sv rs++clientHello :: (HandleLike h, CPRG g) =>+ [CipherSuite] -> HandshakeM h g (CipherSuite, BS.ByteString, Version)+clientHello cssv = do+ ClientHello cv cr _sid cscl cms _ <- readHandshake+ chk cv cscl cms >> return (merge cssv cscl, cr, cv)+ where+ merge sv cl = case find (`elem` cl) sv of+ Just cs -> cs; _ -> CipherSuite RSA AES_128_CBC_SHA+ chk cv css cms+ | cv < version = throwError ALFatal ADProtocolVersion $+ pmsg ++ "client version should 3.3 or more"+ | CipherSuite RSA AES_128_CBC_SHA `notElem` css =+ throwError ALFatal ADIllegalParameter $+ pmsg ++ "TLS_RSA_AES_128_CBC_SHA must be supported"+ | CompressionMethodNull `notElem` cms =+ throwError ALFatal ADDecodeError $+ pmsg ++ "compression method NULL must be supported"+ | otherwise = return ()+ where pmsg = "TlsServer.clientHello: "++serverHello :: (HandleLike h, CPRG g) => CipherSuite ->+ X509.CertificateChain -> X509.CertificateChain ->+ HandshakeM h g BS.ByteString+serverHello cs@(CipherSuite ke _) rcc ecc = do+ sr <- randomByteString 32+ writeHandshake $ ServerHello+ version sr (SessionId "") cs CompressionMethodNull Nothing+ writeHandshake $ case ke of ECDHE_ECDSA -> ecc; _ -> rcc+ return sr+serverHello _ _ _ = E.throwError "TlsServer.serverHello: never occur"++serverKeyExchange :: (HandleLike h, CPRG g, SecretKey sk,+ DhParam dp, B.Bytable dp, B.Bytable (Public dp)) =>+ HashAlg -> dp -> Secret dp -> sk ->+ (BS.ByteString, BS.ByteString) -> HandshakeM h g ()+serverKeyExchange ha dp sv ssk (cr, sr) = do+ bl <- withRandom $ generateBlinder ssk+ writeHandshake+ . ServerKeyEx edp pv ha (signatureAlgorithm ssk)+ . sign ha bl ssk $ BS.concat [cr, sr, edp, pv]+ where+ edp = B.encode dp+ pv = B.encode $ calculatePublic dp sv++requestAndCertificate :: (ValidateHandle h, CPRG g) =>+ Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey)+requestAndCertificate mcs = do+ flip (maybe $ return ()) mcs $ writeHandshake . certificateRequest+ [CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)]+ writeHandshake ServerHelloDone+ maybe (return Nothing) (liftM Just . clientCertificate) mcs++clientCertificate :: (ValidateHandle h, CPRG g) =>+ X509.CertificateStore -> HandshakeM h g X509.PubKey+clientCertificate cs = do+ cc@(X509.CertificateChain (c : _)) <- readHandshake+ chk cc -- >> setClientNames (certNames $ X509.getCertificate c)+ return . X509.certPubKey $ X509.getCertificate c+ where+ chk cc = do+ rs <- handshakeValidate cs cc+ unless (null rs) . throwError ALFatal (selectAlert rs) $+ "TlsServer.clientCertificate: " ++ show rs+ selectAlert rs+ | X509.UnknownCA `elem` rs = ADUnknownCa+ | X509.Expired `elem` rs = ADCertificateExpired+ | X509.InFuture `elem` rs = ADCertificateExpired+ | otherwise = ADCertificateUnknown++rsaClientKeyExchange :: (HandleLike h, CPRG g) => RSA.PrivateKey ->+ Version -> (BS.ByteString, BS.ByteString) -> HandshakeM h g ()+rsaClientKeyExchange sk (cvj, cvn) rs = do+ Epms epms <- readHandshake+ generateKeys Server rs =<< mkpms epms `catchError` const+ ((BS.cons cvj . BS.cons cvn) `liftM` randomByteString 46)+ where+ mkpms epms = do+ pms <- decryptRsa sk epms+ unless (BS.length pms == 48) $ E.throwError "mkpms: length"+ case BS.unpack $ BS.take 2 pms of+ [pvj, pvn] -> unless (pvj == cvj && pvn == cvn) $+ E.throwError "mkpms: version"+ _ -> E.throwError "mkpms: never occur"+ return pms++dhClientKeyExchange :: (HandleLike h, CPRG g, DhParam dp, B.Bytable (Public dp),+ Show (Public dp)) =>+ dp -> Secret dp -> (BS.ByteString, BS.ByteString) -> HandshakeM h g ()+dhClientKeyExchange dp sv rs = do+ ClientKeyExchange cke <- readHandshake+ let Right pv = B.decode cke+ generateKeys Server rs =<< case Right $ calculateShared dp sv pv of+ Left em -> E.throwError . strMsg $+ "TlsServer.dhClientKeyExchange: " ++ em+ Right sh -> return sh++certificateVerify :: (HandleLike h, CPRG g) => X509.PubKey -> HandshakeM h g ()+certificateVerify (X509.PubKeyRSA pk) = do+ debugCipherSuite "RSA"+ hs0 <- rsaPadding pk `liftM` handshakeHash+ DigitallySigned a s <- readHandshake+ case a of+ (Sha256, Rsa) -> return ()+ _ -> throwError ALFatal ADDecodeError $+ "TlsServer.certificateVEerify: not implement: " ++ show a+ unless (RSA.ep pk s == hs0) $ throwError ALFatal ADDecryptError+ "TlsServer.certificateVerify: client auth failed "+certificateVerify (X509.PubKeyECDSA ECC.SEC_p256r1 xy) = do+ debugCipherSuite "ECDSA"+ hs0 <- handshakeHash+ DigitallySigned a s <- readHandshake+ case a of+ (Sha256, Ecdsa) -> return ()+ _ -> throwError ALFatal ADDecodeError $+ "TlsServer.certificateverify: not implement: " ++ show a+ unless (ECDSA.verify id+ (ECDSA.PublicKey secp256r1 $ pnt xy)+ (either error id $ B.decode s) hs0) $ throwError+ ALFatal ADDecryptError+ "TlsServer.certificateverify: client auth failed"+ where+ pnt s = let (x, y) = BS.splitAt 32 $ BS.drop 1 s in ECC.Point+ (either error id $ B.decode x)+ (either error id $ B.decode y)+certificateVerify p = throwError ALFatal ADUnsupportedCertificate $+ "TlsServer.certificateVerify: not implement: " ++ show p
+ src/Network/PeyoTLS/State.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}++module Network.PeyoTLS.State (+ HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys,+ ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..),+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ randomGen, setRandomGen,+ getBuf, setBuf, getWBuf, setWBuf,+ getReadSN, getWriteSN, succReadSN, succWriteSN,+) where++import "monads-tf" Control.Monad.Error.Class (Error(strMsg))+import Data.Maybe (fromJust)+import Data.Word (Word8, Word64)+import Data.String (IsString(..))++import qualified Data.ByteString as BS+import qualified Codec.Bytable as B++import Network.PeyoTLS.CipherSuite (+ CipherSuite(..), KeyExchange(..), BulkEncryption(..))++data HandshakeState h g = HandshakeState {+ randomGen :: g, nextPartnerId :: Int,+ states :: [(PartnerId, StateOne g)] }++initState :: g -> HandshakeState h g+initState g = HandshakeState{ randomGen = g, nextPartnerId = 0, states = [] }++data PartnerId = PartnerId Int deriving (Show, Eq)++newPartnerId :: HandshakeState h g -> (PartnerId, HandshakeState h g)+newPartnerId s = (PartnerId i ,) s{+ nextPartnerId = succ i,+ states = (PartnerId i, so) : sos }+ where+ i = nextPartnerId s+ so = StateOne {+ rBuffer = (CTNull, ""), wBuffer = (CTNull, ""),+ readSN = 0, writeSN = 0 }+ sos = states s++data StateOne g = StateOne {+ rBuffer :: (ContentType, BS.ByteString),+ wBuffer :: (ContentType, BS.ByteString),+ readSN :: Word64, writeSN :: Word64 }++getState :: PartnerId -> HandshakeState h g -> StateOne g+getState i = fromJust' "getState" . lookup i . states++setState :: PartnerId -> StateOne g -> Modify (HandshakeState h g)+setState i so s = s { states = (i, so) : states s }++modifyState :: PartnerId -> Modify (StateOne g) -> Modify (HandshakeState h g)+modifyState i f s = setState i (f $ getState i s) s++data Keys = Keys {+ kCachedCS :: CipherSuite,+ kReadCS :: CipherSuite, kWriteCS :: CipherSuite,+ kMasterSecret :: BS.ByteString,+ kReadMacKey :: BS.ByteString, kWriteMacKey :: BS.ByteString,+ kReadKey :: BS.ByteString, kWriteKey :: BS.ByteString }+ deriving (Show, Eq)++nullKeys :: Keys+nullKeys = Keys {+ kCachedCS = CipherSuite KE_NULL BE_NULL,+ kReadCS = CipherSuite KE_NULL BE_NULL,+ kWriteCS = CipherSuite KE_NULL BE_NULL,+ kMasterSecret = "",+ kReadMacKey = "", kWriteMacKey = "", kReadKey = "", kWriteKey = "" }++data ContentType+ = CTCCSpec | CTAlert | CTHandshake | CTAppData | CTNull | CTRaw Word8+ deriving (Show, Eq)++instance B.Bytable ContentType where+ encode CTNull = BS.pack [0]+ encode CTCCSpec = BS.pack [20]+ encode CTAlert = BS.pack [21]+ encode CTHandshake = BS.pack [22]+ encode CTAppData = BS.pack [23]+ encode (CTRaw ct) = BS.pack [ct]+ decode "\0" = Right CTNull+ decode "\20" = Right CTCCSpec+ decode "\21" = Right CTAlert+ decode "\22" = Right CTHandshake+ decode "\23" = Right CTAppData+ decode bs | [ct] <- BS.unpack bs = Right $ CTRaw ct+ decode _ = Left "State.decodeCT"++data Alert = Alert AlertLevel AlertDesc String | NotDetected String+ deriving Show++data AlertLevel = ALWarning | ALFatal | ALRaw Word8 deriving Show++data AlertDesc+ = ADCloseNotify | ADUnexpectedMessage | ADBadRecordMac+ | ADUnsupportedCertificate | ADCertificateExpired | ADCertificateUnknown+ | ADIllegalParameter | ADUnknownCa | ADDecodeError+ | ADDecryptError | ADProtocolVersion | ADRaw Word8+ deriving Show++instance Error Alert where+ strMsg = NotDetected++instance IsString Alert where+ fromString = NotDetected++setRandomGen :: g -> HandshakeState h g -> HandshakeState h g+setRandomGen rg st = st { randomGen = rg }++getBuf :: PartnerId -> HandshakeState h g -> (ContentType, BS.ByteString)+getBuf i = rBuffer . fromJust' "getBuf" . lookup i . states++setBuf :: PartnerId -> (ContentType, BS.ByteString) -> Modify (HandshakeState h g)+setBuf i = modifyState i . \bs st -> st { rBuffer = bs }++getWBuf :: PartnerId -> HandshakeState h g -> (ContentType, BS.ByteString)+getWBuf i = wBuffer . fromJust' "getWriteBuffer" . lookup i . states++setWBuf :: PartnerId -> (ContentType, BS.ByteString) -> Modify (HandshakeState h g)+setWBuf i = modifyState i . \bs st -> st{ wBuffer = bs }++getReadSN, getWriteSN :: PartnerId -> HandshakeState h g -> Word64+getReadSN i = readSN . fromJust . lookup i . states+getWriteSN i = writeSN . fromJust . lookup i . states++succReadSN, succWriteSN :: PartnerId -> Modify (HandshakeState h g)+succReadSN i = modifyState i $ \s -> s{ readSN = succ $ readSN s }+succWriteSN i = modifyState i $ \s -> s{ writeSN = succ $ writeSN s }++type Modify s = s -> s++fromJust' :: String -> Maybe a -> a+fromJust' _ (Just x) = x+fromJust' msg _ = error msg
+ src/Network/PeyoTLS/TlsHandle.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-}++module Network.PeyoTLS.TlsHandle (+ TlsM, Alert(..), AlertLevel(..), AlertDesc(..),+ run, withRandom, randomByteString,+ TlsHandle(..), RW(..), Side(..), ContentType(..), CipherSuite(..),+ newHandle, getContentType, tlsGet, tlsPut, generateKeys,+ cipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite,+ handshakeHash, finishedHash ) where++import Prelude hiding (read)++import Control.Applicative ((<$>), (<*>))+import Control.Arrow (second)+import Control.Monad (liftM, when, unless)+import "monads-tf" Control.Monad.State (get, put, lift)+import "monads-tf" Control.Monad.Error (throwError, catchError)+import "monads-tf" Control.Monad.Error.Class (strMsg)+import Data.Word (Word16, Word64)+import Data.HandleLike (HandleLike(..))+import "crypto-random" Crypto.Random (CPRG)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Codec.Bytable as B+import qualified Crypto.Hash.SHA256 as SHA256++import Network.PeyoTLS.TlsMonad (+ TlsM, evalTlsM, initState, thlGet, thlPut, thlClose, thlDebug,+ withRandom, randomByteString, getBuf, setBuf, getWBuf, setWBuf,+ getReadSn, getWriteSn, succReadSn, succWriteSn,+ Alert(..), AlertLevel(..), AlertDesc(..),+ ContentType(..), CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ PartnerId, newPartnerId, Keys(..), nullKeys )+import qualified Network.PeyoTLS.CryptoTools as CT (+ makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash )++data TlsHandle h g = TlsHandle {+ clientId :: PartnerId,+ tlsHandle :: h, keys :: Keys, names :: [String] }++type HandleHash h g = (TlsHandle h g, SHA256.Ctx)++data Side = Server | Client deriving (Show, Eq)++run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a+run m g = do+ ret <- (`evalTlsM` initState g) $ m `catchError` \a -> throwError a+ case ret of+ Right r -> return r+ Left a -> error $ show a++newHandle :: HandleLike h => h -> TlsM h g (TlsHandle h g)+newHandle h = do+ s <- get+ let (i, s') = newPartnerId s+ put s'+ return TlsHandle {+ clientId = i, tlsHandle = h, keys = nullKeys, names = [] }++getContentType :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ContentType+getContentType t = do+ ct <- fst `liftM` getBuf (clientId t)+ (\gt -> case ct of CTNull -> gt; _ -> return ct) $ do+ (ct', bf) <- getWholeWithCt t+ setBuf (clientId t) (ct', bf)+ return ct'++tlsGet :: (HandleLike h, CPRG g) => HandleHash h g ->+ Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g)+tlsGet hh@(t, _) n = do+ r@(ct, bs) <- buffered t n+ (r ,) `liftM` case ct of+ CTHandshake -> updateHash hh bs+ _ -> return hh++buffered :: (HandleLike h, CPRG g) =>+ TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString)+buffered t n = do+ (ct, b) <- getBuf $ clientId t; let rl = n - BS.length b+ if rl <= 0+ then do let (ret, b') = BS.splitAt n b+ setBuf (clientId t) $ if BS.null b' then (CTNull, "") else (ct, b')+ return (ct, ret)+ else do (ct', b') <- getWholeWithCt t+ unless (ct' == ct) . throwError . strMsg $+ "Content Type confliction\n" +++ "\tExpected: " ++ show ct ++ "\n" +++ "\tActual : " ++ show ct' ++ "\n" +++ "\tData : " ++ show b'+ when (BS.null b') $ throwError "buffered: No data available"+ setBuf (clientId t) (ct', b')+ second (b `BS.append`) `liftM` buffered t rl++getWholeWithCt :: (HandleLike h, CPRG g) =>+ TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+getWholeWithCt t = do+ flush t+ ct <- (either (throwError . strMsg) return . B.decode) =<< read t 1+ [_vmj, _vmn] <- BS.unpack `liftM` read t 2+ e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2+ when (BS.null e) $ throwError "TlsHandle.getWholeWithCt: e is null"+ p <- decrypt t ct e+ return (ct, p)++read :: (HandleLike h, CPRG g) => TlsHandle h g -> Int -> TlsM h g BS.ByteString+read t n = do+ r <- thlGet (tlsHandle t) n+ unless (BS.length r == n) . throwError . strMsg $+ "TlsHandle.read: can't read " ++ show (BS.length r) ++ " " ++ show n+ return r++decrypt :: HandleLike h =>+ TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+decrypt t _ e+ | Keys{ kReadCS = CipherSuite _ BE_NULL } <- keys t = return e+decrypt t@TlsHandle{ keys = ks } ct e = do+ let CipherSuite _ be = kReadCS ks+ wk = kReadKey ks+ mk = kReadMacKey ks+ sn <- updateSequenceNumber t Read+ hs <- case be of+ AES_128_CBC_SHA -> return CT.hashSha1+ AES_128_CBC_SHA256 -> return CT.hashSha256+ _ -> throwError "TlsHandle.decrypt: not implement bulk encryption"+ either (throwError . strMsg) return $+ CT.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e++tlsPut :: (HandleLike h, CPRG g) =>+ HandleHash h g -> ContentType -> BS.ByteString -> TlsM h g (HandleHash h g)+tlsPut hh@(t, _) ct p = do+ (bct, bp) <- getWBuf $ clientId t+ case ct of+ CTCCSpec -> flush t >> setWBuf (clientId t) (ct, p) >> flush t+ _ | bct /= CTNull && ct /= bct ->+ flush t >> setWBuf (clientId t) (ct, p)+ | otherwise -> setWBuf (clientId t) (ct, bp `BS.append` p)+ case ct of+ CTHandshake -> updateHash hh p+ _ -> return hh++flush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ()+flush t = do+ (bct, bp) <- getWBuf $ clientId t+ setWBuf (clientId t) (CTNull, "")+ unless (bct == CTNull) $ do+ e <- encrypt t bct bp+ thlPut (tlsHandle t) $ BS.concat [+ B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ]++encrypt :: (HandleLike h, CPRG g) =>+ TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+encrypt t _ p+ | Keys{ kWriteCS = CipherSuite _ BE_NULL } <- keys t = return p+encrypt t@TlsHandle{ keys = ks } ct p = do+ let CipherSuite _ be = kWriteCS ks+ wk = kWriteKey ks+ mk = kWriteMacKey ks+ sn <- updateSequenceNumber t Write+ hs <- case be of+ AES_128_CBC_SHA -> return CT.hashSha1+ AES_128_CBC_SHA256 -> return CT.hashSha256+ _ -> throwError "TlsHandle.encrypt: not implemented bulk encryption"+ withRandom $ CT.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p++updateHash ::+ HandleLike h => HandleHash h g -> BS.ByteString -> TlsM h g (HandleHash h g)+updateHash (th, ctx') bs = return (th, SHA256.update ctx' bs)++updateSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g Word64+updateSequenceNumber t@TlsHandle{ keys = ks } rw = do+ (sn, cs) <- case rw of+ Read -> (, kReadCS ks) `liftM` getReadSn (clientId t)+ Write -> (, kWriteCS ks) `liftM` getWriteSn (clientId t)+ case cs of+ CipherSuite _ BE_NULL -> return ()+ _ -> case rw of+ Read -> succReadSn $ clientId t+ Write -> succWriteSn $ clientId t+ return sn++generateKeys :: HandleLike h => Side -> CipherSuite ->+ BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys+generateKeys p cs cr sr pms = do+ let CipherSuite _ be = cs+ kl <- case be of+ AES_128_CBC_SHA -> return 20+ AES_128_CBC_SHA256 -> return 32+ _ -> throwError+ "TlsServer.generateKeys: not implemented bulk encryption"+ let (ms, cwmk, swmk, cwk, swk) = CT.makeKeys kl cr sr pms+ return $ case p of+ Client -> Keys {+ kCachedCS = cs,+ kReadCS = CipherSuite KE_NULL BE_NULL,+ kWriteCS = CipherSuite KE_NULL BE_NULL,+ kMasterSecret = ms,+ kReadMacKey = swmk, kWriteMacKey = cwmk,+ kReadKey = swk, kWriteKey = cwk }+ Server -> Keys {+ kCachedCS = cs,+ kReadCS = CipherSuite KE_NULL BE_NULL,+ kWriteCS = CipherSuite KE_NULL BE_NULL,+ kMasterSecret = ms,+ kReadMacKey = cwmk, kWriteMacKey = swmk,+ kReadKey = cwk, kWriteKey = swk }++cipherSuite :: TlsHandle h g -> CipherSuite+cipherSuite = kCachedCS . keys++setCipherSuite :: CipherSuite -> TlsHandle h g -> TlsHandle h g+setCipherSuite c t@TlsHandle{ keys = k } = t{ keys = k{ kCachedCS = c } }++data RW = Read | Write deriving Show++flushCipherSuite :: RW -> TlsHandle h g -> TlsHandle h g+flushCipherSuite p t@TlsHandle{ keys = ks } = case p of+ Read -> t{ keys = ks { kReadCS = kCachedCS ks } }+ Write -> t{ keys = ks { kWriteCS = kCachedCS ks } }++debugCipherSuite :: HandleLike h => TlsHandle h g -> String -> TlsM h g ()+debugCipherSuite t a = thlDebug (tlsHandle t) "moderate" . BSC.pack+ . (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50+ . show . kCachedCS $ keys t+ where lenSpace n str = str ++ replicate (n - length str) ' '++handshakeHash :: HandleLike h => HandleHash h g -> TlsM h g BS.ByteString+handshakeHash = return . SHA256.finalize . snd++finishedHash :: HandleLike h => HandleHash h g -> Side -> TlsM h g BS.ByteString+finishedHash (t, ctx) partner = do+ let ms = kMasterSecret $ keys t+ sha256 <- handshakeHash (t, ctx)+ return $ CT.finishedHash (partner == Client) ms sha256++instance (HandleLike h, CPRG g) => HandleLike (TlsHandle h g) where+ type HandleMonad (TlsHandle h g) = TlsM h g+ type DebugLevel (TlsHandle h g) = DebugLevel h+ hlPut = ((>> return ()) .) . flip tlsPut CTAppData . (, undefined)+ hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .) . tlsGet . (, undefined)+ hlGetLine = ($) <$> checkAppData <*> tGetLine+ hlGetContent = ($) <$> checkAppData <*> tGetContent+ hlDebug t l = lift . lift . hlDebug (tlsHandle t) l+ hlClose t = tlsPut (t, undefined) CTAlert "\SOH\NUL" >>+ flush t >> thlClose (tlsHandle t)++tGetLine :: (HandleLike h, CPRG g) =>+ TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+tGetLine t = do+ (bct, bp) <- getBuf $ clientId t+ case splitLine bp of+ Just (l, ls) -> setBuf (clientId t) (bct, ls) >> return (bct, l)+ _ -> do cp <- getWholeWithCt t+ setBuf (clientId t) cp+ second (bp `BS.append`) `liftM` tGetLine t++splitLine :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)+splitLine bs = case ('\r' `BSC.elem` bs, '\n' `BSC.elem` bs) of+ (True, _) -> let+ (l, ls) = BSC.span (/= '\r') bs+ Just ('\r', ls') = BSC.uncons ls in+ case BSC.uncons ls' of+ Just ('\n', ls'') -> Just (l, ls'')+ _ -> Just (l, ls')+ (_, True) -> let+ (l, ls) = BSC.span (/= '\n') bs+ Just ('\n', ls') = BSC.uncons ls in Just (l, ls')+ _ -> Nothing++tGetContent :: (HandleLike h, CPRG g) =>+ TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+tGetContent t = do+ bcp@(_, bp) <- getBuf $ clientId t+ if BS.null bp then getWholeWithCt t else+ setBuf (clientId t) (CTNull, BS.empty) >> return bcp++checkAppData :: (HandleLike h, CPRG g) => TlsHandle h g ->+ TlsM h g (ContentType, BS.ByteString) -> TlsM h g BS.ByteString+checkAppData t m = m >>= \cp -> case cp of+ (CTAppData, ad) -> return ad+ (CTAlert, "\SOH\NUL") -> do+ _ <- tlsPut (t, undefined) CTAlert "\SOH\NUL"+ throwError "TlsHandle.checkAppData: EOF"+ _ -> do _ <- tlsPut (t, undefined) CTAlert "\2\10"+ throwError "TlsHandle.checkAppData: not application data"
+ src/Network/PeyoTLS/TlsMonad.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE PackageImports #-}++module Network.PeyoTLS.TlsMonad (+ TlsM, evalTlsM, S.initState,+ thlGet, thlPut, thlClose, thlDebug, thlError,+ withRandom, randomByteString, getBuf, setBuf, getWBuf, setWBuf,+ getReadSn, getWriteSn, succReadSn, succWriteSn,+ S.Alert(..), S.AlertLevel(..), S.AlertDesc(..),+ S.ContentType(..),+ S.CipherSuite(..), S.KeyExchange(..), S.BulkEncryption(..),+ S.PartnerId, S.newPartnerId, S.Keys(..), S.nullKeys ) where++import Control.Monad (liftM)+import "monads-tf" Control.Monad.Trans (lift)+import "monads-tf" Control.Monad.State (StateT, evalStateT, gets, modify)+import "monads-tf" Control.Monad.Error (ErrorT, runErrorT)+import Data.Word (Word64)+import Data.HandleLike (HandleLike(..))+import "crypto-random" Crypto.Random (CPRG, cprgGenerate)++import qualified Data.ByteString as BS++import qualified Network.PeyoTLS.State as S (+ HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys,+ ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..),+ CipherSuite(..), KeyExchange(..), BulkEncryption(..),+ randomGen, setRandomGen,+ setBuf, getBuf, setWBuf, getWBuf,+ getReadSN, getWriteSN, succReadSN, succWriteSN )++type TlsM h g = ErrorT S.Alert (StateT (S.HandshakeState h g) (HandleMonad h))++evalTlsM :: HandleLike h => + TlsM h g a -> S.HandshakeState h g -> HandleMonad h (Either S.Alert a)+evalTlsM = evalStateT . runErrorT++getBuf, getWBuf :: HandleLike h =>+ S.PartnerId -> TlsM h g (S.ContentType, BS.ByteString)+getBuf = gets . S.getBuf; getWBuf = gets . S.getWBuf++setBuf, setWBuf :: HandleLike h =>+ S.PartnerId -> (S.ContentType, BS.ByteString) -> TlsM h g ()+setBuf = (modify .) . S.setBuf; setWBuf = (modify .) . S.setWBuf++getWriteSn, getReadSn :: HandleLike h => S.PartnerId -> TlsM h g Word64+getWriteSn = gets . S.getWriteSN; getReadSn = gets . S.getReadSN++succWriteSn, succReadSn :: HandleLike h => S.PartnerId -> TlsM h g ()+succWriteSn = modify . S.succWriteSN; succReadSn = modify . S.succReadSN++withRandom :: HandleLike h => (gen -> (a, gen)) -> TlsM h gen a+withRandom p = do+ (x, g') <- p `liftM` gets S.randomGen+ modify $ S.setRandomGen g'+ return x++randomByteString :: (HandleLike h, CPRG g) => Int -> TlsM h g BS.ByteString+randomByteString = withRandom . cprgGenerate++thlGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString+thlGet = ((lift . lift) .) . hlGet++thlPut :: HandleLike h => h -> BS.ByteString -> TlsM h g ()+thlPut = ((lift . lift) .) . hlPut++thlClose :: HandleLike h => h -> TlsM h g ()+thlClose = lift . lift . hlClose++thlDebug :: HandleLike h =>+ h -> DebugLevel h -> BS.ByteString -> TlsM h gen ()+thlDebug = (((lift . lift) .) .) . hlDebug++thlError :: HandleLike h => h -> BS.ByteString -> TlsM h g a+thlError = ((lift . lift) .) . hlError
+ test/testClient.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TypeFamilies, PackageImports #-}++import Control.Applicative+import Control.Monad+import Control.Concurrent+import "crypto-random" Crypto.Random++import TestClient+import Data.HandleLike++import Control.Concurrent.STM+import qualified Data.ByteString as BS+import System.IO+import CommandLine+import System.Environment++import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509++import TestServer++cipherSuites :: [CipherSuite]+cipherSuites = [+ CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256,+ CipherSuite ECDHE_ECDSA AES_128_CBC_SHA,+ CipherSuite ECDHE_RSA AES_128_CBC_SHA256,+ CipherSuite ECDHE_RSA AES_128_CBC_SHA,+ CipherSuite DHE_RSA AES_128_CBC_SHA256,+ CipherSuite DHE_RSA AES_128_CBC_SHA,+ CipherSuite RSA AES_128_CBC_SHA256,+ CipherSuite RSA AES_128_CBC_SHA+ ]++len :: Int+len = length cipherSuites - 1++main :: IO ()+main = do+ forM_ (map (`drop` cipherSuites) [len, len - 1 .. 0]) runRsa+ forM_ (map (`drop` cipherSuites) [len, len - 1 .. 0]) ecdsa++runRsa :: [CipherSuite] -> IO ()+runRsa cs = do+ (cw, sw) <- getPair+ _ <- forkIO $ srv sw cs+ (rsk, rcc, crtS) <- readFiles+ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ client g cw [(rsk, rcc)] crtS++ecdsa :: [CipherSuite] -> IO ()+ecdsa cs = do+ (cw, sw) <- getPair+ _ <- forkIO $ srv sw cs+ (rsk, rcc, crtS) <- readFilesEcdsa+ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ client g cw [(rsk, rcc)] crtS++srv :: ChanHandle -> [CipherSuite] -> IO ()+srv sw cs = do+ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ (_prt, _cs, rsa, ec, mcs, _td) <- readOptions =<< getArgs+ server g sw cs rsa ec mcs++readFiles :: IO (CertSecretKey, X509.CertificateChain, X509.CertificateStore)+readFiles = (,,)+ <$> readPathKey "certs/yoshikuni.sample_key"+ <*> readPathCertificateChain "certs/yoshikuni.sample_crt"+ <*> readPathCertificateStore ["certs/cacert.pem"]++readFilesEcdsa :: IO+ (CertSecretKey, X509.CertificateChain, X509.CertificateStore)+readFilesEcdsa = (,,)+ <$> readPathKey "certs/client_ecdsa.sample_key"+ <*> readPathCertificateChain "certs/client_ecdsa.sample_crt"+ <*> readPathCertificateStore ["certs/cacert.pem"]++data ChanHandle = ChanHandle (TChan BS.ByteString) (TChan BS.ByteString)++instance HandleLike ChanHandle where+ type HandleMonad ChanHandle = IO+ hlPut (ChanHandle _ w) = atomically . writeTChan w+ hlGet h@(ChanHandle r _) n = do+ (b, l, bs) <- atomically $ do+ bs <- readTChan r+ let l = BS.length bs+ if l < n+ then return (True, l, bs)+ else do let (x, y) = BS.splitAt n bs+ unGetTChan r y+ return (False, l, x)+ if b then (bs `BS.append`) <$> hlGet h (n - l)+ else return bs+ hlDebug _ _ = BS.putStr+ hlClose _ = return ()++instance ValidateHandle ChanHandle where+ validate _ = validate (undefined :: Handle)++getPair :: IO (ChanHandle, ChanHandle)+getPair = do+ c1 <- newTChanIO+ c2 <- newTChanIO+ return (ChanHandle c1 c2, ChanHandle c2 c1)