packages feed

HsOpenSSL 0.3.1 → 0.4

raw patch · 9 files changed

+392/−18 lines, 9 filesdep +network

Dependencies added: network

Files

HsOpenSSL.cabal view
@@ -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 <phonohawk at ps dot sakura dot ne dot jp>@@ -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
NEWS view
@@ -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 -----------------------
OpenSSL.hsc view
@@ -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
− OpenSSL/SSL.hs 
@@ -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 ()
OpenSSL/SSL.hsc view
@@ -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 ()
+ OpenSSL/Session.hsc view
@@ -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 ()
+ OpenSSL/SocketBIO.hsc view
@@ -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
cbits/HsOpenSSL.c view
@@ -1,5 +1,6 @@ #include <pthread.h> #include "HsOpenSSL.h"+#include <stdint.h>  /* 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; }
cbits/HsOpenSSL.h view
@@ -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