HsOpenSSL 0.10.5 → 0.11.7.11
raw patch · 67 files changed
Files
- ChangeLog +490/−2
- HsOpenSSL.cabal +189/−85
- OpenSSL.hs +111/−0
- OpenSSL.hsc +0/−116
- OpenSSL/ASN1.hsc +37/−40
- OpenSSL/BIO.hs +481/−0
- OpenSSL/BIO.hsc +0/−478
- OpenSSL/BN.hsc +53/−47
- OpenSSL/Cipher.hsc +20/−11
- OpenSSL/DER.hsc +92/−0
- OpenSSL/DH.hs +13/−10
- OpenSSL/DH/Internal.hs +57/−0
- OpenSSL/DH/Internal.hsc +0/−51
- OpenSSL/DSA.hsc +125/−58
- OpenSSL/ERR.hs +24/−0
- OpenSSL/ERR.hsc +0/−22
- OpenSSL/EVP/Base64.hs +151/−0
- OpenSSL/EVP/Base64.hsc +0/−146
- OpenSSL/EVP/Cipher.hs +100/−0
- OpenSSL/EVP/Cipher.hsc +0/−125
- OpenSSL/EVP/Digest.hsc +35/−28
- OpenSSL/EVP/Internal.hsc +178/−50
- OpenSSL/EVP/Open.hs +92/−0
- OpenSSL/EVP/Open.hsc +0/−82
- OpenSSL/EVP/PKey.hsc +34/−23
- OpenSSL/EVP/Seal.hs +141/−0
- OpenSSL/EVP/Seal.hsc +0/−133
- OpenSSL/EVP/Sign.hs +70/−0
- OpenSSL/EVP/Sign.hsc +0/−69
- OpenSSL/EVP/Verify.hs +83/−0
- OpenSSL/EVP/Verify.hsc +0/−78
- OpenSSL/Objects.hsc +7/−6
- OpenSSL/PEM.hs +522/−0
- OpenSSL/PEM.hsc +0/−523
- OpenSSL/PKCS7.hsc +17/−19
- OpenSSL/RSA.hsc +110/−35
- OpenSSL/Random.hs +52/−0
- OpenSSL/Random.hsc +0/−56
- OpenSSL/SSL.hsc +0/−15
- OpenSSL/SSL/Option.hsc +265/−0
- OpenSSL/Session.hsc +328/−78
- OpenSSL/Stack.hsc +25/−6
- OpenSSL/Utils.hs +8/−0
- OpenSSL/X509.hs +0/−382
- OpenSSL/X509.hsc +433/−0
- OpenSSL/X509/Name.hsc +13/−13
- OpenSSL/X509/Request.hs +321/−0
- OpenSSL/X509/Request.hsc +0/−255
- OpenSSL/X509/Revocation.hsc +61/−33
- OpenSSL/X509/Store.hsc +24/−19
- README.md +7/−0
- README.rst +0/−8
- Setup.hs +0/−4
- Test/OpenSSL/DER.hs +11/−0
- Test/OpenSSL/DSA.hs +37/−0
- Test/OpenSSL/EVP/Base64.hs +64/−0
- Test/OpenSSL/EVP/Digest.hs +38/−0
- Test/OpenSSL/TestUtils.hs +25/−0
- cbits/HsOpenSSL.c +148/−10
- cbits/HsOpenSSL.h +35/−15
- examples/HelloWorld.hs +15/−12
- examples/Makefile +4/−3
- examples/Server.hs +2/−1
- tests/Base64.hs +0/−71
- tests/Cipher.hs +0/−91
- tests/DSA.hs +0/−48
- tests/Makefile +0/−11
ChangeLog view
@@ -1,9 +1,497 @@+2026-06-29 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.11++ * Fix OpenSSL 4.0 compatibility (#106)+ by Ravi Kant Sharma @raviksharma++2026-01-31 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.10++ * Allow time-1.15; bump CI to GHC 9.14+ by Andreas Abel @andreasabel++ * Disable C warnings (#95)+ by Erik de Castro Lopo @erikd++2025-01-02 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.9++ * Remove Setup.hs (#101)+ by Andreas Abel @andreasabel++2024-08-19 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.8++ * Fix up incompatible pointer issues (#94)+ by Eric Mertens @glguy++2024-06-11 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.7++ * Added generic functionality for adding extensions to X509 (#87)+ by Ishan Sharma @ishan-rep++ * Clear error stack after x509_verify validation failure (#91)+ by Paolo Capriotti @pcapriotti++ * Add withContextSetKeylogCallback: Allow any type inside action (#85)+ by Akshay Mankar @akshaymankar++2022-06-19 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.6++ * More options in Options.hsc (#82)+ by @BeowulfDragon++ * Add note to help users of Session.read and Session.tryRead (#81)+ * Add withContextSetKeylogCallback (#79)+ by Akshay Mankar @akshaymankar++ * Github Actions for Linux, MacOS and Windows (#72)+ by John Ky @newhoggy++2022-02-05 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.5++ * Better suggestions when OpenSSL is not found (#75)++ * Add contextSetALPNProtos+ by Akshay Mankar @akshaymankar (#76)++2022-12-21 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.4++ * Fixes more OpenSSL 3.0.x compilation issues (#74)++2022-12-17 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.3++ * Use capi instead of ccall for better compatibility+ with OpenSSL 3.0 (#73, #63)++ * Update documentation for ssl cipher selection+ by Adam Sandberg Eriksson @adamse (#66)++2021-09-29 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.2++ * Fixed OpenSSL 3.0 linking errors (#62)++2021-07-28 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7.1++ * Fix SSL_CTX_set_session_id_context #61+ by @flobrosch (#61)++2021-04-19 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.7++ * Added Session.contextSetDefaultVerifyPaths+ by Alexander Biehl @alexbiehl (#59)++ * Fix for LibreSSL (#58)++2021-04-05 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.6.1++ * Windows: Use libcrypto instead of eay; allow pkg-config.+ by @slycelote (#57)++2021-03-19 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.6++ * Added Session.contextSetSessionIdContext+ by Francesco Gazzetta @fgaz (#56)++2020-11-06 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.5.1++ * Fix for older GHC versions.++2020-11-02 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.5+ (actually it is previous version that should be 0.11.5+ since it added new API but it was already released+ so we bumping version here).++ * Handling SSL_ERROR_SYSCALL with errno=0 which means unexpected EOF.++2020-10-08 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.20++ * Hostname validation+ by @amesgen (#52)++ * Do not compile OpenSSL modules twice for tests++2020-09-01 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.19++ * HsOpenSSL.cabal: Discover OpenSSL via pkg-config+ by Alexander Biehl @alexbiehl (#51)++2020-03-31 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.18++ * LibreSSL compatibility+ by Julian Ospald @hasufell (#45, #47)++2019-09-13 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.17++ * Allow old time, allows building with bundled time back to GHC-7.4+ by Oleg Grenrus @phadej (#46)++2019-01-21 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal:+ Added upper version bounds to all dependencies (#41)++2019-01-21 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.16++ * Compatibility for network-3.0.0+ by Roman Borschel @romanb (#40)++ * .travis.yml: Fixed build. Updated to last 3 GHC versions.++2018-09-08 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.15++ * Link libopenssl before libcrypto+ by Shea Levy @shlevy (#38)++2018-05-31 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.14++ * HsOpenSSL.cabal: Removed upper bounds from all dependencies except+ base where it is required.++2018-03-09 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.13++ * HsOpenSSL.cabal: Removed Cabal upper bound,+ fixed Cabal-Version format.++2018-01-24 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.12++ * Fix the build with GHC 8.4+ by Ryan Scott @RyanGlScott (#35)++2017-08-14 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.11++ * cbits/HsOpenSSL.h: Hack OpenSSL version number when using LibreSSL+ by Javier López @TheLinuxKitten (#31)++2017-07-25 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.10++ * Declare dependency on `hsc2hs`+ by Herbert Valerio Riedel @hvr (#28).++2017-06-08 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.9++ * Added -DNOCRYPT to compile in newer MINGW versions+ by Baojun Wang @wangbj (#27)++2017-04-26 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.8++ * Setup.hs: Updated for Cabal-2.0+ by Eric Mertens @glguy (#24)++2017-04-17 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.7++ * Support for MinGW64,+ by @varosi (#23)++2017-04-05 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.6++ * Setup.hs: builds with ghc 8.2,+ by Erik de Castro Lopo @erikd (#22)++2017-04-04 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.5++ * cbits/HsOpenSSL.c: fixed HMAC_CTX_free invocation (#21)++2017-03-24 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.4++ * OpenSSL/EVP/Digest.hsc (hmacLBS): fixed linking error (#19).++ * Tests/OpenSSL/EVP/Digest.hs: added tests for hmacBS and hmacLBS.++2017-03-22 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.3++ * OpenSSL/EVP/Digest.hsc (hmacLBS): added HMAC on lazy bytestrings,+ by SX91 (#18).++2017-03-11 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.2++ * Ported BN to integer-gmp-1.0.x,+ by SX91 (#17).++2017-02-27 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4.1++ * Updated for OpenSSL 1.1.0 (#16)++2017-01-24 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.4++ * Updated for OpenSSL 1.1.0 (#15)++2016-10-17 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.3.2++ * Test/*, HsOpenSSL.cabal (Build-Depends):+ Removed HUnit, test-framework and test-framework-hunit dependencies.++2016-10-15 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.3.1++ * OpenSSL/Session.hsc: Detect failure of SSL_CTX_new,+ by Eric Mertens @glguy (#13)++2016-10-14 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.3++ * HsOpenSSL.cabal (Build-Depends): Bump HUnit upper bound,++ * OpenSSL/RSA.hsc, OpenSSL/DER.hsc: moved DER function from RSA to DER+ module. Added encoding/decoding of private keys in ASN.1 DER.+ by @shak-mar (#12).++2016-10-08 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.2.4++ * Setup.hs: Fixed handling of 'cabal configure' errors+ in Homebrew/MacPorts OpenSSL autodetection.++2016-10-06 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.2.3++ * HsOpenSSL.cabal, Setup.hs:+ Automatic detection of Homebrew or MacPorts OpenSSL on macOS+ with helpful (I hope ;) error messages (phonohawk#41).+ Previous approach caused ld warning 'directory not found',+ wasn't informative when OpenSSL is not installed and could+ potentially prevent linking with OpenSSL from another source.++ * HsOpenSSL.cabal: Bump Cabal-Version to 1.12 (bundled with GHC 7.2.2).++ * OpenSSL/Session.hsc: Exposed OpenSSL.Session internal types,+ by Eric Mertens @glguy (#10).++2016-10-05 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.2.2++ * HsOpenSSL.cabal: Added Include-Dirs and Extra-Lib-Dirs for building+ with Homebrew/MacPorts OpenSSL on Mac OS X 10.11+ (phonohawk#41)++2016-10-04 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.2.1++ * HsOpenSSL.cabal (Build-Depends):+ base >= 4.4 && < 5 (GHC >= 7.2) instead of == 4.* (GHC >= 6.10)++ * OpenSSL/RSA.hsc: fixed incompatibility with GHC < 7.10++ * .travis.yml: Added Travis Job, by Herbert Valerio Riedel @hvr (#8).++2016-10-04 Vladimir Shabanov <dev@vshabanov.com>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.2++ * HsOpenSSL.cabal: New maintainer and GitHub repo path.++ * HsOpenSSL.cabal: removed old-locale dependency (requires time >= 1.5).++ * examples/Client.hs: Added client example, by @mirokuratczyk (#7).++ * OpenSSL/EVP/Internal.hsc: Added cipherSetPadding function,+ by @SX91 (#6).++ * OpenSSL/BN.hsc: prandInteger functions now use BN_pseudo_rand_range,+ by @Pamelloes (#5).++ * OpenSSL/RSA.hsc, OpenSSL/X509.hs, OpenSSL/X509/Request.hs, Test/OpenSSL/RSA.hs, HsOpenSSL.cabal:+ DER reading/writing for X509, X509Req & RSA,+ by @newsham, @shak-mar, @afcady (#4)++ * HsOpenSSL.cabal (Includes): Added openssl/asn1.h, by phadej (#3).++ * HsOpenSSL.cabal (Build-Depends): Bump HUnit upper bound,+ by phadej (#2).++ * 10 files: Fixed GHC 7.10 warnings,+ by Mikhail Glushenkov @23Skidoo (#1).++2015-01-06 PHO <pho@cielonegro.org>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.1.1++ * OpenSSL/SSL/Option.hsc: Guard SSL_OP_SAFARI_ECDHE_ECDSA_BUG with+ #if defined(), Reported by Leon Mergen (#37).++2014-12-31 PHO <pho@cielonegro.org>++ * tests/DSA.hs: Rename to Test/OpenSSL/DSA.hs and make it a cabal+ test-case.++ * tests/Cipher.hs: Rename to Test/OpenSSL/Cipher.hs and make it a+ cabal test-case.++ * tests/Base64.hs: Rename to Test/OpenSSL/EVP/Base64.hs and make+ it a cabal test-case.++ * HsOpenSSL.cabal (Install-Includes): Removed. HsOpenSSL.h needs+ not be installed.++ * HsOpenSSL.cabal (Extensions): Removed. Use {-# LANGUAGE #-}+ pragma instead.++ * OpenSSL/EVP/Internal.hsc (VaguePKey, PKey): Turn documentation+ comments into Haddock ones.++ * OpenSSL/EVP/PKey.hsc (module): Do not re-export PKey. It was+ only accidentally re-exported.++ * HsOpenSSL.cabal (Build-Depends): Narrow version ranges that were+ unnecessarily wide.++ * HsOpenSSL.cabal (Build-Depends): ghc-prim is only required when+ fast-bignum is enabled and the compiler is ghc < 6.11.++ * HsOpenSSL.cabal (Build-Depends) [fast-bignum]: Declare that+ integer-gmp >= 1 is not supported yet. Reported by Herbert+ Valerio Riedel (#36).++2014-12-23 PHO <pho@cielonegro.org>++ * OpenSSL/ASN1.hsc (peekASN1Time): Support time-1.5,+ Patch by Herbert Valerio Riedel (#35).++ * OpenSSL/Session.hsc (context, connection'): Replace+ addMVarFinalizer with mkWeakMVar to suppress deprecation warnings,+ Patch by Ryan Desfosses (#33).++ * OpenSSL/Session.hsc (tryShutdown): "shutdown Bidirectional"+ always resulted in an exception "thread blocked indefinitely in an+ MVar operation" because of the way we were using withMVar in+ OpenSSL.Session.tryShutdown. Reported by Andreas Voellmy (#32).++ * OpenSSL/Session.hsc (contextAddOption, contextRemoveOption)+ (addOption, removeOption, SSLOption): New functions and a data+ type to disable SSLv3 vulnerable to the POODLE attack.+ Suggested by Maxim Dikun (#34).++ * HsOpenSSL.cabal (Version): Bump version to 0.11.1+ 2014-07-13 PHO <pho@cielonegro.org> - * OpenSSL/EVP/Cipher.hsc: Expose cipherInit, Patch by rons.+ * OpenSSL/EVP/Base64.hsc (encodeBase64, decodeBase64): Mark as+ deprecated. + * OpenSSL/EVP/Cipher.hsc (cipherInit): Removed. Use+ OpenSSL.EVP.Internal.cipherInitBS instead. This is a+ backward-incompatible change.++ * OpenSSL/EVP/Cipher.hsc (cipher): Mark as deprecated.++ * OpenSSL/EVP/Digest.hsc (digest): Mark as deprecated.++ * OpenSSL/EVP/Digest.hsc (digestBS): Changed the return type from+ String to strict ByteString. This is a backward-incompatible+ change.++ * OpenSSL/EVP/Digest.hsc (digestBS'): Removed. Use digestBS+ instead. This is a backward-incompatible change.++ * OpenSSL/EVP/Digest.hsc (digestLBS): Change the return type from+ String to strict ByteString. This is a backward-incompatible+ change.++ * OpenSSL/EVP/Open.hsc (open): Mark as deprecated.++ * OpenSSL/EVP/Open.hsc (openBS, openLBS): Take key and IV as a+ strict ByteString intead of String. This is a+ backward-incompatible change.++ * OpenSSL/EVP/Seal.hsc (seal): Mark as deprecated.++ * OpenSSL/EVP/Seal.hsc (sealBS, sealLBS): Return key and IV as a+ strict ByteString intead of String. This is a+ backward-incompatible change.++ * OpenSSL/EVP/Sign.hsc (sign): Mark as deprecated.++ * OpenSSL/EVP/Verify.hsc (verify): Mark as deprecated.++ * OpenSSL/EVP/Verify.hsc (verifyBS, verifyLBS): Take signature as+ a strict ByteString instead of String. This is a+ backward-incompatible change.++ * HsOpenSSL.cabal (Version): Bump version to 0.11++2014-07-13 PHO <pho@cielonegro.org>++ * OpenSSL/EVP/Cipher.hsc: Expose cipherInit, Patch by rnons (#31).+ * HsOpenSSL.cabal (Exposed-Modules): Expose OpenSSL.EVP.Internal,- Patch by rnos.+ Patch by rnons (#31). * HsOpenSSL.cabal (Version): Bump version to 0.10.5
HsOpenSSL.cabal view
@@ -1,7 +1,7 @@+Cabal-Version: 1.18 Name: HsOpenSSL Synopsis: Partial OpenSSL binding for Haskell Description:- . HsOpenSSL is an OpenSSL binding for Haskell. It can generate RSA and DSA keys, read and write PEM files, generate message digests, sign and verify messages, encrypt and decrypt messages. It has@@ -11,23 +11,36 @@ systems and stable. You may also be interested in the @tls@ package, <http://hackage.haskell.org/package/tls>, which is a pure Haskell implementation of SSL.- .-Version: 0.10.5+Version: 0.11.7.11 License: PublicDomain License-File: COPYING Author: Adam Langley, Mikhail Vorozhtsov, PHO, Taru Karttunen-Maintainer: PHO <pho at cielonegro dot org>+Maintainer: Vladimir Shabanov <dev@vshabanov.com> Stability: stable-Homepage: https://github.com/phonohawk/HsOpenSSL-Bug-Reports: https://github.com/phonohawk/HsOpenSSL/issues+Homepage: https://github.com/haskell-cryptography/HsOpenSSL+Bug-Reports: https://github.com/haskell-cryptography/HsOpenSSL/issues Category: Cryptography-Tested-With: GHC == 7.6.2-Cabal-Version: >= 1.6+Tested-With:+ GHC ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.8+ || ==9.4.8+ || ==9.6.6+ || ==9.8.4+ || ==9.10.3+ || ==9.12.2+ || ==9.14.1 Build-Type: Simple-Extra-Source-Files:+Extra-Doc-Files: AUTHORS ChangeLog- README.rst+ README.md+Extra-Source-Files: cbits/HsOpenSSL.h cbits/mutex.h examples/Makefile@@ -37,91 +50,182 @@ examples/Server.hs examples/server.crt examples/server.pem- tests/Base64.hs- tests/Cipher.hs- tests/DSA.hs- tests/Makefile Source-Repository head Type: git- Location: git://github.com/phonohawk/HsOpenSSL.git+ Location: https://github.com/haskell-cryptography/HsOpenSSL.git Flag fast-bignum Description:- Enable fast moving of bignums between OpenSSL and GMP (GHC Only).+ Enable fast moving of bignums between OpenSSL and GMP (GHC and OpenSSL version < 1.1.0 only). Default:+ False++Flag homebrew-openssl+ Description:+ Use Homebrew version of OpenSSL (macOS only).+ Default:+ False++Flag macports-openssl+ Description:+ Use MacPorts version of OpenSSL (macOS only).+ Default:+ False++Flag use-pkg-config+ Description:+ Use pkg-config to find OpenSSL (macOS and linux only).+ Default:+ False+ Manual: True Library- Build-Depends:- base >= 4 && < 5,- bytestring,- ghc-prim,- network >= 2.1.0.0,- old-locale,- time >= 1.1.1+ Build-Depends:+ base >= 4.8 && < 5,+ bytestring >= 0.9 && < 0.13,+ network >= 2.1 && < 3.3,+ time >= 1.5 && < 1.17 - if flag(fast-bignum)- CPP-Options: -DFAST_BIGNUM- if impl(ghc >= 6.11)- Build-Depends: integer-gmp- else- Build-Depends: integer+ Build-Tools: hsc2hs >= 0.67 - if os(mingw32)- Extra-Libraries: eay32 ssl32- C-Sources: cbits/mutex-win.c- CC-Options: -D MINGW32- CPP-Options: -DCALLCONV=stdcall- else- Extra-Libraries: crypto ssl- C-Sources: cbits/mutex-pthread.c- CC-Options: -D PTHREAD- CPP-Options: -DCALLCONV=ccall+ if flag(fast-bignum) && impl(ghc >= 7.10.1)+ -- only new integer-gmp 1.0.0 is supported+ -- and it only works in OpenSSL version < 1.1.0 where BIGNUM+ -- wasn't opaque structure.+ CPP-Options: -DFAST_BIGNUM+ Build-Depends: integer-gmp >= 1.0.0 && < 1.1.0 - Exposed-Modules:- OpenSSL- OpenSSL.BN- OpenSSL.EVP.Base64- OpenSSL.EVP.Cipher- OpenSSL.EVP.Digest- OpenSSL.EVP.Internal- OpenSSL.EVP.Open- OpenSSL.EVP.PKey- OpenSSL.EVP.Seal- OpenSSL.EVP.Sign- OpenSSL.EVP.Verify- OpenSSL.Cipher- OpenSSL.PEM- OpenSSL.PKCS7- OpenSSL.Random- OpenSSL.DSA- OpenSSL.RSA- OpenSSL.X509- OpenSSL.X509.Revocation- OpenSSL.X509.Request- OpenSSL.X509.Store- OpenSSL.Session- OpenSSL.DH- Other-Modules:- OpenSSL.ASN1- OpenSSL.BIO- OpenSSL.ERR- OpenSSL.Objects- OpenSSL.SSL- OpenSSL.Stack- OpenSSL.Utils- OpenSSL.X509.Name- OpenSSL.DH.Internal- Extensions:- ForeignFunctionInterface, EmptyDataDecls, MagicHash,- UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable,- ExistentialQuantification, RankNTypes- ghc-options:- -Wall- C-Sources:- cbits/HsOpenSSL.c- Include-Dirs:- cbits- Install-Includes:- HsOpenSSL.h+ if os(darwin) && flag(homebrew-openssl)+ if arch(aarch64)+ Include-Dirs: /opt/homebrew/opt/openssl/include+ Extra-Lib-Dirs: /opt/homebrew/opt/openssl/lib+ else+ Include-Dirs: /usr/local/opt/openssl/include+ Extra-Lib-Dirs: /usr/local/opt/openssl/lib++ if os(darwin) && flag(macports-openssl)+ Include-Dirs: /opt/local/include+ Extra-Lib-Dirs: /opt/local/lib++ if flag(use-pkg-config)+ pkgconfig-depends: libssl, libcrypto+ else+ Extra-Libraries: ssl crypto++ if os(mingw32)+ C-Sources: cbits/mutex-win.c+ CC-Options: -D MINGW32 -DNOCRYPT+ CPP-Options: -DCALLCONV=stdcall+ else+ C-Sources: cbits/mutex-pthread.c+ CC-Options: -D PTHREAD+ CPP-Options: -DCALLCONV=ccall++ Exposed-Modules:+ OpenSSL+ OpenSSL.BN+ OpenSSL.DER+ OpenSSL.EVP.Base64+ OpenSSL.EVP.Cipher+ OpenSSL.EVP.Digest+ OpenSSL.EVP.Internal+ OpenSSL.EVP.Open+ OpenSSL.EVP.PKey+ OpenSSL.EVP.Seal+ OpenSSL.EVP.Sign+ OpenSSL.EVP.Verify+ OpenSSL.Cipher+ OpenSSL.PEM+ OpenSSL.PKCS7+ OpenSSL.Random+ OpenSSL.DSA+ OpenSSL.RSA+ OpenSSL.X509+ OpenSSL.X509.Revocation+ OpenSSL.X509.Request+ OpenSSL.X509.Store+ OpenSSL.Session+ OpenSSL.DH+ Other-Modules:+ OpenSSL.ASN1+ OpenSSL.BIO+ OpenSSL.ERR+ OpenSSL.Objects+ OpenSSL.SSL.Option+ OpenSSL.Stack+ OpenSSL.Utils+ OpenSSL.X509.Name+ OpenSSL.DH.Internal+ Default-Language:+ Haskell2010+ GHC-Options:+ -Wall+ -Wno-deriving-typeable+ -optc=-Wno-unknown-warning-option+ -optc=-Wno-discarded-qualifiers+ -optc=-Wno-deprecated-declarations+ -optc=-Wno-incompatible-pointer-types+ -optc=-Wno-pointer-sign+ C-Sources:+ cbits/HsOpenSSL.c+ Include-Dirs:+ cbits+ Includes:+ openssl/asn1.h++Test-Suite test-dsa+ Type: exitcode-stdio-1.0+ Main-Is: DSA.hs+ HS-Source-Dirs: Test/OpenSSL+ Other-Modules: TestUtils+ Build-Depends:+ HsOpenSSL,+ base >= 4.8 && < 5,+ bytestring >= 0.9 && < 0.13+ Default-Language:+ Haskell2010+ GHC-Options:+ -Wall++Test-Suite test-der+ Type: exitcode-stdio-1.0+ Main-Is: DER.hs+ HS-Source-Dirs: Test/OpenSSL+ Other-Modules: TestUtils+ Build-Depends:+ HsOpenSSL,+ base >= 4.8 && < 5+ Default-Language:+ Haskell2010+ GHC-Options:+ -Wall++Test-Suite test-evp-base64+ Type: exitcode-stdio-1.0+ Main-Is: EVP/Base64.hs+ HS-Source-Dirs: Test/OpenSSL+ Other-Modules: TestUtils+ Build-Depends:+ HsOpenSSL,+ base >= 4.8 && < 5,+ bytestring >= 0.9 && < 0.13+ Default-Language:+ Haskell2010+ GHC-Options:+ -Wall++Test-Suite test-evp-digest+ Type: exitcode-stdio-1.0+ Main-Is: EVP/Digest.hs+ HS-Source-Dirs: Test/OpenSSL+ Other-Modules: TestUtils+ Build-Depends:+ HsOpenSSL,+ base >= 4.8 && < 5,+ bytestring >= 0.9 && < 0.13+ Default-Language:+ Haskell2010+ GHC-Options:+ -Wall
+ OpenSSL.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- |HsOpenSSL is an OpenSSL binding for Haskell. It can generate RSA+-- and DSA keys, read and write PEM files, generate message digests,+-- sign and verify messages, encrypt and decrypt messages.+--+-- Please note that this project has started at the time when there+-- were no pure-Haskell implementations of TLS. Now there is tls+-- package (<http://hackage.haskell.org/package/tls>), which looks+-- pretty saner than HsOpenSSL especially for initialisation and error+-- handlings. So PHO (the initial author of HsOpenSSL) wants to+-- encourage you to use and improve the tls package instead as long as+-- possible. The only problem is that the tls package has not received+-- as much review as OpenSSL from cryptography specialists yet, thus+-- we can't assume it's secure enough.+--+-- Features that aren't (yet) supported:+--+-- [/SSL network connection/] ssl(3) functionalities aren't fully+-- covered yet. See "OpenSSL.Session".+--+-- [/Complete coverage of Low-level API to symmetric ciphers/] Only+-- high-level APIs (EVP and BIO) are fully available. But I believe+-- no one will be lost without functions like @DES_set_odd_parity@.+--+-- [/Low-level API to asymmetric ciphers/] Only a high-level API+-- (EVP) is available. But I believe no one will complain about the+-- absence of functions like @RSA_public_encrypt@.+--+-- [/X.509 v3 extension handling/] It should be supported in the+-- future.+--+-- [/Low-level API to message digest functions/] Just use EVP+-- instead of something like @MD5_Update@.+--+-- [/API to PKCS#12 functionality/] It should be covered someday.+--+-- [/BIO/] BIO isn't needed because we are Haskell hackers. Though+-- HsOpenSSL itself uses BIO internally.+--+-- [/ENGINE cryptographic module/] The default implementations work+-- very well, don't they?+module OpenSSL+ ( withOpenSSL+ )+ where+import Control.Concurrent.MVar+import Control.Monad+import System.IO.Unsafe++#if !MIN_VERSION_base(4,6,0)+import Control.Exception (onException, mask_)+#endif++foreign import capi "HsOpenSSL.h HsOpenSSL_init"+ initSSL :: IO ()++foreign import capi "HsOpenSSL.h HsOpenSSL_setupMutex"+ setupMutex :: IO ()+++-- |Computation of @'withOpenSSL' action@ initializes the OpenSSL+-- library as necessary, and computes @action@. Every application that+-- uses HsOpenSSL must wrap any operations involving OpenSSL with+-- 'withOpenSSL', or they might crash:+--+-- > module Main where+-- > import OpenSSL+-- >+-- > main :: IO ()+-- > main = withOpenSSL $+-- > do ...+--+-- Since 0.10.3.5, 'withOpenSSL' is safe to be applied+-- redundantly. Library authors may wish to wrap their functions not+-- to force their users to think about initialization:+--+-- > get :: URI -> IO Response+-- > get uri = withOpenSSL $ internalImplementationOfGet uri+--+withOpenSSL :: IO a -> IO a+withOpenSSL io+ -- We don't want our initialisation sequence to be interrupted+ -- halfway.+ = do modifyMVarMasked_ isInitialised $ \ done ->+ do unless done $ do initSSL+ setupMutex+ return True+ io++#if !MIN_VERSION_base(4,6,0)+{-|+ Like 'modifyMVar_', but the @IO@ action in the second argument is executed with+ asynchronous exceptions masked.+-}+{-# INLINE modifyMVarMasked_ #-}+modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO ()+modifyMVarMasked_ m io =+ mask_ $ do+ a <- takeMVar m+ a' <- io a `onException` putMVar m a+ putMVar m a'+#endif++-- This variable must be atomically fetched/stored not to initialise+-- the library twice.+isInitialised :: MVar Bool+{-# NOINLINE isInitialised #-}+isInitialised =+ unsafePerformIO $ newMVar False
− OpenSSL.hsc
@@ -1,116 +0,0 @@-{- -*- haskell -*- -}---- |HsOpenSSL is an OpenSSL binding for Haskell. It can generate RSA--- and DSA keys, read and write PEM files, generate message digests,--- sign and verify messages, encrypt and decrypt messages.------ Please note that this project has started at the time when there--- were no pure-Haskell implementations of TLS. Now there is tls--- package (<http://hackage.haskell.org/package/tls>), which looks--- pretty saner than HsOpenSSL especially for initialisation and error--- handlings. So PHO (the initial author of HsOpenSSL) wants to--- encourage you to use and improve the tls package instead as long as--- possible. The only problem is that the tls package has not received--- as much review as OpenSSL from cryptography specialists yet, thus--- we can't assume it's secure enough.------ Features that aren't (yet) supported:------ [/SSL network connection/] ssl(3) functionalities aren't fully--- covered yet. See "OpenSSL.Session".------ [/Complete coverage of Low-level API to symmetric ciphers/] Only--- high-level APIs (EVP and BIO) are fully available. But I believe--- no one will be lost without functions like @DES_set_odd_parity@.------ [/Low-level API to asymmetric ciphers/] Only a high-level API--- (EVP) is available. But I believe no one will complain about the--- absence of functions like @RSA_public_encrypt@.------ [/Key generation of Diffie-Hellman algorithm/] Only RSA and DSA--- keys can currently be generated.------ [/X.509 v3 extension handling/] It should be supported in the--- future.------ [/Low-level API to message digest functions/] Just use EVP--- instead of something like @MD5_Update@.------ [/API to PKCS#12 functionality/] It should be covered someday.------ [/BIO/] BIO isn't needed because we are Haskell hackers. Though--- HsOpenSSL itself uses BIO internally.------ [/ENGINE cryptographic module/] The default implementations work--- very well, don't they?--#include "HsOpenSSL.h"--module OpenSSL- ( withOpenSSL- )- where-import Control.Concurrent.MVar-import Control.Monad-import OpenSSL.SSL-import System.IO.Unsafe--#if !MIN_VERSION_base(4,6,0)-import Control.Exception (onException, mask_)-#endif--foreign import ccall "HsOpenSSL_setupMutex"- setupMutex :: IO ()----- |Computation of @'withOpenSSL' action@ initializes the OpenSSL--- library as necessary, and computes @action@. Every application that--- uses HsOpenSSL must wrap any operations involving OpenSSL with--- 'withOpenSSL', or they might crash:------ > module Main where--- > import OpenSSL--- >--- > main :: IO ()--- > main = withOpenSSL $--- > do ...------ Since 0.10.3.5, 'withOpenSSL' is safe to be applied--- redundantly. Library authors may wish to wrap their functions not--- to force their users to think about initialization:------ > get :: URI -> IO Response--- > get uri = withOpenSSL $ internalImplementationOfGet uri----withOpenSSL :: IO a -> IO a-withOpenSSL io- -- We don't want our initialisation sequence to be interrupted- -- halfway.- = do modifyMVarMasked_ isInitialised $ \ done ->- do unless done $ do loadErrorStrings- addAllAlgorithms- libraryInit- setupMutex- return True- io--#if !MIN_VERSION_base(4,6,0)-{-|- Like 'modifyMVar_', but the @IO@ action in the second argument is executed with- asynchronous exceptions masked.--}-{-# INLINE modifyMVarMasked_ #-}-modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO ()-modifyMVarMasked_ m io =- mask_ $ do- a <- takeMVar m- a' <- io a `onException` putMVar m a- putMVar m a'-#endif---- This variable must be atomically fetched/stored not to initialise--- the library twice.-isInitialised :: MVar Bool-{-# NOINLINE isInitialised #-}-isInitialised =- unsafePerformIO $ newMVar False
OpenSSL/ASN1.hsc view
@@ -1,5 +1,7 @@-#include "HsOpenSSL.h"-+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-} module OpenSSL.ASN1 ( ASN1_OBJECT , obj2nid@@ -18,8 +20,7 @@ , withASN1Time ) where--+#include "HsOpenSSL.h" import Control.Exception import Data.Time.Clock import Data.Time.Clock.POSIX@@ -29,19 +30,22 @@ import OpenSSL.BIO import OpenSSL.BN import OpenSSL.Utils-import System.Locale +#if !MIN_VERSION_time(1,5,0)+import System.Locale+#endif+ {- ASN1_OBJECT --------------------------------------------------------------- -} -data ASN1_OBJECT+data {-# CTYPE "openssl/asn1.h" "ASN1_OBJECT" #-} ASN1_OBJECT -foreign import ccall unsafe "OBJ_obj2nid"+foreign import capi unsafe "openssl/objects.h OBJ_obj2nid" obj2nid :: Ptr ASN1_OBJECT -> IO CInt -foreign import ccall unsafe "OBJ_nid2sn"+foreign import capi unsafe "openssl/objects.h OBJ_nid2sn" _nid2sn :: CInt -> IO CString -foreign import ccall unsafe "OBJ_nid2ln"+foreign import capi unsafe "openssl/objects.h OBJ_nid2ln" _nid2ln :: CInt -> IO CString @@ -55,29 +59,35 @@ {- ASN1_STRING --------------------------------------------------------------- -} -data ASN1_STRING+data {-# CTYPE "openssl/asn1.h" "ASN1_STRING" #-} ASN1_STRING +foreign import capi unsafe "openssl/asn1.h ASN1_STRING_get0_data"+ _ASN1_STRING_get0_data :: Ptr ASN1_STRING -> IO (Ptr CChar)++foreign import capi unsafe "openssl/asn1.h ASN1_STRING_length"+ _ASN1_STRING_length :: Ptr ASN1_STRING -> IO CInt+ peekASN1String :: Ptr ASN1_STRING -> IO String peekASN1String strPtr- = do buf <- (#peek ASN1_STRING, data ) strPtr- len <- (#peek ASN1_STRING, length) strPtr :: IO CInt+ = do buf <- _ASN1_STRING_get0_data strPtr+ len <- _ASN1_STRING_length strPtr peekCStringLen (buf, fromIntegral len) {- ASN1_INTEGER -------------------------------------------------------------- -} -data ASN1_INTEGER+data {-# CTYPE "openssl/asn1.h" "ASN1_INTEGER" #-} ASN1_INTEGER -foreign import ccall unsafe "HsOpenSSL_M_ASN1_INTEGER_new"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_M_ASN1_INTEGER_new" _ASN1_INTEGER_new :: IO (Ptr ASN1_INTEGER) -foreign import ccall unsafe "HsOpenSSL_M_ASN1_INTEGER_free"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_M_ASN1_INTEGER_free" _ASN1_INTEGER_free :: Ptr ASN1_INTEGER -> IO () -foreign import ccall unsafe "ASN1_INTEGER_to_BN"+foreign import capi unsafe "openssl/asn1.h ASN1_INTEGER_to_BN" _ASN1_INTEGER_to_BN :: Ptr ASN1_INTEGER -> Ptr BIGNUM -> IO (Ptr BIGNUM) -foreign import ccall unsafe "BN_to_ASN1_INTEGER"+foreign import capi unsafe "openssl/asn1.h BN_to_ASN1_INTEGER" _BN_to_ASN1_INTEGER :: Ptr BIGNUM -> Ptr ASN1_INTEGER -> IO (Ptr ASN1_INTEGER) @@ -105,18 +115,18 @@ {- ASN1_TIME ---------------------------------------------------------------- -} -data ASN1_TIME+data {-# CTYPE "openssl/asn1.h" "ASN1_TIME" #-} ASN1_TIME -foreign import ccall unsafe "HsOpenSSL_M_ASN1_TIME_new"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_M_ASN1_TIME_new" _ASN1_TIME_new :: IO (Ptr ASN1_TIME) -foreign import ccall unsafe "HsOpenSSL_M_ASN1_TIME_free"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_M_ASN1_TIME_free" _ASN1_TIME_free :: Ptr ASN1_TIME -> IO () -foreign import ccall unsafe "ASN1_TIME_set"+foreign import capi unsafe "openssl/asn1.h ASN1_TIME_set" _ASN1_TIME_set :: Ptr ASN1_TIME -> CTime -> IO (Ptr ASN1_TIME) -foreign import ccall unsafe "ASN1_TIME_print"+foreign import capi unsafe "openssl/asn1.h ASN1_TIME_print" _ASN1_TIME_print :: Ptr BIO_ -> Ptr ASN1_TIME -> IO CInt @@ -127,26 +137,13 @@ _ASN1_TIME_print bioPtr time >>= failIf_ (/= 1) timeStr <- bioRead bio- case parseTime locale "%b %e %H:%M:%S %Y %Z" timeStr of+#if MIN_VERSION_time(1,5,0)+ case parseTimeM True defaultTimeLocale "%b %e %H:%M:%S %Y %Z" timeStr of+#else+ case parseTime defaultTimeLocale "%b %e %H:%M:%S %Y %Z" timeStr of+#endif Just utc -> return utc Nothing -> fail ("peekASN1Time: failed to parse time string: " ++ timeStr)- where- locale :: TimeLocale- locale = TimeLocale {- wDays = undefined- , months = [ (undefined, x)- | x <- [ "Jan", "Feb", "Mar", "Apr", "May", "Jun"- , "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"- ]- ]- , intervals = undefined- , amPm = undefined- , dateTimeFmt = undefined- , dateFmt = undefined- , timeFmt = undefined- , time12Fmt = undefined- }- allocaASN1Time :: (Ptr ASN1_TIME -> IO a) -> IO a allocaASN1Time
+ OpenSSL/BIO.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{- --------------------------------------------------------------------------- -}+{- -}+{- FOR INTERNAL USE ONLY -}+{- -}+{- When I firstly saw the manpage of bio(3), it looked like a great API. I ac- -}+{- tually wrote a wrapper and even wrote a document. What a pain! -}+{- -}+{- Now I realized that BIOs aren't necessary to we Haskell hackers. Their fun- -}+{- ctionalities overlaps with Haskell's own I/O system. The only thing which -}+{- wasn't available without bio(3) -- at least I thought so -- was the -}+{- BIO_f_base64(3), but I found an undocumented API for the Base64 codec. -}+{- I FOUND AN UNDOCUMENTED API FOR THE VERY BASE64 CODEC. -}+{- So I decided to bury all the OpenSSL.BIO module. The game is over. -}+{- -}+{- --------------------------------------------------------------------------- -}+++-- |A BIO is an I\/O abstraction, it hides many of the underlying I\/O+-- details from an application, if you are writing a pure C+-- application...+--+-- I know, we are hacking on Haskell so BIO components like BIO_s_file+-- are hardly needed. But for filter BIOs, such as BIO_f_base64 and+-- BIO_f_cipher, they should be useful too to us.++module OpenSSL.BIO+ ( -- * Type+ BIO+ , BIO_++ , wrapBioPtr -- private+ , withBioPtr -- private+ , withBioPtr' -- private++ -- * BIO chaning+ , bioPush+ , (==>)+ , (<==)+ , bioJoin++ -- * BIO control operations+ , bioFlush+ , bioReset+ , bioEOF++ -- * BIO I\/O functions+ , bioRead+ , bioReadBS+ , bioReadLBS+ , bioGets+ , bioGetsBS+ , bioGetsLBS+ , bioWrite+ , bioWriteBS+ , bioWriteLBS++ -- * Base64 BIO filter+ , newBase64++ -- * Buffering BIO filter+ , newBuffer++ -- * Memory BIO sink\/source+ , newMem+ , newConstMem+ , newConstMemBS+ , newConstMemLBS++ -- * Null data BIO sink\/source+ , newNullBIO+ )+ where++import Control.Monad+import Data.ByteString.Internal (createAndTrim, toForeignPtr)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.Internal as L+import Foreign hiding (new)+import Foreign.C+import Foreign.Concurrent as Conc+import OpenSSL.Utils+import System.IO.Unsafe++{- bio ---------------------------------------------------------------------- -}++data {-# CTYPE "openssl/bio.h" "BIO_METHOD" #-} BIO_METHOD++-- |@BIO@ is a @ForeignPtr@ to an opaque BIO object. They are created by newXXX actions.+newtype BIO = BIO (ForeignPtr BIO_)+data {-# CTYPE "openssl/bio.h" "BIO" #-} BIO_++foreign import capi unsafe "openssl/bio.h BIO_new"+ _new :: Ptr BIO_METHOD -> IO (Ptr BIO_)++foreign import capi unsafe "openssl/bio.h BIO_free"+ _free :: Ptr BIO_ -> IO ()++foreign import capi unsafe "openssl/bio.h BIO_push"+ _push :: Ptr BIO_ -> Ptr BIO_ -> IO (Ptr BIO_)++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_BIO_set_flags"+ _set_flags :: Ptr BIO_ -> CInt -> IO ()++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_BIO_should_retry"+ _should_retry :: Ptr BIO_ -> IO CInt+++new :: Ptr BIO_METHOD -> IO BIO+new method+ = _new method >>= failIfNull >>= wrapBioPtr+++wrapBioPtr :: Ptr BIO_ -> IO BIO+wrapBioPtr bioPtr+ = fmap BIO (Conc.newForeignPtr bioPtr (_free bioPtr))+++withBioPtr :: BIO -> (Ptr BIO_ -> IO a) -> IO a+withBioPtr (BIO bio) = withForeignPtr bio+++withBioPtr' :: Maybe BIO -> (Ptr BIO_ -> IO a) -> IO a+withBioPtr' Nothing f = f nullPtr+withBioPtr' (Just bio) f = withBioPtr bio f+++-- Connect 'b' behind 'a'. It's possible that 1. we only retain 'a'+-- and write to 'a', and 2. we only retain 'b' and read from 'b', so+-- both ForeignPtr's have to touch each other. This involves a+-- circular dependency but that won't be a problem as the garbage+-- collector isn't reference-counting.++-- |Computation of @'bioPush' a b@ connects @b@ behind @a@.+--+-- Example:+--+-- > do b64 <- newBase64 True+-- > mem <- newMem+-- > bioPush b64 mem+-- >+-- > -- Encode some text in Base64 and write the result to the+-- > -- memory buffer.+-- > bioWrite b64 "Hello, world!"+-- > bioFlush b64+-- >+-- > -- Then dump the memory buffer.+-- > bioRead mem >>= putStrLn+--+bioPush :: BIO -> BIO -> IO ()+bioPush (BIO a) (BIO b)+ = withForeignPtr a $ \ aPtr ->+ withForeignPtr b $ \ bPtr ->+ do _ <- _push aPtr bPtr+ Conc.addForeignPtrFinalizer a $ touchForeignPtr b+ Conc.addForeignPtrFinalizer b $ touchForeignPtr a+ return ()++-- |@a '==>' b@ is an alias to @'bioPush' a b@.+(==>) :: BIO -> BIO -> IO ()+(==>) = bioPush++-- |@a '<==' b@ is an alias to @'bioPush' b a@.+(<==) :: BIO -> BIO -> IO ()+(<==) = flip bioPush+++-- |@'bioJoin' [bio1, bio2, ..]@ connects many BIOs at once.+bioJoin :: [BIO] -> IO ()+bioJoin [] = return ()+bioJoin (_:[]) = return ()+bioJoin (a:b:xs) = bioPush a b >> bioJoin (b:xs)+++setFlags :: BIO -> CInt -> IO ()+setFlags bio flags+ = withBioPtr bio $ flip _set_flags flags+++bioShouldRetry :: BIO -> IO Bool+bioShouldRetry bio+ = withBioPtr bio $ \ bioPtr ->+ fmap (/= 0) (_should_retry bioPtr)+++{- ctrl --------------------------------------------------------------------- -}++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_BIO_flush"+ _flush :: Ptr BIO_ -> IO CInt++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_BIO_reset"+ _reset :: Ptr BIO_ -> IO CInt++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_BIO_eof"+ _eof :: Ptr BIO_ -> IO CInt++-- |@'bioFlush' bio@ normally writes out any internally buffered data,+-- in some cases it is used to signal EOF and that no more data will+-- be written.+bioFlush :: BIO -> IO ()+bioFlush bio+ = withBioPtr bio $ \ bioPtr ->+ _flush bioPtr >>= failIf (/= 1) >> return ()++-- |@'bioReset' bio@ typically resets a BIO to some initial state.+bioReset :: BIO -> IO ()+bioReset bio+ = withBioPtr bio $ \ bioPtr ->+ _reset bioPtr >> return () -- Return value of BIO_reset is not+ -- consistent in every BIO's so we+ -- can't do error-checking.++-- |@'bioEOF' bio@ returns 1 if @bio@ has read EOF, the precise+-- meaning of EOF varies according to the BIO type.+bioEOF :: BIO -> IO Bool+bioEOF bio+ = withBioPtr bio $ \ bioPtr ->+ fmap (==1) (_eof bioPtr)+++{- I/O ---------------------------------------------------------------------- -}++foreign import capi unsafe "openssl/bio.h BIO_read"+ _read :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt++foreign import capi unsafe "openssl/bio.h BIO_gets"+ _gets :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt++foreign import capi unsafe "openssl/bio.h BIO_write"+ _write :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt++-- |@'bioRead' bio@ lazily reads all data in @bio@.+bioRead :: BIO -> IO String+bioRead bio+ = liftM L.unpack $ bioReadLBS bio++-- |@'bioReadBS' bio len@ attempts to read @len@ bytes from @bio@,+-- then return a ByteString. The actual length of result may be less+-- than @len@.+bioReadBS :: BIO -> Int -> IO B.ByteString+bioReadBS bio maxLen+ = withBioPtr bio $ \ bioPtr ->+ createAndTrim maxLen $ \ bufPtr ->+ _read bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret+ where+ interpret :: CInt -> IO Int+ interpret n+ | n == 0 = return 0+ | n == -1 = return 0+ | n < -1 = raiseOpenSSLError+ | otherwise = return (fromIntegral n)++-- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a+-- LazyByteString.+bioReadLBS :: BIO -> IO L.ByteString+bioReadLBS bio = fmap L.fromChunks lazyRead+ where+ chunkSize = L.defaultChunkSize++ lazyRead = unsafeInterleaveIO loop++ loop = do bs <- bioReadBS bio chunkSize+ if B.null bs then+ do isEOF <- bioEOF bio+ if isEOF then+ return []+ else+ do shouldRetry <- bioShouldRetry bio+ if shouldRetry then+ loop+ else+ fail "bioReadLBS: got null but isEOF=False, shouldRetry=False"+ else+ do bss <- lazyRead+ return (bs:bss)++-- |@'bioGets' bio len@ normally attempts to read one line of data+-- from @bio@ of maximum length @len@. There are exceptions to this+-- however, for example 'bioGets' on a digest BIO will calculate and+-- return the digest and other BIOs may not support 'bioGets' at all.+bioGets :: BIO -> Int -> IO String+bioGets bio maxLen+ = liftM B.unpack (bioGetsBS bio maxLen)++-- |'bioGetsBS' does the same as 'bioGets' but returns ByteString.+bioGetsBS :: BIO -> Int -> IO B.ByteString+bioGetsBS bio maxLen+ = withBioPtr bio $ \ bioPtr ->+ createAndTrim maxLen $ \ bufPtr ->+ _gets bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret+ where+ interpret :: CInt -> IO Int+ interpret n+ | n == 0 = return 0+ | n == -1 = return 0+ | n < -1 = raiseOpenSSLError+ | otherwise = return (fromIntegral n)++-- |'bioGetsLBS' does the same as 'bioGets' but returns+-- LazyByteString.+bioGetsLBS :: BIO -> Int -> IO L.ByteString+bioGetsLBS bio maxLen+ = bioGetsBS bio maxLen >>= \ bs -> (return . L.fromChunks) [bs]++-- |@'bioWrite' bio str@ lazily writes entire @str@ to @bio@. The+-- string doesn't necessarily have to be finite.+bioWrite :: BIO -> String -> IO ()+bioWrite bio str+ = (return . L.pack) str >>= bioWriteLBS bio++-- |@'bioWriteBS' bio bs@ writes @bs@ to @bio@.+bioWriteBS :: BIO -> B.ByteString -> IO ()+bioWriteBS bio bs+ = withBioPtr bio $ \ bioPtr ->+ unsafeUseAsCStringLen bs $ \ (buf, len) ->+ _write bioPtr buf (fromIntegral len) >>= interpret+ where+ interpret :: CInt -> IO ()+ interpret n+ | n == fromIntegral (B.length bs)+ = return ()+ | n == -1 = bioWriteBS bio bs -- full retry+ | n < -1 = raiseOpenSSLError+ | otherwise = bioWriteBS bio (B.drop (fromIntegral n) bs) -- partial retry++-- |@'bioWriteLBS' bio lbs@ lazily writes entire @lbs@ to @bio@. The+-- string doesn't necessarily have to be finite.+bioWriteLBS :: BIO -> L.ByteString -> IO ()+bioWriteLBS bio lbs+ = mapM_ (bioWriteBS bio) $ L.toChunks lbs+++{- base64 ------------------------------------------------------------------- -}++foreign import capi unsafe "openssl/bio.h BIO_f_base64"+ f_base64 :: IO (Ptr BIO_METHOD)++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_BIO_FLAGS_BASE64_NO_NL"+ _FLAGS_BASE64_NO_NL :: CInt++-- |@'newBase64' noNL@ creates a Base64 BIO filter. This is a filter+-- bio that base64 encodes any data written through it and decodes any+-- data read through it.+--+-- If @noNL@ flag is True, the filter encodes the data all on one line+-- or expects the data to be all on one line.+--+-- Base64 BIOs do not support 'bioGets'.+--+-- 'bioFlush' on a Base64 BIO that is being written through is used to+-- signal that no more data is to be encoded: this is used to flush+-- the final block through the BIO.+newBase64 :: Bool -> IO BIO+newBase64 noNL+ = do bio <- new =<< f_base64+ when noNL $ setFlags bio _FLAGS_BASE64_NO_NL+ return bio+++{- buffer ------------------------------------------------------------------- -}++foreign import capi unsafe "openssl/bio.h BIO_f_buffer"+ f_buffer :: IO (Ptr BIO_METHOD)++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_BIO_set_buffer_size"+ _set_buffer_size :: Ptr BIO_ -> CInt -> IO CInt+++-- |@'newBuffer' mBufSize@ creates a buffering BIO filter. Data+-- written to a buffering BIO is buffered and periodically written to+-- the next BIO in the chain. Data read from a buffering BIO comes+-- from the next BIO in the chain.+--+-- Buffering BIOs support 'bioGets'.+--+-- Calling 'bioReset' on a buffering BIO clears any buffered data.+--+-- Question: When I created a BIO chain like this and attempted to+-- read from the buf, the buffering BIO weirdly behaved: BIO_read()+-- returned nothing, but both BIO_eof() and BIO_should_retry()+-- returned zero. I tried to examine the source code of+-- crypto\/bio\/bf_buff.c but it was too complicated to+-- understand. Does anyone know why this happens? The version of+-- OpenSSL was 0.9.7l.+--+-- > main = withOpenSSL $+-- > do mem <- newConstMem "Hello, world!"+-- > buf <- newBuffer Nothing+-- > mem ==> buf+-- >+-- > bioRead buf >>= putStrLn -- This fails, but why?+--+-- I am being depressed for this unaccountable failure.+--+newBuffer :: Maybe Int -- ^ Explicit buffer size (@Just n@) or the+ -- default size (@Nothing@).+ -> IO BIO+newBuffer bufSize+ = do bio <- new =<< f_buffer+ case bufSize of+ Just n -> withBioPtr bio $ \ bioPtr ->+ _set_buffer_size bioPtr (fromIntegral n)+ >>= failIf (/= 1) >> return ()+ Nothing -> return ()+ return bio+++{- mem ---------------------------------------------------------------------- -}++foreign import ccall unsafe "openssl/bio.h BIO_s_mem"+ s_mem :: IO (Ptr BIO_METHOD)++foreign import ccall unsafe "openssl/bio.h BIO_new_mem_buf"+ _new_mem_buf :: Ptr CChar -> CInt -> IO (Ptr BIO_)+++-- |@'newMem'@ creates a memory BIO sink\/source. Any data written to+-- a memory BIO can be recalled by reading from it. Unless the memory+-- BIO is read only any data read from it is deleted from the BIO.+--+-- Memory BIOs support 'bioGets'.+--+-- Calling 'bioReset' on a read write memory BIO clears any data in+-- it. On a read only BIO it restores the BIO to its original state+-- and the read only data can be read again.+--+-- 'bioEOF' is true if no data is in the BIO.+--+-- Every read from a read write memory BIO will remove the data just+-- read with an internal copy operation, if a BIO contains a lots of+-- data and it is read in small chunks the operation can be very+-- slow. The use of a read only memory BIO avoids this problem. If the+-- BIO must be read write then adding a buffering BIO ('newBuffer') to+-- the chain will speed up the process.+newMem :: IO BIO+newMem = s_mem >>= new++-- |@'newConstMem' str@ creates a read-only memory BIO source.+newConstMem :: String -> IO BIO+newConstMem str = newConstMemBS (B.pack str)++-- |@'newConstMemBS' bs@ is like 'newConstMem' but takes a ByteString.+newConstMemBS :: B.ByteString -> IO BIO+newConstMemBS bs+ = let (foreignBuf, off, len) = toForeignPtr bs+ in+ -- Let the BIO's finalizer have a reference to the ByteString.+ withForeignPtr foreignBuf $ \ buf ->+ do bioPtr <- _new_mem_buf (castPtr $ buf `plusPtr` off) (fromIntegral len)+ >>= failIfNull++ bio <- newForeignPtr_ bioPtr+ Conc.addForeignPtrFinalizer bio (_free bioPtr >> touchForeignPtr foreignBuf)++ return $ BIO bio++-- |@'newConstMemLBS' lbs@ is like 'newConstMem' but takes a+-- LazyByteString.+newConstMemLBS :: L.ByteString -> IO BIO+newConstMemLBS lbs+ = (return . B.concat . L.toChunks) lbs >>= newConstMemBS++{- null --------------------------------------------------------------------- -}++foreign import ccall unsafe "openssl/bio.h BIO_s_null"+ s_null :: IO (Ptr BIO_METHOD)++-- |@'newNullBIO'@ creates a null BIO sink\/source. Data written to+-- the null sink is discarded, reads return EOF.+--+-- A null sink is useful if, for example, an application wishes to+-- digest some data by writing through a digest bio but not send the+-- digested data anywhere. Since a BIO chain must normally include a+-- source\/sink BIO this can be achieved by adding a null sink BIO to+-- the end of the chain.+newNullBIO :: IO BIO+newNullBIO = s_null >>= new
− OpenSSL/BIO.hsc
@@ -1,478 +0,0 @@-{- --------------------------------------------------------------------------- -}-{- -}-{- FOR INTERNAL USE ONLY -}-{- -}-{- When I firstly saw the manpage of bio(3), it looked like a great API. I ac- -}-{- tually wrote a wrapper and even wrote a document. What a pain! -}-{- -}-{- Now I realized that BIOs aren't necessary to we Haskell hackers. Their fun- -}-{- ctionalities overlaps with Haskell's own I/O system. The only thing which -}-{- wasn't available without bio(3) -- at least I thought so -- was the -}-{- BIO_f_base64(3), but I found an undocumented API for the Base64 codec. -}-{- I FOUND AN UNDOCUMENTED API FOR THE VERY BASE64 CODEC. -}-{- So I decided to bury all the OpenSSL.BIO module. The game is over. -}-{- -}-{- --------------------------------------------------------------------------- -}----- |A BIO is an I\/O abstraction, it hides many of the underlying I\/O--- details from an application, if you are writing a pure C--- application...------ I know, we are hacking on Haskell so BIO components like BIO_s_file--- are hardly needed. But for filter BIOs, such as BIO_f_base64 and--- BIO_f_cipher, they should be useful too to us.--module OpenSSL.BIO- ( -- * Type- BIO- , BIO_-- , wrapBioPtr -- private- , withBioPtr -- private- , withBioPtr' -- private-- -- * BIO chaning- , bioPush- , (==>)- , (<==)- , bioJoin-- -- * BIO control operations- , bioFlush- , bioReset- , bioEOF-- -- * BIO I\/O functions- , bioRead- , bioReadBS- , bioReadLBS- , bioGets- , bioGetsBS- , bioGetsLBS- , bioWrite- , bioWriteBS- , bioWriteLBS-- -- * Base64 BIO filter- , newBase64-- -- * Buffering BIO filter- , newBuffer-- -- * Memory BIO sink\/source- , newMem- , newConstMem- , newConstMemBS- , newConstMemLBS-- -- * Null data BIO sink\/source- , newNullBIO- )- where--import Control.Monad-import Data.ByteString.Internal (createAndTrim, toForeignPtr)-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Lazy.Internal as L-import Foreign hiding (new)-import Foreign.C-import Foreign.Concurrent as Conc-import OpenSSL.Utils-import System.IO.Unsafe--{- bio ---------------------------------------------------------------------- -}--data BIO_METHOD---- |@BIO@ is a @ForeignPtr@ to an opaque BIO object. They are created by newXXX actions.-newtype BIO = BIO (ForeignPtr BIO_)-data BIO_--foreign import ccall unsafe "BIO_new"- _new :: Ptr BIO_METHOD -> IO (Ptr BIO_)--foreign import ccall unsafe "BIO_free"- _free :: Ptr BIO_ -> IO ()--foreign import ccall unsafe "BIO_push"- _push :: Ptr BIO_ -> Ptr BIO_ -> IO (Ptr BIO_)--foreign import ccall unsafe "HsOpenSSL_BIO_set_flags"- _set_flags :: Ptr BIO_ -> CInt -> IO ()--foreign import ccall unsafe "HsOpenSSL_BIO_should_retry"- _should_retry :: Ptr BIO_ -> IO CInt---new :: Ptr BIO_METHOD -> IO BIO-new method- = _new method >>= failIfNull >>= wrapBioPtr---wrapBioPtr :: Ptr BIO_ -> IO BIO-wrapBioPtr bioPtr- = fmap BIO (Conc.newForeignPtr bioPtr (_free bioPtr))---withBioPtr :: BIO -> (Ptr BIO_ -> IO a) -> IO a-withBioPtr (BIO bio) = withForeignPtr bio---withBioPtr' :: Maybe BIO -> (Ptr BIO_ -> IO a) -> IO a-withBioPtr' Nothing f = f nullPtr-withBioPtr' (Just bio) f = withBioPtr bio f----- Connect 'b' behind 'a'. It's possible that 1. we only retain 'a'--- and write to 'a', and 2. we only retain 'b' and read from 'b', so--- both ForeignPtr's have to touch each other. This involves a--- circular dependency but that won't be a problem as the garbage--- collector isn't reference-counting.---- |Computation of @'bioPush' a b@ connects @b@ behind @a@.------ Example:------ > do b64 <- newBase64 True--- > mem <- newMem--- > bioPush b64 mem--- >--- > -- Encode some text in Base64 and write the result to the--- > -- memory buffer.--- > bioWrite b64 "Hello, world!"--- > bioFlush b64--- >--- > -- Then dump the memory buffer.--- > bioRead mem >>= putStrLn----bioPush :: BIO -> BIO -> IO ()-bioPush (BIO a) (BIO b)- = withForeignPtr a $ \ aPtr ->- withForeignPtr b $ \ bPtr ->- do _ <- _push aPtr bPtr- Conc.addForeignPtrFinalizer a $ touchForeignPtr b- Conc.addForeignPtrFinalizer b $ touchForeignPtr a- return ()---- |@a '==>' b@ is an alias to @'bioPush' a b@.-(==>) :: BIO -> BIO -> IO ()-(==>) = bioPush---- |@a '<==' b@ is an alias to @'bioPush' b a@.-(<==) :: BIO -> BIO -> IO ()-(<==) = flip bioPush----- |@'bioJoin' [bio1, bio2, ..]@ connects many BIOs at once.-bioJoin :: [BIO] -> IO ()-bioJoin [] = return ()-bioJoin (_:[]) = return ()-bioJoin (a:b:xs) = bioPush a b >> bioJoin (b:xs)---setFlags :: BIO -> CInt -> IO ()-setFlags bio flags- = withBioPtr bio $ flip _set_flags flags- --bioShouldRetry :: BIO -> IO Bool-bioShouldRetry bio- = withBioPtr bio $ \ bioPtr ->- fmap (/= 0) (_should_retry bioPtr)---{- ctrl --------------------------------------------------------------------- -}--foreign import ccall unsafe "HsOpenSSL_BIO_flush"- _flush :: Ptr BIO_ -> IO CInt--foreign import ccall unsafe "HsOpenSSL_BIO_reset"- _reset :: Ptr BIO_ -> IO CInt--foreign import ccall unsafe "HsOpenSSL_BIO_eof"- _eof :: Ptr BIO_ -> IO CInt---- |@'bioFlush' bio@ normally writes out any internally buffered data,--- in some cases it is used to signal EOF and that no more data will--- be written.-bioFlush :: BIO -> IO ()-bioFlush bio- = withBioPtr bio $ \ bioPtr ->- _flush bioPtr >>= failIf (/= 1) >> return ()---- |@'bioReset' bio@ typically resets a BIO to some initial state.-bioReset :: BIO -> IO ()-bioReset bio- = withBioPtr bio $ \ bioPtr ->- _reset bioPtr >> return () -- Return value of BIO_reset is not- -- consistent in every BIO's so we- -- can't do error-checking.---- |@'bioEOF' bio@ returns 1 if @bio@ has read EOF, the precise--- meaning of EOF varies according to the BIO type.-bioEOF :: BIO -> IO Bool-bioEOF bio- = withBioPtr bio $ \ bioPtr ->- fmap (==1) (_eof bioPtr)---{- I/O ---------------------------------------------------------------------- -}--foreign import ccall unsafe "BIO_read"- _read :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt--foreign import ccall unsafe "BIO_gets"- _gets :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt--foreign import ccall unsafe "BIO_write"- _write :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt---- |@'bioRead' bio@ lazily reads all data in @bio@.-bioRead :: BIO -> IO String-bioRead bio- = liftM L.unpack $ bioReadLBS bio---- |@'bioReadBS' bio len@ attempts to read @len@ bytes from @bio@,--- then return a ByteString. The actual length of result may be less--- than @len@.-bioReadBS :: BIO -> Int -> IO B.ByteString-bioReadBS bio maxLen- = withBioPtr bio $ \ bioPtr ->- createAndTrim maxLen $ \ bufPtr ->- _read bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret- where- interpret :: CInt -> IO Int- interpret n- | n == 0 = return 0- | n == -1 = return 0- | n < -1 = raiseOpenSSLError- | otherwise = return (fromIntegral n)---- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a--- LazyByteString.-bioReadLBS :: BIO -> IO L.ByteString-bioReadLBS bio = fmap L.fromChunks lazyRead- where- chunkSize = L.defaultChunkSize- - lazyRead = unsafeInterleaveIO loop-- loop = do bs <- bioReadBS bio chunkSize- if B.null bs then- do isEOF <- bioEOF bio- if isEOF then- return []- else- do shouldRetry <- bioShouldRetry bio- if shouldRetry then- loop- else- fail "bioReadLBS: got null but isEOF=False, shouldRetry=False"- else- do bss <- lazyRead- return (bs:bss)---- |@'bioGets' bio len@ normally attempts to read one line of data--- from @bio@ of maximum length @len@. There are exceptions to this--- however, for example 'bioGets' on a digest BIO will calculate and--- return the digest and other BIOs may not support 'bioGets' at all.-bioGets :: BIO -> Int -> IO String-bioGets bio maxLen- = liftM B.unpack (bioGetsBS bio maxLen)---- |'bioGetsBS' does the same as 'bioGets' but returns ByteString.-bioGetsBS :: BIO -> Int -> IO B.ByteString-bioGetsBS bio maxLen- = withBioPtr bio $ \ bioPtr ->- createAndTrim maxLen $ \ bufPtr ->- _gets bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret- where- interpret :: CInt -> IO Int- interpret n- | n == 0 = return 0- | n == -1 = return 0- | n < -1 = raiseOpenSSLError- | otherwise = return (fromIntegral n)---- |'bioGetsLBS' does the same as 'bioGets' but returns--- LazyByteString.-bioGetsLBS :: BIO -> Int -> IO L.ByteString-bioGetsLBS bio maxLen- = bioGetsBS bio maxLen >>= \ bs -> (return . L.fromChunks) [bs]---- |@'bioWrite' bio str@ lazily writes entire @str@ to @bio@. The--- string doesn't necessarily have to be finite.-bioWrite :: BIO -> String -> IO ()-bioWrite bio str- = (return . L.pack) str >>= bioWriteLBS bio---- |@'bioWriteBS' bio bs@ writes @bs@ to @bio@.-bioWriteBS :: BIO -> B.ByteString -> IO ()-bioWriteBS bio bs- = withBioPtr bio $ \ bioPtr ->- unsafeUseAsCStringLen bs $ \ (buf, len) ->- _write bioPtr buf (fromIntegral len) >>= interpret- where- interpret :: CInt -> IO ()- interpret n- | n == fromIntegral (B.length bs)- = return ()- | n == -1 = bioWriteBS bio bs -- full retry- | n < -1 = raiseOpenSSLError- | otherwise = bioWriteBS bio (B.drop (fromIntegral n) bs) -- partial retry---- |@'bioWriteLBS' bio lbs@ lazily writes entire @lbs@ to @bio@. The--- string doesn't necessarily have to be finite.-bioWriteLBS :: BIO -> L.ByteString -> IO ()-bioWriteLBS bio lbs- = mapM_ (bioWriteBS bio) $ L.toChunks lbs---{- base64 ------------------------------------------------------------------- -}--foreign import ccall unsafe "BIO_f_base64"- f_base64 :: IO (Ptr BIO_METHOD)--foreign import ccall unsafe "HsOpenSSL_BIO_FLAGS_BASE64_NO_NL"- _FLAGS_BASE64_NO_NL :: CInt---- |@'newBase64' noNL@ creates a Base64 BIO filter. This is a filter--- bio that base64 encodes any data written through it and decodes any--- data read through it.------ If @noNL@ flag is True, the filter encodes the data all on one line--- or expects the data to be all on one line.------ Base64 BIOs do not support 'bioGets'.------ 'bioFlush' on a Base64 BIO that is being written through is used to--- signal that no more data is to be encoded: this is used to flush--- the final block through the BIO.-newBase64 :: Bool -> IO BIO-newBase64 noNL- = do bio <- new =<< f_base64- when noNL $ setFlags bio _FLAGS_BASE64_NO_NL- return bio---{- buffer ------------------------------------------------------------------- -}--foreign import ccall unsafe "BIO_f_buffer"- f_buffer :: IO (Ptr BIO_METHOD)--foreign import ccall unsafe "HsOpenSSL_BIO_set_buffer_size"- _set_buffer_size :: Ptr BIO_ -> CInt -> IO CInt----- |@'newBuffer' mBufSize@ creates a buffering BIO filter. Data--- written to a buffering BIO is buffered and periodically written to--- the next BIO in the chain. Data read from a buffering BIO comes--- from the next BIO in the chain.------ Buffering BIOs support 'bioGets'.------ Calling 'bioReset' on a buffering BIO clears any buffered data.------ Question: When I created a BIO chain like this and attempted to--- read from the buf, the buffering BIO weirdly behaved: BIO_read()--- returned nothing, but both BIO_eof() and BIO_should_retry()--- returned zero. I tried to examine the source code of--- crypto\/bio\/bf_buff.c but it was too complicated to--- understand. Does anyone know why this happens? The version of--- OpenSSL was 0.9.7l.------ > main = withOpenSSL $--- > do mem <- newConstMem "Hello, world!"--- > buf <- newBuffer Nothing--- > mem ==> buf--- >--- > bioRead buf >>= putStrLn -- This fails, but why?------ I am being depressed for this unaccountable failure.----newBuffer :: Maybe Int -- ^ Explicit buffer size (@Just n@) or the- -- default size (@Nothing@).- -> IO BIO-newBuffer bufSize- = do bio <- new =<< f_buffer- case bufSize of- Just n -> withBioPtr bio $ \ bioPtr ->- _set_buffer_size bioPtr (fromIntegral n)- >>= failIf (/= 1) >> return ()- Nothing -> return ()- return bio---{- mem ---------------------------------------------------------------------- -}--foreign import ccall unsafe "BIO_s_mem"- s_mem :: IO (Ptr BIO_METHOD)--foreign import ccall unsafe "BIO_new_mem_buf"- _new_mem_buf :: Ptr CChar -> CInt -> IO (Ptr BIO_)----- |@'newMem'@ creates a memory BIO sink\/source. Any data written to--- a memory BIO can be recalled by reading from it. Unless the memory--- BIO is read only any data read from it is deleted from the BIO.------ Memory BIOs support 'bioGets'.------ Calling 'bioReset' on a read write memory BIO clears any data in--- it. On a read only BIO it restores the BIO to its original state--- and the read only data can be read again.------ 'bioEOF' is true if no data is in the BIO.------ Every read from a read write memory BIO will remove the data just--- read with an internal copy operation, if a BIO contains a lots of--- data and it is read in small chunks the operation can be very--- slow. The use of a read only memory BIO avoids this problem. If the--- BIO must be read write then adding a buffering BIO ('newBuffer') to--- the chain will speed up the process.-newMem :: IO BIO-newMem = s_mem >>= new---- |@'newConstMem' str@ creates a read-only memory BIO source.-newConstMem :: String -> IO BIO-newConstMem str = newConstMemBS (B.pack str)---- |@'newConstMemBS' bs@ is like 'newConstMem' but takes a ByteString.-newConstMemBS :: B.ByteString -> IO BIO-newConstMemBS bs- = let (foreignBuf, off, len) = toForeignPtr bs- in- -- Let the BIO's finalizer have a reference to the ByteString.- withForeignPtr foreignBuf $ \ buf ->- do bioPtr <- _new_mem_buf (castPtr $ buf `plusPtr` off) (fromIntegral len)- >>= failIfNull-- bio <- newForeignPtr_ bioPtr- Conc.addForeignPtrFinalizer bio (_free bioPtr >> touchForeignPtr foreignBuf)- - return $ BIO bio---- |@'newConstMemLBS' lbs@ is like 'newConstMem' but takes a--- LazyByteString.-newConstMemLBS :: L.ByteString -> IO BIO-newConstMemLBS lbs- = (return . B.concat . L.toChunks) lbs >>= newConstMemBS--{- null --------------------------------------------------------------------- -}--foreign import ccall unsafe "BIO_s_null"- s_null :: IO (Ptr BIO_METHOD)---- |@'newNullBIO'@ creates a null BIO sink\/source. Data written to--- the null sink is discarded, reads return EOF.------ A null sink is useful if, for example, an application wishes to--- digest some data by writing through a digest bio but not send the--- digested data anywhere. Since a BIO chain must normally include a--- source\/sink BIO this can be achieved by adding a null sink BIO to--- the end of the chain.-newNullBIO :: IO BIO-newNullBIO = s_null >>= new
OpenSSL/BN.hsc view
@@ -1,12 +1,23 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE BangPatterns #-}- #include "HsOpenSSL.h" -{-# OPTIONS_HADDOCK prune #-}+#if (OPENSSL_VERSION_NUMBER >= 0x10100000L && defined(FAST_BIGNUM))+-- BIGNUM is opaque type in OpenSSL 1.1.x+#undef FAST_BIGNUM+#endif +#if defined(FAST_BIGNUM)+{-# LANGUAGE BangPatterns #-}+#endif+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+#if defined(FAST_BIGNUM)+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedFFITypes #-}+#endif+{-# OPTIONS_HADDOCK prune #-} -- |BN - multiprecision integer arithmetics- module OpenSSL.BN ( -- * Type BigNum@@ -48,17 +59,10 @@ import OpenSSL.Utils import System.IO.Unsafe -#ifdef FAST_BIGNUM+#if defined(FAST_BIGNUM) import Foreign.C.Types import GHC.Base-# if MIN_VERSION_integer_gmp(0,2,0) import GHC.Integer.GMP.Internals-# else-import GHC.Num-import GHC.Prim-import GHC.Integer.Internals-import GHC.IOBase (IO(..))-# endif #else import Control.Monad import Foreign.C@@ -66,13 +70,13 @@ -- |'BigNum' is an opaque object representing a big number. newtype BigNum = BigNum (Ptr BIGNUM)-data BIGNUM+data {-# CTYPE "openssl/bn.h" "BIGNUM" #-} BIGNUM -foreign import ccall unsafe "BN_new"+foreign import capi unsafe "openssl/bn.h BN_new" _new :: IO (Ptr BIGNUM) -foreign import ccall unsafe "BN_free"+foreign import capi unsafe "openssl/bn.h BN_free" _free :: Ptr BIGNUM -> IO () -- |@'allocaBN' f@ allocates a 'BigNum' and computes @f@. Then it@@ -90,17 +94,17 @@ wrapBN = BigNum -#ifndef FAST_BIGNUM+#if !defined(FAST_BIGNUM) {- slow, safe functions ----------------------------------------------------- -} -foreign import ccall unsafe "BN_bn2dec"+foreign import capi unsafe "openssl/bn.h BN_bn2dec" _bn2dec :: Ptr BIGNUM -> IO CString -foreign import ccall unsafe "BN_dec2bn"+foreign import capi unsafe "openssl/bn.h BN_dec2bn" _dec2bn :: Ptr (Ptr BIGNUM) -> CString -> IO CInt -foreign import ccall unsafe "HsOpenSSL_OPENSSL_free"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_OPENSSL_free" _openssl_free :: Ptr a -> IO () -- |Convert a BIGNUM to an 'Integer'.@@ -134,10 +138,10 @@ -- GC could do nasty things to the data which we thought that we had a pointer -- to -foreign import ccall unsafe "memcpy"+foreign import capi unsafe "string.h memcpy" _copy_in :: ByteArray## -> Ptr () -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "memcpy"+foreign import capi unsafe "string.h memcpy" _copy_out :: Ptr () -> ByteArray## -> CSize -> IO (Ptr ()) -- These are taken from Data.Binary's disabled fast Integer support@@ -164,7 +168,7 @@ negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO CInt if negative == 0 then return $ S## i- else return $ 0 - (S## i)+ else return $ S## (0## -## i) _ -> do let !(I## nlimbsi) = fromIntegral nlimbs !(I## limbsize) = (#size unsigned long)@@ -174,8 +178,8 @@ _ <- _copy_in ba limbs $ fromIntegral $ nlimbs * (#size unsigned long) negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO CInt if negative == 0- then return $ J## nlimbsi ba- else return $ 0 - (J## nlimbsi ba)+ then return $ Jp## (byteArrayToBigNat## ba nlimbsi)+ else return $ Jn## (byteArrayToBigNat## ba nlimbsi) -- | This is a GHC specific, fast conversion between Integers and OpenSSL -- bignums. It returns a malloced BigNum.@@ -209,9 +213,15 @@ (#poke BIGNUM, neg) bnptr (if (I## v) < 0 then one else 0) return (wrapBN bnptr) -integerToBN v@(J## nlimbs_ bytearray)- | v >= 0 = do- let nlimbs = (I## nlimbs_)+integerToBN v =+ case v of+ Jp## bn -> convert 0 bn+ Jn## bn -> convert 1 bn+ S## _ -> undefined+ where+ convert :: CInt -> BigNat -> IO BigNum+ convert negValue bn@(BN## bytearray) = do+ let nlimbs = I## (sizeofBigNat## bn) bnptr <- mallocBytes (#size BIGNUM) limbs <- mallocBytes ((#size unsigned long) * nlimbs) (#poke BIGNUM, d) bnptr limbs@@ -219,12 +229,8 @@ _ <- _copy_out limbs bytearray (fromIntegral $ (#size unsigned long) * nlimbs) (#poke BIGNUM, top) bnptr ((fromIntegral nlimbs) :: CInt) (#poke BIGNUM, dmax) bnptr ((fromIntegral nlimbs) :: CInt)- (#poke BIGNUM, neg) bnptr (0 :: CInt)+ (#poke BIGNUM, neg) bnptr negValue return (wrapBN bnptr)- | otherwise = do bnptr <- integerToBN (0-v)- (#poke BIGNUM, neg) (unwrapBN bnptr) (1 :: CInt)- return bnptr- #endif -- TODO: we could make a function which doesn't even allocate BN data if we@@ -237,11 +243,11 @@ withBN :: Integer -> (BigNum -> IO a) -> IO a withBN dec m = bracket (integerToBN dec) (_free . unwrapBN) m -foreign import ccall unsafe "BN_bn2mpi"- _bn2mpi :: Ptr BIGNUM -> Ptr CChar -> IO CInt+foreign import capi unsafe "openssl/bn.h BN_bn2mpi"+ _bn2mpi :: Ptr BIGNUM -> Ptr CUChar -> IO CInt -foreign import ccall unsafe "BN_mpi2bn"- _mpi2bn :: Ptr CChar -> CInt -> Ptr BIGNUM -> IO (Ptr BIGNUM)+foreign import capi unsafe "openssl/bn.h BN_mpi2bn"+ _mpi2bn :: Ptr CUChar -> CInt -> Ptr BIGNUM -> IO (Ptr BIGNUM) -- |This is an alias to 'bnToInteger'. peekBN :: BigNum -> IO Integer@@ -259,13 +265,13 @@ bytes <- _bn2mpi (unwrapBN bn) nullPtr allocaBytes (fromIntegral bytes) (\buffer -> do _ <- _bn2mpi (unwrapBN bn) buffer- BS.packCStringLen (buffer, fromIntegral bytes))+ BS.packCStringLen (castPtr buffer, fromIntegral bytes)) -- | Convert an MPI into a BigNum. See bnToMPI for details of the format mpiToBN :: BS.ByteString -> IO BigNum mpiToBN mpi = do BS.useAsCStringLen mpi (\(ptr, len) -> do- _mpi2bn ptr (fromIntegral len) nullPtr) >>= return . wrapBN+ _mpi2bn (castPtr ptr) (fromIntegral len) nullPtr) >>= return . wrapBN -- | Convert an Integer to an MPI. See bnToMPI for the format integerToMPI :: Integer -> IO BS.ByteString@@ -279,16 +285,16 @@ _free (unwrapBN bn) return v -foreign import ccall unsafe "BN_mod_exp"- _mod_exp :: Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> BNCtx -> IO (Ptr BIGNUM)+foreign import capi unsafe "openssl/bn.h BN_mod_exp"+ _mod_exp :: Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> BNCtx -> IO CInt type BNCtx = Ptr BNCTX-data BNCTX+data {-# CTYPE "openssl/bn.h" "BN_CTX" #-} BNCTX -foreign import ccall unsafe "BN_CTX_new"+foreign import capi unsafe "openssl/bn.h BN_CTX_new" _BN_ctx_new :: IO BNCtx -foreign import ccall unsafe "BN_CTX_free"+foreign import capi unsafe "openssl/bn.h BN_CTX_free" _BN_ctx_free :: BNCtx -> IO () withBNCtx :: (BNCtx -> IO a) -> IO a@@ -307,10 +313,10 @@ {- Random Integer generation ------------------------------------------------ -} -foreign import ccall unsafe "BN_rand_range"+foreign import capi unsafe "openssl/bn.h BN_rand_range" _BN_rand_range :: Ptr BIGNUM -> Ptr BIGNUM -> IO CInt -foreign import ccall unsafe "BN_pseudo_rand_range"+foreign import capi unsafe "openssl/bn.h BN_pseudo_rand_range" _BN_pseudo_rand_range :: Ptr BIGNUM -> Ptr BIGNUM -> IO CInt -- | Return a strongly random number in the range 0 <= x < n where the given@@ -336,7 +342,7 @@ prandIntegerUptoNMinusOneSuchThat f range = withBN range (\bnRange -> (do r <- newBN 0 let try = do- _BN_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf_ (/= 1)+ _BN_pseudo_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf_ (/= 1) i <- bnToInteger r if f i then return i
OpenSSL/Cipher.hsc view
@@ -1,6 +1,9 @@ #include "HsOpenSSL.h" #include "openssl/aes.h" +{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-} -- | This module interfaces to some of the OpenSSL ciphers without using -- EVP (see OpenSSL.EVP.Cipher). The EVP ciphers are easier to use, -- however, in some cases you cannot do without using the OpenSSL@@ -17,7 +20,10 @@ , AESCtx , newAESCtx , aesCBC- , aesCTR)+#if OPENSSL_VERSION_NUMBER < 0x10100000L+ , aesCTR+#endif+ ) where import Control.Monad (when, unless)@@ -34,7 +40,7 @@ modeToInt Encrypt = 1 modeToInt Decrypt = 0 -data AES_KEY+data {-# CTYPE "openssl/aes.h" "AES_KEY" #-} AES_KEY data AESCtx = AESCtx (ForeignPtr AES_KEY) -- the key schedule (ForeignPtr CUChar) -- the IV / counter@@ -42,24 +48,21 @@ (IORef CUInt) -- the number of bytes of the encrypted counter used Mode -foreign import ccall unsafe "memcpy"+foreign import capi unsafe "string.h memcpy" _memcpy :: Ptr CUChar -> Ptr CChar -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "memset"+foreign import capi unsafe "string.h memset" _memset :: Ptr CUChar -> CChar -> CSize -> IO () -foreign import ccall unsafe "AES_set_encrypt_key"+foreign import capi unsafe "openssl/aes.h AES_set_encrypt_key" _AES_set_encrypt_key :: Ptr CChar -> CInt -> Ptr AES_KEY -> IO CInt-foreign import ccall unsafe "AES_set_decrypt_key"+foreign import capi unsafe "openssl/aes.h AES_set_decrypt_key" _AES_set_decrypt_key :: Ptr CChar -> CInt -> Ptr AES_KEY -> IO CInt -foreign import ccall unsafe "AES_cbc_encrypt"+foreign import capi unsafe "openssl/aes.h AES_cbc_encrypt" _AES_cbc_encrypt :: Ptr CChar -> Ptr Word8 -> CULong -> Ptr AES_KEY -> Ptr CUChar -> CInt -> IO () -foreign import ccall unsafe "AES_ctr128_encrypt"- _AES_ctr_encrypt :: Ptr CChar -> Ptr Word8 -> CULong -> Ptr AES_KEY -> Ptr CUChar -> Ptr CUChar -> Ptr CUInt -> IO ()--foreign import ccall unsafe "&free"+foreign import capi unsafe "stdlib.h &free" _free :: FunPtr (Ptr a -> IO ()) -- | Construct a new context which holds the key schedule and IV.@@ -99,6 +102,11 @@ BSI.create (BS.length input) $ \out -> _AES_cbc_encrypt ptr out (fromIntegral len) ctxPtr ivPtr $ modeToInt mode +#if OPENSSL_VERSION_NUMBER < 0x10100000L+-- seems that AES_ctr128_encrypt was removed in recent OpenSSL versions+foreign import capi unsafe "openssl/aes.h AES_ctr128_encrypt"+ _AES_ctr_encrypt :: Ptr CChar -> Ptr Word8 -> CULong -> Ptr AES_KEY -> Ptr CUChar -> Ptr CUChar -> Ptr CUInt -> IO ()+ -- | Encrypt some number of bytes using CTR mode. This is an IO function -- because the context is destructivly updated. aesCTR :: AESCtx -- ^ context@@ -117,3 +125,4 @@ _AES_ctr_encrypt ptr out (fromIntegral len) ctxPtr ivPtr ecptr nptr n' <- peek nptr writeIORef nref n'+#endif
+ OpenSSL/DER.hsc view
@@ -0,0 +1,92 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- |Encoding and decoding of RSA keys using the ASN.1 DER format+module OpenSSL.DER+ ( toDERPub+ , fromDERPub+ , toDERPriv+ , fromDERPriv+ )+ where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import OpenSSL.RSA (RSA, RSAKey, RSAKeyPair, RSAPubKey,+ absorbRSAPtr, withRSAPtr)++import Data.ByteString (ByteString)+import qualified Data.ByteString as B (useAsCStringLen)+import qualified Data.ByteString.Internal as BI (createAndTrim)+import Foreign.Ptr (Ptr, nullPtr, castPtr)+import Foreign.C.Types (CLong(..), CInt(..))+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (poke)+import GHC.Word (Word8)+import System.IO.Unsafe (unsafePerformIO)++type CDecodeFun = Ptr (Ptr RSA) -> Ptr (Ptr Word8) -> CLong -> IO (Ptr RSA)+type CEncodeFun = Ptr RSA -> Ptr (Ptr Word8) -> IO CInt++foreign import capi unsafe "HsOpenSSL.h d2i_RSAPublicKey"+ _fromDERPub :: CDecodeFun++foreign import capi unsafe "HsOpenSSL.h i2d_RSAPublicKey"+ _toDERPub :: CEncodeFun++foreign import capi unsafe "HsOpenSSL.h d2i_RSAPrivateKey"+ _fromDERPriv :: CDecodeFun++foreign import capi unsafe "HsOpenSSL.h i2d_RSAPrivateKey"+ _toDERPriv :: CEncodeFun++-- | Generate a function that decodes a key from ASN.1 DER format+makeDecodeFun :: RSAKey k => CDecodeFun -> ByteString -> Maybe k+makeDecodeFun fun bs = unsafePerformIO . usingConvedBS $ \(csPtr, ci) -> do+ -- When you pass a null pointer to this function, it will allocate the memory+ -- space required for the RSA key all by itself. It will be freed whenever+ -- the haskell object is garbage collected, as they are stored in ForeignPtrs+ -- internally.+ rsaPtr <- fun nullPtr (castPtr csPtr) ci+ -- CString is represented as a void* in C and the C compiler whines about+ -- a bad pointer conversion in d2i_* functions. So we declare+ -- the CDecodeFun to accept Ptr Word8 and perform the castPtr here.+ if rsaPtr == nullPtr then return Nothing else absorbRSAPtr rsaPtr+ where usingConvedBS io = B.useAsCStringLen bs $ \(cs, len) ->+ alloca $ \csPtr -> poke csPtr cs >> io (csPtr, fromIntegral len)++-- | Generate a function that encodes a key in ASN.1 DER format+makeEncodeFun :: RSAKey k => CEncodeFun -> k -> ByteString+makeEncodeFun fun k = unsafePerformIO $ do+ -- When you pass a null pointer to this function, it will only compute the+ -- required buffer size. See https://www.openssl.org/docs/faq.html#PROG3+ requiredSize <- withRSAPtr k $ flip fun nullPtr+ -- It’s too sad BI.createAndTrim is considered internal, as it does a great+ -- job here. See https://hackage.haskell.org/package/bytestring-0.9.1.4/docs/Data-ByteString-Internal.html#v%3AcreateAndTrim+ BI.createAndTrim (fromIntegral requiredSize) $ \ptr ->+ alloca $ \pptr ->+ (fromIntegral <$>) . withRSAPtr k $ \key ->+ poke pptr ptr >> fun key pptr++-- | Dump a public key to ASN.1 DER format+toDERPub :: RSAKey k+ => k -- ^ You can pass either 'RSAPubKey' or 'RSAKeyPair'+ -- because both contain the necessary information.+ -> ByteString -- ^ The public key information encoded in ASN.1 DER+toDERPub = makeEncodeFun _toDERPub++-- | Parse a public key from ASN.1 DER format+fromDERPub :: ByteString -> Maybe RSAPubKey+fromDERPub = makeDecodeFun _fromDERPub++-- | Dump a private key to ASN.1 DER format+toDERPriv :: RSAKeyPair -> ByteString+toDERPriv = makeEncodeFun _toDERPriv++-- | Parse a private key from ASN.1 DER format+fromDERPriv :: RSAKey k+ => ByteString -- ^ The private key information encoded in ASN.1 DER+ -> Maybe k -- ^ This can return either 'RSAPubKey' or+ -- 'RSAKeyPair' because there’s sufficient+ -- information for both.+fromDERPriv = makeDecodeFun _fromDERPriv
OpenSSL/DH.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-} -- | Diffie-Hellman key exchange module OpenSSL.DH ( DHP@@ -16,7 +18,9 @@ import Data.Word (Word8) import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as BS+#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))+#endif import Foreign.Ptr (Ptr, nullPtr) #if MIN_VERSION_base(4,5,0) import Foreign.C.Types (CInt(..))@@ -79,20 +83,19 @@ fromIntegral <$> _DH_compute_key bsPtr (unwrapBN bn) dhPtr >>= failIf (< 0) -foreign import ccall "DH_generate_parameters"+foreign import capi "openssl/dh.h DH_generate_parameters" _DH_generate_parameters :: CInt -> CInt -> Ptr () -> Ptr () -> IO (Ptr DH_)-foreign import ccall "DH_generate_key"+foreign import capi "openssl/dh.h DH_generate_key" _DH_generate_key :: Ptr DH_ -> IO CInt-foreign import ccall "DH_compute_key"+foreign import capi "openssl/dh.h DH_compute_key" _DH_compute_key :: Ptr Word8 -> Ptr BIGNUM -> Ptr DH_ -> IO CInt-foreign import ccall "DH_check"+foreign import capi "openssl/dh.h DH_check" _DH_check :: Ptr DH_ -> Ptr CInt -> IO Bool-foreign import ccall unsafe "DH_size"+foreign import capi unsafe "openssl/dh.h DH_size" _DH_size :: Ptr DH_ -> IO CInt-foreign import ccall unsafe "HsOpenSSL_DHparams_dup"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_DHparams_dup" _DH_dup :: Ptr DH_ -> IO (Ptr DH_)-foreign import ccall unsafe "HsOpenSSL_DH_get_pub_key"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_DH_get_pub_key" _DH_get_pub_key :: Ptr DH_ -> IO (Ptr BIGNUM)-foreign import ccall unsafe "HsOpenSSL_DH_length"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_DH_length" _DH_length :: Ptr DH_ -> IO CInt-
+ OpenSSL/DH/Internal.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+module OpenSSL.DH.Internal (+ DH_,+ DHP,+ withDHPPtr,+ wrapDHPPtrWith,+ wrapDHPPtr,+ DH,+ withDHPtr,+ wrapDHPtrWith,+ wrapDHPtr,+ asDH,+ asDHP+ ) where++import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import qualified Foreign.Concurrent as FC++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++data {-# CTYPE "openssl/dh.h" "DH" #-} DH_+newtype DHP = DHP (ForeignPtr DH_)++withDHPPtr :: DHP -> (Ptr DH_ -> IO a) -> IO a+withDHPPtr (DHP fp) = withForeignPtr fp++wrapDHPPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DHP+wrapDHPPtrWith fin p = DHP <$> FC.newForeignPtr p (fin p)++wrapDHPPtr :: Ptr DH_ -> IO DHP+wrapDHPPtr = wrapDHPPtrWith _DH_free++newtype DH = DH (ForeignPtr DH_)++withDHPtr :: DH -> (Ptr DH_ -> IO a) -> IO a+withDHPtr (DH fp) = withForeignPtr fp++wrapDHPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DH+wrapDHPtrWith fin p = DH <$> FC.newForeignPtr p (fin p)++wrapDHPtr :: Ptr DH_ -> IO DH+wrapDHPtr = wrapDHPtrWith _DH_free++asDH :: DHP -> DH+asDH (DHP fp) = DH fp++asDHP :: DH -> DHP+asDHP (DH fp) = DHP fp++foreign import capi "openssl/dh.h DH_free"+ _DH_free :: Ptr DH_ -> IO ()
− OpenSSL/DH/Internal.hsc
@@ -1,51 +0,0 @@-module OpenSSL.DH.Internal (- DH_,- DHP,- withDHPPtr,- wrapDHPPtrWith,- wrapDHPPtr,- DH,- withDHPtr,- wrapDHPtrWith,- wrapDHPtr,- asDH,- asDHP- ) where--import Control.Applicative ((<$>))-import Foreign.Ptr (Ptr)-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)-import qualified Foreign.Concurrent as FC--data DH_-newtype DHP = DHP (ForeignPtr DH_)--withDHPPtr :: DHP -> (Ptr DH_ -> IO a) -> IO a-withDHPPtr (DHP fp) = withForeignPtr fp--wrapDHPPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DHP-wrapDHPPtrWith fin p = DHP <$> FC.newForeignPtr p (fin p)--wrapDHPPtr :: Ptr DH_ -> IO DHP-wrapDHPPtr = wrapDHPPtrWith _DH_free--newtype DH = DH (ForeignPtr DH_)--withDHPtr :: DH -> (Ptr DH_ -> IO a) -> IO a-withDHPtr (DH fp) = withForeignPtr fp--wrapDHPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DH-wrapDHPtrWith fin p = DH <$> FC.newForeignPtr p (fin p)--wrapDHPtr :: Ptr DH_ -> IO DH-wrapDHPtr = wrapDHPtrWith _DH_free--asDH :: DHP -> DH-asDH (DHP fp) = DH fp--asDHP :: DH -> DHP-asDHP (DH fp) = DHP fp--foreign import ccall "DH_free"- _DH_free :: Ptr DH_ -> IO ()-
OpenSSL/DSA.hsc view
@@ -1,12 +1,10 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK prune #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# OPTIONS_HADDOCK prune #-} -- | The Digital Signature Algorithm (FIPS 186-2). -- See <http://www.openssl.org/docs/crypto/dsa.html>--#include "HsOpenSSL.h"- module OpenSSL.DSA ( -- * Type DSAKey(..)@@ -30,16 +28,23 @@ , tupleToDSAPubKey , tupleToDSAKeyPair ) where--import Control.Monad+#include "HsOpenSSL.h"+import Control.Monad import qualified Data.ByteString as BS-import Data.Typeable-import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe (unsafePerformIO)-import Foreign.C (CString)-import Foreign.C.Types-import OpenSSL.BN-import OpenSSL.Utils+import Data.Typeable+import Foreign.C.String (CString)+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CChar(..), CInt(..))+#else+import Foreign.C.Types (CChar, CInt)+#endif+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (FunPtr, Ptr, nullPtr)+import Foreign.Storable (Storable(..))+import OpenSSL.BN+import OpenSSL.Utils+import System.IO.Unsafe (unsafePerformIO) -- | The type of a DSA public key, includes parameters p, q, g and public. newtype DSAPubKey = DSAPubKey (ForeignPtr DSA)@@ -64,19 +69,19 @@ -- |Return the public prime number of the key. dsaP :: k -> Integer- dsaP = peekI (#peek DSA, p)+ dsaP = peekI dsa_p -- |Return the public 160-bit subprime, @q | p - 1@ of the key. dsaQ :: k -> Integer- dsaQ = peekI (#peek DSA, q)+ dsaQ = peekI dsa_q -- |Return the public generator of subgroup of the key. dsaG :: k -> Integer- dsaG = peekI (#peek DSA, g)+ dsaG = peekI dsa_g -- |Return the public key @y = g^x@. dsaPublic :: k -> Integer- dsaPublic = peekI (#peek DSA, pub_key)+ dsaPublic = peekI dsa_pub_key -- private withDSAPtr :: k -> (Ptr DSA -> IO a) -> IO a@@ -108,42 +113,109 @@ hasDSAPrivateKey :: Ptr DSA -> IO Bool hasDSAPrivateKey dsaPtr- = fmap (/= nullPtr) ((#peek DSA, priv_key) dsaPtr)+ = fmap (/= nullPtr) (dsa_priv_key dsaPtr) -foreign import ccall unsafe "&DSA_free"+foreign import capi unsafe "openssl/dsa.h &DSA_free" _free :: FunPtr (Ptr DSA -> IO ()) -foreign import ccall unsafe "DSA_free"+foreign import capi unsafe "openssl/dsa.h DSA_free" dsa_free :: Ptr DSA -> IO () -foreign import ccall unsafe "BN_free"+foreign import capi unsafe "openssl/dsa.h BN_free" _bn_free :: Ptr BIGNUM -> IO () -foreign import ccall unsafe "DSA_new"+foreign import capi unsafe "openssl/dsa.h DSA_new" _dsa_new :: IO (Ptr DSA) -foreign import ccall unsafe "DSA_generate_key"+foreign import capi unsafe "openssl/dsa.h DSA_generate_key" _dsa_generate_key :: Ptr DSA -> IO () -foreign import ccall unsafe "HsOpenSSL_dsa_sign"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_dsa_sign" _dsa_sign :: Ptr DSA -> CString -> CInt -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO CInt -foreign import ccall unsafe "HsOpenSSL_dsa_verify"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_dsa_verify" _dsa_verify :: Ptr DSA -> CString -> CInt -> Ptr BIGNUM -> Ptr BIGNUM -> IO CInt -foreign import ccall safe "DSA_generate_parameters"+foreign import capi safe "openssl/dsa.h DSA_generate_parameters" _generate_params :: CInt -> Ptr CChar -> CInt -> Ptr CInt -> Ptr CInt -> Ptr () -> Ptr () -> IO (Ptr DSA) -foreign import ccall unsafe "HsOpenSSL_DSAPublicKey_dup"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_DSAPublicKey_dup" _pubDup :: Ptr DSA -> IO (Ptr DSA) -foreign import ccall unsafe "HsOpenSSL_DSAPrivateKey_dup"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_DSAPrivateKey_dup" _privDup :: Ptr DSA -> IO (Ptr DSA) -foreign import ccall unsafe "DSA_size"+foreign import capi unsafe "openssl/dsa.h DSA_size" _size :: Ptr DSA -> IO CInt +dsa_p, dsa_q, dsa_g, dsa_pub_key, dsa_priv_key :: Ptr DSA -> IO (Ptr BIGNUM)+setPQG :: Ptr DSA -> Integer -> Integer -> Integer -> IO ()+setKey :: Ptr DSA -> Ptr BIGNUM -> Ptr BIGNUM -> IO ()++#if OPENSSL_VERSION_NUMBER >= 0x10100000L++foreign import capi unsafe "openssl/dsa.h DSA_get0_pqg"+ _get0_pqg :: Ptr DSA -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO ()++foreign import capi unsafe "openssl/dsa.h DSA_get0_key"+ _get0_key :: Ptr DSA -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO ()++foreign import capi unsafe "openssl/dsa.h DSA_set0_pqg"+ _set0_pqg :: Ptr DSA -> Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> IO CInt++foreign import capi unsafe "openssl/dsa.h DSA_set0_key"+ _set0_key :: Ptr DSA -> Ptr BIGNUM -> Ptr BIGNUM -> IO CInt++withPQG :: (Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO a)+ -> Ptr DSA -> IO a+withPQG f dsa = alloca $ \ p -> alloca $ \ q -> alloca $ \ g -> do+ poke p nullPtr+ poke q nullPtr+ poke g nullPtr+ _get0_pqg dsa p q g+ f p q g++dsa_p = withPQG $ \ p _ _ -> peek p+dsa_q = withPQG $ \ _ q _ -> peek q+dsa_g = withPQG $ \ _ _ g -> peek g++withKey :: (Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO a) -> Ptr DSA -> IO a+withKey f dsa = alloca $ \ pub -> alloca $ \ priv -> do+ poke pub nullPtr+ poke priv nullPtr+ _get0_key dsa pub priv+ f pub priv+dsa_pub_key = withKey $ \ p _ -> peek p+dsa_priv_key = withKey $ \ _ p -> peek p++setPQG ptr p q g = do+ p' <- fmap unwrapBN (newBN p)+ q' <- fmap unwrapBN (newBN q)+ g' <- fmap unwrapBN (newBN g)+ void $ _set0_pqg ptr p' q' g'++setKey ptr pub priv = void $ _set0_key ptr pub priv++#else++dsa_p = (#peek DSA, p)+dsa_q = (#peek DSA, q)+dsa_g = (#peek DSA, g)+dsa_pub_key = (#peek DSA, pub_key)+dsa_priv_key = (#peek DSA, priv_key)++setPQG ptr p q g = do+ fmap unwrapBN (newBN p) >>= (#poke DSA, p) ptr+ fmap unwrapBN (newBN q) >>= (#poke DSA, q) ptr+ fmap unwrapBN (newBN g) >>= (#poke DSA, g) ptr++setKey ptr pub priv = do+ (#poke DSA, pub_key ) ptr pub+ (#poke DSA, priv_key) ptr priv++#endif+ peekI :: DSAKey k => (Ptr DSA -> IO (Ptr BIGNUM)) -> k -> Integer peekI peeker dsa = unsafePerformIO $@@ -169,9 +241,9 @@ failIfNull_ ptr itcount <- peek i1 gencount <- peek i2- p <- (#peek DSA, p) ptr >>= peekBN . wrapBN- q <- (#peek DSA, q) ptr >>= peekBN . wrapBN- g <- (#peek DSA, g) ptr >>= peekBN . wrapBN+ p <- dsa_p ptr >>= peekBN . wrapBN+ q <- dsa_q ptr >>= peekBN . wrapBN+ g <- dsa_g ptr >>= peekBN . wrapBN dsa_free ptr return (fromIntegral itcount, fromIntegral gencount, p, q, g)))) @@ -202,24 +274,22 @@ -> IO DSAKeyPair generateDSAKey p q g = do ptr <- _dsa_new- fmap unwrapBN (newBN p) >>= (#poke DSA, p) ptr- fmap unwrapBN (newBN q) >>= (#poke DSA, q) ptr- fmap unwrapBN (newBN g) >>= (#poke DSA, g) ptr+ setPQG ptr p q g _dsa_generate_key ptr fmap DSAKeyPair (newForeignPtr _free ptr) -- |Return the private key @x@. dsaPrivate :: DSAKeyPair -> Integer-dsaPrivate = peekI (#peek DSA, priv_key)+dsaPrivate = peekI dsa_priv_key -- | Convert a DSAPubKey object to a tuple of its members in the -- order p, q, g, and public. dsaPubKeyToTuple :: DSAKeyPair -> (Integer, Integer, Integer, Integer) dsaPubKeyToTuple dsa- = let p = peekI (#peek DSA, p) dsa- q = peekI (#peek DSA, q) dsa- g = peekI (#peek DSA, g) dsa- pub = peekI (#peek DSA, pub_key) dsa+ = let p = peekI dsa_p dsa+ q = peekI dsa_q dsa+ g = peekI dsa_g dsa+ pub = peekI dsa_pub_key dsa in (p, q, g, pub) @@ -227,11 +297,11 @@ -- order p, q, g, public and private. dsaKeyPairToTuple :: DSAKeyPair -> (Integer, Integer, Integer, Integer, Integer) dsaKeyPairToTuple dsa- = let p = peekI (#peek DSA, p) dsa- q = peekI (#peek DSA, q) dsa- g = peekI (#peek DSA, g) dsa- pub = peekI (#peek DSA, pub_key ) dsa- pri = peekI (#peek DSA, priv_key) dsa+ = let p = peekI dsa_p dsa+ q = peekI dsa_q dsa+ g = peekI dsa_g dsa+ pub = peekI dsa_pub_key dsa+ pri = peekI dsa_priv_key dsa in (p, q, g, pub, pri) @@ -240,11 +310,9 @@ tupleToDSAPubKey :: (Integer, Integer, Integer, Integer) -> DSAPubKey tupleToDSAPubKey (p, q, g, pub) = unsafePerformIO $ do ptr <- _dsa_new- fmap unwrapBN (newBN p ) >>= (#poke DSA, p) ptr- fmap unwrapBN (newBN q ) >>= (#poke DSA, q) ptr- fmap unwrapBN (newBN g ) >>= (#poke DSA, g) ptr- fmap unwrapBN (newBN pub) >>= (#poke DSA, pub_key) ptr- (#poke DSA, priv_key) ptr nullPtr+ setPQG ptr p q g+ pub' <- fmap unwrapBN (newBN pub)+ setKey ptr pub' nullPtr fmap DSAPubKey (newForeignPtr _free ptr) -- | Convert a tuple of members (in the same format as from@@ -252,11 +320,10 @@ tupleToDSAKeyPair :: (Integer, Integer, Integer, Integer, Integer) -> DSAKeyPair tupleToDSAKeyPair (p, q, g, pub, pri) = unsafePerformIO $ do ptr <- _dsa_new- fmap unwrapBN (newBN p ) >>= (#poke DSA, p) ptr- fmap unwrapBN (newBN q ) >>= (#poke DSA, q) ptr- fmap unwrapBN (newBN g ) >>= (#poke DSA, g) ptr- fmap unwrapBN (newBN pub) >>= (#poke DSA, pub_key ) ptr- fmap unwrapBN (newBN pri) >>= (#poke DSA, priv_key) ptr+ setPQG ptr p q g+ pub' <- fmap unwrapBN (newBN pub)+ priv' <- fmap unwrapBN (newBN pri)+ setKey ptr pub' priv' fmap DSAKeyPair (newForeignPtr _free ptr) -- | A utility function to generate both the parameters and the key pair at the
+ OpenSSL/ERR.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+module OpenSSL.ERR+ ( getError+ , peekError++ , errorString+ )+ where+import Foreign+import Foreign.C++foreign import capi unsafe "openssl/err.h ERR_get_error"+ getError :: IO CULong++foreign import capi unsafe "openssl/err.h ERR_peek_error"+ peekError :: IO CULong++foreign import capi unsafe "openssl/err.h ERR_error_string"+ _error_string :: CULong -> CString -> IO CString++errorString :: CULong -> IO String+errorString code+ = _error_string code nullPtr >>= peekCString
− OpenSSL/ERR.hsc
@@ -1,22 +0,0 @@-module OpenSSL.ERR- ( getError- , peekError-- , errorString- )- where-import Foreign-import Foreign.C--foreign import ccall unsafe "ERR_get_error"- getError :: IO CULong--foreign import ccall unsafe "ERR_peek_error"- peekError :: IO CULong--foreign import ccall unsafe "ERR_error_string"- _error_string :: CULong -> CString -> IO CString--errorString :: CULong -> IO String-errorString code- = _error_string code nullPtr >>= peekCString
+ OpenSSL/EVP/Base64.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- |An interface to Base64 codec.+module OpenSSL.EVP.Base64+ ( -- * Encoding+ encodeBase64+ , encodeBase64BS+ , encodeBase64LBS++ -- * Decoding+ , decodeBase64+ , decodeBase64BS+ , decodeBase64LBS+ )+ where+import Control.Exception (assert)+import Data.ByteString.Internal (createAndTrim)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import qualified Data.ByteString.Lazy.Internal as L8Internal+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.List+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CUChar(..), CInt(..))+#else+import Foreign.C.Types (CUChar, CInt)+#endif+import Foreign.Ptr (Ptr, castPtr)+import System.IO.Unsafe (unsafePerformIO)+++-- On encoding, we keep fetching the next block until we get at least+-- 3 bytes. Then we apply B8.concat to the returned [ByteString] and+-- split it at the offset in multiple of 3, then prepend the remaining+-- bytes to the next block.+--+-- On decoding, we apply the same algorithm but we split the input in+-- multiple of 4.+nextBlock :: Int -> ([B8.ByteString], L8.ByteString) -> ([B8.ByteString], L8.ByteString)+nextBlock minLen (xs, src)+ = if foldl' (+) 0 (map B8.length xs) >= minLen then+ (xs, src)+ else+ case src of+ L8Internal.Empty -> (xs, src)+ L8Internal.Chunk y ys -> nextBlock minLen (xs ++ [y], ys)+++{- encode -------------------------------------------------------------------- -}++foreign import capi unsafe "openssl/evp.h EVP_EncodeBlock"+ _EncodeBlock :: Ptr CUChar -> Ptr CUChar -> CInt -> IO CInt+++encodeBlock :: B8.ByteString -> B8.ByteString+encodeBlock inBS+ = unsafePerformIO $+ unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) ->+ createAndTrim maxOutLen $ \ outBuf ->+ fmap fromIntegral+ (_EncodeBlock (castPtr outBuf) (castPtr inBuf) (fromIntegral inLen))+ where+ maxOutLen = (inputLen `div` 3 + 1) * 4 + 1 -- +1: '\0'+ inputLen = B8.length inBS+++-- |@'encodeBase64' str@ lazilly encodes a stream of data to+-- Base64. The string doesn't have to be finite. Note that the string+-- must not contain any letters which aren't in the range of U+0000 -+-- U+00FF.+{-# DEPRECATED encodeBase64 "Use encodeBase64BS or encodeBase64LBS instead." #-}+encodeBase64 :: String -> String+encodeBase64 = L8.unpack . encodeBase64LBS . L8.pack++-- |@'encodeBase64BS' bs@ strictly encodes a chunk of data to Base64.+encodeBase64BS :: B8.ByteString -> B8.ByteString+encodeBase64BS = encodeBlock++-- |@'encodeBase64LBS' lbs@ lazilly encodes a stream of data to+-- Base64. The string doesn't have to be finite.+encodeBase64LBS :: L8.ByteString -> L8.ByteString+encodeBase64LBS inLBS+ | L8.null inLBS = L8.empty+ | otherwise+ = let (blockParts', remain' ) = nextBlock 3 ([], inLBS)+ block' = B8.concat blockParts'+ blockLen' = B8.length block'+ (block , leftover) = if blockLen' < 3 then+ -- The last remnant.+ (block', B8.empty)+ else+ B8.splitAt (blockLen' - blockLen' `mod` 3) block'+ remain = if B8.null leftover then+ remain'+ else+ L8.fromChunks [leftover] `L8.append` remain'+ encodedBlock = encodeBlock block+ encodedRemain = encodeBase64LBS remain+ in+ L8.fromChunks [encodedBlock] `L8.append` encodedRemain+++{- decode -------------------------------------------------------------------- -}++foreign import capi unsafe "openssl/evp.h EVP_DecodeBlock"+ _DecodeBlock :: Ptr CUChar -> Ptr CUChar -> CInt -> IO CInt+++decodeBlock :: B8.ByteString -> B8.ByteString+decodeBlock inBS+ = assert (B8.length inBS `mod` 4 == 0) $+ unsafePerformIO $+ unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) ->+ createAndTrim (B8.length inBS) $ \ outBuf ->+ _DecodeBlock (castPtr outBuf) (castPtr inBuf) (fromIntegral inLen)+ >>= \ outLen -> return (fromIntegral outLen - paddingLen)+ where+ paddingLen :: Int+ paddingLen = B8.count '=' inBS++-- |@'decodeBase64' str@ lazilly decodes a stream of data from+-- Base64. The string doesn't have to be finite.+{-# DEPRECATED decodeBase64 "Use decodeBase64BS or decodeBase64LBS instead." #-}+decodeBase64 :: String -> String+decodeBase64 = L8.unpack . decodeBase64LBS . L8.pack++-- |@'decodeBase64BS' bs@ strictly decodes a chunk of data from+-- Base64.+decodeBase64BS :: B8.ByteString -> B8.ByteString+decodeBase64BS = decodeBlock++-- |@'decodeBase64LBS' lbs@ lazilly decodes a stream of data from+-- Base64. The string doesn't have to be finite.+decodeBase64LBS :: L8.ByteString -> L8.ByteString+decodeBase64LBS inLBS+ | L8.null inLBS = L8.empty+ | otherwise+ = let (blockParts', remain' ) = nextBlock 4 ([], inLBS)+ block' = B8.concat blockParts'+ blockLen' = B8.length block'+ (block , leftover) = assert (blockLen' >= 4) $+ B8.splitAt (blockLen' - blockLen' `mod` 4) block'+ remain = if B8.null leftover then+ remain'+ else+ L8.fromChunks [leftover] `L8.append` remain'+ decodedBlock = decodeBlock block+ decodedRemain = decodeBase64LBS remain+ in+ L8.fromChunks [decodedBlock] `L8.append` decodedRemain
− OpenSSL/EVP/Base64.hsc
@@ -1,146 +0,0 @@-{- -*- haskell -*- -}---- |An interface to Base64 codec.--module OpenSSL.EVP.Base64- ( -- * Encoding- encodeBase64- , encodeBase64BS- , encodeBase64LBS-- -- * Decoding- , decodeBase64- , decodeBase64BS- , decodeBase64LBS- )- where--import Control.Exception hiding (block)-import Data.ByteString.Internal (createAndTrim)-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-import qualified Data.ByteString.Lazy.Internal as L8Internal-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Data.List-import Foreign hiding (unsafePerformIO)-import Foreign.C-import System.IO.Unsafe (unsafePerformIO)----- On encoding, we keep fetching the next block until we get at least--- 3 bytes. Then we apply B8.concat to the returned [ByteString] and--- split it at the offset in multiple of 3, then prepend the remaining--- bytes to the next block.------ On decoding, we apply the same algorithm but we split the input in--- multiple of 4.-nextBlock :: Int -> ([B8.ByteString], L8.ByteString) -> ([B8.ByteString], L8.ByteString)-nextBlock minLen (xs, src)- = if foldl' (+) 0 (map B8.length xs) >= minLen then- (xs, src)- else- case src of- L8Internal.Empty -> (xs, src)- L8Internal.Chunk y ys -> nextBlock minLen (xs ++ [y], ys)---{- encode -------------------------------------------------------------------- -}--foreign import ccall unsafe "EVP_EncodeBlock"- _EncodeBlock :: Ptr CChar -> Ptr CChar -> CInt -> IO CInt---encodeBlock :: B8.ByteString -> B8.ByteString-encodeBlock inBS- = unsafePerformIO $- unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) ->- createAndTrim maxOutLen $ \ outBuf ->- fmap fromIntegral- (_EncodeBlock (castPtr outBuf) inBuf (fromIntegral inLen))- where- maxOutLen = (inputLen `div` 3 + 1) * 4 + 1 -- +1: '\0'- inputLen = B8.length inBS----- |@'encodeBase64' str@ lazilly encodes a stream of data to--- Base64. The string doesn't have to be finite. Note that the string--- must not contain any letters which aren't in the range of U+0000 ---- U+00FF.-encodeBase64 :: String -> String-encodeBase64 = L8.unpack . encodeBase64LBS . L8.pack---- |@'encodeBase64BS' bs@ strictly encodes a chunk of data to Base64.-encodeBase64BS :: B8.ByteString -> B8.ByteString-encodeBase64BS = encodeBlock---- |@'encodeBase64LBS' lbs@ lazilly encodes a stream of data to--- Base64. The string doesn't have to be finite.-encodeBase64LBS :: L8.ByteString -> L8.ByteString-encodeBase64LBS inLBS- | L8.null inLBS = L8.empty- | otherwise- = let (blockParts', remain' ) = nextBlock 3 ([], inLBS)- block' = B8.concat blockParts'- blockLen' = B8.length block'- (block , leftover) = if blockLen' < 3 then- -- The last remnant.- (block', B8.empty)- else- B8.splitAt (blockLen' - blockLen' `mod` 3) block'- remain = if B8.null leftover then- remain'- else- L8.fromChunks [leftover] `L8.append` remain'- encodedBlock = encodeBlock block- encodedRemain = encodeBase64LBS remain- in- L8.fromChunks [encodedBlock] `L8.append` encodedRemain---{- decode -------------------------------------------------------------------- -}--foreign import ccall unsafe "EVP_DecodeBlock"- _DecodeBlock :: Ptr CChar -> Ptr CChar -> CInt -> IO CInt---decodeBlock :: B8.ByteString -> B8.ByteString-decodeBlock inBS- = assert (B8.length inBS `mod` 4 == 0) $- unsafePerformIO $- unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) ->- createAndTrim (B8.length inBS) $ \ outBuf ->- _DecodeBlock (castPtr outBuf) inBuf (fromIntegral inLen)- >>= \ outLen -> return (fromIntegral outLen - paddingLen)- where- paddingLen :: Int- paddingLen = B8.count '=' inBS---- |@'decodeBase64' str@ lazilly decodes a stream of data from--- Base64. The string doesn't have to be finite.-decodeBase64 :: String -> String-decodeBase64 = L8.unpack . decodeBase64LBS . L8.pack---- |@'decodeBase64BS' bs@ strictly decodes a chunk of data from--- Base64.-decodeBase64BS :: B8.ByteString -> B8.ByteString-decodeBase64BS = decodeBlock---- |@'decodeBase64LBS' lbs@ lazilly decodes a stream of data from--- Base64. The string doesn't have to be finite.-decodeBase64LBS :: L8.ByteString -> L8.ByteString-decodeBase64LBS inLBS- | L8.null inLBS = L8.empty- | otherwise- = let (blockParts', remain' ) = nextBlock 4 ([], inLBS)- block' = B8.concat blockParts'- blockLen' = B8.length block'- (block , leftover) = assert (blockLen' >= 4) $- B8.splitAt (blockLen' - blockLen' `mod` 4) block'- remain = if B8.null leftover then- remain'- else- L8.fromChunks [leftover] `L8.append` remain'- decodedBlock = decodeBlock block- decodedRemain = decodeBase64LBS remain- in- L8.fromChunks [decodedBlock] `L8.append` decodedRemain
+ OpenSSL/EVP/Cipher.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- |An interface to symmetric cipher algorithms.+module OpenSSL.EVP.Cipher+ ( Cipher+ , getCipherByName+ , getCipherNames++ , CryptoMode(..)++ , cipher+ , cipherBS+ , cipherLBS+ , cipherStrictLBS+ )+ where+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Foreign+import Foreign.C+import OpenSSL.Objects+import OpenSSL.EVP.Internal++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif++foreign import capi unsafe "openssl/evp.h EVP_get_cipherbyname"+ _get_cipherbyname :: CString -> IO (Ptr EVP_CIPHER)++-- |@'getCipherByName' name@ returns a symmetric cipher algorithm+-- whose name is @name@. If no algorithms are found, the result is+-- @Nothing@.+getCipherByName :: String -> IO (Maybe Cipher)+getCipherByName name+ = withCString name $ \ namePtr ->+ do ptr <- _get_cipherbyname namePtr+ if ptr == nullPtr then+ return Nothing+ else+ return $ Just $ Cipher ptr++-- |@'getCipherNames'@ returns a list of name of symmetric cipher+-- algorithms.+getCipherNames :: IO [String]+getCipherNames = getObjNames CipherMethodType True++{- encrypt/decrypt ----------------------------------------------------------- -}++-- | Encrypt a lazy bytestring in a strict manner. Does not leak the keys.+cipherStrictLBS :: Cipher -- ^ Cipher+ -> B8.ByteString -- ^ Key+ -> B8.ByteString -- ^ IV+ -> CryptoMode -- ^ Encrypt\/Decrypt+ -> L8.ByteString -- ^ Input+ -> IO L8.ByteString+cipherStrictLBS c key iv mode input =+ do ctx <- cipherInitBS c key iv mode+ xs <- cipherUpdateBS ctx `mapM` L8.toChunks input+ x <- cipherFinalBS ctx+ return $ L8.fromChunks (xs `mappend` [x])++-- |@'cipher'@ lazilly encrypts or decrypts a stream of data. The+-- input string doesn't necessarily have to be finite.+cipher :: Cipher -- ^ algorithm to use+ -> String -- ^ symmetric key+ -> String -- ^ IV+ -> CryptoMode -- ^ operation+ -> String -- ^ An input string to encrypt\/decrypt. Note+ -- that the string must not contain any letters+ -- which aren't in the range of U+0000 -+ -- U+00FF.+ -> IO String -- ^ the result string+{-# DEPRECATED cipher "Use cipherBS, cipherLBS or cipherStrictLBS." #-}+cipher c key iv mode input+ = fmap L8.unpack $ cipherLBS c (B8.pack key) (B8.pack iv) mode (L8.pack input)++-- |@'cipherBS'@ strictly encrypts or decrypts a chunk of data.+cipherBS :: Cipher -- ^ algorithm to use+ -> B8.ByteString -- ^ symmetric key+ -> B8.ByteString -- ^ IV+ -> CryptoMode -- ^ operation+ -> B8.ByteString -- ^ input string to encrypt\/decrypt+ -> IO B8.ByteString -- ^ the result string+cipherBS c key iv mode input+ = do ctx <- cipherInitBS c key iv mode+ cipherStrictly ctx input++-- |@'cipherLBS'@ lazilly encrypts or decrypts a stream of data. The+-- input string doesn't necessarily have to be finite.+cipherLBS :: Cipher -- ^ algorithm to use+ -> B8.ByteString -- ^ symmetric key+ -> B8.ByteString -- ^ IV+ -> CryptoMode -- ^ operation+ -> L8.ByteString -- ^ input string to encrypt\/decrypt+ -> IO L8.ByteString -- ^ the result string+cipherLBS c key iv mode input+ = do ctx <- cipherInitBS c key iv mode+ cipherLazily ctx input
− OpenSSL/EVP/Cipher.hsc
@@ -1,125 +0,0 @@-{- -*- haskell -*- -}---- |An interface to symmetric cipher algorithms.--#include "HsOpenSSL.h"--module OpenSSL.EVP.Cipher- ( Cipher- , getCipherByName- , getCipherNames-- , CryptoMode(..)-- , cipherInit- , cipher- , cipherBS- , cipherLBS- , cipherStrictLBS- )- where-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Foreign-import Foreign.C-import OpenSSL.Objects-import OpenSSL.Utils-import OpenSSL.EVP.Internal--foreign import ccall unsafe "EVP_get_cipherbyname"- _get_cipherbyname :: CString -> IO (Ptr EVP_CIPHER)---- |@'getCipherByName' name@ returns a symmetric cipher algorithm--- whose name is @name@. If no algorithms are found, the result is--- @Nothing@.-getCipherByName :: String -> IO (Maybe Cipher)-getCipherByName name- = withCString name $ \ namePtr ->- do ptr <- _get_cipherbyname namePtr- if ptr == nullPtr then- return Nothing- else- return $ Just $ Cipher ptr---- |@'getCipherNames'@ returns a list of name of symmetric cipher--- algorithms.-getCipherNames :: IO [String]-getCipherNames = getObjNames CipherMethodType True--{- encrypt/decrypt ----------------------------------------------------------- -}---- |@CryptoMode@ represents instruction to 'cipher' and such like.-data CryptoMode = Encrypt | Decrypt--cryptoModeToInt :: CryptoMode -> CInt-cryptoModeToInt Encrypt = 1-cryptoModeToInt Decrypt = 0--foreign import ccall unsafe "EVP_CipherInit"- _CipherInit :: Ptr EVP_CIPHER_CTX -> Ptr EVP_CIPHER -> CString -> CString -> CInt -> IO CInt--cipherInit :: Cipher -> String -> String -> CryptoMode -> IO CipherCtx-cipherInit (Cipher c) key iv mode- = do ctx <- newCipherCtx- withCipherCtxPtr ctx $ \ ctxPtr ->- withCString key $ \ keyPtr ->- withCString iv $ \ ivPtr ->- _CipherInit ctxPtr c keyPtr ivPtr (cryptoModeToInt mode)- >>= failIf_ (/= 1)- return ctx---- | Encrypt a lazy bytestring in a strict manner. Does not leak the keys.-cipherStrictLBS :: Cipher -- ^ Cipher- -> B8.ByteString -- ^ Key- -> B8.ByteString -- ^ IV- -> CryptoMode -- ^ Encrypt\/Decrypt- -> L8.ByteString -- ^ Input- -> IO L8.ByteString-cipherStrictLBS (Cipher c) key iv mode input =- withNewCipherCtxPtr $ \cptr ->- unsafeUseAsCStringLen key $ \(keyp,_) ->- unsafeUseAsCStringLen iv $ \(ivp, _) -> do- failIf_ (/= 1) =<< _CipherInit cptr c keyp ivp (cryptoModeToInt mode)- cc <- fmap CipherCtx (newForeignPtr_ cptr)- rr <- cipherUpdateBS cc `mapM` L8.toChunks input- rf <- cipherFinalBS cc- return $ L8.fromChunks (rr++[rf])---- |@'cipher'@ lazilly encrypts or decrypts a stream of data. The--- input string doesn't necessarily have to be finite.-cipher :: Cipher -- ^ algorithm to use- -> String -- ^ symmetric key- -> String -- ^ IV- -> CryptoMode -- ^ operation- -> String -- ^ An input string to encrypt\/decrypt. Note- -- that the string must not contain any letters- -- which aren't in the range of U+0000 -- -- U+00FF.- -> IO String -- ^ the result string-cipher c key iv mode input- = fmap L8.unpack $ cipherLBS c key iv mode $ L8.pack input---- |@'cipherBS'@ strictly encrypts or decrypts a chunk of data.-cipherBS :: Cipher -- ^ algorithm to use- -> String -- ^ symmetric key- -> String -- ^ IV- -> CryptoMode -- ^ operation- -> B8.ByteString -- ^ input string to encrypt\/decrypt- -> IO B8.ByteString -- ^ the result string-cipherBS c key iv mode input- = do ctx <- cipherInit c key iv mode- cipherStrictly ctx input---- |@'cipherLBS'@ lazilly encrypts or decrypts a stream of data. The--- input string doesn't necessarily have to be finite.-cipherLBS :: Cipher -- ^ algorithm to use- -> String -- ^ symmetric key- -> String -- ^ IV- -> CryptoMode -- ^ operation- -> L8.ByteString -- ^ input string to encrypt\/decrypt- -> IO L8.ByteString -- ^ the result string-cipherLBS c key iv mode input- = do ctx <- cipherInit c key iv mode- cipherLazily ctx input-
OpenSSL/EVP/Digest.hsc view
@@ -1,9 +1,7 @@-{- -*- haskell -*- -}-+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-} -- |An interface to message digest algorithms.--#include "HsOpenSSL.h"- module OpenSSL.EVP.Digest ( Digest , getDigestByName@@ -11,26 +9,36 @@ , digest , digestBS- , digestBS' , digestLBS , hmacBS+ , hmacLBS , pkcs5_pbkdf2_hmac_sha1 ) where--import Data.ByteString.Internal (create)-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+#include "HsOpenSSL.h"+import Data.ByteString.Internal (create)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8-import Control.Applicative ((<$>))-import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe (unsafePerformIO)-import Foreign.C-import OpenSSL.EVP.Internal-import OpenSSL.Objects+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Foreign.C.String (CString, withCString)+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CChar(..), CInt(..), CSize(..), CUInt(..))+#else+import Foreign.C.Types (CChar, CInt, CSize, CUInt)+#endif+import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Array (allocaArray)+import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Foreign.Storable (peek)+import OpenSSL.EVP.Internal+import OpenSSL.Objects+import System.IO.Unsafe (unsafePerformIO) -foreign import ccall unsafe "EVP_get_digestbyname"+foreign import capi unsafe "openssl/evp.h EVP_get_digestbyname" _get_digestbyname :: CString -> IO (Ptr EVP_MD) -- |@'getDigestByName' name@ returns a message digest algorithm whose@@ -56,27 +64,23 @@ -- not contain any letters which aren't in the range of U+0000 - -- U+00FF. digest :: Digest -> String -> String+{-# DEPRECATED digest "Use digestBS or digestLBS instead." #-} digest md input- = digestLBS md $ L8.pack input+ = B8.unpack $ digestLBS md $ L8.pack input -- |@'digestBS'@ digests a chunk of data.-digestBS :: Digest -> B8.ByteString -> String+digestBS :: Digest -> B8.ByteString -> B8.ByteString digestBS md input- = unsafePerformIO $ digestStrictly md input >>= digestFinal---- |Same as 'digestBS' but returns 'B8.ByteString' instead.-digestBS' :: Digest -> B8.ByteString -> B8.ByteString-digestBS' md input = unsafePerformIO $ digestStrictly md input >>= digestFinalBS -- |@'digestLBS'@ digests a stream of data.-digestLBS :: Digest -> L8.ByteString -> String+digestLBS :: Digest -> L8.ByteString -> B8.ByteString digestLBS md input- = unsafePerformIO $ digestLazily md input >>= digestFinal+ = unsafePerformIO $ digestLazily md input >>= digestFinalBS {- HMAC ---------------------------------------------------------------------- -} -foreign import ccall unsafe "HMAC"+foreign import capi unsafe "openssl/hmac.h HMAC" _HMAC :: Ptr EVP_MD -> Ptr CChar -> CInt -> Ptr CChar -> CSize -> Ptr CChar -> Ptr CUInt -> IO () @@ -97,6 +101,10 @@ bufLen <- fromIntegral <$> peek bufLenPtr B8.packCStringLen (bufPtr, bufLen) +hmacLBS :: Digest -> B8.ByteString -> L8.ByteString -> B8.ByteString+hmacLBS md key input+ = unsafePerformIO $ hmacLazily md key input >>= hmacFinalBS+ -- | Calculate a PKCS5-PBKDF2 SHA1-HMAC suitable for password hashing. pkcs5_pbkdf2_hmac_sha1 :: B8.ByteString -- ^ password -> B8.ByteString -- ^ salt@@ -114,9 +122,8 @@ (fromIntegral iter) (fromIntegral dkeylen) (castPtr dkeydata) >> return () -foreign import ccall unsafe "PKCS5_PBKDF2_HMAC_SHA1"+foreign import capi unsafe "openssl/hmac.h PKCS5_PBKDF2_HMAC_SHA1" _PKCS5_PBKDF2_HMAC_SHA1 :: Ptr CChar -> CInt -> Ptr CChar -> CInt -> CInt -> CInt -> Ptr CChar -> IO CInt-
OpenSSL/EVP/Internal.hsc view
@@ -1,3 +1,6 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-} module OpenSSL.EVP.Internal ( Cipher(..), EVP_CIPHER,@@ -11,6 +14,9 @@ withCipherCtxPtr, withNewCipherCtxPtr, + CryptoMode(..),+ cipherSetPadding,+ cipherInitBS, cipherUpdateBS, cipherFinalBS, cipherStrictly,@@ -30,6 +36,14 @@ digestStrictly, digestLazily, + HmacCtx(..),+ HMAC_CTX,+ withHmacCtxPtr,++ hmacUpdateBS,+ hmacFinalBS,+ hmacLazily,+ VaguePKey(..), EVP_PKEY, PKey(..),@@ -48,16 +62,18 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Internal as L8+#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))-import Control.Exception (mask, mask_, bracket_, onException)-import Foreign.C.Types (CChar)+#endif+import Control.Exception (mask, mask_, bracket, onException)+import Foreign.C.Types (CChar, CUChar) #if MIN_VERSION_base(4,5,0) import Foreign.C.Types (CInt(..), CUInt(..), CSize(..)) #else import Foreign.C.Types (CInt, CUInt, CSize) #endif import Foreign.Ptr (Ptr, castPtr, FunPtr)-import Foreign.C.String (peekCStringLen)+import Foreign.C.String (CString, peekCStringLen) import Foreign.ForeignPtr #if MIN_VERSION_base(4,4,0) import Foreign.ForeignPtr.Unsafe as Unsafe@@ -65,22 +81,23 @@ import Foreign.ForeignPtr as Unsafe #endif import Foreign.Storable (Storable(..))-import Foreign.Marshal.Alloc (alloca, allocaBytes)+import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (allocaArray) import System.IO.Unsafe (unsafeInterleaveIO) import OpenSSL.Utils + {- EVP_CIPHER ---------------------------------------------------------------- -} -- |@Cipher@ is an opaque object that represents an algorithm of -- symmetric cipher. newtype Cipher = Cipher (Ptr EVP_CIPHER)-data EVP_CIPHER+data {-# CTYPE "openssl/evp.h" "EVP_CIPHER" #-} EVP_CIPHER withCipherPtr :: Cipher -> (Ptr EVP_CIPHER -> IO a) -> IO a withCipherPtr (Cipher cipherPtr) f = f cipherPtr -foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_iv_length"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_EVP_CIPHER_iv_length" _iv_length :: Ptr EVP_CIPHER -> CInt cipherIvLength :: Cipher -> Int@@ -89,26 +106,32 @@ {- EVP_CIPHER_CTX ------------------------------------------------------------ -} newtype CipherCtx = CipherCtx (ForeignPtr EVP_CIPHER_CTX)-data EVP_CIPHER_CTX+data {-# CTYPE "openssl/evp.h" "EVP_CIPHER_CTX" #-} EVP_CIPHER_CTX -foreign import ccall unsafe "EVP_CIPHER_CTX_init"- _cipher_ctx_init :: Ptr EVP_CIPHER_CTX -> IO ()+foreign import capi unsafe "openssl/evp.h EVP_CIPHER_CTX_new"+ _cipher_ctx_new :: IO (Ptr EVP_CIPHER_CTX) -foreign import ccall unsafe "&EVP_CIPHER_CTX_cleanup"- _cipher_ctx_cleanup :: FunPtr (Ptr EVP_CIPHER_CTX -> IO ())+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import capi unsafe "openssl/evp.h EVP_CIPHER_CTX_reset"+ _cipher_ctx_reset :: Ptr EVP_CIPHER_CTX -> IO ()+#else+foreign import capi unsafe "openssl/evp.h EVP_CIPHER_CTX_init"+ _cipher_ctx_reset :: Ptr EVP_CIPHER_CTX -> IO ()+#endif -foreign import ccall unsafe "EVP_CIPHER_CTX_cleanup"- _cipher_ctx_cleanup' :: Ptr EVP_CIPHER_CTX -> IO ()+foreign import capi unsafe "openssl/evp.h &EVP_CIPHER_CTX_free"+ _cipher_ctx_free :: FunPtr (Ptr EVP_CIPHER_CTX -> IO ()) -foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_CTX_block_size"+foreign import capi unsafe "openssl/evp.h EVP_CIPHER_CTX_free"+ _cipher_ctx_free' :: Ptr EVP_CIPHER_CTX -> IO ()++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_EVP_CIPHER_CTX_block_size" _cipher_ctx_block_size :: Ptr EVP_CIPHER_CTX -> CInt newCipherCtx :: IO CipherCtx-newCipherCtx = do- ctx <- mallocForeignPtrBytes (#size EVP_CIPHER_CTX)- mask_ $ do- withForeignPtr ctx _cipher_ctx_init- addForeignPtrFinalizer _cipher_ctx_cleanup ctx+newCipherCtx = mask_ $ do+ ctx <- newForeignPtr _cipher_ctx_free =<< failIfNull =<< _cipher_ctx_new+ withForeignPtr ctx _cipher_ctx_reset return $ CipherCtx ctx withCipherCtxPtr :: CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a@@ -116,12 +139,52 @@ withNewCipherCtxPtr :: (Ptr EVP_CIPHER_CTX -> IO a) -> IO a withNewCipherCtxPtr f =- allocaBytes (#size EVP_CIPHER_CTX) $ \ptr ->- bracket_ (_cipher_ctx_init ptr) (_cipher_ctx_cleanup' ptr) (f ptr)+ bracket (failIfNull =<< _cipher_ctx_new) _cipher_ctx_free' $ \ p -> do+ _cipher_ctx_reset p+ f p {- encrypt/decrypt ----------------------------------------------------------- -} -foreign import ccall unsafe "EVP_CipherUpdate"+-- |@CryptoMode@ represents instruction to 'cipher' and such like.+data CryptoMode = Encrypt | Decrypt++fromCryptoMode :: Num a => CryptoMode -> a+fromCryptoMode Encrypt = 1+fromCryptoMode Decrypt = 0++foreign import capi unsafe "openssl/evp.h EVP_CIPHER_CTX_set_padding"+ _SetPadding :: Ptr EVP_CIPHER_CTX -> CInt -> IO CInt++cipherSetPadding :: CipherCtx -> Int -> IO CipherCtx+cipherSetPadding ctx pad+ = do withCipherCtxPtr ctx $ \ctxPtr ->+ _SetPadding ctxPtr (fromIntegral pad)+ >>= failIf_ (/= 1)+ return ctx++foreign import capi unsafe "openssl/evp.h EVP_CipherInit"+ _CipherInit :: Ptr EVP_CIPHER_CTX+ -> Ptr EVP_CIPHER+ -> CString+ -> CString+ -> CInt+ -> IO CInt++cipherInitBS :: Cipher+ -> B8.ByteString -- ^ key+ -> B8.ByteString -- ^ IV+ -> CryptoMode+ -> IO CipherCtx+cipherInitBS (Cipher c) key iv mode+ = do ctx <- newCipherCtx+ withCipherCtxPtr ctx $ \ ctxPtr ->+ B8.unsafeUseAsCString key $ \ keyPtr ->+ B8.unsafeUseAsCString iv $ \ ivPtr ->+ _CipherInit ctxPtr c keyPtr ivPtr (fromCryptoMode mode)+ >>= failIf_ (/= 1)+ return ctx++foreign import capi unsafe "openssl/evp.h EVP_CipherUpdate" _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> Ptr CChar -> CInt -> IO CInt @@ -137,7 +200,7 @@ >>= failIf (/= 1) >> fromIntegral <$> peek outLenPtr -foreign import ccall unsafe "EVP_CipherFinal"+foreign import capi unsafe "openssl/evp.h EVP_CipherFinal" _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> IO CInt cipherFinalBS :: CipherCtx -> IO B8.ByteString@@ -169,7 +232,7 @@ -- |@Digest@ is an opaque object that represents an algorithm of -- message digest. newtype Digest = Digest (Ptr EVP_MD)-data EVP_MD+data {-# CTYPE "openssl/evp.h" "EVP_MD" #-} EVP_MD withMDPtr :: Digest -> (Ptr EVP_MD -> IO a) -> IO a withMDPtr (Digest mdPtr) f = f mdPtr@@ -177,20 +240,29 @@ {- EVP_MD_CTX ---------------------------------------------------------------- -} newtype DigestCtx = DigestCtx (ForeignPtr EVP_MD_CTX)-data EVP_MD_CTX+data {-# CTYPE "openssl/evp.h" "EVP_MD_CTX" #-} EVP_MD_CTX -foreign import ccall unsafe "EVP_MD_CTX_init"- _md_ctx_init :: Ptr EVP_MD_CTX -> IO () -foreign import ccall unsafe "&EVP_MD_CTX_cleanup"- _md_ctx_cleanup :: FunPtr (Ptr EVP_MD_CTX -> IO ())+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import capi unsafe "openssl/evp.h EVP_MD_CTX_new"+ _md_ctx_new :: IO (Ptr EVP_MD_CTX)+foreign import capi unsafe "openssl/evp.h EVP_MD_CTX_reset"+ _md_ctx_reset :: Ptr EVP_MD_CTX -> IO ()+foreign import capi unsafe "openssl/evp.h &EVP_MD_CTX_free"+ _md_ctx_free :: FunPtr (Ptr EVP_MD_CTX -> IO ())+#else+foreign import capi unsafe "openssl/evp.h EVP_MD_CTX_create"+ _md_ctx_new :: IO (Ptr EVP_MD_CTX)+foreign import capi unsafe "openssl/evp.h EVP_MD_CTX_init"+ _md_ctx_reset :: Ptr EVP_MD_CTX -> IO ()+foreign import capi unsafe "openssl/evp.h &EVP_MD_CTX_destroy"+ _md_ctx_free :: FunPtr (Ptr EVP_MD_CTX -> IO ())+#endif newDigestCtx :: IO DigestCtx-newDigestCtx = do- ctx <- mallocForeignPtrBytes (#size EVP_MD_CTX)- mask_ $ do- withForeignPtr ctx _md_ctx_init- addForeignPtrFinalizer _md_ctx_cleanup ctx+newDigestCtx = mask_ $ do+ ctx <- newForeignPtr _md_ctx_free =<< failIfNull =<< _md_ctx_new+ withForeignPtr ctx _md_ctx_reset return $ DigestCtx ctx withDigestCtxPtr :: DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a@@ -198,7 +270,7 @@ {- digest -------------------------------------------------------------------- -} -foreign import ccall unsafe "EVP_DigestInit"+foreign import capi unsafe "openssl/evp.h EVP_DigestInit" _DigestInit :: Ptr EVP_MD_CTX -> Ptr EVP_MD -> IO CInt digestInit :: Digest -> IO DigestCtx@@ -209,7 +281,7 @@ >>= failIf_ (/= 1) >> return ctx -foreign import ccall unsafe "EVP_DigestUpdate"+foreign import capi unsafe "openssl/evp.h EVP_DigestUpdate" _DigestUpdate :: Ptr EVP_MD_CTX -> Ptr CChar -> CSize -> IO CInt digestUpdateBS :: DigestCtx -> B8.ByteString -> IO ()@@ -220,7 +292,7 @@ >>= failIf (/= 1) >> return () -foreign import ccall unsafe "EVP_DigestFinal"+foreign import capi unsafe "openssl/evp.h EVP_DigestFinal" _DigestFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> Ptr CUInt -> IO CInt digestFinalBS :: DigestCtx -> IO B8.ByteString@@ -252,36 +324,92 @@ mapM_ (digestUpdateBS ctx) $ L8.toChunks lbs return ctx +{- HMAC ---------------------------------------------------------------------- -}+newtype HmacCtx = HmacCtx (ForeignPtr HMAC_CTX)+data {-# CTYPE "openssl/hmac.h" "HMAC_CTX" #-} HMAC_CTX++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_HMAC_CTX_new"+ _hmac_ctx_new :: IO (Ptr HMAC_CTX)++foreign import capi unsafe "openssl/hmac.h HMAC_Init"+ _hmac_init :: Ptr HMAC_CTX -> Ptr () -> CInt -> Ptr EVP_MD -> IO CInt++foreign import capi unsafe "openssl/hmac.h HMAC_Update"+ _hmac_update :: Ptr HMAC_CTX -> Ptr CUChar -> CSize -> IO CInt++foreign import capi unsafe "openssl/hmac.h HMAC_Final"+ _hmac_final :: Ptr HMAC_CTX -> Ptr CUChar -> Ptr CUInt -> IO CUInt++foreign import capi unsafe "HsOpenSSL &HsOpenSSL_HMAC_CTX_free"+ _hmac_ctx_free :: FunPtr (Ptr HMAC_CTX -> IO ())++newHmacCtx :: IO HmacCtx+newHmacCtx = do+ ctxPtr <- _hmac_ctx_new+ HmacCtx <$> newForeignPtr _hmac_ctx_free ctxPtr++withHmacCtxPtr :: HmacCtx -> (Ptr HMAC_CTX -> IO a) -> IO a+withHmacCtxPtr (HmacCtx ctx) = withForeignPtr ctx++hmacInit :: Digest -> B8.ByteString -> IO HmacCtx+hmacInit (Digest md) key = do+ ctx <- newHmacCtx+ withHmacCtxPtr ctx $ \ctxPtr ->+ B8.unsafeUseAsCStringLen key $ \(keyPtr, keyLen) ->+ _hmac_init ctxPtr (castPtr keyPtr) (fromIntegral keyLen) md+ >>= failIf_ (/= 1)+ >> return ctx++hmacUpdateBS :: HmacCtx -> B8.ByteString -> IO ()+hmacUpdateBS ctx bs = withHmacCtxPtr ctx $ \ctxPtr -> do+ B8.unsafeUseAsCStringLen bs $ \(buf, len) ->+ _hmac_update ctxPtr (castPtr buf) (fromIntegral len)+ >>= failIf_ (/= 1)++hmacFinalBS :: HmacCtx -> IO B8.ByteString+hmacFinalBS ctx =+ withHmacCtxPtr ctx $ \ctxPtr ->+ B8.createAndTrim (#const EVP_MAX_MD_SIZE) $ \bufPtr ->+ alloca $ \bufLenPtr -> do+ _hmac_final ctxPtr (castPtr bufPtr) bufLenPtr >>= failIf_ (/= 1)+ fromIntegral <$> peek bufLenPtr++hmacLazily :: Digest -> B8.ByteString -> L8.ByteString -> IO HmacCtx+hmacLazily md key lbs = do+ ctx <- hmacInit md key+ mapM_ (hmacUpdateBS ctx) $ L8.toChunks lbs+ return ctx+ {- EVP_PKEY ------------------------------------------------------------------ -} --- VaguePKey is a ForeignPtr to EVP_PKEY, that is either public key or--- a ker pair. We can't tell which at compile time.+-- | VaguePKey is a 'ForeignPtr' to 'EVP_PKEY', that is either public+-- key or a ker pair. We can't tell which at compile time. newtype VaguePKey = VaguePKey (ForeignPtr EVP_PKEY)-data EVP_PKEY+data {-# CTYPE "openssl/evp.h" "EVP_PKEY" #-} EVP_PKEY --- Instances of class PKey can be converted back and forth to--- VaguePKey.+-- | Instances of class 'PKey' can be converted back and forth to+-- 'VaguePKey'. class PKey k where- -- Wrap the key (i.g. RSA) into EVP_PKEY.+ -- | Wrap the key (i.g. RSA) into 'EVP_PKEY'. toPKey :: k -> IO VaguePKey - -- Extract the concrete key from the EVP_PKEY. Returns Nothing if- -- the type mismatches.+ -- | Extract the concrete key from the 'EVP_PKEY'. Returns+ -- 'Nothing' if the type mismatches. fromPKey :: VaguePKey -> IO (Maybe k) - -- Do the same as EVP_PKEY_size().+ -- | Do the same as EVP_PKEY_size(). pkeySize :: k -> Int - -- Return the default digesting algorithm for the key.+ -- | Return the default digesting algorithm for the key. pkeyDefaultMD :: k -> IO Digest -foreign import ccall unsafe "EVP_PKEY_new"+foreign import capi unsafe "openssl/evp.h EVP_PKEY_new" _pkey_new :: IO (Ptr EVP_PKEY) -foreign import ccall unsafe "&EVP_PKEY_free"+foreign import capi unsafe "openssl/evp.h &EVP_PKEY_free" _pkey_free :: FunPtr (Ptr EVP_PKEY -> IO ()) -foreign import ccall unsafe "EVP_PKEY_free"+foreign import capi unsafe "openssl/evp.h EVP_PKEY_free" _pkey_free' :: Ptr EVP_PKEY -> IO () wrapPKeyPtr :: Ptr EVP_PKEY -> IO VaguePKey
+ OpenSSL/EVP/Open.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- |Asymmetric cipher decryption using encrypted symmetric key. This+-- is an opposite of "OpenSSL.EVP.Seal".+module OpenSSL.EVP.Open+ ( open+ , openBS+ , openLBS+ )+ where+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Unsafe as B8+import Foreign.C.String (CString)+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CChar(..), CInt(..))+#else+import Foreign.C.Types (CChar, CInt)+#endif+import Foreign.Ptr (Ptr)+import OpenSSL.EVP.Cipher hiding (cipher)+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+import OpenSSL.Utils+import System.IO.Unsafe (unsafePerformIO)++foreign import capi unsafe "openssl/evp.h EVP_OpenInit"+ _OpenInit :: Ptr EVP_CIPHER_CTX+ -> Cipher+ -> Ptr CChar+ -> CInt+ -> CString+ -> Ptr EVP_PKEY+ -> IO CInt+++openInit :: KeyPair key =>+ Cipher+ -> B8.ByteString+ -> B8.ByteString+ -> key+ -> IO CipherCtx+openInit cipher encKey iv pkey+ = do ctx <- newCipherCtx+ withCipherCtxPtr ctx $ \ ctxPtr ->+ B8.unsafeUseAsCStringLen encKey $ \ (encKeyPtr, encKeyLen) ->+ B8.unsafeUseAsCString iv $ \ ivPtr ->+ withPKeyPtr' pkey $ \ pkeyPtr ->+ _OpenInit ctxPtr cipher encKeyPtr (fromIntegral encKeyLen) ivPtr pkeyPtr+ >>= failIf_ (== 0)+ return ctx++-- |@'open'@ lazilly decrypts a stream of data. The input string+-- doesn't necessarily have to be finite.+open :: KeyPair key =>+ Cipher -- ^ symmetric cipher algorithm to use+ -> String -- ^ encrypted symmetric key to decrypt the input string+ -> String -- ^ IV+ -> key -- ^ private key to decrypt the symmetric key+ -> String -- ^ input string to decrypt+ -> String -- ^ decrypted string+{-# DEPRECATED open "Use openBS or openLBS instead." #-}+open cipher encKey iv pkey input+ = L8.unpack $ openLBS cipher (B8.pack encKey) (B8.pack iv) pkey (L8.pack input)++-- |@'openBS'@ decrypts a chunk of data.+openBS :: KeyPair key =>+ Cipher -- ^ symmetric cipher algorithm to use+ -> B8.ByteString -- ^ encrypted symmetric key to decrypt the input string+ -> B8.ByteString -- ^ IV+ -> key -- ^ private key to decrypt the symmetric key+ -> B8.ByteString -- ^ input string to decrypt+ -> B8.ByteString -- ^ decrypted string+openBS cipher encKey iv pkey input+ = unsafePerformIO $+ do ctx <- openInit cipher encKey iv pkey+ cipherStrictly ctx input++-- |@'openLBS'@ lazilly decrypts a stream of data. The input string+-- doesn't necessarily have to be finite.+openLBS :: KeyPair key =>+ Cipher -- ^ symmetric cipher algorithm to use+ -> B8.ByteString -- ^ encrypted symmetric key to decrypt the input string+ -> B8.ByteString -- ^ IV+ -> key -- ^ private key to decrypt the symmetric key+ -> L8.ByteString -- ^ input string to decrypt+ -> L8.ByteString -- ^ decrypted string+openLBS cipher encKey iv pkey input+ = unsafePerformIO $+ do ctx <- openInit cipher encKey iv pkey+ cipherLazily ctx input
− OpenSSL/EVP/Open.hsc
@@ -1,82 +0,0 @@-{- -*- haskell -*- -}---- |Asymmetric cipher decryption using encrypted symmetric key. This--- is an opposite of "OpenSSL.EVP.Seal".--module OpenSSL.EVP.Open- ( open- , openBS- , openLBS- )- where--import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe (unsafePerformIO)-import Foreign.C-import OpenSSL.EVP.Cipher hiding (cipher)-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-import OpenSSL.Utils---foreign import ccall unsafe "EVP_OpenInit"- _OpenInit :: Ptr EVP_CIPHER_CTX- -> Cipher- -> Ptr CChar- -> CInt- -> CString- -> Ptr EVP_PKEY- -> IO CInt---openInit :: KeyPair key => Cipher -> String -> String -> key -> IO CipherCtx-openInit cipher encKey iv pkey- = do ctx <- newCipherCtx- withCipherCtxPtr ctx $ \ ctxPtr ->- withCStringLen encKey $ \ (encKeyPtr, encKeyLen) ->- withCString iv $ \ ivPtr ->- withPKeyPtr' pkey $ \ pkeyPtr ->- _OpenInit ctxPtr cipher encKeyPtr (fromIntegral encKeyLen) ivPtr pkeyPtr- >>= failIf_ (== 0)- return ctx---- |@'open'@ lazilly decrypts a stream of data. The input string--- doesn't necessarily have to be finite.-open :: KeyPair key =>- Cipher -- ^ symmetric cipher algorithm to use- -> String -- ^ encrypted symmetric key to decrypt the input string- -> String -- ^ IV- -> key -- ^ private key to decrypt the symmetric key- -> String -- ^ input string to decrypt- -> String -- ^ decrypted string-open cipher encKey iv pkey input- = L8.unpack $ openLBS cipher encKey iv pkey $ L8.pack input---- |@'openBS'@ decrypts a chunk of data.-openBS :: KeyPair key =>- Cipher -- ^ symmetric cipher algorithm to use- -> String -- ^ encrypted symmetric key to decrypt the input string- -> String -- ^ IV- -> key -- ^ private key to decrypt the symmetric key- -> B8.ByteString -- ^ input string to decrypt- -> B8.ByteString -- ^ decrypted string-openBS cipher encKey iv pkey input- = unsafePerformIO $- do ctx <- openInit cipher encKey iv pkey- cipherStrictly ctx input---- |@'openLBS'@ lazilly decrypts a stream of data. The input string--- doesn't necessarily have to be finite.-openLBS :: KeyPair key =>- Cipher -- ^ symmetric cipher algorithm to use- -> String -- ^ encrypted symmetric key to decrypt the input string- -> String -- ^ IV- -> key -- ^ private key to decrypt the symmetric key- -> L8.ByteString -- ^ input string to decrypt- -> L8.ByteString -- ^ decrypted string-openLBS cipher encKey iv pkey input- = unsafePerformIO $- do ctx <- openInit cipher encKey iv pkey- cipherLazily ctx input
OpenSSL/EVP/PKey.hsc view
@@ -1,19 +1,18 @@-{- -*- haskell -*- -}--{-# OPTIONS_GHC -fno-warn-orphans #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- |An interface to asymmetric cipher keypair.--#include "HsOpenSSL.h"- module OpenSSL.EVP.PKey- ( PKey- , PublicKey(..)+ ( PublicKey(..) , KeyPair(..) , SomePublicKey , SomeKeyPair ) where+#include "HsOpenSSL.h" import Data.Typeable import Data.Maybe import Foreign@@ -51,19 +50,30 @@ toKeyPair :: SomeKeyPair -> Maybe a toKeyPair (SomeKeyPair pk) = cast pk +++#if OPENSSL_VERSION_PREREQ(3,0)+foreign import capi unsafe "openssl/evp.h EVP_PKEY_get_base_id" getType :: Ptr EVP_PKEY -> IO CInt+#elif OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import capi unsafe "openssl/evp.h EVP_PKEY_base_id" getType :: Ptr EVP_PKEY -> IO CInt+#else+getType :: Ptr EVP_PKEY -> IO CInt+getType = (#peek EVP_PKEY, type)+#endif+ -- Reconstruct the concrete public-key type from an EVP_PKEY. withConcretePubKey :: VaguePKey -> (forall k. PublicKey k => k -> IO a) -> IO a withConcretePubKey pk f = withPKeyPtr pk $ \ pkeyPtr ->- do pkeyType <- (#peek EVP_PKEY, type) pkeyPtr :: IO CInt+ do pkeyType <- getType pkeyPtr case pkeyType of-#ifndef OPENSSL_NO_RSA+#if !defined(OPENSSL_NO_RSA) (#const EVP_PKEY_RSA) -> do rsaPtr <- _get1_RSA pkeyPtr Just rsa <- absorbRSAPtr rsaPtr f (rsa :: RSAPubKey) #endif-#ifndef OPENSSL_NO_DSA+#if !defined(OPENSSL_NO_DSA) (#const EVP_PKEY_DSA) -> do dsaPtr <- _get1_DSA pkeyPtr Just dsa <- absorbDSAPtr dsaPtr@@ -75,15 +85,15 @@ withConcreteKeyPair :: VaguePKey -> (forall k. KeyPair k => k -> IO a) -> IO a withConcreteKeyPair pk f = withPKeyPtr pk $ \ pkeyPtr ->- do pkeyType <- (#peek EVP_PKEY, type) pkeyPtr :: IO CInt+ do pkeyType <- getType pkeyPtr case pkeyType of-#ifndef OPENSSL_NO_RSA+#if !defined(OPENSSL_NO_RSA) (#const EVP_PKEY_RSA) -> do rsaPtr <- _get1_RSA pkeyPtr Just rsa <- absorbRSAPtr rsaPtr f (rsa :: RSAKeyPair) #endif-#ifndef OPENSSL_NO_DSA+#if !defined(OPENSSL_NO_DSA) (#const EVP_PKEY_DSA) -> do dsaPtr <- _get1_DSA pkeyPtr Just dsa <- absorbDSAPtr dsaPtr@@ -146,12 +156,12 @@ = withConcreteKeyPair pk (return . Just . SomeKeyPair) -#ifndef OPENSSL_NO_RSA+#if !defined(OPENSSL_NO_RSA) -- The resulting Ptr RSA must be freed by caller.-foreign import ccall unsafe "EVP_PKEY_get1_RSA"+foreign import capi unsafe "openssl/evp.h EVP_PKEY_get1_RSA" _get1_RSA :: Ptr EVP_PKEY -> IO (Ptr RSA) -foreign import ccall unsafe "EVP_PKEY_set1_RSA"+foreign import capi unsafe "openssl/evp.h EVP_PKEY_set1_RSA" _set1_RSA :: Ptr EVP_PKEY -> Ptr RSA -> IO CInt @@ -164,7 +174,7 @@ rsaFromPKey :: RSAKey k => VaguePKey -> IO (Maybe k) rsaFromPKey pk = withPKeyPtr pk $ \ pkeyPtr ->- do pkeyType <- (#peek EVP_PKEY, type) pkeyPtr :: IO CInt+ do pkeyType <- getType pkeyPtr case pkeyType of (#const EVP_PKEY_RSA) -> _get1_RSA pkeyPtr >>= absorbRSAPtr@@ -187,11 +197,11 @@ #endif -#ifndef OPENSSL_NO_DSA-foreign import ccall unsafe "EVP_PKEY_get1_DSA"+#if !defined(OPENSSL_NO_DSA)+foreign import capi unsafe "openssl/evp.h EVP_PKEY_get1_DSA" _get1_DSA :: Ptr EVP_PKEY -> IO (Ptr DSA) -foreign import ccall unsafe "EVP_PKEY_set1_DSA"+foreign import capi unsafe "openssl/evp.h EVP_PKEY_set1_DSA" _set1_DSA :: Ptr EVP_PKEY -> Ptr DSA -> IO CInt dsaToPKey :: DSAKey k => k -> IO VaguePKey@@ -200,10 +210,11 @@ createPKey $ \pkeyPtr -> _set1_DSA pkeyPtr dsaPtr >>= failIf_ (/= 1) + dsaFromPKey :: DSAKey k => VaguePKey -> IO (Maybe k) dsaFromPKey pk = withPKeyPtr pk $ \ pkeyPtr ->- do pkeyType <- (#peek EVP_PKEY, type) pkeyPtr :: IO CInt+ do pkeyType <- getType pkeyPtr case pkeyType of (#const EVP_PKEY_DSA) -> _get1_DSA pkeyPtr >>= absorbDSAPtr
+ OpenSSL/EVP/Seal.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- |Asymmetric cipher decryption using encrypted symmetric key. This+-- is an opposite of "OpenSSL.EVP.Open".+module OpenSSL.EVP.Seal+ ( seal+ , sealBS+ , sealLBS+ )+ where+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Foreign+import Foreign.C+import OpenSSL.EVP.Cipher hiding (cipher)+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+import OpenSSL.Utils+++foreign import capi unsafe "openssl/evp.h EVP_SealInit"+ _SealInit :: Ptr EVP_CIPHER_CTX+ -> Cipher+ -> Ptr (Ptr CChar)+ -> Ptr CInt+ -> Ptr CChar+ -> Ptr (Ptr EVP_PKEY)+ -> CInt+ -> IO CInt+++sealInit :: Cipher+ -> [SomePublicKey]+ -> IO (CipherCtx, [B8.ByteString], B8.ByteString)++sealInit _ []+ = fail "sealInit: at least one public key is required"++sealInit cipher pubKeys+ = do ctx <- newCipherCtx++ -- Allocate a list of buffers to write encrypted symmetric+ -- keys. Each keys will be at most pkeySize bytes long.+ encKeyBufs <- mapM mallocEncKeyBuf pubKeys++ -- encKeyBufs is [Ptr a] but we want Ptr (Ptr CChar).+ encKeyBufsPtr <- newArray encKeyBufs++ -- Allocate a buffer to write lengths of each encrypted+ -- symmetric keys.+ encKeyBufsLenPtr <- mallocArray nKeys++ -- Allocate a buffer to write IV.+ ivPtr <- mallocArray (cipherIvLength cipher)++ -- Create Ptr (Ptr EVP_PKEY) from [PKey]. Don't forget to+ -- apply touchForeignPtr to each PKey's later.+ pkeys <- mapM toPKey pubKeys+ pubKeysPtr <- newArray $ map unsafePKeyToPtr pkeys++ -- Prepare an IO action to free buffers we allocated above.+ let cleanup = do mapM_ free encKeyBufs+ free encKeyBufsPtr+ free encKeyBufsLenPtr+ free ivPtr+ free pubKeysPtr+ mapM_ touchPKey pkeys++ -- Call EVP_SealInit finally.+ ret <- withCipherCtxPtr ctx $ \ ctxPtr ->+ _SealInit ctxPtr cipher encKeyBufsPtr encKeyBufsLenPtr ivPtr pubKeysPtr (fromIntegral nKeys)++ if ret == 0 then+ cleanup >> raiseOpenSSLError+ else+ do encKeysLen <- peekArray nKeys encKeyBufsLenPtr+ encKeys <- mapM B8.packCStringLen $ zip encKeyBufs (fromIntegral `fmap` encKeysLen)+ iv <- B8.packCStringLen (ivPtr, cipherIvLength cipher)+ cleanup+ return (ctx, encKeys, iv)+ where+ nKeys :: Int+ nKeys = length pubKeys++ mallocEncKeyBuf :: (PKey k, Storable a) => k -> IO (Ptr a)+ mallocEncKeyBuf = mallocArray . pkeySize++-- |@'seal'@ lazilly encrypts a stream of data. The input string+-- doesn't necessarily have to be finite.+seal :: Cipher -- ^ symmetric cipher algorithm to use+ -> [SomePublicKey] -- ^ A list of public keys to encrypt a+ -- symmetric key. At least one public key+ -- must be supplied. If two or more keys are+ -- given, the symmetric key are encrypted by+ -- each public keys so that any of the+ -- corresponding private keys can decrypt+ -- the message.+ -> String -- ^ input string to encrypt+ -> IO ( String+ , [String]+ , String+ ) -- ^ (encrypted string, list of encrypted asymmetric+ -- keys, IV)+{-# DEPRECATED seal "Use sealBS or sealLBS instead." #-}+seal cipher pubKeys input+ = do (output, encKeys, iv) <- sealLBS cipher pubKeys $ L8.pack input+ return ( L8.unpack output+ , B8.unpack `fmap` encKeys+ , B8.unpack iv+ )++-- |@'sealBS'@ strictly encrypts a chunk of data.+sealBS :: Cipher -- ^ symmetric cipher algorithm to use+ -> [SomePublicKey] -- ^ list of public keys to encrypt a+ -- symmetric key+ -> B8.ByteString -- ^ input string to encrypt+ -> IO ( B8.ByteString+ , [B8.ByteString]+ , B8.ByteString+ ) -- ^ (encrypted string, list of encrypted asymmetric+ -- keys, IV)+sealBS cipher pubKeys input+ = do (ctx, encKeys, iv) <- sealInit cipher pubKeys+ output <- cipherStrictly ctx input+ return (output, encKeys, iv)++-- |@'sealLBS'@ lazilly encrypts a stream of data. The input string+-- doesn't necessarily have to be finite.+sealLBS :: Cipher -- ^ symmetric cipher algorithm to use+ -> [SomePublicKey] -- ^ list of public keys to encrypt a+ -- symmetric key+ -> L8.ByteString -- ^ input string to encrypt+ -> IO ( L8.ByteString+ , [B8.ByteString]+ , B8.ByteString+ ) -- ^ (encrypted string, list of encrypted asymmetric+ -- keys, IV)+sealLBS cipher pubKeys input+ = do (ctx, encKeys, iv) <- sealInit cipher pubKeys+ output <- cipherLazily ctx input+ return (output, encKeys, iv)
− OpenSSL/EVP/Seal.hsc
@@ -1,133 +0,0 @@-{- -*- haskell -*- -}---- |Asymmetric cipher decryption using encrypted symmetric key. This--- is an opposite of "OpenSSL.EVP.Open".--module OpenSSL.EVP.Seal- ( seal- , sealBS- , sealLBS- )- where--import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Foreign-import Foreign.C-import OpenSSL.EVP.Cipher hiding (cipher)-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-import OpenSSL.Utils---foreign import ccall unsafe "EVP_SealInit"- _SealInit :: Ptr EVP_CIPHER_CTX- -> Cipher- -> Ptr (Ptr CChar)- -> Ptr CInt- -> CString- -> Ptr (Ptr EVP_PKEY)- -> CInt- -> IO CInt---sealInit :: Cipher -> [SomePublicKey] -> IO (CipherCtx, [String], String)--sealInit _ []- = fail "sealInit: at least one public key is required"--sealInit cipher pubKeys- = do ctx <- newCipherCtx-- -- Allocate a list of buffers to write encrypted symmetric- -- keys. Each keys will be at most pkeySize bytes long.- encKeyBufs <- mapM mallocEncKeyBuf pubKeys-- -- encKeyBufs is [Ptr a] but we want Ptr (Ptr CChar).- encKeyBufsPtr <- newArray encKeyBufs-- -- Allocate a buffer to write lengths of each encrypted- -- symmetric keys.- encKeyBufsLenPtr <- mallocArray nKeys-- -- Allocate a buffer to write IV.- ivPtr <- mallocArray (cipherIvLength cipher)-- -- Create Ptr (Ptr EVP_PKEY) from [PKey]. Don't forget to- -- apply touchForeignPtr to each PKey's later.- pkeys <- mapM toPKey pubKeys- pubKeysPtr <- newArray $ map unsafePKeyToPtr pkeys-- -- Prepare an IO action to free buffers we allocated above.- let cleanup = do mapM_ free encKeyBufs- free encKeyBufsPtr- free encKeyBufsLenPtr- free ivPtr- free pubKeysPtr- mapM_ touchPKey pkeys-- -- Call EVP_SealInit finally.- ret <- withCipherCtxPtr ctx $ \ ctxPtr ->- _SealInit ctxPtr cipher encKeyBufsPtr encKeyBufsLenPtr ivPtr pubKeysPtr (fromIntegral nKeys)-- if ret == 0 then- cleanup >> raiseOpenSSLError- else- do encKeysLen <- peekArray nKeys encKeyBufsLenPtr- encKeys <- mapM peekCStringCLen $ zip encKeyBufs encKeysLen- iv <- peekCString ivPtr- cleanup- return (ctx, encKeys, iv)- where- nKeys :: Int- nKeys = length pubKeys-- mallocEncKeyBuf :: (PKey k, Storable a) => k -> IO (Ptr a)- mallocEncKeyBuf = mallocArray . pkeySize---- |@'seal'@ lazilly encrypts a stream of data. The input string--- doesn't necessarily have to be finite.-seal :: Cipher -- ^ symmetric cipher algorithm to use- -> [SomePublicKey] -- ^ A list of public keys to encrypt a- -- symmetric key. At least one public key- -- must be supplied. If two or more keys are- -- given, the symmetric key are encrypted by- -- each public keys so that any of the- -- corresponding private keys can decrypt- -- the message.- -> String -- ^ input string to encrypt- -> IO (String, [String], String) -- ^ (encrypted string, list of- -- encrypted asymmetric keys,- -- IV)-seal cipher pubKeys input- = do (output, encKeys, iv) <- sealLBS cipher pubKeys $ L8.pack input- return (L8.unpack output, encKeys, iv)---- |@'sealBS'@ strictly encrypts a chunk of data.-sealBS :: Cipher -- ^ symmetric cipher algorithm to use- -> [SomePublicKey] -- ^ list of public keys to encrypt a- -- symmetric key- -> B8.ByteString -- ^ input string to encrypt- -> IO (B8.ByteString, [String], String) -- ^ (encrypted string,- -- list of encrypted- -- asymmetric keys, IV)-sealBS cipher pubKeys input- = do (ctx, encKeys, iv) <- sealInit cipher pubKeys- output <- cipherStrictly ctx input- return (output, encKeys, iv)---- |@'sealLBS'@ lazilly encrypts a stream of data. The input string--- doesn't necessarily have to be finite.-sealLBS :: Cipher -- ^ symmetric cipher algorithm to use- -> [SomePublicKey] -- ^ list of public keys to encrypt a- -- symmetric key- -> L8.ByteString -- ^ input string to encrypt- -> IO (L8.ByteString, [String], String) -- ^ (encrypted- -- string, list of- -- encrypted- -- asymmetric keys,- -- IV)-sealLBS cipher pubKeys input- = do (ctx, encKeys, iv) <- sealInit cipher pubKeys- output <- cipherLazily ctx input- return (output, encKeys, iv)
+ OpenSSL/EVP/Sign.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- |Message signing using asymmetric cipher and message digest+-- algorithm. This is an opposite of "OpenSSL.EVP.Verify".+module OpenSSL.EVP.Sign+ ( sign+ , signBS+ , signLBS+ )+ where+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Internal as B8+import qualified Data.ByteString.Lazy.Char8 as L8+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Foreign+import Foreign.C+import OpenSSL.EVP.Digest+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+import OpenSSL.Utils++foreign import capi unsafe "openssl/evp.h EVP_SignFinal"+ _SignFinal :: Ptr EVP_MD_CTX -> Ptr Word8 -> Ptr CUInt+ -> Ptr EVP_PKEY -> IO CInt++signFinal :: KeyPair k => DigestCtx -> k -> IO B8.ByteString+signFinal ctx k = do+ let maxLen = pkeySize k+ withDigestCtxPtr ctx $ \ ctxPtr ->+ withPKeyPtr' k $ \ pkeyPtr ->+ B8.createAndTrim maxLen $ \ bufPtr ->+ alloca $ \ bufLenPtr -> do+ failIf_ (/= 1) =<< _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr+ fromIntegral <$> peek bufLenPtr++-- |@'sign'@ generates a signature from a stream of data. The string+-- must not contain any letters which aren't in the range of U+0000 -+-- U+00FF.+sign :: KeyPair key =>+ Digest -- ^ message digest algorithm to use+ -> key -- ^ private key to sign the message digest+ -> String -- ^ input string+ -> IO String -- ^ the result signature+{-# DEPRECATED sign "Use signBS or signLBS instead." #-}+sign md pkey input+ = fmap L8.unpack $ signLBS md pkey $ L8.pack input++-- |@'signBS'@ generates a signature from a chunk of data.+signBS :: KeyPair key =>+ Digest -- ^ message digest algorithm to use+ -> key -- ^ private key to sign the message digest+ -> B8.ByteString -- ^ input string+ -> IO B8.ByteString -- ^ the result signature+signBS md pkey input+ = do ctx <- digestStrictly md input+ signFinal ctx pkey++-- |@'signLBS'@ generates a signature from a stream of data.+signLBS :: KeyPair key =>+ Digest -- ^ message digest algorithm to use+ -> key -- ^ private key to sign the message digest+ -> L8.ByteString -- ^ input string+ -> IO L8.ByteString -- ^ the result signature+signLBS md pkey input+ = do ctx <- digestLazily md input+ sig <- signFinal ctx pkey+ return $ L8.fromChunks [sig]
− OpenSSL/EVP/Sign.hsc
@@ -1,69 +0,0 @@-{- -*- haskell -*- -}---- |Message signing using asymmetric cipher and message digest--- algorithm. This is an opposite of "OpenSSL.EVP.Verify".--module OpenSSL.EVP.Sign- ( sign- , signBS- , signLBS- )- where--import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Internal as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Control.Applicative ((<$>))-import Foreign-import Foreign.C-import OpenSSL.EVP.Digest-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-import OpenSSL.Utils--foreign import ccall unsafe "EVP_SignFinal"- _SignFinal :: Ptr EVP_MD_CTX -> Ptr Word8 -> Ptr CUInt- -> Ptr EVP_PKEY -> IO CInt--signFinal :: KeyPair k => DigestCtx -> k -> IO B8.ByteString-signFinal ctx k = do- let maxLen = pkeySize k- withDigestCtxPtr ctx $ \ ctxPtr ->- withPKeyPtr' k $ \ pkeyPtr ->- B8.createAndTrim maxLen $ \ bufPtr ->- alloca $ \ bufLenPtr -> do- failIf_ (/= 1) =<< _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr- fromIntegral <$> peek bufLenPtr---- |@'sign'@ generates a signature from a stream of data. The string--- must not contain any letters which aren't in the range of U+0000 ---- U+00FF.-sign :: KeyPair key =>- Digest -- ^ message digest algorithm to use- -> key -- ^ private key to sign the message digest- -> String -- ^ input string- -> IO String -- ^ the result signature-sign md pkey input- = fmap L8.unpack $ signLBS md pkey $ L8.pack input---- |@'signBS'@ generates a signature from a chunk of data.-signBS :: KeyPair key =>- Digest -- ^ message digest algorithm to use- -> key -- ^ private key to sign the message digest- -> B8.ByteString -- ^ input string- -> IO B8.ByteString -- ^ the result signature-signBS md pkey input- = do ctx <- digestStrictly md input- signFinal ctx pkey---- |@'signLBS'@ generates a signature from a stream of data.-signLBS :: KeyPair key =>- Digest -- ^ message digest algorithm to use- -> key -- ^ private key to sign the message digest- -> L8.ByteString -- ^ input string- -> IO L8.ByteString -- ^ the result signature-signLBS md pkey input- = do ctx <- digestLazily md input- sig <- signFinal ctx pkey- return $ L8.fromChunks [sig]-
+ OpenSSL/EVP/Verify.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- |Message verification using asymmetric cipher and message digest+-- algorithm. This is an opposite of "OpenSSL.EVP.Sign".+module OpenSSL.EVP.Verify+ ( VerifyStatus(..)+ , verify+ , verifyBS+ , verifyLBS+ )+ where+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Unsafe as B8+import Data.Typeable+import Foreign+import Foreign.C+import OpenSSL.EVP.Digest+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+import OpenSSL.Utils++-- |@'VerifyStatus'@ represents a result of verification.+data VerifyStatus = VerifySuccess+ | VerifyFailure+ deriving (Show, Eq, Typeable)+++foreign import capi unsafe "openssl/evp.h EVP_VerifyFinal"+ _VerifyFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> CUInt -> Ptr EVP_PKEY -> IO CInt+++verifyFinalBS :: PublicKey k =>+ DigestCtx+ -> B8.ByteString+ -> k+ -> IO VerifyStatus+verifyFinalBS ctx sig k+ = withDigestCtxPtr ctx $ \ ctxPtr ->+ B8.unsafeUseAsCStringLen sig $ \ (buf, len) ->+ withPKeyPtr' k $ \ pkeyPtr ->+ _VerifyFinal ctxPtr buf (fromIntegral len) pkeyPtr >>= interpret+ where+ interpret :: CInt -> IO VerifyStatus+ interpret 1 = return VerifySuccess+ interpret 0 = return VerifyFailure+ interpret _ = raiseOpenSSLError++-- |@'verify'@ verifies a signature and a stream of data. The string+-- must not contain any letters which aren't in the range of U+0000 -+-- U+00FF.+verify :: PublicKey key =>+ Digest -- ^ message digest algorithm to use+ -> String -- ^ message signature+ -> key -- ^ public key to verify the signature+ -> String -- ^ input string to verify+ -> IO VerifyStatus -- ^ the result of verification+{-# DEPRECATED verify "Use verifyBS or verifyLBS instead." #-}+verify md sig pkey input+ = verifyLBS md (B8.pack sig) pkey (L8.pack input)++-- |@'verifyBS'@ verifies a signature and a chunk of data.+verifyBS :: PublicKey key =>+ Digest -- ^ message digest algorithm to use+ -> B8.ByteString -- ^ message signature+ -> key -- ^ public key to verify the signature+ -> B8.ByteString -- ^ input string to verify+ -> IO VerifyStatus -- ^ the result of verification+verifyBS md sig pkey input+ = do ctx <- digestStrictly md input+ verifyFinalBS ctx sig pkey++-- |@'verifyLBS'@ verifies a signature of a stream of data.+verifyLBS :: PublicKey key =>+ Digest -- ^ message digest algorithm to use+ -> B8.ByteString -- ^ message signature+ -> key -- ^ public key to verify the signature+ -> L8.ByteString -- ^ input string to verify+ -> IO VerifyStatus -- ^ the result of verification+verifyLBS md sig pkey input+ = do ctx <- digestLazily md input+ verifyFinalBS ctx sig pkey
− OpenSSL/EVP/Verify.hsc
@@ -1,78 +0,0 @@-{- -*- haskell -*- -}---- |Message verification using asymmetric cipher and message digest--- algorithm. This is an opposite of "OpenSSL.EVP.Sign".--module OpenSSL.EVP.Verify- ( VerifyStatus(..)- , verify- , verifyBS- , verifyLBS- )- where--import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Data.Typeable-import Foreign-import Foreign.C-import OpenSSL.EVP.Digest-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-import OpenSSL.Utils---- |@'VerifyStatus'@ represents a result of verification.-data VerifyStatus = VerifySuccess- | VerifyFailure- deriving (Show, Eq, Typeable)---foreign import ccall unsafe "EVP_VerifyFinal"- _VerifyFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> CUInt -> Ptr EVP_PKEY -> IO CInt---verifyFinalBS :: PublicKey k => DigestCtx -> String -> k -> IO VerifyStatus-verifyFinalBS ctx sig k- = withDigestCtxPtr ctx $ \ ctxPtr ->- withCStringLen sig $ \ (buf, len) ->- withPKeyPtr' k $ \ pkeyPtr ->- _VerifyFinal ctxPtr buf (fromIntegral len) pkeyPtr >>= interpret- where- interpret :: CInt -> IO VerifyStatus- interpret 1 = return VerifySuccess- interpret 0 = return VerifyFailure- interpret _ = raiseOpenSSLError---- |@'verify'@ verifies a signature and a stream of data. The string--- must not contain any letters which aren't in the range of U+0000 ---- U+00FF.-verify :: PublicKey key =>- Digest -- ^ message digest algorithm to use- -> String -- ^ message signature- -> key -- ^ public key to verify the signature- -> String -- ^ input string to verify- -> IO VerifyStatus -- ^ the result of verification-verify md sig pkey input- = verifyLBS md sig pkey (L8.pack input)---- |@'verifyBS'@ verifies a signature and a chunk of data.-verifyBS :: PublicKey key =>- Digest -- ^ message digest algorithm to use- -> String -- ^ message signature- -> key -- ^ public key to verify the signature- -> B8.ByteString -- ^ input string to verify- -> IO VerifyStatus -- ^ the result of verification-verifyBS md sig pkey input- = do ctx <- digestStrictly md input- verifyFinalBS ctx sig pkey---- |@'verifyLBS'@ verifies a signature of a stream of data.-verifyLBS :: PublicKey key =>- Digest -- ^ message digest algorithm to use- -> String -- ^ message signature- -> key -- ^ public key to verify the signature- -> L8.ByteString -- ^ input string to verify- -> IO VerifyStatus -- ^ the result of verification-verifyLBS md sig pkey input- = do ctx <- digestLazily md input- verifyFinalBS ctx sig pkey
OpenSSL/Objects.hsc view
@@ -1,26 +1,27 @@-#include "HsOpenSSL.h"-+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-} module OpenSSL.Objects ( ObjNameType(..) , getObjNames ) where-+#include "HsOpenSSL.h" import Data.IORef import Foreign import Foreign.C type ObjName = Ptr OBJ_NAME-data OBJ_NAME+data {-# CTYPE "openssl/objects.h" "OBJ_NAME" #-} OBJ_NAME type DoAllCallback = ObjName -> Ptr () -> IO () -foreign import ccall safe "OBJ_NAME_do_all"+foreign import capi safe "openssl/objects.h OBJ_NAME_do_all" _NAME_do_all :: CInt -> FunPtr DoAllCallback -> Ptr () -> IO () -foreign import ccall safe "OBJ_NAME_do_all_sorted"+foreign import capi safe "openssl/objects.h OBJ_NAME_do_all_sorted" _NAME_do_all_sorted :: CInt -> FunPtr DoAllCallback -> Ptr () -> IO () foreign import ccall "wrapper"
+ OpenSSL/PEM.hs view
@@ -0,0 +1,522 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- |An interface to PEM routines.+module OpenSSL.PEM+ ( -- * Password supply+ PemPasswordCallback+ , PemPasswordRWState(..)+ , PemPasswordSupply(..)++ -- * Private key+ , writePKCS8PrivateKey+ , readPrivateKey++ -- * Public key+ , writePublicKey+ , readPublicKey++ -- * X.509 certificate+ , writeX509+ , readX509++ -- * PKCS#10 certificate request+ , PemX509ReqFormat(..)+ , writeX509Req+ , readX509Req++ -- * Certificate Revocation List+ , writeCRL+ , readCRL++ -- * PKCS#7 structure+ , writePkcs7+ , readPkcs7++ -- * DH parameters+ , writeDHParams+ , readDHParams+ )+ where+import Control.Exception hiding (try)+import Control.Monad+import qualified Data.ByteString.Char8 as B8+import Data.Maybe+import Foreign+import Foreign.C+import OpenSSL.BIO+import OpenSSL.EVP.Cipher hiding (cipher)+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+import OpenSSL.DH.Internal+import OpenSSL.PKCS7+import OpenSSL.Utils+import OpenSSL.X509+import OpenSSL.X509.Request+import OpenSSL.X509.Revocation+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif+import System.IO+++-- |@'PemPasswordCallback'@ represents a callback function to supply a+-- password.+--+-- [@Int@] The maximum length of the password to be accepted.+--+-- [@PemPasswordRWState@] The context.+--+-- [@IO String@] The resulting password.+--+type PemPasswordCallback = Int -> PemPasswordRWState -> IO String+type PemPasswordCallback' = Ptr CChar -> Int -> Int -> Ptr () -> IO Int+++-- |@'PemPasswordRWState'@ represents a context of+-- 'PemPasswordCallback'.+data PemPasswordRWState = PwRead -- ^ The callback was called to get+ -- a password to read something+ -- encrypted.+ | PwWrite -- ^ The callback was called to get+ -- a password to encrypt+ -- something.++-- |@'PemPasswordSupply'@ represents a way to supply password.+--+-- FIXME: using PwTTY causes an error but I don't know why:+-- \"error:0906406D:PEM routines:DEF_CALLBACK:problems getting+-- password\"+data PemPasswordSupply = PwNone -- ^ no password+ | PwStr String -- ^ password in a static string+ | PwBS B8.ByteString -- ^ password in a static bytestring.+ | PwCallback PemPasswordCallback -- ^ get a+ -- password+ -- by a+ -- callback+ | PwTTY -- ^ read a password from TTY+++foreign import ccall "wrapper"+ mkPemPasswordCallback :: PemPasswordCallback' -> IO (FunPtr PemPasswordCallback')+++rwflagToState :: Int -> PemPasswordRWState+rwflagToState 0 = PwRead+rwflagToState 1 = PwWrite+rwflagToState _ = undefined+++callPasswordCB :: PemPasswordCallback -> PemPasswordCallback'+callPasswordCB cb buf bufLen rwflag _+ = let mode = rwflagToState rwflag+ try = do passStr <- cb bufLen mode+ let passLen = length passStr++ when (passLen > bufLen)+ $ failForTooLongPassword bufLen++ pokeArray buf $ map (toEnum . fromEnum) passStr+ return passLen+ in+ try `catch` \ exc ->+ do hPutStrLn stderr (show (exc :: SomeException))+ return 0 -- zero indicates an error+ where+ failForTooLongPassword :: Int -> IO a+ failForTooLongPassword len+ = fail ("callPasswordCB: the password which the callback returned is too long: "+ ++ "it must be at most " ++ show len ++ " bytes.")+++{- PKCS#8 -------------------------------------------------------------------- -}++foreign import capi safe "openssl/pem.h PEM_write_bio_PKCS8PrivateKey"+ _write_bio_PKCS8PrivateKey :: Ptr BIO_+ -> Ptr EVP_PKEY+ -> Ptr EVP_CIPHER+ -> Ptr CChar+ -> CInt+ -> FunPtr PemPasswordCallback'+ -> Ptr a+ -> IO CInt++writePKCS8PrivateKey' :: KeyPair key =>+ BIO+ -> key+ -> Maybe (Cipher, PemPasswordSupply)+ -> IO ()+writePKCS8PrivateKey' bio key encryption+ = withBioPtr bio $ \ bioPtr ->+ withPKeyPtr' key $ \ pkeyPtr ->+ do ret <- case encryption of+ Nothing+ -> _write_bio_PKCS8PrivateKey bioPtr pkeyPtr nullPtr nullPtr 0 nullFunPtr nullPtr++ Just (_, PwNone)+ -> _write_bio_PKCS8PrivateKey bioPtr pkeyPtr nullPtr nullPtr 0 nullFunPtr nullPtr++ Just (cipher, PwStr passStr)+ -> withCStringLen passStr $ \(passPtr, passLen) ->+ withCipherPtr cipher $ \ cipherPtr ->+ _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr passPtr (fromIntegral passLen) nullFunPtr nullPtr+ Just (cipher, PwBS passStr)+ -> withBS passStr $ \(passPtr, passLen) ->+ withCipherPtr cipher $ \ cipherPtr ->+ _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr passPtr (fromIntegral passLen) nullFunPtr nullPtr+ Just (cipher, PwCallback cb)+ -> withCipherPtr cipher $ \ cipherPtr ->+ bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr ->+ _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 cbPtr nullPtr++ Just (cipher, PwTTY)+ -> withCipherPtr cipher $ \ cipherPtr ->+ _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 nullFunPtr nullPtr+ failIf_ (/= 1) ret++-- |@'writePKCS8PrivateKey'@ writes a private key to PEM string in+-- PKCS#8 format.+writePKCS8PrivateKey+ :: KeyPair key =>+ key -- ^ private key to write+ -> Maybe (Cipher, PemPasswordSupply) -- ^ Either (symmetric cipher+ -- algorithm, password+ -- supply) or @Nothing@. If+ -- @Nothing@ is given the+ -- private key is not+ -- encrypted.+ -> IO String -- ^ the result PEM string+writePKCS8PrivateKey pkey encryption+ = do mem <- newMem+ writePKCS8PrivateKey' mem pkey encryption+ bioRead mem+++foreign import capi safe "openssl/pem.h PEM_read_bio_PrivateKey"+ _read_bio_PrivateKey :: Ptr BIO_+ -> Ptr (Ptr EVP_PKEY)+ -> FunPtr PemPasswordCallback'+ -> CString+ -> IO (Ptr EVP_PKEY)++readPrivateKey' :: BIO -> PemPasswordSupply -> IO SomeKeyPair+readPrivateKey' bio supply+ = withBioPtr bio $ \ bioPtr ->+ do pkeyPtr <- case supply of+ PwNone+ -> withCString "" $ \ strPtr ->+ _read_bio_PrivateKey bioPtr nullPtr nullFunPtr (castPtr strPtr)+ PwStr passStr+ -> withCString passStr $+ _read_bio_PrivateKey bioPtr nullPtr nullFunPtr+ PwBS passStr+ -> withBS passStr $ \(passPtr,_) ->+ _read_bio_PrivateKey bioPtr nullPtr nullFunPtr passPtr+ PwCallback cb+ -> bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr ->+ _read_bio_PrivateKey bioPtr nullPtr cbPtr nullPtr+ PwTTY+ -> _read_bio_PrivateKey bioPtr nullPtr nullFunPtr nullPtr+ failIfNull_ pkeyPtr+ fmap fromJust (wrapPKeyPtr pkeyPtr >>= fromPKey)++-- |@'readPrivateKey' pem supply@ reads a private key in PEM string.+readPrivateKey :: String -> PemPasswordSupply -> IO SomeKeyPair+readPrivateKey pemStr supply+ = do mem <- newConstMem pemStr+ readPrivateKey' mem supply+++{- Public Key ---------------------------------------------------------------- -}++foreign import capi unsafe "openssl/pem.h PEM_write_bio_PUBKEY"+ _write_bio_PUBKEY :: Ptr BIO_ -> Ptr EVP_PKEY -> IO CInt++foreign import capi unsafe "openssl/pem.h PEM_read_bio_PUBKEY"+ _read_bio_PUBKEY :: Ptr BIO_+ -> Ptr (Ptr EVP_PKEY)+ -> FunPtr PemPasswordCallback'+ -> Ptr ()+ -> IO (Ptr EVP_PKEY)+++writePublicKey' :: PublicKey key => BIO -> key -> IO ()+writePublicKey' bio key+ = withBioPtr bio $ \ bioPtr ->+ withPKeyPtr' key $ \ pkeyPtr ->+ _write_bio_PUBKEY bioPtr pkeyPtr >>= failIf (/= 1) >> return ()++-- |@'writePublicKey' pubkey@ writes a public to PEM string.+writePublicKey :: PublicKey key => key -> IO String+writePublicKey pkey+ = do mem <- newMem+ writePublicKey' mem pkey+ bioRead mem++-- Why the heck PEM_read_bio_PUBKEY takes pem_password_cb? Is there+-- any form of encrypted public key?+readPublicKey' :: BIO -> IO SomePublicKey+readPublicKey' bio+ = withBioPtr bio $ \ bioPtr ->+ withCString "" $ \ passPtr ->+ fmap fromJust+ ( _read_bio_PUBKEY bioPtr nullPtr nullFunPtr (castPtr passPtr)+ >>= failIfNull+ >>= wrapPKeyPtr+ >>= fromPKey+ )++-- |@'readPublicKey' pem@ reads a public key in PEM string.+readPublicKey :: String -> IO SomePublicKey+readPublicKey pemStr+ = newConstMem pemStr >>= readPublicKey'+++{- X.509 certificate --------------------------------------------------------- -}++foreign import capi unsafe "openssl/pem.h PEM_write_bio_X509"+ _write_bio_X509 :: Ptr BIO_+ -> Ptr X509_+ -> IO CInt++foreign import capi safe "openssl/pem.h PEM_read_bio_X509"+ _read_bio_X509 :: Ptr BIO_+ -> Ptr (Ptr X509_)+ -> FunPtr PemPasswordCallback'+ -> Ptr ()+ -> IO (Ptr X509_)++writeX509' :: BIO -> X509 -> IO ()+writeX509' bio x509+ = withBioPtr bio $ \ bioPtr ->+ withX509Ptr x509 $ \ x509Ptr ->+ _write_bio_X509 bioPtr x509Ptr+ >>= failIf (/= 1)+ >> return ()++-- |@'writeX509' cert@ writes an X.509 certificate to PEM string.+writeX509 :: X509 -> IO String+writeX509 x509+ = do mem <- newMem+ writeX509' mem x509+ bioRead mem+++-- I believe X.509 isn't encrypted.+readX509' :: BIO -> IO X509+readX509' bio+ = withBioPtr bio $ \ bioPtr ->+ withCString "" $ \ passPtr ->+ _read_bio_X509 bioPtr nullPtr nullFunPtr (castPtr passPtr)+ >>= failIfNull+ >>= wrapX509++-- |@'readX509' pem@ reads an X.509 certificate in PEM string.+readX509 :: String -> IO X509+readX509 pemStr+ = newConstMem pemStr >>= readX509'+++{- PKCS#10 certificate request ----------------------------------------------- -}++foreign import capi unsafe "openssl/pem.h PEM_write_bio_X509_REQ"+ _write_bio_X509_REQ :: Ptr BIO_+ -> Ptr X509_REQ+ -> IO CInt++foreign import capi unsafe "openssl/pem.h PEM_write_bio_X509_REQ_NEW"+ _write_bio_X509_REQ_NEW :: Ptr BIO_+ -> Ptr X509_REQ+ -> IO CInt++foreign import capi safe "openssl/pem.h PEM_read_bio_X509_REQ"+ _read_bio_X509_REQ :: Ptr BIO_+ -> Ptr (Ptr X509_REQ)+ -> FunPtr PemPasswordCallback'+ -> Ptr ()+ -> IO (Ptr X509_REQ)++-- |@'PemX509ReqFormat'@ represents format of PKCS#10 certificate+-- request.+data PemX509ReqFormat+ = ReqNewFormat -- ^ The new format, whose header is \"NEW+ -- CERTIFICATE REQUEST\".+ | ReqOldFormat -- ^ The old format, whose header is \"CERTIFICATE+ -- REQUEST\".+++writeX509Req' :: BIO -> X509Req -> PemX509ReqFormat -> IO ()+writeX509Req' bio req format+ = withBioPtr bio $ \ bioPtr ->+ withX509ReqPtr req $ \ reqPtr ->+ writer bioPtr reqPtr+ >>= failIf (/= 1)+ >> return ()+ where+ writer = case format of+ ReqNewFormat -> _write_bio_X509_REQ_NEW+ ReqOldFormat -> _write_bio_X509_REQ++-- |@'writeX509Req'@ writes a PKCS#10 certificate request to PEM+-- string.+writeX509Req :: X509Req -- ^ request+ -> PemX509ReqFormat -- ^ format+ -> IO String -- ^ the result PEM string+writeX509Req req format+ = do mem <- newMem+ writeX509Req' mem req format+ bioRead mem+++readX509Req' :: BIO -> IO X509Req+readX509Req' bio+ = withBioPtr bio $ \ bioPtr ->+ withCString "" $ \ passPtr ->+ _read_bio_X509_REQ bioPtr nullPtr nullFunPtr (castPtr passPtr)+ >>= failIfNull+ >>= wrapX509Req++-- |@'readX509Req'@ reads a PKCS#10 certificate request in PEM string.+readX509Req :: String -> IO X509Req+readX509Req pemStr+ = newConstMem pemStr >>= readX509Req'+++{- Certificate Revocation List ----------------------------------------------- -}++foreign import capi unsafe "openssl/pem.h PEM_write_bio_X509_CRL"+ _write_bio_X509_CRL :: Ptr BIO_+ -> Ptr X509_CRL+ -> IO CInt++foreign import capi safe "openssl/pem.h PEM_read_bio_X509_CRL"+ _read_bio_X509_CRL :: Ptr BIO_+ -> Ptr (Ptr X509_CRL)+ -> FunPtr PemPasswordCallback'+ -> Ptr ()+ -> IO (Ptr X509_CRL)+++writeCRL' :: BIO -> CRL -> IO ()+writeCRL' bio crl+ = withBioPtr bio $ \ bioPtr ->+ withCRLPtr crl $ \ crlPtr ->+ _write_bio_X509_CRL bioPtr crlPtr+ >>= failIf (/= 1)+ >> return ()++-- |@'writeCRL' crl@ writes a Certificate Revocation List to PEM+-- string.+writeCRL :: CRL -> IO String+writeCRL crl+ = do mem <- newMem+ writeCRL' mem crl+ bioRead mem+++readCRL' :: BIO -> IO CRL+readCRL' bio+ = withBioPtr bio $ \ bioPtr ->+ withCString "" $ \ passPtr ->+ _read_bio_X509_CRL bioPtr nullPtr nullFunPtr (castPtr passPtr)+ >>= failIfNull+ >>= wrapCRL++-- |@'readCRL' pem@ reads a Certificate Revocation List in PEM string.+readCRL :: String -> IO CRL+readCRL pemStr+ = newConstMem pemStr >>= readCRL'+++{- PKCS#7 -------------------------------------------------------------------- -}++foreign import capi unsafe "openssl/pem.h PEM_write_bio_PKCS7"+ _write_bio_PKCS7 :: Ptr BIO_+ -> Ptr PKCS7+ -> IO CInt++foreign import capi safe "openssl/pem.h PEM_read_bio_PKCS7"+ _read_bio_PKCS7 :: Ptr BIO_+ -> Ptr (Ptr PKCS7)+ -> FunPtr PemPasswordCallback'+ -> Ptr ()+ -> IO (Ptr PKCS7)+++writePkcs7' :: BIO -> Pkcs7 -> IO ()+writePkcs7' bio pkcs7+ = withBioPtr bio $ \ bioPtr ->+ withPkcs7Ptr pkcs7 $ \ pkcs7Ptr ->+ _write_bio_PKCS7 bioPtr pkcs7Ptr+ >>= failIf (/= 1)+ >> return ()++-- |@'writePkcs7' p7@ writes a PKCS#7 structure to PEM string.+writePkcs7 :: Pkcs7 -> IO String+writePkcs7 pkcs7+ = do mem <- newMem+ writePkcs7' mem pkcs7+ bioRead mem+++readPkcs7' :: BIO -> IO Pkcs7+readPkcs7' bio+ = withBioPtr bio $ \ bioPtr ->+ withCString "" $ \ passPtr ->+ _read_bio_PKCS7 bioPtr nullPtr nullFunPtr (castPtr passPtr)+ >>= failIfNull+ >>= wrapPkcs7Ptr++-- |@'readPkcs7' pem@ reads a PKCS#7 structure in PEM string.+readPkcs7 :: String -> IO Pkcs7+readPkcs7 pemStr+ = newConstMem pemStr >>= readPkcs7'++{- DH parameters ------------------------------------------------------------- -}++foreign import capi unsafe "openssl/pem.h PEM_write_bio_DHparams"+ _write_bio_DH :: Ptr BIO_+ -> Ptr DH_+ -> IO CInt++foreign import capi safe "openssl/pem.h PEM_read_bio_DHparams"+ _read_bio_DH :: Ptr BIO_+ -> Ptr (Ptr DH_)+ -> FunPtr PemPasswordCallback'+ -> Ptr ()+ -> IO (Ptr DH_)++writeDHParams' :: BIO -> DHP -> IO ()+writeDHParams' bio dh+ = withBioPtr bio $ \ bioPtr ->+ withDHPPtr dh $ \ dhPtr ->+ _write_bio_DH bioPtr dhPtr >>= failIf_ (/= 1)++-- |@'writeDHParams' dh@ writes DH parameters to PEM string.+writeDHParams :: DHP -> IO String+writeDHParams dh+ = do mem <- newMem+ writeDHParams' mem dh+ bioRead mem++readDHParams' :: BIO -> IO DHP+readDHParams' bio+ = withBioPtr bio $ \ bioPtr ->+ withCString "" $ \ passPtr ->+ _read_bio_DH bioPtr nullPtr nullFunPtr (castPtr passPtr)+ >>= failIfNull+ >>= wrapDHPPtr++-- |@'readDHParams' pem@ reads DH parameters in PEM string.+readDHParams :: String -> IO DHP+readDHParams pemStr+ = newConstMem pemStr >>= readDHParams'+++withBS :: B8.ByteString -> ((Ptr CChar, Int) -> IO t) -> IO t+withBS passStr act =+ B8.useAsCStringLen passStr $ \ (passPtr, passLen) ->+ flip finally (memset passPtr 0 $ fromIntegral passLen) $+ act (castPtr passPtr, passLen)++foreign import capi unsafe "string.h memset" memset :: Ptr a -> CInt -> CSize -> IO ()
− OpenSSL/PEM.hsc
@@ -1,523 +0,0 @@-{- -*- haskell -*- -}---- |An interface to PEM routines.--module OpenSSL.PEM- ( -- * Password supply- PemPasswordCallback- , PemPasswordRWState(..)- , PemPasswordSupply(..)-- -- * Private key- , writePKCS8PrivateKey- , readPrivateKey-- -- * Public key- , writePublicKey- , readPublicKey-- -- * X.509 certificate- , writeX509- , readX509-- -- * PKCS#10 certificate request- , PemX509ReqFormat(..)- , writeX509Req- , readX509Req-- -- * Certificate Revocation List- , writeCRL- , readCRL-- -- * PKCS#7 structure- , writePkcs7- , readPkcs7-- -- * DH parameters- , writeDHParams- , readDHParams- )- where--import Control.Exception hiding (try)-import Control.Monad-import qualified Data.ByteString.Char8 as B8-import Data.Maybe-import Foreign-import Foreign.C-import OpenSSL.BIO-import OpenSSL.EVP.Cipher hiding (cipher)-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-import OpenSSL.DH.Internal-import OpenSSL.PKCS7-import OpenSSL.Utils-import OpenSSL.X509-import OpenSSL.X509.Request-import OpenSSL.X509.Revocation-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import System.IO----- |@'PemPasswordCallback'@ represents a callback function to supply a--- password.------ [@Int@] The maximum length of the password to be accepted.------ [@PemPasswordRWState@] The context.------ [@IO String@] The resulting password.----type PemPasswordCallback = Int -> PemPasswordRWState -> IO String-type PemPasswordCallback' = Ptr CChar -> Int -> Int -> Ptr () -> IO Int----- |@'PemPasswordRWState'@ represents a context of--- 'PemPasswordCallback'.-data PemPasswordRWState = PwRead -- ^ The callback was called to get- -- a password to read something- -- encrypted.- | PwWrite -- ^ The callback was called to get- -- a password to encrypt- -- something.---- |@'PemPasswordSupply'@ represents a way to supply password.------ FIXME: using PwTTY causes an error but I don't know why:--- \"error:0906406D:PEM routines:DEF_CALLBACK:problems getting--- password\"-data PemPasswordSupply = PwNone -- ^ no password- | PwStr String -- ^ password in a static string- | PwBS B8.ByteString -- ^ password in a static bytestring.- | PwCallback PemPasswordCallback -- ^ get a- -- password- -- by a- -- callback- | PwTTY -- ^ read a password from TTY---foreign import ccall "wrapper"- mkPemPasswordCallback :: PemPasswordCallback' -> IO (FunPtr PemPasswordCallback')---rwflagToState :: Int -> PemPasswordRWState-rwflagToState 0 = PwRead-rwflagToState 1 = PwWrite-rwflagToState _ = undefined---callPasswordCB :: PemPasswordCallback -> PemPasswordCallback'-callPasswordCB cb buf bufLen rwflag _- = let mode = rwflagToState rwflag- try = do passStr <- cb bufLen mode- let passLen = length passStr-- when (passLen > bufLen)- $ failForTooLongPassword bufLen-- pokeArray buf $ map (toEnum . fromEnum) passStr- return passLen- in- try `catch` \ exc ->- do hPutStrLn stderr (show (exc :: SomeException))- return 0 -- zero indicates an error- where- failForTooLongPassword :: Int -> IO a- failForTooLongPassword len- = fail ("callPasswordCB: the password which the callback returned is too long: "- ++ "it must be at most " ++ show len ++ " bytes.")---{- PKCS#8 -------------------------------------------------------------------- -}--foreign import ccall safe "PEM_write_bio_PKCS8PrivateKey"- _write_bio_PKCS8PrivateKey :: Ptr BIO_- -> Ptr EVP_PKEY- -> Ptr EVP_CIPHER- -> Ptr CChar- -> CInt- -> FunPtr PemPasswordCallback'- -> Ptr a- -> IO CInt--writePKCS8PrivateKey' :: KeyPair key =>- BIO- -> key- -> Maybe (Cipher, PemPasswordSupply)- -> IO ()-writePKCS8PrivateKey' bio key encryption- = withBioPtr bio $ \ bioPtr ->- withPKeyPtr' key $ \ pkeyPtr ->- do ret <- case encryption of- Nothing- -> _write_bio_PKCS8PrivateKey bioPtr pkeyPtr nullPtr nullPtr 0 nullFunPtr nullPtr-- Just (_, PwNone)- -> _write_bio_PKCS8PrivateKey bioPtr pkeyPtr nullPtr nullPtr 0 nullFunPtr nullPtr-- Just (cipher, PwStr passStr)- -> withCStringLen passStr $ \(passPtr, passLen) ->- withCipherPtr cipher $ \ cipherPtr ->- _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr passPtr (fromIntegral passLen) nullFunPtr nullPtr- Just (cipher, PwBS passStr)- -> withBS passStr $ \(passPtr, passLen) ->- withCipherPtr cipher $ \ cipherPtr ->- _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr passPtr (fromIntegral passLen) nullFunPtr nullPtr- Just (cipher, PwCallback cb)- -> withCipherPtr cipher $ \ cipherPtr ->- bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr ->- _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 cbPtr nullPtr- - Just (cipher, PwTTY)- -> withCipherPtr cipher $ \ cipherPtr ->- _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 nullFunPtr nullPtr- failIf_ (/= 1) ret---- |@'writePKCS8PrivateKey'@ writes a private key to PEM string in--- PKCS#8 format.-writePKCS8PrivateKey- :: KeyPair key =>- key -- ^ private key to write- -> Maybe (Cipher, PemPasswordSupply) -- ^ Either (symmetric cipher- -- algorithm, password- -- supply) or @Nothing@. If- -- @Nothing@ is given the- -- private key is not- -- encrypted.- -> IO String -- ^ the result PEM string-writePKCS8PrivateKey pkey encryption- = do mem <- newMem- writePKCS8PrivateKey' mem pkey encryption- bioRead mem---foreign import ccall safe "PEM_read_bio_PrivateKey"- _read_bio_PrivateKey :: Ptr BIO_- -> Ptr (Ptr EVP_PKEY)- -> FunPtr PemPasswordCallback'- -> CString- -> IO (Ptr EVP_PKEY)--readPrivateKey' :: BIO -> PemPasswordSupply -> IO SomeKeyPair-readPrivateKey' bio supply- = withBioPtr bio $ \ bioPtr ->- do pkeyPtr <- case supply of- PwNone- -> withCString "" $ \ strPtr ->- _read_bio_PrivateKey bioPtr nullPtr nullFunPtr (castPtr strPtr)- PwStr passStr- -> withCString passStr $- _read_bio_PrivateKey bioPtr nullPtr nullFunPtr- PwBS passStr- -> withBS passStr $ \(passPtr,_) ->- _read_bio_PrivateKey bioPtr nullPtr nullFunPtr passPtr- PwCallback cb- -> bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr ->- _read_bio_PrivateKey bioPtr nullPtr cbPtr nullPtr- PwTTY- -> _read_bio_PrivateKey bioPtr nullPtr nullFunPtr nullPtr - failIfNull_ pkeyPtr- fmap fromJust (wrapPKeyPtr pkeyPtr >>= fromPKey)---- |@'readPrivateKey' pem supply@ reads a private key in PEM string.-readPrivateKey :: String -> PemPasswordSupply -> IO SomeKeyPair-readPrivateKey pemStr supply- = do mem <- newConstMem pemStr- readPrivateKey' mem supply---{- Public Key ---------------------------------------------------------------- -}--foreign import ccall unsafe "PEM_write_bio_PUBKEY"- _write_bio_PUBKEY :: Ptr BIO_ -> Ptr EVP_PKEY -> IO CInt--foreign import ccall unsafe "PEM_read_bio_PUBKEY"- _read_bio_PUBKEY :: Ptr BIO_- -> Ptr (Ptr EVP_PKEY)- -> FunPtr PemPasswordCallback'- -> Ptr ()- -> IO (Ptr EVP_PKEY)---writePublicKey' :: PublicKey key => BIO -> key -> IO ()-writePublicKey' bio key- = withBioPtr bio $ \ bioPtr ->- withPKeyPtr' key $ \ pkeyPtr ->- _write_bio_PUBKEY bioPtr pkeyPtr >>= failIf (/= 1) >> return ()---- |@'writePublicKey' pubkey@ writes a public to PEM string.-writePublicKey :: PublicKey key => key -> IO String-writePublicKey pkey- = do mem <- newMem- writePublicKey' mem pkey- bioRead mem---- Why the heck PEM_read_bio_PUBKEY takes pem_password_cb? Is there--- any form of encrypted public key?-readPublicKey' :: BIO -> IO SomePublicKey-readPublicKey' bio- = withBioPtr bio $ \ bioPtr ->- withCString "" $ \ passPtr ->- fmap fromJust- ( _read_bio_PUBKEY bioPtr nullPtr nullFunPtr (castPtr passPtr)- >>= failIfNull- >>= wrapPKeyPtr- >>= fromPKey- )---- |@'readPublicKey' pem@ reads a public key in PEM string.-readPublicKey :: String -> IO SomePublicKey-readPublicKey pemStr- = newConstMem pemStr >>= readPublicKey'---{- X.509 certificate --------------------------------------------------------- -}--foreign import ccall unsafe "PEM_write_bio_X509"- _write_bio_X509 :: Ptr BIO_- -> Ptr X509_- -> IO CInt--foreign import ccall safe "PEM_read_bio_X509"- _read_bio_X509 :: Ptr BIO_- -> Ptr (Ptr X509_)- -> FunPtr PemPasswordCallback'- -> Ptr ()- -> IO (Ptr X509_)--writeX509' :: BIO -> X509 -> IO ()-writeX509' bio x509- = withBioPtr bio $ \ bioPtr ->- withX509Ptr x509 $ \ x509Ptr ->- _write_bio_X509 bioPtr x509Ptr- >>= failIf (/= 1)- >> return ()---- |@'writeX509' cert@ writes an X.509 certificate to PEM string.-writeX509 :: X509 -> IO String-writeX509 x509- = do mem <- newMem- writeX509' mem x509- bioRead mem----- I believe X.509 isn't encrypted.-readX509' :: BIO -> IO X509-readX509' bio- = withBioPtr bio $ \ bioPtr ->- withCString "" $ \ passPtr ->- _read_bio_X509 bioPtr nullPtr nullFunPtr (castPtr passPtr)- >>= failIfNull- >>= wrapX509---- |@'readX509' pem@ reads an X.509 certificate in PEM string.-readX509 :: String -> IO X509-readX509 pemStr- = newConstMem pemStr >>= readX509'---{- PKCS#10 certificate request ----------------------------------------------- -}--foreign import ccall unsafe "PEM_write_bio_X509_REQ"- _write_bio_X509_REQ :: Ptr BIO_- -> Ptr X509_REQ- -> IO CInt--foreign import ccall unsafe "PEM_write_bio_X509_REQ_NEW"- _write_bio_X509_REQ_NEW :: Ptr BIO_- -> Ptr X509_REQ- -> IO CInt--foreign import ccall safe "PEM_read_bio_X509_REQ"- _read_bio_X509_REQ :: Ptr BIO_- -> Ptr (Ptr X509_REQ)- -> FunPtr PemPasswordCallback'- -> Ptr ()- -> IO (Ptr X509_REQ)---- |@'PemX509ReqFormat'@ represents format of PKCS#10 certificate--- request.-data PemX509ReqFormat- = ReqNewFormat -- ^ The new format, whose header is \"NEW- -- CERTIFICATE REQUEST\".- | ReqOldFormat -- ^ The old format, whose header is \"CERTIFICATE- -- REQUEST\".---writeX509Req' :: BIO -> X509Req -> PemX509ReqFormat -> IO ()-writeX509Req' bio req format- = withBioPtr bio $ \ bioPtr ->- withX509ReqPtr req $ \ reqPtr ->- writer bioPtr reqPtr- >>= failIf (/= 1)- >> return ()- where- writer = case format of- ReqNewFormat -> _write_bio_X509_REQ_NEW- ReqOldFormat -> _write_bio_X509_REQ---- |@'writeX509Req'@ writes a PKCS#10 certificate request to PEM--- string.-writeX509Req :: X509Req -- ^ request- -> PemX509ReqFormat -- ^ format- -> IO String -- ^ the result PEM string-writeX509Req req format- = do mem <- newMem- writeX509Req' mem req format- bioRead mem---readX509Req' :: BIO -> IO X509Req-readX509Req' bio- = withBioPtr bio $ \ bioPtr ->- withCString "" $ \ passPtr ->- _read_bio_X509_REQ bioPtr nullPtr nullFunPtr (castPtr passPtr)- >>= failIfNull- >>= wrapX509Req---- |@'readX509Req'@ reads a PKCS#10 certificate request in PEM string.-readX509Req :: String -> IO X509Req-readX509Req pemStr- = newConstMem pemStr >>= readX509Req'---{- Certificate Revocation List ----------------------------------------------- -}--foreign import ccall unsafe "PEM_write_bio_X509_CRL"- _write_bio_X509_CRL :: Ptr BIO_- -> Ptr X509_CRL- -> IO CInt--foreign import ccall safe "PEM_read_bio_X509_CRL"- _read_bio_X509_CRL :: Ptr BIO_- -> Ptr (Ptr X509_CRL)- -> FunPtr PemPasswordCallback'- -> Ptr ()- -> IO (Ptr X509_CRL)---writeCRL' :: BIO -> CRL -> IO ()-writeCRL' bio crl- = withBioPtr bio $ \ bioPtr ->- withCRLPtr crl $ \ crlPtr ->- _write_bio_X509_CRL bioPtr crlPtr- >>= failIf (/= 1)- >> return ()---- |@'writeCRL' crl@ writes a Certificate Revocation List to PEM--- string.-writeCRL :: CRL -> IO String-writeCRL crl- = do mem <- newMem- writeCRL' mem crl- bioRead mem---readCRL' :: BIO -> IO CRL-readCRL' bio- = withBioPtr bio $ \ bioPtr ->- withCString "" $ \ passPtr ->- _read_bio_X509_CRL bioPtr nullPtr nullFunPtr (castPtr passPtr)- >>= failIfNull- >>= wrapCRL---- |@'readCRL' pem@ reads a Certificate Revocation List in PEM string.-readCRL :: String -> IO CRL-readCRL pemStr- = newConstMem pemStr >>= readCRL'---{- PKCS#7 -------------------------------------------------------------------- -}--foreign import ccall unsafe "PEM_write_bio_PKCS7"- _write_bio_PKCS7 :: Ptr BIO_- -> Ptr PKCS7- -> IO CInt--foreign import ccall safe "PEM_read_bio_PKCS7"- _read_bio_PKCS7 :: Ptr BIO_- -> Ptr (Ptr PKCS7)- -> FunPtr PemPasswordCallback'- -> Ptr ()- -> IO (Ptr PKCS7)---writePkcs7' :: BIO -> Pkcs7 -> IO ()-writePkcs7' bio pkcs7- = withBioPtr bio $ \ bioPtr ->- withPkcs7Ptr pkcs7 $ \ pkcs7Ptr ->- _write_bio_PKCS7 bioPtr pkcs7Ptr- >>= failIf (/= 1)- >> return ()---- |@'writePkcs7' p7@ writes a PKCS#7 structure to PEM string.-writePkcs7 :: Pkcs7 -> IO String-writePkcs7 pkcs7- = do mem <- newMem- writePkcs7' mem pkcs7- bioRead mem---readPkcs7' :: BIO -> IO Pkcs7-readPkcs7' bio- = withBioPtr bio $ \ bioPtr ->- withCString "" $ \ passPtr ->- _read_bio_PKCS7 bioPtr nullPtr nullFunPtr (castPtr passPtr)- >>= failIfNull- >>= wrapPkcs7Ptr---- |@'readPkcs7' pem@ reads a PKCS#7 structure in PEM string.-readPkcs7 :: String -> IO Pkcs7-readPkcs7 pemStr- = newConstMem pemStr >>= readPkcs7'--{- DH parameters ------------------------------------------------------------- -}--foreign import ccall unsafe "PEM_write_bio_DHparams"- _write_bio_DH :: Ptr BIO_- -> Ptr DH_- -> IO CInt--foreign import ccall safe "PEM_read_bio_DHparams"- _read_bio_DH :: Ptr BIO_- -> Ptr (Ptr DH_)- -> FunPtr PemPasswordCallback'- -> Ptr ()- -> IO (Ptr DH_)--writeDHParams' :: BIO -> DHP -> IO ()-writeDHParams' bio dh- = withBioPtr bio $ \ bioPtr ->- withDHPPtr dh $ \ dhPtr ->- _write_bio_DH bioPtr dhPtr >>= failIf_ (/= 1)---- |@'writeDHParams' dh@ writes DH parameters to PEM string.-writeDHParams :: DHP -> IO String-writeDHParams dh- = do mem <- newMem- writeDHParams' mem dh- bioRead mem--readDHParams' :: BIO -> IO DHP-readDHParams' bio- = withBioPtr bio $ \ bioPtr ->- withCString "" $ \ passPtr ->- _read_bio_DH bioPtr nullPtr nullFunPtr (castPtr passPtr)- >>= failIfNull- >>= wrapDHPPtr---- |@'readDHParams' pem@ reads DH parameters in PEM string.-readDHParams :: String -> IO DHP-readDHParams pemStr- = newConstMem pemStr >>= readDHParams'---withBS :: B8.ByteString -> ((Ptr CChar, Int) -> IO t) -> IO t-withBS passStr act =- B8.useAsCStringLen passStr $ \ (passPtr, passLen) ->- flip finally (memset passPtr 0 $ fromIntegral passLen) $- act (castPtr passPtr, passLen)--foreign import ccall unsafe memset :: Ptr a -> CInt -> CSize -> IO ()
OpenSSL/PKCS7.hsc view
@@ -1,11 +1,9 @@-{- -*- haskell -*- -}---- #prune-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# OPTIONS_HADDOCK prune #-} -- |An interface to PKCS#7 structure and S\/MIME message.--#include "HsOpenSSL.h"- module OpenSSL.PKCS7 ( -- * Types Pkcs7@@ -26,7 +24,7 @@ , readSmime ) where-+#include "HsOpenSSL.h" import Data.List import Data.Traversable import Data.Typeable@@ -49,7 +47,7 @@ -- very haskellish but please get it out of your mind since OpenSSL is -- written in C. newtype Pkcs7 = Pkcs7 (ForeignPtr PKCS7)-data PKCS7+data {-# CTYPE "openssl/pkcs7.h" "PKCS7" #-} PKCS7 -- |@'Pkcs7Flag'@ is a set of flags that are used in many operations -- related to PKCS#7.@@ -96,22 +94,22 @@ flagListToInt = foldl' (.|.) 0 . map flagToInt -foreign import ccall "&PKCS7_free"+foreign import capi "openssl/pkcs7.h &PKCS7_free" _free :: FunPtr (Ptr PKCS7 -> IO ()) -foreign import ccall "HsOpenSSL_PKCS7_is_detached"+foreign import capi "HsOpenSSL.h HsOpenSSL_PKCS7_is_detached" _is_detached :: Ptr PKCS7 -> IO CLong -foreign import ccall "PKCS7_sign"+foreign import capi "openssl/pkcs7.h PKCS7_sign" _sign :: Ptr X509_ -> Ptr EVP_PKEY -> Ptr STACK -> Ptr BIO_ -> CInt -> IO (Ptr PKCS7) -foreign import ccall "PKCS7_verify"+foreign import capi "openssl/pkcs7.h PKCS7_verify" _verify :: Ptr PKCS7 -> Ptr STACK -> Ptr X509_STORE -> Ptr BIO_ -> Ptr BIO_ -> CInt -> IO CInt -foreign import ccall "PKCS7_encrypt"+foreign import capi "openssl/pkcs7.h PKCS7_encrypt" _encrypt :: Ptr STACK -> Ptr BIO_ -> Ptr EVP_CIPHER -> CInt -> IO (Ptr PKCS7) -foreign import ccall "PKCS7_decrypt"+foreign import capi "openssl/pkcs7.h PKCS7_decrypt" _decrypt :: Ptr PKCS7 -> Ptr EVP_PKEY -> Ptr X509_ -> Ptr BIO_ -> CInt -> IO CInt @@ -149,7 +147,7 @@ -- chain) -> String -- ^ data to be signed -> [Pkcs7Flag] -- ^ An optional set of flags:- -- + -- -- ['Pkcs7Text'] Many S\/MIME clients -- expect the signed content to include -- valid MIME headers. If the 'Pkcs7Text'@@ -233,7 +231,7 @@ -- present in the PKCS#7 structure -- (that is it is detached). -> [Pkcs7Flag] -- ^ An optional set of flags:- -- + -- -- ['Pkcs7NoIntern'] If -- 'Pkcs7NoIntern' is set the -- certificates in the message itself@@ -347,10 +345,10 @@ {- S/MIME -------------------------------------------------------------------- -} -foreign import ccall unsafe "SMIME_write_PKCS7"+foreign import capi unsafe "openssl/pkcs7.h SMIME_write_PKCS7" _SMIME_write_PKCS7 :: Ptr BIO_ -> Ptr PKCS7 -> Ptr BIO_ -> CInt -> IO CInt -foreign import ccall unsafe "SMIME_read_PKCS7"+foreign import capi unsafe "openssl/pkcs7.h SMIME_read_PKCS7" _SMIME_read_PKCS7 :: Ptr BIO_ -> Ptr (Ptr BIO_) -> IO (Ptr PKCS7) -- |@'writeSmime'@ writes PKCS#7 structure to S\/MIME message.
OpenSSL/RSA.hsc view
@@ -1,11 +1,9 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK prune #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# OPTIONS_HADDOCK prune #-} -- |An interface to RSA public key generator.--#include "HsOpenSSL.h"- module OpenSSL.RSA ( -- * Type RSAKey(..)@@ -29,14 +27,27 @@ , rsaKeyPairFinalize -- private ) where+#include "HsOpenSSL.h"+import Control.Monad+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Data.Typeable -import Control.Monad-import Data.Typeable-import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe (unsafePerformIO)-import Foreign.C-import OpenSSL.BN-import OpenSSL.Utils+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CInt(..))+#else+import Foreign.C.Types (CInt)+#endif+import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, newForeignPtr, withForeignPtr)+import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr, nullFunPtr, nullPtr)+import Foreign.Storable (Storable(..))+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+import Foreign.Marshal.Alloc (alloca)+#endif+import OpenSSL.BN+import OpenSSL.Utils+import System.IO.Unsafe (unsafePerformIO) -- |@'RSAPubKey'@ is an opaque object that represents RSA public key. newtype RSAPubKey = RSAPubKey (ForeignPtr RSA)@@ -48,7 +59,7 @@ -- RSAPubKey and RSAKeyPair are in fact the same type at the OpenSSL -- level, but we want to treat them differently for type-safety.-data RSA+data {-# CTYPE "openssl/rsa.h" "RSA" #-} RSA -- |@'RSAKey' a@ is either 'RSAPubKey' or 'RSAKeyPair'. class RSAKey k where@@ -61,11 +72,11 @@ -- |@'rsaN' key@ returns the public modulus of the key. rsaN :: k -> Integer- rsaN = peekI (#peek RSA, n)+ rsaN = peekI rsa_n -- |@'rsaE' key@ returns the public exponent of the key. rsaE :: k -> Integer- rsaE = peekI (#peek RSA, e)+ rsaE = peekI rsa_e -- private withRSAPtr :: k -> (Ptr RSA -> IO a) -> IO a@@ -97,23 +108,23 @@ hasRSAPrivateKey :: Ptr RSA -> IO Bool hasRSAPrivateKey rsaPtr- = do d <- (#peek RSA, d) rsaPtr- p <- (#peek RSA, p) rsaPtr- q <- (#peek RSA, q) rsaPtr+ = do d <- rsa_d rsaPtr+ p <- rsa_p rsaPtr+ q <- rsa_q rsaPtr return (d /= nullPtr && p /= nullPtr && q /= nullPtr)- -foreign import ccall unsafe "&RSA_free"++foreign import capi unsafe "openssl/rsa.h &RSA_free" _free :: FunPtr (Ptr RSA -> IO ()) -foreign import ccall unsafe "RSAPublicKey_dup"+foreign import capi unsafe "openssl/rsa.h RSAPublicKey_dup" _pubDup :: Ptr RSA -> IO (Ptr RSA) -foreign import ccall unsafe "RSAPrivateKey_dup"+foreign import capi unsafe "openssl/rsa.h RSAPrivateKey_dup" _privDup :: Ptr RSA -> IO (Ptr RSA) -foreign import ccall unsafe "RSA_size"+foreign import capi unsafe "openssl/rsa.h RSA_size" _size :: Ptr RSA -> IO CInt -- | Make a copy of the public parameters of the given key.@@ -150,7 +161,7 @@ foreign import ccall "wrapper" mkGenKeyCallback :: RSAGenKeyCallback' -> IO (FunPtr RSAGenKeyCallback') -foreign import ccall safe "RSA_generate_key"+foreign import capi safe "openssl/rsa.h RSA_generate_key" _generate_key :: CInt -> CInt -> FunPtr RSAGenKeyCallback' -> Ptr a -> IO (Ptr RSA) -- |@'generateRSAKey'@ generates an RSA keypair.@@ -188,6 +199,71 @@ {- exploration -------------------------------------------------------------- -} +rsa_n, rsa_e, rsa_d, rsa_p, rsa_q :: Ptr RSA -> IO (Ptr BIGNUM)+rsa_dmp1, rsa_dmq1, rsa_iqmp :: Ptr RSA -> IO (Ptr BIGNUM)++#if OPENSSL_VERSION_NUMBER >= 0x10100000L++foreign import capi unsafe "openssl/rsa.h RSA_get0_key"+ _get0_key :: Ptr RSA -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO ()++foreign import capi unsafe "openssl/rsa.h RSA_get0_factors"+ _get0_factors :: Ptr RSA -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO ()++foreign import capi unsafe "openssl/rsa.h RSA_get0_crt_params"+ _get0_crt_params :: Ptr RSA -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO ()++withNED :: (Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO b)+ -> Ptr RSA -> IO b+withNED f rsa = alloca $ \ n -> alloca $ \ e -> alloca $ \ d -> do+ poke n nullPtr+ poke e nullPtr+ poke d nullPtr+ _get0_key rsa n e d+ f n e d++rsa_n = withNED $ \ n _ _ -> peek n+rsa_e = withNED $ \ _ e _ -> peek e+rsa_d = withNED $ \ _ _ d -> peek d++withFactors+ :: (Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO a) -> Ptr RSA -> IO a+withFactors f rsa = alloca $ \ p -> alloca $ \ q -> do+ poke p nullPtr+ poke q nullPtr+ _get0_factors rsa p q+ f p q++rsa_p = withFactors $ \ p _ -> peek p+rsa_q = withFactors $ \ _ q -> peek q++withCrtParams+ :: (Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO b)+ -> Ptr RSA -> IO b+withCrtParams f rsa = alloca $ \ dmp1 -> alloca $ \ dmq1 -> alloca $ \ iqmp -> do+ poke dmp1 nullPtr+ poke dmq1 nullPtr+ poke iqmp nullPtr+ _get0_crt_params rsa dmp1 dmq1 iqmp+ f dmp1 dmq1 iqmp++rsa_dmp1 = withCrtParams $ \ dmp1 _ _ -> peek dmp1+rsa_dmq1 = withCrtParams $ \ _ dmq1 _ -> peek dmq1+rsa_iqmp = withCrtParams $ \ _ _ iqmp -> peek iqmp++#else++rsa_n = (#peek RSA, n)+rsa_e = (#peek RSA, e)+rsa_d = (#peek RSA, d)+rsa_p = (#peek RSA, p)+rsa_q = (#peek RSA, q)+rsa_dmp1 = (#peek RSA, dmp1)+rsa_dmq1 = (#peek RSA, dmq1)+rsa_iqmp = (#peek RSA, iqmp)++#endif+ peekI :: RSAKey a => (Ptr RSA -> IO (Ptr BIGNUM)) -> a -> Integer peekI peeker rsa = unsafePerformIO $@@ -208,28 +284,27 @@ -- |@'rsaD' privKey@ returns the private exponent of the key. rsaD :: RSAKeyPair -> Integer-rsaD = peekI (#peek RSA, d)+rsaD = peekI rsa_d -- |@'rsaP' privkey@ returns the secret prime factor @p@ of the key. rsaP :: RSAKeyPair -> Integer-rsaP = peekI (#peek RSA, p)+rsaP = peekI rsa_p -- |@'rsaQ' privkey@ returns the secret prime factor @q@ of the key. rsaQ :: RSAKeyPair -> Integer-rsaQ = peekI (#peek RSA, q)+rsaQ = peekI rsa_q -- |@'rsaDMP1' privkey@ returns @d mod (p-1)@ of the key. rsaDMP1 :: RSAKeyPair -> Maybe Integer-rsaDMP1 = peekMI (#peek RSA, dmp1)+rsaDMP1 = peekMI rsa_dmp1 -- |@'rsaDMQ1' privkey@ returns @d mod (q-1)@ of the key. rsaDMQ1 :: RSAKeyPair -> Maybe Integer-rsaDMQ1 = peekMI (#peek RSA, dmq1)+rsaDMQ1 = peekMI rsa_dmq1 -- |@'rsaIQMP' privkey@ returns @q^-1 mod p@ of the key. rsaIQMP :: RSAKeyPair -> Maybe Integer-rsaIQMP = peekMI (#peek RSA, iqmp)-+rsaIQMP = peekMI rsa_iqmp {- instances ---------------------------------------------------------------- -} @@ -274,7 +349,7 @@ , "rsaN = ", show (rsaN a), ", " , "rsaE = ", show (rsaE a) , "}"- ] + ] instance Show RSAKeyPair where show a@@ -285,4 +360,4 @@ , "rsaP = ", show (rsaP a), ", " , "rsaQ = ", show (rsaQ a) , "}"- ] + ]
+ OpenSSL/Random.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+-- | PRNG services+-- See <http://www.openssl.org/docs/crypto/rand.html>+-- For random Integer generation, see "OpenSSL.BN"+module OpenSSL.Random+ ( -- * Random byte generation+ randBytes+ , prandBytes+ , add+ ) where+import Foreign+import Foreign.C.Types+import qualified Data.ByteString as BS+import OpenSSL.Utils++foreign import capi unsafe "openssl/rand.h RAND_bytes"+ _RAND_bytes :: Ptr CChar -> CInt -> IO CInt++foreign import capi unsafe "openssl/rand.h RAND_pseudo_bytes"+ _RAND_pseudo_bytes :: Ptr CChar -> CInt -> IO ()++foreign import capi unsafe "openssl/rand.h RAND_add"+ _RAND_add :: Ptr CChar -> CInt -> CInt -> IO ()++-- | Return a bytestring consisting of the given number of strongly random+-- bytes+randBytes :: Int -- ^ the number of bytes requested+ -> IO BS.ByteString+randBytes n =+ allocaArray n $ \bufPtr ->+ do _RAND_bytes bufPtr (fromIntegral n) >>= failIf_ (/= 1)+ BS.packCStringLen (bufPtr, n)++-- | Return a bytestring consisting of the given number of pseudo random+-- bytes+prandBytes :: Int -- ^ the number of bytes requested+ -> IO BS.ByteString+prandBytes n =+ allocaArray n $ \bufPtr ->+ do _RAND_pseudo_bytes bufPtr (fromIntegral n)+ BS.packCStringLen (bufPtr, n)++-- | Add data to the entropy pool. It's safe to add sensitive information+-- (e.g. user passwords etc) to the pool. Also, adding data with an entropy+-- of 0 can never hurt.+add :: BS.ByteString -- ^ random data to be added to the pool+ -> Int -- ^ the number of bits of entropy in the first argument+ -> IO ()+add bs entropy =+ BS.useAsCStringLen bs $ \(ptr, len) ->+ _RAND_add ptr (fromIntegral len) (fromIntegral entropy)
− OpenSSL/Random.hsc
@@ -1,56 +0,0 @@-{- -*- haskell -*- -}---- | PRNG services--- See <http://www.openssl.org/docs/crypto/rand.html>--- For random Integer generation, see "OpenSSL.BN"--#include "HsOpenSSL.h"--module OpenSSL.Random- ( -- * Random byte generation- randBytes- , prandBytes- , add- ) where--import Foreign-import Foreign.C.Types-import qualified Data.ByteString as BS-import OpenSSL.Utils--foreign import ccall unsafe "RAND_bytes"- _RAND_bytes :: Ptr CChar -> CInt -> IO CInt--foreign import ccall unsafe "RAND_pseudo_bytes"- _RAND_pseudo_bytes :: Ptr CChar -> CInt -> IO ()--foreign import ccall unsafe "RAND_add"- _RAND_add :: Ptr CChar -> CInt -> CInt -> IO ()---- | Return a bytestring consisting of the given number of strongly random--- bytes-randBytes :: Int -- ^ the number of bytes requested- -> IO BS.ByteString-randBytes n =- allocaArray n $ \bufPtr ->- do _RAND_bytes bufPtr (fromIntegral n) >>= failIf_ (/= 1)- BS.packCStringLen (bufPtr, n)---- | Return a bytestring consisting of the given number of pseudo random--- bytes-prandBytes :: Int -- ^ the number of bytes requested- -> IO BS.ByteString-prandBytes n =- allocaArray n $ \bufPtr ->- do _RAND_pseudo_bytes bufPtr (fromIntegral n)- BS.packCStringLen (bufPtr, n)---- | Add data to the entropy pool. It's safe to add sensitive information--- (e.g. user passwords etc) to the pool. Also, adding data with an entropy--- of 0 can never hurt.-add :: BS.ByteString -- ^ random data to be added to the pool- -> Int -- ^ the number of bits of entropy in the first argument- -> IO ()-add bs entropy =- BS.useAsCStringLen bs $ \(ptr, len) ->- _RAND_add ptr (fromIntegral len) (fromIntegral entropy)
− OpenSSL/SSL.hsc
@@ -1,15 +0,0 @@-module OpenSSL.SSL- ( loadErrorStrings- , addAllAlgorithms- , libraryInit- )- where--foreign import ccall unsafe "SSL_load_error_strings"- loadErrorStrings :: IO ()--foreign import ccall unsafe "HsOpenSSL_OpenSSL_add_all_algorithms"- addAllAlgorithms :: IO ()--foreign import ccall unsafe "SSL_library_init"- libraryInit :: IO ()
+ OpenSSL/SSL/Option.hsc view
@@ -0,0 +1,265 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | See https://www.openssl.org/docs/ssl/SSL_CTX_set_options.html+module OpenSSL.SSL.Option+ ( SSLOption(..)+ , optionToIntegral+ )+ where+import Data.Typeable++#include <openssl/ssl.h>++-- | The behaviour of the SSL library can be changed by setting+-- several options. During a handshake, the option settings of the+-- 'OpenSSL.Session.SSL' object are used. When a new+-- 'OpenSSL.Session.SSL' object is created from a+-- 'OpenSSL.Session.SSLContext', the current option setting is+-- copied. Changes to 'OpenSSL.Session.SSLContext' do not affect+-- already created 'OpenSSL.Session.SSL' objects.+data SSLOption+ = -- | As of OpenSSL 1.0.0 this option has no effect.+ SSL_OP_MICROSOFT_SESS_ID_BUG+ -- | As of OpenSSL 1.0.0 this option has no effect.+ | SSL_OP_NETSCAPE_CHALLENGE_BUG+ -- | As of OpenSSL 0.9.8q and 1.0.0c, this option has no effect.+ | SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG+ -- | As of OpenSSL 1.0.1h and 1.0.2, this option has no effect.+ | SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG+ -- | As of OpenSSL 1.1.0 this option has no effect.+ | SSL_OP_MICROSOFT_BIG_SSLV3_BUFFER+#if defined(SSL_OP_SAFARI_ECDHE_ECDSA_BUG)+ -- | Don't prefer ECDHE-ECDSA ciphers when the client appears to+ -- be Safari on OS X. OS X 10.8..10.8.3 has broken support for+ -- ECDHE-ECDSA ciphers.+ | SSL_OP_SAFARI_ECDHE_ECDSA_BUG+#endif+ -- | As of OpenSSL 1.1.0 this option has no effect.+ | SSL_OP_SSLEAY_080_CLIENT_DH_BUG+ -- | As of OpenSSL 1.1.0 this option has no effect.+ | SSL_OP_TLS_D5_BUG+ -- | As of OpenSSL 1.1.0 this option has no effect.+ | SSL_OP_TLS_BLOCK_PADDING_BUG+#if defined(SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS)+ -- | Disables a countermeasure against a SSL 3.0/TLS 1.0+ -- protocol vulnerability affecting CBC ciphers, which cannot be+ -- handled by some broken SSL implementations. This option has+ -- no effect for connections using other ciphers.+ | SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS+#endif+#if defined(SSL_OP_TLSEXT_PADDING)+ -- | Adds a padding extension to ensure the ClientHello size is+ -- never between 256 and 511 bytes in length. This is needed as+ -- a workaround for some implementations.+ | SSL_OP_TLSEXT_PADDING+#endif+ -- | Default set of options+ | SSL_OP_ALL+#if defined(SSL_OP_TLS_ROLLBACK_BUG)+ -- | Disable version rollback attack detection.+ --+ -- During the client key exchange, the client must send the same+ -- information about acceptable SSL/TLS protocol levels as+ -- during the first hello. Some clients violate this rule by+ -- adapting to the server's answer. (Example: the client sends a+ -- SSLv2 hello and accepts up to SSLv3.1=TLSv1, the server only+ -- understands up to SSLv3. In this case the client must still+ -- use the same SSLv3.1=TLSv1 announcement. Some clients step+ -- down to SSLv3 with respect to the server's answer and violate+ -- the version rollback protection.)+ | SSL_OP_TLS_ROLLBACK_BUG+#endif+ -- | As of OpenSSL 1.1.0 this option has no effect.+ | SSL_OP_SINGLE_DH_USE+ -- | As of OpenSSL 1.0.1k and 1.0.2, this option has no effect.+ | SSL_OP_EPHEMERAL_RSA+#if defined(SSL_OP_CIPHER_SERVER_PREFERENCE)+ -- | When choosing a cipher, use the server's preferences+ -- instead of the client preferences. When not set, the SSL+ -- server will always follow the clients preferences. When set,+ -- the SSLv3/TLSv1 server will choose following its own+ -- preferences. Because of the different protocol, for SSLv2 the+ -- server will send its list of preferences to the client and+ -- the client chooses.+ | SSL_OP_CIPHER_SERVER_PREFERENCE+#endif+ -- | As of OpenSSL 1.0.1 this option has no effect.+ | SSL_OP_PKCS1_CHECK_1+ -- | As of OpenSSL 1.0.1 this option has no effect.+ | SSL_OP_PKCS1_CHECK_2+ -- | As of OpenSSL 1.1.0 this option has no effect.+ | SSL_OP_NETSCAPE_CA_DN_BUG+ -- | As of OpenSSL 1.1.0 this option has no effect.+ | SSL_OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG+ -- | As of OpenSSL 1.1.0 this option has no effect.+ | SSL_OP_NO_SSLv2+ -- | Do not use the SSLv3 protocol.+ -- As of OpenSSL 1.1.0, this option is deprecated+ | SSL_OP_NO_SSLv3+ -- | Do not use the TLSv1 protocol.+ -- As of OpenSSL 1.1.0, this option is deprecated+ | SSL_OP_NO_TLSv1+ -- | Do not use the TLSv1.1 protocol.+ -- As of OpenSSL 1.1.0, this option is deprecated+ | SSL_OP_NO_TLSv1_1+ -- | Do not use the TLSv1.2 protocol.+ -- As of OpenSSL 1.1.0, this option is deprecated+ | SSL_OP_NO_TLSv1_2+ -- | Do not use the TLSv1.3 protocol.+ -- As of OpenSSL 1.1.0, this option is deprecated+ | SSL_OP_NO_TLSv1_3+ -- | Do not use the DTLSv1 protocol.+ -- As of OpenSSL 1.1.0, this option is deprecated+ | SSL_OP_NO_DTLSv1+ -- | Do not use the DTLSv1.2 protocol.+ -- As of OpenSSL 1.1.0, this option is deprecated+ | SSL_OP_NO_DTLSv1_2+#if defined(SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION)+ -- | When performing renegotiation as a server, always start a+ -- new session (i.e., session resumption requests are only+ -- accepted in the initial handshake). This option is not needed+ -- for clients.+ | SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION+#endif+ -- | Normally clients and servers will, where possible,+ -- transparently make use of+ -- <http://tools.ietf.org/html/rfc4507 RFC 4507> tickets for+ -- stateless session resumption.+ --+ -- If this option is set this functionality is disabled and+ -- tickets will not be used by clients or servers.+ | SSL_OP_NO_TICKET+#if defined(SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION)+ -- | Allow legacy insecure renegotiation between OpenSSL and+ -- unpatched clients or servers. See+ -- <https://www.openssl.org/docs/ssl/SSL_CTX_set_options.html#secure_renegotiation SECURE RENEGOTIATION>+ -- for more details.+ | SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION+#endif+#if defined(SSL_OP_LEGACY_SERVER_CONNECT)+ -- | Allow legacy insecure renegotiation between OpenSSL and+ -- unpatched servers _only_. See+ -- <https://www.openssl.org/docs/ssl/SSL_CTX_set_options.html#secure_renegotiation SECURE RENEGOTIATION>+ -- for more details.+ | SSL_OP_LEGACY_SERVER_CONNECT+#endif+#if defined(SSL_OP_NO_EXTENDED_MASTER_SECRET)+ -- | Disable Extended master secret.+ -- Only available on OpenSSL 3.0.0 and later.+ | SSL_OP_NO_EXTENDED_MASTER_SECRET+#endif+#if defined(SSL_OP_CLEANSE_PLAINTEXT)+ -- | Cleanse plaintext copies of data.+ -- Only available on OpenSSL 3.0.0 and later.+ | SSL_OP_CLEANSE_PLAINTEXT+#endif+#if defined(SSL_OP_ENABLE_KTLS)+ -- | Enble support for Kernel TLS+ -- Only available on OpenSSL 3.0.0 and later+ | SSL_OP_ENABLE_KTLS+#endif+#if defined(SSL_OP_IGNORE_UNEXPECTED_EOF)+ | SSL_OP_IGNORE_UNEXPECTED_EOF+#endif+#if defined(SSL_OP_ALLOW_CLIENT_RENEGOTIATION)+ | SSL_OP_ALLOW_CLIENT_RENEGOTIATION+#endif+#if defined(SSL_OP_DISABLE_TLSEXT_CA_NAMES)+ | SSL_OP_DISABLE_TLSEXT_CA_NAMES+#endif+ | SSL_OP_CISCO_ANYCONNECT+ | SSL_OP_NO_ANTI_REPLAY+ | SSL_OP_PRIORITIZE_CHACHA+ | SSL_OP_ALLOW_NO_DHE_KEX+ | SSL_OP_NO_ENCRYPT_THEN_MAC+ | SSL_OP_NO_QUERY_MTU+ | SSL_OP_COOKIE_EXCHANGE+ | SSL_OP_NO_COMPRESSION+ | SSL_OP_ENABLE_MIDDLEBOX_COMPAT+ | SSL_OP_NO_RENEGOTIATION+ | SSL_OP_CRYPTOPRO_TLSEXT_BUG+ deriving (Eq, Ord, Show, Typeable)++optionToIntegral :: Integral a => SSLOption -> a+optionToIntegral SSL_OP_MICROSOFT_SESS_ID_BUG = #const SSL_OP_MICROSOFT_SESS_ID_BUG+optionToIntegral SSL_OP_NETSCAPE_CHALLENGE_BUG = #const SSL_OP_NETSCAPE_CHALLENGE_BUG+optionToIntegral SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG = #const SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG+optionToIntegral SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG = #const SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG+optionToIntegral SSL_OP_MICROSOFT_BIG_SSLV3_BUFFER = #const SSL_OP_MICROSOFT_BIG_SSLV3_BUFFER+#if defined(SSL_OP_SAFARI_ECDHE_ECDSA_BUG)+optionToIntegral SSL_OP_SAFARI_ECDHE_ECDSA_BUG = #const SSL_OP_SAFARI_ECDHE_ECDSA_BUG+#endif+optionToIntegral SSL_OP_SSLEAY_080_CLIENT_DH_BUG = #const SSL_OP_SSLEAY_080_CLIENT_DH_BUG+optionToIntegral SSL_OP_TLS_D5_BUG = #const SSL_OP_TLS_D5_BUG+optionToIntegral SSL_OP_TLS_BLOCK_PADDING_BUG = #const SSL_OP_TLS_BLOCK_PADDING_BUG+#if defined(SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS)+optionToIntegral SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS = #const SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS+#endif+#if defined(SSL_OP_TLSEXT_PADDING)+optionToIntegral SSL_OP_TLSEXT_PADDING = #const SSL_OP_TLSEXT_PADDING+#endif+optionToIntegral SSL_OP_ALL = #const SSL_OP_ALL+#if defined(SSL_OP_TLS_ROLLBACK_BUG)+optionToIntegral SSL_OP_TLS_ROLLBACK_BUG = #const SSL_OP_TLS_ROLLBACK_BUG+#endif+optionToIntegral SSL_OP_SINGLE_DH_USE = #const SSL_OP_SINGLE_DH_USE+optionToIntegral SSL_OP_EPHEMERAL_RSA = #const SSL_OP_EPHEMERAL_RSA+#if defined(SSL_OP_CIPHER_SERVER_PREFERENCE)+optionToIntegral SSL_OP_CIPHER_SERVER_PREFERENCE = #const SSL_OP_CIPHER_SERVER_PREFERENCE+#endif+optionToIntegral SSL_OP_PKCS1_CHECK_1 = #const SSL_OP_PKCS1_CHECK_1+optionToIntegral SSL_OP_PKCS1_CHECK_2 = #const SSL_OP_PKCS1_CHECK_2+optionToIntegral SSL_OP_NETSCAPE_CA_DN_BUG = #const SSL_OP_NETSCAPE_CA_DN_BUG+optionToIntegral SSL_OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG = #const SSL_OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG+optionToIntegral SSL_OP_NO_SSLv2 = #const SSL_OP_NO_SSLv2+optionToIntegral SSL_OP_NO_SSLv3 = #const SSL_OP_NO_SSLv3+optionToIntegral SSL_OP_NO_TLSv1 = #const SSL_OP_NO_TLSv1+optionToIntegral SSL_OP_NO_TLSv1_1 = #const SSL_OP_NO_TLSv1_1+optionToIntegral SSL_OP_NO_TLSv1_2 = #const SSL_OP_NO_TLSv1_2+#if defined(SSL_OP_NO_TLSv1_3)+optionToIntegral SSL_OP_NO_TLSv1_3 = #const SSL_OP_NO_TLSv1_3+#endif+#if defined(SSL_OP_NO_DTLSv1)+optionToIntegral SSL_OP_NO_DTLSv1 = #const SSL_OP_NO_DTLSv1+#endif+#if defined(SSL_OP_NO_DTLSv1_2)+optionToIntegral SSL_OP_NO_DTLSv1_2 = #const SSL_OP_NO_DTLSv1_2+#endif+#if defined(SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION)+optionToIntegral SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION = #const SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION+#endif+optionToIntegral SSL_OP_NO_TICKET = #const SSL_OP_NO_TICKET+#if defined(SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION)+optionToIntegral SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION = #const SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION+#endif+#if defined(SSL_OP_LEGACY_SERVER_CONNECT)+optionToIntegral SSL_OP_LEGACY_SERVER_CONNECT = #const SSL_OP_LEGACY_SERVER_CONNECT+#endif+#if defined(SSL_OP_NO_EXTENDED_MASTER_SECRET)+optionToIntegral SSL_OP_NO_EXTENDED_MASTER_SECRET = #const SSL_OP_NO_EXTENDED_MASTER_SECRET+#endif+#if defined(SSL_OP_CLEANSE_PLAINTEXT)+optionToIntegral SSL_OP_CLEANSE_PLAINTEXT = #const SSL_OP_CLEANSE_PLAINTEXT+#endif+#if defined(SSL_OP_ENABLE_KTLS)+optionToIntegral SSL_OP_ENABLE_KTLS = #const SSL_OP_ENABLE_KTLS+#endif+#if defined(SSL_OP_IGNORE_UNEXPECTED_EOF)+optionToIntegral SSL_OP_IGNORE_UNEXPECTED_EOF = #const SSL_OP_IGNORE_UNEXPECTED_EOF+#endif+#if defined(SSL_OP_ALLOW_CLIENT_RENEGOTIATION)+optionToIntegral SSL_OP_ALLOW_CLIENT_RENEGOTIATION = #const SSL_OP_ALLOW_CLIENT_RENEGOTIATION+#endif+#if defined(SSL_OP_DISABLE_TLSEXT_CA_NAMES)+optionToIntegral SSL_OP_DISABLE_TLSEXT_CA_NAMES = #const SSL_OP_DISABLE_TLSEXT_CA_NAMES+#endif+optionToIntegral SSL_OP_NO_ANTI_REPLAY = #const SSL_OP_NO_ANTI_REPLAY+optionToIntegral SSL_OP_PRIORITIZE_CHACHA = #const SSL_OP_PRIORITIZE_CHACHA+optionToIntegral SSL_OP_ENABLE_MIDDLEBOX_COMPAT = #const SSL_OP_ENABLE_MIDDLEBOX_COMPAT+optionToIntegral SSL_OP_NO_ENCRYPT_THEN_MAC = #const SSL_OP_NO_ENCRYPT_THEN_MAC+optionToIntegral SSL_OP_ALLOW_NO_DHE_KEX = #const SSL_OP_ALLOW_NO_DHE_KEX+optionToIntegral SSL_OP_NO_QUERY_MTU = #const SSL_OP_NO_QUERY_MTU +optionToIntegral SSL_OP_COOKIE_EXCHANGE = #const SSL_OP_COOKIE_EXCHANGE+optionToIntegral SSL_OP_NO_COMPRESSION = #const SSL_OP_NO_COMPRESSION+optionToIntegral SSL_OP_NO_RENEGOTIATION = #const SSL_OP_NO_RENEGOTIATION+optionToIntegral SSL_OP_CRYPTOPRO_TLSEXT_BUG = #const SSL_OP_CRYPTOPRO_TLSEXT_BUG+optionToIntegral SSL_OP_CISCO_ANYCONNECT = #const SSL_OP_CISCO_ANYCONNECT
OpenSSL/Session.hsc view
@@ -1,8 +1,13 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE NamedFieldPuns #-} -- | Functions for handling SSL connections. These functions use GHC specific -- calls to cooperative the with the scheduler so that 'blocking' functions -- only actually block the Haskell thread, not a whole OS thread.@@ -10,6 +15,8 @@ ( -- * Contexts SSLContext , context+ , contextAddOption+ , contextRemoveOption , contextSetPrivateKey , contextSetCertificate , contextSetPrivateKeyFile@@ -20,15 +27,23 @@ , contextCheckPrivateKey , VerificationMode(..) , contextSetVerificationMode+ , contextSetDefaultVerifyPaths , contextSetCAFile , contextSetCADirectory , contextGetCAStore+ , contextSetSessionIdContext+ , contextSetALPNProtos+ , withContextSetKeylogCallback -- * SSL connections , SSL , SSLResult(..) , connection , fdConnection+ , addOption+ , removeOption+ , setTlsextHostName+ , enableHostnameValidation , accept , tryAccept , connect@@ -51,13 +66,23 @@ , sslSocket , sslFd + -- * Protocol Options+ , SSLOption(..)+ -- * SSL Exceptions , SomeSSLException , ConnectionAbruptlyTerminated , ProtocolError(..)++ -- * Direct access to OpenSSL objects+ , SSLContext_+ , withContext+ , SSL_+ , withSSL+ ) where -#include "openssl/ssl.h"+#include "HsOpenSSL.h" import Prelude hiding ( #if !MIN_VERSION_base(4,6,0)@@ -67,11 +92,10 @@ import Control.Concurrent (threadWaitWrite, threadWaitRead, runInBoundThread) import Control.Concurrent.MVar import Control.Exception-import Control.Applicative ((<$>), (<$)) import Control.Monad (unless)+import Data.Foldable (mapM_, forM_)+import Data.Traversable (mapM) import Data.Typeable-import Data.Foldable (Foldable, mapM_, forM_)-import Data.Traversable (Traversable, mapM) import Data.Maybe (fromMaybe) import Data.IORef import Foreign@@ -83,11 +107,22 @@ import qualified Data.ByteString.Lazy.Internal as L import System.IO.Unsafe import System.Posix.Types (Fd(..))-import Network.Socket (Socket(..))+#if MIN_VERSION_network(3,1,0)+import Network.Socket (Socket, withFdSocket)+#else+import Network.Socket (Socket, fdSocket)+#endif +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<$))+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)+#endif+ import OpenSSL.ERR import OpenSSL.EVP.PKey import OpenSSL.EVP.Internal+import OpenSSL.SSL.Option import OpenSSL.Utils import OpenSSL.X509 (X509, X509_, wrapX509, withX509Ptr) import OpenSSL.X509.Store@@ -96,7 +131,7 @@ foreign import ccall "wrapper" mkVerifyCb :: VerifyCb -> IO (FunPtr VerifyCb) -data SSLContext_+data {-# CTYPE "openssl/ssl.h" "SSL_CTX" #-} SSLContext_ -- | An SSL context. Contexts carry configuration such as a server's private -- key, root CA certiifcates etc. Contexts are stateful IO objects; they -- start empty and various options are set on them by the functions in this@@ -107,21 +142,29 @@ } deriving Typeable -data SSLMethod_+data {-# CTYPE "openssl/ssl.h" "const SSL_METHOD" #-} SSLMethod_ -foreign import ccall unsafe "SSL_CTX_new" _ssl_ctx_new :: Ptr SSLMethod_ -> IO (Ptr SSLContext_)-foreign import ccall unsafe "SSL_CTX_free" _ssl_ctx_free :: Ptr SSLContext_ -> IO ()-foreign import ccall unsafe "SSLv23_method" _ssl_method :: IO (Ptr SSLMethod_)+foreign import capi unsafe "openssl/ssl.h SSL_CTX_new" _ssl_ctx_new :: Ptr SSLMethod_ -> IO (Ptr SSLContext_)+foreign import capi unsafe "openssl/ssl.h SSL_CTX_free" _ssl_ctx_free :: Ptr SSLContext_ -> IO ()+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import capi unsafe "openssl/ssl.h TLS_method" _ssl_method :: IO (Ptr SSLMethod_)+#else+foreign import capi unsafe "openssl/ssl.h SSLv23_method" _ssl_method :: IO (Ptr SSLMethod_)+#endif -- | Create a new SSL context. context :: IO SSLContext context = mask_ $ do- ctx <- _ssl_method >>= _ssl_ctx_new+ ctx <- _ssl_method >>= _ssl_ctx_new >>= failIfNull cbRef <- newIORef Nothing mvar <- newMVar ctx- addMVarFinalizer mvar $ do- _ssl_ctx_free ctx- readIORef cbRef >>= mapM_ freeHaskellFunPtr+#if MIN_VERSION_base(4,6,0)+ _ <- mkWeakMVar mvar+#else+ _ <- addMVarFinalizer mvar+#endif+ $ do _ssl_ctx_free ctx+ readIORef cbRef >>= mapM_ freeHaskellFunPtr return $ SSLContext { ctxMVar = mvar, ctxVfCb = cbRef } -- | Run the given action with the raw context pointer and obtain the lock@@ -132,6 +175,24 @@ touchContext :: SSLContext -> IO () touchContext = (>> return ()) . isEmptyMVar . ctxMVar +foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_CTX_set_options"+ _SSL_CTX_set_options :: Ptr SSLContext_ -> CLong -> IO CLong++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_CTX_clear_options"+ _SSL_CTX_clear_options :: Ptr SSLContext_ -> CLong -> IO CLong++-- | Add a protocol option to the context.+contextAddOption :: SSLContext -> SSLOption -> IO ()+contextAddOption ctx opt =+ withContext ctx $ \ctxPtr ->+ _SSL_CTX_set_options ctxPtr (optionToIntegral opt) >> return ()++-- | Remove a protocol option from the context.+contextRemoveOption :: SSLContext -> SSLOption -> IO ()+contextRemoveOption ctx opt =+ withContext ctx $ \ctxPtr ->+ _SSL_CTX_clear_options ctxPtr (optionToIntegral opt) >> return ()+ contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO CInt) -> SSLContext -> String -> IO () contextLoadFile f context path =@@ -141,9 +202,9 @@ unless (result == 1) $ f ctx cpath (#const SSL_FILETYPE_ASN1) >>= failIf_ (/= 1) -foreign import ccall unsafe "SSL_CTX_use_PrivateKey"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_use_PrivateKey" _ssl_ctx_use_privatekey :: Ptr SSLContext_ -> Ptr EVP_PKEY -> IO CInt-foreign import ccall unsafe "SSL_CTX_use_certificate"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_use_certificate" _ssl_ctx_use_certificate :: Ptr SSLContext_ -> Ptr X509_ -> IO CInt -- | Install a private key into a context.@@ -162,9 +223,9 @@ _ssl_ctx_use_certificate ctx certPtr >>= failIf_ (/= 1) -foreign import ccall unsafe "SSL_CTX_use_PrivateKey_file"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_use_PrivateKey_file" _ssl_ctx_use_privatekey_file :: Ptr SSLContext_ -> CString -> CInt -> IO CInt-foreign import ccall unsafe "SSL_CTX_use_certificate_file"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_use_certificate_file" _ssl_ctx_use_certificate_file :: Ptr SSLContext_ -> CString -> CInt -> IO CInt -- | Install a private key file in a context. The key is given as a path to the@@ -179,7 +240,7 @@ contextSetCertificateFile :: SSLContext -> FilePath -> IO () contextSetCertificateFile = contextLoadFile _ssl_ctx_use_certificate_file -foreign import ccall unsafe "SSL_CTX_use_certificate_chain_file"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_use_certificate_chain_file" _ssl_ctx_use_certificate_chain_file :: Ptr SSLContext_ -> CString -> IO CInt -- | Install a certificate chain in a context. The certificates must be in PEM@@ -192,12 +253,12 @@ withCString path $ \cpath -> _ssl_ctx_use_certificate_chain_file ctx cpath >>= failIf_ (/= 1) -foreign import ccall unsafe "SSL_CTX_set_cipher_list"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_set_cipher_list" _ssl_ctx_set_cipher_list :: Ptr SSLContext_ -> CString -> IO CInt -- | Set the ciphers to be used by the given context. The string argument is a -- list of ciphers, comma separated, as given at--- http://www.openssl.org/docs/apps/ciphers.html+-- <https://www.openssl.org/docs/manmaster/man1/openssl-ciphers.html>. -- -- Unrecognised ciphers are ignored. If no ciphers from the list are -- recognised, an exception is raised.@@ -207,10 +268,11 @@ withCString list $ \cpath -> _ssl_ctx_set_cipher_list ctx cpath >>= failIf_ (/= 1) +-- | Set the ciphers to "DEFAULT". contextSetDefaultCiphers :: SSLContext -> IO () contextSetDefaultCiphers = flip contextSetCiphers "DEFAULT" -foreign import ccall unsafe "SSL_CTX_check_private_key"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_check_private_key" _ssl_ctx_check_private_key :: Ptr SSLContext_ -> IO CInt -- | Return true iff the private key installed in the given context matches the@@ -229,7 +291,7 @@ } deriving Typeable -foreign import ccall unsafe "SSL_CTX_set_verify"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_set_verify" _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> FunPtr VerifyCb -> IO () contextSetVerificationMode :: SSLContext -> VerificationMode -> IO ()@@ -251,7 +313,28 @@ _ssl_set_verify_mode ctx mode $ fromMaybe nullFunPtr newCb return () -foreign import ccall unsafe "SSL_CTX_load_verify_locations"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_set_default_verify_paths"+ _ssl_set_default_verify_paths :: Ptr SSLContext_ -> IO CInt++-- | Specifies that the default locations from which CA certificates are loaded+-- should be used. There is one default directory and one default file.+--+-- The default CA certificates directory is called "certs" in the default OpenSSL+-- directory. Alternatively the SSL_CERT_DIR environment variable can be defined+-- to override this location.+--+-- The default CA certificates file is called "cert.pem" in the default OpenSSL+-- directory. Alternatively the SSL_CERT_FILE environment+-- variable can be defined to override this location.+--+-- See <https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_default_verify_paths.html> for+-- more information.+contextSetDefaultVerifyPaths :: SSLContext -> IO ()+contextSetDefaultVerifyPaths context =+ withContext context $ \ctx ->+ _ssl_set_default_verify_paths ctx >>= failIf_ (/= 1)++foreign import capi unsafe "openssl/ssl.h SSL_CTX_load_verify_locations" _ssl_load_verify_locations :: Ptr SSLContext_ -> Ptr CChar -> Ptr CChar -> IO CInt -- | Set the location of a PEM encoded list of CA certificates to be used when@@ -272,7 +355,7 @@ withCString path $ \cpath -> _ssl_load_verify_locations ctx nullPtr cpath >>= failIf_ (/= 1) -foreign import ccall unsafe "SSL_CTX_get_cert_store"+foreign import capi unsafe "openssl/ssl.h SSL_CTX_get_cert_store" _ssl_get_cert_store :: Ptr SSLContext_ -> IO (Ptr X509_STORE) -- | Get a reference to, not a copy of, the X.509 certificate storage@@ -283,8 +366,56 @@ _ssl_get_cert_store ctx >>= wrapX509Store (touchContext context) +foreign import capi unsafe "openssl/ssl.h SSL_CTX_set_session_id_context"+ _ssl_set_session_id_context :: Ptr SSLContext_ -> Ptr CChar -> CUInt -> IO CInt -data SSL_+-- | Set context within which session can be reused (server side only).+--+-- If client certificates are used and the session id context is not set,+-- attempts by the clients to reuse a session will make the handshake fail.+contextSetSessionIdContext :: SSLContext -> B.ByteString -> IO ()+contextSetSessionIdContext context idCtx =+ withContext context $ \ctx ->+ B.unsafeUseAsCStringLen idCtx $ \(cIdCtx, len) ->+ _ssl_set_session_id_context ctx cIdCtx (fromIntegral len) >>= failIf_ (/= 1)++foreign import capi unsafe "openssl/ssl.h SSL_CTX_set_alpn_protos"+ _ssl_set_alpn_protos :: Ptr SSLContext_ -> Ptr CChar -> CUInt -> IO CInt++contextSetALPNProtos :: SSLContext -> [B.ByteString] -> IO ()+contextSetALPNProtos context protos =+ withContext context $ \ctx -> do+ -- Protos need to be wire-format as documented here:+ -- https://www.openssl.org/docs/man1.0.2/man3/SSL_CTX_set_alpn_protos.html#NOTES+ let formattedProtos = B.concat $ map (\p -> B.cons (fromIntegral (B.length p)) p) protos+ B.unsafeUseAsCStringLen formattedProtos $ \(cFormattedProtos, len) ->+ -- This function breaks the convention of returning '1' for success:+ -- https://www.openssl.org/docs/man1.0.2/man3/SSL_CTX_set_alpn_protos.html#RETURN-VALUES+ _ssl_set_alpn_protos ctx cFormattedProtos (fromIntegral len) >>= failIf_ (/= 0)++type KeylogCb = Ptr SSL_ -> CString -> IO ()++foreign import ccall "wrapper" mkKeylogCb :: KeylogCb -> IO (FunPtr KeylogCb)++foreign import capi "openssl/ssl.h SSL_CTX_set_keylog_callback" _ssl_ctx_set_keylog_callback :: Ptr SSLContext_ -> FunPtr KeylogCb -> IO ()++-- | The key logging callback is called with a String "line". The line is a+-- string containing the key material in the format used by NSS for its+-- SSLKEYLOGFILE debugging output. To recreate that file, the key logging+-- callback should log line, followed by a newline.+--+-- FIXME: Not re-entrant (ignores previous callback and resets it to+-- nullFunPtr on exit)+withContextSetKeylogCallback :: SSLContext -> (String -> IO ()) -> IO a -> IO a+withContextSetKeylogCallback context cb action = do+ -- There doesn't seem to be a way to go from 'Ptr SSL_' to 'SSL', so let's+ -- just ignore it in the haskell callback.+ bracket+ (mkKeylogCb $ \_ssl line -> (cb =<< peekCString line))+ (\cbPtr -> withContext context (flip _ssl_ctx_set_keylog_callback nullFunPtr) >> freeHaskellFunPtr cbPtr)+ (\cbPtr -> withContext context (flip _ssl_ctx_set_keylog_callback cbPtr) >> action)++data {-# CTYPE "openssl/ssl.h" "SSL" #-} SSL_ -- | This is the type of an SSL connection -- -- IO with SSL objects is non-blocking and many SSL functions return a error@@ -300,9 +431,9 @@ } deriving Typeable -foreign import ccall unsafe "SSL_new" _ssl_new :: Ptr SSLContext_ -> IO (Ptr SSL_)-foreign import ccall unsafe "SSL_free" _ssl_free :: Ptr SSL_ -> IO ()-foreign import ccall unsafe "SSL_set_fd" _ssl_set_fd :: Ptr SSL_ -> CInt -> IO ()+foreign import capi unsafe "openssl/ssl.h SSL_new" _ssl_new :: Ptr SSLContext_ -> IO (Ptr SSL_)+foreign import capi unsafe "openssl/ssl.h SSL_free" _ssl_free :: Ptr SSL_ -> IO ()+foreign import capi unsafe "openssl/ssl.h SSL_set_fd" _ssl_set_fd :: Ptr SSL_ -> CInt -> IO () connection' :: SSLContext -> Fd -> Maybe Socket -> IO SSL connection' context fd@(Fd fdInt) sock = do@@ -312,7 +443,11 @@ _ssl_set_fd ssl fdInt return ssl mvar <- newMVar ssl- addMVarFinalizer mvar $ _ssl_free ssl+#if MIN_VERSION_base(4,6,0)+ _ <- mkWeakMVar mvar $ _ssl_free ssl+#else+ _ <- addMVarFinalizer mvar $ _ssl_free ssl+#endif return mvar return $ SSL { sslCtx = context , sslMVar = mvar@@ -325,30 +460,121 @@ -- carries a handle to the Socket so you need not worry about the garbage -- collector closing the file descriptor out from under you. connection :: SSLContext -> Socket -> IO SSL-connection context sock@(MkSocket fd _ _ _ _) =+connection context sock = do+#if MIN_VERSION_network(3,1,0)+ withFdSocket sock $ \ fd -> connection' context (Fd fd) (Just sock)+#else+#if MIN_VERSION_network(3,0,0)+ fd <- fdSocket sock+#else+ let fd = fdSocket sock+#endif connection' context (Fd fd) (Just sock)+#endif -- | Wrap a socket Fd in an SSL connection. fdConnection :: SSLContext -> Fd -> IO SSL fdConnection context fd = connection' context fd Nothing +-- | Run continuation with exclusive access to the underlying SSL object. withSSL :: SSL -> (Ptr SSL_ -> IO a) -> IO a withSSL = withMVar . sslMVar -foreign import ccall "SSL_accept" _ssl_accept :: Ptr SSL_ -> IO CInt-foreign import ccall "SSL_connect" _ssl_connect :: Ptr SSL_ -> IO CInt-foreign import ccall unsafe "SSL_get_error" _ssl_get_error :: Ptr SSL_ -> CInt -> IO CInt+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_set_options"+ _SSL_set_options :: Ptr SSL_ -> CLong -> IO CLong -throwSSLException :: String -> CInt -> IO a-throwSSLException loc ret+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_clear_options"+ _SSL_clear_options :: Ptr SSL_ -> CLong -> IO CLong++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_set_tlsext_host_name"+ _SSL_set_tlsext_host_name :: Ptr SSL_ -> CString -> IO CLong++-- | Add a protocol option to the SSL connection.+addOption :: SSL -> SSLOption -> IO ()+addOption ssl opt =+ withSSL ssl $ \sslPtr ->+ _SSL_set_options sslPtr (optionToIntegral opt) >> return ()++-- | Remove a protocol option from the SSL connection.+removeOption :: SSL -> SSLOption -> IO ()+removeOption ssl opt =+ withSSL ssl $ \sslPtr ->+ _SSL_clear_options sslPtr (optionToIntegral opt) >> return ()++-- | Set host name for Server Name Indication (SNI)+setTlsextHostName :: SSL -> String -> IO ()+setTlsextHostName ssl h =+ withSSL ssl $ \sslPtr ->+ withCString h $ \ hPtr ->+ _SSL_set_tlsext_host_name sslPtr hPtr >> return ()++-- Hostname validation, inspired by https://wiki.openssl.org/index.php/Hostname_validation++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_enable_hostname_validation"+ _enable_hostname_validation :: Ptr SSL_ -> CString -> CSize -> IO CInt++-- | Enable hostname validation. Also see 'setTlsextHostName'.+--+-- This uses the built-in mechanism introduced in 1.0.2/1.1.0, and will+-- fail otherwise.+enableHostnameValidation :: SSL -> String -> IO ()+enableHostnameValidation ssl host =+ withSSL ssl $ \ssl ->+ withCStringLen host $ \(host, hostLen) ->+ _enable_hostname_validation ssl host (fromIntegral hostLen) >>= failIf_ (/= 1)++foreign import capi "openssl/ssl.h SSL_accept" _ssl_accept :: Ptr SSL_ -> IO CInt+foreign import capi "openssl/ssl.h SSL_connect" _ssl_connect :: Ptr SSL_ -> IO CInt+foreign import capi unsafe "openssl/ssl.h SSL_get_error" _ssl_get_error :: Ptr SSL_ -> CInt -> IO CInt++throwSSLException :: String -> CInt -> CInt -> IO a+throwSSLException loc sslErr ret = do e <- getError if e == 0 then case ret of- 0 -> throwIO ConnectionAbruptlyTerminated- _ -> throwErrno loc+ 0 ->+ throwIO ConnectionAbruptlyTerminated+ -- empty error queue and ret==0 meant EOF in older versions+ -- of OpenSSL+ -- https://github.com/openssl/openssl/commit/beacb0f0c1ae7b0542fe053b95307f515b578eb7+ _ -> do+ errno <- getErrno+ if errno == eOK then+ if sslErr == (#const SSL_ERROR_SYSCALL) then+ -- newer OpenSSL versions have bug:+ -- SSL_ERROR_SYSCALL with errno=0 means unexpected EOF+ -- from the peer+ throwIO ConnectionAbruptlyTerminated+ else+ throwIO $ ProtocolError $ loc ++ ": "+ ++ sslErrorString sslErr+ else+ throwErrno loc else errorString e >>= throwIO . ProtocolError +sslErrorString :: CInt -> String+sslErrorString e = case e of+ (#const SSL_ERROR_NONE) -> "SSL_ERROR_NONE"+ (#const SSL_ERROR_ZERO_RETURN) -> "SSL_ERROR_ZERO_RETURN"+ (#const SSL_ERROR_WANT_READ) -> "SSL_ERROR_WANT_READ"+ (#const SSL_ERROR_WANT_WRITE) -> "SSL_ERROR_WANT_WRITE"+ (#const SSL_ERROR_WANT_CONNECT) -> "SSL_ERROR_WANT_CONNECT"+ (#const SSL_ERROR_WANT_ACCEPT) -> "SSL_ERROR_WANT_ACCEPT"+ (#const SSL_ERROR_WANT_X509_LOOKUP) -> "SSL_ERROR_WANT_X509_LOOKUP"+#if defined(SSL_ERROR_WANT_ASYNC)+ (#const SSL_ERROR_WANT_ASYNC) -> "SSL_ERROR_WANT_ASYNC"+#endif+#if defined(SSL_ERROR_WANT_ASYNC_JOB)+ (#const SSL_ERROR_WANT_ASYNC_JOB) -> "SSL_ERROR_WANT_ASYNC_JOB"+#endif+#if defined(SSL_ERROR_WANT_CLIENT_HELLO_CB)+ (#const SSL_ERROR_WANT_CLIENT_HELLO_CB) -> "SSL_ERROR_WANT_CLIENT_HELLO_CB"+#endif+ (#const SSL_ERROR_SYSCALL) -> "SSL_ERROR_SYSCALL"+ (#const SSL_ERROR_SSL) -> "SSL_ERROR_SSL"+ _ -> "Unknown SSL error: " ++ show e+ -- | This is the type of an SSL IO operation. Errors are handled by -- exceptions while everything else is one of these. Note that reading -- from an SSL socket can result in WantWrite and vice versa.@@ -384,7 +610,7 @@ case err of (#const SSL_ERROR_WANT_READ ) -> return WantRead (#const SSL_ERROR_WANT_WRITE) -> return WantWrite- _ -> throwSSLException loc n+ _ -> throwSSLException loc err n -- | Perform an SSL server handshake accept :: SSL -> IO ()@@ -404,8 +630,8 @@ tryConnect ssl = (() <$) <$> sslTryHandshake "SSL_connect" _ssl_connect ssl -foreign import ccall "SSL_read" _ssl_read :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt-foreign import ccall unsafe "SSL_get_shutdown" _ssl_get_shutdown :: Ptr SSL_ -> IO CInt+foreign import capi "openssl/ssl.h SSL_read" _ssl_read :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt+foreign import capi unsafe "openssl/ssl.h SSL_get_shutdown" _ssl_get_shutdown :: Ptr SSL_ -> IO CInt -- | Perform an SSL operation which operates of a buffer and can return -- non-blocking error codes, thus requesting that it be performed again when@@ -434,16 +660,22 @@ (#const SSL_ERROR_ZERO_RETURN) -> return $ SSLDone $ 0 (#const SSL_ERROR_WANT_READ ) -> return WantRead (#const SSL_ERROR_WANT_WRITE ) -> return WantWrite- _ -> throwSSLException loc n+ _ -> throwSSLException loc err n -- | Try to read the given number of bytes from an SSL connection. On EOF an -- empty ByteString is returned. If the connection dies without a graceful -- SSL shutdown, an exception is raised.+--+-- NOTE: The returned bytestring could be shorter than the size requested, see:+-- https://www.openssl.org/docs/man3.0/man3/SSL_read.html read :: SSL -> Int -> IO B.ByteString read ssl nBytes = sslBlock (`tryRead` nBytes) ssl -- | Try to read the given number of bytes from an SSL connection -- without blocking.+--+-- NOTE: The returned bytestring could be shorter than the size requested, see:+-- https://www.openssl.org/docs/man3.0/man3/SSL_read.html tryRead :: SSL -> Int -> IO (SSLResult B.ByteString) tryRead ssl nBytes = do (bs, result) <- B.createAndTrim' nBytes $ \bufPtr ->@@ -465,7 +697,7 @@ fmap (fmap fromIntegral) (sslIOInner "SSL_read" _ssl_read (castPtr bufPtr) nBytes ssl) -foreign import ccall "SSL_write" _ssl_write :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt+foreign import capi "openssl/ssl.h SSL_write" _ssl_write :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt -- | Write a given ByteString to the SSL connection. Either all the data is -- written or an exception is raised because of an error.@@ -521,7 +753,7 @@ lazyWrite ssl lbs = mapM_ (write ssl) $ L.toChunks lbs -foreign import ccall "SSL_shutdown" _ssl_shutdown :: Ptr SSL_ -> IO CInt+foreign import capi "openssl/ssl.h SSL_shutdown" _ssl_shutdown :: Ptr SSL_ -> IO CInt data ShutdownType = Bidirectional -- ^ wait for the peer to also shutdown | Unidirectional -- ^ only send our shutdown@@ -538,35 +770,53 @@ -- | Try to cleanly shutdown an SSL connection without blocking. tryShutdown :: SSL -> ShutdownType -> IO (SSLResult ())-tryShutdown ssl ty- = runInBoundThread $- withSSL ssl $ \sslPtr ->- do n <- _ssl_shutdown sslPtr- case n of- 1 -> return $ SSLDone ()- 0 -> if ty == Bidirectional then- tryShutdown ssl ty- else- return $ SSLDone ()- _ -> do err <- _ssl_get_error sslPtr n- case err of- (#const SSL_ERROR_WANT_READ ) -> return WantRead- (#const SSL_ERROR_WANT_WRITE) -> return WantWrite- -- SSL_ERROR_SYSCALL/-1 happens when we are- -- trying to send the remote peer a "close- -- notify" alert but the underlying socket was- -- closed at the time. We don't treat this an- -- error /if and only if/ we have already- -- received a "close notify" from the peer.- (#const SSL_ERROR_SYSCALL)- -> do sd <- _ssl_get_shutdown sslPtr- if sd .&. (#const SSL_RECEIVED_SHUTDOWN) == 0 then- throwSSLException "SSL_shutdown" n- else- return $ SSLDone ()- _ -> throwSSLException "SSL_shutdown" n--foreign import ccall "SSL_get_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_)+tryShutdown ssl ty = runInBoundThread $ withSSL ssl loop+ where+ loop :: Ptr SSL_ -> IO (SSLResult ())+ loop sslPtr+ = do n <- _ssl_shutdown sslPtr+ case n of+ 0 | ty == Bidirectional ->+ -- We successfully sent a close notify alert to+ -- the peer but haven't got a reply+ -- yet. Complete the bidirectional shutdown by+ -- calling SSL_shutdown(3) again.+ loop sslPtr+ | otherwise ->+ -- Unidirection shutdown is enough for us.+ return $ SSLDone ()+ 1 ->+ -- Shutdown has succeeded, either bidirectionally+ -- or unidirectionally.+ return $ SSLDone ()+ 2 ->+ -- SSL_shutdown(2) can return 2 according to its+ -- documentation. It says we have to retry+ -- calling SSL_shutdown(3) in this case.+ loop sslPtr+ _ -> do err <- _ssl_get_error sslPtr n+ case err of+ (#const SSL_ERROR_WANT_READ ) -> return WantRead+ (#const SSL_ERROR_WANT_WRITE) -> return WantWrite+ -- SSL_ERROR_SYSCALL/-1 happens when we are+ -- trying to send the remote peer a "close+ -- notify" alert but the underlying socket+ -- was closed at the time. We don't treat+ -- this an error /if and only if/ we have+ -- already received a "close notify" from+ -- the peer.+ (#const SSL_ERROR_SYSCALL)+ -> do sd <- _ssl_get_shutdown sslPtr+ if sd .&. (#const SSL_RECEIVED_SHUTDOWN) == 0 then+ throwSSLException "SSL_shutdown" err n+ else+ return $ SSLDone ()+ _ -> throwSSLException "SSL_shutdown" err n+#if OPENSSL_VERSION_PREREQ(3,0)+foreign import capi "openssl/ssl.h SSL_get1_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_)+#else+foreign import capi "openssl/ssl.h SSL_get_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_)+#endif -- | After a successful connection, get the certificate of the other party. If -- this is a server connection, you probably won't get a certificate unless@@ -579,7 +829,7 @@ then return Nothing else fmap Just (wrapX509 cert) -foreign import ccall "SSL_get_verify_result" _ssl_get_verify_result :: Ptr SSL_ -> IO CLong+foreign import capi "openssl/ssl.h SSL_get_verify_result" _ssl_get_verify_result :: Ptr SSL_ -> IO CLong -- | Get the result of verifing the peer's certificate. This is mostly for -- clients to verify the certificate of the server that they have connected
OpenSSL/Stack.hsc view
@@ -1,3 +1,6 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-} module OpenSSL.Stack ( STACK , mapStack@@ -5,7 +8,7 @@ , withForeignStack ) where-+#include "HsOpenSSL.h" import Control.Exception import Foreign import Foreign.C@@ -14,21 +17,37 @@ data STACK -foreign import ccall unsafe "sk_new_null"+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_new_null" skNewNull :: IO (Ptr STACK) -foreign import ccall unsafe "sk_free"+foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_free" skFree :: Ptr STACK -> IO () -foreign import ccall unsafe "sk_push"+foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_push" skPush :: Ptr STACK -> Ptr () -> IO () -foreign import ccall unsafe "sk_num"+foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_num" skNum :: Ptr STACK -> IO CInt -foreign import ccall unsafe "sk_value"+foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_value" skValue :: Ptr STACK -> CInt -> IO (Ptr ())+#else+foreign import capi unsafe "openssl/safestack.h sk_new_null"+ skNewNull :: IO (Ptr STACK) +foreign import capi unsafe "openssl/safestack.h sk_free"+ skFree :: Ptr STACK -> IO ()++foreign import capi unsafe "openssl/safestack.h sk_push"+ skPush :: Ptr STACK -> Ptr () -> IO ()++foreign import capi unsafe "openssl/safestack.h sk_num"+ skNum :: Ptr STACK -> IO CInt++foreign import capi unsafe "openssl/safestack.h sk_value"+ skValue :: Ptr STACK -> CInt -> IO (Ptr ())+#endif mapStack :: (Ptr a -> IO b) -> Ptr STACK -> IO [b] mapStack m st
OpenSSL/Utils.hs view
@@ -4,11 +4,13 @@ , failIf , failIf_ , raiseOpenSSLError+ , clearErrorStack , toHex , fromHex , peekCStringCLen ) where+import Control.Monad import Foreign.C.String import Foreign.C.Types import Foreign.Ptr@@ -40,6 +42,12 @@ raiseOpenSSLError :: IO a raiseOpenSSLError = getError >>= errorString >>= fail+++clearErrorStack :: IO ()+clearErrorStack = do+ e <- getError+ when (e /= 0) clearErrorStack -- | Convert an integer to a hex string toHex :: (Num i, Bits i) => i -> String
− OpenSSL/X509.hs
@@ -1,382 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK prune #-}---- |An interface to X.509 certificate.--module OpenSSL.X509- ( -- * Type- X509- , X509_-- -- * Functions to manipulate certificate- , newX509- , wrapX509 -- private- , withX509Ptr -- private- , withX509Stack -- private- , unsafeX509ToPtr -- private- , touchX509 -- private-- , compareX509-- , signX509- , verifyX509-- , printX509-- -- * Accessors- , getVersion- , setVersion-- , getSerialNumber- , setSerialNumber-- , getIssuerName- , setIssuerName-- , getSubjectName- , setSubjectName-- , getNotBefore- , setNotBefore-- , getNotAfter- , setNotAfter-- , getPublicKey- , setPublicKey-- , getSubjectEmail- )- where-import Control.Monad-import Data.Time.Clock-import Data.Maybe-import Foreign.ForeignPtr-#if MIN_VERSION_base(4,4,0)-import Foreign.ForeignPtr.Unsafe as Unsafe-#else-import Foreign.ForeignPtr as Unsafe-#endif-import Foreign.Ptr-import Foreign.C-import OpenSSL.ASN1-import OpenSSL.BIO-import OpenSSL.EVP.Digest-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Verify-import OpenSSL.EVP.Internal-import OpenSSL.Utils-import OpenSSL.Stack-import OpenSSL.X509.Name---- |@'X509'@ is an opaque object that represents X.509 certificate.-newtype X509 = X509 (ForeignPtr X509_)-data X509_---foreign import ccall unsafe "X509_new"- _new :: IO (Ptr X509_)--foreign import ccall unsafe "&X509_free"- _free :: FunPtr (Ptr X509_ -> IO ())--foreign import ccall unsafe "X509_print"- _print :: Ptr BIO_ -> Ptr X509_ -> IO CInt--foreign import ccall unsafe "X509_cmp"- _cmp :: Ptr X509_ -> Ptr X509_ -> IO CInt--foreign import ccall unsafe "HsOpenSSL_X509_get_version"- _get_version :: Ptr X509_ -> IO CLong--foreign import ccall unsafe "X509_set_version"- _set_version :: Ptr X509_ -> CLong -> IO CInt--foreign import ccall unsafe "X509_get_serialNumber"- _get_serialNumber :: Ptr X509_ -> IO (Ptr ASN1_INTEGER)--foreign import ccall unsafe "X509_set_serialNumber"- _set_serialNumber :: Ptr X509_ -> Ptr ASN1_INTEGER -> IO CInt--foreign import ccall unsafe "X509_get_issuer_name"- _get_issuer_name :: Ptr X509_ -> IO (Ptr X509_NAME)--foreign import ccall unsafe "X509_set_issuer_name"- _set_issuer_name :: Ptr X509_ -> Ptr X509_NAME -> IO CInt--foreign import ccall unsafe "X509_get_subject_name"- _get_subject_name :: Ptr X509_ -> IO (Ptr X509_NAME)--foreign import ccall unsafe "X509_set_subject_name"- _set_subject_name :: Ptr X509_ -> Ptr X509_NAME -> IO CInt--foreign import ccall unsafe "HsOpenSSL_X509_get_notBefore"- _get_notBefore :: Ptr X509_ -> IO (Ptr ASN1_TIME)--foreign import ccall unsafe "X509_set_notBefore"- _set_notBefore :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt--foreign import ccall unsafe "HsOpenSSL_X509_get_notAfter"- _get_notAfter :: Ptr X509_ -> IO (Ptr ASN1_TIME)--foreign import ccall unsafe "X509_set_notAfter"- _set_notAfter :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt--foreign import ccall unsafe "X509_get_pubkey"- _get_pubkey :: Ptr X509_ -> IO (Ptr EVP_PKEY)--foreign import ccall unsafe "X509_set_pubkey"- _set_pubkey :: Ptr X509_ -> Ptr EVP_PKEY -> IO CInt--foreign import ccall unsafe "X509_get1_email"- _get1_email :: Ptr X509_ -> IO (Ptr STACK)--foreign import ccall unsafe "X509_email_free"- _email_free :: Ptr STACK -> IO ()--foreign import ccall unsafe "X509_sign"- _sign :: Ptr X509_ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt--foreign import ccall unsafe "X509_verify"- _verify :: Ptr X509_ -> Ptr EVP_PKEY -> IO CInt---- |@'newX509'@ creates an empty certificate. You must set the--- following properties to and sign it (see 'signX509') to actually--- use the certificate.------ [/Version/] See 'setVersion'.------ [/Serial number/] See 'setSerialNumber'.------ [/Issuer name/] See 'setIssuerName'.------ [/Subject name/] See 'setSubjectName'.------ [/Validity/] See 'setNotBefore' and 'setNotAfter'.------ [/Public Key/] See 'setPublicKey'.----newX509 :: IO X509-newX509 = _new >>= failIfNull >>= wrapX509---wrapX509 :: Ptr X509_ -> IO X509-wrapX509 = fmap X509 . newForeignPtr _free---withX509Ptr :: X509 -> (Ptr X509_ -> IO a) -> IO a-withX509Ptr (X509 x509) = withForeignPtr x509---withX509Stack :: [X509] -> (Ptr STACK -> IO a) -> IO a-withX509Stack = withForeignStack unsafeX509ToPtr touchX509---unsafeX509ToPtr :: X509 -> Ptr X509_-unsafeX509ToPtr (X509 x509) = Unsafe.unsafeForeignPtrToPtr x509---touchX509 :: X509 -> IO ()-touchX509 (X509 x509) = touchForeignPtr x509---- |@'compareX509' cert1 cert2@ compares two certificates.-compareX509 :: X509 -> X509 -> IO Ordering-compareX509 cert1 cert2- = withX509Ptr cert1 $ \ cert1Ptr ->- withX509Ptr cert2 $ \ cert2Ptr ->- fmap interpret (_cmp cert1Ptr cert2Ptr)- where- interpret :: CInt -> Ordering- interpret n- | n > 0 = GT- | n < 0 = LT- | otherwise = EQ---- |@'signX509'@ signs a certificate with an issuer private key.-signX509 :: KeyPair key =>- X509 -- ^ The certificate to be signed.- -> key -- ^ The private key to sign with.- -> Maybe Digest -- ^ A hashing algorithm to use. If @Nothing@- -- the most suitable algorithm for the key- -- is automatically used.- -> IO ()-signX509 x509 key mDigest- = withX509Ptr x509 $ \ x509Ptr ->- withPKeyPtr' key $ \ pkeyPtr ->- do dig <- case mDigest of- Just md -> return md- Nothing -> pkeyDefaultMD key- withMDPtr dig $ \ digestPtr ->- _sign x509Ptr pkeyPtr digestPtr- >>= failIf_ (== 0)- return ()---- |@'verifyX509'@ verifies a signature of certificate with an issuer--- public key.-verifyX509 :: PublicKey key =>- X509 -- ^ The certificate to be verified.- -> key -- ^ The public key to verify with.- -> IO VerifyStatus-verifyX509 x509 key- = withX509Ptr x509 $ \ x509Ptr ->- withPKeyPtr' key $ \ pkeyPtr ->- _verify x509Ptr pkeyPtr- >>= interpret- where- interpret :: CInt -> IO VerifyStatus- interpret 1 = return VerifySuccess- interpret 0 = return VerifyFailure- interpret _ = raiseOpenSSLError---- |@'printX509' cert@ translates a certificate into human-readable--- format.-printX509 :: X509 -> IO String-printX509 x509- = do mem <- newMem- withX509Ptr x509 $ \ x509Ptr ->- withBioPtr mem $ \ memPtr ->- _print memPtr x509Ptr- >>= failIf_ (/= 1)- bioRead mem---- |@'getVersion' cert@ returns the version number of certificate. It--- seems the number is 0-origin: version 2 means X.509 v3.-getVersion :: X509 -> IO Int-getVersion x509- = withX509Ptr x509 $ \ x509Ptr ->- liftM fromIntegral $ _get_version x509Ptr---- |@'setVersion' cert ver@ updates the version number of certificate.-setVersion :: X509 -> Int -> IO ()-setVersion x509 ver- = withX509Ptr x509 $ \ x509Ptr ->- _set_version x509Ptr (fromIntegral ver)- >>= failIf (/= 1)- >> return ()---- |@'getSerialNumber' cert@ returns the serial number of certificate.-getSerialNumber :: X509 -> IO Integer-getSerialNumber x509- = withX509Ptr x509 $ \ x509Ptr ->- _get_serialNumber x509Ptr- >>= peekASN1Integer---- |@'setSerialNumber' cert num@ updates the serial number of--- certificate.-setSerialNumber :: X509 -> Integer -> IO ()-setSerialNumber x509 serial- = withX509Ptr x509 $ \ x509Ptr ->- withASN1Integer serial $ \ serialPtr ->- _set_serialNumber x509Ptr serialPtr- >>= failIf (/= 1)- >> return ()---- |@'getIssuerName'@ returns the issuer name of certificate.-getIssuerName :: X509 -- ^ The certificate to examine.- -> Bool -- ^ @True@ if you want the keys of each parts- -- to be of long form (e.g. \"commonName\"),- -- or @False@ if you don't (e.g. \"CN\").- -> IO [(String, String)] -- ^ Pairs of key and value,- -- for example \[(\"C\",- -- \"JP\"), (\"ST\",- -- \"Some-State\"), ...\].-getIssuerName x509 wantLongName- = withX509Ptr x509 $ \ x509Ptr ->- do namePtr <- _get_issuer_name x509Ptr- peekX509Name namePtr wantLongName---- |@'setIssuerName' cert name@ updates the issuer name of--- certificate. Keys of each parts may be of either long form or short--- form. See 'getIssuerName'.-setIssuerName :: X509 -> [(String, String)] -> IO ()-setIssuerName x509 issuer- = withX509Ptr x509 $ \ x509Ptr ->- withX509Name issuer $ \ namePtr ->- _set_issuer_name x509Ptr namePtr- >>= failIf (/= 1)- >> return ()---- |@'getSubjectName' cert wantLongName@ returns the subject name of--- certificate. See 'getIssuerName'.-getSubjectName :: X509 -> Bool -> IO [(String, String)]-getSubjectName x509 wantLongName- = withX509Ptr x509 $ \ x509Ptr ->- do namePtr <- _get_subject_name x509Ptr- peekX509Name namePtr wantLongName---- |@'setSubjectName' cert name@ updates the subject name of--- certificate. See 'setIssuerName'.-setSubjectName :: X509 -> [(String, String)] -> IO ()-setSubjectName x509 subject- = withX509Ptr x509 $ \ x509Ptr ->- withX509Name subject $ \ namePtr ->- _set_subject_name x509Ptr namePtr- >>= failIf (/= 1)- >> return ()---- |@'getNotBefore' cert@ returns the time when the certificate begins--- to be valid.-getNotBefore :: X509 -> IO UTCTime-getNotBefore x509- = withX509Ptr x509 $ \ x509Ptr ->- _get_notBefore x509Ptr- >>= peekASN1Time---- |@'setNotBefore' cert utc@ updates the time when the certificate--- begins to be valid.-setNotBefore :: X509 -> UTCTime -> IO ()-setNotBefore x509 utc- = withX509Ptr x509 $ \ x509Ptr ->- withASN1Time utc $ \ time ->- _set_notBefore x509Ptr time- >>= failIf (/= 1)- >> return ()---- |@'getNotAfter' cert@ returns the time when the certificate--- expires.-getNotAfter :: X509 -> IO UTCTime-getNotAfter x509- = withX509Ptr x509 $ \ x509Ptr ->- _get_notAfter x509Ptr- >>= peekASN1Time---- |@'setNotAfter' cert utc@ updates the time when the certificate--- expires.-setNotAfter :: X509 -> UTCTime -> IO ()-setNotAfter x509 utc- = withX509Ptr x509 $ \ x509Ptr ->- withASN1Time utc $ \ time ->- _set_notAfter x509Ptr time- >>= failIf (/= 1)- >> return ()---- |@'getPublicKey' cert@ returns the public key of the subject of--- certificate.-getPublicKey :: X509 -> IO SomePublicKey-getPublicKey x509- = withX509Ptr x509 $ \ x509Ptr ->- fmap fromJust ( _get_pubkey x509Ptr- >>= failIfNull- >>= wrapPKeyPtr- >>= fromPKey- )---- |@'setPublicKey' cert pubkey@ updates the public key of the subject--- of certificate.-setPublicKey :: PublicKey key => X509 -> key -> IO ()-setPublicKey x509 key- = withX509Ptr x509 $ \ x509Ptr ->- withPKeyPtr' key $ \ pkeyPtr ->- _set_pubkey x509Ptr pkeyPtr- >>= failIf (/= 1)- >> return ()---- |@'getSubjectEmail' cert@ returns every subject email addresses in--- the certificate.-getSubjectEmail :: X509 -> IO [String]-getSubjectEmail x509- = withX509Ptr x509 $ \ x509Ptr ->- do st <- _get1_email x509Ptr- list <- mapStack peekCString st- _email_free st- return list
+ OpenSSL/X509.hsc view
@@ -0,0 +1,433 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# OPTIONS_HADDOCK prune #-}+-- |An interface to X.509 certificate.+module OpenSSL.X509+ ( -- * Type+ X509(..)+ , X509_++ -- * Functions to manipulate certificate+ , newX509+ , wrapX509 -- private+ , withX509Ptr -- private+ , withX509Stack -- private+ , unsafeX509ToPtr -- private+ , touchX509 -- private++ , writeDerX509+ , readDerX509+ , compareX509++ , signX509+ , verifyX509++ , printX509++ -- * Accessors+ , getVersion+ , setVersion++ , getSerialNumber+ , setSerialNumber++ , getIssuerName+ , setIssuerName++ , getSubjectName+ , setSubjectName++ , getNotBefore+ , setNotBefore++ , getNotAfter+ , setNotAfter++ , getPublicKey+ , setPublicKey++ , getSubjectEmail+ )+ where+#include "HsOpenSSL.h"+import Control.Monad+import Data.Time.Clock+import Data.Maybe+import Foreign.ForeignPtr+#if MIN_VERSION_base(4,4,0)+import Foreign.ForeignPtr.Unsafe as Unsafe+#else+import Foreign.ForeignPtr as Unsafe+#endif+import Foreign.Ptr+import Foreign.C+import OpenSSL.ASN1+import OpenSSL.BIO+import OpenSSL.EVP.Digest+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Verify+import OpenSSL.EVP.Internal+import OpenSSL.Utils+import OpenSSL.Stack+import OpenSSL.X509.Name+import Data.ByteString.Lazy (ByteString)++-- |@'X509'@ is an opaque object that represents X.509 certificate.+newtype X509 = X509 (ForeignPtr X509_)+data {-# CTYPE "openssl/x509.h" "X509" #-} X509_+++foreign import capi unsafe "openssl/x509.h X509_new"+ _new :: IO (Ptr X509_)++foreign import capi unsafe "openssl/x509.h &X509_free"+ _free :: FunPtr (Ptr X509_ -> IO ())++foreign import capi unsafe "openssl/x509.h X509_print"+ _print :: Ptr BIO_ -> Ptr X509_ -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_cmp"+ _cmp :: Ptr X509_ -> Ptr X509_ -> IO CInt++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_get_version"+ _get_version :: Ptr X509_ -> IO CLong++foreign import capi unsafe "openssl/x509.h X509_set_version"+ _set_version :: Ptr X509_ -> CLong -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_get_serialNumber"+ _get_serialNumber :: Ptr X509_ -> IO (Ptr ASN1_INTEGER)++foreign import capi unsafe "openssl/x509.h X509_set_serialNumber"+ _set_serialNumber :: Ptr X509_ -> Ptr ASN1_INTEGER -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_get_issuer_name"+ _get_issuer_name :: Ptr X509_ -> IO (Ptr X509_NAME)++foreign import capi unsafe "openssl/x509.h X509_set_issuer_name"+ _set_issuer_name :: Ptr X509_ -> Ptr X509_NAME -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_get_subject_name"+ _get_subject_name :: Ptr X509_ -> IO (Ptr X509_NAME)++foreign import capi unsafe "openssl/x509.h X509_set_subject_name"+ _set_subject_name :: Ptr X509_ -> Ptr X509_NAME -> IO CInt++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_get_notBefore"+ _get_notBefore :: Ptr X509_ -> IO (Ptr ASN1_TIME)++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_get_notAfter"+ _get_notAfter :: Ptr X509_ -> IO (Ptr ASN1_TIME)++#if OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import capi unsafe "openssl/x509.h X509_set1_notBefore"+ _set_notBefore :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_set1_notAfter"+ _set_notAfter :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt+#else+foreign import capi unsafe "openssl/x509.h X509_set_notBefore"+ _set_notBefore :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_set_notAfter"+ _set_notAfter :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt+#endif++foreign import capi unsafe "openssl/x509.h X509_get_pubkey"+ _get_pubkey :: Ptr X509_ -> IO (Ptr EVP_PKEY)++foreign import capi unsafe "openssl/x509.h X509_set_pubkey"+ _set_pubkey :: Ptr X509_ -> Ptr EVP_PKEY -> IO CInt++foreign import capi unsafe "openssl/x509v3.h X509_get1_email"+ _get1_email :: Ptr X509_ -> IO (Ptr STACK)++foreign import capi unsafe "openssl/x509v3.h X509_email_free"+ _email_free :: Ptr STACK -> IO ()++foreign import capi unsafe "openssl/x509.h X509_sign"+ _sign :: Ptr X509_ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_verify"+ _verify :: Ptr X509_ -> Ptr EVP_PKEY -> IO CInt++foreign import capi safe "openssl/x509.h i2d_X509_bio"+ _write_bio_X509 :: Ptr BIO_+ -> Ptr X509_+ -> IO CInt++foreign import capi safe "openssl/x509.h d2i_X509_bio"+ _read_bio_X509 :: Ptr BIO_+ -> Ptr (Ptr X509_)+ -> IO (Ptr X509_)++-- |@'newX509'@ creates an empty certificate. You must set the+-- following properties to and sign it (see 'signX509') to actually+-- use the certificate.+--+-- [/Version/] See 'setVersion'.+--+-- [/Serial number/] See 'setSerialNumber'.+--+-- [/Issuer name/] See 'setIssuerName'.+--+-- [/Subject name/] See 'setSubjectName'.+--+-- [/Validity/] See 'setNotBefore' and 'setNotAfter'.+--+-- [/Public Key/] See 'setPublicKey'.+--+newX509 :: IO X509+newX509 = _new >>= failIfNull >>= wrapX509+++wrapX509 :: Ptr X509_ -> IO X509+wrapX509 = fmap X509 . newForeignPtr _free+++withX509Ptr :: X509 -> (Ptr X509_ -> IO a) -> IO a+withX509Ptr (X509 x509) = withForeignPtr x509+++withX509Stack :: [X509] -> (Ptr STACK -> IO a) -> IO a+withX509Stack = withForeignStack unsafeX509ToPtr touchX509+++unsafeX509ToPtr :: X509 -> Ptr X509_+unsafeX509ToPtr (X509 x509) = Unsafe.unsafeForeignPtrToPtr x509+++touchX509 :: X509 -> IO ()+touchX509 (X509 x509) = touchForeignPtr x509++writeX509' :: BIO -> X509 -> IO ()+writeX509' bio x509+ = withBioPtr bio $ \ bioPtr ->+ withX509Ptr x509 $ \ x509Ptr ->+ _write_bio_X509 bioPtr x509Ptr+ >>= failIf (< 0)+ >> return ()++-- |@'writeDerX509' cert@ writes an X.509 certificate to DER string.+writeDerX509 :: X509 -> IO ByteString+writeDerX509 x509+ = do mem <- newMem+ writeX509' mem x509+ bioReadLBS mem++readX509' :: BIO -> IO X509+readX509' bio+ = withBioPtr bio $ \ bioPtr ->+ _read_bio_X509 bioPtr nullPtr+ >>= failIfNull+ >>= wrapX509++-- |@'readDerX509' der@ reads in a certificate.+readDerX509 :: ByteString -> IO X509+readDerX509 derStr+ = newConstMemLBS derStr >>= readX509'++-- |@'compareX509' cert1 cert2@ compares two certificates.+compareX509 :: X509 -> X509 -> IO Ordering+compareX509 cert1 cert2+ = withX509Ptr cert1 $ \ cert1Ptr ->+ withX509Ptr cert2 $ \ cert2Ptr ->+ fmap interpret (_cmp cert1Ptr cert2Ptr)+ where+ interpret :: CInt -> Ordering+ interpret n+ | n > 0 = GT+ | n < 0 = LT+ | otherwise = EQ++-- |@'signX509'@ signs a certificate with an issuer private key.+signX509 :: KeyPair key =>+ X509 -- ^ The certificate to be signed.+ -> key -- ^ The private key to sign with.+ -> Maybe Digest -- ^ A hashing algorithm to use. If @Nothing@+ -- the most suitable algorithm for the key+ -- is automatically used.+ -> IO ()+signX509 x509 key mDigest+ = withX509Ptr x509 $ \ x509Ptr ->+ withPKeyPtr' key $ \ pkeyPtr ->+ do dig <- case mDigest of+ Just md -> return md+ Nothing -> pkeyDefaultMD key+ withMDPtr dig $ \ digestPtr ->+ _sign x509Ptr pkeyPtr digestPtr+ >>= failIf_ (== 0)+ return ()++-- |@'verifyX509'@ verifies a signature of certificate with an issuer+-- public key.+verifyX509 :: PublicKey key =>+ X509 -- ^ The certificate to be verified.+ -> key -- ^ The public key to verify with.+ -> IO VerifyStatus+verifyX509 x509 key+ = withX509Ptr x509 $ \ x509Ptr ->+ withPKeyPtr' key $ \ pkeyPtr ->+ _verify x509Ptr pkeyPtr+ >>= interpret+ where+ interpret :: CInt -> IO VerifyStatus+ interpret 1 = return VerifySuccess+ interpret 0 = do+ clearErrorStack+ return VerifyFailure+ interpret _ = raiseOpenSSLError++-- |@'printX509' cert@ translates a certificate into human-readable+-- format.+printX509 :: X509 -> IO String+printX509 x509+ = do mem <- newMem+ withX509Ptr x509 $ \ x509Ptr ->+ withBioPtr mem $ \ memPtr ->+ _print memPtr x509Ptr+ >>= failIf_ (/= 1)+ bioRead mem++-- |@'getVersion' cert@ returns the version number of certificate. It+-- seems the number is 0-origin: version 2 means X.509 v3.+getVersion :: X509 -> IO Int+getVersion x509+ = withX509Ptr x509 $ \ x509Ptr ->+ liftM fromIntegral $ _get_version x509Ptr++-- |@'setVersion' cert ver@ updates the version number of certificate.+setVersion :: X509 -> Int -> IO ()+setVersion x509 ver+ = withX509Ptr x509 $ \ x509Ptr ->+ _set_version x509Ptr (fromIntegral ver)+ >>= failIf (/= 1)+ >> return ()++-- |@'getSerialNumber' cert@ returns the serial number of certificate.+getSerialNumber :: X509 -> IO Integer+getSerialNumber x509+ = withX509Ptr x509 $ \ x509Ptr ->+ _get_serialNumber x509Ptr+ >>= peekASN1Integer++-- |@'setSerialNumber' cert num@ updates the serial number of+-- certificate.+setSerialNumber :: X509 -> Integer -> IO ()+setSerialNumber x509 serial+ = withX509Ptr x509 $ \ x509Ptr ->+ withASN1Integer serial $ \ serialPtr ->+ _set_serialNumber x509Ptr serialPtr+ >>= failIf (/= 1)+ >> return ()++-- |@'getIssuerName'@ returns the issuer name of certificate.+getIssuerName :: X509 -- ^ The certificate to examine.+ -> Bool -- ^ @True@ if you want the keys of each parts+ -- to be of long form (e.g. \"commonName\"),+ -- or @False@ if you don't (e.g. \"CN\").+ -> IO [(String, String)] -- ^ Pairs of key and value,+ -- for example \[(\"C\",+ -- \"JP\"), (\"ST\",+ -- \"Some-State\"), ...\].+getIssuerName x509 wantLongName+ = withX509Ptr x509 $ \ x509Ptr ->+ do namePtr <- _get_issuer_name x509Ptr+ peekX509Name namePtr wantLongName++-- |@'setIssuerName' cert name@ updates the issuer name of+-- certificate. Keys of each parts may be of either long form or short+-- form. See 'getIssuerName'.+setIssuerName :: X509 -> [(String, String)] -> IO ()+setIssuerName x509 issuer+ = withX509Ptr x509 $ \ x509Ptr ->+ withX509Name issuer $ \ namePtr ->+ _set_issuer_name x509Ptr namePtr+ >>= failIf (/= 1)+ >> return ()++-- |@'getSubjectName' cert wantLongName@ returns the subject name of+-- certificate. See 'getIssuerName'.+getSubjectName :: X509 -> Bool -> IO [(String, String)]+getSubjectName x509 wantLongName+ = withX509Ptr x509 $ \ x509Ptr ->+ do namePtr <- _get_subject_name x509Ptr+ peekX509Name namePtr wantLongName++-- |@'setSubjectName' cert name@ updates the subject name of+-- certificate. See 'setIssuerName'.+setSubjectName :: X509 -> [(String, String)] -> IO ()+setSubjectName x509 subject+ = withX509Ptr x509 $ \ x509Ptr ->+ withX509Name subject $ \ namePtr ->+ _set_subject_name x509Ptr namePtr+ >>= failIf (/= 1)+ >> return ()++-- |@'getNotBefore' cert@ returns the time when the certificate begins+-- to be valid.+getNotBefore :: X509 -> IO UTCTime+getNotBefore x509+ = withX509Ptr x509 $ \ x509Ptr ->+ _get_notBefore x509Ptr+ >>= peekASN1Time++-- |@'setNotBefore' cert utc@ updates the time when the certificate+-- begins to be valid.+setNotBefore :: X509 -> UTCTime -> IO ()+setNotBefore x509 utc+ = withX509Ptr x509 $ \ x509Ptr ->+ withASN1Time utc $ \ time ->+ _set_notBefore x509Ptr time+ >>= failIf (/= 1)+ >> return ()++-- |@'getNotAfter' cert@ returns the time when the certificate+-- expires.+getNotAfter :: X509 -> IO UTCTime+getNotAfter x509+ = withX509Ptr x509 $ \ x509Ptr ->+ _get_notAfter x509Ptr+ >>= peekASN1Time++-- |@'setNotAfter' cert utc@ updates the time when the certificate+-- expires.+setNotAfter :: X509 -> UTCTime -> IO ()+setNotAfter x509 utc+ = withX509Ptr x509 $ \ x509Ptr ->+ withASN1Time utc $ \ time ->+ _set_notAfter x509Ptr time+ >>= failIf (/= 1)+ >> return ()++-- |@'getPublicKey' cert@ returns the public key of the subject of+-- certificate.+getPublicKey :: X509 -> IO SomePublicKey+getPublicKey x509+ = withX509Ptr x509 $ \ x509Ptr ->+ fmap fromJust ( _get_pubkey x509Ptr+ >>= failIfNull+ >>= wrapPKeyPtr+ >>= fromPKey+ )++-- |@'setPublicKey' cert pubkey@ updates the public key of the subject+-- of certificate.+setPublicKey :: PublicKey key => X509 -> key -> IO ()+setPublicKey x509 key+ = withX509Ptr x509 $ \ x509Ptr ->+ withPKeyPtr' key $ \ pkeyPtr ->+ _set_pubkey x509Ptr pkeyPtr+ >>= failIf (/= 1)+ >> return ()++-- |@'getSubjectEmail' cert@ returns every subject email addresses in+-- the certificate.+getSubjectEmail :: X509 -> IO [String]+getSubjectEmail x509+ = withX509Ptr x509 $ \ x509Ptr ->+ do st <- _get1_email x509Ptr+ list <- mapStack peekCString st+ _email_free st+ return list
OpenSSL/X509/Name.hsc view
@@ -1,5 +1,6 @@-#include "HsOpenSSL.h"-+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-} module OpenSSL.X509.Name ( X509_NAME @@ -8,36 +9,35 @@ , peekX509Name ) where-+#include "HsOpenSSL.h" import Control.Exception import Foreign import Foreign.C import OpenSSL.ASN1 import OpenSSL.Utils --data X509_NAME-data X509_NAME_ENTRY+data {-# CTYPE "openssl/x509.h" "X509_NAME" #-} X509_NAME+data {-# CTYPE "openssl/x509.h" "X509_NAME_ENTRY" #-} X509_NAME_ENTRY -foreign import ccall unsafe "X509_NAME_new"+foreign import capi unsafe "openssl/x509.h X509_NAME_new" _new :: IO (Ptr X509_NAME) -foreign import ccall unsafe "X509_NAME_free"+foreign import capi unsafe "openssl/x509.h X509_NAME_free" _free :: Ptr X509_NAME -> IO () -foreign import ccall unsafe "X509_NAME_add_entry_by_txt"+foreign import capi unsafe "openssl/x509.h X509_NAME_add_entry_by_txt" _add_entry_by_txt :: Ptr X509_NAME -> CString -> CInt -> Ptr CChar -> CInt -> CInt -> CInt -> IO CInt -foreign import ccall unsafe "X509_NAME_entry_count"+foreign import capi unsafe "openssl/x509.h X509_NAME_entry_count" _entry_count :: Ptr X509_NAME -> IO CInt -foreign import ccall unsafe "X509_NAME_get_entry"+foreign import capi unsafe "openssl/x509.h X509_NAME_get_entry" _get_entry :: Ptr X509_NAME -> CInt -> IO (Ptr X509_NAME_ENTRY) -foreign import ccall unsafe "X509_NAME_ENTRY_get_object"+foreign import capi unsafe "openssl/x509.h X509_NAME_ENTRY_get_object" _ENTRY_get_object :: Ptr X509_NAME_ENTRY -> IO (Ptr ASN1_OBJECT) -foreign import ccall unsafe "X509_NAME_ENTRY_get_data"+foreign import capi unsafe "openssl/x509.h X509_NAME_ENTRY_get_data" _ENTRY_get_data :: Ptr X509_NAME_ENTRY -> IO (Ptr ASN1_STRING)
+ OpenSSL/X509/Request.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# OPTIONS_HADDOCK prune #-}+-- |An interface to PKCS#10 certificate request.+module OpenSSL.X509.Request+ ( -- * Type+ X509Req+ , X509_REQ -- private++ -- * Functions to manipulate request+ , newX509Req+ , wrapX509Req -- private+ , withX509ReqPtr -- private++ , signX509Req+ , verifyX509Req++ , printX509Req+ , writeX509ReqDER++ , makeX509FromReq++ -- * Accessors+ , getVersion+ , setVersion++ , getSubjectName+ , setSubjectName++ , getPublicKey+ , setPublicKey++ , addExtensions+ , addExtensionToX509+ )+ where++import Control.Monad+import Data.Maybe+import Foreign+import Foreign.C+import OpenSSL.BIO+import OpenSSL.EVP.Digest hiding (digest)+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Verify+import OpenSSL.EVP.Internal+import OpenSSL.Utils+import OpenSSL.X509 (X509)+import qualified OpenSSL.X509 as Cert+import OpenSSL.X509.Name+import Data.ByteString.Lazy (ByteString)+import OpenSSL.Stack++-- |@'X509Req'@ is an opaque object that represents PKCS#10+-- certificate request.+newtype X509Req = X509Req (ForeignPtr X509_REQ)+data {-# CTYPE "openssl/x509.h" "X509_REQ" #-} X509_REQ++data X509_EXT++foreign import capi unsafe "openssl/x509.h X509_REQ_new"+ _new :: IO (Ptr X509_REQ)++foreign import capi unsafe "openssl/x509.h &X509_REQ_free"+ _free :: FunPtr (Ptr X509_REQ -> IO ())++foreign import capi unsafe "openssl/x509.h X509_REQ_sign"+ _sign :: Ptr X509_REQ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_REQ_verify"+ _verify :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_REQ_print"+ _print :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt++foreign import capi unsafe "openssl/x509.h i2d_X509_REQ_bio"+ _req_to_der :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_REQ_get_version"+ _get_version :: Ptr X509_REQ -> IO CLong++foreign import capi unsafe "openssl/x509.h X509_REQ_set_version"+ _set_version :: Ptr X509_REQ -> CLong -> IO CInt++foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_REQ_get_subject_name"+ _get_subject_name :: Ptr X509_REQ -> IO (Ptr X509_NAME)++foreign import capi unsafe "openssl/x509.h X509_REQ_set_subject_name"+ _set_subject_name :: Ptr X509_REQ -> Ptr X509_NAME -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_REQ_get_pubkey"+ _get_pubkey :: Ptr X509_REQ -> IO (Ptr EVP_PKEY)++foreign import capi unsafe "openssl/x509.h X509_REQ_set_pubkey"+ _set_pubkey :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt++foreign import capi unsafe "openssl/x509v3.h X509V3_EXT_nconf_nid"+ _ext_create :: Ptr a -> Ptr b -> CInt -> CString -> IO (Ptr X509_EXT)++foreign import capi unsafe "openssl/x509.h X509_REQ_add_extensions"+ _req_add_extensions :: Ptr X509_REQ -> Ptr STACK -> IO CInt++foreign import capi unsafe "openssl/x509.h X509_add_ext"+ _X509_add_ext :: Ptr Cert.X509_ -> Ptr X509_EXT -> CInt -> IO CInt++-- |@'newX509Req'@ creates an empty certificate request. You must set+-- the following properties to and sign it (see 'signX509Req') to+-- actually use the certificate request.+--+-- [/Version/] See 'setVersion'.+--+-- [/Subject Name/] See 'setSubjectName'.+--+-- [/Public Key/] See 'setPublicKey'.+--+newX509Req :: IO X509Req+newX509Req = _new >>= wrapX509Req+++wrapX509Req :: Ptr X509_REQ -> IO X509Req+wrapX509Req = fmap X509Req . newForeignPtr _free+++withX509ReqPtr :: X509Req -> (Ptr X509_REQ -> IO a) -> IO a+withX509ReqPtr (X509Req req) = withForeignPtr req++-- |@'signX509Req'@ signs a certificate request with a subject private+-- key.+signX509Req :: KeyPair key =>+ X509Req -- ^ The request to be signed.+ -> key -- ^ The private key to sign with.+ -> Maybe Digest -- ^ A hashing algorithm to use. If+ -- @Nothing@ the most suitable algorithm+ -- for the key is automatically used.+ -> IO ()+signX509Req req pkey mDigest+ = withX509ReqPtr req $ \ reqPtr ->+ withPKeyPtr' pkey $ \ pkeyPtr ->+ do digest <- case mDigest of+ Just md -> return md+ Nothing -> pkeyDefaultMD pkey+ withMDPtr digest $ \ digestPtr ->+ _sign reqPtr pkeyPtr digestPtr+ >>= failIf_ (== 0)++-- |@'verifyX509Req'@ verifies a signature of certificate request with+-- a subject public key.+verifyX509Req :: PublicKey key =>+ X509Req -- ^ The request to be verified.+ -> key -- ^ The public key to verify with.+ -> IO VerifyStatus+verifyX509Req req pkey+ = withX509ReqPtr req $ \ reqPtr ->+ withPKeyPtr' pkey $ \ pkeyPtr ->+ _verify reqPtr pkeyPtr+ >>= interpret+ where+ interpret :: CInt -> IO VerifyStatus+ interpret 1 = return VerifySuccess+ interpret 0 = return VerifyFailure+ interpret _ = raiseOpenSSLError++-- |@'printX509Req' req@ translates a certificate request into+-- human-readable format.+printX509Req :: X509Req -> IO String+printX509Req req+ = do mem <- newMem+ withBioPtr mem $ \ memPtr ->+ withX509ReqPtr req $ \ reqPtr ->+ _print memPtr reqPtr+ >>= failIf_ (/= 1)+ bioRead mem++{- DER encoding ------------------------------------------------------------- -}++-- |@'writeX509ReqDER' req@ writes a PKCS#10 certificate request to DER string.+writeX509ReqDER :: X509Req -> IO ByteString+writeX509ReqDER req+ = do mem <- newMem+ withBioPtr mem $ \ memPtr ->+ withX509ReqPtr req $ \ reqPtr ->+ _req_to_der memPtr reqPtr+ >>= failIf_ (< 0)+ bioReadLBS mem+++-- |@'getVersion' req@ returns the version number of certificate+-- request.+getVersion :: X509Req -> IO Int+getVersion req+ = withX509ReqPtr req $ \ reqPtr ->+ liftM fromIntegral $ _get_version reqPtr++-- |@'setVersion' req ver@ updates the version number of certificate+-- request.+setVersion :: X509Req -> Int -> IO ()+setVersion req ver+ = withX509ReqPtr req $ \ reqPtr ->+ _set_version reqPtr (fromIntegral ver)+ >>= failIf (/= 1)+ >> return ()++-- |@'getSubjectName' req wantLongName@ returns the subject name of+-- certificate request. See 'OpenSSL.X509.getSubjectName' of+-- "OpenSSL.X509".+getSubjectName :: X509Req -> Bool -> IO [(String, String)]+getSubjectName req wantLongName+ = withX509ReqPtr req $ \ reqPtr ->+ do namePtr <- _get_subject_name reqPtr+ peekX509Name namePtr wantLongName++-- |@'setSubjectName' req name@ updates the subject name of+-- certificate request. See 'OpenSSL.X509.setSubjectName' of+-- "OpenSSL.X509".+setSubjectName :: X509Req -> [(String, String)] -> IO ()+setSubjectName req subject+ = withX509ReqPtr req $ \ reqPtr ->+ withX509Name subject $ \ namePtr ->+ _set_subject_name reqPtr namePtr+ >>= failIf (/= 1)+ >> return ()++-- |@'getPublicKey' req@ returns the public key of the subject of+-- certificate request.+getPublicKey :: X509Req -> IO SomePublicKey+getPublicKey req+ = withX509ReqPtr req $ \ reqPtr ->+ fmap fromJust+ ( _get_pubkey reqPtr+ >>= failIfNull+ >>= wrapPKeyPtr+ >>= fromPKey+ )++-- |@'setPublicKey' req@ updates the public key of the subject of+-- certificate request.+setPublicKey :: PublicKey key => X509Req -> key -> IO ()+setPublicKey req pkey+ = withX509ReqPtr req $ \ reqPtr ->+ withPKeyPtr' pkey $ \ pkeyPtr ->+ _set_pubkey reqPtr pkeyPtr+ >>= failIf (/= 1)+ >> return ()+++-- |@'addExtensions' req [(nid, str)]@+--+-- E.g., nid 85 = 'subjectAltName' http://osxr.org:8080/openssl/source/crypto/objects/objects.h#0476+--+-- (TODO: more docs; NID type)+addExtensions :: X509Req -> [(Int, String)] -> IO CInt+addExtensions req exts =+ withX509ReqPtr req $ \reqPtr -> do+ extPtrs <- forM exts make+ withStack extPtrs $ _req_add_extensions reqPtr++ where+ make (nid, str) = withCString str $ _ext_create nullPtr nullPtr (fromIntegral nid)+++-- |@'makeX509FromReq' req cert@ creates an empty X.509 certificate+-- and copies as much data from the request as possible. The resulting+-- certificate doesn't have the following data and it isn't signed so+-- you must fill them and sign it yourself.+--+-- * Serial number+--+-- * Validity (Not Before and Not After)+--+-- Example:+--+-- > import Data.Time.Clock+-- >+-- > genCert :: X509 -> EvpPKey -> Integer -> Int -> X509Req -> IO X509+-- > genCert caCert caKey serial days req+-- > = do cert <- makeX509FromReq req caCert+-- > now <- getCurrentTime+-- > setSerialNumber cert serial+-- > setNotBefore cert $ addUTCTime (-1) now+-- > setNotAfter cert $ addUTCTime (days * 24 * 60 * 60) now+-- > signX509 cert caKey Nothing+-- > return cert+--+makeX509FromReq :: X509Req+ -> X509+ -> IO X509+makeX509FromReq req caCert+ = do reqPubKey <- getPublicKey req+ verified <- verifyX509Req req reqPubKey++ when (verified == VerifyFailure)+ $ fail "makeX509FromReq: the request isn't properly signed by its own key."++ cert <- Cert.newX509+ Cert.setVersion cert 2 -- Version 2 means X509 v3. It's confusing.+ Cert.setIssuerName cert =<< Cert.getSubjectName caCert False+ Cert.setSubjectName cert =<< getSubjectName req False+ Cert.setPublicKey cert =<< getPublicKey req++ return cert++-- | Add Extensions to a certificate (when the Server accepting certs requires it)+-- E.g.:+--+-- > addExtensionToX509 cert1 87 "CA:FALSE"+-- > addExtensionToX509 cert1 85 "critical,serverAuth, clientAuth" -- when this extension field is critical+--+addExtensionToX509 :: X509 -> Int -> String -> IO Bool+addExtensionToX509 (Cert.X509 certFPtr) nid value = do+ -- Context and config pointers are set to nullPtr for simplicity.+ -- Depending on your use case, you might need to provide actual values.+ result <- withForeignPtr certFPtr $ \certPtr ->+ withCString value $ \cValue -> do+ extPtr <- _ext_create nullPtr nullPtr (fromIntegral nid) cValue+ if extPtr /= nullPtr+ then do+ res <- _X509_add_ext certPtr extPtr (-1) -- Add to the end+ return (res == 0)+ else return False+ return result
− OpenSSL/X509/Request.hsc
@@ -1,255 +0,0 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK prune #-}---- |An interface to PKCS#10 certificate request.--module OpenSSL.X509.Request- ( -- * Type- X509Req- , X509_REQ -- private-- -- * Functions to manipulate request- , newX509Req- , wrapX509Req -- private- , withX509ReqPtr -- private-- , signX509Req- , verifyX509Req-- , printX509Req-- , makeX509FromReq-- -- * Accessors- , getVersion- , setVersion-- , getSubjectName- , setSubjectName-- , getPublicKey- , setPublicKey- )- where--import Control.Monad-import Data.Maybe-import Foreign-import Foreign.C-import OpenSSL.BIO-import OpenSSL.EVP.Digest hiding (digest)-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Verify-import OpenSSL.EVP.Internal-import OpenSSL.Utils-import OpenSSL.X509 (X509)-import qualified OpenSSL.X509 as Cert-import OpenSSL.X509.Name---- |@'X509Req'@ is an opaque object that represents PKCS#10--- certificate request.-newtype X509Req = X509Req (ForeignPtr X509_REQ)-data X509_REQ---foreign import ccall unsafe "X509_REQ_new"- _new :: IO (Ptr X509_REQ)--foreign import ccall unsafe "&X509_REQ_free"- _free :: FunPtr (Ptr X509_REQ -> IO ())--foreign import ccall unsafe "X509_REQ_sign"- _sign :: Ptr X509_REQ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt--foreign import ccall unsafe "X509_REQ_verify"- _verify :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt--foreign import ccall unsafe "X509_REQ_print"- _print :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt--foreign import ccall unsafe "HsOpenSSL_X509_REQ_get_version"- _get_version :: Ptr X509_REQ -> IO CLong--foreign import ccall unsafe "X509_REQ_set_version"- _set_version :: Ptr X509_REQ -> CLong -> IO CInt--foreign import ccall unsafe "HsOpenSSL_X509_REQ_get_subject_name"- _get_subject_name :: Ptr X509_REQ -> IO (Ptr X509_NAME)--foreign import ccall unsafe "X509_REQ_set_subject_name"- _set_subject_name :: Ptr X509_REQ -> Ptr X509_NAME -> IO CInt--foreign import ccall unsafe "X509_REQ_get_pubkey"- _get_pubkey :: Ptr X509_REQ -> IO (Ptr EVP_PKEY)--foreign import ccall unsafe "X509_REQ_set_pubkey"- _set_pubkey :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt---- |@'newX509Req'@ creates an empty certificate request. You must set--- the following properties to and sign it (see 'signX509Req') to--- actually use the certificate request.------ [/Version/] See 'setVersion'.------ [/Subject Name/] See 'setSubjectName'.------ [/Public Key/] See 'setPublicKey'.----newX509Req :: IO X509Req-newX509Req = _new >>= wrapX509Req---wrapX509Req :: Ptr X509_REQ -> IO X509Req-wrapX509Req = fmap X509Req . newForeignPtr _free---withX509ReqPtr :: X509Req -> (Ptr X509_REQ -> IO a) -> IO a-withX509ReqPtr (X509Req req) = withForeignPtr req---- |@'signX509Req'@ signs a certificate request with a subject private--- key.-signX509Req :: KeyPair key =>- X509Req -- ^ The request to be signed.- -> key -- ^ The private key to sign with.- -> Maybe Digest -- ^ A hashing algorithm to use. If- -- @Nothing@ the most suitable algorithm- -- for the key is automatically used.- -> IO ()-signX509Req req pkey mDigest- = withX509ReqPtr req $ \ reqPtr ->- withPKeyPtr' pkey $ \ pkeyPtr ->- do digest <- case mDigest of- Just md -> return md- Nothing -> pkeyDefaultMD pkey- withMDPtr digest $ \ digestPtr ->- _sign reqPtr pkeyPtr digestPtr- >>= failIf_ (== 0)---- |@'verifyX509Req'@ verifies a signature of certificate request with--- a subject public key.-verifyX509Req :: PublicKey key =>- X509Req -- ^ The request to be verified.- -> key -- ^ The public key to verify with.- -> IO VerifyStatus-verifyX509Req req pkey- = withX509ReqPtr req $ \ reqPtr ->- withPKeyPtr' pkey $ \ pkeyPtr ->- _verify reqPtr pkeyPtr- >>= interpret- where- interpret :: CInt -> IO VerifyStatus- interpret 1 = return VerifySuccess- interpret 0 = return VerifyFailure- interpret _ = raiseOpenSSLError---- |@'printX509Req' req@ translates a certificate request into--- human-readable format.-printX509Req :: X509Req -> IO String-printX509Req req- = do mem <- newMem- withBioPtr mem $ \ memPtr ->- withX509ReqPtr req $ \ reqPtr ->- _print memPtr reqPtr- >>= failIf_ (/= 1)- bioRead mem---- |@'getVersion' req@ returns the version number of certificate--- request.-getVersion :: X509Req -> IO Int-getVersion req- = withX509ReqPtr req $ \ reqPtr ->- liftM fromIntegral $ _get_version reqPtr---- |@'setVersion' req ver@ updates the version number of certificate--- request.-setVersion :: X509Req -> Int -> IO ()-setVersion req ver- = withX509ReqPtr req $ \ reqPtr ->- _set_version reqPtr (fromIntegral ver)- >>= failIf (/= 1)- >> return ()---- |@'getSubjectName' req wantLongName@ returns the subject name of--- certificate request. See 'OpenSSL.X509.getSubjectName' of--- "OpenSSL.X509".-getSubjectName :: X509Req -> Bool -> IO [(String, String)]-getSubjectName req wantLongName- = withX509ReqPtr req $ \ reqPtr ->- do namePtr <- _get_subject_name reqPtr- peekX509Name namePtr wantLongName---- |@'setSubjectName' req name@ updates the subject name of--- certificate request. See 'OpenSSL.X509.setSubjectName' of--- "OpenSSL.X509".-setSubjectName :: X509Req -> [(String, String)] -> IO ()-setSubjectName req subject- = withX509ReqPtr req $ \ reqPtr ->- withX509Name subject $ \ namePtr ->- _set_subject_name reqPtr namePtr- >>= failIf (/= 1)- >> return ()---- |@'getPublicKey' req@ returns the public key of the subject of--- certificate request.-getPublicKey :: X509Req -> IO SomePublicKey-getPublicKey req- = withX509ReqPtr req $ \ reqPtr ->- fmap fromJust- ( _get_pubkey reqPtr- >>= failIfNull- >>= wrapPKeyPtr- >>= fromPKey- )---- |@'setPublicKey' req@ updates the public key of the subject of--- certificate request.-setPublicKey :: PublicKey key => X509Req -> key -> IO ()-setPublicKey req pkey- = withX509ReqPtr req $ \ reqPtr ->- withPKeyPtr' pkey $ \ pkeyPtr ->- _set_pubkey reqPtr pkeyPtr- >>= failIf (/= 1)- >> return ()----- |@'makeX509FromReq' req cert@ creates an empty X.509 certificate--- and copies as much data from the request as possible. The resulting--- certificate doesn't have the following data and it isn't signed so--- you must fill them and sign it yourself.------ * Serial number------ * Validity (Not Before and Not After)------ Example:------ > import Data.Time.Clock--- >--- > genCert :: X509 -> EvpPKey -> Integer -> Int -> X509Req -> IO X509--- > genCert caCert caKey serial days req--- > = do cert <- makeX509FromReq req caCert--- > now <- getCurrentTime--- > setSerialNumber cert serial--- > setNotBefore cert $ addUTCTime (-1) now--- > setNotAfter cert $ addUTCTime (days * 24 * 60 * 60) now--- > signX509 cert caKey Nothing--- > return cert----makeX509FromReq :: X509Req- -> X509- -> IO X509-makeX509FromReq req caCert- = do reqPubKey <- getPublicKey req- verified <- verifyX509Req req reqPubKey-- when (verified == VerifyFailure)- $ fail "makeX509FromReq: the request isn't properly signed by its own key."-- cert <- Cert.newX509- Cert.setVersion cert 2 -- Version 2 means X509 v3. It's confusing.- Cert.setIssuerName cert =<< Cert.getSubjectName caCert False- Cert.setSubjectName cert =<< getSubjectName req False- Cert.setPublicKey cert =<< getPublicKey req-- return cert
OpenSSL/X509/Revocation.hsc view
@@ -1,11 +1,9 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK prune #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# OPTIONS_HADDOCK prune #-} -- |An interface to Certificate Revocation List.--#include "HsOpenSSL.h"- module OpenSSL.X509.Revocation ( -- * Types CRL@@ -42,6 +40,7 @@ , getRevoked ) where+#include "HsOpenSSL.h" import Control.Monad #if OPENSSL_VERSION_NUMBER < 0x10000000 import Data.List@@ -63,8 +62,8 @@ -- |@'CRL'@ is an opaque object that represents Certificate Revocation -- List. newtype CRL = CRL (ForeignPtr X509_CRL)-data X509_CRL-data X509_REVOKED+data {-# CTYPE "openssl/x509.h" "X509_CRL" #-} X509_CRL+data {-# CTYPE "openssl/x509.h" "X509_REVOKED" #-} X509_REVOKED -- |@'RevokedCertificate'@ represents a revoked certificate in a -- list. Each certificates are supposed to be distinguishable by@@ -78,73 +77,81 @@ deriving (Show, Eq, Typeable) -foreign import ccall unsafe "X509_CRL_new"+foreign import capi unsafe "openssl/x509.h X509_CRL_new" _new :: IO (Ptr X509_CRL) -foreign import ccall unsafe "&X509_CRL_free"+foreign import capi unsafe "openssl/x509.h &X509_CRL_free" _free :: FunPtr (Ptr X509_CRL -> IO ()) -foreign import ccall unsafe "X509_CRL_sign"+foreign import capi unsafe "openssl/x509.h X509_CRL_sign" _sign :: Ptr X509_CRL -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt -foreign import ccall unsafe "X509_CRL_verify"+foreign import capi unsafe "openssl/x509.h X509_CRL_verify" _verify :: Ptr X509_CRL -> Ptr EVP_PKEY -> IO CInt -foreign import ccall unsafe "X509_CRL_print"+foreign import capi unsafe "openssl/x509.h X509_CRL_print" _print :: Ptr BIO_ -> Ptr X509_CRL -> IO CInt -foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_version"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_version" _get_version :: Ptr X509_CRL -> IO CLong -foreign import ccall unsafe "X509_CRL_set_version"+foreign import capi unsafe "openssl/x509.h X509_CRL_set_version" _set_version :: Ptr X509_CRL -> CLong -> IO CInt -foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_lastUpdate"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_lastUpdate" _get_lastUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME) -foreign import ccall unsafe "X509_CRL_set_lastUpdate"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_nextUpdate"+ _get_nextUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME)++#if OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import capi unsafe "openssl/x509.h X509_CRL_set1_lastUpdate" _set_lastUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt -foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_nextUpdate"- _get_nextUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME)+foreign import capi unsafe "openssl/x509.h X509_CRL_set1_nextUpdate"+ _set_nextUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt+#else+foreign import capi unsafe "openssl/x509.h X509_CRL_set_lastUpdate"+ _set_lastUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt -foreign import ccall unsafe "X509_CRL_set_nextUpdate"+foreign import capi unsafe "openssl/x509.h X509_CRL_set_nextUpdate" _set_nextUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt+#endif -foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_issuer"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_issuer" _get_issuer_name :: Ptr X509_CRL -> IO (Ptr X509_NAME) -foreign import ccall unsafe "X509_CRL_set_issuer_name"+foreign import capi unsafe "openssl/x509.h X509_CRL_set_issuer_name" _set_issuer_name :: Ptr X509_CRL -> Ptr X509_NAME -> IO CInt -foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_REVOKED"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_REVOKED" _get_REVOKED :: Ptr X509_CRL -> IO (Ptr STACK) -foreign import ccall unsafe "X509_CRL_add0_revoked"+foreign import capi unsafe "openssl/x509.h X509_CRL_add0_revoked" _add0_revoked :: Ptr X509_CRL -> Ptr X509_REVOKED -> IO CInt #if OPENSSL_VERSION_NUMBER >= 0x10000000 -- This function is only available on OpenSSL 1.0.0 or later.-foreign import ccall unsafe "X509_CRL_get0_by_serial"+foreign import capi unsafe "openssl/x509.h X509_CRL_get0_by_serial" _get0_by_serial :: Ptr X509_CRL -> Ptr (Ptr X509_REVOKED) -> Ptr ASN1_INTEGER -> IO CInt #endif -foreign import ccall unsafe "X509_CRL_sort"+foreign import capi unsafe "openssl/x509.h X509_CRL_sort" _sort :: Ptr X509_CRL -> IO CInt -foreign import ccall unsafe "X509_REVOKED_new"+foreign import capi unsafe "openssl/x509.h X509_REVOKED_new" _new_revoked :: IO (Ptr X509_REVOKED) -foreign import ccall unsafe "X509_REVOKED_free"+foreign import capi unsafe "openssl/x509.h X509_REVOKED_free" freeRevoked :: Ptr X509_REVOKED -> IO () -foreign import ccall unsafe "X509_REVOKED_set_serialNumber"+foreign import capi unsafe "openssl/x509.h X509_REVOKED_set_serialNumber" _set_serialNumber :: Ptr X509_REVOKED -> Ptr ASN1_INTEGER -> IO CInt -foreign import ccall unsafe "X509_REVOKED_set_revocationDate"+foreign import capi unsafe "openssl/x509.h X509_REVOKED_set_revocationDate" _set_revocationDate :: Ptr X509_REVOKED -> Ptr ASN1_TIME -> IO CInt -- |@'newCRL'@ creates an empty revocation list. You must set the@@ -291,10 +298,31 @@ = withCRLPtr crl $ \ crlPtr -> _get_REVOKED crlPtr >>= mapStack peekRevoked +getSerialNumber :: Ptr X509_REVOKED -> IO (Ptr ASN1_INTEGER)+getRevocationDate :: Ptr X509_REVOKED -> IO (Ptr ASN1_TIME)++#if OPENSSL_VERSION_NUMBER >= 0x10100000L++foreign import capi unsafe "openssl/x509.h X509_REVOKED_get0_serialNumber"+ _get0_serialNumber :: Ptr X509_REVOKED -> IO (Ptr ASN1_INTEGER)++foreign import capi unsafe "openssl/x509.h X509_REVOKED_get0_revocationDate"+ _get0_revocationDate :: Ptr X509_REVOKED -> IO (Ptr ASN1_TIME)++getSerialNumber = _get0_serialNumber+getRevocationDate = _get0_revocationDate++#else++getSerialNumber = (#peek X509_REVOKED, serialNumber )+getRevocationDate = (#peek X509_REVOKED, revocationDate)++#endif+ peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate peekRevoked rev = do- serial <- peekASN1Integer =<< (#peek X509_REVOKED, serialNumber ) rev- date <- peekASN1Time =<< (#peek X509_REVOKED, revocationDate) rev+ serial <- peekASN1Integer =<< getSerialNumber rev+ date <- peekASN1Time =<< getRevocationDate rev return RevokedCertificate { revSerialNumber = serial , revRevocationDate = date }
OpenSSL/X509/Store.hsc view
@@ -1,9 +1,8 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK prune #-}-+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CApiFFI #-}+{-# OPTIONS_HADDOCK prune #-} -- |An interface to X.509 certificate store.- module OpenSSL.X509.Store ( X509Store , X509_STORE -- private@@ -28,8 +27,10 @@ , getStoreCtxChain ) where-+#include "HsOpenSSL.h"+#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))+#endif import Control.Exception (throwIO, mask_) import Foreign import Foreign.C@@ -43,19 +44,19 @@ -- certificate store. The certificate store is usually used for chain -- verification. newtype X509Store = X509Store (ForeignPtr X509_STORE)-data X509_STORE+data {-# CTYPE "openssl/x509.h" "X509_STORE" #-} X509_STORE -foreign import ccall unsafe "X509_STORE_new"+foreign import capi unsafe "openssl/x509.h X509_STORE_new" _new :: IO (Ptr X509_STORE) -foreign import ccall unsafe "X509_STORE_free"+foreign import capi unsafe "openssl/x509.h X509_STORE_free" _free :: Ptr X509_STORE -> IO () -foreign import ccall unsafe "X509_STORE_add_cert"+foreign import capi unsafe "openssl/x509.h X509_STORE_add_cert" _add_cert :: Ptr X509_STORE -> Ptr X509_ -> IO CInt -foreign import ccall unsafe "X509_STORE_add_crl"+foreign import capi unsafe "openssl/x509.h X509_STORE_add_crl" _add_crl :: Ptr X509_STORE -> Ptr X509_CRL -> IO CInt -- |@'newX509Store'@ creates an empty X.509 certificate store.@@ -92,25 +93,30 @@ >>= failIf (/= 1) >> return () -data X509_STORE_CTX+data {-# CTYPE "openssl/x509.h" "X509_STORE_CTX" #-} X509_STORE_CTX newtype X509StoreCtx = X509StoreCtx (ForeignPtr X509_STORE_CTX) -foreign import ccall unsafe "X509_STORE_CTX_get_current_cert"+foreign import capi unsafe "openssl/x509.h X509_STORE_CTX_get_current_cert" _store_ctx_get_current_cert :: Ptr X509_STORE_CTX -> IO (Ptr X509_) -foreign import ccall unsafe "HsOpenSSL_X509_STORE_CTX_get0_current_issuer"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_STORE_CTX_get0_current_issuer" _store_ctx_get0_current_issuer :: Ptr X509_STORE_CTX -> IO (Ptr X509_) -foreign import ccall unsafe "HsOpenSSL_X509_STORE_CTX_get0_current_crl"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_STORE_CTX_get0_current_crl" _store_ctx_get0_current_crl :: Ptr X509_STORE_CTX -> IO (Ptr X509_CRL) -foreign import ccall unsafe "X509_STORE_CTX_get_chain"+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import capi unsafe "openssl/x509.h X509_STORE_CTX_get1_chain" _store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK)+#else+foreign import capi unsafe "openssl/x509.h X509_STORE_CTX_get_chain"+ _store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK)+#endif -foreign import ccall unsafe "HsOpenSSL_X509_ref"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_ref" _x509_ref :: Ptr X509_ -> IO () -foreign import ccall unsafe "HsOpenSSL_X509_CRL_ref"+foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_ref" _crl_ref :: Ptr X509_CRL -> IO () withX509StoreCtxPtr :: X509StoreCtx -> (Ptr X509_STORE_CTX -> IO a) -> IO a@@ -145,4 +151,3 @@ getStoreCtxChain ctx = withX509StoreCtxPtr ctx $ \pCtx -> do stack <- _store_ctx_get_chain pCtx (`mapStack` stack) $ \pCert -> mask_ $ _x509_ref pCert >> wrapX509 pCert-
+ README.md view
@@ -0,0 +1,7 @@+HsOpenSSL+=========++HsOpenSSL is an (incomplete) OpenSSL binding for Haskell. It can+generate RSA and DSA keys, read and write PEM files, generate message+digests, sign and verify messages, encrypt and decrypt messages. It+also has some capabilities of creating SSL clients and servers.
− README.rst
@@ -1,8 +0,0 @@-======-README-======--HsOpenSSL is an (incomplete) OpenSSL binding for Haskell. It can-generate RSA and DSA keys, read and write PEM files, generate message-digests, sign and verify messages, encrypt and decrypt messages. It-also has some capabilities of creating SSL clients and servers.
− Setup.hs
@@ -1,4 +0,0 @@-#!/usr/bin/env runghc--import Distribution.Simple-main = defaultMain
+ Test/OpenSSL/DER.hs view
@@ -0,0 +1,11 @@+module Main (main) where++import OpenSSL.RSA+import OpenSSL.DER+import TestUtils++main :: IO ()+main = do+ keyPair <- generateRSAKey 1024 3 Nothing+ pubKey <- rsaCopyPublic keyPair+ assertEqual "encodeDecode" (Just pubKey) (fromDERPub (toDERPub keyPair))
+ Test/OpenSSL/DSA.hs view
@@ -0,0 +1,37 @@+module Main (main) where++import qualified Data.ByteString as BS+import OpenSSL.DSA+import TestUtils++-- | This function just runs the example DSA generation, as given in FIP 186-2,+-- app 5.+test_generateParameters :: IO ()+test_generateParameters = do+ let seed = BS.pack [0xd5, 0x01, 0x4e, 0x4b,+ 0x60, 0xef, 0x2b, 0xa8,+ 0xb6, 0x21, 0x1b, 0x40,+ 0x62, 0xba, 0x32, 0x24,+ 0xe0, 0x42, 0x7d, 0xd3]+ (a, _, p, q, g) <- generateDSAParameters 512 $ Just seed+ assertEqual "generateParameters"+ ( 105+ , 0x8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291+ , 0xc773218c737ec8ee993b4f2ded30f48edace915f+ , 0x626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802+ ) (a, p, q, g)++testMessage :: BS.ByteString+testMessage = BS.pack [1..20]++test_signVerify :: IO ()+test_signVerify = do+ dsa <- generateDSAParametersAndKey 512 Nothing+ (a, b) <- signDigestedDataWithDSA dsa testMessage+ valid <- verifyDigestedDataWithDSA dsa testMessage (a, b)+ assertBool "signVerify" valid++main :: IO ()+main = do+ test_generateParameters+ test_signVerify
+ Test/OpenSSL/EVP/Base64.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Unittest for Base64 [en|de]coding.+module Main (main) where+#if !MIN_VERSION_bytestring(0,9,1)+import Data.Char (ord)+import Data.String+#endif+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import OpenSSL.EVP.Base64+import TestUtils++-- NOTE: bytestring-0.9.0.4 has these instances too, while+-- bytestring-0.9.0.3 does not. If our bytestring is 0.9.0.4 we'll+-- have duplicate instances, but that's not our fault, is it?+#if !MIN_VERSION_bytestring(0,9,1)+instance IsString BS.ByteString where+ fromString = BS.pack . map (fromIntegral . ord)++-- Note that this instance packs each charactor as a separate lazy chunk.+-- This is to stress the lazy code - not because it's a good idea generally+instance IsString BSL.ByteString where+ fromString = BSL.fromChunks . map (BS.singleton . fromIntegral . ord)+#endif++encodeTests :: IO ()+encodeTests =+ assertFunction "encodeBase64BS" encodeBase64BS pairs+ where+ pairs :: [(BS.ByteString, BS.ByteString)]+ pairs = [ ("" , "" )+ , ("a" , "YQ==")+ , ("aa" , "YWE=")+ , ("aaa", "YWFh")+ ]++lazyEncodeTests :: IO ()+lazyEncodeTests =+ assertFunction "encodeBase64LBS" encodeBase64LBS pairs+ where+ pairs :: [(BSL.ByteString, BSL.ByteString)]+ pairs = [ ("" , "" )+ , ("a" , "YQ==")+ , ("aa" , "YWE=")+ , ("aaa", "YWFh")+ ]++decodeTests :: IO ()+decodeTests =+ assertFunction "decodeBase64BS" decodeBase64BS pairs+ where+ pairs :: [(BS.ByteString, BS.ByteString)]+ pairs = [ ("" , "" )+ , ("aGFza2VsbA==" , "haskell" )+ , ("YWJjZGVmZ2hpams=" , "abcdefghijk")+ , ("YWJjZGVmZ2hpams=\n", "abcdefghijk")+ ]++main :: IO ()+main = do+ encodeTests+ lazyEncodeTests+ decodeTests
+ Test/OpenSSL/EVP/Digest.hs view
@@ -0,0 +1,38 @@+module Main (main) where++import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.Char+import OpenSSL+import Text.Printf+import OpenSSL.EVP.Digest+import TestUtils++main :: IO ()+main = withOpenSSL $ do+ Just md5 <- getDigestByName "MD5"+ Just sha1 <- getDigestByName "SHA1"+ Just sha256 <- getDigestByName "SHA256"+ let hex = concatMap (printf "%02x" . ord) . B.unpack+ checkHMAC digestName key testData result = do+ assertEqual what result $+ hex $ hmacBS d (B.pack key) (B.pack testData)+ assertEqual ("lazy " ++ what) result $+ hex $ hmacLBS d (B.pack key) (BL.pack testData)+ where what =+ "HMAC_" ++ digestName +++ "(" ++ show key ++ ", " ++ show testData ++ ")"+ d = case digestName of+ "MD5" -> md5+ "SHA1" -> sha1+ "SHA256" -> sha256+ _ -> error digestName+ -- test data from+ -- https://en.wikipedia.org/wiki/Hash-based_message_authentication_code++ checkHMAC "MD5" "" "" "74e6f7298a9c2d168935f58c001bad88"+ checkHMAC "SHA1" "" "" "fbdb1d1b18aa6c08324b7d64b71fb76370690e1d"+ checkHMAC "SHA256" "" "" "b613679a0814d9ec772f95d778c35fc5ff1697c493715653c6c712144292c5ad"+ checkHMAC "MD5" "key" "The quick brown fox jumps over the lazy dog" "80070713463e7749b90c2dc24911e275"+ checkHMAC "SHA1" "key" "The quick brown fox jumps over the lazy dog" "de7c9b85b8b78aa6bc8a7a36f70a90701c9db4d9"+ checkHMAC "SHA256" "key" "The quick brown fox jumps over the lazy dog" "f7bc83f430538424b13298e6aa6fb143ef4d59a14946175997479dbc2d1a3cd8"
+ Test/OpenSSL/TestUtils.hs view
@@ -0,0 +1,25 @@+module TestUtils where++import qualified Control.Exception as E+import Control.Monad++assertBool :: String -> Bool -> IO ()+assertBool n ok =+ unless ok $ E.throw $ E.AssertionFailed $ "Assertion failed: " ++ n++assertEqual :: (Show a, Eq a) => String -> a -> a -> IO ()+assertEqual n a b =+ assertBool (n ++ "\n" ++ show a ++ " /= " ++ show b) (a == b)++assertFunction+ :: (Show x, Show y, Eq y) => String -> (x -> y) -> [(x, y)] -> IO ()+assertFunction n f points =+ forM_ points $ \ (x, y) ->+ let r = f x in+ assertBool+ (n ++ " " ++ showsPrec 11 x "" ++ " == " ++ show r+ ++ " /= " ++ show y)+ (r == y)++-- assertFunction "asdf" (fmap (+1)) [(Just 1, Nothing)]+-- *** Exception: Assertion failed: asdf (Just 1) == Just 2 /= Nothing
cbits/HsOpenSSL.c view
@@ -4,8 +4,15 @@ #include "mutex.h" /* OpenSSL ********************************************************************/-void HsOpenSSL_OpenSSL_add_all_algorithms() {+void HsOpenSSL_init() {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ // OPENSSL_init_ssl(OPENSSL_INIT_LOAD_SSL_STRINGS, NULL);+ // unnecessary in OpenSSL 1.1.0+#else+ SSL_load_error_strings(); OpenSSL_add_all_algorithms();+ SSL_library_init();+#endif } void HsOpenSSL_OPENSSL_free(void* ptr) {@@ -63,6 +70,26 @@ return EVP_CIPHER_iv_length(cipher); } +/* EVP HMAC *******************************************************************/+HMAC_CTX *HsOpenSSL_HMAC_CTX_new(void) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ return HMAC_CTX_new();+#else+ HMAC_CTX *ctx = (HMAC_CTX *)malloc(sizeof(HMAC_CTX));+ HMAC_CTX_init(ctx);+ return ctx;+#endif+}++void HsOpenSSL_HMAC_CTX_free(HMAC_CTX *ctx) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ HMAC_CTX_free(ctx);+#else+ HMAC_CTX_cleanup(ctx);+ free(ctx);+#endif+}+ /* X509 ***********************************************************************/ long HsOpenSSL_X509_get_version(X509* x509) { return X509_get_version(x509);@@ -88,12 +115,20 @@ return X509_CRL_get_version(crl); } -ASN1_TIME* HsOpenSSL_X509_CRL_get_lastUpdate(X509_CRL* crl) {- return X509_CRL_get_lastUpdate(crl);+const ASN1_TIME* HsOpenSSL_X509_CRL_get_lastUpdate(const X509_CRL* crl) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ return X509_CRL_get0_lastUpdate(crl);+#else+ return X509_CRL_get_lastUpdate((X509_CRL*) crl);+#endif } -ASN1_TIME* HsOpenSSL_X509_CRL_get_nextUpdate(X509_CRL* crl) {- return X509_CRL_get_nextUpdate(crl);+const ASN1_TIME* HsOpenSSL_X509_CRL_get_nextUpdate(const X509_CRL* crl) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ return X509_CRL_get0_nextUpdate(crl);+#else+ return X509_CRL_get_nextUpdate((X509_CRL*) crl);+#endif } X509_NAME* HsOpenSSL_X509_CRL_get_issuer(X509_CRL* crl) {@@ -105,11 +140,19 @@ } void HsOpenSSL_X509_ref(X509* x509) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ X509_up_ref(x509);+#else CRYPTO_add(&x509->references, 1, CRYPTO_LOCK_X509);+#endif } void HsOpenSSL_X509_CRL_ref(X509_CRL* crl) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ X509_CRL_up_ref(crl);+#else CRYPTO_add(&crl->references, 1, CRYPTO_LOCK_X509_CRL);+#endif } X509* HsOpenSSL_X509_STORE_CTX_get0_current_issuer(X509_STORE_CTX *ctx) {@@ -135,16 +178,45 @@ /* DH *************************************************************************/-BIGNUM *HsOpenSSL_DH_get_pub_key(DH *dh) {+const BIGNUM *HsOpenSSL_DH_get_pub_key(DH *dh) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ const BIGNUM** pub_key = 0;+ const BIGNUM** priv_key = 0;+ DH_get0_key(dh, pub_key, priv_key);+ return *pub_key;+#else return dh->pub_key;+#endif } int HsOpenSSL_DH_length(DH *dh) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ const BIGNUM** p = 0;+ const BIGNUM** q = 0;+ const BIGNUM** g = 0;+ DH_get0_pqg(dh, p, q, g);+ return BN_num_bits(*p);+#else return BN_num_bits(dh->p);+#endif } /* ASN1 ***********************************************************************/++#if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)+#define M_ASN1_INTEGER_new() (ASN1_INTEGER *)\+ ASN1_STRING_type_new(V_ASN1_INTEGER)+#define M_ASN1_TIME_new() (ASN1_TIME *)\+ ASN1_STRING_type_new(V_ASN1_UTCTIME)+#define M_ASN1_TIME_free(a) ASN1_STRING_free((ASN1_STRING *)a)+#endif++#if OPENSSL_VERSION_NUMBER >= 0x10100000L+#define M_ASN1_INTEGER_free(a) ASN1_STRING_free((ASN1_STRING *)a)+#endif++ ASN1_INTEGER* HsOpenSSL_M_ASN1_INTEGER_new() { return M_ASN1_INTEGER_new(); }@@ -226,21 +298,39 @@ /* OpenSSL sadly wants to ASN1 encode the resulting bignums so we use this * function to skip that. Returns > 0 on success */ int HsOpenSSL_dsa_sign(DSA *dsa, const unsigned char *ddata, int dlen,- BIGNUM **r, BIGNUM **s) {+ const BIGNUM **r, const BIGNUM **s) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ DSA_SIG *const sig = DSA_do_sign(ddata, dlen, dsa);+ if (!sig) return 0;+ DSA_SIG_get0(sig, r, s);+ *r = BN_dup(*r);+ *s = BN_dup(*s);+ DSA_SIG_free(sig);+ return 1;+#else DSA_SIG *const sig = dsa->meth->dsa_do_sign(ddata, dlen, dsa); if (!sig) return 0; *r = sig->r; *s = sig->s; free(sig); return 1;+#endif } int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int dlen,- BIGNUM *r, BIGNUM *s) {+ const BIGNUM *r, const BIGNUM *s) {+#if OPENSSL_VERSION_NUMBER >= 0x10100000L+ DSA_SIG* sig = DSA_SIG_new();+ DSA_SIG_set0(sig, BN_dup(r), BN_dup(s));+ int res = DSA_do_verify(ddata, dlen, sig, dsa);+ DSA_SIG_free(sig);+ return res;+#else DSA_SIG sig;- sig.r = r;- sig.s = s;+ sig.r = (BIGNUM *)r;+ sig.s = (BIGNUM *)s; return dsa->meth->dsa_do_verify(ddata, dlen, &sig, dsa);+#endif } #if !defined(DSAPublicKey_dup)@@ -261,4 +351,52 @@ DSA* HsOpenSSL_DSAPrivateKey_dup(const DSA* dsa) { return DSAPrivateKey_dup(dsa);+}++/* SSL ************************************************************************/+long HsOpenSSL_SSL_CTX_set_options(SSL_CTX* ctx, long options) {+ return SSL_CTX_set_options(ctx, options);+}++/* OpenSSL < 0.9.8m does not have SSL_CTX_clear_options() */+long HsOpenSSL_SSL_CTX_clear_options(SSL_CTX* ctx, long options) {+#if defined(SSL_CTX_clear_options)+ return SSL_CTX_clear_options(ctx, options);+#else+ long tmp = SSL_CTX_get_options(ctx);+ return SSL_CTX_set_options(ctx, tmp & ~options);+#endif+}++long HsOpenSSL_SSL_set_options(SSL* ssl, long options) {+ return SSL_set_options(ssl, options);+}++/* OpenSSL < 1.0.0 does not have SSL_set_tlsext_host_name() */+long HsOpenSSL_SSL_set_tlsext_host_name(SSL* ssl, char* host_name) {+#if defined(SSL_set_tlsext_host_name)+ return SSL_set_tlsext_host_name(ssl, host_name);+#else+ return 0;+#endif+}++/* OpenSSL < 0.9.8m does not have SSL_clear_options() */+long HsOpenSSL_SSL_clear_options(SSL* ssl, long options) {+#if defined(SSL_clear_options)+ return SSL_clear_options(ssl, options);+#else+ long tmp = SSL_get_options(ssl);+ return SSL_set_options(ssl, tmp & ~options);+#endif+}++int HsOpenSSL_enable_hostname_validation(SSL* ssl, char* host_name, size_t host_len) {+#if defined(X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS)+ X509_VERIFY_PARAM* param = SSL_get0_param(ssl);+ X509_VERIFY_PARAM_set_hostflags(param, X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS);+ return X509_VERIFY_PARAM_set1_host(param, host_name, host_len);+#else+ return 0;+#endif }
cbits/HsOpenSSL.h view
@@ -20,20 +20,21 @@ #include <openssl/x509v3.h> #include <openssl/dsa.h> -/* A dirty hack to work around for broken versions of Cabal:- * https://github.com/phonohawk/HsOpenSSL/issues/8- *- * The trick is to abuse the fact that -Icbits is (almost) always- * passed to hsc2hs so we can reach the cabal_macros.h from cbits, but- * see #23, #24 and #25...- */-#if !defined(MIN_VERSION_base) && \- !defined(HSOPENSSL_NEED_NOT_INCLUDE_CABAL_MACROS_H)-# include "../dist/build/autogen/cabal_macros.h"+/* LibreSSL *******************************************************************/+#if (defined LIBRESSL_VERSION_NUMBER && OPENSSL_VERSION_NUMBER == 0x20000000L)+#undef OPENSSL_VERSION_NUMBER+#define OPENSSL_VERSION_NUMBER 0x1000107fL #endif +/* OpenSSL 3.0 ****************************************************************/++#ifndef OPENSSL_VERSION_PREREQ+#define OPENSSL_VERSION_PREREQ(maj,min) 0+#endif++ /* OpenSSL ********************************************************************/-void HsOpenSSL_OpenSSL_add_all_algorithms();+void HsOpenSSL_init(); void HsOpenSSL_OPENSSL_free(void* ptr); /* BIO ************************************************************************/@@ -48,12 +49,18 @@ /* DH *************************************************************************/ DH* HsOpenSSL_DHparams_dup(DH* dh);+const BIGNUM *HsOpenSSL_DH_get_pub_key(DH *dh);+int HsOpenSSL_DH_length(DH *dh); /* EVP ************************************************************************/ int HsOpenSSL_EVP_MD_size(EVP_MD* md); int HsOpenSSL_EVP_CIPHER_CTX_block_size(EVP_CIPHER_CTX* ctx); int HsOpenSSL_EVP_CIPHER_iv_length(EVP_CIPHER* cipher); +/* EVP HMAC *******************************************************************/+HMAC_CTX *HsOpenSSL_HMAC_CTX_new(void);+void HsOpenSSL_HMAC_CTX_free(HMAC_CTX *ctx);+ /* X509 ***********************************************************************/ long HsOpenSSL_X509_get_version(X509* x509); ASN1_TIME* HsOpenSSL_X509_get_notBefore(X509* x509);@@ -63,10 +70,14 @@ X509_NAME* HsOpenSSL_X509_REQ_get_subject_name(X509_REQ* req); long HsOpenSSL_X509_CRL_get_version(X509_CRL* crl);-ASN1_TIME* HsOpenSSL_X509_CRL_get_lastUpdate(X509_CRL* crl);-ASN1_TIME* HsOpenSSL_X509_CRL_get_nextUpdate(X509_CRL* crl);+const ASN1_TIME* HsOpenSSL_X509_CRL_get_lastUpdate(const X509_CRL* crl);+const ASN1_TIME* HsOpenSSL_X509_CRL_get_nextUpdate(const X509_CRL* crl); X509_NAME* HsOpenSSL_X509_CRL_get_issuer(X509_CRL* crl); STACK_OF(X509_REVOKED)* HsOpenSSL_X509_CRL_get_REVOKED(X509_CRL* crl);+void HsOpenSSL_X509_ref(X509* x509);+void HsOpenSSL_X509_CRL_ref(X509_CRL* crl);+X509* HsOpenSSL_X509_STORE_CTX_get0_current_issuer(X509_STORE_CTX *ctx);+X509_CRL* HsOpenSSL_X509_STORE_CTX_get0_current_crl(X509_STORE_CTX *ctx); /* PKCS#7 *********************************************************************/ long HsOpenSSL_PKCS7_is_detached(PKCS7* pkcs7);@@ -82,10 +93,19 @@ /* DSA ************************************************************************/ int HsOpenSSL_dsa_sign(DSA *dsa, const unsigned char *ddata, int len,- BIGNUM **r, BIGNUM **s);+ const BIGNUM **r, const BIGNUM **s); int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int len,- BIGNUM *r, BIGNUM *s);+ const BIGNUM *r, const BIGNUM *s); DSA* HsOpenSSL_DSAPublicKey_dup(const DSA* dsa); DSA* HsOpenSSL_DSAPrivateKey_dup(const DSA* dsa);++/* SSL ************************************************************************/+long HsOpenSSL_SSL_CTX_set_options(SSL_CTX* ctx, long options);+long HsOpenSSL_SSL_CTX_clear_options(SSL_CTX* ctx, long options);+long HsOpenSSL_SSL_set_options(SSL* ssl, long options);+long HsOpenSSL_SSL_clear_options(SSL* ssl, long options);+long HsOpenSSL_SSL_set_tlsext_host_name(SSL* ssl, char* host_name);++int HsOpenSSL_enable_hostname_validation(SSL* ssl, char* host_name, size_t host_len); #endif
examples/HelloWorld.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE OverloadedStrings #-} import Control.Monad+import qualified Data.ByteString.Char8 as B8 import Data.List import Data.Maybe+import Data.Monoid import OpenSSL import OpenSSL.EVP.Cipher import OpenSSL.EVP.Open@@ -12,31 +15,31 @@ main = withOpenSSL $- do putStrLn "cipher: DES-CBC"- des <- liftM fromJust $ getCipherByName "DES-CBC"-+ do putStrLn "cipher: DES3"+ des <- liftM fromJust $ getCipherByName "DES3"+ putStrLn "generating RSA keypair..." rsa <- generateRSAKey 512 65537 Nothing let plainText = "Hello, world!"- putStrLn ("plain text to encrypt: " ++ plainText)+ B8.putStrLn ("plain text to encrypt: " `mappend` plainText) putStrLn "" putStrLn "encrypting..."- (encrypted, [encKey], iv) <- seal des [fromPublicKey rsa] plainText+ (encrypted, [encKey], iv) <- sealBS des [fromPublicKey rsa] plainText - putStrLn ("encrypted symmetric key: " ++ binToHex encKey)- putStrLn ("IV: " ++ binToHex iv)- putStrLn ("encrypted message: " ++ binToHex encrypted)+ B8.putStrLn ("encrypted symmetric key: " `mappend` binToHex encKey)+ B8.putStrLn ("IV: " `mappend` binToHex iv)+ B8.putStrLn ("encrypted message: " `mappend` binToHex encrypted) putStrLn "" putStrLn "decrypting..."- let decrypted = open des encKey iv rsa encrypted+ let decrypted = openBS des encKey iv rsa encrypted - putStrLn ("decrypted message: " ++ decrypted)+ B8.putStrLn ("decrypted message: " `mappend` decrypted) -binToHex :: String -> String-binToHex bin = concat $ intersperse ":" $ map (printf "%02x" . fromEnum) bin+binToHex :: B8.ByteString -> B8.ByteString+binToHex = B8.pack . intercalate ":" . map (printf "%02x" . fromEnum) . B8.unpack
examples/Makefile view
@@ -1,16 +1,17 @@-GHCFLAGS = -O2 -fglasgow-exts+GHCFLAGS = -O2 build: ghc $(GHCFLAGS) --make GenRSAKey ghc $(GHCFLAGS) --make HelloWorld ghc $(GHCFLAGS) --make PKCS7- ghc $(GHCFLAGS) --make Server+ ghc $(GHCFLAGS) --make -threaded Server+ ghc $(GHCFLAGS) --make Client run: build ./PKCS7 # ./HelloWorld clean:- rm -f HelloWorld GenRSAKey PKCS7 Server *.hi *.o+ rm -f HelloWorld GenRSAKey PKCS7 Server Client *.hi *.o .PHONY: build run clean
examples/Server.hs view
@@ -32,6 +32,8 @@ print $ "Accepted connection from " ++ show sockaddr ctx <- SSL.context+ SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2+ SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 SSL.contextSetPrivateKeyFile ctx "server.pem" SSL.contextSetCertificateFile ctx "server.crt" SSL.contextSetCiphers ctx "DEFAULT"@@ -41,4 +43,3 @@ b <- SSL.read conn 1024 SSL.write conn b SSL.shutdown conn SSL.Bidirectional-
− tests/Base64.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Unittest for Base64 [en|de]coding.-module Main where--import Data.Char (ord)-import Data.String-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import OpenSSL.EVP.Base64--{-- Comment by PHO:-- These instance declarations now seem to be part of- Data.ByteString. What should we do then?-- Base64.hs:12:9:- Duplicate instance declarations:- instance IsString BS.ByteString -- Defined at Base64.hs:12:9-30- instance IsString BS.ByteString -- Defined in Data.ByteString.Char8-- Base64.hs:17:9:- Duplicate instance declarations:- instance IsString BSL.ByteString -- Defined at Base64.hs:17:9-31- instance IsString BSL.ByteString- -- Defined in Data.ByteString.Lazy.Char8--}-{--instance IsString BS.ByteString where- fromString = BS.pack . map (fromIntegral . ord)---- Note that this instance packs each charactor as a separate lazy chunk.--- This is to stress the lazy code - not because it's a good idea generally-instance IsString BSL.ByteString where- fromString = BSL.fromChunks . map (BS.singleton . fromIntegral . ord)--}--encodeTests :: [(BS.ByteString, BS.ByteString)]-encodeTests =- [("", "")- ,("a", "YQ==")- ,("aa", "YWE=")- ,("aaa", "YWFh")- ]--lazyEncodeTests :: [(BSL.ByteString, BSL.ByteString)]-lazyEncodeTests =- [("", "")- ,("a", "YQ==")- ,("aa", "YWE=")- ,("aaa", "YWFh")- ]--decodeTests :: [(BS.ByteString, BS.ByteString)]-decodeTests =- [("", "")- ,("aGFza2VsbA==", "haskell")- ,("YWJjZGVmZ2hpams=", "abcdefghijk")- ,("YWJjZGVmZ2hpams=\n", "abcdefghijk")- ]--encoding = all id $ map (\(a, v) -> encodeBase64BS a == v) encodeTests-lazyEncoding = all id $ map (\(a, v) -> encodeBase64LBS a == v) lazyEncodeTests-decoding = all id $ map (\(a, v) -> decodeBase64BS a == v) decodeTests--main = do- mapM_ (print . encodeBase64LBS . fst) lazyEncodeTests- if encoding && lazyEncoding && decoding- then putStrLn "PASS"- else putStrLn "FAIL"
− tests/Cipher.hs
@@ -1,91 +0,0 @@--- | Tests for the non-EVP ciphers-module Main where--import Control.Monad (unless)-import qualified Data.ByteString as BS--import OpenSSL.Cipher---- | Convert a hex string to a ByteString (e.g. "0011" == BS.pack [0, 0x11])-hexToBS [] = BS.empty-hexToBS (a : b : rest) = BS.append (BS.singleton ((valueOfHexChar a * 16) + valueOfHexChar b))- (hexToBS rest)--valueOfHexChar '0' = 0-valueOfHexChar '1' = 1-valueOfHexChar '2' = 2-valueOfHexChar '3' = 3-valueOfHexChar '4' = 4-valueOfHexChar '5' = 5-valueOfHexChar '6' = 6-valueOfHexChar '7' = 7-valueOfHexChar '8' = 8-valueOfHexChar '9' = 9-valueOfHexChar 'a' = 10-valueOfHexChar 'b' = 11-valueOfHexChar 'c' = 12-valueOfHexChar 'd' = 13-valueOfHexChar 'e' = 14-valueOfHexChar 'f' = 15-valueOfHexChar 'A' = 10-valueOfHexChar 'B' = 11-valueOfHexChar 'C' = 12-valueOfHexChar 'D' = 13-valueOfHexChar 'E' = 14-valueOfHexChar 'F' = 15--hexOf 0 = '0'-hexOf 1 = '1'-hexOf 2 = '2'-hexOf 3 = '3'-hexOf 4 = '4'-hexOf 5 = '5'-hexOf 6 = '6'-hexOf 7 = '7'-hexOf 8 = '8'-hexOf 9 = '9'-hexOf 10 = 'a'-hexOf 11 = 'b'-hexOf 12 = 'c'-hexOf 13 = 'd'-hexOf 14 = 'e'-hexOf 15 = 'f'---- | A test containing counter mode test vectors-data CTRTest = CTRTest BS.ByteString -- ^ key- BS.ByteString -- ^ IV- BS.ByteString -- ^ plaintext- BS.ByteString -- ^ cipher text---- Test vectors from draft-ietf-ipsec-ciph-aes-ctr-05 section 6-ctrTests = [- CTRTest (hexToBS "AE6852F8121067CC4BF7A5765577F39E")- (hexToBS "00000030000000000000000000000001")- (hexToBS "53696E676C6520626C6F636B206D7367")- (hexToBS "E4095D4FB7A7B3792D6175A3261311B8"),- CTRTest (hexToBS "7691BE035E5020A8AC6E618529F9A0DC")- (hexToBS "00E0017B27777F3F4A1786F000000001")- (hexToBS "000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F20212223")- (hexToBS "C1CF48A89F2FFDD9CF4652E9EFDB72D74540A42BDE6D7836D59A5CEAAEF3105325B2072F"),- CTRTest (hexToBS "16AF5B145FC9F579C175F93E3BFB0EED863D06CCFDB78515")- (hexToBS "0000004836733C147D6D93CB00000001")- (hexToBS "53696E676C6520626C6F636B206D7367")- (hexToBS "4B55384FE259C9C84E7935A003CBE928"),- CTRTest (hexToBS "FF7A617CE69148E4F1726E2F43581DE2AA62D9F805532EDFF1EED687FB54153D")- (hexToBS "001CC5B751A51D70A1C1114800000001")- (hexToBS "000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F20212223")- (hexToBS "EB6C52821D0BBBF7CE7594462ACA4FAAB407DF866569FD07F48CC0B583D6071F1EC0E6B8") ]--runCtrTest :: CTRTest -> IO Bool-runCtrTest (CTRTest key iv plaintext ciphertext) = do- ctx <- newAESCtx Encrypt key iv- ct <- aesCTR ctx plaintext- return (ct == ciphertext)--runCtrTests :: IO Bool-runCtrTests = fmap (all (== True)) (mapM runCtrTest ctrTests)--main = do- r <- runCtrTests- unless r $ fail "CTR tests failed"- putStrLn "PASS"
− tests/DSA.hs
@@ -1,48 +0,0 @@-module Main where--import Control.Monad-import System.Time-import OpenSSL.DSA-import qualified Data.ByteString as BS---- | This function just runs the example DSA generation, as given in FIP 186-2,--- app 5.-test_generateParameters = do- let seed = BS.pack [0xd5, 0x01, 0x4e, 0x4b,- 0x60, 0xef, 0x2b, 0xa8,- 0xb6, 0x21, 0x1b, 0x40,- 0x62, 0xba, 0x32, 0x24,- 0xe0, 0x42, 0x7d, 0xd3]- (a, b, p, q, g) <- generateDSAParameters 512 $ Just seed- return $ (a, p, q, g) == (105,- 0x8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291,- 0xc773218c737ec8ee993b4f2ded30f48edace915f,- 0x626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802)--testMessage = BS.pack [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20]--test_signVerify = do- dsa <- generateDSAParametersAndKey 512 Nothing- (a, b) <- signDigestedDataWithDSA dsa testMessage- verifyDigestedDataWithDSA dsa testMessage (a, b)--test_signVerifySpeed = do- dsa <- generateDSAParametersAndKey 512 Nothing-- let test = do- (a, b) <- signDigestedDataWithDSA dsa testMessage- True <- verifyDigestedDataWithDSA dsa testMessage (a, b)- return ()-- starttime <- getClockTime- replicateM_ 2000 test- endtime <- getClockTime- print $ diffClockTimes endtime starttime-- return True--main = do- results <- sequence [test_generateParameters, test_signVerify, test_signVerifySpeed]- if all id results- then putStrLn "PASS"- else putStrLn $ "FAIL" ++ show results
− tests/Makefile
@@ -1,11 +0,0 @@-TESTS = \- Base64 \- Cipher \- DSA \- $(NULL)--test:- for i in $(TESTS); do ghc --make $$i; ./$$i; done--clean:- rm -f *.hi *.o $(TESTS)