{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{- --------------------------------------------------------------------------- -}
{-                                                                             -}
{-                           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 :: Ptr BIO_METHOD -> IO BIO
new Ptr BIO_METHOD
method
    = Ptr BIO_METHOD -> IO (Ptr BIO_)
_new Ptr BIO_METHOD
method IO (Ptr BIO_) -> (Ptr BIO_ -> IO (Ptr BIO_)) -> IO (Ptr BIO_)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr BIO_ -> IO (Ptr BIO_)
forall a. Ptr a -> IO (Ptr a)
failIfNull IO (Ptr BIO_) -> (Ptr BIO_ -> IO BIO) -> IO BIO
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr BIO_ -> IO BIO
wrapBioPtr


wrapBioPtr :: Ptr BIO_ -> IO BIO
wrapBioPtr :: Ptr BIO_ -> IO BIO
wrapBioPtr Ptr BIO_
bioPtr
    = (ForeignPtr BIO_ -> BIO) -> IO (ForeignPtr BIO_) -> IO BIO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr BIO_ -> BIO
BIO (Ptr BIO_ -> IO () -> IO (ForeignPtr BIO_)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
Conc.newForeignPtr Ptr BIO_
bioPtr (Ptr BIO_ -> IO ()
_free Ptr BIO_
bioPtr))


withBioPtr :: BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr :: BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr (BIO ForeignPtr BIO_
bio) = ForeignPtr BIO_ -> (Ptr BIO_ -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr BIO_
bio


withBioPtr' :: Maybe BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr' :: Maybe BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr' Maybe BIO
Nothing    Ptr BIO_ -> IO a
f = Ptr BIO_ -> IO a
f Ptr BIO_
forall a. Ptr a
nullPtr
withBioPtr' (Just BIO
bio) Ptr BIO_ -> IO a
f = BIO -> (Ptr BIO_ -> IO a) -> IO a
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio Ptr BIO_ -> IO a
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 -> BIO -> IO ()
bioPush (BIO ForeignPtr BIO_
a) (BIO ForeignPtr BIO_
b)
    = ForeignPtr BIO_ -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr BIO_
a ((Ptr BIO_ -> IO ()) -> IO ()) -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
aPtr ->
      ForeignPtr BIO_ -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr BIO_
b ((Ptr BIO_ -> IO ()) -> IO ()) -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
bPtr ->
      do Ptr BIO_
_ <- Ptr BIO_ -> Ptr BIO_ -> IO (Ptr BIO_)
_push Ptr BIO_
aPtr Ptr BIO_
bPtr
         ForeignPtr BIO_ -> IO () -> IO ()
forall a. ForeignPtr a -> IO () -> IO ()
Conc.addForeignPtrFinalizer ForeignPtr BIO_
a (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr BIO_ -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr BIO_
b
         ForeignPtr BIO_ -> IO () -> IO ()
forall a. ForeignPtr a -> IO () -> IO ()
Conc.addForeignPtrFinalizer ForeignPtr BIO_
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr BIO_ -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr BIO_
a
         () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |@a '==>' b@ is an alias to @'bioPush' a b@.
(==>) :: BIO -> BIO -> IO ()
==> :: BIO -> BIO -> IO ()
(==>) = BIO -> BIO -> IO ()
bioPush

-- |@a '<==' b@ is an alias to @'bioPush' b a@.
(<==) :: BIO -> BIO -> IO ()
<== :: BIO -> BIO -> IO ()
(<==) = (BIO -> BIO -> IO ()) -> BIO -> BIO -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip BIO -> BIO -> IO ()
bioPush


-- |@'bioJoin' [bio1, bio2, ..]@ connects many BIOs at once.
bioJoin :: [BIO] -> IO ()
bioJoin :: [BIO] -> IO ()
bioJoin []       = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
bioJoin (BIO
_:[])   = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
bioJoin (BIO
a:BIO
b:[BIO]
xs) = BIO -> BIO -> IO ()
bioPush BIO
a BIO
b IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [BIO] -> IO ()
bioJoin (BIO
bBIO -> [BIO] -> [BIO]
forall a. a -> [a] -> [a]
:[BIO]
xs)


setFlags :: BIO -> CInt -> IO ()
setFlags :: BIO -> CInt -> IO ()
setFlags BIO
bio CInt
flags
    = BIO -> (Ptr BIO_ -> IO ()) -> IO ()
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio ((Ptr BIO_ -> IO ()) -> IO ()) -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Ptr BIO_ -> CInt -> IO ()) -> CInt -> Ptr BIO_ -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr BIO_ -> CInt -> IO ()
_set_flags CInt
flags
      

bioShouldRetry :: BIO -> IO Bool
bioShouldRetry :: BIO -> IO Bool
bioShouldRetry BIO
bio
    = BIO -> (Ptr BIO_ -> IO Bool) -> IO Bool
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio ((Ptr BIO_ -> IO Bool) -> IO Bool)
-> (Ptr BIO_ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
bioPtr ->
      (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (Ptr BIO_ -> IO CInt
_should_retry Ptr BIO_
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 -> IO ()
bioFlush BIO
bio
    = BIO -> (Ptr BIO_ -> IO ()) -> IO ()
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio ((Ptr BIO_ -> IO ()) -> IO ()) -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
bioPtr ->
      Ptr BIO_ -> IO CInt
_flush Ptr BIO_
bioPtr IO CInt -> (CInt -> IO CInt) -> IO CInt
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO CInt
forall a. (a -> Bool) -> a -> IO a
failIf (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1) IO CInt -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |@'bioReset' bio@ typically resets a BIO to some initial state.
bioReset :: BIO -> IO ()
bioReset :: BIO -> IO ()
bioReset BIO
bio
    = BIO -> (Ptr BIO_ -> IO ()) -> IO ()
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio ((Ptr BIO_ -> IO ()) -> IO ()) -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
bioPtr ->
      Ptr BIO_ -> IO CInt
_reset Ptr BIO_
bioPtr IO CInt -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
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 -> IO Bool
bioEOF BIO
bio
    = BIO -> (Ptr BIO_ -> IO Bool) -> IO Bool
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio ((Ptr BIO_ -> IO Bool) -> IO Bool)
-> (Ptr BIO_ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
bioPtr ->
      (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
==CInt
1) (Ptr BIO_ -> IO CInt
_eof Ptr BIO_
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 -> IO String
bioRead BIO
bio
    = (ByteString -> String) -> IO ByteString -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> String
L.unpack (IO ByteString -> IO String) -> IO ByteString -> IO String
forall a b. (a -> b) -> a -> b
$ BIO -> IO ByteString
bioReadLBS BIO
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 -> Int -> IO ByteString
bioReadBS BIO
bio Int
maxLen
    = BIO -> (Ptr BIO_ -> IO ByteString) -> IO ByteString
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio       ((Ptr BIO_ -> IO ByteString) -> IO ByteString)
-> (Ptr BIO_ -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
bioPtr ->
      Int -> (Ptr Word8 -> IO Int) -> IO ByteString
createAndTrim Int
maxLen ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
bufPtr ->
      Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt
_read Ptr BIO_
bioPtr (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bufPtr) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxLen) IO CInt -> (CInt -> IO Int) -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO Int
interpret
    where
      interpret :: CInt -> IO Int
      interpret :: CInt -> IO Int
interpret CInt
n
          | CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
==  CInt
0   = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
          | CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1   = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
          | CInt
n CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<  -CInt
1   = IO Int
forall a. IO a
raiseOpenSSLError
          | Bool
otherwise = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n)

-- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a
-- LazyByteString.
bioReadLBS :: BIO -> IO L.ByteString
bioReadLBS :: BIO -> IO ByteString
bioReadLBS BIO
bio = ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteString] -> ByteString
L.fromChunks IO [ByteString]
lazyRead
    where
      chunkSize :: Int
chunkSize = Int
L.defaultChunkSize
      
      lazyRead :: IO [ByteString]
lazyRead = IO [ByteString] -> IO [ByteString]
forall a. IO a -> IO a
unsafeInterleaveIO IO [ByteString]
loop

      loop :: IO [ByteString]
loop = do ByteString
bs <- BIO -> Int -> IO ByteString
bioReadBS BIO
bio Int
chunkSize
                if ByteString -> Bool
B.null ByteString
bs then
                    do Bool
isEOF <- BIO -> IO Bool
bioEOF BIO
bio
                       if Bool
isEOF then
                           [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                         else
                           do Bool
shouldRetry <- BIO -> IO Bool
bioShouldRetry BIO
bio
                              if Bool
shouldRetry then
                                  IO [ByteString]
loop
                                else
                                  String -> IO [ByteString]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bioReadLBS: got null but isEOF=False, shouldRetry=False"
                  else
                    do [ByteString]
bss <- IO [ByteString]
lazyRead
                       [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
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 -> Int -> IO String
bioGets BIO
bio Int
maxLen
    = (ByteString -> String) -> IO ByteString -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> String
B.unpack (BIO -> Int -> IO ByteString
bioGetsBS BIO
bio Int
maxLen)

-- |'bioGetsBS' does the same as 'bioGets' but returns ByteString.
bioGetsBS :: BIO -> Int -> IO B.ByteString
bioGetsBS :: BIO -> Int -> IO ByteString
bioGetsBS BIO
bio Int
maxLen
    = BIO -> (Ptr BIO_ -> IO ByteString) -> IO ByteString
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio       ((Ptr BIO_ -> IO ByteString) -> IO ByteString)
-> (Ptr BIO_ -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
bioPtr ->
      Int -> (Ptr Word8 -> IO Int) -> IO ByteString
createAndTrim Int
maxLen ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
bufPtr ->
      Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt
_gets Ptr BIO_
bioPtr (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bufPtr) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxLen) IO CInt -> (CInt -> IO Int) -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO Int
interpret
    where
      interpret :: CInt -> IO Int
      interpret :: CInt -> IO Int
interpret CInt
n
          | CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
==  CInt
0   = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
          | CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1   = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
          | CInt
n CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<  -CInt
1   = IO Int
forall a. IO a
raiseOpenSSLError
          | Bool
otherwise = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n)

-- |'bioGetsLBS' does the same as 'bioGets' but returns
-- LazyByteString.
bioGetsLBS :: BIO -> Int -> IO L.ByteString
bioGetsLBS :: BIO -> Int -> IO ByteString
bioGetsLBS BIO
bio Int
maxLen
    = BIO -> Int -> IO ByteString
bioGetsBS BIO
bio Int
maxLen IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ ByteString
bs -> (ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
L.fromChunks) [ByteString
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 -> String -> IO ()
bioWrite BIO
bio String
str
    = (ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> (String -> ByteString) -> String -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
L.pack) String
str IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BIO -> ByteString -> IO ()
bioWriteLBS BIO
bio

-- |@'bioWriteBS' bio bs@ writes @bs@ to @bio@.
bioWriteBS :: BIO -> B.ByteString -> IO ()
bioWriteBS :: BIO -> ByteString -> IO ()
bioWriteBS BIO
bio ByteString
bs
    = BIO -> (Ptr BIO_ -> IO ()) -> IO ()
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio           ((Ptr BIO_ -> IO ()) -> IO ()) -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
bioPtr ->
      ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ (Ptr CChar
buf, Int
len) ->
      Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt
_write Ptr BIO_
bioPtr Ptr CChar
buf (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
interpret
    where
      interpret :: CInt -> IO ()
      interpret :: CInt -> IO ()
interpret CInt
n
          | CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)
                      = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          | CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1   = BIO -> ByteString -> IO ()
bioWriteBS BIO
bio ByteString
bs -- full retry
          | CInt
n CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<  -CInt
1   = IO ()
forall a. IO a
raiseOpenSSLError
          | Bool
otherwise = BIO -> ByteString -> IO ()
bioWriteBS BIO
bio (Int -> ByteString -> ByteString
B.drop (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n) ByteString
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 -> ByteString -> IO ()
bioWriteLBS BIO
bio ByteString
lbs
    = (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BIO -> ByteString -> IO ()
bioWriteBS BIO
bio) ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
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 :: Bool -> IO BIO
newBase64 Bool
noNL
    = do BIO
bio <- Ptr BIO_METHOD -> IO BIO
new (Ptr BIO_METHOD -> IO BIO) -> IO (Ptr BIO_METHOD) -> IO BIO
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr BIO_METHOD)
f_base64
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noNL (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ BIO -> CInt -> IO ()
setFlags BIO
bio CInt
_FLAGS_BASE64_NO_NL
         BIO -> IO BIO
forall (m :: * -> *) a. Monad m => a -> m a
return BIO
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 :: Maybe Int -> IO BIO
newBuffer Maybe Int
bufSize
    = do BIO
bio <- Ptr BIO_METHOD -> IO BIO
new (Ptr BIO_METHOD -> IO BIO) -> IO (Ptr BIO_METHOD) -> IO BIO
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr BIO_METHOD)
f_buffer
         case Maybe Int
bufSize of
           Just Int
n  -> BIO -> (Ptr BIO_ -> IO ()) -> IO ()
forall a. BIO -> (Ptr BIO_ -> IO a) -> IO a
withBioPtr BIO
bio ((Ptr BIO_ -> IO ()) -> IO ()) -> (Ptr BIO_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr BIO_
bioPtr ->
                      Ptr BIO_ -> CInt -> IO CInt
_set_buffer_size Ptr BIO_
bioPtr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
                           IO CInt -> (CInt -> IO CInt) -> IO CInt
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO CInt
forall a. (a -> Bool) -> a -> IO a
failIf (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1) IO CInt -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Maybe Int
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         BIO -> IO BIO
forall (m :: * -> *) a. Monad m => a -> m a
return BIO
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 :: IO BIO
newMem = IO (Ptr BIO_METHOD)
s_mem IO (Ptr BIO_METHOD) -> (Ptr BIO_METHOD -> IO BIO) -> IO BIO
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr BIO_METHOD -> IO BIO
new

-- |@'newConstMem' str@ creates a read-only memory BIO source.
newConstMem :: String -> IO BIO
newConstMem :: String -> IO BIO
newConstMem String
str = ByteString -> IO BIO
newConstMemBS (String -> ByteString
B.pack String
str)

-- |@'newConstMemBS' bs@ is like 'newConstMem' but takes a ByteString.
newConstMemBS :: B.ByteString -> IO BIO
newConstMemBS :: ByteString -> IO BIO
newConstMemBS ByteString
bs
    = let (ForeignPtr Word8
foreignBuf, Int
off, Int
len) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
bs
      in
        -- Let the BIO's finalizer have a reference to the ByteString.
        ForeignPtr Word8 -> (Ptr Word8 -> IO BIO) -> IO BIO
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
foreignBuf ((Ptr Word8 -> IO BIO) -> IO BIO)
-> (Ptr Word8 -> IO BIO) -> IO BIO
forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
buf ->
        do Ptr BIO_
bioPtr <- Ptr CChar -> CInt -> IO (Ptr BIO_)
_new_mem_buf (Ptr Any -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr (Ptr Any -> Ptr CChar) -> Ptr Any -> Ptr CChar
forall a b. (a -> b) -> a -> b
$ Ptr Word8
buf Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                     IO (Ptr BIO_) -> (Ptr BIO_ -> IO (Ptr BIO_)) -> IO (Ptr BIO_)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr BIO_ -> IO (Ptr BIO_)
forall a. Ptr a -> IO (Ptr a)
failIfNull

           ForeignPtr BIO_
bio <- Ptr BIO_ -> IO (ForeignPtr BIO_)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr BIO_
bioPtr
           ForeignPtr BIO_ -> IO () -> IO ()
forall a. ForeignPtr a -> IO () -> IO ()
Conc.addForeignPtrFinalizer ForeignPtr BIO_
bio (Ptr BIO_ -> IO ()
_free Ptr BIO_
bioPtr IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ForeignPtr Word8 -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr Word8
foreignBuf)
           
           BIO -> IO BIO
forall (m :: * -> *) a. Monad m => a -> m a
return (BIO -> IO BIO) -> BIO -> IO BIO
forall a b. (a -> b) -> a -> b
$ ForeignPtr BIO_ -> BIO
BIO ForeignPtr BIO_
bio

-- |@'newConstMemLBS' lbs@ is like 'newConstMem' but takes a
-- LazyByteString.
newConstMemLBS :: L.ByteString -> IO BIO
newConstMemLBS :: ByteString -> IO BIO
newConstMemLBS ByteString
lbs
    = (ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks) ByteString
lbs IO ByteString -> (ByteString -> IO BIO) -> IO BIO
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO BIO
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 :: IO BIO
newNullBIO = IO (Ptr BIO_METHOD)
s_null IO (Ptr BIO_METHOD) -> (Ptr BIO_METHOD -> IO BIO) -> IO BIO
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr BIO_METHOD -> IO BIO
new