diff --git a/HsOpenSSL.cabal b/HsOpenSSL.cabal --- a/HsOpenSSL.cabal +++ b/HsOpenSSL.cabal @@ -5,7 +5,7 @@ can generate RSA and DSA keys, read and write PEM files, generate message digests, sign and verify messages, encrypt and decrypt messages. -Version: 0.6 +Version: 0.6.1 License: PublicDomain License-File: COPYING Author: Adam Langley , PHO diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,5 +1,15 @@ -*- Coding: utf-8 -*- +Changes from 0.6 to 0.6.1 +------------------------- +* OpenSSL.Session: + - New functions: + # lazyRead + # lazyWrite + # contextGetCAStore + # contextSetPrivateKey + # contextSetCertificate + Changes from 0.5.2 to 0.6 ------------------------- * INCOMPATIBLE CHANGES: diff --git a/OpenSSL/BIO.hsc b/OpenSSL/BIO.hsc --- a/OpenSSL/BIO.hsc +++ b/OpenSSL/BIO.hsc @@ -74,11 +74,12 @@ import Control.Monad import Data.ByteString.Internal (createAndTrim, toForeignPtr) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import Foreign hiding (new) +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 qualified GHC.ForeignPtr as GF +import qualified GHC.ForeignPtr as GF import OpenSSL.Utils import System.IO.Unsafe @@ -229,12 +230,12 @@ -- |@'bioRead' bio@ lazily reads all data in @bio@. bioRead :: BIO -> IO String bioRead bio - = liftM L8.unpack $ bioReadLBS 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 B8.ByteString +bioReadBS :: BIO -> Int -> IO B.ByteString bioReadBS bio maxLen = withBioPtr bio $ \ bioPtr -> createAndTrim maxLen $ \ bufPtr -> @@ -249,15 +250,15 @@ -- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a -- LazyByteString. -bioReadLBS :: BIO -> IO L8.ByteString -bioReadLBS bio = lazyRead >>= return . L8.fromChunks +bioReadLBS :: BIO -> IO L.ByteString +bioReadLBS bio = lazyRead >>= return . L.fromChunks where - chunkSize = 32 * 1024 + chunkSize = L.defaultChunkSize lazyRead = unsafeInterleaveIO loop loop = do bs <- bioReadBS bio chunkSize - if B8.null bs then + if B.null bs then do isEOF <- bioEOF bio if isEOF then return [] @@ -277,10 +278,10 @@ -- return the digest and other BIOs may not support 'bioGets' at all. bioGets :: BIO -> Int -> IO String bioGets bio maxLen - = liftM B8.unpack (bioGetsBS bio maxLen) + = liftM B.unpack (bioGetsBS bio maxLen) -- |'bioGetsBS' does the same as 'bioGets' but returns ByteString. -bioGetsBS :: BIO -> Int -> IO B8.ByteString +bioGetsBS :: BIO -> Int -> IO B.ByteString bioGetsBS bio maxLen = withBioPtr bio $ \ bioPtr -> createAndTrim maxLen $ \ bufPtr -> @@ -295,18 +296,18 @@ -- |'bioGetsLBS' does the same as 'bioGets' but returns -- LazyByteString. -bioGetsLBS :: BIO -> Int -> IO L8.ByteString +bioGetsLBS :: BIO -> Int -> IO L.ByteString bioGetsLBS bio maxLen - = bioGetsBS bio maxLen >>= \ bs -> (return . L8.fromChunks) [bs] + = 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 . L8.pack) str >>= bioWriteLBS bio + = (return . L.pack) str >>= bioWriteLBS bio -- |@'bioWriteBS' bio bs@ writes @bs@ to @bio@. -bioWriteBS :: BIO -> B8.ByteString -> IO () +bioWriteBS :: BIO -> B.ByteString -> IO () bioWriteBS bio bs = withBioPtr bio $ \ bioPtr -> unsafeUseAsCStringLen bs $ \ (buf, len) -> @@ -314,17 +315,17 @@ where interpret :: CInt -> IO () interpret n - | n == fromIntegral (B8.length bs) + | n == fromIntegral (B.length bs) = return () | n == -1 = bioWriteBS bio bs -- full retry | n < -1 = raiseOpenSSLError - | otherwise = bioWriteBS bio (B8.drop (fromIntegral n) bs) -- partial retry + | 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 -> L8.ByteString -> IO () +bioWriteLBS :: BIO -> L.ByteString -> IO () bioWriteLBS bio lbs - = mapM_ (bioWriteBS bio) $ L8.toChunks lbs + = mapM_ (bioWriteBS bio) $ L.toChunks lbs {- base64 ------------------------------------------------------------------- -} @@ -435,10 +436,10 @@ -- |@'newConstMem' str@ creates a read-only memory BIO source. newConstMem :: String -> IO BIO newConstMem str - = (return . B8.pack) str >>= newConstMemBS + = (return . B.pack) str >>= newConstMemBS -- |@'newConstMemBS' bs@ is like 'newConstMem' but takes a ByteString. -newConstMemBS :: B8.ByteString -> IO BIO +newConstMemBS :: B.ByteString -> IO BIO newConstMemBS bs = let (foreignBuf, off, len) = toForeignPtr bs in @@ -454,9 +455,9 @@ -- |@'newConstMemLBS' lbs@ is like 'newConstMem' but takes a -- LazyByteString. -newConstMemLBS :: L8.ByteString -> IO BIO +newConstMemLBS :: L.ByteString -> IO BIO newConstMemLBS lbs - = (return . B8.concat . L8.toChunks) lbs >>= newConstMemBS + = (return . B.concat . L.toChunks) lbs >>= newConstMemBS {- null --------------------------------------------------------------------- -} diff --git a/OpenSSL/Session.hsc b/OpenSSL/Session.hsc --- a/OpenSSL/Session.hsc +++ b/OpenSSL/Session.hsc @@ -6,6 +6,8 @@ ( -- * Contexts SSLContext , context + , contextSetPrivateKey + , contextSetCertificate , contextSetPrivateKeyFile , contextSetCertificateFile , contextSetCiphers @@ -15,6 +17,7 @@ , contextSetVerificationMode , contextSetCAFile , contextSetCADirectory + , contextGetCAStore -- * SSL connections , SSL @@ -23,6 +26,8 @@ , connect , read , write + , lazyRead + , lazyWrite , shutdown , ShutdownType(..) , getPeerCertificate @@ -38,14 +43,20 @@ import Control.Exception (finally) 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 System.IO.Error (mkIOError, ioError, eofErrorType) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L +import System.IO.Error (mkIOError, ioError, eofErrorType, catch, isEOFError) +import System.IO.Unsafe import System.Posix.Types (Fd(..)) import Network.Socket (Socket(..)) +import OpenSSL.EVP.PKey import OpenSSL.Utils (failIfNull, failIf) -import OpenSSL.X509 (X509, X509_, wrapX509) +import OpenSSL.X509 (X509, X509_, wrapX509, withX509Ptr) +import OpenSSL.X509.Store data SSLContext_ -- | An SSL context. Contexts carry configuration such as a server's private @@ -80,6 +91,10 @@ waitQSem sem finally (withForeignPtr ctxfp action) $ signalQSem sem +touchContext :: SSLContext -> IO () +touchContext (SSLContext (_, fp)) + = touchForeignPtr fp + contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO CInt) -> SSLContext -> String -> IO () contextLoadFile f context path = @@ -90,6 +105,29 @@ then return () else f ctx cpath (#const SSL_FILETYPE_ASN1) >>= failIf (/= 1) >> return () +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) + >> return () + +-- | 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) + >> return () + 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" @@ -180,8 +218,18 @@ _ssl_load_verify_locations ctx nullPtr cpath >>= failIf (/= 1) return () +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 -- @@ -309,13 +357,20 @@ -- 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 (_, _, fd, _)) nbytes = B.createAndTrim nbytes $ f ssl where - f ssl ptr = do - result <- withSSL ssl $ sslIOInner _ssl_read (castPtr ptr) nbytes - case result of - Done n -> return $ fromIntegral n - WantRead -> threadWaitRead fd >> f ssl ptr - WantWrite -> threadWaitWrite fd >> f ssl ptr +read ssl@(SSL (_, _, fd, _)) nbytes = B.createAndTrim nbytes $ f ssl + where + f ssl ptr + = do result <- withSSL ssl $ sslIOInner _ssl_read (castPtr ptr) nbytes + case result of + Done n -> return $ fromIntegral n + WantRead -> threadWaitRead fd >> f ssl ptr + WantWrite -> threadWaitWrite fd >> f ssl ptr + `catch` + \ ioe -> + if isEOFError ioe then + return 0 + else + ioError ioe -- rethrow foreign import ccall "SSL_write" _ssl_write :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt @@ -329,6 +384,31 @@ Done _ -> return () WantRead -> threadWaitRead fd >> f ssl (ptr, len) WantWrite -> threadWaitWrite fd >> f ssl (ptr, len) + +-- | 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 = lazyRead' >>= return . L.fromChunks + 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 diff --git a/OpenSSL/X509/Store.hsc b/OpenSSL/X509/Store.hsc --- a/OpenSSL/X509/Store.hsc +++ b/OpenSSL/X509/Store.hsc @@ -9,6 +9,8 @@ , X509_STORE -- private , newX509Store + + , wrapX509Store -- private , withX509StorePtr -- private , addCertToStore @@ -18,6 +20,7 @@ import Foreign import Foreign.C +import Foreign.Concurrent as FC import OpenSSL.X509 import OpenSSL.X509.Revocation import OpenSSL.Utils @@ -32,8 +35,8 @@ foreign import ccall unsafe "X509_STORE_new" _new :: IO (Ptr X509_STORE) -foreign import ccall unsafe "&X509_STORE_free" - _free :: FunPtr (Ptr X509_STORE -> IO ()) +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 @@ -45,9 +48,13 @@ newX509Store :: IO X509Store newX509Store = _new >>= failIfNull - >>= newForeignPtr _free - >>= return . X509Store + >>= \ 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)