Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

479 lines (390 sloc) 16.3 kb
{- --------------------------------------------------------------------------- -}
{- -}
{- FOR INTERNAL USE ONLY -}
{- -}
{- When I firstly saw the manpage of bio(3), it looked like a great API. I ac- -}
{- tually wrote a wrapper and even wrote a document. What a pain! -}
{- -}
{- Now I realized that BIOs aren't necessary to we Haskell hackers. Their fun- -}
{- ctionalities overlaps with Haskell's own I/O system. The only thing which -}
{- wasn't available without bio(3) -- at least I thought so -- was the -}
{- BIO_f_base64(3), but I found an undocumented API for the Base64 codec. -}
{- I FOUND AN UNDOCUMENTED API FOR THE VERY BASE64 CODEC. -}
{- So I decided to bury all the OpenSSL.BIO module. The game is over. -}
{- -}
{- --------------------------------------------------------------------------- -}
-- |A BIO is an I\/O abstraction, it hides many of the underlying I\/O
-- details from an application, if you are writing a pure C
-- application...
--
-- I know, we are hacking on Haskell so BIO components like BIO_s_file
-- are hardly needed. But for filter BIOs, such as BIO_f_base64 and
-- BIO_f_cipher, they should be useful too to us.
module OpenSSL.BIO
( -- * Type
BIO
, BIO_
, wrapBioPtr -- private
, withBioPtr -- private
, withBioPtr' -- private
-- * BIO chaning
, bioPush
, (==>)
, (<==)
, bioJoin
-- * BIO control operations
, bioFlush
, bioReset
, bioEOF
-- * BIO I\/O functions
, bioRead
, bioReadBS
, bioReadLBS
, bioGets
, bioGetsBS
, bioGetsLBS
, bioWrite
, bioWriteBS
, bioWriteLBS
-- * Base64 BIO filter
, newBase64
-- * Buffering BIO filter
, newBuffer
-- * Memory BIO sink\/source
, newMem
, newConstMem
, newConstMemBS
, newConstMemLBS
-- * Null data BIO sink\/source
, newNullBIO
)
where
import Control.Monad
import Data.ByteString.Internal (createAndTrim, toForeignPtr)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
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 Foreign.Concurrent as Conc
import OpenSSL.Utils
import System.IO.Unsafe
{- bio ---------------------------------------------------------------------- -}
data BIO_METHOD
-- |@BIO@ is a @ForeignPtr@ to an opaque BIO object. They are created by newXXX actions.
newtype BIO = BIO (ForeignPtr BIO_)
data BIO_
foreign import ccall unsafe "BIO_new"
_new :: Ptr BIO_METHOD -> IO (Ptr BIO_)
foreign import ccall unsafe "BIO_free"
_free :: Ptr BIO_ -> IO ()
foreign import ccall unsafe "BIO_push"
_push :: Ptr BIO_ -> Ptr BIO_ -> IO (Ptr BIO_)
foreign import ccall unsafe "HsOpenSSL_BIO_set_flags"
_set_flags :: Ptr BIO_ -> CInt -> IO ()
foreign import ccall unsafe "HsOpenSSL_BIO_should_retry"
_should_retry :: Ptr BIO_ -> IO CInt
new :: Ptr BIO_METHOD -> IO BIO
new method
= _new method >>= failIfNull >>= wrapBioPtr
wrapBioPtr :: Ptr BIO_ -> IO BIO
wrapBioPtr bioPtr
= fmap BIO (Conc.newForeignPtr bioPtr (_free bioPtr))
withBioPtr :: BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr (BIO bio) = withForeignPtr bio
withBioPtr' :: Maybe BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr' Nothing f = f nullPtr
withBioPtr' (Just bio) f = withBioPtr bio f
-- Connect 'b' behind 'a'. It's possible that 1. we only retain 'a'
-- and write to 'a', and 2. we only retain 'b' and read from 'b', so
-- both ForeignPtr's have to touch each other. This involves a
-- circular dependency but that won't be a problem as the garbage
-- collector isn't reference-counting.
-- |Computation of @'bioPush' a b@ connects @b@ behind @a@.
--
-- Example:
--
-- > do b64 <- newBase64 True
-- > mem <- newMem
-- > bioPush b64 mem
-- >
-- > -- Encode some text in Base64 and write the result to the
-- > -- memory buffer.
-- > bioWrite b64 "Hello, world!"
-- > bioFlush b64
-- >
-- > -- Then dump the memory buffer.
-- > bioRead mem >>= putStrLn
--
bioPush :: BIO -> BIO -> IO ()
bioPush (BIO a) (BIO b)
= withForeignPtr a $ \ aPtr ->
withForeignPtr b $ \ bPtr ->
do _ <- _push aPtr bPtr
Conc.addForeignPtrFinalizer a $ touchForeignPtr b
Conc.addForeignPtrFinalizer b $ touchForeignPtr a
return ()
-- |@a '==>' b@ is an alias to @'bioPush' a b@.
(==>) :: BIO -> BIO -> IO ()
(==>) = bioPush
-- |@a '<==' b@ is an alias to @'bioPush' b a@.
(<==) :: BIO -> BIO -> IO ()
(<==) = flip bioPush
-- |@'bioJoin' [bio1, bio2, ..]@ connects many BIOs at once.
bioJoin :: [BIO] -> IO ()
bioJoin [] = return ()
bioJoin (_:[]) = return ()
bioJoin (a:b:xs) = bioPush a b >> bioJoin (b:xs)
setFlags :: BIO -> CInt -> IO ()
setFlags bio flags
= withBioPtr bio $ flip _set_flags flags
bioShouldRetry :: BIO -> IO Bool
bioShouldRetry bio
= withBioPtr bio $ \ bioPtr ->
fmap (/= 0) (_should_retry bioPtr)
{- ctrl --------------------------------------------------------------------- -}
foreign import ccall unsafe "HsOpenSSL_BIO_flush"
_flush :: Ptr BIO_ -> IO CInt
foreign import ccall unsafe "HsOpenSSL_BIO_reset"
_reset :: Ptr BIO_ -> IO CInt
foreign import ccall unsafe "HsOpenSSL_BIO_eof"
_eof :: Ptr BIO_ -> IO CInt
-- |@'bioFlush' bio@ normally writes out any internally buffered data,
-- in some cases it is used to signal EOF and that no more data will
-- be written.
bioFlush :: BIO -> IO ()
bioFlush bio
= withBioPtr bio $ \ bioPtr ->
_flush bioPtr >>= failIf (/= 1) >> return ()
-- |@'bioReset' bio@ typically resets a BIO to some initial state.
bioReset :: BIO -> IO ()
bioReset bio
= withBioPtr bio $ \ bioPtr ->
_reset bioPtr >> return () -- Return value of BIO_reset is not
-- consistent in every BIO's so we
-- can't do error-checking.
-- |@'bioEOF' bio@ returns 1 if @bio@ has read EOF, the precise
-- meaning of EOF varies according to the BIO type.
bioEOF :: BIO -> IO Bool
bioEOF bio
= withBioPtr bio $ \ bioPtr ->
fmap (==1) (_eof bioPtr)
{- I/O ---------------------------------------------------------------------- -}
foreign import ccall unsafe "BIO_read"
_read :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt
foreign import ccall unsafe "BIO_gets"
_gets :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt
foreign import ccall unsafe "BIO_write"
_write :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt
-- |@'bioRead' bio@ lazily reads all data in @bio@.
bioRead :: BIO -> IO String
bioRead 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 B.ByteString
bioReadBS bio maxLen
= withBioPtr bio $ \ bioPtr ->
createAndTrim maxLen $ \ bufPtr ->
_read bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret
where
interpret :: CInt -> IO Int
interpret n
| n == 0 = return 0
| n == -1 = return 0
| n < -1 = raiseOpenSSLError
| otherwise = return (fromIntegral n)
-- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a
-- LazyByteString.
bioReadLBS :: BIO -> IO L.ByteString
bioReadLBS bio = fmap L.fromChunks lazyRead
where
chunkSize = L.defaultChunkSize
lazyRead = unsafeInterleaveIO loop
loop = do bs <- bioReadBS bio chunkSize
if B.null bs then
do isEOF <- bioEOF bio
if isEOF then
return []
else
do shouldRetry <- bioShouldRetry bio
if shouldRetry then
loop
else
fail "bioReadLBS: got null but isEOF=False, shouldRetry=False"
else
do bss <- lazyRead
return (bs:bss)
-- |@'bioGets' bio len@ normally attempts to read one line of data
-- from @bio@ of maximum length @len@. There are exceptions to this
-- however, for example 'bioGets' on a digest BIO will calculate and
-- return the digest and other BIOs may not support 'bioGets' at all.
bioGets :: BIO -> Int -> IO String
bioGets bio maxLen
= liftM B.unpack (bioGetsBS bio maxLen)
-- |'bioGetsBS' does the same as 'bioGets' but returns ByteString.
bioGetsBS :: BIO -> Int -> IO B.ByteString
bioGetsBS bio maxLen
= withBioPtr bio $ \ bioPtr ->
createAndTrim maxLen $ \ bufPtr ->
_gets bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret
where
interpret :: CInt -> IO Int
interpret n
| n == 0 = return 0
| n == -1 = return 0
| n < -1 = raiseOpenSSLError
| otherwise = return (fromIntegral n)
-- |'bioGetsLBS' does the same as 'bioGets' but returns
-- LazyByteString.
bioGetsLBS :: BIO -> Int -> IO L.ByteString
bioGetsLBS bio maxLen
= 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 . L.pack) str >>= bioWriteLBS bio
-- |@'bioWriteBS' bio bs@ writes @bs@ to @bio@.
bioWriteBS :: BIO -> B.ByteString -> IO ()
bioWriteBS bio bs
= withBioPtr bio $ \ bioPtr ->
unsafeUseAsCStringLen bs $ \ (buf, len) ->
_write bioPtr buf (fromIntegral len) >>= interpret
where
interpret :: CInt -> IO ()
interpret n
| n == fromIntegral (B.length bs)
= return ()
| n == -1 = bioWriteBS bio bs -- full retry
| n < -1 = raiseOpenSSLError
| 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 -> L.ByteString -> IO ()
bioWriteLBS bio lbs
= mapM_ (bioWriteBS bio) $ L.toChunks lbs
{- base64 ------------------------------------------------------------------- -}
foreign import ccall unsafe "BIO_f_base64"
f_base64 :: IO (Ptr BIO_METHOD)
foreign import ccall unsafe "HsOpenSSL_BIO_FLAGS_BASE64_NO_NL"
_FLAGS_BASE64_NO_NL :: CInt
-- |@'newBase64' noNL@ creates a Base64 BIO filter. This is a filter
-- bio that base64 encodes any data written through it and decodes any
-- data read through it.
--
-- If @noNL@ flag is True, the filter encodes the data all on one line
-- or expects the data to be all on one line.
--
-- Base64 BIOs do not support 'bioGets'.
--
-- 'bioFlush' on a Base64 BIO that is being written through is used to
-- signal that no more data is to be encoded: this is used to flush
-- the final block through the BIO.
newBase64 :: Bool -> IO BIO
newBase64 noNL
= do bio <- new =<< f_base64
when noNL $ setFlags bio _FLAGS_BASE64_NO_NL
return bio
{- buffer ------------------------------------------------------------------- -}
foreign import ccall unsafe "BIO_f_buffer"
f_buffer :: IO (Ptr BIO_METHOD)
foreign import ccall unsafe "HsOpenSSL_BIO_set_buffer_size"
_set_buffer_size :: Ptr BIO_ -> CInt -> IO CInt
-- |@'newBuffer' mBufSize@ creates a buffering BIO filter. Data
-- written to a buffering BIO is buffered and periodically written to
-- the next BIO in the chain. Data read from a buffering BIO comes
-- from the next BIO in the chain.
--
-- Buffering BIOs support 'bioGets'.
--
-- Calling 'bioReset' on a buffering BIO clears any buffered data.
--
-- Question: When I created a BIO chain like this and attempted to
-- read from the buf, the buffering BIO weirdly behaved: BIO_read()
-- returned nothing, but both BIO_eof() and BIO_should_retry()
-- returned zero. I tried to examine the source code of
-- crypto\/bio\/bf_buff.c but it was too complicated to
-- understand. Does anyone know why this happens? The version of
-- OpenSSL was 0.9.7l.
--
-- > main = withOpenSSL $
-- > do mem <- newConstMem "Hello, world!"
-- > buf <- newBuffer Nothing
-- > mem ==> buf
-- >
-- > bioRead buf >>= putStrLn -- This fails, but why?
--
-- I am being depressed for this unaccountable failure.
--
newBuffer :: Maybe Int -- ^ Explicit buffer size (@Just n@) or the
-- default size (@Nothing@).
-> IO BIO
newBuffer bufSize
= do bio <- new =<< f_buffer
case bufSize of
Just n -> withBioPtr bio $ \ bioPtr ->
_set_buffer_size bioPtr (fromIntegral n)
>>= failIf (/= 1) >> return ()
Nothing -> return ()
return bio
{- mem ---------------------------------------------------------------------- -}
foreign import ccall unsafe "BIO_s_mem"
s_mem :: IO (Ptr BIO_METHOD)
foreign import ccall unsafe "BIO_new_mem_buf"
_new_mem_buf :: Ptr CChar -> CInt -> IO (Ptr BIO_)
-- |@'newMem'@ creates a memory BIO sink\/source. Any data written to
-- a memory BIO can be recalled by reading from it. Unless the memory
-- BIO is read only any data read from it is deleted from the BIO.
--
-- Memory BIOs support 'bioGets'.
--
-- Calling 'bioReset' on a read write memory BIO clears any data in
-- it. On a read only BIO it restores the BIO to its original state
-- and the read only data can be read again.
--
-- 'bioEOF' is true if no data is in the BIO.
--
-- Every read from a read write memory BIO will remove the data just
-- read with an internal copy operation, if a BIO contains a lots of
-- data and it is read in small chunks the operation can be very
-- slow. The use of a read only memory BIO avoids this problem. If the
-- BIO must be read write then adding a buffering BIO ('newBuffer') to
-- the chain will speed up the process.
newMem :: IO BIO
newMem = s_mem >>= new
-- |@'newConstMem' str@ creates a read-only memory BIO source.
newConstMem :: String -> IO BIO
newConstMem str = newConstMemBS (B.pack str)
-- |@'newConstMemBS' bs@ is like 'newConstMem' but takes a ByteString.
newConstMemBS :: B.ByteString -> IO BIO
newConstMemBS bs
= let (foreignBuf, off, len) = toForeignPtr bs
in
-- Let the BIO's finalizer have a reference to the ByteString.
withForeignPtr foreignBuf $ \ buf ->
do bioPtr <- _new_mem_buf (castPtr $ buf `plusPtr` off) (fromIntegral len)
>>= failIfNull
bio <- newForeignPtr_ bioPtr
Conc.addForeignPtrFinalizer bio (_free bioPtr >> touchForeignPtr foreignBuf)
return $ BIO bio
-- |@'newConstMemLBS' lbs@ is like 'newConstMem' but takes a
-- LazyByteString.
newConstMemLBS :: L.ByteString -> IO BIO
newConstMemLBS lbs
= (return . B.concat . L.toChunks) lbs >>= newConstMemBS
{- null --------------------------------------------------------------------- -}
foreign import ccall unsafe "BIO_s_null"
s_null :: IO (Ptr BIO_METHOD)
-- |@'newNullBIO'@ creates a null BIO sink\/source. Data written to
-- the null sink is discarded, reads return EOF.
--
-- A null sink is useful if, for example, an application wishes to
-- digest some data by writing through a digest bio but not send the
-- digested data anywhere. Since a BIO chain must normally include a
-- source\/sink BIO this can be achieved by adding a null sink BIO to
-- the end of the chain.
newNullBIO :: IO BIO
newNullBIO = s_null >>= new
Jump to Line
Something went wrong with that request. Please try again.