packages feed

HsOpenSSL 0.4 → 0.4.1

raw patch · 11 files changed

+304/−267 lines, 11 files

Files

HsOpenSSL.cabal view
@@ -5,16 +5,17 @@         generate RSA and DSA keys, read and write PEM files, generate         message digests, sign and verify messages, encrypt and decrypt         messages.-Version: 0.4+Version: 0.4.1 License: PublicDomain License-File: COPYING-Author: PHO <phonohawk at ps dot sakura dot ne dot jp>-Maintainer: PHO <phonohawk at ps dot sakura dot ne dot jp>+Author: PHO <pho at cielonegro.org>+Maintainer: PHO <pho at cielonegro.org> Stability: experimental Homepage: http://ccm.sherry.jp/HsOpenSSL/ Category: Cryptography Tested-With: GHC == 6.8.1 Cabal-Version: >= 1.2+Build-Type: Configure  Extra-Source-Files: 	AUTHORS@@ -66,7 +67,6 @@           OpenSSL.X509.Revocation           OpenSSL.X509.Request           OpenSSL.X509.Store-          OpenSSL.SocketBIO           OpenSSL.Session   Other-Modules:           OpenSSL.ASN1
NEWS view
@@ -1,3 +1,15 @@+Changes from 0.4 to 0.4.1+-------------------------+* Applied patches by Adam Langley:+  - Fix BN<->Integer conversions on 64-bit systems+  - Another 64-bit fix (OpenSSL.ASN1.peekASN1String)+  - Add ByteString version of digestBS+  - Fix the foreign types of the cipher functions to use CInt, not Int+  - 64-bit fix for HMAC+  - Turn the Session IO inside out+  - Silly cosmetic change++ Changes from 0.3.1 to 0.4 ------------------------- * Applied patches by Adam Langley:
OpenSSL/ASN1.hsc view
@@ -61,8 +61,8 @@ peekASN1String :: Ptr ASN1_STRING -> IO String peekASN1String strPtr     = do buf <- (#peek ASN1_STRING, data  ) strPtr-         len <- (#peek ASN1_STRING, length) strPtr-         peekCStringLen (buf, len)+         len <- (#peek ASN1_STRING, length) strPtr :: IO CInt+         peekCStringLen (buf, fromIntegral len)   {- ASN1_INTEGER -------------------------------------------------------------- -}
OpenSSL/BN.hsc view
@@ -51,7 +51,6 @@ import           Foreign.C #else import           Foreign.C.Types-import           Data.Word (Word32) import           GHC.Base import           GHC.Num import           GHC.Prim@@ -164,11 +163,11 @@ -- | Convert a BIGNUM to an Integer bnToInteger :: BigNum -> IO Integer bnToInteger bn = do-  nlimbs <- (#peek BIGNUM, top) (unwrapBN bn) :: IO CSize+  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 Word32+            negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO CInt             if negative == 0                then return $ S## i                else return $ 0 - (S## i)@@ -179,7 +178,7 @@       (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 Word32+      negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO CInt       if negative == 0          then return $ J## nlimbsi ba          else return $ 0 - (J## nlimbsi ba)@@ -191,9 +190,9 @@   bnptr <- mallocBytes (#size BIGNUM)   (#poke BIGNUM, d) bnptr nullPtr   -- This is needed to give GHC enough type information-  let one :: Word32+  let one :: CInt       one = 1-      zero :: Word32+      zero :: CInt       zero = 0   (#poke BIGNUM, flags) bnptr one   (#poke BIGNUM, top) bnptr zero@@ -203,12 +202,12 @@  integerToBN (S## v) = do   bnptr <- mallocBytes (#size BIGNUM)-  limbs <- malloc :: IO (Ptr Word32)+  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 :: Word32+  let one :: CInt       one = 1   (#poke BIGNUM, flags) bnptr one   (#poke BIGNUM, top) bnptr one@@ -220,16 +219,16 @@   | v >= 0 = do       let nlimbs = (I## nlimbs_)       bnptr <- mallocBytes (#size BIGNUM)-      limbs <- mallocBytes ((#size unsigned) * nlimbs)+      limbs <- mallocBytes ((#size unsigned long) * nlimbs)       (#poke BIGNUM, d) bnptr limbs-      (#poke BIGNUM, flags) bnptr (1 :: Word32)-      _copy_out limbs bytearray (fromIntegral $ (#size unsigned) * nlimbs)-      (#poke BIGNUM, top) bnptr ((fromIntegral nlimbs) :: Word32)-      (#poke BIGNUM, dmax) bnptr ((fromIntegral nlimbs) :: Word32)-      (#poke BIGNUM, neg) bnptr (0 :: Word32)+      (#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 :: Word32)+                   (#poke BIGNUM, neg) (unwrapBN bnptr) (1 :: CInt)                    return bnptr  -- TODO: we could make a function which doesn't even allocate BN data if we
OpenSSL/EVP/Cipher.hsc view
@@ -121,16 +121,16 @@   foreign import ccall unsafe "EVP_CipherInit"-        _CipherInit :: Ptr EVP_CIPHER_CTX -> Ptr EVP_CIPHER -> CString -> CString -> Int -> IO Int+        _CipherInit :: Ptr EVP_CIPHER_CTX -> Ptr EVP_CIPHER -> CString -> CString -> CInt -> IO CInt  foreign import ccall unsafe "EVP_CipherUpdate"-        _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr Int -> Ptr CChar -> Int -> IO Int+        _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> Ptr CChar -> CInt -> IO CInt  foreign import ccall unsafe "EVP_CipherFinal"-        _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr Int -> IO Int+        _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> IO CInt  -cryptoModeToInt :: CryptoMode -> Int+cryptoModeToInt :: CryptoMode -> CInt cryptoModeToInt Encrypt = 1 cryptoModeToInt Decrypt = 0 @@ -152,9 +152,9 @@       unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) ->       createAndTrim (inLen + _ctx_block_size ctxPtr - 1) $ \ outBuf ->       alloca $ \ outLenPtr ->-      _CipherUpdate ctxPtr (castPtr outBuf) outLenPtr inBuf inLen+      _CipherUpdate ctxPtr (castPtr outBuf) outLenPtr inBuf (fromIntegral inLen)            >>= failIf (/= 1)-           >>  peek outLenPtr+           >>  liftM fromIntegral (peek outLenPtr)   cipherFinalBS :: CipherCtx -> IO B8.ByteString@@ -164,7 +164,7 @@       alloca $ \ outLenPtr ->       _CipherFinal ctxPtr (castPtr outBuf) outLenPtr            >>= failIf (/= 1)-           >>  peek outLenPtr+           >>  liftM fromIntegral (peek outLenPtr)  -- |@'cipher'@ lazilly encrypts or decrypts a stream of data. The -- input string doesn't necessarily have to be finite.
OpenSSL/EVP/Digest.hsc view
@@ -23,6 +23,7 @@      , digest     , digestBS+    , digestBS'     , digestLBS      , hmacBS@@ -30,6 +31,7 @@     where  import           Control.Monad+import           Data.ByteString.Internal (createAndTrim) import           Data.ByteString.Unsafe (unsafeUseAsCStringLen) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8@@ -133,7 +135,15 @@          bufLen <- liftM fromIntegral $ peek bufLenPtr          peekCStringLen (bufPtr, bufLen) +digestFinalBS :: DigestCtx -> IO B8.ByteString+digestFinalBS ctx =+  withDigestCtxPtr ctx $ \ctxPtr ->+  createAndTrim (#const EVP_MAX_MD_SIZE) $ \bufPtr ->+  alloca $ \bufLenPtr ->+  do _DigestFinal ctxPtr (castPtr bufPtr) bufLenPtr >>= failIf (/= 1)+     liftM fromIntegral $ peek bufLenPtr + digestStrictly :: Digest -> B8.ByteString -> IO DigestCtx digestStrictly md input     = do ctx <- digestInit md@@ -161,6 +171,12 @@       do ctx <- digestStrictly md input          digestFinal ctx +digestBS' :: Digest -> B8.ByteString -> B8.ByteString+digestBS' md input+    = unsafePerformIO $+      do ctx <- digestStrictly md input+         digestFinalBS ctx+ -- |@'digestLBS'@ digests a stream of data. digestLBS :: Digest -> L8.ByteString -> String digestLBS md input@@ -171,7 +187,7 @@ {- HMAC ---------------------------------------------------------------------- -}  foreign import ccall unsafe "HMAC"-        _HMAC :: Ptr EVP_MD -> Ptr CChar -> CInt -> Ptr CChar -> CInt+        _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
OpenSSL/Session.hsc view
@@ -1,8 +1,7 @@ {-# 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)+-- | 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@@ -12,29 +11,41 @@   , contextSetCiphers   , contextSetDefaultCiphers   , contextCheckPrivateKey+  , VerificationMode(..)+  , contextSetVerificationMode+  , contextSetCAFile+  , contextSetCADirectory      -- * SSL connections   , SSL   , connection   , accept+  , connect   , read   , write-  , ShutdownType(..)   , shutdown+  , ShutdownType(..)+  , getPeerCertificate+  , getVerifyResult+  , sslSocket   ) where  #include "openssl/ssl.h" -import Prelude hiding (read)+import Prelude hiding (read, ioError)+import Control.Concurrent (threadWaitWrite, threadWaitRead)+import Control.Concurrent.QSem+import Control.Exception (finally) import Foreign import Foreign.C import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B-import Network.Socket (Socket)+import System.IO.Error (mkIOError, ioError, eofErrorType)+import System.Posix.Types (Fd(..))+import Network.Socket (Socket(..)) -import OpenSSL.Utils (failIfNull, failIf, raiseOpenSSLError)-import OpenSSL.BIO (BIO, BIO_, withBioPtr)-import OpenSSL.SocketBIO (socketToBIO)+import OpenSSL.Utils (failIfNull, failIf)+import OpenSSL.X509 (X509, X509_, wrapX509)  data SSLContext_ -- | An SSL context. Contexts carry configuration such as a server's private@@ -42,7 +53,11 @@ --   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_)+--+--   Contexts are not thread safe so they carry a QSem with them which only+--   lets a single thread work inside them at a time. Thus, one must always use+--   withContext, not withForeignPtr directly.+newtype SSLContext = SSLContext (QSem, ForeignPtr SSLContext_)  data SSLMethod_ @@ -52,12 +67,23 @@  -- | Create a new SSL context. context :: IO SSLContext-context = _ssl_method >>= _ssl_ctx_new >>= newForeignPtr _ssl_ctx_free >>= return . SSLContext+context = do+  ctx <- _ssl_method >>= _ssl_ctx_new+  context <- newForeignPtr _ssl_ctx_free ctx+  sem <- newQSem 1+  return $ SSLContext (sem, context) +-- | 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 (SSLContext (sem, ctxfp)) action = do+  waitQSem sem+  finally (withForeignPtr ctxfp action) $ signalQSem sem+ contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO Int)                 -> SSLContext -> String -> IO ()-contextLoadFile f (SSLContext context) path =-  withForeignPtr context $ \ctx ->+contextLoadFile f context path =+  withContext context $ \ctx ->     withCString path $ \cpath -> do       result <- f ctx cpath (#const SSL_FILETYPE_PEM)       if result == 1@@ -91,8 +117,8 @@ --   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 ->+contextSetCiphers context list =+  withContext context $ \ctx ->     withCString list $ \cpath ->       _ssl_ctx_set_cipher_list ctx cpath >>= failIf (/= 1) >> return () @@ -105,75 +131,202 @@ -- | 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 ->+contextCheckPrivateKey context =+  withContext context $ \ctx ->     _ssl_ctx_check_private_key ctx >>= return . (==) 1 +-- | See <http://www.openssl.org/docs/ssl/SSL_CTX_set_verify.html>+data VerificationMode = VerifyNone+                      | VerifyPeer Bool  -- ^ is a certificate required+                                   Bool  -- ^ only request once per connection++foreign import ccall unsafe "SSL_CTX_set_verify"+   _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> Ptr () -> IO ()++contextSetVerificationMode :: SSLContext -> VerificationMode -> IO ()+contextSetVerificationMode context VerifyNone = do+  withContext context $ \ctx ->+    _ssl_set_verify_mode ctx (#const SSL_VERIFY_NONE) nullPtr >> return ()++contextSetVerificationMode context (VerifyPeer reqp oncep) = 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 ->+    _ssl_set_verify_mode ctx mode nullPtr >> 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 = do+  withContext context $ \ctx ->+    withCString path $ \cpath -> do+      _ssl_load_verify_locations ctx cpath nullPtr >>= failIf (/= 1)+      return ()++-- | Set the path to a directory which contains the PEM encoded CA root+--   certificates. This is an alternative to 'contextSetCAFile'. See+--   <http://www.openssl.org/docs/ssl/SSL_CTX_load_verify_locations.html> for+--   details of the file naming scheme+contextSetCADirectory :: SSLContext -> FilePath -> IO ()+contextSetCADirectory context path = do+  withContext context $ \ctx ->+    withCString path $ \cpath -> do+      _ssl_load_verify_locations ctx nullPtr cpath >>= failIf (/= 1)+      return ()+++ data SSL_ -- | This is the type of an SSL connection-newtype SSL = SSL (Socket, BIO, ForeignPtr SSL_)+--+--   SSL objects are not thread safe, so they carry a QSem around with them+--   which only lets a single thread work inside them at a time. Thus, one must+--   always use withSSL, rather than withForeignPtr directly.+--+--   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.+newtype SSL = SSL (QSem, ForeignPtr SSL_, Fd, Socket)  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 ()+foreign import ccall unsafe "SSL_set_fd" _ssl_set_fd :: Ptr SSL_ -> CInt -> 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))+connection context sock@(MkSocket fd _ _ _ _) = do+  sem <- newQSem 1+  ssl <- withContext context (\ctx -> do+    ssl <- _ssl_new ctx >>= failIfNull+    _ssl_set_fd ssl fd+    return ssl)   fpssl <- newForeignPtr _ssl_free ssl-  return $ SSL (sock, bio, fpssl)+  return $ SSL (sem, fpssl, Fd fd, sock) +withSSL :: SSL -> (Ptr SSL_ -> IO a) -> IO a+withSSL (SSL (sem, ssl, _, _)) action = do+  waitQSem sem+  finally (withForeignPtr ssl action) $ signalQSem sem+ 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 +sslErrorToString :: CInt -> String+sslErrorToString (#const SSL_ERROR_NONE) = "SSL: No error"+sslErrorToString (#const SSL_ERROR_ZERO_RETURN) = "SSL: connection cleanly closed"+sslErrorToString (#const SSL_ERROR_WANT_CONNECT) = "SSL: want connect"+sslErrorToString (#const SSL_ERROR_WANT_ACCEPT) = "SSL: want accept"+sslErrorToString (#const SSL_ERROR_WANT_X509_LOOKUP) = "SSL: want X509 lookup"+sslErrorToString (#const SSL_ERROR_SYSCALL) = "SSL: syscall error"+sslErrorToString (#const SSL_ERROR_SSL) = "SSL: ssl protocol error"+sslErrorToString x = "SSL: unknown error " ++ show x++-- | This is the type of an SSL IO operation. EOF and termination 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 SSLIOResult = Done CInt  -- ^ successfully mananged *n* bytes+                 | WantRead  -- ^ needs more data from the network+                 | WantWrite  -- ^ needs more outgoing buffer space+                 deriving (Eq)+++-- | 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.+sslDoHandshake :: (Ptr SSL_ -> IO CInt) -> SSL -> IO CInt+sslDoHandshake action ssl@(SSL (_, _, fd, _)) = do+  let f ssl = do+        n <- action ssl+        case n of+             n | n >= 0 -> return $ Done n+             _ -> do+               err <- _ssl_get_error ssl n+               case err of+                    (#const SSL_ERROR_WANT_READ) -> return WantRead+                    (#const SSL_ERROR_WANT_WRITE) -> return WantWrite+                    _ -> fail $ sslErrorToString err+  result <- withSSL ssl f+  case result of+       Done n -> return n+       WantRead -> threadWaitRead fd >> sslDoHandshake action ssl+       WantWrite -> threadWaitWrite fd >> sslDoHandshake action ssl+ -- | Perform an SSL server handshake accept :: SSL -> IO ()-accept (SSL (_, _, ssl)) = withForeignPtr ssl (\ssl -> do-  _ssl_accept ssl >>= failIf (/= 1)) >> return ()+accept ssl = sslDoHandshake _ssl_accept ssl >>= failIf (/= 1) >> return () +-- | Perform an SSL client handshake+connect :: SSL -> IO ()+connect ssl = sslDoHandshake _ssl_connect 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 +-- | 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 availible.+--+--   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 :: (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt)  -- ^ the SSL IO function to call+           -> Ptr CChar  -- ^ the buffer to pass+           -> Int  -- ^ the length to pass+           -> Ptr SSL_+           -> IO SSLIOResult+sslIOInner f ptr nbytes ssl = do+  n <- f ssl (castPtr ptr) $ fromIntegral nbytes+  case n of+       n | n > 0 -> return $ Done $ fromIntegral n+         | n == 0 -> do+           shutdown <- _ssl_get_shutdown ssl+           if shutdown .&. (#const SSL_RECEIVED_SHUTDOWN) == 0+              then fail "SSL connection abruptly terminated"+              else ioError $ mkIOError eofErrorType  "" Nothing Nothing+       _ -> do+           err <- _ssl_get_error ssl n+           case err of+                (#const SSL_ERROR_WANT_READ) -> return WantRead+                (#const SSL_ERROR_WANT_WRITE) -> return WantWrite+                _ -> fail $ sslErrorToString err+ -- | 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"+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 -foreign import ccall "SSL_write" _ssl_write :: Ptr SSL_ -> Ptr CChar -> CInt -> IO CInt+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 (_, _, 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+write ssl@(SSL (_, _, fd, _)) bs = B.unsafeUseAsCStringLen bs $ f ssl where+  f ssl (ptr, len) = do+    result <- withSSL ssl $ sslIOInner _ssl_write ptr len+    case result of+         Done _ -> return ()+         WantRead -> threadWaitRead fd >> f ssl (ptr, len)+         WantWrite -> threadWaitWrite fd >> f ssl (ptr, len)  foreign import ccall "SSL_shutdown" _ssl_shutdown :: Ptr SSL_ -> IO CInt @@ -187,12 +340,44 @@ --   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 ()+shutdown ssl ty = do+  n <- sslDoHandshake _ssl_shutdown ssl+  case ty of+       Unidirectional -> return ()+       Bidirectional -> do+         if n == 1+            then return ()+            else shutdown ssl ty++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 wrapX509 cert >>= return . Just++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 = do+  withSSL ssl $ \ssl -> do+    r <- _ssl_get_verify_result ssl+    return $ r == (#const X509_V_OK)++-- | Get the socket underlying an SSL connection+sslSocket :: SSL -> Socket+sslSocket (SSL (_, _, _, socket)) = socket
− OpenSSL/SocketBIO.hsc 
@@ -1,75 +0,0 @@--- | 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
OpenSSL/X509/Name.hsc view
@@ -64,7 +64,7 @@ peekX509Name :: Ptr X509_NAME -> Bool -> IO [(String, String)] peekX509Name namePtr wantLongName     = do count <- _entry_count namePtr >>= failIf (< 0)-         mapM peekEntry $ take count [0..]+         mapM peekEntry [0..count - 1]     where       peekEntry :: Int -> IO (String, String)       peekEntry n
cbits/HsOpenSSL.c view
@@ -203,99 +203,3 @@   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,8 +69,4 @@ 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