diff --git a/HsOpenSSL.cabal b/HsOpenSSL.cabal --- a/HsOpenSSL.cabal +++ b/HsOpenSSL.cabal @@ -5,7 +5,7 @@ generate RSA and DSA keys, read and write PEM files, generate message digests, sign and verify messages, encrypt and decrypt messages. -Version: 0.3.1 +Version: 0.4 License: PublicDomain License-File: COPYING Author: PHO @@ -37,7 +37,7 @@ Library if flag(splitBase) - build-depends: base >= 3, bytestring, time >= 1.1.1, old-locale + build-depends: base >= 3, bytestring, time >= 1.1.1, old-locale, network>=2.1.0.0 else build-depends: base < 3, time >= 1.1.1 @@ -66,6 +66,8 @@ OpenSSL.X509.Revocation OpenSSL.X509.Request OpenSSL.X509.Store + OpenSSL.SocketBIO + OpenSSL.Session Other-Modules: OpenSSL.ASN1 OpenSSL.BIO diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,10 @@ +Changes from 0.3.1 to 0.4 +------------------------- +* Applied patches by Adam Langley: + - Add the beginnings of session support + - Add an example SSL server + + Changes from 0.3 to 0.3.1 ------------------------- * OpenSSL.EVP.Base64: Fix a bug in an internal function `decodeBlock': @@ -5,6 +12,7 @@ * Applied patches by Adam Langley: - Updates for 6.8.1 (also *requires* 6.8.1 now) - tests/Base64.hs: Test for Base64 + Changes from 0.2 to 0.3 ----------------------- diff --git a/OpenSSL.hsc b/OpenSSL.hsc --- a/OpenSSL.hsc +++ b/OpenSSL.hsc @@ -8,8 +8,8 @@ -- -- Features that aren't (yet) supported: -- --- [/TLS\/SSL network connection/] ssl(3) functionalities are --- totally uncovered. They should be covered someday. +-- [/TLS\/SSL network connection/] ssl(3) functionalities aren't +-- fully covered yet. -- -- [/Complete coverage of Low-level API to symmetric ciphers/] Only -- high-level APIs (EVP and BIO) are fully available. But I believe @@ -70,5 +70,6 @@ withOpenSSL act = do loadErrorStrings addAllAlgorithms + libraryInit setupMutex act diff --git a/OpenSSL/SSL.hs b/OpenSSL/SSL.hs deleted file mode 100644 --- a/OpenSSL/SSL.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} -{-# LINE 1 "OpenSSL/SSL.hsc" #-} -module OpenSSL.SSL -{-# LINE 2 "OpenSSL/SSL.hsc" #-} - ( loadErrorStrings - , addAllAlgorithms - ) - where - -foreign import ccall unsafe "SSL_load_error_strings" - loadErrorStrings :: IO () - -foreign import ccall unsafe "HsOpenSSL_OpenSSL_add_all_algorithms" - addAllAlgorithms :: IO () diff --git a/OpenSSL/SSL.hsc b/OpenSSL/SSL.hsc --- a/OpenSSL/SSL.hsc +++ b/OpenSSL/SSL.hsc @@ -1,6 +1,7 @@ module OpenSSL.SSL ( loadErrorStrings , addAllAlgorithms + , libraryInit ) where @@ -9,3 +10,6 @@ foreign import ccall unsafe "HsOpenSSL_OpenSSL_add_all_algorithms" addAllAlgorithms :: IO () + +foreign import ccall unsafe "SSL_library_init" + libraryInit :: IO () diff --git a/OpenSSL/Session.hsc b/OpenSSL/Session.hsc new file mode 100644 --- /dev/null +++ b/OpenSSL/Session.hsc @@ -0,0 +1,198 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +-- | Functions for handling SSL/TLS connections over Sockets. The Sockets are +-- wrapped in BIO objects so that openssl works well with Haskell's threading +-- system (i.e. a 'blocking' read will actually allow other green threads to +-- run rather than blocking the whole OS thread) +module OpenSSL.Session + ( -- * Contexts + SSLContext + , context + , contextSetPrivateKeyFile + , contextSetCertificateFile + , contextSetCiphers + , contextSetDefaultCiphers + , contextCheckPrivateKey + + -- * SSL connections + , SSL + , connection + , accept + , read + , write + , ShutdownType(..) + , shutdown + ) where + +#include "openssl/ssl.h" + +import Prelude hiding (read) +import Foreign +import Foreign.C +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B +import Network.Socket (Socket) + +import OpenSSL.Utils (failIfNull, failIf, raiseOpenSSLError) +import OpenSSL.BIO (BIO, BIO_, withBioPtr) +import OpenSSL.SocketBIO (socketToBIO) + +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. +newtype SSLContext = SSLContext (ForeignPtr SSLContext_) + +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 :: FunPtr (Ptr SSLContext_ -> IO ()) +foreign import ccall unsafe "SSLv23_method" _ssl_method :: IO (Ptr SSLMethod_) + +-- | Create a new SSL context. +context :: IO SSLContext +context = _ssl_method >>= _ssl_ctx_new >>= newForeignPtr _ssl_ctx_free >>= return . SSLContext + +contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO Int) + -> SSLContext -> String -> IO () +contextLoadFile f (SSLContext context) path = + withForeignPtr context $ \ctx -> + withCString path $ \cpath -> do + result <- f ctx cpath (#const SSL_FILETYPE_PEM) + if result == 1 + then return () + else f ctx cpath (#const SSL_FILETYPE_ASN1) >>= failIf (/= 1) >> return () + +foreign import ccall unsafe "SSL_CTX_use_PrivateKey_file" + _ssl_ctx_use_privatekey_file :: Ptr SSLContext_ -> CString -> CInt -> IO Int +foreign import ccall unsafe "SSL_CTX_use_certificate_file" + _ssl_ctx_use_certificate_file :: Ptr SSLContext_ -> CString -> CInt -> IO Int + +-- | 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_set_cipher_list" + _ssl_ctx_set_cipher_list :: Ptr SSLContext_ -> CString -> IO Int + +-- | 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 (SSLContext context) list = + withForeignPtr context $ \ctx -> + withCString list $ \cpath -> + _ssl_ctx_set_cipher_list ctx cpath >>= failIf (/= 1) >> return () + +contextSetDefaultCiphers :: SSLContext -> IO () +contextSetDefaultCiphers = flip contextSetCiphers "DEFAULT" + +foreign import ccall unsafe "SSL_CTX_check_private_key" + _ssl_ctx_check_private_key :: Ptr SSLContext_ -> IO Int + +-- | Return true iff the private key installed in the given context matches the +-- certificate also installed. +contextCheckPrivateKey :: SSLContext -> IO Bool +contextCheckPrivateKey (SSLContext context) = + withForeignPtr context $ \ctx -> + _ssl_ctx_check_private_key ctx >>= return . (==) 1 + +data SSL_ +-- | This is the type of an SSL connection +newtype SSL = SSL (Socket, BIO, ForeignPtr SSL_) + +foreign import ccall unsafe "SSL_new" _ssl_new :: Ptr SSLContext_ -> IO (Ptr SSL_) +foreign import ccall unsafe "&SSL_free" _ssl_free :: FunPtr (Ptr SSL_ -> IO ()) +foreign import ccall unsafe "SSL_set_bio" _ssl_set_bio :: Ptr SSL_ -> Ptr BIO_ -> Ptr BIO_ -> IO () + +-- | 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 (SSLContext context) sock = do + bio <- socketToBIO sock + ssl <- withBioPtr bio (\bio -> do + withForeignPtr context (\ctx -> do + ssl <- _ssl_new ctx >>= failIfNull + _ssl_set_bio ssl bio bio + return ssl)) + fpssl <- newForeignPtr _ssl_free ssl + return $ SSL (sock, bio, fpssl) + +foreign import ccall "SSL_accept" _ssl_accept :: Ptr SSL_ -> IO CInt + +-- | Perform an SSL server handshake +accept :: SSL -> IO () +accept (SSL (_, _, ssl)) = withForeignPtr ssl (\ssl -> do + _ssl_accept ssl >>= failIf (/= 1)) >> return () + +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 + +-- | Try the 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 (_, _, ssl)) nbytes = B.createAndTrim nbytes $ \ptr -> + withForeignPtr ssl $ \ssl -> do + n <- _ssl_read ssl ptr $ fromIntegral nbytes + if n > 0 + then return $ fromIntegral n + else if n < 0 + then raiseOpenSSLError + else do + shutdown <- _ssl_get_shutdown ssl + if shutdown .&. (#const SSL_RECEIVED_SHUTDOWN) /= 0 + then return 0 + else fail "SSL connection abruptly terminated" + +foreign import ccall "SSL_write" _ssl_write :: Ptr SSL_ -> Ptr CChar -> 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 (_, _, ssl)) bs = do + withForeignPtr ssl $ \ssl -> + B.unsafeUseAsCStringLen bs $ \(ptr, nbytes) -> + let f _ 0 = return () + f ptr nbytes = do + n <- _ssl_write ssl ptr (fromIntegral nbytes) >>= return . fromIntegral + if n <= 0 + then raiseOpenSSLError + else f (ptr `plusPtr` n) (nbytes - n) + in f ptr nbytes + +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 + +-- | 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 (_, _, ssl)) ty = + withForeignPtr ssl $ \ssl -> do + n <- _ssl_shutdown ssl >>= failIf (< 0) + case ty of + Unidirectional -> return () + Bidirectional -> do + if n == 1 + then return () + else _ssl_shutdown ssl >>= failIf (< 0) >> return () diff --git a/OpenSSL/SocketBIO.hsc b/OpenSSL/SocketBIO.hsc new file mode 100644 --- /dev/null +++ b/OpenSSL/SocketBIO.hsc @@ -0,0 +1,75 @@ +-- | This module wraps a Haskell Socket in a BIO. It's different from the +-- @BIO@ module in that it works the 'other way' - gather than being the +-- client of a BIO, we are the implementation. +module OpenSSL.SocketBIO (socketToBIO) where + +import Foreign +import Foreign.C +import Network.Socket (Socket(..)) +import GHC.Conc (threadWaitRead, threadWaitWrite) + +import OpenSSL.BIO (BIO, BIO_, wrapBioPtr) + +foreign import ccall "socket_BIO_wrapper" _wrapper :: CInt -> IO (Ptr BIO_) + +-- | Convert a Socket into a BIO object. Warning: the file descriptor +-- underlying this Socket is saved in the BIO, but it doesn't carry a +-- reference to the Socket itself. Thus, if you don't keep your own reference +-- then the GC could close the socket from under the BIO. +socketToBIO :: Socket -> IO BIO +socketToBIO (MkSocket s _ _ _ _) = _wrapper s >>= wrapBioPtr + +foreign import ccall unsafe "send" + c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt +foreign import ccall unsafe "recv" + c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt + +-------------------------------------------------------------------------------- +-- Taken from network-bytestring + +{-# SPECIALISE + throwErrnoIfMinus1Retry_mayBlock + :: String -> IO CInt -> IO CInt -> IO CInt #-} +throwErrnoIfMinus1Retry_mayBlock :: Num a => String -> IO a -> IO a -> IO a +throwErrnoIfMinus1Retry_mayBlock name on_block act = do + res <- act + if res == -1 + then do + err <- getErrno + if err == eINTR + then throwErrnoIfMinus1Retry_mayBlock name on_block act + else if err == eWOULDBLOCK || err == eAGAIN + then on_block + else return (-1) + else return res + +throwErrnoIfMinus1Retry_repeatOnBlock :: Num a => String -> IO b -> IO a -> IO a +throwErrnoIfMinus1Retry_repeatOnBlock name on_block act = do + throwErrnoIfMinus1Retry_mayBlock name (on_block >> repeat) act + where repeat = throwErrnoIfMinus1Retry_repeatOnBlock name on_block act + +-------------------------------------------------------------------------------- +-- The following functions are callback Haskell functions which are exported to +-- the C code + +bioRead :: CInt -> Ptr Word8 -> CInt -> IO CInt +bioRead fd ptr nbytes = do + len <- throwErrnoIfMinus1Retry_repeatOnBlock "bioRead" + (threadWaitRead (fromIntegral fd)) $ + c_recv fd (castPtr ptr) (fromIntegral nbytes) 0 + if fromIntegral len == (-1 :: Int) + then do errno <- getErrno + if errno == eINTR + then bioRead fd ptr nbytes + else return (-1) + else return len + +bioWrite :: CInt -> Ptr Word8 -> CInt -> IO CInt +bioWrite fd ptr nbytes = do + len <- throwErrnoIfMinus1Retry_repeatOnBlock "bioWrite" + (threadWaitWrite (fromIntegral fd)) $ + c_send fd (castPtr ptr) (fromIntegral nbytes) 0 + return len + +foreign export ccall "bioRead" bioRead :: CInt -> Ptr Word8 -> CInt -> IO CInt +foreign export ccall "bioWrite" bioWrite :: CInt -> Ptr Word8 -> CInt -> IO CInt diff --git a/cbits/HsOpenSSL.c b/cbits/HsOpenSSL.c --- a/cbits/HsOpenSSL.c +++ b/cbits/HsOpenSSL.c @@ -1,5 +1,6 @@ #include #include "HsOpenSSL.h" +#include /* OpenSSL ********************************************************************/ void HsOpenSSL_OpenSSL_add_all_algorithms() { @@ -201,4 +202,100 @@ sig.r = r; sig.s = s; return dsa->meth->dsa_do_verify(ddata, dlen, &sig, dsa); +} + +/* Socket BIO *****************************************************************/ + +extern int bioRead(int fd, char *buffer, int size); +extern int bioWrite(int fd, const char *buffer, int size); + +static int +wrapped_bio_fd(BIO *b) { + return (int) ((intptr_t) b->ptr); +} + +static int +wrapped_bio_write(BIO *b, const char *ptr, int size) { + const int fd = wrapped_bio_fd(b); + return bioWrite(fd, ptr, size); +} + +static int +wrapped_bio_read(BIO *b, char *ptr, int size) { + const int fd = wrapped_bio_fd(b); + return bioRead(fd, ptr, size); +} + +static int +wrapped_bio_puts(BIO *b, const char *str) { + const int fd = wrapped_bio_fd(b); + const int n = strlen(str); + return bioWrite(fd, str, n); +} + +static int +wrapped_bio_new(BIO *b) { + b->init = 1; + b->shutdown = 0; + b->flags = 0; + b->retry_reason = 0; + b->num = 0; + b->ptr = NULL; + b->next_bio = b->prev_bio = NULL; + b->callback = NULL; + // By default, reference is set to one and functions like SSL_set_bio 'steal' + // the reference. This makes sense for C programmers who can then ignore the + // reference count and everything will work out. However, we want to keep a + // reference because this ends up in a ForeignPtr and so the GC will want to + // destroy it at some point. + b->references = 2; + + return 1; +} + +static int +wrapped_bio_free(BIO *b) { + return 1; +} + +static long +wrapped_bio_ctl(BIO *b, int cmd, long num, void *ptr) { + long ret = 1; + + switch (cmd) { + case BIO_CTRL_RESET: + case BIO_C_FILE_SEEK: + case BIO_C_FILE_TELL: + case BIO_CTRL_INFO: + case BIO_C_SET_FD: + case BIO_C_GET_FD: + case BIO_CTRL_GET_CLOSE: + case BIO_CTRL_PENDING: + case BIO_CTRL_WPENDING: + return 0; + case BIO_CTRL_SET_CLOSE: + case BIO_CTRL_DUP: + case BIO_CTRL_FLUSH: + return 1; + default: + return 0; + } +} + +static BIO_METHOD wrapper_methods = + { BIO_TYPE_SOCKET, + "socket", + wrapped_bio_write, + wrapped_bio_read, + wrapped_bio_puts, + NULL, /* gets */ + wrapped_bio_ctl, + wrapped_bio_new, + wrapped_bio_free, + NULL, }; + +BIO *socket_BIO_wrapper(int fd) { + BIO *const b = BIO_new(&wrapper_methods); + b->ptr = (void *) ((intptr_t) fd); + return b; } diff --git a/cbits/HsOpenSSL.h b/cbits/HsOpenSSL.h --- a/cbits/HsOpenSSL.h +++ b/cbits/HsOpenSSL.h @@ -69,5 +69,8 @@ int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int len, BIGNUM *r, BIGNUM *s); +/* Socket BIO *****************************************************************/ + +BIO *socket_BIO_wrapper(int fd); #endif