HsOpenSSL-0.11.3.2/0000755000000000000000000000000013001155766011704 5ustar0000000000000000HsOpenSSL-0.11.3.2/AUTHORS0000644000000000000000000000041513001155766012754 0ustar0000000000000000This is an incomplete list of contributors to the HsOpenSSL: * Adam Langley * John Van Enk and his friend * Mikhail Vorozhtsov * Taru Karttunen * PHO HsOpenSSL-0.11.3.2/ChangeLog0000644000000000000000000005147413001155766013471 0ustar00000000000000002016-10-17 Vladimir Shabanov * 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 * 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 * 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 * 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 * 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 * 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 * 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 * 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 * 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 * 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 * 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 * 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 * OpenSSL/EVP/Cipher.hsc: Expose cipherInit, Patch by rnons (#31). * HsOpenSSL.cabal (Exposed-Modules): Expose OpenSSL.EVP.Internal, Patch by rnons (#31). * HsOpenSSL.cabal (Version): Bump version to 0.10.5 2013-12-25 PHO * OpenSSL/Session.hsc (contextSetCertificateChainFile): Add function to support for setting a certificate chain file, Patch by Jacob Stanley. * HsOpenSSL.cabal (Extra-Source-Files): Add Server-example files, Patch by Jacob Stanley. * HsOpenSSL.cabal (Version): Bump version to 0.10.4 2013-12-11 PHO * OpenSSL.hsc [base < 4.6] (modifyMVar_): Fix compilation, Patch by Gregory Collins. * HsOpenSSL.cabal: Bump version to 0.10.3.6 2013-11-07 PHO * OpenSSL.hsc (withOpenSSL): OpenSSL.withOpenSSL is now safe to be applied redundantly, Suggested by Andrew Cowie (#26). * COPYING: Update the license to CC0: copyright waiver with a public license fallback. See http://creativecommons.org/publicdomain/zero/1.0/ * HsOpenSSL.cabal: Bump version to 0.10.3.5 2013-09-05 PHO * cbits/HsOpenSSL.c, cbits/HsOpenSSL.h: Fix a compilation issue that occurs when using a different builddir with "cabal build --builddir=DIR", Reported by Bit Connor (#23), Gregory Collins (#24) and Bas van Dijk (#25). * HsOpenSSL.cabal: Bump version to 0.10.3.4 2012-08-28 PHO * OpenSSL/Session.hsc: Merged #17 "Use MVar instead of QSem in OpenSSL.Session", Patch by Mikhail Vorozhtsov. * HsOpenSSL.cabal: Bump version to 0.10.3.3 2012-07-21 PHO * OpenSSL/PEM.hsc, OpenSSL/Session.hsc: Merged #15 "Fixed build with base-4.6", Patch by Mikhail Vorozhtsov. * HsOpenSSL.cabal: Added a configuration flag 'fast-bignum' (#16). * HsOpenSSL.cabal: Bump version to 0.10.3.2 2012-04-24 PHO * OpenSSL/X509/Store.hsc: Merged #14 "Fixed X509_STORE_CTX bindings vs OpenSSL 0.9.x", Patch by Mikhail Vorozhtsov. * HsOpenSSL.cabal: Bump version to 0.10.3.1 2012-04-17 PHO * OpenSSL/X509/Store.hsc (getStoreCtxCert, getStoreCtxIssuer) (getStoreCtxCRL, getStoreCtxChain): Merged #12 "Bindings to some of the X509_STORE_CTX functions", Patch by Mikhail Vorozhtsov. * OpenSSL/Session.hsc: Merged #13 "Fixed early verification callback deallocation crash", Patch by Mikhail Vorozhtsov. * HsOpenSSL.cabal: Bump version to 0.10.3 2012-04-16 PHO * OpenSSL/PEM.hsc: Merged #10 "Fix X509 PEM reading/writing", Patch by Mikhail Vorozhtsov. * HsOpenSSL.cabal: Bump version to 0.10.2.1 2012-04-06 PHO * OpenSSL/Session.hsc (readPtr, tryReadPtr, writePtr) (tryWritePtr): Merged #9 "Add raw pointer read/write operations", Patch by Iavor S. Diatchki. * cbits/HsOpenSSL.h: Fixed #8 "HsOpenSSL 0.10.1.4 won't build", Reported by vcxp. * HsOpenSSL.cabal: Bump version to 0.10.2 2012-03-08 PHO * OpenSSL/EVP/Internal.hsc, OpenSSL/X509.hsc: Fixed #7 "Haskell Platform 2011.4 Support", Reported by stepcut. * HsOpenSSL.cabal: Bump version to 0.10.1.4 2012-03-04 PHO * OpenSSL/Session.hsc (SSL, SSLContext, SSLResult, ShutdownType) (VerificationMode): Make these types instances of Typeable. * OpenSSL/Utils.hs: Add Num to constraints with Bits, Patch by Ben Gamari. * OpenSSL/DSA.hsc, OpenSSL/EVP/Base64.hsc, OpenSSL/EVP/Digest.hsc, OpenSSL/EVP/Open.hsc, OpenSSL/RSA.hsc: Use unsafePerformIO from System.IO.Unsafe, Patch by Ben Gamari. * OpenSSL/EVP/Internal.hsc, OpenSSL/X509.hsc: Use unsafeForeignPtrToPtr from Foreign.ForeignPtr.Unsafe, Patch by Ben Gamari. * HsOpenSSL.cabal: Bump version to 0.10.1.3 2011-11-16 PHO * OpenSSL/Session.hsc: SSL_get_error() must be called within the OS thread which caused the failed operation as it inspects the thread-local storage. * OpenSSL/Session.hsc: write/tryWrite should throw EPIPE for cleanly-closed connections rather than EOF. * OpenSSL/Session.hsc: shutdown/tryShutdown shouldn't throw an exception when a remote peer sends us a "close notify" alert and closes the connection without waiting for our reply. * OpenSSL/Session.hsc: ProtocolError should contain an error message string. * OpenSSL/EVP/*: Moved all EVP-related private functions to OpenSSL.EVP.Internal, Patch by Mikhail Vorozhtsov. * HsOpenSSL.cabal: Bump version to 0.10.1.2 2011-09-22 PHO * OpenSSL/Session.hsc: GHC 6.12.3 friendliness: don't use Control.Monad.void, Patch by Peter Gammie. * OpenSSL/BN.hsc, OpenSSL/Cipher.hsc: Placate LLVM in GHC 7.3.x HEAD: give memcpy the right type. Patch by Peter Gammie and David Terei. * OpenSSL/Session.hsc: Use throwIO instead of throw to raise SSL exceptions, Patch by Mikhail Vorozhtsov. * cbits/HsOpenSSL.c, cbits/HsOpenSSL.h: DHparams_dup() is a function in OpenSSL 1.0.0 but is a macro in 0.9.8. * OpenSSL/X509/Revocation.hsc: OpenSSL 0.9.8 doesn't provide X509_CRL_get0_by_serial(). * HsOpenSSL.cabal: Bump version to 0.10.1.1 2011-08-27 PHO * OpenSSL/DH.hsc: Added bindings to Diffie-Hellman functions, Patch by Mikhail Vorozhtsov. * OpenSSL/X509/Revocation.hsc: Added revocation lookup function, Patch by Mikhail Vorozhtsov. * OpenSSL/Session.hsc: Added optional verification callback to VerifyPeer, Patch by Mikhail Vorozhtsov. * OpenSSL/Session.hsc: Expose low-level asynchronous versions of accept, connect, read, write and shutdown, Patch by Mikhail Vorozhtsov. * HsOpenSSL.cabal: Bump version to 0.10.1 2011-07-26 PHO * OpenSSL/Session.hsc (fdConnection, sslSocket): Support wrapping plain file descriptors in SSL connections, Patch by Mikhail Vorozhtsov. * HsOpenSSL.cabal: Bump version to 0.10 2011-06-21 PHO * OpenSSL/BN.hsc: Added missing BangPatterns pragma, Patch by Mikhail Vorozhtsov. * HsOpenSSL.cabal: Bump version to 0.9.0.1 2010-11-13 PHO * OpenSSL/Session.hsc: Operations in OpenSSL.Session now throw exceptions of individual exception types instead of plain strings, Suggested by Arthur Chan. * HsOpenSSL.cabal: Bump version to 0.9 2010-09-19 PHO * HsOpenSSL.cabal: Fix Windows support as suggested in , Reported by Edward Z. Yang. * HsOpenSSL.cabal: Bump version to 0.8.0.2 2010-02-09 PHO * OpenSSL/PEM.hsc: Add PEM-functionality with a new PwBS that works like PwStr except there are no superfluous extra copies retained in the memory, Patch by Taru Karttunen. * OpenSSL/PEM.hsc: Make PEM callbacks use bracket which makes cleanup work even if there are exceptions, Patch by Taru Karttunen. * OpenSSL/EVP/Sign.hsc: Export OpenSSL.EVP.Sign.signFinal, Patch by Taru Karttunen. * OpenSSL/EVP/Sign.hsc: Make OpenSSL.EVP.Sign.signFinal use ByteStrings internally, Patch by Taru Karttunen. * OpenSSL/EVP/Digest.hsc: Document pkcs5_pbkdf2_hmac_sha1 in OpenSSL.EVP.Digest, Patch by Taru Karttunen. * OpenSSL/RSA.hsc: Add rsaCopyPublic and rsaKeyPairFinalize to OpenSSL.RSA, Patch by Taru Karttunen. * OpenSSL/EVP/Cipher.hsc: Add cipherStrictLBS - Encrypt a lazy bytestring in a strict manner. Does not leak the keys, Patch by Taru Karttunen. * HsOpenSSL.cabal: Bump version to 0.8 2010-01-24 PHO * HsOpenSSL.cabal, OpenSSL/BN.hsc: Make HsOpenSSL compatible with GHC 6.12.1, Patch by Taru Karttunen. * HsOpenSSL.cabal: Bump version to 0.7 2009-08-03 PHO * OpenSSL/Cipher.hsc: OpenSSL.Cipher now exports the type AESCtx, Suggested by Carl Mackey. * HsOpenSSL.cabal: Bump version to 0.6.5 2009-07-14 PHO * OpenSSL/BIO.hsc: Unbreak BIO ForeignPtrs for GHC 6.10, Patch by Taru Karttunen. * HsOpenSSL.cabal: Bump version to 0.6.4 2009-07-13 PHO * OpenSSL/EVP/Sign.hsc (signBS, signLBS): These functions should return Strict.Bytestring and Lazy.Bytestring respectively, Suggested by Grant Monroe. * HsOpenSSL.cabal: Bump version to 0.6.3 2009-06-28 PHO * HsOpenSSL.cabal: Moved away from the Configure build type to the Simple build type, Patch by John Van Enk and his friend. * cbits/mutex-*: Removed the direct dependency on pthreads. This involved an indirection layer using the preprocessor. In linux/bsd, we use pthreads. In windows, we call out to the OS mutexing functions. This allows us to "cabal install" the HsOpenSSL library from the cmd.exe terminal in windows *without* having to use cygwin, Patch by John Van Enk and his friend. * HsOpenSSL.cabal: Bump version to 0.6.2 2009-06-02 PHO * OpenSSL/Session.hsc (lazyRead, lazyWrite, contextGetCAStore) (contextSetPrivateKey, contextSetCertificate): New functions. * HsOpenSSL.cabal: Bump version to 0.6.1 2009-03-27 PHO * OpenSSL/DSA.hsc: The data type "DSA" is now broken into two separate types "DSAPubKey" and "DSAKeyPair" to distinguish between public keys and keypairs at type-level. These two data types are instances of class "DSAKey". * OpenSSL/DSA.hsc (generateDSAParameters, generateDSAKey) (generateDSAParametersAndKey, signDigestedDataWithDSA) (verifyDigestedDataWithDSA): Rename functions to avoid name collision with OpenSSL.RSA. * OpenSSL/DSA.hsc (dsaToTuple, tupleToDSA): Break into separate functions. * OpenSSL/RSA.hsc: The data type "RSA" is now broken into two separate types "RSAPubKey" and "RSAKeyPair" to distinguish between public keys and keypairs at type-level. These two data types are instances of class "RSAKey". * OpenSSL/EVP/PKey.hsc: The data type "PKey" is now broken into two separate classes, not data types, "PublicKey" and "KeyPair" to distinguish between public keys and keypairs at type-level. You can pass "RSAPubKey" and such like directly to cryptographic functions instead of the prior polymorphic type "PKey", for the sake of type classes. * OpenSSL/EVP/Open.hsc (open, openBS, openLBS): Take "KeyPair k" instead of "PKey". * OpenSSL/EVP/Seal.hsc (seal, sealBS, sealLBS): Take "SomePublicKey" instead of "PKey". * OpenSSL/EVP/Sign.hsc (sign, signBS, signLBS): Take "KeyPair k" instead of "PKey". * OpenSSL/EVP/Verify.hsc (verify, verifyBS, verifyLBS): Take "PublicKey k" instead of "PKey". * OpenSSL/PEM.hsc (writePKCS8PrivateKey, readPrivateKey) (writePublicKey, readPublicKey): Take/return "KeyPair k", "SomKeyPair", "PublicKey k", or "SomePublicKey" instead of "PKey". * OpenSSL/PKCS7.hsc (pkcs7Sign, pkcs7Decrypt): Take "KeyPair k" instead of "PKey". * OpenSSL/X509.hsc (signX509, verifyX509, getPublicKey) (setPublicKey): Take/return "KeyPair k", "PublicKey k", or "SomePublicKey" instead of "PKey". * OpenSSL/X509/Request.hsc (signX509Req, verifyX509Req) (getPublicKey, setPublicKey): Take/return "KeyPair k", "PublicKey k", or "SomePublicKey" instead of "PKey". * OpenSSL/X509/Revocation.hsc (signCRL, verifyCRL): Take "KeyPair k" or "PublicKey k" instead of "PKey". * OpenSSL/RSA.hsc (RSAPubKey, RSAKeyPair): Let these types be instances of Eq, Ord and Show. * OpenSSL/RSA.hsc (generateRSAKey'): New function. * OpenSSL/DSA.hsc (DSAPubKey, DSAKeyPair): Let these types be instances of Eq, Ord and Show. * HsOpenSSL.cabal: Bump version to 0.6 2009-02-20 PHO * HsOpenSSL.cabal: Fix incorrect dependency declaration in HsOpenSSL.cabal. No semantical changes to the code. * HsOpenSSL.cabal: Bump version to 0.5.2 2009-02-02 PHO * OpenSSL/**/*.hsc: Fix breakage on 64-bit architectures, Reported by Neumark Péter. * HsOpenSSL.cabal: Bump version to 0.5.1 2009-01-14 PHO * OpenSSL/BN.hsc, OpenSSL/PEM.hsc: Fix breakage on GHC 6.10.1, and now requires 6.10.1... * OpenSSL/EVP/Digest.hsc (pkcs5_pbkdf2_hmac_sha1): New function, Patch by Taru Karttunen. * HsOpenSSL.cabal: Bump version to 0.5 2008-06-11 PHO * HsOpenSSL.cabal: No .hs files which are generated from .hsc files should be in the tarball. If any .hs files are outdated, Cabal seems to compile the outdated files instead of newer .hsc files. * HsOpenSSL.cabal: Bump version to 0.4.2 2008-03-19 PHO * OpenSSL/Session.hsc: Turn the Session IO inside out, Patch by Adam Langley. * OpenSSL/EVP/Digest.hsc: 64-bit fix for HMAC, Patch by Adam Langley. * OpenSSL/EVP/Cipher.hsc: Fix the foreign types of the cipher functions to use CInt, not Int, Patch by Adam Langley. * OpenSSL/EVP/Digest.hsc: Add ByteString version of digestBS, Patch by Adam Langley. * OpenSSL/BN.hsc: Fix BN<->Integer conversions on 64-bit systems, Patch by Adam Langley. * OpenSSL/ASN1.hsc (peekASN1String): Another 64-bit fix, Patch by Adam Langley. * HsOpenSSL.cabal: Bump version to 0.4.1 2008-02-14 PHO * OpenSSL/Session.hsc: Add the beginnings of session support, Patch by Adam Langley. * HsOpenSSL.cabal: Bump version to 0.4 2007-11-05 PHO * OpenSSL/EVP/Base64.hsc (decodeBlock): decodeBase64* weren't dropping the padding NUL. * HsOpenSSL.cabal: Updates for 6.8.1 (also *requires* 6.8.1 now), Patch by Adam Langley * HsOpenSSL.cabal: Bump version to 0.3.1 2007-10-29 PHO * OpenSSL/Cipher.hsc: Add non-EVP cipher support, Patch by Adam Langley. * OpenSSL/EVP/Digest.hsc: Add HMAC support in EVP, Patch by Adam Langley. * OpenSSL/Random.hsc: Add OpenSSL.Random, Patch by Adam Langley. * OpenSSL/BN.hsc: Additional utility functions in BN and exposing BN, Patch by Adam Langley. * OpenSSL/BN.hsc: Bug fix for fast Integer<->BN functions, Patch by Adam Langley. * HsOpenSSL.cabal: Bump version to 0.3 2007-10-14 PHO * OpenSSL/BN.hsc: Add support for fast Integer<->BN conversions, Patch by Adam Langley. * OpenSSL/DSA.hsc: Add DSA support, Patch by Adam Langley. * OpenSSL/BN.hsc (newBN): New BN utility function, Patch by Adam Langley. * OpenSSL/BN.hsc: FIX: set the BN ptr to NULL before calling BN_dec2bn, otherwise that function thinks that there's a valid BN there, Patch by Adam Langley. * OpenSSL/Utils.hsc: Add utility functions to print and read hex numbers, Patch by Adam Langley. * HsOpenSSL.cabal: Bump version to 0.2 2007-08-25 PHO * HsOpenSSL.hsc: Move hidden modules from Exposed-Modules to Other-Modules. * HsOpenSSL.cabal: Bump version to 0.1.1 HsOpenSSL-0.11.3.2/COPYING0000644000000000000000000001561013001155766012742 0ustar0000000000000000Creative Commons Legal Code CC0 1.0 Universal CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED HEREUNDER. Statement of Purpose The laws of most jurisdictions throughout the world automatically confer exclusive Copyright and Related Rights (defined below) upon the creator and subsequent owner(s) (each and all, an "owner") of an original work of authorship and/or a database (each, a "Work"). Certain owners wish to permanently relinquish those rights to a Work for the purpose of contributing to a commons of creative, cultural and scientific works ("Commons") that the public can reliably and without fear of later claims of infringement build upon, modify, incorporate in other works, reuse and redistribute as freely as possible in any form whatsoever and for any purposes, including without limitation commercial purposes. These owners may contribute to the Commons to promote the ideal of a free culture and the further production of creative, cultural and scientific works, or to gain reputation or greater distribution for their Work in part through the use and efforts of others. For these and/or other purposes and motivations, and without any expectation of additional consideration or compensation, the person associating CC0 with a Work (the "Affirmer"), to the extent that he or she is an owner of Copyright and Related Rights in the Work, voluntarily elects to apply CC0 to the Work and publicly distribute the Work under its terms, with knowledge of his or her Copyright and Related Rights in the Work and the meaning and intended legal effect of CC0 on those rights. 1. Copyright and Related Rights. A Work made available under CC0 may be protected by copyright and related or neighboring rights ("Copyright and Related Rights"). Copyright and Related Rights include, but are not limited to, the following: i. the right to reproduce, adapt, distribute, perform, display, communicate, and translate a Work; ii. moral rights retained by the original author(s) and/or performer(s); iii. publicity and privacy rights pertaining to a person's image or likeness depicted in a Work; iv. rights protecting against unfair competition in regards to a Work, subject to the limitations in paragraph 4(a), below; v. rights protecting the extraction, dissemination, use and reuse of data in a Work; vi. database rights (such as those arising under Directive 96/9/EC of the European Parliament and of the Council of 11 March 1996 on the legal protection of databases, and under any national implementation thereof, including any amended or successor version of such directive); and vii. other similar, equivalent or corresponding rights throughout the world based on applicable law or treaty, and any national implementations thereof. 2. Waiver. To the greatest extent permitted by, but not in contravention of, applicable law, Affirmer hereby overtly, fully, permanently, irrevocably and unconditionally waives, abandons, and surrenders all of Affirmer's Copyright and Related Rights and associated claims and causes of action, whether now known or unknown (including existing as well as future claims and causes of action), in the Work (i) in all territories worldwide, (ii) for the maximum duration provided by applicable law or treaty (including future time extensions), (iii) in any current or future medium and for any number of copies, and (iv) for any purpose whatsoever, including without limitation commercial, advertising or promotional purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each member of the public at large and to the detriment of Affirmer's heirs and successors, fully intending that such Waiver shall not be subject to revocation, rescission, cancellation, termination, or any other legal or equitable action to disrupt the quiet enjoyment of the Work by the public as contemplated by Affirmer's express Statement of Purpose. 3. Public License Fallback. Should any part of the Waiver for any reason be judged legally invalid or ineffective under applicable law, then the Waiver shall be preserved to the maximum extent permitted taking into account Affirmer's express Statement of Purpose. In addition, to the extent the Waiver is so judged Affirmer hereby grants to each affected person a royalty-free, non transferable, non sublicensable, non exclusive, irrevocable and unconditional license to exercise Affirmer's Copyright and Related Rights in the Work (i) in all territories worldwide, (ii) for the maximum duration provided by applicable law or treaty (including future time extensions), (iii) in any current or future medium and for any number of copies, and (iv) for any purpose whatsoever, including without limitation commercial, advertising or promotional purposes (the "License"). The License shall be deemed effective as of the date CC0 was applied by Affirmer to the Work. Should any part of the License for any reason be judged legally invalid or ineffective under applicable law, such partial invalidity or ineffectiveness shall not invalidate the remainder of the License, and in such case Affirmer hereby affirms that he or she will not (i) exercise any of his or her remaining Copyright and Related Rights in the Work or (ii) assert any associated claims and causes of action with respect to the Work, in either case contrary to Affirmer's express Statement of Purpose. 4. Limitations and Disclaimers. a. No trademark or patent rights held by Affirmer are waived, abandoned, surrendered, licensed or otherwise affected by this document. b. Affirmer offers the Work as-is and makes no representations or warranties of any kind concerning the Work, express, implied, statutory or otherwise, including without limitation warranties of title, merchantability, fitness for a particular purpose, non infringement, or the absence of latent or other defects, accuracy, or the present or absence of errors, whether or not discoverable, all to the greatest extent permissible under applicable law. c. Affirmer disclaims responsibility for clearing rights of other persons that may apply to the Work or any use thereof, including without limitation any person's Copyright and Related Rights in the Work. Further, Affirmer disclaims responsibility for obtaining any necessary consents, permissions or other rights required for any use of the Work. d. Affirmer understands and acknowledges that Creative Commons is not a party to this document and has no duty or obligation with respect to this CC0 or use of the Work. HsOpenSSL-0.11.3.2/HsOpenSSL.cabal0000644000000000000000000001235413001155766014453 0ustar0000000000000000Name: 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 also some capabilities of creating SSL clients and servers. . This package is in production use by a number of Haskell based systems and stable. You may also be interested in the @tls@ package, , which is a pure Haskell implementation of SSL. . Version: 0.11.3.2 License: PublicDomain License-File: COPYING Author: Adam Langley, Mikhail Vorozhtsov, PHO, Taru Karttunen Maintainer: Vladimir Shabanov Stability: stable Homepage: https://github.com/vshabanov/HsOpenSSL Bug-Reports: https://github.com/vshabanov/HsOpenSSL/issues Category: Cryptography Cabal-Version: >= 1.12 Tested-With: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 Build-Type: Custom Extra-Source-Files: AUTHORS ChangeLog README.md cbits/HsOpenSSL.h cbits/mutex.h examples/Makefile examples/GenRSAKey.hs examples/HelloWorld.hs examples/PKCS7.hs examples/Server.hs examples/server.crt examples/server.pem Source-Repository head Type: git Location: git://github.com/vshabanov/HsOpenSSL.git Flag fast-bignum Description: Enable fast moving of bignums between OpenSSL and GMP (GHC only). Default: True 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 Library Build-Depends: base >= 4.4 && < 5, bytestring >= 0.9 && < 0.11, network >= 2.1 && < 2.7, time >= 1.5 && < 1.7 if flag(fast-bignum) CPP-Options: -DFAST_BIGNUM if impl(ghc >= 6.11) -- TODO: integer-gmp >= 1 is not supported yet. -- https://github.com/phonohawk/HsOpenSSL/issues/36 Build-Depends: integer-gmp >= 0.2 && < 1 -- Doesn't work since GHC 7.10.1 (integer-gmp-1.0.0.0) else Build-Depends: ghc-prim, integer if os(darwin) && flag(homebrew-openssl) 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 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 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 OpenSSL.SSL.Option OpenSSL.Stack OpenSSL.Utils OpenSSL.X509.Name OpenSSL.DH.Internal Default-Language: Haskell2010 GHC-Options: -Wall C-Sources: cbits/HsOpenSSL.c Include-Dirs: cbits Includes: openssl/asn1.h Test-Suite test-cipher Type: exitcode-stdio-1.0 Main-Is: Test/OpenSSL/Cipher.hs Other-Modules: Test.OpenSSL.TestUtils Build-Depends: HsOpenSSL, base >= 4.4 && < 5, bytestring >= 0.9 && < 0.11 Default-Language: Haskell2010 GHC-Options: -Wall Test-Suite test-dsa Type: exitcode-stdio-1.0 Main-Is: Test/OpenSSL/DSA.hs Other-Modules: Test.OpenSSL.TestUtils Build-Depends: HsOpenSSL, base >= 4.4 && < 5, bytestring >= 0.9 && < 0.11 Default-Language: Haskell2010 GHC-Options: -Wall Test-Suite test-der Type: exitcode-stdio-1.0 Main-Is: Test/OpenSSL/DER.hs Other-Modules: Test.OpenSSL.TestUtils Build-Depends: HsOpenSSL, base >= 4.4 && < 5 Default-Language: Haskell2010 GHC-Options: -Wall Test-Suite test-evp-base64 Type: exitcode-stdio-1.0 Main-Is: Test/OpenSSL/EVP/Base64.hs Other-Modules: Test.OpenSSL.TestUtils Build-Depends: HsOpenSSL, base >= 4.4 && < 5, bytestring >= 0.9 && < 0.11 Default-Language: Haskell2010 GHC-Options: -Wall HsOpenSSL-0.11.3.2/OpenSSL.hs0000644000000000000000000000736013001155766013531 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- |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 (), 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 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 HsOpenSSL-0.11.3.2/README.md0000644000000000000000000000063413001155766013166 0ustar0000000000000000HsOpenSSL ========== [![Build Status](https://travis-ci.org/vshabanov/HsOpenSSL.svg?branch=master)](https://travis-ci.org/vshabanov/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. HsOpenSSL-0.11.3.2/Setup.hs0000644000000000000000000000662313001155766013347 0ustar0000000000000000#!/usr/bin/env runghc {-# LANGUAGE TupleSections #-} import Distribution.Simple import Distribution.Simple.Setup (ConfigFlags(..), toFlag) import Distribution.Simple.LocalBuildInfo (localPkgDescr) import Distribution.PackageDescription (FlagName(..)) import Distribution.Verbosity (silent) import System.Info (os) import qualified Control.Exception as E (tryJust, throw) import System.IO.Error (isUserError) import Control.Monad (forM) import Data.List -- On macOS we're checking whether OpenSSL library is avaiable -- and if not, we're trying to find Homebrew or MacPorts OpenSSL installations. -- -- Method is dumb -- set homebrew-openssl or macports-openssl flag and try -- to configure and check C libs. -- -- If no or multiple libraries are found we display error message -- with instructions. main | os == "darwin" = defaultMainWithHooks simpleUserHooks { confHook = conf } | otherwise = defaultMain flags = ["homebrew-openssl", "macports-openssl"] conf descr cfg = do c <- tryConfig descr cfg case c of Right lbi -> return lbi -- library was found Left e | configConfigurationsFlags cfg `intersect` [(FlagName f, True) | f <- flags] /= [] -> E.throw e -- flag was set but library still wasn't found | otherwise -> do r <- forM flags $ \ f -> fmap (f,) $ tryConfig descr $ setFlag f cfg { configVerbosity = toFlag silent } -- TODO: configure is a long operation -- while checkForeignDeps is fast. -- Perhaps there is a way to configure once -- and only apply flags to result and check. -- However, additional `configure`s happen only on macOS -- and only when library wasn't found. case [(f,r) | (f, Right r) <- r] of [(_,lbi)] -> return lbi -- library was found [] -> fail notFound fs -> fail $ multipleFound fs notFound = "Can't find OpenSSL library,\n\ \install it via 'brew install openssl' or 'port install openssl'\n\ \or use --extra-include-dirs= and --extra-lib-dirs=\n\ \to specify location of installed OpenSSL library." multipleFound fs = "Multiple OpenSSL libraries were found,\n\ \use " ++ intercalate " or " ["'-f " ++ f ++ "'" | (f,_) <- fs] ++ "\n\ \to specify location of installed OpenSSL library." setFlag f c = c { configConfigurationsFlags = go (configConfigurationsFlags c) } where go [] = [] go (x@(FlagName n, _):xs) | n == f = (FlagName f, True) : xs | otherwise = x : go xs tryConfig descr flags = do lbi <- confHook simpleUserHooks descr flags -- confHook simpleUserHooks == Distribution.Simple.Configure.configure -- Testing whether C lib and header dependencies are working. -- We check exceptions only here, to check C libs errors but not other -- configuration problems like not resolved .cabal dependencies. E.tryJust ue $ do postConf simpleUserHooks [] flags (localPkgDescr lbi) lbi -- postConf simpleUserHooks ~== -- Distribution.Simple.Configure.checkForeignDeps return lbi where ue e | isUserError e = Just e | otherwise = Nothing HsOpenSSL-0.11.3.2/cbits/0000755000000000000000000000000013001155766013010 5ustar0000000000000000HsOpenSSL-0.11.3.2/cbits/HsOpenSSL.c0000644000000000000000000002010413001155766014727 0ustar0000000000000000#define HSOPENSSL_NEED_NOT_INCLUDE_CABAL_MACROS_H 1 #include "HsOpenSSL.h" #include #include "mutex.h" /* OpenSSL ********************************************************************/ void HsOpenSSL_OpenSSL_add_all_algorithms() { OpenSSL_add_all_algorithms(); } void HsOpenSSL_OPENSSL_free(void* ptr) { OPENSSL_free(ptr); } /* BIO ************************************************************************/ void HsOpenSSL_BIO_set_flags(BIO* bio, int flags) { BIO_set_flags(bio, flags); } int HsOpenSSL_BIO_flush(BIO* bio) { return BIO_flush(bio); } int HsOpenSSL_BIO_reset(BIO* bio) { return BIO_reset(bio); } int HsOpenSSL_BIO_eof(BIO* bio) { return BIO_eof(bio); } int HsOpenSSL_BIO_set_md(BIO* bio, EVP_MD* md) { return BIO_set_md(bio, md); } int HsOpenSSL_BIO_set_buffer_size(BIO* bio, int bufSize) { return BIO_set_buffer_size(bio, bufSize); } int HsOpenSSL_BIO_should_retry(BIO* bio) { return BIO_should_retry(bio); } int HsOpenSSL_BIO_FLAGS_BASE64_NO_NL() { return BIO_FLAGS_BASE64_NO_NL; } /* DH *************************************************************************/ DH* HsOpenSSL_DHparams_dup(DH* dh) { return DHparams_dup(dh); } /* EVP ************************************************************************/ int HsOpenSSL_EVP_MD_size(EVP_MD* md) { return EVP_MD_size(md); } int HsOpenSSL_EVP_CIPHER_CTX_block_size(EVP_CIPHER_CTX* ctx) { return EVP_CIPHER_CTX_block_size(ctx); } int HsOpenSSL_EVP_CIPHER_iv_length(EVP_CIPHER* cipher) { return EVP_CIPHER_iv_length(cipher); } /* X509 ***********************************************************************/ long HsOpenSSL_X509_get_version(X509* x509) { return X509_get_version(x509); } ASN1_TIME* HsOpenSSL_X509_get_notBefore(X509* x509) { return X509_get_notBefore(x509); } ASN1_TIME* HsOpenSSL_X509_get_notAfter(X509* x509) { return X509_get_notAfter(x509); } long HsOpenSSL_X509_REQ_get_version(X509_REQ* req) { return X509_REQ_get_version(req); } X509_NAME* HsOpenSSL_X509_REQ_get_subject_name(X509_REQ* req) { return X509_REQ_get_subject_name(req); } long HsOpenSSL_X509_CRL_get_version(X509_CRL* crl) { return X509_CRL_get_version(crl); } ASN1_TIME* HsOpenSSL_X509_CRL_get_lastUpdate(X509_CRL* crl) { return X509_CRL_get_lastUpdate(crl); } ASN1_TIME* HsOpenSSL_X509_CRL_get_nextUpdate(X509_CRL* crl) { return X509_CRL_get_nextUpdate(crl); } X509_NAME* HsOpenSSL_X509_CRL_get_issuer(X509_CRL* crl) { return X509_CRL_get_issuer(crl); } STACK_OF(X509_REVOKED)* HsOpenSSL_X509_CRL_get_REVOKED(X509_CRL* crl) { return X509_CRL_get_REVOKED(crl); } void HsOpenSSL_X509_ref(X509* x509) { CRYPTO_add(&x509->references, 1, CRYPTO_LOCK_X509); } void HsOpenSSL_X509_CRL_ref(X509_CRL* crl) { CRYPTO_add(&crl->references, 1, CRYPTO_LOCK_X509_CRL); } X509* HsOpenSSL_X509_STORE_CTX_get0_current_issuer(X509_STORE_CTX *ctx) { #if OPENSSL_VERSION_NUMBER >= 0x10000000L return X509_STORE_CTX_get0_current_issuer(ctx); #else return ctx->current_issuer; #endif } X509_CRL* HsOpenSSL_X509_STORE_CTX_get0_current_crl(X509_STORE_CTX *ctx) { #if OPENSSL_VERSION_NUMBER >= 0x10000000L return X509_STORE_CTX_get0_current_crl(ctx); #else return ctx->current_crl; #endif } /* PKCS#7 *********************************************************************/ long HsOpenSSL_PKCS7_is_detached(PKCS7* pkcs7) { return PKCS7_is_detached(pkcs7); } /* DH *************************************************************************/ BIGNUM *HsOpenSSL_DH_get_pub_key(DH *dh) { return dh->pub_key; } int HsOpenSSL_DH_length(DH *dh) { return BN_num_bits(dh->p); } /* ASN1 ***********************************************************************/ ASN1_INTEGER* HsOpenSSL_M_ASN1_INTEGER_new() { return M_ASN1_INTEGER_new(); } void HsOpenSSL_M_ASN1_INTEGER_free(ASN1_INTEGER* intPtr) { M_ASN1_INTEGER_free(intPtr); } ASN1_INTEGER* HsOpenSSL_M_ASN1_TIME_new() { return M_ASN1_TIME_new(); } void HsOpenSSL_M_ASN1_TIME_free(ASN1_TIME* timePtr) { M_ASN1_TIME_free(timePtr); } /* Threads ********************************************************************/ static mutex_t* mutex_at; struct CRYPTO_dynlock_value { mutex_t mutex; }; static void HsOpenSSL_lockingCallback(int mode, int n, const char* file, int line) { if (mode & CRYPTO_LOCK) { mutex_lock(&mutex_at[n]); } else { mutex_unlock(&mutex_at[n]); } } static unsigned long HsOpenSSL_idCallback() { return (unsigned long)self(); } static struct CRYPTO_dynlock_value* HsOpenSSL_dynlockCreateCallback(const char* file, int line) { struct CRYPTO_dynlock_value* val; val = OPENSSL_malloc(sizeof(struct CRYPTO_dynlock_value)); mutex_init(&val->mutex); return val; } static void HsOpenSSL_dynlockLockCallback(int mode, struct CRYPTO_dynlock_value* val, const char* file, int line) { if (mode & CRYPTO_LOCK) { mutex_lock(&val->mutex); } else { mutex_unlock(&val->mutex); } } static void HsOpenSSL_dynlockDestroyCallback(struct CRYPTO_dynlock_value* val, const char* file, int line) { mutex_destroy(&val->mutex); OPENSSL_free(val); } void HsOpenSSL_setupMutex() { int i; mutex_at = OPENSSL_malloc(CRYPTO_num_locks() * sizeof(*mutex_at)); for (i = 0; i < CRYPTO_num_locks(); i++) { mutex_init(&mutex_at[i]); } CRYPTO_set_locking_callback(HsOpenSSL_lockingCallback); CRYPTO_set_id_callback(HsOpenSSL_idCallback); CRYPTO_set_dynlock_create_callback(HsOpenSSL_dynlockCreateCallback); CRYPTO_set_dynlock_lock_callback(HsOpenSSL_dynlockLockCallback); CRYPTO_set_dynlock_destroy_callback(HsOpenSSL_dynlockDestroyCallback); } /* DSA ************************************************************************/ /* 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) { 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; } int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int dlen, BIGNUM *r, BIGNUM *s) { DSA_SIG sig; sig.r = r; sig.s = s; return dsa->meth->dsa_do_verify(ddata, dlen, &sig, dsa); } #if !defined(DSAPublicKey_dup) # define DSAPublicKey_dup(dsa) \ (DSA *)ASN1_dup((i2d_of_void *)i2d_DSAPublicKey, \ (d2i_of_void *)d2i_DSAPublicKey,(char *)dsa) #endif #if !defined(DSAPrivateKey_dup) #define DSAPrivateKey_dup(dsa) \ (DSA *)ASN1_dup((i2d_of_void *)i2d_DSAPrivateKey, \ (d2i_of_void *)d2i_DSAPrivateKey,(char *)dsa) #endif DSA* HsOpenSSL_DSAPublicKey_dup(const DSA* dsa) { return DSAPublicKey_dup(dsa); } 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 } HsOpenSSL-0.11.3.2/cbits/HsOpenSSL.h0000644000000000000000000000754413001155766014751 0ustar0000000000000000#ifndef HSOPENSSL_H_INCLUDED #define HSOPENSSL_H_INCLUDED #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include /* 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" #endif /* OpenSSL ********************************************************************/ void HsOpenSSL_OpenSSL_add_all_algorithms(); void HsOpenSSL_OPENSSL_free(void* ptr); /* BIO ************************************************************************/ void HsOpenSSL_BIO_set_flags(BIO* bio, int flags); int HsOpenSSL_BIO_flush(BIO* bio); int HsOpenSSL_BIO_reset(BIO* bio); int HsOpenSSL_BIO_eof(BIO* bio); int HsOpenSSL_BIO_set_md(BIO* bio, EVP_MD* md); int HsOpenSSL_BIO_set_buffer_size(BIO* bio, int bufSize); int HsOpenSSL_BIO_should_retry(BIO* bio); int HsOpenSSL_BIO_FLAGS_BASE64_NO_NL(); /* DH *************************************************************************/ DH* HsOpenSSL_DHparams_dup(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); /* X509 ***********************************************************************/ long HsOpenSSL_X509_get_version(X509* x509); ASN1_TIME* HsOpenSSL_X509_get_notBefore(X509* x509); ASN1_TIME* HsOpenSSL_X509_get_notAfter(X509* x509); long HsOpenSSL_X509_REQ_get_version(X509_REQ* req); 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); X509_NAME* HsOpenSSL_X509_CRL_get_issuer(X509_CRL* crl); STACK_OF(X509_REVOKED)* HsOpenSSL_X509_CRL_get_REVOKED(X509_CRL* crl); /* PKCS#7 *********************************************************************/ long HsOpenSSL_PKCS7_is_detached(PKCS7* pkcs7); /* ASN1 ***********************************************************************/ ASN1_INTEGER* HsOpenSSL_M_ASN1_INTEGER_new(); void HsOpenSSL_M_ASN1_INTEGER_free(ASN1_INTEGER* intPtr); ASN1_INTEGER* HsOpenSSL_M_ASN1_TIME_new(); void HsOpenSSL_M_ASN1_TIME_free(ASN1_TIME* timePtr); /* Threads ********************************************************************/ void HsOpenSSL_setupMutex(); /* DSA ************************************************************************/ int HsOpenSSL_dsa_sign(DSA *dsa, const unsigned char *ddata, int len, BIGNUM **r, BIGNUM **s); int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int len, BIGNUM *r, 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); #endif HsOpenSSL-0.11.3.2/cbits/mutex-pthread.c0000644000000000000000000000055513001155766015750 0ustar0000000000000000#include "mutex.h" void mutex_init(mutex_t* mutex) { pthread_mutex_init(mutex, NULL); } void mutex_destroy(mutex_t* mutex) { pthread_mutex_destroy(mutex); } void mutex_lock(mutex_t* mutex) { pthread_mutex_lock(mutex); } void mutex_unlock(mutex_t* mutex) { pthread_mutex_unlock(mutex); } unsigned long self() { return (unsigned long)pthread_self(); } HsOpenSSL-0.11.3.2/cbits/mutex-win.c0000644000000000000000000000054213001155766015112 0ustar0000000000000000#include "mutex.h" void mutex_init(mutex_t* mutex) { *mutex = CreateMutex(NULL, FALSE, NULL); } void mutex_destroy(mutex_t* mutex) { CloseHandle(*mutex); } void mutex_lock(mutex_t* mutex) { WaitForSingleObject(mutex, INFINITE); } void mutex_unlock(mutex_t* mutex) { ReleaseMutex(mutex); } unsigned long self() { return GetCurrentThreadId(); } HsOpenSSL-0.11.3.2/cbits/mutex.h0000644000000000000000000000070613001155766014326 0ustar0000000000000000#ifndef HSOPENSSL_MUTEX_H_INCLUDED #define HSOPENSSL_MUTEX_H_INCLUDED #if defined(MINGW32) #include typedef HANDLE mutex_t; #elif defined(PTHREAD) #include typedef pthread_mutex_t mutex_t; #else #error "ERROR: This platform is not supported." #endif void mutex_init(mutex_t* mutex); void mutex_destroy(mutex_t* mutex); void mutex_lock(mutex_t* mutex); void mutex_unlock(mutex_t* mutex); unsigned long self(); #endif HsOpenSSL-0.11.3.2/examples/0000755000000000000000000000000013001155766013522 5ustar0000000000000000HsOpenSSL-0.11.3.2/examples/GenRSAKey.hs0000644000000000000000000000236613001155766015615 0ustar0000000000000000import Control.Monad hiding (join) import OpenSSL import OpenSSL.EVP.PKey import OpenSSL.PEM import OpenSSL.RSA import System.IO import Text.Printf main = withOpenSSL $ do let keyBits = 512 keyE = 65537 printf "Generating RSA key-pair, nbits = %d, e = %d:\n" keyBits keyE rsa <- generateRSAKey keyBits keyE $ Just $ \ phase _ -> do putChar $ case phase of 0 -> '.' 1 -> '+' 2 -> '*' 3 -> '\n' n -> head $ show n hFlush stdout printf "Done.\n" let n = rsaN rsa e = rsaE rsa d = rsaD rsa p = rsaP rsa q = rsaQ rsa printf "n (public modulus) = %s\n" (show n) printf "e (public exponent) = %s\n" (show e) printf "d (private exponent) = %s\n" (show d) printf "p (secret prime factor) = %s\n" (show p) printf "q (secret prime factor) = %s\n" (show q) writePKCS8PrivateKey rsa Nothing >>= putStr writePublicKey rsa >>= putStr HsOpenSSL-0.11.3.2/examples/HelloWorld.hs0000644000000000000000000000245613001155766016140 0ustar0000000000000000{-# 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 import OpenSSL.EVP.PKey import OpenSSL.EVP.Seal import OpenSSL.PEM import OpenSSL.RSA import Text.Printf main = withOpenSSL $ do putStrLn "cipher: DES-CBC" des <- liftM fromJust $ getCipherByName "DES-CBC" putStrLn "generating RSA keypair..." rsa <- generateRSAKey 512 65537 Nothing let plainText = "Hello, world!" B8.putStrLn ("plain text to encrypt: " `mappend` plainText) putStrLn "" putStrLn "encrypting..." (encrypted, [encKey], iv) <- sealBS des [fromPublicKey rsa] plainText 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 = openBS des encKey iv rsa encrypted B8.putStrLn ("decrypted message: " `mappend` decrypted) binToHex :: B8.ByteString -> B8.ByteString binToHex = B8.pack . intercalate ":" . map (printf "%02x" . fromEnum) . B8.unpack HsOpenSSL-0.11.3.2/examples/Makefile0000644000000000000000000000050013001155766015155 0ustar0000000000000000GHCFLAGS = -O2 build: ghc $(GHCFLAGS) --make GenRSAKey ghc $(GHCFLAGS) --make HelloWorld ghc $(GHCFLAGS) --make PKCS7 ghc $(GHCFLAGS) --make -threaded Server ghc $(GHCFLAGS) --make Client run: build ./PKCS7 # ./HelloWorld clean: rm -f HelloWorld GenRSAKey PKCS7 Server Client *.hi *.o .PHONY: build run clean HsOpenSSL-0.11.3.2/examples/PKCS7.hs0000644000000000000000000000203513001155766014705 0ustar0000000000000000import Control.Monad import Data.Time.Clock import Data.Time.Calendar import Data.Maybe import OpenSSL import OpenSSL.PKCS7 import OpenSSL.EVP.Cipher import OpenSSL.EVP.PKey import OpenSSL.PEM import OpenSSL.RSA import OpenSSL.X509 import OpenSSL.X509.Store main = withOpenSSL $ do rsa <- generateRSAKey 512 65537 Nothing cert <- genCert rsa pkcs7 <- pkcs7Sign cert rsa [] "Hello, world!" [Pkcs7NoCerts] store <- newX509Store addCertToStore store cert pkcs7Verify pkcs7 [cert] store Nothing [] >>= print return () genCert :: KeyPair k => k -> IO X509 genCert pkey = do x509 <- newX509 setVersion x509 2 setSerialNumber x509 1 setIssuerName x509 [("C", "JP")] setSubjectName x509 [("C", "JP")] setNotBefore x509 =<< liftM (addUTCTime (-1)) getCurrentTime setNotAfter x509 =<< liftM (addUTCTime (365 * 24 * 60 * 60)) getCurrentTime setPublicKey x509 pkey signX509 x509 pkey Nothing return x509 HsOpenSSL-0.11.3.2/examples/server.crt0000644000000000000000000000202213001155766015536 0ustar0000000000000000-----BEGIN CERTIFICATE----- MIIC1TCCAj6gAwIBAgIJAK8d9L3ArBp+MA0GCSqGSIb3DQEBBQUAMFExCzAJBgNV BAYTAlVTMRMwEQYDVQQIEwpDYWxpZm9ybmlhMRYwFAYDVQQHEw1TYW4gRnJhbmNp c2NvMRUwEwYDVQQKEwxUZXN0aW5nIEx0ZC4wHhcNMDgwMjEzMTg1NzIwWhcNMTgw MjEwMTg1NzIwWjBRMQswCQYDVQQGEwJVUzETMBEGA1UECBMKQ2FsaWZvcm5pYTEW MBQGA1UEBxMNU2FuIEZyYW5jaXNjbzEVMBMGA1UEChMMVGVzdGluZyBMdGQuMIGf MA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCbeCZfNbMAGpFeE/ttioZhIWCP3xKU OX+ZNsMa3m3+olXx7xBjJIiF7u2VT7EqAnrdk2L8YqfDT543ihEJ6STBcrR8JCYw SE45QQNf02lRvXCG//s1H75cd/2fMeg6x8aQEgL8tFvNwTlsW9W61+qlLPanCz2s kkIqevMWcn/VVQIDAQABo4G0MIGxMB0GA1UdDgQWBBTqhsnHVVEunLFm+GyrnQBE uDCSUDCBgQYDVR0jBHoweIAU6obJx1VRLpyxZvhsq50ARLgwklChVaRTMFExCzAJ BgNVBAYTAlVTMRMwEQYDVQQIEwpDYWxpZm9ybmlhMRYwFAYDVQQHEw1TYW4gRnJh bmNpc2NvMRUwEwYDVQQKEwxUZXN0aW5nIEx0ZC6CCQCvHfS9wKwafjAMBgNVHRME BTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAEwbwKDRq1tYoEfbzX7W7iqnBHYgg0gy EbP4/7VCShUvZwdFWXe9om+W+3i83xeziBXFlNQfkXAKuoZRZSZ/6km9cbBNQYyx cAZwPGwmEQwVteLpIVqeFID5q9WTlb+PoTGhxsa36NLwzoFoptHGP9ou0X5FibDT X6eg/Y6Ie1bF -----END CERTIFICATE----- HsOpenSSL-0.11.3.2/examples/Server.hs0000644000000000000000000000255113001155766015327 0ustar0000000000000000module Main where import Control.Concurrent (threadDelay) import Control.Monad import Network.Socket import OpenSSL import OpenSSL.EVP.PKey import OpenSSL.PEM import OpenSSL.RSA import qualified OpenSSL.Session as SSL import Text.Printf main = withOpenSSL (dumpPEM >> main') dumpPEM = do pem <- readFile "server.pem" Just key <- liftM toKeyPair $ readPrivateKey pem PwNone let n = rsaN key e = rsaE key d = rsaD key printf "n (public modulus) = %s\n" (show n) printf "e (public exponent) = %s\n" (show e) printf "d (private exponent) = %s\n" (show d) main' = do sock <- socket AF_INET Stream 0 bindSocket sock $ SockAddrInet (fromIntegral 4112) iNADDR_ANY setSocketOption sock ReuseAddr 1 putStrLn "\n*** Listening to 4112/tcp ***" listen sock 1 (sock', sockaddr) <- accept sock 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" SSL.contextCheckPrivateKey ctx >>= print conn <- SSL.connection ctx sock' SSL.accept conn b <- SSL.read conn 1024 SSL.write conn b SSL.shutdown conn SSL.Bidirectional HsOpenSSL-0.11.3.2/examples/server.pem0000644000000000000000000000156713001155766015544 0ustar0000000000000000-----BEGIN RSA PRIVATE KEY----- MIICXQIBAAKBgQCbeCZfNbMAGpFeE/ttioZhIWCP3xKUOX+ZNsMa3m3+olXx7xBj JIiF7u2VT7EqAnrdk2L8YqfDT543ihEJ6STBcrR8JCYwSE45QQNf02lRvXCG//s1 H75cd/2fMeg6x8aQEgL8tFvNwTlsW9W61+qlLPanCz2skkIqevMWcn/VVQIDAQAB AoGARGdJ4sw6tMn7ubvq/Rhc5bGMzeBlSUg/JwdcMp85IDcGv4ri1+xEEUG90Nse ZRBwRLtLayZxD9MhFuitdIHbBH7BMR9F/lOF/b9vItyUbH1TmPM+64Px5mwbnmXQ RPWUQbfg3GKjyycHjnLujmrD6kzocuUTxlOsaKBZFk+Q0yUCQQDLIcutn+3alc0A BFRlkPqZOPAIGEPs47dtc588MiV2fJOlzWub9wo6286wwtuDSmkw7PJDCdt9/jw1 6bep6kxDAkEAw+6z+X4/AYUqzP79Hr9f43x0ZfwmM7z6zbS5xAYDyyOV6jqNzlJw 84QAI8oIijPJqa2SLe48RzpdyiYDlz0KhwJBAMGJNI77RlqxyTzP4z1V0X21AvUj cWw9ViGBPODUgl8OuHoLaxCRYfzMOnStYwoHFowX5YY72RWE6gcP4/6PDhMCQQC+ M4c697cqPp/iCNandpgbOcG1DyX2q8m8z2hWRpCALrdlfhoS5C0J+GY6V/IaV1O5 B+oT9GVHr/1EM8rgkj0ZAkBhVzqfVz/iMyYnOk0rusWUoDzWvKh+mS6o5UlWa6Ko jrwaPf6HhX1aP8d6W1jmfNXenuqH/uPBf8mJUCzrlsOX -----END RSA PRIVATE KEY----- HsOpenSSL-0.11.3.2/OpenSSL/0000755000000000000000000000000013001155766013167 5ustar0000000000000000HsOpenSSL-0.11.3.2/OpenSSL/ASN1.hsc0000644000000000000000000001105513001155766014372 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} module OpenSSL.ASN1 ( ASN1_OBJECT , obj2nid , nid2sn , nid2ln , ASN1_STRING , peekASN1String , ASN1_INTEGER , peekASN1Integer , withASN1Integer , ASN1_TIME , peekASN1Time , withASN1Time ) where #include "HsOpenSSL.h" import Control.Exception import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Time.Format import Foreign import Foreign.C import OpenSSL.BIO import OpenSSL.BN import OpenSSL.Utils {- ASN1_OBJECT --------------------------------------------------------------- -} data ASN1_OBJECT foreign import ccall unsafe "OBJ_obj2nid" obj2nid :: Ptr ASN1_OBJECT -> IO CInt foreign import ccall unsafe "OBJ_nid2sn" _nid2sn :: CInt -> IO CString foreign import ccall unsafe "OBJ_nid2ln" _nid2ln :: CInt -> IO CString nid2sn :: CInt -> IO String nid2sn nid = _nid2sn nid >>= peekCString nid2ln :: CInt -> IO String nid2ln nid = _nid2ln nid >>= peekCString {- ASN1_STRING --------------------------------------------------------------- -} data ASN1_STRING peekASN1String :: Ptr ASN1_STRING -> IO String peekASN1String strPtr = do buf <- (#peek ASN1_STRING, data ) strPtr len <- (#peek ASN1_STRING, length) strPtr :: IO CInt peekCStringLen (buf, fromIntegral len) {- ASN1_INTEGER -------------------------------------------------------------- -} data ASN1_INTEGER foreign import ccall unsafe "HsOpenSSL_M_ASN1_INTEGER_new" _ASN1_INTEGER_new :: IO (Ptr ASN1_INTEGER) foreign import ccall unsafe "HsOpenSSL_M_ASN1_INTEGER_free" _ASN1_INTEGER_free :: Ptr ASN1_INTEGER -> IO () foreign import ccall unsafe "ASN1_INTEGER_to_BN" _ASN1_INTEGER_to_BN :: Ptr ASN1_INTEGER -> Ptr BIGNUM -> IO (Ptr BIGNUM) foreign import ccall unsafe "BN_to_ASN1_INTEGER" _BN_to_ASN1_INTEGER :: Ptr BIGNUM -> Ptr ASN1_INTEGER -> IO (Ptr ASN1_INTEGER) peekASN1Integer :: Ptr ASN1_INTEGER -> IO Integer peekASN1Integer intPtr = allocaBN $ \ bn -> do _ASN1_INTEGER_to_BN intPtr (unwrapBN bn) >>= failIfNull_ peekBN bn allocaASN1Integer :: (Ptr ASN1_INTEGER -> IO a) -> IO a allocaASN1Integer = bracket _ASN1_INTEGER_new _ASN1_INTEGER_free withASN1Integer :: Integer -> (Ptr ASN1_INTEGER -> IO a) -> IO a withASN1Integer int m = withBN int $ \ bn -> allocaASN1Integer $ \ intPtr -> do _BN_to_ASN1_INTEGER (unwrapBN bn) intPtr >>= failIfNull_ m intPtr {- ASN1_TIME ---------------------------------------------------------------- -} data ASN1_TIME foreign import ccall unsafe "HsOpenSSL_M_ASN1_TIME_new" _ASN1_TIME_new :: IO (Ptr ASN1_TIME) foreign import ccall unsafe "HsOpenSSL_M_ASN1_TIME_free" _ASN1_TIME_free :: Ptr ASN1_TIME -> IO () foreign import ccall unsafe "ASN1_TIME_set" _ASN1_TIME_set :: Ptr ASN1_TIME -> CTime -> IO (Ptr ASN1_TIME) foreign import ccall unsafe "ASN1_TIME_print" _ASN1_TIME_print :: Ptr BIO_ -> Ptr ASN1_TIME -> IO CInt peekASN1Time :: Ptr ASN1_TIME -> IO UTCTime -- asn1/t_x509.c peekASN1Time time = do bio <- newMem withBioPtr bio $ \ bioPtr -> _ASN1_TIME_print bioPtr time >>= failIf_ (/= 1) timeStr <- bioRead bio case parseTimeM True locale "%b %e %H:%M:%S %Y %Z" timeStr of 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" ] ] , amPm = undefined , dateTimeFmt = undefined , dateFmt = undefined , timeFmt = undefined , time12Fmt = undefined , knownTimeZones = [] } allocaASN1Time :: (Ptr ASN1_TIME -> IO a) -> IO a allocaASN1Time = bracket _ASN1_TIME_new _ASN1_TIME_free withASN1Time :: UTCTime -> (Ptr ASN1_TIME -> IO a) -> IO a withASN1Time utc m = allocaASN1Time $ \ time -> do _ASN1_TIME_set time (fromIntegral (round $ utcTimeToPOSIXSeconds utc :: Integer)) >>= failIfNull_ m time HsOpenSSL-0.11.3.2/OpenSSL/BIO.hs0000644000000000000000000004000013001155766014126 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {- --------------------------------------------------------------------------- -} {- -} {- 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 HsOpenSSL-0.11.3.2/OpenSSL/BN.hsc0000644000000000000000000002744613001155766014202 0ustar0000000000000000#if defined(FAST_BIGNUM) {-# LANGUAGE BangPatterns #-} #endif {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} #if defined(FAST_BIGNUM) {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-} #endif {-# OPTIONS_HADDOCK prune #-} -- |BN - multiprecision integer arithmetics module OpenSSL.BN ( -- * Type BigNum , BIGNUM -- * Allocation , allocaBN , withBN , newBN , wrapBN -- private , unwrapBN -- private -- * Conversion from\/to Integer , peekBN , integerToBN , bnToInteger , integerToMPI , mpiToInteger -- * Computation , modexp -- * Random number generation , randIntegerUptoNMinusOneSuchThat , prandIntegerUptoNMinusOneSuchThat , randIntegerZeroToNMinusOne , prandIntegerZeroToNMinusOne , randIntegerOneToNMinusOne , prandIntegerOneToNMinusOne ) where #include "HsOpenSSL.h" import Control.Exception hiding (try) import qualified Data.ByteString as BS import Foreign.Marshal import Foreign.Ptr import Foreign.Storable import OpenSSL.Utils import System.IO.Unsafe #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 #endif -- |'BigNum' is an opaque object representing a big number. newtype BigNum = BigNum (Ptr BIGNUM) data BIGNUM foreign import ccall unsafe "BN_new" _new :: IO (Ptr BIGNUM) foreign import ccall unsafe "BN_free" _free :: Ptr BIGNUM -> IO () -- |@'allocaBN' f@ allocates a 'BigNum' and computes @f@. Then it -- frees the 'BigNum'. allocaBN :: (BigNum -> IO a) -> IO a allocaBN m = bracket _new _free (m . wrapBN) unwrapBN :: BigNum -> Ptr BIGNUM unwrapBN (BigNum p) = p wrapBN :: Ptr BIGNUM -> BigNum wrapBN = BigNum #if !defined(FAST_BIGNUM) {- slow, safe functions ----------------------------------------------------- -} foreign import ccall unsafe "BN_bn2dec" _bn2dec :: Ptr BIGNUM -> IO CString foreign import ccall unsafe "BN_dec2bn" _dec2bn :: Ptr (Ptr BIGNUM) -> CString -> IO CInt foreign import ccall unsafe "HsOpenSSL_OPENSSL_free" _openssl_free :: Ptr a -> IO () -- |Convert a BIGNUM to an 'Integer'. bnToInteger :: BigNum -> IO Integer bnToInteger bn = bracket (do strPtr <- _bn2dec (unwrapBN bn) when (strPtr == nullPtr) $ fail "BN_bn2dec failed" return strPtr) _openssl_free ((read `fmap`) . peekCString) -- |Return a new, alloced BIGNUM. integerToBN :: Integer -> IO BigNum integerToBN i = do withCString (show i) (\str -> do alloca (\bnptr -> do poke bnptr nullPtr _ <- _dec2bn bnptr str >>= failIf (== 0) wrapBN `fmap` peek bnptr)) #else {- fast, dangerous functions ------------------------------------------------ -} -- Both BN (the OpenSSL library) and GMP (used by GHC) use the same internal -- representation for numbers: an array of words, least-significant first. Thus -- we can move from Integer's to BIGNUMs very quickly: by copying in the worst -- case and by just alloca'ing and pointing into the Integer in the fast case. -- Note that, in the fast case, it's very important that any foreign function -- calls be "unsafe", that is, they don't call back into Haskell. Otherwise the -- GC could do nasty things to the data which we thought that we had a pointer -- to foreign import ccall unsafe "memcpy" _copy_in :: ByteArray## -> Ptr () -> CSize -> IO (Ptr ()) foreign import ccall unsafe "memcpy" _copy_out :: Ptr () -> ByteArray## -> CSize -> IO (Ptr ()) -- These are taken from Data.Binary's disabled fast Integer support data ByteArray = BA !ByteArray## data MBA = MBA !(MutableByteArray## RealWorld) newByteArray :: Int## -> IO MBA newByteArray sz = IO $ \s -> case newByteArray## sz s of { (## s', arr ##) -> (## s', MBA arr ##) } freezeByteArray :: MutableByteArray## RealWorld -> IO ByteArray freezeByteArray arr = IO $ \s -> case unsafeFreezeByteArray## arr s of { (## s', arr' ##) -> (## s', BA arr' ##) } -- | Convert a BIGNUM to an Integer bnToInteger :: BigNum -> IO Integer bnToInteger bn = do nlimbs <- (#peek BIGNUM, top) (unwrapBN bn) :: IO CInt case nlimbs of 0 -> return 0 1 -> do (I## i) <- (#peek BIGNUM, d) (unwrapBN bn) >>= peek negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO CInt if negative == 0 then return $ S## i else return $ 0 - (S## i) _ -> do let !(I## nlimbsi) = fromIntegral nlimbs !(I## limbsize) = (#size unsigned long) (MBA arr) <- newByteArray (nlimbsi *## limbsize) (BA ba) <- freezeByteArray arr limbs <- (#peek BIGNUM, d) (unwrapBN bn) _ <- _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) -- | This is a GHC specific, fast conversion between Integers and OpenSSL -- bignums. It returns a malloced BigNum. integerToBN :: Integer -> IO BigNum integerToBN (S## 0##) = do bnptr <- mallocBytes (#size BIGNUM) (#poke BIGNUM, d) bnptr nullPtr -- This is needed to give GHC enough type information let one :: CInt one = 1 zero :: CInt zero = 0 (#poke BIGNUM, flags) bnptr one (#poke BIGNUM, top) bnptr zero (#poke BIGNUM, dmax) bnptr zero (#poke BIGNUM, neg) bnptr zero return (wrapBN bnptr) integerToBN (S## v) = do bnptr <- mallocBytes (#size BIGNUM) limbs <- malloc :: IO (Ptr CULong) poke limbs $ fromIntegral $ abs $ I## v (#poke BIGNUM, d) bnptr limbs -- This is needed to give GHC enough type information since #poke just -- uses an offset let one :: CInt one = 1 (#poke BIGNUM, flags) bnptr one (#poke BIGNUM, top) bnptr one (#poke BIGNUM, dmax) bnptr one (#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_) bnptr <- mallocBytes (#size BIGNUM) limbs <- mallocBytes ((#size unsigned long) * nlimbs) (#poke BIGNUM, d) bnptr limbs (#poke BIGNUM, flags) bnptr (1 :: CInt) _ <- _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) 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 -- wanted to be very fast and dangerout. The BIGNUM could point right into the -- Integer's data. However, I'm not sure about the semantics of the GC; which -- might move the Integer data around. -- |@'withBN' n f@ converts n to a 'BigNum' and computes @f@. Then it -- frees the 'BigNum'. 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 ccall unsafe "BN_mpi2bn" _mpi2bn :: Ptr CChar -> CInt -> Ptr BIGNUM -> IO (Ptr BIGNUM) -- |This is an alias to 'bnToInteger'. peekBN :: BigNum -> IO Integer peekBN = bnToInteger -- |This is an alias to 'integerToBN'. newBN :: Integer -> IO BigNum newBN = integerToBN -- | Convert a BigNum to an MPI: a serialisation of large ints which has a -- 4-byte, big endian length followed by the bytes of the number in -- most-significant-first order. bnToMPI :: BigNum -> IO BS.ByteString bnToMPI bn = do bytes <- _bn2mpi (unwrapBN bn) nullPtr allocaBytes (fromIntegral bytes) (\buffer -> do _ <- _bn2mpi (unwrapBN bn) buffer BS.packCStringLen (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 -- | Convert an Integer to an MPI. See bnToMPI for the format integerToMPI :: Integer -> IO BS.ByteString integerToMPI v = bracket (integerToBN v) (_free . unwrapBN) bnToMPI -- | Convert an MPI to an Integer. See bnToMPI for the format mpiToInteger :: BS.ByteString -> IO Integer mpiToInteger mpi = do bn <- mpiToBN mpi v <- bnToInteger bn _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) type BNCtx = Ptr BNCTX data BNCTX foreign import ccall unsafe "BN_CTX_new" _BN_ctx_new :: IO BNCtx foreign import ccall unsafe "BN_CTX_free" _BN_ctx_free :: BNCtx -> IO () withBNCtx :: (BNCtx -> IO a) -> IO a withBNCtx f = bracket _BN_ctx_new _BN_ctx_free f -- |@'modexp' a p m@ computes @a@ to the @p@-th power modulo @m@. modexp :: Integer -> Integer -> Integer -> Integer modexp a p m = unsafePerformIO (do withBN a (\bnA -> (do withBN p (\bnP -> (do withBN m (\bnM -> (do withBNCtx (\ctx -> (do r <- newBN 0 _ <- _mod_exp (unwrapBN r) (unwrapBN bnA) (unwrapBN bnP) (unwrapBN bnM) ctx bnToInteger r >>= return))))))))) {- Random Integer generation ------------------------------------------------ -} foreign import ccall unsafe "BN_rand_range" _BN_rand_range :: Ptr BIGNUM -> Ptr BIGNUM -> IO CInt foreign import ccall unsafe "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 -- filter function returns true. randIntegerUptoNMinusOneSuchThat :: (Integer -> Bool) -- ^ a filter function -> Integer -- ^ one plus the upper limit -> IO Integer randIntegerUptoNMinusOneSuchThat f range = withBN range (\bnRange -> (do r <- newBN 0 let try = do _BN_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf_ (/= 1) i <- bnToInteger r if f i then return i else try try)) -- | Return a random number in the range 0 <= x < n where the given -- filter function returns true. prandIntegerUptoNMinusOneSuchThat :: (Integer -> Bool) -- ^ a filter function -> Integer -- ^ one plus the upper limit -> IO Integer prandIntegerUptoNMinusOneSuchThat f range = withBN range (\bnRange -> (do r <- newBN 0 let try = do _BN_pseudo_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf_ (/= 1) i <- bnToInteger r if f i then return i else try try)) -- | Return a strongly random number in the range 0 <= x < n randIntegerZeroToNMinusOne :: Integer -> IO Integer randIntegerZeroToNMinusOne = randIntegerUptoNMinusOneSuchThat (const True) -- | Return a strongly random number in the range 0 < x < n randIntegerOneToNMinusOne :: Integer -> IO Integer randIntegerOneToNMinusOne = randIntegerUptoNMinusOneSuchThat (/= 0) -- | Return a random number in the range 0 <= x < n prandIntegerZeroToNMinusOne :: Integer -> IO Integer prandIntegerZeroToNMinusOne = prandIntegerUptoNMinusOneSuchThat (const True) -- | Return a random number in the range 0 < x < n prandIntegerOneToNMinusOne :: Integer -> IO Integer prandIntegerOneToNMinusOne = prandIntegerUptoNMinusOneSuchThat (/= 0) HsOpenSSL-0.11.3.2/OpenSSL/Cipher.hsc0000644000000000000000000001151213001155766015100 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | 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 -- fuctions directly. -- -- One of these cases (and the motivating example -- for this module) is that the EVP CBC functions try to encode the -- length of the input string in the output (thus hiding the fact that the -- cipher is, in fact, block based and needs padding). This means that the -- EVP CBC functions cannot, in some cases, interface with other users -- which don't use that system (like SSH). module OpenSSL.Cipher ( Mode(..) , AESCtx , newAESCtx , aesCBC , aesCTR) where #include "HsOpenSSL.h" #include "openssl/aes.h" import Control.Monad (when, unless) import Data.IORef import Foreign import Foreign.C.Types import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI import OpenSSL.Utils data Mode = Encrypt | Decrypt deriving (Eq, Show) modeToInt :: Num a => Mode -> a modeToInt Encrypt = 1 modeToInt Decrypt = 0 data AES_KEY data AESCtx = AESCtx (ForeignPtr AES_KEY) -- the key schedule (ForeignPtr CUChar) -- the IV / counter (ForeignPtr CUChar) -- the encrypted counter (CTR mode) (IORef CUInt) -- the number of bytes of the encrypted counter used Mode foreign import ccall unsafe "memcpy" _memcpy :: Ptr CUChar -> Ptr CChar -> CSize -> IO (Ptr ()) foreign import ccall unsafe "memset" _memset :: Ptr CUChar -> CChar -> CSize -> IO () foreign import ccall unsafe "AES_set_encrypt_key" _AES_set_encrypt_key :: Ptr CChar -> CInt -> Ptr AES_KEY -> IO CInt foreign import ccall unsafe "AES_set_decrypt_key" _AES_set_decrypt_key :: Ptr CChar -> CInt -> Ptr AES_KEY -> IO CInt foreign import ccall unsafe "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" _free :: FunPtr (Ptr a -> IO ()) -- | Construct a new context which holds the key schedule and IV. newAESCtx :: Mode -- ^ For CTR mode, this must always be Encrypt -> BS.ByteString -- ^ Key: 128, 192 or 256 bits long -> BS.ByteString -- ^ IV: 16 bytes long -> IO AESCtx newAESCtx mode key iv = do let keyLen = BS.length key * 8 unless (any (keyLen ==) [128, 192, 256]) $ fail "Bad AES key length" when (BS.length iv /= 16) $ fail "Bad AES128 iv length" ctx <- mallocForeignPtrBytes (#size AES_KEY) withForeignPtr ctx $ \ctxPtr -> BS.useAsCStringLen key (\(ptr, _) -> case mode of Encrypt -> _AES_set_encrypt_key ptr (fromIntegral keyLen) ctxPtr >>= failIf_ (/= 0) Decrypt -> _AES_set_decrypt_key ptr (fromIntegral keyLen) ctxPtr >>= failIf_ (/= 0)) ivbytes <- mallocForeignPtrBytes 16 ecounter <- mallocForeignPtrBytes 16 nref <- newIORef 0 withForeignPtr ecounter (\ecptr -> _memset ecptr 0 16) withForeignPtr ivbytes $ \ivPtr -> BS.useAsCStringLen iv $ \(ptr, _) -> do _ <- _memcpy ivPtr ptr 16 return $ AESCtx ctx ivbytes ecounter nref mode -- | Encrypt some number of blocks using CBC. This is an IO function because -- the context is destructivly updated. aesCBC :: AESCtx -- ^ context -> BS.ByteString -- ^ input, must be multiple of block size (16 bytes) -> IO BS.ByteString aesCBC (AESCtx ctx iv _ _ mode) input = do when (BS.length input `mod` 16 /= 0) $ fail "Bad input length to aesCBC" withForeignPtr ctx $ \ctxPtr -> withForeignPtr iv $ \ivPtr -> BS.useAsCStringLen input $ \(ptr, len) -> BSI.create (BS.length input) $ \out -> _AES_cbc_encrypt ptr out (fromIntegral len) ctxPtr ivPtr $ modeToInt mode -- | Encrypt some number of bytes using CTR mode. This is an IO function -- because the context is destructivly updated. aesCTR :: AESCtx -- ^ context -> BS.ByteString -- ^ input, any number of bytes -> IO BS.ByteString aesCTR (AESCtx _ _ _ _ Decrypt) _ = fail "the context mode must be Encrypt" aesCTR (AESCtx ctx iv ecounter nref Encrypt) input = withForeignPtr ctx $ \ctxPtr -> withForeignPtr iv $ \ivPtr -> withForeignPtr ecounter $ \ecptr -> BS.useAsCStringLen input $ \(ptr, len) -> BSI.create (BS.length input) $ \out -> alloca $ \nptr -> do n <- readIORef nref poke nptr n _AES_ctr_encrypt ptr out (fromIntegral len) ctxPtr ivPtr ecptr nptr n' <- peek nptr writeIORef nref n' HsOpenSSL-0.11.3.2/OpenSSL/DER.hsc0000644000000000000000000000743413001155766014310 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} -- |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) import Foreign.C.String (CString) 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 CString -> CLong -> IO (Ptr RSA) type CEncodeFun = Ptr RSA -> Ptr (Ptr Word8) -> IO CInt foreign import ccall unsafe "d2i_RSAPublicKey" _fromDERPub :: CDecodeFun foreign import ccall unsafe "i2d_RSAPublicKey" _toDERPub :: CEncodeFun foreign import ccall unsafe "d2i_RSAPrivateKey" _fromDERPriv :: CDecodeFun foreign import ccall unsafe "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 csPtr ci 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 HsOpenSSL-0.11.3.2/OpenSSL/DH.hs0000644000000000000000000000577413001155766014033 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | Diffie-Hellman key exchange module OpenSSL.DH ( DHP , DH , DHGen(..) , genDHParams , getDHLength , checkDHParams , genDH , getDHParams , getDHPublicKey , computeDHKey ) where 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(..)) #else import Foreign.C.Types (CInt) #endif import Foreign.Marshal.Alloc (alloca) import OpenSSL.BN import OpenSSL.DH.Internal import OpenSSL.Utils data DHGen = DHGen2 | DHGen5 deriving (Eq, Ord, Show) -- | @'genDHParams' gen n@ generates @n@-bit long DH parameters. genDHParams :: DHGen -> Int -> IO DHP genDHParams gen len = do _DH_generate_parameters (fromIntegral len) gen' nullPtr nullPtr >>= failIfNull >>= wrapDHPPtr where gen' = case gen of DHGen2 -> 2 DHGen5 -> 5 -- | Get DH parameters length (in bits). getDHLength :: DHP -> IO Int getDHLength dh = fromIntegral <$> withDHPPtr dh _DH_length -- | Check that DH parameters are coherent. checkDHParams :: DHP -> IO Bool checkDHParams dh = alloca $ \pErr -> withDHPPtr dh $ \dhPtr -> _DH_check dhPtr pErr -- | The first step of a key exchange. Public and private keys are generated. genDH :: DHP -> IO DH genDH dh = do dh' <- withDHPPtr dh _DH_dup >>= failIfNull >>= wrapDHPPtr withDHPPtr dh' _DH_generate_key >>= failIf_ (/= 1) return $ asDH dh' -- | Get parameters of a key exchange. getDHParams :: DH -> DHP getDHParams = asDHP -- | Get the public key. getDHPublicKey :: DH -> IO Integer getDHPublicKey dh = withDHPtr dh $ \dhPtr -> do pKey <- _DH_get_pub_key dhPtr bnToInteger (wrapBN pKey) -- | Compute the shared key using the other party's public key. computeDHKey :: DH -> Integer -> IO ByteString computeDHKey dh pubKey = withDHPtr dh $ \dhPtr -> withBN pubKey $ \bn -> do size <- fromIntegral <$> _DH_size dhPtr BS.createAndTrim size $ \bsPtr -> fromIntegral <$> _DH_compute_key bsPtr (unwrapBN bn) dhPtr >>= failIf (< 0) foreign import ccall "DH_generate_parameters" _DH_generate_parameters :: CInt -> CInt -> Ptr () -> Ptr () -> IO (Ptr DH_) foreign import ccall "DH_generate_key" _DH_generate_key :: Ptr DH_ -> IO CInt foreign import ccall "DH_compute_key" _DH_compute_key :: Ptr Word8 -> Ptr BIGNUM -> Ptr DH_ -> IO CInt foreign import ccall "DH_check" _DH_check :: Ptr DH_ -> Ptr CInt -> IO Bool foreign import ccall unsafe "DH_size" _DH_size :: Ptr DH_ -> IO CInt foreign import ccall unsafe "HsOpenSSL_DHparams_dup" _DH_dup :: Ptr DH_ -> IO (Ptr DH_) foreign import ccall unsafe "HsOpenSSL_DH_get_pub_key" _DH_get_pub_key :: Ptr DH_ -> IO (Ptr BIGNUM) foreign import ccall unsafe "HsOpenSSL_DH_length" _DH_length :: Ptr DH_ -> IO CInt HsOpenSSL-0.11.3.2/OpenSSL/DSA.hsc0000644000000000000000000003234713001155766014306 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK prune #-} -- | The Digital Signature Algorithm (FIPS 186-2). -- See module OpenSSL.DSA ( -- * Type DSAKey(..) , DSAPubKey , DSAKeyPair , DSA -- private -- * Key and parameter generation , generateDSAParameters , generateDSAKey , generateDSAParametersAndKey -- * Signing and verification , signDigestedDataWithDSA , verifyDigestedDataWithDSA -- * Extracting fields of DSA objects , dsaPrivate , dsaPubKeyToTuple , dsaKeyPairToTuple , tupleToDSAPubKey , tupleToDSAKeyPair ) where #include "HsOpenSSL.h" import Control.Monad import qualified Data.ByteString as BS 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) deriving Typeable -- | The type of a DSA keypair, includes parameters p, q, g, public and private. newtype DSAKeyPair = DSAKeyPair (ForeignPtr DSA) deriving Typeable -- DSAPubKey and DSAKeyPair are in fact the same type at the OpenSSL -- level, but we want to treat them differently for type-safety. data DSA -- |@'DSAKey' a@ is either 'DSAPubKey' or 'DSAKeyPair'. class DSAKey k where -- |Return the length of key. dsaSize :: k -> Int dsaSize dsa = unsafePerformIO $ withDSAPtr dsa $ \ dsaPtr -> fmap fromIntegral (_size dsaPtr) -- |Return the public prime number of the key. dsaP :: k -> Integer dsaP = peekI (#peek DSA, p) -- |Return the public 160-bit subprime, @q | p - 1@ of the key. dsaQ :: k -> Integer dsaQ = peekI (#peek DSA, q) -- |Return the public generator of subgroup of the key. dsaG :: k -> Integer dsaG = peekI (#peek DSA, g) -- |Return the public key @y = g^x@. dsaPublic :: k -> Integer dsaPublic = peekI (#peek DSA, pub_key) -- private withDSAPtr :: k -> (Ptr DSA -> IO a) -> IO a peekDSAPtr :: Ptr DSA -> IO (Maybe k) absorbDSAPtr :: Ptr DSA -> IO (Maybe k) instance DSAKey DSAPubKey where withDSAPtr (DSAPubKey fp) = withForeignPtr fp peekDSAPtr dsaPtr = _pubDup dsaPtr >>= absorbDSAPtr absorbDSAPtr dsaPtr = fmap (Just . DSAPubKey) (newForeignPtr _free dsaPtr) instance DSAKey DSAKeyPair where withDSAPtr (DSAKeyPair fp) = withForeignPtr fp peekDSAPtr dsaPtr = do hasP <- hasDSAPrivateKey dsaPtr if hasP then _privDup dsaPtr >>= absorbDSAPtr else return Nothing absorbDSAPtr dsaPtr = do hasP <- hasDSAPrivateKey dsaPtr if hasP then fmap (Just . DSAKeyPair) (newForeignPtr _free dsaPtr) else return Nothing hasDSAPrivateKey :: Ptr DSA -> IO Bool hasDSAPrivateKey dsaPtr = fmap (/= nullPtr) ((#peek DSA, priv_key) dsaPtr) foreign import ccall unsafe "&DSA_free" _free :: FunPtr (Ptr DSA -> IO ()) foreign import ccall unsafe "DSA_free" dsa_free :: Ptr DSA -> IO () foreign import ccall unsafe "BN_free" _bn_free :: Ptr BIGNUM -> IO () foreign import ccall unsafe "DSA_new" _dsa_new :: IO (Ptr DSA) foreign import ccall unsafe "DSA_generate_key" _dsa_generate_key :: Ptr DSA -> IO () foreign import ccall unsafe "HsOpenSSL_dsa_sign" _dsa_sign :: Ptr DSA -> CString -> CInt -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO CInt foreign import ccall unsafe "HsOpenSSL_dsa_verify" _dsa_verify :: Ptr DSA -> CString -> CInt -> Ptr BIGNUM -> Ptr BIGNUM -> IO CInt foreign import ccall safe "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" _pubDup :: Ptr DSA -> IO (Ptr DSA) foreign import ccall unsafe "HsOpenSSL_DSAPrivateKey_dup" _privDup :: Ptr DSA -> IO (Ptr DSA) foreign import ccall unsafe "DSA_size" _size :: Ptr DSA -> IO CInt peekI :: DSAKey k => (Ptr DSA -> IO (Ptr BIGNUM)) -> k -> Integer peekI peeker dsa = unsafePerformIO $ withDSAPtr dsa $ \ dsaPtr -> do bn <- peeker dsaPtr when (bn == nullPtr) $ fail "peekI: got a nullPtr" peekBN (wrapBN bn) -- | Generate DSA parameters (*not* a key, but required for a key). This is a -- compute intensive operation. See FIPS 186-2, app 2. This agrees with the -- test vectors given in FIP 186-2, app 5 generateDSAParameters :: Int -- ^ The number of bits in the generated prime: 512 <= x <= 1024 -> Maybe BS.ByteString -- ^ optional seed, its length must be 20 bytes -> IO (Int, Int, Integer, Integer, Integer) -- ^ (iteration count, generator count, p, q, g) generateDSAParameters nbits mseed = do when (nbits < 512 || nbits > 1024) $ fail "Invalid DSA bit size" alloca (\i1 -> alloca (\i2 -> (\x -> case mseed of Nothing -> x (nullPtr, 0) Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do ptr <- _generate_params (fromIntegral nbits) seedptr (fromIntegral seedlen) i1 i2 nullPtr nullPtr 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 dsa_free ptr return (fromIntegral itcount, fromIntegral gencount, p, q, g)))) {- -- | This function just runs the example DSA generation, as given in FIP 186-2, -- app 5. The return values should be: -- (105, -- "8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210 -- eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291", -- "c773218c737ec8ee993b4f2ded30f48edace915f", -- "626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24 -- babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802"), as given at the bottom of -- page 21 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) <- generateParameters 512 $ Just seed return (a, toHex p, toHex q, g) -} -- | Generate a new DSA keypair, given valid parameters generateDSAKey :: Integer -- ^ p -> Integer -- ^ q -> Integer -- ^ g -> 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 _dsa_generate_key ptr fmap DSAKeyPair (newForeignPtr _free ptr) -- |Return the private key @x@. dsaPrivate :: DSAKeyPair -> Integer dsaPrivate = peekI (#peek 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 in (p, q, g, pub) -- | Convert a DSAKeyPair object to a tuple of its members in the -- 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 in (p, q, g, pub, pri) -- | Convert a tuple of members (in the same format as from -- 'dsaPubKeyToTuple') into a DSAPubKey object 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 fmap DSAPubKey (newForeignPtr _free ptr) -- | Convert a tuple of members (in the same format as from -- 'dsaPubKeyToTuple') into a DSAPubKey object 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 fmap DSAKeyPair (newForeignPtr _free ptr) -- | A utility function to generate both the parameters and the key pair at the -- same time. Saves serialising and deserialising the parameters too generateDSAParametersAndKey :: Int -- ^ The number of bits in the generated prime: 512 <= x <= 1024 -> Maybe BS.ByteString -- ^ optional seed, its length must be 20 bytes -> IO DSAKeyPair generateDSAParametersAndKey nbits mseed = (\x -> case mseed of Nothing -> x (nullPtr, 0) Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do ptr <- _generate_params (fromIntegral nbits) seedptr (fromIntegral seedlen) nullPtr nullPtr nullPtr nullPtr failIfNull_ ptr _dsa_generate_key ptr fmap DSAKeyPair (newForeignPtr _free ptr)) -- | Sign pre-digested data. The DSA specs call for SHA1 to be used so, if you -- use anything else, YMMV. Returns a pair of Integers which, together, are -- the signature signDigestedDataWithDSA :: DSAKeyPair -> BS.ByteString -> IO (Integer, Integer) signDigestedDataWithDSA dsa bytes = BS.useAsCStringLen bytes (\(ptr, len) -> alloca (\rptr -> alloca (\sptr -> withDSAPtr dsa (\dsaptr -> do _dsa_sign dsaptr ptr (fromIntegral len) rptr sptr >>= failIf_ (== 0) r <- peek rptr >>= peekBN . wrapBN peek rptr >>= _bn_free s <- peek sptr >>= peekBN . wrapBN peek sptr >>= _bn_free return (r, s))))) -- | Verify pre-digested data given a signature. verifyDigestedDataWithDSA :: DSAKey k => k -> BS.ByteString -> (Integer, Integer) -> IO Bool verifyDigestedDataWithDSA dsa bytes (r, s) = BS.useAsCStringLen bytes (\(ptr, len) -> withBN r (\bnR -> withBN s (\bnS -> withDSAPtr dsa (\dsaptr -> fmap (== 1) (_dsa_verify dsaptr ptr (fromIntegral len) (unwrapBN bnR) (unwrapBN bnS)))))) instance Eq DSAPubKey where a == b = dsaP a == dsaP b && dsaQ a == dsaQ b && dsaG a == dsaG b && dsaPublic a == dsaPublic b instance Eq DSAKeyPair where a == b = dsaP a == dsaP b && dsaQ a == dsaQ b && dsaG a == dsaG b && dsaPublic a == dsaPublic b && dsaPrivate a == dsaPrivate b instance Ord DSAPubKey where a `compare` b | dsaP a < dsaP b = LT | dsaP a > dsaP b = GT | dsaQ a < dsaQ b = LT | dsaQ a > dsaQ b = GT | dsaG a < dsaG b = LT | dsaG a > dsaG b = GT | dsaPublic a < dsaPublic b = LT | dsaPublic a > dsaPublic b = GT | otherwise = EQ instance Ord DSAKeyPair where a `compare` b | dsaP a < dsaP b = LT | dsaP a > dsaP b = GT | dsaQ a < dsaQ b = LT | dsaQ a > dsaQ b = GT | dsaG a < dsaG b = LT | dsaG a > dsaG b = GT | dsaPublic a < dsaPublic b = LT | dsaPublic a > dsaPublic b = GT | dsaPrivate a < dsaPrivate b = LT | dsaPrivate a > dsaPrivate b = GT | otherwise = EQ instance Show DSAPubKey where show a = concat [ "DSAPubKey {" , "dsaP = ", show (dsaP a), ", " , "dsaQ = ", show (dsaQ a), ", " , "dsaG = ", show (dsaG a), ", " , "dsaPublic = ", show (dsaPublic a) , "}" ] instance Show DSAKeyPair where show a = concat [ "DSAPubKey {" , "dsaP = ", show (dsaP a), ", " , "dsaQ = ", show (dsaQ a), ", " , "dsaG = ", show (dsaG a), ", " , "dsaPublic = ", show (dsaPublic a), ", " , "dsaPrivate = ", show (dsaPrivate a) , "}" ]HsOpenSSL-0.11.3.2/OpenSSL/ERR.hs0000644000000000000000000000077213001155766014161 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} 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 HsOpenSSL-0.11.3.2/OpenSSL/Objects.hsc0000644000000000000000000000365613001155766015271 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} 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 type DoAllCallback = ObjName -> Ptr () -> IO () foreign import ccall safe "OBJ_NAME_do_all" _NAME_do_all :: CInt -> FunPtr DoAllCallback -> Ptr () -> IO () foreign import ccall safe "OBJ_NAME_do_all_sorted" _NAME_do_all_sorted :: CInt -> FunPtr DoAllCallback -> Ptr () -> IO () foreign import ccall "wrapper" mkDoAllCallback :: DoAllCallback -> IO (FunPtr DoAllCallback) data ObjNameType = MDMethodType | CipherMethodType | PKeyMethodType | CompMethodType objNameTypeToInt :: ObjNameType -> CInt objNameTypeToInt MDMethodType = #const OBJ_NAME_TYPE_MD_METH objNameTypeToInt CipherMethodType = #const OBJ_NAME_TYPE_CIPHER_METH objNameTypeToInt PKeyMethodType = #const OBJ_NAME_TYPE_PKEY_METH objNameTypeToInt CompMethodType = #const OBJ_NAME_TYPE_COMP_METH iterateObjNames :: ObjNameType -> Bool -> (ObjName -> IO ()) -> IO () iterateObjNames nameType wantSorted cb = do cbPtr <- mkDoAllCallback $ \ name _ -> cb name let action = if wantSorted then _NAME_do_all_sorted else _NAME_do_all action (objNameTypeToInt nameType) cbPtr nullPtr freeHaskellFunPtr cbPtr objNameStr :: ObjName -> IO String objNameStr name = (#peek OBJ_NAME, name) name >>= peekCString getObjNames :: ObjNameType -> Bool -> IO [String] getObjNames nameType wantSorted = do listRef <- newIORef [] iterateObjNames nameType wantSorted $ \ name -> do nameStr <- objNameStr name modifyIORef listRef (++ [nameStr]) readIORef listRef HsOpenSSL-0.11.3.2/OpenSSL/PEM.hs0000644000000000000000000004324213001155766014151 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- |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 () HsOpenSSL-0.11.3.2/OpenSSL/PKCS7.hsc0000644000000000000000000004437613001155766014533 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK prune #-} -- |An interface to PKCS#7 structure and S\/MIME message. module OpenSSL.PKCS7 ( -- * Types Pkcs7 , PKCS7 -- private , Pkcs7Flag(..) , Pkcs7VerifyStatus(..) , wrapPkcs7Ptr -- private , withPkcs7Ptr -- private -- * Encryption and Signing , pkcs7Sign , pkcs7Verify , pkcs7Encrypt , pkcs7Decrypt -- * S\/MIME , writeSmime , readSmime ) where #include "HsOpenSSL.h" import Data.List import Data.Traversable import Data.Typeable import Foreign import Foreign.C import OpenSSL.BIO import OpenSSL.EVP.Cipher hiding (cipher) import OpenSSL.EVP.PKey import OpenSSL.EVP.Internal import OpenSSL.Stack import OpenSSL.Utils import OpenSSL.X509 import OpenSSL.X509.Store {- PKCS#7 -------------------------------------------------------------------- -} -- |@'Pkcs7'@ represents an abstract PKCS#7 structure. The concrete -- type of structure is hidden in the object: such polymorphism isn't -- very haskellish but please get it out of your mind since OpenSSL is -- written in C. newtype Pkcs7 = Pkcs7 (ForeignPtr PKCS7) data PKCS7 -- |@'Pkcs7Flag'@ is a set of flags that are used in many operations -- related to PKCS#7. data Pkcs7Flag = Pkcs7Text | Pkcs7NoCerts | Pkcs7NoSigs | Pkcs7NoChain | Pkcs7NoIntern | Pkcs7NoVerify | Pkcs7Detached | Pkcs7Binary | Pkcs7NoAttr | Pkcs7NoSmimeCap | Pkcs7NoOldMimeType | Pkcs7CRLFEOL deriving (Show, Eq, Typeable) flagToInt :: Pkcs7Flag -> CInt flagToInt Pkcs7Text = #const PKCS7_TEXT flagToInt Pkcs7NoCerts = #const PKCS7_NOCERTS flagToInt Pkcs7NoSigs = #const PKCS7_NOSIGS flagToInt Pkcs7NoChain = #const PKCS7_NOCHAIN flagToInt Pkcs7NoIntern = #const PKCS7_NOINTERN flagToInt Pkcs7NoVerify = #const PKCS7_NOVERIFY flagToInt Pkcs7Detached = #const PKCS7_DETACHED flagToInt Pkcs7Binary = #const PKCS7_BINARY flagToInt Pkcs7NoAttr = #const PKCS7_NOATTR flagToInt Pkcs7NoSmimeCap = #const PKCS7_NOSMIMECAP flagToInt Pkcs7NoOldMimeType = #const PKCS7_NOOLDMIMETYPE flagToInt Pkcs7CRLFEOL = #const PKCS7_CRLFEOL -- |@'Pkcs7VerifyStatus'@ represents a result of PKCS#7 -- verification. See 'pkcs7Verify'. data Pkcs7VerifyStatus = Pkcs7VerifySuccess (Maybe String) -- ^ Nothing if the PKCS#7 -- signature was a detached -- signature, and @Just content@ -- if it wasn't. | Pkcs7VerifyFailure deriving (Show, Eq, Typeable) flagListToInt :: [Pkcs7Flag] -> CInt flagListToInt = foldl' (.|.) 0 . map flagToInt foreign import ccall "&PKCS7_free" _free :: FunPtr (Ptr PKCS7 -> IO ()) foreign import ccall "HsOpenSSL_PKCS7_is_detached" _is_detached :: Ptr PKCS7 -> IO CLong foreign import ccall "PKCS7_sign" _sign :: Ptr X509_ -> Ptr EVP_PKEY -> Ptr STACK -> Ptr BIO_ -> CInt -> IO (Ptr PKCS7) foreign import ccall "PKCS7_verify" _verify :: Ptr PKCS7 -> Ptr STACK -> Ptr X509_STORE -> Ptr BIO_ -> Ptr BIO_ -> CInt -> IO CInt foreign import ccall "PKCS7_encrypt" _encrypt :: Ptr STACK -> Ptr BIO_ -> Ptr EVP_CIPHER -> CInt -> IO (Ptr PKCS7) foreign import ccall "PKCS7_decrypt" _decrypt :: Ptr PKCS7 -> Ptr EVP_PKEY -> Ptr X509_ -> Ptr BIO_ -> CInt -> IO CInt wrapPkcs7Ptr :: Ptr PKCS7 -> IO Pkcs7 wrapPkcs7Ptr = fmap Pkcs7 . newForeignPtr _free withPkcs7Ptr :: Pkcs7 -> (Ptr PKCS7 -> IO a) -> IO a withPkcs7Ptr (Pkcs7 pkcs7) = withForeignPtr pkcs7 isDetachedSignature :: Pkcs7 -> IO Bool isDetachedSignature pkcs7 = withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> fmap (== 1) (_is_detached pkcs7Ptr) pkcs7Sign' :: KeyPair key => X509 -> key -> [X509] -> BIO -> [Pkcs7Flag] -> IO Pkcs7 pkcs7Sign' signCert pkey certs input flagList = withX509Ptr signCert $ \ signCertPtr -> withPKeyPtr' pkey $ \ pkeyPtr -> withX509Stack certs $ \ certStack -> withBioPtr input $ \ inputPtr -> _sign signCertPtr pkeyPtr certStack inputPtr (flagListToInt flagList) >>= failIfNull >>= wrapPkcs7Ptr -- |@'pkcs7Sign'@ creates a PKCS#7 signedData structure. pkcs7Sign :: KeyPair key => X509 -- ^ certificate to sign with -> key -- ^ corresponding private key -> [X509] -- ^ optional additional set of certificates -- to include in the PKCS#7 structure (for -- example any intermediate CAs in the -- 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' -- flag is set MIME headers for type -- \"text\/plain\" are prepended to the -- data. -- -- ['Pkcs7NoCerts'] If 'Pkcs7NoCerts' is -- set the signer's certificate will not be -- included in the PKCS#7 structure, the -- signer's certificate must still be -- supplied in the parameter though. This -- can reduce the size of the signature if -- the signer's certificate can be obtained -- by other means: for example a previously -- signed message. -- -- ['Pkcs7Detached'] The data being signed -- is included in the PKCS#7 structure, -- unless 'Pkcs7Detached' is set in which -- case it is ommited. This is used for -- PKCS#7 detached signatures which are -- used in S\/MIME plaintext signed message -- for example. -- -- ['Pkcs7Binary'] Normally the supplied -- content is translated into MIME -- canonical format (as required by the -- S\/MIME specifications) but if -- 'Pkcs7Binary' is set no translation -- occurs. This option should be uesd if -- the supplied data is in binary format -- otherwise the translation will corrupt -- it. -- -- ['Pkcs7NoAttr'] -- -- ['Pkcs7NoSmimeCap'] The signedData -- structure includes several PKCS#7 -- authenticatedAttributes including the -- signing time, the PKCS#7 content type -- and the supported list of ciphers in an -- SMIMECapabilities attribute. If -- 'Pkcs7NoAttr' is set then no -- authenticatedAttributes will be used. If -- Pkcs7NoSmimeCap is set then just the -- SMIMECapabilities are omitted. -> IO Pkcs7 pkcs7Sign signCert pkey certs input flagList = do mem <- newConstMem input pkcs7Sign' signCert pkey certs mem flagList pkcs7Verify' :: Pkcs7 -> [X509] -> X509Store -> Maybe BIO -> [Pkcs7Flag] -> IO (Maybe BIO, Bool) pkcs7Verify' pkcs7 certs store inData flagList = withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> withX509Stack certs $ \ certStack -> withX509StorePtr store $ \ storePtr -> withBioPtr' inData $ \ inDataPtr -> do isDetached <- isDetachedSignature pkcs7 outData <- if isDetached then return Nothing else fmap Just newMem withBioPtr' outData $ \ outDataPtr -> _verify pkcs7Ptr certStack storePtr inDataPtr outDataPtr (flagListToInt flagList) >>= interpret outData where interpret :: Maybe BIO -> CInt -> IO (Maybe BIO, Bool) interpret bio 1 = return (bio , True ) interpret _ _ = return (Nothing, False) -- |@'pkcs7Verify'@ verifies a PKCS#7 signedData structure. pkcs7Verify :: Pkcs7 -- ^ A PKCS#7 structure to verify. -> [X509] -- ^ Set of certificates in which to -- search for the signer's -- certificate. -> X509Store -- ^ Trusted certificate store (used -- for chain verification). -> Maybe String -- ^ Signed data if the content is not -- 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 -- are not searched when locating the -- signer's certificate. This means -- that all the signers certificates -- must be in the second argument -- (['X509']). -- -- ['Pkcs7Text'] If the 'Pkcs7Text' -- flag is set MIME headers for type -- \"text\/plain\" are deleted from -- the content. If the content is not -- of type \"text\/plain\" then an -- error is returned. -- -- ['Pkcs7NoVerify'] If -- 'Pkcs7NoVerify' is set the -- signer's certificates are not -- chain verified. -- -- ['Pkcs7NoChain'] If 'Pkcs7NoChain' -- is set then the certificates -- contained in the message are not -- used as untrusted CAs. This means -- that the whole verify chain (apart -- from the signer's certificate) -- must be contained in the trusted -- store. -- -- ['Pkcs7NoSigs'] If 'Pkcs7NoSigs' -- is set then the signatures on the -- data are not checked. -> IO Pkcs7VerifyStatus pkcs7Verify pkcs7 certs store inData flagList = do inDataBio <- forM inData newConstMem (outDataBio, isSuccess) <- pkcs7Verify' pkcs7 certs store inDataBio flagList if isSuccess then do outData <- forM outDataBio bioRead return $ Pkcs7VerifySuccess outData else return Pkcs7VerifyFailure pkcs7Encrypt' :: [X509] -> BIO -> Cipher -> [Pkcs7Flag] -> IO Pkcs7 pkcs7Encrypt' certs input cipher flagList = withX509Stack certs $ \ certsPtr -> withBioPtr input $ \ inputPtr -> withCipherPtr cipher $ \ cipherPtr -> _encrypt certsPtr inputPtr cipherPtr (flagListToInt flagList) >>= failIfNull >>= wrapPkcs7Ptr -- |@'pkcs7Encrypt'@ creates a PKCS#7 envelopedData structure. pkcs7Encrypt :: [X509] -- ^ A list of recipient certificates. -> String -- ^ The content to be encrypted. -> Cipher -- ^ The symmetric cipher to use. -> [Pkcs7Flag] -- ^ An optional set of flags: -- -- ['Pkcs7Text'] If the 'Pkcs7Text' flag -- is set MIME headers for type -- \"text\/plain\" are prepended to the -- data. -- -- ['Pkcs7Binary'] Normally the supplied -- content is translated into MIME -- canonical format (as required by the -- S\/MIME specifications) if -- 'Pkcs7Binary' is set no translation -- occurs. This option should be used if -- the supplied data is in binary format -- otherwise the translation will -- corrupt it. If 'Pkcs7Binary' is set -- then 'Pkcs7Text' is ignored. -> IO Pkcs7 pkcs7Encrypt certs input cipher flagList = do mem <- newConstMem input pkcs7Encrypt' certs mem cipher flagList pkcs7Decrypt' :: KeyPair key => Pkcs7 -> key -> X509 -> BIO -> [Pkcs7Flag] -> IO () pkcs7Decrypt' pkcs7 pkey cert output flagList = withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> withPKeyPtr' pkey $ \ pkeyPtr -> withX509Ptr cert $ \ certPtr -> withBioPtr output $ \ outputPtr -> _decrypt pkcs7Ptr pkeyPtr certPtr outputPtr (flagListToInt flagList) >>= failIf (/= 1) >> return () -- |@'pkcs7Decrypt'@ decrypts content from PKCS#7 envelopedData -- structure. pkcs7Decrypt :: KeyPair key => Pkcs7 -- ^ The PKCS#7 structure to decrypt. -> key -- ^ The private key of the recipient. -> X509 -- ^ The recipient's certificate. -> [Pkcs7Flag] -- ^ An optional set of flags: -- -- ['Pkcs7Text'] If the 'Pkcs7Text' flag -- is set MIME headers for type -- \"text\/plain\" are deleted from the -- content. If the content is not of -- type \"text\/plain\" then an error is -- thrown. -> IO String -- ^ The decrypted content. pkcs7Decrypt pkcs7 pkey cert flagList = do mem <- newMem pkcs7Decrypt' pkcs7 pkey cert mem flagList bioRead mem {- S/MIME -------------------------------------------------------------------- -} foreign import ccall unsafe "SMIME_write_PKCS7" _SMIME_write_PKCS7 :: Ptr BIO_ -> Ptr PKCS7 -> Ptr BIO_ -> CInt -> IO CInt foreign import ccall unsafe "SMIME_read_PKCS7" _SMIME_read_PKCS7 :: Ptr BIO_ -> Ptr (Ptr BIO_) -> IO (Ptr PKCS7) -- |@'writeSmime'@ writes PKCS#7 structure to S\/MIME message. writeSmime :: Pkcs7 -- ^ A PKCS#7 structure to be written. -> Maybe String -- ^ If cleartext signing -- (multipart\/signed) is being used then -- the signed data must be supplied here. -> [Pkcs7Flag] -- ^ An optional set of flags: -- -- ['Pkcs7Detached'] If 'Pkcs7Detached' -- is set then cleartext signing will be -- used, this option only makes sense for -- signedData where 'Pkcs7Detached' is -- also set when 'pkcs7Sign' is also -- called. -- -- ['Pkcs7Text'] If the 'Pkcs7Text' flag -- is set MIME headers for type -- \"text\/plain\" are added to the -- content, this only makes sense if -- 'Pkcs7Detached' is also set. -> IO String -- ^ The result S\/MIME message. writeSmime pkcs7 dataStr flagList = do outBio <- newMem dataBio <- forM dataStr newConstMem writeSmime' outBio pkcs7 dataBio flagList bioRead outBio writeSmime' :: BIO -> Pkcs7 -> Maybe BIO -> [Pkcs7Flag] -> IO () writeSmime' outBio pkcs7 dataBio flagList = withBioPtr outBio $ \ outBioPtr -> withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> withBioPtr' dataBio $ \ dataBioPtr -> _SMIME_write_PKCS7 outBioPtr pkcs7Ptr dataBioPtr (flagListToInt flagList) >>= failIf (/= 1) >> return () -- |@'readSmime'@ parses S\/MIME message. readSmime :: String -- ^ The message to be read. -> IO (Pkcs7, Maybe String) -- ^ (The result PKCS#7 -- structure, @Just content@ -- if the PKCS#7 structure was -- a cleartext signature and -- @Nothing@ if it wasn't.) readSmime input = do inBio <- newConstMem input (pkcs7, outBio) <- readSmime' inBio output <- forM outBio bioRead return (pkcs7, output) readSmime' :: BIO -> IO (Pkcs7, Maybe BIO) readSmime' inBio = withBioPtr inBio $ \ inBioPtr -> alloca $ \ outBioPtrPtr -> do poke outBioPtrPtr nullPtr pkcs7 <- _SMIME_read_PKCS7 inBioPtr outBioPtrPtr >>= failIfNull >>= wrapPkcs7Ptr outBioPtr <- peek outBioPtrPtr outBio <- if outBioPtr == nullPtr then return Nothing else fmap Just (wrapBioPtr outBioPtr) return (pkcs7, outBio) HsOpenSSL-0.11.3.2/OpenSSL/Random.hs0000644000000000000000000000332613001155766014747 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} -- | PRNG services -- See -- 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 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) HsOpenSSL-0.11.3.2/OpenSSL/RSA.hsc0000644000000000000000000002226713001155766014324 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK prune #-} -- |An interface to RSA public key generator. module OpenSSL.RSA ( -- * Type RSAKey(..) , RSAPubKey , RSAKeyPair , RSA -- private -- * Generating keypair , RSAGenKeyCallback , generateRSAKey , generateRSAKey' -- * Exploring keypair , rsaD , rsaP , rsaQ , rsaDMP1 , rsaDMQ1 , rsaIQMP , rsaCopyPublic , rsaKeyPairFinalize -- private ) where #include "HsOpenSSL.h" import Control.Monad #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Data.Typeable #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(..)) 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) deriving Typeable -- |@'RSAKeyPair'@ is an opaque object that represents RSA keypair. newtype RSAKeyPair = RSAKeyPair (ForeignPtr RSA) deriving Typeable -- 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 -- |@'RSAKey' a@ is either 'RSAPubKey' or 'RSAKeyPair'. class RSAKey k where -- |@'rsaSize' key@ returns the length of key. rsaSize :: k -> Int rsaSize rsa = unsafePerformIO $ withRSAPtr rsa $ \ rsaPtr -> fmap fromIntegral (_size rsaPtr) -- |@'rsaN' key@ returns the public modulus of the key. rsaN :: k -> Integer rsaN = peekI (#peek RSA, n) -- |@'rsaE' key@ returns the public exponent of the key. rsaE :: k -> Integer rsaE = peekI (#peek RSA, e) -- private withRSAPtr :: k -> (Ptr RSA -> IO a) -> IO a peekRSAPtr :: Ptr RSA -> IO (Maybe k) absorbRSAPtr :: Ptr RSA -> IO (Maybe k) instance RSAKey RSAPubKey where withRSAPtr (RSAPubKey fp) = withForeignPtr fp peekRSAPtr rsaPtr = _pubDup rsaPtr >>= absorbRSAPtr absorbRSAPtr rsaPtr = fmap (Just . RSAPubKey) (newForeignPtr _free rsaPtr) instance RSAKey RSAKeyPair where withRSAPtr (RSAKeyPair fp) = withForeignPtr fp peekRSAPtr rsaPtr = do hasP <- hasRSAPrivateKey rsaPtr if hasP then _privDup rsaPtr >>= absorbRSAPtr else return Nothing absorbRSAPtr rsaPtr = do hasP <- hasRSAPrivateKey rsaPtr if hasP then fmap (Just . RSAKeyPair) (newForeignPtr _free rsaPtr) else return Nothing hasRSAPrivateKey :: Ptr RSA -> IO Bool hasRSAPrivateKey rsaPtr = do d <- (#peek RSA, d) rsaPtr p <- (#peek RSA, p) rsaPtr q <- (#peek RSA, q) rsaPtr return (d /= nullPtr && p /= nullPtr && q /= nullPtr) foreign import ccall unsafe "&RSA_free" _free :: FunPtr (Ptr RSA -> IO ()) foreign import ccall unsafe "RSAPublicKey_dup" _pubDup :: Ptr RSA -> IO (Ptr RSA) foreign import ccall unsafe "RSAPrivateKey_dup" _privDup :: Ptr RSA -> IO (Ptr RSA) foreign import ccall unsafe "RSA_size" _size :: Ptr RSA -> IO CInt -- | Make a copy of the public parameters of the given key. rsaCopyPublic :: RSAKey key => key -> IO RSAPubKey rsaCopyPublic key = withRSAPtr key (fmap RSAPubKey . (newForeignPtr _free =<<) . _pubDup) -- private rsaKeyPairFinalize :: RSAKeyPair -> IO () rsaKeyPairFinalize (RSAKeyPair fp) = finalizeForeignPtr fp {- generation --------------------------------------------------------------- -} -- |@'RSAGenKeyCallback'@ represents a callback function to get -- informed the progress of RSA key generation. -- -- * @callback 0 i@ is called after generating the @i@-th potential -- prime number. -- -- * While the number is being tested for primality, @callback 1 j@ is -- called after the @j@-th iteration (j = 0, 1, ...). -- -- * When the @n@-th randomly generated prime is rejected as not -- suitable for the key, @callback 2 n@ is called. -- -- * When a random @p@ has been found with @p@-1 relatively prime to -- @e@, it is called as @callback 3 0@. -- -- * The process is then repeated for prime @q@ with @callback 3 1@. type RSAGenKeyCallback = Int -> Int -> IO () type RSAGenKeyCallback' = Int -> Int -> Ptr () -> IO () foreign import ccall "wrapper" mkGenKeyCallback :: RSAGenKeyCallback' -> IO (FunPtr RSAGenKeyCallback') foreign import ccall safe "RSA_generate_key" _generate_key :: CInt -> CInt -> FunPtr RSAGenKeyCallback' -> Ptr a -> IO (Ptr RSA) -- |@'generateRSAKey'@ generates an RSA keypair. generateRSAKey :: Int -- ^ The number of bits of the public modulus -- (i.e. key size). Key sizes with @n < -- 1024@ should be considered insecure. -> Int -- ^ The public exponent. It is an odd -- number, typically 3, 17 or 65537. -> Maybe RSAGenKeyCallback -- ^ A callback function. -> IO RSAKeyPair -- ^ The generated keypair. generateRSAKey nbits e Nothing = do ptr <- _generate_key (fromIntegral nbits) (fromIntegral e) nullFunPtr nullPtr failIfNull_ ptr fmap RSAKeyPair (newForeignPtr _free ptr) generateRSAKey nbits e (Just cb) = do cbPtr <- mkGenKeyCallback $ \ arg1 arg2 _ -> cb arg1 arg2 ptr <- _generate_key (fromIntegral nbits) (fromIntegral e) cbPtr nullPtr freeHaskellFunPtr cbPtr failIfNull_ ptr fmap RSAKeyPair (newForeignPtr _free ptr) -- |A simplified alternative to 'generateRSAKey' generateRSAKey' :: Int -- ^ The number of bits of the public modulus -- (i.e. key size). Key sizes with @n < -- 1024@ should be considered insecure. -> Int -- ^ The public exponent. It is an odd -- number, typically 3, 17 or 65537. -> IO RSAKeyPair -- ^ The generated keypair. generateRSAKey' nbits e = generateRSAKey nbits e Nothing {- exploration -------------------------------------------------------------- -} peekI :: RSAKey a => (Ptr RSA -> IO (Ptr BIGNUM)) -> a -> Integer peekI peeker rsa = unsafePerformIO $ withRSAPtr rsa $ \ rsaPtr -> do bn <- peeker rsaPtr when (bn == nullPtr) $ fail "peekI: got a nullPtr" peekBN (wrapBN bn) peekMI :: RSAKey a => (Ptr RSA -> IO (Ptr BIGNUM)) -> a -> Maybe Integer peekMI peeker rsa = unsafePerformIO $ withRSAPtr rsa $ \ rsaPtr -> do bn <- peeker rsaPtr if bn == nullPtr then return Nothing else fmap Just (peekBN (wrapBN bn)) -- |@'rsaD' privKey@ returns the private exponent of the key. rsaD :: RSAKeyPair -> Integer rsaD = peekI (#peek RSA, d) -- |@'rsaP' privkey@ returns the secret prime factor @p@ of the key. rsaP :: RSAKeyPair -> Integer rsaP = peekI (#peek RSA, p) -- |@'rsaQ' privkey@ returns the secret prime factor @q@ of the key. rsaQ :: RSAKeyPair -> Integer rsaQ = peekI (#peek RSA, q) -- |@'rsaDMP1' privkey@ returns @d mod (p-1)@ of the key. rsaDMP1 :: RSAKeyPair -> Maybe Integer rsaDMP1 = peekMI (#peek RSA, dmp1) -- |@'rsaDMQ1' privkey@ returns @d mod (q-1)@ of the key. rsaDMQ1 :: RSAKeyPair -> Maybe Integer rsaDMQ1 = peekMI (#peek RSA, dmq1) -- |@'rsaIQMP' privkey@ returns @q^-1 mod p@ of the key. rsaIQMP :: RSAKeyPair -> Maybe Integer rsaIQMP = peekMI (#peek RSA, iqmp) {- instances ---------------------------------------------------------------- -} instance Eq RSAPubKey where a == b = rsaN a == rsaN b && rsaE a == rsaE b instance Eq RSAKeyPair where a == b = rsaN a == rsaN b && rsaE a == rsaE b && rsaD a == rsaD b && rsaP a == rsaP b && rsaQ a == rsaQ b instance Ord RSAPubKey where a `compare` b | rsaN a < rsaN b = LT | rsaN a > rsaN b = GT | rsaE a < rsaE b = LT | rsaE a > rsaE b = GT | otherwise = EQ instance Ord RSAKeyPair where a `compare` b | rsaN a < rsaN b = LT | rsaN a > rsaN b = GT | rsaE a < rsaE b = LT | rsaE a > rsaE b = GT | rsaD a < rsaD b = LT | rsaD a > rsaD b = GT | rsaP a < rsaP b = LT | rsaP a > rsaP b = GT | rsaQ a < rsaQ b = LT | rsaQ a > rsaQ b = GT | otherwise = EQ instance Show RSAPubKey where show a = concat [ "RSAPubKey {" , "rsaN = ", show (rsaN a), ", " , "rsaE = ", show (rsaE a) , "}" ] instance Show RSAKeyPair where show a = concat [ "RSAKeyPair {" , "rsaN = ", show (rsaN a), ", " , "rsaE = ", show (rsaE a), ", " , "rsaD = ", show (rsaD a), ", " , "rsaP = ", show (rsaP a), ", " , "rsaQ = ", show (rsaQ a) , "}" ] HsOpenSSL-0.11.3.2/OpenSSL/Session.hsc0000644000000000000000000007022613001155766015320 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | 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. module OpenSSL.Session ( -- * Contexts SSLContext , context , contextAddOption , contextRemoveOption , contextSetPrivateKey , contextSetCertificate , contextSetPrivateKeyFile , contextSetCertificateFile , contextSetCertificateChainFile , contextSetCiphers , contextSetDefaultCiphers , contextCheckPrivateKey , VerificationMode(..) , contextSetVerificationMode , contextSetCAFile , contextSetCADirectory , contextGetCAStore -- * SSL connections , SSL , SSLResult(..) , connection , fdConnection , addOption , removeOption , setTlsextHostName , accept , tryAccept , connect , tryConnect , read , tryRead , readPtr , tryReadPtr , write , tryWrite , writePtr , tryWritePtr , lazyRead , lazyWrite , shutdown , tryShutdown , ShutdownType(..) , getPeerCertificate , getVerifyResult , sslSocket , sslFd -- * Protocol Options , SSLOption(..) -- * SSL Exceptions , SomeSSLException , ConnectionAbruptlyTerminated , ProtocolError(..) -- * Direct access to OpenSSL objects , SSLContext_ , withContext , SSL_ , withSSL ) where #include "openssl/ssl.h" import Prelude hiding ( #if !MIN_VERSION_base(4,6,0) catch, #endif read, ioError, mapM, mapM_) import Control.Concurrent (threadWaitWrite, threadWaitRead, runInBoundThread) import Control.Concurrent.MVar import Control.Exception import Control.Monad (unless) import Data.Foldable (mapM_, forM_) import Data.Traversable (mapM) import Data.Typeable import Data.Maybe (fromMaybe) import Data.IORef import Foreign import Foreign.C import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as L import System.IO.Unsafe import System.Posix.Types (Fd(..)) import Network.Socket (Socket(..)) #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 type VerifyCb = Bool -> Ptr X509_STORE_CTX -> IO Bool foreign import ccall "wrapper" mkVerifyCb :: VerifyCb -> IO (FunPtr VerifyCb) data 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 -- module. Note that an empty context will pretty much cause any operation to -- fail since it doesn't even have any ciphers enabled. data SSLContext = SSLContext { ctxMVar :: MVar (Ptr SSLContext_) , ctxVfCb :: IORef (Maybe (FunPtr VerifyCb)) } deriving Typeable data 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_) -- | Create a new SSL context. context :: IO SSLContext context = mask_ $ do ctx <- _ssl_method >>= _ssl_ctx_new >>= failIfNull cbRef <- newIORef Nothing mvar <- newMVar ctx #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 -- while doing so. withContext :: SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a withContext = withMVar . ctxMVar touchContext :: SSLContext -> IO () touchContext = (>> return ()) . isEmptyMVar . ctxMVar foreign import ccall unsafe "HsOpenSSL_SSL_CTX_set_options" _SSL_CTX_set_options :: Ptr SSLContext_ -> CLong -> IO CLong foreign import ccall unsafe "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 = withContext context $ \ctx -> withCString path $ \cpath -> do result <- f ctx cpath (#const SSL_FILETYPE_PEM) unless (result == 1) $ f ctx cpath (#const SSL_FILETYPE_ASN1) >>= failIf_ (/= 1) foreign import ccall unsafe "SSL_CTX_use_PrivateKey" _ssl_ctx_use_privatekey :: Ptr SSLContext_ -> Ptr EVP_PKEY -> IO CInt foreign import ccall unsafe "SSL_CTX_use_certificate" _ssl_ctx_use_certificate :: Ptr SSLContext_ -> Ptr X509_ -> IO CInt -- | Install a private key into a context. contextSetPrivateKey :: KeyPair k => SSLContext -> k -> IO () contextSetPrivateKey context key = withContext context $ \ ctx -> withPKeyPtr' key $ \ keyPtr -> _ssl_ctx_use_privatekey ctx keyPtr >>= failIf_ (/= 1) -- | Install a certificate (public key) into a context. contextSetCertificate :: SSLContext -> X509 -> IO () contextSetCertificate context cert = withContext context $ \ ctx -> withX509Ptr cert $ \ certPtr -> _ssl_ctx_use_certificate ctx certPtr >>= failIf_ (/= 1) foreign import ccall unsafe "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" _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 -- file which contains the key. The file is parsed first as PEM and, if that -- fails, as ASN1. If both fail, an exception is raised. contextSetPrivateKeyFile :: SSLContext -> FilePath -> IO () contextSetPrivateKeyFile = contextLoadFile _ssl_ctx_use_privatekey_file -- | Install a certificate (public key) file in a context. The key is given as -- a path to the file which contains the key. The file is parsed first as PEM -- and, if that fails, as ASN1. If both fail, an exception is raised. contextSetCertificateFile :: SSLContext -> FilePath -> IO () contextSetCertificateFile = contextLoadFile _ssl_ctx_use_certificate_file foreign import ccall unsafe "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 -- format and must be sorted starting with the subject's certificate (actual -- client or server certificate), followed by intermediate CA certificates if -- applicable, and ending at the highest level (root) CA. contextSetCertificateChainFile :: SSLContext -> FilePath -> IO () contextSetCertificateChainFile context path = withContext context $ \ctx -> withCString path $ \cpath -> _ssl_ctx_use_certificate_chain_file ctx cpath >>= failIf_ (/= 1) foreign import ccall unsafe "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 -- -- Unrecognised ciphers are ignored. If no ciphers from the list are -- recognised, an exception is raised. contextSetCiphers :: SSLContext -> String -> IO () contextSetCiphers context list = withContext context $ \ctx -> withCString list $ \cpath -> _ssl_ctx_set_cipher_list ctx cpath >>= failIf_ (/= 1) contextSetDefaultCiphers :: SSLContext -> IO () contextSetDefaultCiphers = flip contextSetCiphers "DEFAULT" foreign import ccall unsafe "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 -- certificate also installed. contextCheckPrivateKey :: SSLContext -> IO Bool contextCheckPrivateKey context = withContext context $ \ctx -> fmap (== 1) (_ssl_ctx_check_private_key ctx) -- | See data VerificationMode = VerifyNone | VerifyPeer { vpFailIfNoPeerCert :: Bool -- ^ is a certificate required , vpClientOnce :: Bool -- ^ only request once per connection , vpCallback :: Maybe (Bool -> X509StoreCtx -> IO Bool) -- ^ optional callback } deriving Typeable foreign import ccall unsafe "SSL_CTX_set_verify" _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> FunPtr VerifyCb -> IO () contextSetVerificationMode :: SSLContext -> VerificationMode -> IO () contextSetVerificationMode context VerifyNone = withContext context $ \ctx -> _ssl_set_verify_mode ctx (#const SSL_VERIFY_NONE) nullFunPtr >> return () contextSetVerificationMode context (VerifyPeer reqp oncep cbp) = do let mode = (#const SSL_VERIFY_PEER) .|. (if reqp then (#const SSL_VERIFY_FAIL_IF_NO_PEER_CERT) else 0) .|. (if oncep then (#const SSL_VERIFY_CLIENT_ONCE) else 0) withContext context $ \ctx -> mask_ $ do let cbRef = ctxVfCb context newCb <- mapM mkVerifyCb $ (<$> cbp) $ \cb pvf pStoreCtx -> cb pvf =<< wrapX509StoreCtx (return ()) pStoreCtx oldCb <- readIORef cbRef writeIORef cbRef newCb forM_ oldCb freeHaskellFunPtr _ssl_set_verify_mode ctx mode $ fromMaybe nullFunPtr newCb return () foreign import ccall unsafe "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 -- verifying a server's certificate contextSetCAFile :: SSLContext -> FilePath -> IO () contextSetCAFile context path = withContext context $ \ctx -> withCString path $ \cpath -> _ssl_load_verify_locations ctx cpath nullPtr >>= failIf_ (/= 1) -- | Set the path to a directory which contains the PEM encoded CA root -- certificates. This is an alternative to 'contextSetCAFile'. See -- for -- details of the file naming scheme contextSetCADirectory :: SSLContext -> FilePath -> IO () contextSetCADirectory context path = withContext context $ \ctx -> withCString path $ \cpath -> _ssl_load_verify_locations ctx nullPtr cpath >>= failIf_ (/= 1) foreign import ccall unsafe "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 -- in the SSL context. contextGetCAStore :: SSLContext -> IO X509Store contextGetCAStore context = withContext context $ \ ctx -> _ssl_get_cert_store ctx >>= wrapX509Store (touchContext context) data SSL_ -- | This is the type of an SSL connection -- -- IO with SSL objects is non-blocking and many SSL functions return a error -- code which signifies that it needs to read or write more data. We handle -- these calls and call threadWaitRead and threadWaitWrite at the correct -- times. Thus multiple OS threads can be 'blocked' inside IO in the same SSL -- object at a time, because they aren't really in the SSL object, they are -- waiting for the RTS to wake the Haskell thread. data SSL = SSL { sslCtx :: SSLContext , sslMVar :: MVar (Ptr SSL_) , sslFd :: Fd -- ^ Get the underlying socket Fd , sslSocket :: Maybe Socket -- ^ Get the socket underlying an SSL connection } 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 () connection' :: SSLContext -> Fd -> Maybe Socket -> IO SSL connection' context fd@(Fd fdInt) sock = do mvar <- mask_ $ do ssl <- withContext context $ \ctx -> do ssl <- _ssl_new ctx >>= failIfNull _ssl_set_fd ssl fdInt return ssl mvar <- newMVar 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 , sslFd = fd , sslSocket = sock } -- | Wrap a Socket in an SSL connection. Reading and writing to the Socket -- after this will cause weird errors in the SSL code. The SSL object -- 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 (Fd fd) (Just sock) -- | 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 unsafe "HsOpenSSL_SSL_set_options" _SSL_set_options :: Ptr SSL_ -> CLong -> IO CLong foreign import ccall unsafe "HsOpenSSL_SSL_clear_options" _SSL_clear_options :: Ptr SSL_ -> CLong -> IO CLong foreign import ccall unsafe "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 () 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 throwSSLException :: String -> CInt -> IO a throwSSLException loc ret = do e <- getError if e == 0 then case ret of 0 -> throwIO ConnectionAbruptlyTerminated _ -> throwErrno loc else errorString e >>= throwIO . ProtocolError -- | 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. data SSLResult a = SSLDone a -- ^ operation finished successfully | WantRead -- ^ needs more data from the network | WantWrite -- ^ needs more outgoing buffer space deriving (Eq, Show, Functor, Foldable, Traversable, Typeable) -- | Block until the operation is finished. sslBlock :: (SSL -> IO (SSLResult a)) -> SSL -> IO a sslBlock action ssl = do result <- action ssl case result of SSLDone r -> return r WantRead -> threadWaitRead (sslFd ssl) >> sslBlock action ssl WantWrite -> threadWaitWrite (sslFd ssl) >> sslBlock action ssl -- | Perform an SSL operation which can return non-blocking error codes, thus -- requesting that the operation be performed when data or buffer space is -- availible. sslTryHandshake :: String -> (Ptr SSL_ -> IO CInt) -> SSL -> IO (SSLResult CInt) sslTryHandshake loc action ssl = runInBoundThread $ withSSL ssl $ \sslPtr -> do n <- action sslPtr if n == 1 then return $ SSLDone n else do err <- _ssl_get_error sslPtr n case err of (#const SSL_ERROR_WANT_READ ) -> return WantRead (#const SSL_ERROR_WANT_WRITE) -> return WantWrite _ -> throwSSLException loc n -- | Perform an SSL server handshake accept :: SSL -> IO () accept = sslBlock tryAccept -- | Try to perform an SSL server handshake without blocking tryAccept :: SSL -> IO (SSLResult ()) tryAccept ssl = (() <$) <$> sslTryHandshake "SSL_accept" _ssl_accept ssl -- | Perform an SSL client handshake connect :: SSL -> IO () connect = sslBlock tryConnect -- | Try to perform an SSL client handshake without blocking tryConnect :: SSL -> IO (SSLResult ()) 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 -- | Perform an SSL operation which operates of a buffer and can return -- non-blocking error codes, thus requesting that it be performed again when -- more data or buffer space is available. -- -- Note that these SSL functions generally require that the arguments to the -- repeated call be exactly the same. This presents an issue because multiple -- threads could try writing at the same time (with different buffers) so the -- calling function should probably hold the lock on the SSL object over the -- whole time (include repeated calls) sslIOInner :: String -- ^ the name of SSL IO function to call -> (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt) -- ^ the SSL IO function to call -> Ptr CChar -- ^ the buffer to pass -> Int -- ^ the length to pass -> SSL -> IO (SSLResult CInt) sslIOInner loc f ptr nbytes ssl = runInBoundThread $ withSSL ssl $ \sslPtr -> do n <- f sslPtr (castPtr ptr) $ fromIntegral nbytes if n > 0 then return $ SSLDone $ fromIntegral n else do err <- _ssl_get_error sslPtr n case err of (#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 -- | 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. 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. tryRead :: SSL -> Int -> IO (SSLResult B.ByteString) tryRead ssl nBytes = do (bs, result) <- B.createAndTrim' nBytes $ \bufPtr -> do result <- sslIOInner "SSL_read" _ssl_read (castPtr bufPtr) nBytes ssl case result of SSLDone n -> return (0, fromIntegral n, SSLDone ()) WantRead -> return (0, 0, WantRead ) WantWrite -> return (0, 0, WantWrite ) return $ bs <$ result -- | Read some data into a raw pointer buffer. -- Retrns the number of bytes read. readPtr :: SSL -> Ptr a -> Int -> IO Int readPtr ssl ptr len = sslBlock (\h -> tryReadPtr h ptr len) ssl -- | Try to read some data into a raw pointer buffer, without blocking. tryReadPtr :: SSL -> Ptr a -> Int -> IO (SSLResult Int) tryReadPtr ssl bufPtr nBytes = 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 -- | Write a given ByteString to the SSL connection. Either all the data is -- written or an exception is raised because of an error. write :: SSL -> B.ByteString -> IO () write ssl bs = sslBlock (`tryWrite` bs) ssl >> return () -- | Try to write a given ByteString to the SSL connection without blocking. tryWrite :: SSL -> B.ByteString -> IO (SSLResult ()) tryWrite ssl bs | B.null bs = return $ SSLDone () | otherwise = B.unsafeUseAsCStringLen bs $ \(ptr, len) -> tryWritePtr ssl ptr len -- | Send some data from a raw pointer buffer. writePtr :: SSL -> Ptr a -> Int -> IO () writePtr ssl ptr len = sslBlock (\h -> tryWritePtr h ptr len) ssl >> return () -- | Send some data from a raw pointer buffer, without blocking. tryWritePtr :: SSL -> Ptr a -> Int -> IO (SSLResult ()) tryWritePtr ssl ptr len = do result <- sslIOInner "SSL_write" _ssl_write (castPtr ptr) len ssl case result of SSLDone 0 -> ioError $ errnoToIOError "SSL_write" ePIPE Nothing Nothing SSLDone _ -> return $ SSLDone () WantRead -> return WantRead WantWrite -> return WantWrite -- | Lazily read all data until reaching EOF. If the connection dies -- without a graceful SSL shutdown, an exception is raised. lazyRead :: SSL -> IO L.ByteString lazyRead ssl = fmap L.fromChunks lazyRead' where chunkSize = L.defaultChunkSize lazyRead' = unsafeInterleaveIO loop loop = do bs <- read ssl chunkSize if B.null bs then -- got EOF return [] else do bss <- lazyRead' return (bs:bss) -- | Write a lazy ByteString to the SSL connection. In contrast to -- 'write', there is a chance that the string is written partway and -- then an exception is raised for an error. The string doesn't -- necessarily have to be finite. lazyWrite :: SSL -> L.ByteString -> IO () lazyWrite ssl lbs = mapM_ (write ssl) $ L.toChunks lbs foreign import ccall "SSL_shutdown" _ssl_shutdown :: Ptr SSL_ -> IO CInt data ShutdownType = Bidirectional -- ^ wait for the peer to also shutdown | Unidirectional -- ^ only send our shutdown deriving (Eq, Show, Typeable) -- | Cleanly shutdown an SSL connection. Note that SSL has a concept of a -- secure shutdown, which is distinct from just closing the TCP connection. -- This performs the former and should always be preferred. -- -- This can either just send a shutdown, or can send and wait for the peer's -- shutdown message. shutdown :: SSL -> ShutdownType -> IO () shutdown ssl ty = sslBlock (`tryShutdown` ty) ssl -- | Try to cleanly shutdown an SSL connection without blocking. tryShutdown :: SSL -> ShutdownType -> IO (SSLResult ()) 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" n else return $ SSLDone () _ -> throwSSLException "SSL_shutdown" n foreign import ccall "SSL_get_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_) -- | 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 -- you asked for it with contextSetVerificationMode getPeerCertificate :: SSL -> IO (Maybe X509) getPeerCertificate ssl = withSSL ssl $ \ssl -> do cert <- _ssl_get_peer_cert ssl if cert == nullPtr then return Nothing else fmap Just (wrapX509 cert) foreign import ccall "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 -- it. You must set a list of root CA certificates with contextSetCA... for -- this to make sense. -- -- Note that this returns True iff the peer's certificate has a valid chain -- to a root CA. You also need to check that the certificate is correct (i.e. -- has the correct hostname in it) with getPeerCertificate. getVerifyResult :: SSL -> IO Bool getVerifyResult ssl = withSSL ssl $ \ssl -> do r <- _ssl_get_verify_result ssl return $ r == (#const X509_V_OK) -- | The root exception type for all SSL exceptions. data SomeSSLException = forall e. Exception e => SomeSSLException e deriving Typeable instance Show SomeSSLException where show (SomeSSLException e) = show e instance Exception SomeSSLException sslExceptionToException :: Exception e => e -> SomeException sslExceptionToException = toException . SomeSSLException sslExceptionFromException :: Exception e => SomeException -> Maybe e sslExceptionFromException x = do SomeSSLException a <- fromException x cast a -- | The peer uncleanly terminated the connection without sending the -- \"close notify\" alert. data ConnectionAbruptlyTerminated = ConnectionAbruptlyTerminated deriving (Typeable, Show, Eq) instance Exception ConnectionAbruptlyTerminated where toException = sslExceptionToException fromException = sslExceptionFromException -- | A failure in the SSL library occurred, usually a protocol -- error. data ProtocolError = ProtocolError !String deriving (Typeable, Show, Eq) instance Exception ProtocolError where toException = sslExceptionToException fromException = sslExceptionFromException HsOpenSSL-0.11.3.2/OpenSSL/SSL.hs0000644000000000000000000000063013001155766014163 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} 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 () HsOpenSSL-0.11.3.2/OpenSSL/Stack.hs0000644000000000000000000000267613001155766014603 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} module OpenSSL.Stack ( STACK , mapStack , withStack , withForeignStack ) where import Control.Exception import Foreign import Foreign.C data STACK foreign import ccall unsafe "sk_new_null" skNewNull :: IO (Ptr STACK) foreign import ccall unsafe "sk_free" skFree :: Ptr STACK -> IO () foreign import ccall unsafe "sk_push" skPush :: Ptr STACK -> Ptr () -> IO () foreign import ccall unsafe "sk_num" skNum :: Ptr STACK -> IO CInt foreign import ccall unsafe "sk_value" skValue :: Ptr STACK -> CInt -> IO (Ptr ()) mapStack :: (Ptr a -> IO b) -> Ptr STACK -> IO [b] mapStack m st = do num <- skNum st mapM (\ i -> fmap castPtr (skValue st i) >>= m) $ take (fromIntegral num) [0..] newStack :: [Ptr a] -> IO (Ptr STACK) newStack values = do st <- skNewNull mapM_ (skPush st . castPtr) values return st withStack :: [Ptr a] -> (Ptr STACK -> IO b) -> IO b withStack values = bracket (newStack values) skFree withForeignStack :: (fp -> Ptr obj) -> (fp -> IO ()) -> [fp] -> (Ptr STACK -> IO ret) -> IO ret withForeignStack unsafeFpToPtr touchFp fps action = do ret <- withStack (map unsafeFpToPtr fps) action mapM_ touchFp fps return ret HsOpenSSL-0.11.3.2/OpenSSL/Utils.hs0000644000000000000000000000374013001155766014627 0ustar0000000000000000module OpenSSL.Utils ( failIfNull , failIfNull_ , failIf , failIf_ , raiseOpenSSLError , toHex , fromHex , peekCStringCLen ) where import Foreign.C.String import Foreign.C.Types import Foreign.Ptr import OpenSSL.ERR import Data.Bits import Data.List failIfNull :: Ptr a -> IO (Ptr a) failIfNull ptr = if ptr == nullPtr then raiseOpenSSLError else return ptr failIfNull_ :: Ptr a -> IO () failIfNull_ ptr = failIfNull ptr >> return () failIf :: (a -> Bool) -> a -> IO a failIf f a | f a = raiseOpenSSLError | otherwise = return a failIf_ :: (a -> Bool) -> a -> IO () failIf_ f a = failIf f a >> return () raiseOpenSSLError :: IO a raiseOpenSSLError = getError >>= errorString >>= fail -- | Convert an integer to a hex string toHex :: (Num i, Bits i) => i -> String toHex = reverse . map hexByte . unfoldr step where step 0 = Nothing step i = Just (i .&. 0xf, i `shiftR` 4) hexByte 0 = '0' hexByte 1 = '1' hexByte 2 = '2' hexByte 3 = '3' hexByte 4 = '4' hexByte 5 = '5' hexByte 6 = '6' hexByte 7 = '7' hexByte 8 = '8' hexByte 9 = '9' hexByte 10 = 'a' hexByte 11 = 'b' hexByte 12 = 'c' hexByte 13 = 'd' hexByte 14 = 'e' hexByte 15 = 'f' hexByte _ = undefined -- | Convert a hex string to an integer fromHex :: (Num i, Bits i) => String -> i fromHex = foldl step 0 where step acc hexchar = (acc `shiftL` 4) .|. byteHex hexchar byteHex '0' = 0 byteHex '1' = 1 byteHex '2' = 2 byteHex '3' = 3 byteHex '4' = 4 byteHex '5' = 5 byteHex '6' = 6 byteHex '7' = 7 byteHex '8' = 8 byteHex '9' = 9 byteHex 'a' = 10 byteHex 'b' = 11 byteHex 'c' = 12 byteHex 'd' = 13 byteHex 'e' = 14 byteHex 'f' = 15 byteHex 'A' = 10 byteHex 'B' = 11 byteHex 'C' = 12 byteHex 'D' = 13 byteHex 'E' = 14 byteHex 'F' = 15 byteHex _ = undefined peekCStringCLen :: (Ptr CChar, CInt) -> IO String peekCStringCLen (p, n) = peekCStringLen (p, fromIntegral n) HsOpenSSL-0.11.3.2/OpenSSL/X509.hs0000644000000000000000000003123613001155766014175 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# 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 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 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 foreign import ccall safe "i2d_X509_bio" _write_bio_X509 :: Ptr BIO_ -> Ptr X509_ -> IO CInt foreign import ccall safe "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 = 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 HsOpenSSL-0.11.3.2/OpenSSL/DH/0000755000000000000000000000000013001155766013462 5ustar0000000000000000HsOpenSSL-0.11.3.2/OpenSSL/DH/Internal.hs0000644000000000000000000000236713001155766015602 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} 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 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 () HsOpenSSL-0.11.3.2/OpenSSL/EVP/0000755000000000000000000000000013001155766013621 5ustar0000000000000000HsOpenSSL-0.11.3.2/OpenSSL/EVP/Base64.hs0000644000000000000000000001355613001155766015213 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- |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 (CChar(..), CInt(..)) #else import Foreign.C.Types (CChar, 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 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. {-# 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 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. {-# 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 HsOpenSSL-0.11.3.2/OpenSSL/EVP/Cipher.hs0000644000000000000000000000705113001155766015372 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- |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 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 ----------------------------------------------------------- -} -- | 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 HsOpenSSL-0.11.3.2/OpenSSL/EVP/Digest.hsc0000644000000000000000000001055113001155766015541 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- |An interface to message digest algorithms. module OpenSSL.EVP.Digest ( Digest , getDigestByName , getDigestNames , digest , digestBS , digestLBS , hmacBS , pkcs5_pbkdf2_hmac_sha1 ) where #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 #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" _get_digestbyname :: CString -> IO (Ptr EVP_MD) -- |@'getDigestByName' name@ returns a message digest algorithm whose -- name is @name@. If no algorithms are found, the result is -- @Nothing@. getDigestByName :: String -> IO (Maybe Digest) getDigestByName name = withCString name $ \ namePtr -> do ptr <- _get_digestbyname namePtr if ptr == nullPtr then return Nothing else return $ Just $ Digest ptr -- |@'getDigestNames'@ returns a list of name of message digest -- algorithms. getDigestNames :: IO [String] getDigestNames = getObjNames MDMethodType True {- digest -------------------------------------------------------------------- -} -- |@'digest'@ digests a stream of data. The string must -- 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 = B8.unpack $ digestLBS md $ L8.pack input -- |@'digestBS'@ digests a chunk of data. digestBS :: Digest -> B8.ByteString -> B8.ByteString digestBS md input = unsafePerformIO $ digestStrictly md input >>= digestFinalBS -- |@'digestLBS'@ digests a stream of data. digestLBS :: Digest -> L8.ByteString -> B8.ByteString digestLBS md input = unsafePerformIO $ digestLazily md input >>= digestFinalBS {- HMAC ---------------------------------------------------------------------- -} foreign import ccall unsafe "HMAC" _HMAC :: Ptr EVP_MD -> Ptr CChar -> CInt -> Ptr CChar -> CSize -> Ptr CChar -> Ptr CUInt -> IO () -- | Perform a private key signing using the HMAC template with a given hash hmacBS :: Digest -- ^ the hash function to use in the HMAC calculation -> B8.ByteString -- ^ the HMAC key -> B8.ByteString -- ^ the data to be signed -> B8.ByteString -- ^ resulting HMAC hmacBS (Digest md) key input = unsafePerformIO $ allocaArray (#const EVP_MAX_MD_SIZE) $ \bufPtr -> alloca $ \bufLenPtr -> unsafeUseAsCStringLen key $ \(keydata, keylen) -> unsafeUseAsCStringLen input $ \(inputdata, inputlen) -> do _HMAC md keydata (fromIntegral keylen) inputdata (fromIntegral inputlen) bufPtr bufLenPtr bufLen <- fromIntegral <$> peek bufLenPtr B8.packCStringLen (bufPtr, bufLen) -- | Calculate a PKCS5-PBKDF2 SHA1-HMAC suitable for password hashing. pkcs5_pbkdf2_hmac_sha1 :: B8.ByteString -- ^ password -> B8.ByteString -- ^ salt -> Int -- ^ iterations -> Int -- ^ destination key length -> B8.ByteString -- ^ destination key pkcs5_pbkdf2_hmac_sha1 pass salt iter dkeylen = unsafePerformIO $ unsafeUseAsCStringLen pass $ \(passdata, passlen) -> unsafeUseAsCStringLen salt $ \(saltdata, saltlen) -> create dkeylen $ \dkeydata -> _PKCS5_PBKDF2_HMAC_SHA1 passdata (fromIntegral passlen) saltdata (fromIntegral saltlen) (fromIntegral iter) (fromIntegral dkeylen) (castPtr dkeydata) >> return () foreign import ccall unsafe "PKCS5_PBKDF2_HMAC_SHA1" _PKCS5_PBKDF2_HMAC_SHA1 :: Ptr CChar -> CInt -> Ptr CChar -> CInt -> CInt -> CInt -> Ptr CChar -> IO CInt HsOpenSSL-0.11.3.2/OpenSSL/EVP/Internal.hsc0000644000000000000000000002571213001155766016103 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} module OpenSSL.EVP.Internal ( Cipher(..), EVP_CIPHER, withCipherPtr, cipherIvLength, CipherCtx(..), EVP_CIPHER_CTX, newCipherCtx, withCipherCtxPtr, withNewCipherCtxPtr, CryptoMode(..), cipherSetPadding, cipherInitBS, cipherUpdateBS, cipherFinalBS, cipherStrictly, cipherLazily, Digest(..), EVP_MD, withMDPtr, DigestCtx(..), EVP_MD_CTX, withDigestCtxPtr, digestUpdateBS, digestFinalBS, digestFinal, digestStrictly, digestLazily, VaguePKey(..), EVP_PKEY, PKey(..), createPKey, wrapPKeyPtr, withPKeyPtr, withPKeyPtr', unsafePKeyToPtr, touchPKey ) where #include "HsOpenSSL.h" import qualified Data.ByteString.Internal as B8 import qualified Data.ByteString.Unsafe as B8 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 ((<$>)) #endif import Control.Exception (mask, mask_, bracket_, onException) import Foreign.C.Types (CChar) #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 (CString, peekCStringLen) 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.Storable (Storable(..)) import Foreign.Marshal.Alloc (alloca, allocaBytes) 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 withCipherPtr :: Cipher -> (Ptr EVP_CIPHER -> IO a) -> IO a withCipherPtr (Cipher cipherPtr) f = f cipherPtr foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_iv_length" _iv_length :: Ptr EVP_CIPHER -> CInt cipherIvLength :: Cipher -> Int cipherIvLength (Cipher cipherPtr) = fromIntegral $ _iv_length cipherPtr {- EVP_CIPHER_CTX ------------------------------------------------------------ -} newtype CipherCtx = CipherCtx (ForeignPtr EVP_CIPHER_CTX) data EVP_CIPHER_CTX foreign import ccall unsafe "EVP_CIPHER_CTX_init" _cipher_ctx_init :: Ptr EVP_CIPHER_CTX -> IO () foreign import ccall unsafe "&EVP_CIPHER_CTX_cleanup" _cipher_ctx_cleanup :: FunPtr (Ptr EVP_CIPHER_CTX -> IO ()) foreign import ccall unsafe "EVP_CIPHER_CTX_cleanup" _cipher_ctx_cleanup' :: Ptr EVP_CIPHER_CTX -> IO () foreign import ccall unsafe "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 return $ CipherCtx ctx withCipherCtxPtr :: CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a withCipherCtxPtr (CipherCtx ctx) = withForeignPtr ctx 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) {- encrypt/decrypt ----------------------------------------------------------- -} -- |@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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "EVP_CipherUpdate" _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> Ptr CChar -> CInt -> IO CInt cipherUpdateBS :: CipherCtx -> B8.ByteString -> IO B8.ByteString cipherUpdateBS ctx inBS = withCipherCtxPtr ctx $ \ctxPtr -> B8.unsafeUseAsCStringLen inBS $ \(inBuf, inLen) -> let len = inLen + fromIntegral (_cipher_ctx_block_size ctxPtr) - 1 in B8.createAndTrim len $ \outBuf -> alloca $ \outLenPtr -> _CipherUpdate ctxPtr (castPtr outBuf) outLenPtr inBuf (fromIntegral inLen) >>= failIf (/= 1) >> fromIntegral <$> peek outLenPtr foreign import ccall unsafe "EVP_CipherFinal" _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> IO CInt cipherFinalBS :: CipherCtx -> IO B8.ByteString cipherFinalBS ctx = withCipherCtxPtr ctx $ \ctxPtr -> let len = fromIntegral $ _cipher_ctx_block_size ctxPtr in B8.createAndTrim len $ \outBuf -> alloca $ \outLenPtr -> _CipherFinal ctxPtr (castPtr outBuf) outLenPtr >>= failIf (/= 1) >> fromIntegral <$> peek outLenPtr cipherStrictly :: CipherCtx -> B8.ByteString -> IO B8.ByteString cipherStrictly ctx input = do output' <- cipherUpdateBS ctx input output'' <- cipherFinalBS ctx return $ B8.append output' output'' cipherLazily :: CipherCtx -> L8.ByteString -> IO L8.ByteString cipherLazily ctx (L8.Empty) = cipherFinalBS ctx >>= return . L8.fromChunks . return cipherLazily ctx (L8.Chunk x xs) = do y <- cipherUpdateBS ctx x ys <- unsafeInterleaveIO $ cipherLazily ctx xs return $ L8.Chunk y ys {- EVP_MD -------------------------------------------------------------------- -} -- |@Digest@ is an opaque object that represents an algorithm of -- message digest. newtype Digest = Digest (Ptr EVP_MD) data EVP_MD withMDPtr :: Digest -> (Ptr EVP_MD -> IO a) -> IO a withMDPtr (Digest mdPtr) f = f mdPtr {- EVP_MD_CTX ---------------------------------------------------------------- -} newtype DigestCtx = DigestCtx (ForeignPtr EVP_MD_CTX) data 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 ()) newDigestCtx :: IO DigestCtx newDigestCtx = do ctx <- mallocForeignPtrBytes (#size EVP_MD_CTX) mask_ $ do withForeignPtr ctx _md_ctx_init addForeignPtrFinalizer _md_ctx_cleanup ctx return $ DigestCtx ctx withDigestCtxPtr :: DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a withDigestCtxPtr (DigestCtx ctx) = withForeignPtr ctx {- digest -------------------------------------------------------------------- -} foreign import ccall unsafe "EVP_DigestInit" _DigestInit :: Ptr EVP_MD_CTX -> Ptr EVP_MD -> IO CInt digestInit :: Digest -> IO DigestCtx digestInit (Digest md) = do ctx <- newDigestCtx withDigestCtxPtr ctx $ \ctxPtr -> _DigestInit ctxPtr md >>= failIf_ (/= 1) >> return ctx foreign import ccall unsafe "EVP_DigestUpdate" _DigestUpdate :: Ptr EVP_MD_CTX -> Ptr CChar -> CSize -> IO CInt digestUpdateBS :: DigestCtx -> B8.ByteString -> IO () digestUpdateBS ctx bs = withDigestCtxPtr ctx $ \ctxPtr -> B8.unsafeUseAsCStringLen bs $ \(buf, len) -> _DigestUpdate ctxPtr buf (fromIntegral len) >>= failIf (/= 1) >> return () foreign import ccall unsafe "EVP_DigestFinal" _DigestFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> Ptr CUInt -> IO CInt digestFinalBS :: DigestCtx -> IO B8.ByteString digestFinalBS ctx = withDigestCtxPtr ctx $ \ctxPtr -> B8.createAndTrim (#const EVP_MAX_MD_SIZE) $ \bufPtr -> alloca $ \bufLenPtr -> do _DigestFinal ctxPtr (castPtr bufPtr) bufLenPtr >>= failIf_ (/= 1) fromIntegral <$> peek bufLenPtr digestFinal :: DigestCtx -> IO String digestFinal ctx = withDigestCtxPtr ctx $ \ctxPtr -> allocaArray (#const EVP_MAX_MD_SIZE) $ \bufPtr -> alloca $ \bufLenPtr -> do _DigestFinal ctxPtr bufPtr bufLenPtr >>= failIf_ (/= 1) bufLen <- fromIntegral <$> peek bufLenPtr peekCStringLen (bufPtr, bufLen) digestStrictly :: Digest -> B8.ByteString -> IO DigestCtx digestStrictly md input = do ctx <- digestInit md digestUpdateBS ctx input return ctx digestLazily :: Digest -> L8.ByteString -> IO DigestCtx digestLazily md lbs = do ctx <- digestInit md mapM_ (digestUpdateBS 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. newtype VaguePKey = VaguePKey (ForeignPtr EVP_PKEY) data EVP_PKEY -- | 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'. toPKey :: k -> IO VaguePKey -- | 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(). pkeySize :: k -> Int -- | Return the default digesting algorithm for the key. pkeyDefaultMD :: k -> IO Digest foreign import ccall unsafe "EVP_PKEY_new" _pkey_new :: IO (Ptr EVP_PKEY) foreign import ccall unsafe "&EVP_PKEY_free" _pkey_free :: FunPtr (Ptr EVP_PKEY -> IO ()) foreign import ccall unsafe "EVP_PKEY_free" _pkey_free' :: Ptr EVP_PKEY -> IO () wrapPKeyPtr :: Ptr EVP_PKEY -> IO VaguePKey wrapPKeyPtr = fmap VaguePKey . newForeignPtr _pkey_free createPKey :: (Ptr EVP_PKEY -> IO a) -> IO VaguePKey createPKey f = mask $ \restore -> do ptr <- _pkey_new >>= failIfNull (restore $ f ptr >> return ()) `onException` _pkey_free' ptr wrapPKeyPtr ptr withPKeyPtr :: VaguePKey -> (Ptr EVP_PKEY -> IO a) -> IO a withPKeyPtr (VaguePKey pkey) = withForeignPtr pkey withPKeyPtr' :: PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a withPKeyPtr' k f = do pk <- toPKey k withPKeyPtr pk f unsafePKeyToPtr :: VaguePKey -> Ptr EVP_PKEY unsafePKeyToPtr (VaguePKey pkey) = Unsafe.unsafeForeignPtrToPtr pkey touchPKey :: VaguePKey -> IO () touchPKey (VaguePKey pkey) = touchForeignPtr pkey HsOpenSSL-0.11.3.2/OpenSSL/EVP/Open.hs0000644000000000000000000000647013001155766015065 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- |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 ccall unsafe "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 HsOpenSSL-0.11.3.2/OpenSSL/EVP/PKey.hsc0000644000000000000000000001653413001155766015201 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE Rank2Types #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- |An interface to asymmetric cipher keypair. module OpenSSL.EVP.PKey ( PublicKey(..) , KeyPair(..) , SomePublicKey , SomeKeyPair ) where #include "HsOpenSSL.h" import Data.Typeable import Data.Maybe import Foreign import Foreign.C import OpenSSL.DSA import OpenSSL.EVP.Digest import OpenSSL.EVP.Internal import OpenSSL.RSA import OpenSSL.Utils -- |Instances of this class has at least public portion of a -- keypair. They might or might not have the private key. class (Eq k, Typeable k, PKey k) => PublicKey k where -- |Wrap an arbitrary public key into polymorphic type -- 'SomePublicKey'. fromPublicKey :: k -> SomePublicKey fromPublicKey = SomePublicKey -- |Cast from the polymorphic type 'SomePublicKey' to the concrete -- type. Return 'Nothing' if failed. toPublicKey :: SomePublicKey -> Maybe k toPublicKey (SomePublicKey pk) = cast pk -- |Instances of this class has both of public and private portions of -- a keypair. class PublicKey a => KeyPair a where -- |Wrap an arbitrary keypair into polymorphic type 'SomeKeyPair'. fromKeyPair :: a -> SomeKeyPair fromKeyPair = SomeKeyPair -- |Cast from the polymorphic type 'SomeKeyPair' to the concrete -- type. Return 'Nothing' if failed. toKeyPair :: SomeKeyPair -> Maybe a toKeyPair (SomeKeyPair pk) = cast pk -- 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 case pkeyType of #if !defined(OPENSSL_NO_RSA) (#const EVP_PKEY_RSA) -> do rsaPtr <- _get1_RSA pkeyPtr Just rsa <- absorbRSAPtr rsaPtr f (rsa :: RSAPubKey) #endif #if !defined(OPENSSL_NO_DSA) (#const EVP_PKEY_DSA) -> do dsaPtr <- _get1_DSA pkeyPtr Just dsa <- absorbDSAPtr dsaPtr f (dsa :: DSAPubKey) #endif _ -> fail ("withConcretePubKey: unsupported EVP_PKEY type: " ++ show pkeyType) -- Reconstruct the concrete keypair type from an EVP_PKEY. 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 case pkeyType of #if !defined(OPENSSL_NO_RSA) (#const EVP_PKEY_RSA) -> do rsaPtr <- _get1_RSA pkeyPtr Just rsa <- absorbRSAPtr rsaPtr f (rsa :: RSAKeyPair) #endif #if !defined(OPENSSL_NO_DSA) (#const EVP_PKEY_DSA) -> do dsaPtr <- _get1_DSA pkeyPtr Just dsa <- absorbDSAPtr dsaPtr f (dsa :: DSAKeyPair) #endif _ -> fail ("withConcreteKeyPair: unsupported EVP_PKEY type: " ++ show pkeyType) -- |This is an opaque type to hold an arbitrary public key in it. The -- actual key type can be safelly type-casted using 'toPublicKey'. data SomePublicKey = forall k. PublicKey k => SomePublicKey !k deriving Typeable instance Eq SomePublicKey where (SomePublicKey a) == (SomePublicKey b) = case cast b of Just c -> a == c Nothing -> False -- different types instance PublicKey SomePublicKey where fromPublicKey = id toPublicKey = Just instance PKey SomePublicKey where toPKey (SomePublicKey k) = toPKey k pkeySize (SomePublicKey k) = pkeySize k pkeyDefaultMD (SomePublicKey k) = pkeyDefaultMD k fromPKey pk = withConcretePubKey pk (return . Just . SomePublicKey) -- |This is an opaque type to hold an arbitrary keypair in it. The -- actual key type can be safelly type-casted using 'toKeyPair'. data SomeKeyPair = forall k. KeyPair k => SomeKeyPair !k deriving Typeable instance Eq SomeKeyPair where (SomeKeyPair a) == (SomeKeyPair b) = case cast b of Just c -> a == c Nothing -> False instance PublicKey SomeKeyPair where -- Cast the keypair to a public key, hiding its private part. fromPublicKey (SomeKeyPair k) = SomePublicKey k -- It's impossible to cast a public key to a keypair. toPublicKey _ = Nothing instance KeyPair SomeKeyPair where fromKeyPair = id toKeyPair = Just instance PKey SomeKeyPair where toPKey (SomeKeyPair k) = toPKey k pkeySize (SomeKeyPair k) = pkeySize k pkeyDefaultMD (SomeKeyPair k) = pkeyDefaultMD k fromPKey pk = withConcreteKeyPair pk (return . Just . SomeKeyPair) #if !defined(OPENSSL_NO_RSA) -- The resulting Ptr RSA must be freed by caller. foreign import ccall unsafe "EVP_PKEY_get1_RSA" _get1_RSA :: Ptr EVP_PKEY -> IO (Ptr RSA) foreign import ccall unsafe "EVP_PKEY_set1_RSA" _set1_RSA :: Ptr EVP_PKEY -> Ptr RSA -> IO CInt rsaToPKey :: RSAKey k => k -> IO VaguePKey rsaToPKey rsa = withRSAPtr rsa $ \rsaPtr -> createPKey $ \pkeyPtr -> _set1_RSA pkeyPtr rsaPtr >>= failIf_ (/= 1) rsaFromPKey :: RSAKey k => VaguePKey -> IO (Maybe k) rsaFromPKey pk = withPKeyPtr pk $ \ pkeyPtr -> do pkeyType <- (#peek EVP_PKEY, type) pkeyPtr :: IO CInt case pkeyType of (#const EVP_PKEY_RSA) -> _get1_RSA pkeyPtr >>= absorbRSAPtr _ -> return Nothing instance PublicKey RSAPubKey instance PKey RSAPubKey where toPKey = rsaToPKey fromPKey = rsaFromPKey pkeySize = rsaSize pkeyDefaultMD _ = return . fromJust =<< getDigestByName "sha1" instance KeyPair RSAKeyPair instance PublicKey RSAKeyPair instance PKey RSAKeyPair where toPKey = rsaToPKey fromPKey = rsaFromPKey pkeySize = rsaSize pkeyDefaultMD _ = return . fromJust =<< getDigestByName "sha1" #endif #if !defined(OPENSSL_NO_DSA) foreign import ccall unsafe "EVP_PKEY_get1_DSA" _get1_DSA :: Ptr EVP_PKEY -> IO (Ptr DSA) foreign import ccall unsafe "EVP_PKEY_set1_DSA" _set1_DSA :: Ptr EVP_PKEY -> Ptr DSA -> IO CInt dsaToPKey :: DSAKey k => k -> IO VaguePKey dsaToPKey dsa = withDSAPtr dsa $ \dsaPtr -> 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 case pkeyType of (#const EVP_PKEY_DSA) -> _get1_DSA pkeyPtr >>= absorbDSAPtr _ -> return Nothing instance PublicKey DSAPubKey instance PKey DSAPubKey where toPKey = dsaToPKey fromPKey = dsaFromPKey pkeySize = dsaSize pkeyDefaultMD _ = return . fromJust =<< getDigestByName "dss1" instance KeyPair DSAKeyPair instance PublicKey DSAKeyPair instance PKey DSAKeyPair where toPKey = dsaToPKey fromPKey = dsaFromPKey pkeySize = dsaSize pkeyDefaultMD _ = return . fromJust =<< getDigestByName "dss1" #endif HsOpenSSL-0.11.3.2/OpenSSL/EVP/Seal.hs0000644000000000000000000001243113001155766015042 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} -- |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, [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) HsOpenSSL-0.11.3.2/OpenSSL/EVP/Sign.hs0000644000000000000000000000500313001155766015053 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- |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 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 {-# 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] HsOpenSSL-0.11.3.2/OpenSSL/EVP/Verify.hs0000644000000000000000000000610013001155766015416 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ForeignFunctionInterface #-} -- |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 ccall unsafe "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 HsOpenSSL-0.11.3.2/OpenSSL/SSL/0000755000000000000000000000000013001155766013630 5ustar0000000000000000HsOpenSSL-0.11.3.2/OpenSSL/SSL/Option.hsc0000644000000000000000000002272313001155766015605 0ustar0000000000000000{-# 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 -- | 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 | SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG | 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 | SSL_OP_SSLEAY_080_CLIENT_DH_BUG | SSL_OP_TLS_D5_BUG | 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 -- | All of the above bug workarounds. | 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 -- | Always create a new key when using temporary/ephemeral DH -- parameters. This option must be used to prevent small -- subgroup attacks, when the DH parameters were not generated -- using \"strong\" primes (e.g. when using DSA-parameters). If -- \"strong\" primes were used, it is not strictly necessary to -- generate a new DH key during each handshake but it is also -- recommended. 'SSL_OP_SINGLE_DH_USE' should therefore be enabled -- whenever temporary/ephemeral DH parameters are used. | SSL_OP_SINGLE_DH_USE -- | Always use ephemeral (temporary) RSA key when doing RSA -- operations. According to the specifications this is only -- done, when a RSA key can only be used for signature -- operations (namely under export ciphers with restricted RSA -- keylength). By setting this option, ephemeral RSA keys are -- always used. This option breaks compatibility with the -- SSL/TLS specifications and may lead to interoperability -- problems with clients and should therefore never be -- used. Ciphers with DHE (ephemeral Diffie-Hellman) key -- exchange should be used instead. | 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 | SSL_OP_PKCS1_CHECK_1 | SSL_OP_PKCS1_CHECK_2 -- | If we accept a netscape connection, demand a client cert, -- have a non-self-signed CA which does not have its CA in -- netscape, and the browser has a cert, it will -- crash/hang. Works for 3.x and 4.xbeta | SSL_OP_NETSCAPE_CA_DN_BUG | SSL_OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG -- | Do not use the SSLv2 protocol. | SSL_OP_NO_SSLv2 -- | Do not use the SSLv3 protocol. | SSL_OP_NO_SSLv3 -- | Do not use the TLSv1 protocol. | SSL_OP_NO_TLSv1 #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 -- 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 -- -- 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 -- -- for more details. | SSL_OP_LEGACY_SERVER_CONNECT #endif 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 #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 HsOpenSSL-0.11.3.2/OpenSSL/X509/0000755000000000000000000000000013001155766013634 5ustar0000000000000000HsOpenSSL-0.11.3.2/OpenSSL/X509/Name.hsc0000644000000000000000000000506613001155766015222 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} module OpenSSL.X509.Name ( X509_NAME , allocaX509Name , withX509Name , 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 foreign import ccall unsafe "X509_NAME_new" _new :: IO (Ptr X509_NAME) foreign import ccall unsafe "X509_NAME_free" _free :: Ptr X509_NAME -> IO () foreign import ccall unsafe "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" _entry_count :: Ptr X509_NAME -> IO CInt foreign import ccall unsafe "X509_NAME_get_entry" _get_entry :: Ptr X509_NAME -> CInt -> IO (Ptr X509_NAME_ENTRY) foreign import ccall unsafe "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" _ENTRY_get_data :: Ptr X509_NAME_ENTRY -> IO (Ptr ASN1_STRING) allocaX509Name :: (Ptr X509_NAME -> IO a) -> IO a allocaX509Name = bracket _new _free withX509Name :: [(String, String)] -> (Ptr X509_NAME -> IO a) -> IO a withX509Name name m = allocaX509Name $ \ namePtr -> do mapM_ (addEntry namePtr) name m namePtr where addEntry :: Ptr X509_NAME -> (String, String) -> IO () addEntry namePtr (key, val) = withCString key $ \ keyPtr -> withCStringLen val $ \ (valPtr, valLen) -> _add_entry_by_txt namePtr keyPtr (#const MBSTRING_UTF8) valPtr (fromIntegral valLen) (-1) 0 >>= failIf (/= 1) >> return () peekX509Name :: Ptr X509_NAME -> Bool -> IO [(String, String)] peekX509Name namePtr wantLongName = do count <- return . fromIntegral =<< failIf (< 0) =<< _entry_count namePtr mapM peekEntry [0..count - 1] where peekEntry :: Int -> IO (String, String) peekEntry n = do ent <- _get_entry namePtr (fromIntegral n) >>= failIfNull obj <- _ENTRY_get_object ent >>= failIfNull dat <- _ENTRY_get_data ent >>= failIfNull nid <- obj2nid obj key <- if wantLongName then nid2ln nid else nid2sn nid val <- peekASN1String dat return (key, val) HsOpenSSL-0.11.3.2/OpenSSL/X509/Request.hs0000644000000000000000000002254513001155766015630 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# 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 ) 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 X509_REQ data X509_EXT 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 "i2d_X509_REQ_bio" _req_to_der :: 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 foreign import ccall unsafe "X509V3_EXT_nconf_nid" _ext_create :: Ptr a -> Ptr b -> CInt -> CString -> IO (Ptr X509_EXT) foreign import ccall unsafe "X509_REQ_add_extensions" _req_add_extensions :: Ptr X509_REQ -> Ptr STACK -> 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 HsOpenSSL-0.11.3.2/OpenSSL/X509/Revocation.hsc0000644000000000000000000002550013001155766016446 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK prune #-} -- |An interface to Certificate Revocation List. module OpenSSL.X509.Revocation ( -- * Types CRL , X509_CRL -- privae , RevokedCertificate(..) -- * Functions to manipulate revocation list , newCRL , wrapCRL -- private , withCRLPtr -- private , signCRL , verifyCRL , printCRL , sortCRL -- * Accessors , getVersion , setVersion , getLastUpdate , setLastUpdate , getNextUpdate , setNextUpdate , getIssuerName , setIssuerName , getRevokedList , addRevoked , getRevoked ) where #include "HsOpenSSL.h" import Control.Monad #if OPENSSL_VERSION_NUMBER < 0x10000000 import Data.List #endif import Data.Time.Clock import Data.Typeable import Foreign import Foreign.C import OpenSSL.ASN1 import OpenSSL.BIO import OpenSSL.EVP.Digest hiding (digest) import OpenSSL.EVP.PKey import OpenSSL.EVP.Verify import OpenSSL.EVP.Internal import OpenSSL.Stack import OpenSSL.Utils import OpenSSL.X509.Name -- |@'CRL'@ is an opaque object that represents Certificate Revocation -- List. newtype CRL = CRL (ForeignPtr X509_CRL) data X509_CRL data X509_REVOKED -- |@'RevokedCertificate'@ represents a revoked certificate in a -- list. Each certificates are supposed to be distinguishable by -- issuer name and serial number, so it is sufficient to have only -- serial number on each entries. data RevokedCertificate = RevokedCertificate { revSerialNumber :: Integer , revRevocationDate :: UTCTime } deriving (Show, Eq, Typeable) foreign import ccall unsafe "X509_CRL_new" _new :: IO (Ptr X509_CRL) foreign import ccall unsafe "&X509_CRL_free" _free :: FunPtr (Ptr X509_CRL -> IO ()) foreign import ccall unsafe "X509_CRL_sign" _sign :: Ptr X509_CRL -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt foreign import ccall unsafe "X509_CRL_verify" _verify :: Ptr X509_CRL -> Ptr EVP_PKEY -> IO CInt foreign import ccall unsafe "X509_CRL_print" _print :: Ptr BIO_ -> Ptr X509_CRL -> IO CInt foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_version" _get_version :: Ptr X509_CRL -> IO CLong foreign import ccall unsafe "X509_CRL_set_version" _set_version :: Ptr X509_CRL -> CLong -> IO CInt foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_lastUpdate" _get_lastUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME) foreign import ccall unsafe "X509_CRL_set_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 ccall unsafe "X509_CRL_set_nextUpdate" _set_nextUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_issuer" _get_issuer_name :: Ptr X509_CRL -> IO (Ptr X509_NAME) foreign import ccall unsafe "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" _get_REVOKED :: Ptr X509_CRL -> IO (Ptr STACK) foreign import ccall unsafe "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" _get0_by_serial :: Ptr X509_CRL -> Ptr (Ptr X509_REVOKED) -> Ptr ASN1_INTEGER -> IO CInt #endif foreign import ccall unsafe "X509_CRL_sort" _sort :: Ptr X509_CRL -> IO CInt foreign import ccall unsafe "X509_REVOKED_new" _new_revoked :: IO (Ptr X509_REVOKED) foreign import ccall unsafe "X509_REVOKED_free" freeRevoked :: Ptr X509_REVOKED -> IO () foreign import ccall unsafe "X509_REVOKED_set_serialNumber" _set_serialNumber :: Ptr X509_REVOKED -> Ptr ASN1_INTEGER -> IO CInt foreign import ccall unsafe "X509_REVOKED_set_revocationDate" _set_revocationDate :: Ptr X509_REVOKED -> Ptr ASN1_TIME -> IO CInt -- |@'newCRL'@ creates an empty revocation list. You must set the -- following properties to and sign it (see 'signCRL') to actually use -- the revocation list. If you have any certificates to be listed, you -- must of course add them (see 'addRevoked') before signing the list. -- -- [/Version/] See 'setVersion'. -- -- [/Last Update/] See 'setLastUpdate'. -- -- [/Next Update/] See 'setNextUpdate'. -- -- [/Issuer Name/] See 'setIssuerName'. -- newCRL :: IO CRL newCRL = _new >>= wrapCRL wrapCRL :: Ptr X509_CRL -> IO CRL wrapCRL = fmap CRL . newForeignPtr _free withCRLPtr :: CRL -> (Ptr X509_CRL -> IO a) -> IO a withCRLPtr (CRL crl) = withForeignPtr crl -- |@'signCRL'@ signs a revocation list with an issuer private key. signCRL :: KeyPair key => CRL -- ^ The revocation list 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 () signCRL crl key mDigest = withCRLPtr crl $ \ crlPtr -> withPKeyPtr' key $ \ pkeyPtr -> do digest <- case mDigest of Just md -> return md Nothing -> pkeyDefaultMD key withMDPtr digest $ \ digestPtr -> _sign crlPtr pkeyPtr digestPtr >>= failIf_ (== 0) return () -- |@'verifyCRL'@ verifies a signature of revocation list with an -- issuer public key. verifyCRL :: PublicKey key => CRL -> key -> IO VerifyStatus verifyCRL crl key = withCRLPtr crl $ \ crlPtr -> withPKeyPtr' key $ \ pkeyPtr -> _verify crlPtr pkeyPtr >>= interpret where interpret :: CInt -> IO VerifyStatus interpret 1 = return VerifySuccess interpret 0 = return VerifyFailure interpret _ = raiseOpenSSLError -- |@'printCRL'@ translates a revocation list into human-readable -- format. printCRL :: CRL -> IO String printCRL crl = do mem <- newMem withBioPtr mem $ \ memPtr -> withCRLPtr crl $ \ crlPtr -> _print memPtr crlPtr >>= failIf_ (/= 1) bioRead mem -- |@'getVersion' crl@ returns the version number of revocation list. getVersion :: CRL -> IO Int getVersion crl = withCRLPtr crl $ \ crlPtr -> liftM fromIntegral $ _get_version crlPtr -- |@'setVersion' crl ver@ updates the version number of revocation -- list. setVersion :: CRL -> Int -> IO () setVersion crl ver = withCRLPtr crl $ \ crlPtr -> _set_version crlPtr (fromIntegral ver) >>= failIf (/= 1) >> return () -- |@'getLastUpdate' crl@ returns the time when the revocation list -- has last been updated. getLastUpdate :: CRL -> IO UTCTime getLastUpdate crl = withCRLPtr crl $ \ crlPtr -> _get_lastUpdate crlPtr >>= peekASN1Time -- |@'setLastUpdate' crl utc@ updates the time when the revocation -- list has last been updated. setLastUpdate :: CRL -> UTCTime -> IO () setLastUpdate crl utc = withCRLPtr crl $ \ crlPtr -> withASN1Time utc $ \ time -> _set_lastUpdate crlPtr time >>= failIf (/= 1) >> return () -- |@'getNextUpdate' crl@ returns the time when the revocation list -- will next be updated. getNextUpdate :: CRL -> IO UTCTime getNextUpdate crl = withCRLPtr crl $ \ crlPtr -> _get_nextUpdate crlPtr >>= peekASN1Time -- |@'setNextUpdate' crl utc@ updates the time when the revocation -- list will next be updated. setNextUpdate :: CRL -> UTCTime -> IO () setNextUpdate crl utc = withCRLPtr crl $ \ crlPtr -> withASN1Time utc $ \ time -> _set_nextUpdate crlPtr time >>= failIf (/= 1) >> return () -- |@'getIssuerName' crl wantLongName@ returns the issuer name of -- revocation list. See 'OpenSSL.X509.getIssuerName' of -- "OpenSSL.X509". getIssuerName :: CRL -> Bool -> IO [(String, String)] getIssuerName crl wantLongName = withCRLPtr crl $ \ crlPtr -> do namePtr <- _get_issuer_name crlPtr peekX509Name namePtr wantLongName -- |@'setIssuerName' crl name@ updates the issuer name of revocation -- list. See 'OpenSSL.X509.setIssuerName' of "OpenSSL.X509". setIssuerName :: CRL -> [(String, String)] -> IO () setIssuerName crl issuer = withCRLPtr crl $ \ crlPtr -> withX509Name issuer $ \ namePtr -> _set_issuer_name crlPtr namePtr >>= failIf (/= 1) >> return () -- |@'getRevokedList' crl@ returns the list of revoked certificates. getRevokedList :: CRL -> IO [RevokedCertificate] getRevokedList crl = withCRLPtr crl $ \ crlPtr -> _get_REVOKED crlPtr >>= mapStack peekRevoked peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate peekRevoked rev = do serial <- peekASN1Integer =<< (#peek X509_REVOKED, serialNumber ) rev date <- peekASN1Time =<< (#peek X509_REVOKED, revocationDate) rev return RevokedCertificate { revSerialNumber = serial , revRevocationDate = date } newRevoked :: RevokedCertificate -> IO (Ptr X509_REVOKED) newRevoked revoked = do revPtr <- _new_revoked seriRet <- withASN1Integer (revSerialNumber revoked) $ _set_serialNumber revPtr dateRet <- withASN1Time (revRevocationDate revoked) $ _set_revocationDate revPtr if seriRet /= 1 || dateRet /= 1 then freeRevoked revPtr >> raiseOpenSSLError else return revPtr -- |@'addRevoked' crl revoked@ add the certificate to the revocation -- list. addRevoked :: CRL -> RevokedCertificate -> IO () addRevoked crl revoked = withCRLPtr crl $ \ crlPtr -> do revPtr <- newRevoked revoked ret <- _add0_revoked crlPtr revPtr case ret of 1 -> return () _ -> freeRevoked revPtr >> raiseOpenSSLError -- |@'getRevoked' crl serial@ looks up the corresponding revocation. getRevoked :: CRL -> Integer -> IO (Maybe RevokedCertificate) #if OPENSSL_VERSION_NUMBER >= 0x10000000 getRevoked crl serial = withCRLPtr crl $ \crlPtr -> alloca $ \revPtr -> withASN1Integer serial $ \serialPtr -> do r <- _get0_by_serial crlPtr revPtr serialPtr if r == 1 then fmap Just $ peek revPtr >>= peekRevoked else return Nothing #else getRevoked crl serial = find p `fmap` getRevokedList crl where p :: RevokedCertificate -> Bool p = ((==) serial) . revSerialNumber #endif -- |@'sortCRL' crl@ sorts the certificates in the revocation list. sortCRL :: CRL -> IO () sortCRL crl = withCRLPtr crl $ \ crlPtr -> _sort crlPtr >>= failIf_ (/= 1) HsOpenSSL-0.11.3.2/OpenSSL/X509/Store.hs0000644000000000000000000001131413001155766015264 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK prune #-} -- |An interface to X.509 certificate store. module OpenSSL.X509.Store ( X509Store , X509_STORE -- private , newX509Store , wrapX509Store -- private , withX509StorePtr -- private , addCertToStore , addCRLToStore , X509StoreCtx , X509_STORE_CTX -- private , withX509StoreCtxPtr -- private , wrapX509StoreCtx -- private , getStoreCtxCert , getStoreCtxIssuer , getStoreCtxCRL , getStoreCtxChain ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Exception (throwIO, mask_) import Foreign import Foreign.C import Foreign.Concurrent as FC import OpenSSL.X509 import OpenSSL.X509.Revocation import OpenSSL.Stack import OpenSSL.Utils -- |@'X509Store'@ is an opaque object that represents X.509 -- certificate store. The certificate store is usually used for chain -- verification. newtype X509Store = X509Store (ForeignPtr X509_STORE) data X509_STORE foreign import ccall unsafe "X509_STORE_new" _new :: IO (Ptr X509_STORE) foreign import ccall unsafe "X509_STORE_free" _free :: Ptr X509_STORE -> IO () foreign import ccall unsafe "X509_STORE_add_cert" _add_cert :: Ptr X509_STORE -> Ptr X509_ -> IO CInt foreign import ccall unsafe "X509_STORE_add_crl" _add_crl :: Ptr X509_STORE -> Ptr X509_CRL -> IO CInt -- |@'newX509Store'@ creates an empty X.509 certificate store. newX509Store :: IO X509Store newX509Store = _new >>= failIfNull >>= \ ptr -> wrapX509Store (_free ptr) ptr wrapX509Store :: IO () -> Ptr X509_STORE -> IO X509Store wrapX509Store finaliser ptr = do fp <- newForeignPtr_ ptr FC.addForeignPtrFinalizer fp finaliser return $ X509Store fp withX509StorePtr :: X509Store -> (Ptr X509_STORE -> IO a) -> IO a withX509StorePtr (X509Store store) = withForeignPtr store -- |@'addCertToStore' store cert@ adds a certificate to store. addCertToStore :: X509Store -> X509 -> IO () addCertToStore store cert = withX509StorePtr store $ \ storePtr -> withX509Ptr cert $ \ certPtr -> _add_cert storePtr certPtr >>= failIf (/= 1) >> return () -- |@'addCRLToStore' store crl@ adds a revocation list to store. addCRLToStore :: X509Store -> CRL -> IO () addCRLToStore store crl = withX509StorePtr store $ \ storePtr -> withCRLPtr crl $ \ crlPtr -> _add_crl storePtr crlPtr >>= failIf (/= 1) >> return () data X509_STORE_CTX newtype X509StoreCtx = X509StoreCtx (ForeignPtr X509_STORE_CTX) foreign import ccall unsafe "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" _store_ctx_get0_current_issuer :: Ptr X509_STORE_CTX -> IO (Ptr X509_) foreign import ccall unsafe "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" _store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK) foreign import ccall unsafe "HsOpenSSL_X509_ref" _x509_ref :: Ptr X509_ -> IO () foreign import ccall unsafe "HsOpenSSL_X509_CRL_ref" _crl_ref :: Ptr X509_CRL -> IO () withX509StoreCtxPtr :: X509StoreCtx -> (Ptr X509_STORE_CTX -> IO a) -> IO a withX509StoreCtxPtr (X509StoreCtx fp) = withForeignPtr fp wrapX509StoreCtx :: IO () -> Ptr X509_STORE_CTX -> IO X509StoreCtx wrapX509StoreCtx finaliser ptr = X509StoreCtx <$> FC.newForeignPtr ptr finaliser getStoreCtxCert :: X509StoreCtx -> IO X509 getStoreCtxCert ctx = withX509StoreCtxPtr ctx $ \pCtx -> do pCert <- _store_ctx_get_current_cert pCtx if pCert == nullPtr then throwIO $ userError "BUG: NULL certificate in X509_STORE_CTX" else mask_ $ _x509_ref pCert >> wrapX509 pCert getStoreCtxIssuer :: X509StoreCtx -> IO (Maybe X509) getStoreCtxIssuer ctx = withX509StoreCtxPtr ctx $ \pCtx -> do pCert <- _store_ctx_get0_current_issuer pCtx if pCert == nullPtr then return Nothing else fmap Just $ mask_ $ _x509_ref pCert >> wrapX509 pCert getStoreCtxCRL :: X509StoreCtx -> IO (Maybe CRL) getStoreCtxCRL ctx = withX509StoreCtxPtr ctx $ \pCtx -> do pCrl <- _store_ctx_get0_current_crl pCtx if pCrl == nullPtr then return Nothing else fmap Just $ mask_ $ _crl_ref pCrl >> wrapCRL pCrl getStoreCtxChain :: X509StoreCtx -> IO [X509] getStoreCtxChain ctx = withX509StoreCtxPtr ctx $ \pCtx -> do stack <- _store_ctx_get_chain pCtx (`mapStack` stack) $ \pCert -> mask_ $ _x509_ref pCert >> wrapX509 pCert HsOpenSSL-0.11.3.2/Test/0000755000000000000000000000000013001155766012623 5ustar0000000000000000HsOpenSSL-0.11.3.2/Test/OpenSSL/0000755000000000000000000000000013001155766014106 5ustar0000000000000000HsOpenSSL-0.11.3.2/Test/OpenSSL/Cipher.hs0000644000000000000000000000537513001155766015666 0ustar0000000000000000-- | Tests for the non-EVP ciphers module Main (main) where import qualified Data.ByteString as BS import OpenSSL.Cipher import Test.OpenSSL.TestUtils -- | Convert a hex string to a ByteString (e.g. "0011" == BS.pack [0, 0x11]) hexToBS :: String -> BS.ByteString hexToBS [] = BS.empty hexToBS (a : b : rest) = BS.append (BS.singleton ((valueOfHexChar a * 16) + valueOfHexChar b)) (hexToBS rest) hexToBS xs = error ("hexToBS: invalid hex string: " ++ xs) valueOfHexChar :: Integral a => Char -> a 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 valueOfHexChar x = error ("valueOfHexChar: invalid char: " ++ show x) -- | 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] 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 () runCtrTest (CTRTest key iv plaintext ciphertext) = do ctx <- newAESCtx Encrypt key iv ct <- aesCTR ctx plaintext assertEqual "" ciphertext ct main :: IO () main = mapM_ runCtrTest ctrTests HsOpenSSL-0.11.3.2/Test/OpenSSL/DER.hs0000644000000000000000000000042513001155766015055 0ustar0000000000000000module Main (main) where import OpenSSL.RSA import OpenSSL.DER import Test.OpenSSL.TestUtils main :: IO () main = do keyPair <- generateRSAKey 1024 3 Nothing pubKey <- rsaCopyPublic keyPair assertEqual "encodeDecode" (Just pubKey) (fromDERPub (toDERPub keyPair)) HsOpenSSL-0.11.3.2/Test/OpenSSL/DSA.hs0000644000000000000000000000253413001155766015055 0ustar0000000000000000module Main (main) where import qualified Data.ByteString as BS import OpenSSL.DSA import Test.OpenSSL.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 HsOpenSSL-0.11.3.2/Test/OpenSSL/TestUtils.hs0000644000000000000000000000145413001155766016406 0ustar0000000000000000module Test.OpenSSL.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 HsOpenSSL-0.11.3.2/Test/OpenSSL/EVP/0000755000000000000000000000000013001155766014540 5ustar0000000000000000HsOpenSSL-0.11.3.2/Test/OpenSSL/EVP/Base64.hs0000644000000000000000000000372213001155766016124 0ustar0000000000000000{-# 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 Test.OpenSSL.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