Permalink
Browse files

Add the beginnings of session support

The main point of openssl is to support actual SSL/TLS connections. This adds
wrappings for enough functions to write a basic SSL/TLS server. Many more
wrappings are probably needed but, for many servers, this will suffice.

darcs-hash:20080213213343-19166-f001956ba727e29f0dbaaa04452fc617aeb01979.gz
  • Loading branch information...
1 parent 85bbcc6 commit ed5b4c2f187d141b647355cbd81e6cfae7f6ef23 @agl agl committed Feb 13, 2008
Showing with 381 additions and 1 deletion.
  1. +3 −1 HsOpenSSL.cabal
  2. +1 −0 OpenSSL.hsc
  3. +4 −0 OpenSSL/SSL.hsc
  4. +198 −0 OpenSSL/Session.hsc
  5. +75 −0 OpenSSL/SocketBIO.hsc
  6. +97 −0 cbits/HsOpenSSL.c
  7. +3 −0 cbits/HsOpenSSL.h
View
@@ -37,7 +37,7 @@ flag splitBase
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 @@ Library
OpenSSL.X509.Revocation
OpenSSL.X509.Request
OpenSSL.X509.Store
+ OpenSSL.SocketBIO
+ OpenSSL.Session
Other-Modules:
OpenSSL.ASN1
OpenSSL.BIO
View
@@ -70,5 +70,6 @@ withOpenSSL :: IO a -> IO a
withOpenSSL act
= do loadErrorStrings
addAllAlgorithms
+ libraryInit
setupMutex
act
View
@@ -1,6 +1,7 @@
module OpenSSL.SSL
( loadErrorStrings
, addAllAlgorithms
+ , libraryInit
)
where
@@ -9,3 +10,6 @@ foreign import ccall unsafe "SSL_load_error_strings"
foreign import ccall unsafe "HsOpenSSL_OpenSSL_add_all_algorithms"
addAllAlgorithms :: IO ()
+
+foreign import ccall unsafe "SSL_library_init"
+ libraryInit :: IO ()
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 ()
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
Oops, something went wrong.

0 comments on commit ed5b4c2

Please sign in to comment.