diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2014, Yoshikuni Jujo +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of the Yoshikuni Jujo nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data/certs/cacert.pem b/data/certs/cacert.pem new file mode 100644 --- /dev/null +++ b/data/certs/cacert.pem @@ -0,0 +1,60 @@ +Certificate: + Data: + Version: 3 (0x2) + Serial Number: + a6:ea:4f:7c:d6:d9:87:67 + Signature Algorithm: sha1WithRSAEncryption + Issuer: C=JP, ST=Gunma, O=Yoshikuni Co.,Ltd., CN=skami4592.iocikun.jp + Validity + Not Before: Apr 26 02:13:01 2014 GMT + Not After : Apr 25 02:13:01 2017 GMT + Subject: C=JP, ST=Gunma, O=Yoshikuni Co.,Ltd., CN=skami4592.iocikun.jp + Subject Public Key Info: + Public Key Algorithm: rsaEncryption + Public-Key: (1024 bit) + Modulus: + 00:f4:d1:4b:f7:1f:99:65:73:ea:df:4f:66:9d:90: + 2a:1b:e5:31:b3:da:6c:35:07:a7:ff:3d:de:69:ff: + cc:24:fd:1c:58:c1:de:c5:33:c8:4d:60:06:a6:cf: + d9:30:bf:05:47:01:63:db:90:92:df:48:b5:8b:6d: + 4a:00:d5:4e:66:47:a5:3b:c0:5f:f4:ea:34:71:f1: + fa:c5:0d:dd:c9:69:ef:20:ef:e0:a7:1c:c0:3a:9f: + 6c:42:8b:cd:bb:82:44:e7:aa:e1:11:8e:34:f3:b7: + c7:73:2d:c6:c8:98:8a:66:68:68:30:1d:f2:0c:f7: + 72:e6:06:76:fd:05:7d:ef:e9 + Exponent: 65537 (0x10001) + X509v3 extensions: + X509v3 Subject Key Identifier: + 50:46:D5:F3:87:0B:5C:51:D0:A3:68:44:41:DB:D4:E3:89:DE:78:38 + X509v3 Authority Key Identifier: + keyid:50:46:D5:F3:87:0B:5C:51:D0:A3:68:44:41:DB:D4:E3:89:DE:78:38 + + X509v3 Basic Constraints: + CA:TRUE + X509v3 Key Usage: + Certificate Sign, CRL Sign + Signature Algorithm: sha1WithRSAEncryption + 98:24:01:e7:4a:fa:7c:72:22:bc:eb:88:3d:6f:3e:8f:b0:9c: + ed:98:93:95:09:7d:d5:cb:ba:fe:7b:7f:59:e0:6d:5a:cc:c6: + df:98:1b:0b:5b:cc:a0:f8:ee:1b:c4:8c:a5:f2:ba:4c:54:b3: + ff:3f:cc:b1:81:74:0a:5a:30:76:a8:99:fc:67:d4:27:6e:5c: + a4:a2:30:93:f2:45:86:8c:0b:bc:cb:58:75:3e:05:cf:db:84: + e8:39:04:f2:9c:e1:44:26:2b:93:5d:ce:e6:61:13:58:dd:45: + 38:39:33:66:71:ea:5b:d4:0e:40:32:94:83:b6:0f:2d:2a:29: + 9e:b4 +-----BEGIN CERTIFICATE----- +MIICjTCCAfagAwIBAgIJAKbqT3zW2YdnMA0GCSqGSIb3DQEBBQUAMFkxCzAJBgNV +BAYTAkpQMQ4wDAYDVQQIDAVHdW5tYTEbMBkGA1UECgwSWW9zaGlrdW5pIENvLixM +dGQuMR0wGwYDVQQDDBRza2FtaTQ1OTIuaW9jaWt1bi5qcDAeFw0xNDA0MjYwMjEz +MDFaFw0xNzA0MjUwMjEzMDFaMFkxCzAJBgNVBAYTAkpQMQ4wDAYDVQQIDAVHdW5t +YTEbMBkGA1UECgwSWW9zaGlrdW5pIENvLixMdGQuMR0wGwYDVQQDDBRza2FtaTQ1 +OTIuaW9jaWt1bi5qcDCBnzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEA9NFL9x+Z +ZXPq309mnZAqG+Uxs9psNQen/z3eaf/MJP0cWMHexTPITWAGps/ZML8FRwFj25CS +30i1i21KANVOZkelO8Bf9Oo0cfH6xQ3dyWnvIO/gpxzAOp9sQovNu4JE56rhEY40 +87fHcy3GyJiKZmhoMB3yDPdy5gZ2/QV97+kCAwEAAaNdMFswHQYDVR0OBBYEFFBG +1fOHC1xR0KNoREHb1OOJ3ng4MB8GA1UdIwQYMBaAFFBG1fOHC1xR0KNoREHb1OOJ +3ng4MAwGA1UdEwQFMAMBAf8wCwYDVR0PBAQDAgEGMA0GCSqGSIb3DQEBBQUAA4GB +AJgkAedK+nxyIrzriD1vPo+wnO2Yk5UJfdXLuv57f1ngbVrMxt+YGwtbzKD47hvE +jKXyukxUs/8/zLGBdApaMHaomfxn1CduXKSiMJPyRYaMC7zLWHU+Bc/bhOg5BPKc +4UQmK5NdzuZhE1jdRTg5M2Zx6lvUDkAylIO2Dy0qKZ60 +-----END CERTIFICATE----- diff --git a/data/certs/client_ecdsa.sample_crt b/data/certs/client_ecdsa.sample_crt new file mode 100644 --- /dev/null +++ b/data/certs/client_ecdsa.sample_crt @@ -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----- diff --git a/data/certs/client_ecdsa.sample_key b/data/certs/client_ecdsa.sample_key new file mode 100644 --- /dev/null +++ b/data/certs/client_ecdsa.sample_key @@ -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----- diff --git a/data/certs/localhost.sample_crt b/data/certs/localhost.sample_crt new file mode 100644 --- /dev/null +++ b/data/certs/localhost.sample_crt @@ -0,0 +1,17 @@ +-----BEGIN CERTIFICATE----- +MIICszCCAhygAwIBAgIJAKbqT3zW2YdoMA0GCSqGSIb3DQEBBQUAMFkxCzAJBgNV +BAYTAkpQMQ4wDAYDVQQIDAVHdW5tYTEbMBkGA1UECgwSWW9zaGlrdW5pIENvLixM +dGQuMR0wGwYDVQQDDBRza2FtaTQ1OTIuaW9jaWt1bi5qcDAeFw0xNDA0MjYwMjE1 +MDZaFw0xNTA0MjYwMjE1MDZaMGExCzAJBgNVBAYTAkpQMQ4wDAYDVQQIDAVHdW5t +YTERMA8GA1UEBwwIVGFrYXNha2kxGzAZBgNVBAoMEllvc2hpa3VuaSBDby4sTHRk +LjESMBAGA1UEAwwJbG9jYWxob3N0MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB +gQDKDeMfXFUK9YCNC4J+BVghnmxDH1lVmjQdZnVEy9zaBQ+pUeTV8XkTlfvMvFpo +JBxhXGijGD24HE2nHnLYjICxnah5Bg2LPAqOcze2JESZx0oUCTiNX0Co0Na80hoM +vXZgU9FfJp4D0Fb+t85QHbJ8Cfke2xv1nOwXo2s+iY1+OwIDAQABo3sweTAJBgNV +HRMEAjAAMCwGCWCGSAGG+EIBDQQfFh1PcGVuU1NMIEdlbmVyYXRlZCBDZXJ0aWZp +Y2F0ZTAdBgNVHQ4EFgQUCZmhAC/aukdc2wFKdtgSj8nGW1kwHwYDVR0jBBgwFoAU +UEbV84cLXFHQo2hEQdvU44neeDgwDQYJKoZIhvcNAQEFBQADgYEAoYLLedvBcYBh +zTqormeGuSTxTgM92hLHm21YCDSkeYNSik1LLsm3vxo/mwKFhGaoOvtiX4z1CCKX ++qic0X4XOyhXADg/WS29h06A2E4JaAnhOn4ZhtayaBa0uS8I047VmhfpiySAcg36 +SaMp6HRIBsK1zUrTrFEhpT+XXeOnHaY= +-----END CERTIFICATE----- diff --git a/data/certs/localhost.sample_key b/data/certs/localhost.sample_key new file mode 100644 --- /dev/null +++ b/data/certs/localhost.sample_key @@ -0,0 +1,15 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICXQIBAAKBgQDKDeMfXFUK9YCNC4J+BVghnmxDH1lVmjQdZnVEy9zaBQ+pUeTV +8XkTlfvMvFpoJBxhXGijGD24HE2nHnLYjICxnah5Bg2LPAqOcze2JESZx0oUCTiN +X0Co0Na80hoMvXZgU9FfJp4D0Fb+t85QHbJ8Cfke2xv1nOwXo2s+iY1+OwIDAQAB +AoGBAMHBMWO4ScC5jS0ztU2dWFbcsRporGTe+0yaHKf9CepzYgJPCq5x4VX7xDse +/17QCfr+/0QukbjEQ16XXy/zA9AZUtIwzFXYZGu3+0pDIIfKQH7MzIuOCghncxwI +YwSN4cibgt3m9z+2xAHuY6R/dwzpDjz8el4VjJR7yMjRdj4pAkEA9ZJjCN1HuhKA +IsvdJKGrCfspAsvEu7ma62Fj43LFC3tvaHuqT6NX5YH3hD/fadCETooicrXafx7j +r+AG3T/3pwJBANKia6HTWz/OTUwUMVn1lq3cP5kjqJ1QJDmxR285vlY057t4FMN4 +c2Sm1vxUVgqEFXn97v2lmwujntB+hJNwF00CQQClccdI/JPLV5V+W+yUNlseMVkS +6ieT9drag9WhMfxw3OtU8CPw3XJlTGducP3as0HADC5jLAOVq0Doh7z4KJV3AkAM +fVEAgXXRrLvsnO3oNaW/nWWwAOtImK3tNdPUhooAtpZfCVnB1WySNUpeH+oSKY7U +cvgu1hkBcaxDFJ1r2KOpAkBbhCr5rDXRmHy0j+Txb4DbyIpjpP9lCRPiiPrN43Xh +8a+/mVx3mz2aaJkQV74JbcqyO4RUV5JOti8doh1Wpp7L +-----END RSA PRIVATE KEY----- diff --git a/data/certs/localhost_ecdsa.sample_crt b/data/certs/localhost_ecdsa.sample_crt new file mode 100644 --- /dev/null +++ b/data/certs/localhost_ecdsa.sample_crt @@ -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----- diff --git a/data/certs/localhost_ecdsa.sample_key b/data/certs/localhost_ecdsa.sample_key new file mode 100644 --- /dev/null +++ b/data/certs/localhost_ecdsa.sample_key @@ -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----- diff --git a/data/certs/yoshikuni.sample_crt b/data/certs/yoshikuni.sample_crt new file mode 100644 --- /dev/null +++ b/data/certs/yoshikuni.sample_crt @@ -0,0 +1,17 @@ +-----BEGIN CERTIFICATE----- +MIICqjCCAhOgAwIBAgIJAKbqT3zW2YdrMA0GCSqGSIb3DQEBBQUAMFkxCzAJBgNV +BAYTAkpQMQ4wDAYDVQQIDAVHdW5tYTEbMBkGA1UECgwSWW9zaGlrdW5pIENvLixM +dGQuMR0wGwYDVQQDDBRza2FtaTQ1OTIuaW9jaWt1bi5qcDAeFw0xNDA1MDcwMzIx +MTdaFw0xNTA1MDcwMzIxMTdaMFgxCzAJBgNVBAYTAkpQMQ4wDAYDVQQIDAVHdW5t +YTERMA8GA1UEBwwIVGFrYXNha2kxEjAQBgNVBAoMCVlvc2hpa3VuaTESMBAGA1UE +AwwJWW9zaGlrdW5pMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDUZ8SMZSKO +9MSHkydQKqAvNe2UClkhEedTw4iu13NQMmaB0Oy1H2qaNKkJXqVM0nOJi2/J9dNF +gSenOr4Yqmit7kCSlsTqCpFCN81FcIcsF+gpujeSRgZktJFe5dPNjw38wTWzofx9 +Pid/36978+Y4T+kg7EZSVQQ0tkrJQWRJvwIDAQABo3sweTAJBgNVHRMEAjAAMCwG +CWCGSAGG+EIBDQQfFh1PcGVuU1NMIEdlbmVyYXRlZCBDZXJ0aWZpY2F0ZTAdBgNV +HQ4EFgQU3RXgXkT0Tw1FxYgNhipYgeCAzLkwHwYDVR0jBBgwFoAUUEbV84cLXFHQ +o2hEQdvU44neeDgwDQYJKoZIhvcNAQEFBQADgYEAUMIzOZIIQe7QMKakuLjCN/XC ++gViRzIPL4lh6X6N9kwW0onHXyo6nTJ7Lv4FXePRJyV9ApjTjmriu0Wyyer6frB3 +ey1EXw+XreNwveo6op0wSvpJhATGo2XjikT1G5DBDokO6EKKKFPQzsHfJWHwXz/r +AlKFnCmiYMcIlDrHidA= +-----END CERTIFICATE----- diff --git a/data/certs/yoshikuni.sample_key b/data/certs/yoshikuni.sample_key new file mode 100644 --- /dev/null +++ b/data/certs/yoshikuni.sample_key @@ -0,0 +1,15 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICXAIBAAKBgQDUZ8SMZSKO9MSHkydQKqAvNe2UClkhEedTw4iu13NQMmaB0Oy1 +H2qaNKkJXqVM0nOJi2/J9dNFgSenOr4Yqmit7kCSlsTqCpFCN81FcIcsF+gpujeS +RgZktJFe5dPNjw38wTWzofx9Pid/36978+Y4T+kg7EZSVQQ0tkrJQWRJvwIDAQAB +AoGAFcNoHSaDqvgjZuzJ+2nSreOtqxyAU2YdOLTxPVDwDMiNPkHk7w4AAzrgEwiy +kTODCRXTZ3MbqaR5JqZbMfXL8c5s9VT5FQ+y7n46prseiUlv5vojdG2I0iO/Y/xm +8hn26jvMLAwBKeuxX8CMzcEKA65Iw7uYsWMJW6EX2Tq2hBkCQQD603V52o83DoS1 +1x094v5AOrYa1sxUT2UAcoYKJk26VlSpyY0zJi8hNw9DA+89xWJKCWJ/l9ogu4KL +XdWVraZzAkEA2Mlrku4qdKjRhDSRH2q2GOZaue8HZyBFQeuK+sBGa5Jm/MIzdulL +JRYgjil11+BhM2orhUFIwCtQvqLnTBvwhQJBAMpIAOS9q2QWdFaF3lJLnwpDjxtE +AVM5GFZtBcZnr6XH+81V+2a1s6qQ0eEU6jsh1SuqN+J4n3RoZFZq3VYxzhsCQBX2 +0l9gogyPziqG6O018p0zOZ39CdL5AgtbwgkF0hy0CJszUeOKX4Kyazn8GWR152M+ +Loqhwq01tkiaWLTtX8ECQC2INLRdNa6+ySZZnvKfLHrx3umU0VFnq4QNH6KAFuUr +cU6zXjWkciN6fzXBSV5Ib9g+TIr7ghy5D15pRt6L4Rs= +-----END RSA PRIVATE KEY----- diff --git a/examples/clcertClient.hs b/examples/clcertClient.hs new file mode 100644 --- /dev/null +++ b/examples/clcertClient.hs @@ -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 diff --git a/examples/clcertEcdsaClient.hs b/examples/clcertEcdsaClient.hs new file mode 100644 --- /dev/null +++ b/examples/clcertEcdsaClient.hs @@ -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 diff --git a/examples/clcertServer.hs b/examples/clcertServer.hs new file mode 100644 --- /dev/null +++ b/examples/clcertServer.hs @@ -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 diff --git a/examples/eccClient.hs b/examples/eccClient.hs new file mode 100644 --- /dev/null +++ b/examples/eccClient.hs @@ -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 diff --git a/examples/eccServer.hs b/examples/eccServer.hs new file mode 100644 --- /dev/null +++ b/examples/eccServer.hs @@ -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 diff --git a/examples/simpleClient.hs b/examples/simpleClient.hs new file mode 100644 --- /dev/null +++ b/examples/simpleClient.hs @@ -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 diff --git a/examples/simpleServer.hs b/examples/simpleServer.hs new file mode 100644 --- /dev/null +++ b/examples/simpleServer.hs @@ -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 diff --git a/peyotls.cabal b/peyotls.cabal new file mode 100644 --- /dev/null +++ b/peyotls.cabal @@ -0,0 +1,311 @@ +build-type: Simple +cabal-version: >= 1.8 + +name: peyotls +version: 0.0.0.0 +stability: Experimental +author: Yoshikuni Jujo +maintainer: Yoshikuni Jujo +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 diff --git a/src/Network/PeyoTLS/CertSecretKey.hs b/src/Network/PeyoTLS/CertSecretKey.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/CertSecretKey.hs @@ -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 diff --git a/src/Network/PeyoTLS/Certificate.hs b/src/Network/PeyoTLS/Certificate.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Certificate.hs @@ -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 diff --git a/src/Network/PeyoTLS/CipherSuite.hs b/src/Network/PeyoTLS/CipherSuite.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/CipherSuite.hs @@ -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 diff --git a/src/Network/PeyoTLS/Client.hs b/src/Network/PeyoTLS/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Client.hs @@ -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) diff --git a/src/Network/PeyoTLS/CryptoTools.hs b/src/Network/PeyoTLS/CryptoTools.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/CryptoTools.hs @@ -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 diff --git a/src/Network/PeyoTLS/Ecdsa.hs b/src/Network/PeyoTLS/Ecdsa.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Ecdsa.hs @@ -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 diff --git a/src/Network/PeyoTLS/Extension.hs b/src/Network/PeyoTLS/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Extension.hs @@ -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 diff --git a/src/Network/PeyoTLS/HandshakeBase.hs b/src/Network/PeyoTLS/HandshakeBase.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/HandshakeBase.hs @@ -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 diff --git a/src/Network/PeyoTLS/HandshakeMonad.hs b/src/Network/PeyoTLS/HandshakeMonad.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/HandshakeMonad.hs @@ -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 diff --git a/src/Network/PeyoTLS/HandshakeType.hs b/src/Network/PeyoTLS/HandshakeType.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/HandshakeType.hs @@ -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] diff --git a/src/Network/PeyoTLS/HashSignAlgorithm.hs b/src/Network/PeyoTLS/HashSignAlgorithm.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/HashSignAlgorithm.hs @@ -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 diff --git a/src/Network/PeyoTLS/Hello.hs b/src/Network/PeyoTLS/Hello.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Hello.hs @@ -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 diff --git a/src/Network/PeyoTLS/ReadFile.hs b/src/Network/PeyoTLS/ReadFile.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/ReadFile.hs @@ -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] diff --git a/src/Network/PeyoTLS/Server.hs b/src/Network/PeyoTLS/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Server.hs @@ -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 diff --git a/src/Network/PeyoTLS/State.hs b/src/Network/PeyoTLS/State.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/State.hs @@ -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 diff --git a/src/Network/PeyoTLS/TlsHandle.hs b/src/Network/PeyoTLS/TlsHandle.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/TlsHandle.hs @@ -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" diff --git a/src/Network/PeyoTLS/TlsMonad.hs b/src/Network/PeyoTLS/TlsMonad.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/TlsMonad.hs @@ -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 diff --git a/test/testClient.hs b/test/testClient.hs new file mode 100644 --- /dev/null +++ b/test/testClient.hs @@ -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)