{-# LANGUAGE Trustworthy #-}

{- arch-tag: I/O utilities, binary tools
Copyright (c) 2004-2011 John Goerzen <jgoerzen@complete.org>

All rights reserved.

For license and copyright information, see the file LICENSE
-}

{- |
   Module     : System.IO.Binary
   Copyright  : Copyright (C) 2004-2011 John Goerzen
   SPDX-License-Identifier: BSD-3-Clause

   Stability  : stable
   Portability: portable to platforms supporting binary I\/O

This module provides various helpful utilities for dealing with binary
input and output.

You can use this module to deal with binary blocks of data as either Strings
or lists of Word8.  The BinaryConvertible class provides this abstraction.

Wherever you see HVIO, you can transparently substite a regular Handle.
This module can work with any HVIO object, however.  See
"System.IO.HVIO" for more details.

Versions of MissingH prior 0.11.6 lacked the 'BinaryConvertible' class
and worked only with Strings and Handles.

Non-binary functions may be found in "System.IO".

See also: "System.IO.BlockIO"

Written by John Goerzen, jgoerzen\@complete.org
-}

module System.IO.Binary(
                       -- * Support for different types of blocks
                       BinaryConvertible(..),
                       -- * Entire File\/Handle Utilities
                       -- ** Opened Handle Data Copying
                       hBlockCopy, blockCopy,
                       -- ** Disk File Data Copying
                       copyFileBlocksToFile,
                       -- * Binary Single-Block I\/O
                       hPutBufStr, putBufStr, hGetBufStr, getBufStr,
                       hFullGetBufStr, fullGetBufStr,
                       -- * Binary Multi-Block I\/O
                       hGetBlocks, getBlocks, hFullGetBlocks, fullGetBlocks,
                       -- * Lazy Interaction
                       readBinaryFile, writeBinaryFile,
                       -- ** Binary Block-based
                       hBlockInteract, blockInteract,
                       hFullBlockInteract, fullBlockInteract
                        ) where

import Data.Word (Word8())
import Foreign.C.String (peekCStringLen, withCString)
import Foreign.C.Types (CChar())
import Foreign.ForeignPtr
    ( ForeignPtr, mallocForeignPtrArray, withForeignPtr )
import Foreign.Marshal.Array (peekArray, withArray)
import Foreign.Ptr ( Ptr, castPtr )
import System.IO
    ( stdout,
      hClose,
      openBinaryFile,
      stdin,
      IOMode(WriteMode, ReadMode) )
import System.IO.HVFS
    ( SystemFS(SystemFS),
      HVFSOpenable(vOpenBinaryFile),
      HVFSOpenEncap(HVFSOpenEncap) )
import System.IO.HVIO
    ( HVIO(vClose, vGetBuf, vPutBuf, vGetContents, vPutStr) )
import System.IO.Unsafe (unsafeInterleaveIO)

{- | Provides support for handling binary blocks with convenient
types.

This module provides implementations for Strings and for [Word8] (lists of
Word8s). -}
class (Eq a, Show a) => BinaryConvertible a where
    toBuf :: [a] -> (Ptr CChar -> IO c) -> IO c
    fromBuf :: Int -> (Ptr CChar -> IO Int) -> IO [a]

instance BinaryConvertible Char where
    toBuf :: forall c. [Char] -> (Ptr CChar -> IO c) -> IO c
toBuf = forall c. [Char] -> (Ptr CChar -> IO c) -> IO c
withCString
    fromBuf :: Int -> (Ptr CChar -> IO Int) -> IO [Char]
fromBuf Int
len Ptr CChar -> IO Int
func =
        do ForeignPtr CChar
fbuf <- forall a. Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray (Int
len forall a. Num a => a -> a -> a
+ Int
1)
           forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuf Ptr CChar -> IO [Char]
handler
        where handler :: Ptr CChar -> IO [Char]
handler Ptr CChar
ptr =
                  do Int
bytesread <- Ptr CChar -> IO Int
func Ptr CChar
ptr
                     CStringLen -> IO [Char]
peekCStringLen (Ptr CChar
ptr, Int
bytesread)

instance BinaryConvertible Word8 where
    toBuf :: forall c. [Word8] -> (Ptr CChar -> IO c) -> IO c
toBuf [Word8]
hslist Ptr CChar -> IO c
func = forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [Word8]
hslist (\Ptr Word8
ptr -> Ptr CChar -> IO c
func (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr))
    fromBuf :: Int -> (Ptr CChar -> IO Int) -> IO [Word8]
fromBuf Int
len Ptr CChar -> IO Int
func =
        do (ForeignPtr Word8
fbuf::(ForeignPtr Word8)) <- forall a. Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray (Int
len forall a. Num a => a -> a -> a
+ Int
1)
           forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fbuf forall {a}. Storable a => Ptr a -> IO [a]
handler
        where handler :: Ptr a -> IO [a]
handler Ptr a
ptr =
                  do Int
bytesread <- Ptr CChar -> IO Int
func (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr)
                     forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
bytesread Ptr a
ptr


--  **************************************************
--  Binary Files
--  **************************************************

{- | As a wrapper around the standard function 'System.IO.hPutBuf',
this function takes a standard Haskell 'String' instead of the far less
convenient @Ptr a@.  The entire contents of the string will be written
as a binary buffer using 'hPutBuf'.  The length of the output will be
the length of the passed String or list.

If it helps, you can thing of this function as being of type
@Handle -> String -> IO ()@ -}
hPutBufStr :: (HVIO a, BinaryConvertible b) => a -> [b] -> IO ()
hPutBufStr :: forall a b. (HVIO a, BinaryConvertible b) => a -> [b] -> IO ()
hPutBufStr a
f [b]
s = forall a c.
BinaryConvertible a =>
[a] -> (Ptr CChar -> IO c) -> IO c
toBuf [b]
s (\Ptr CChar
cs -> forall a b. HVIO a => a -> Ptr b -> Int -> IO ()
vPutBuf a
f Ptr CChar
cs (forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
s))

-- | An alias for 'hPutBufStr' 'stdout'
putBufStr :: (BinaryConvertible b) => [b] -> IO ()
putBufStr :: forall b. BinaryConvertible b => [b] -> IO ()
putBufStr = forall a b. (HVIO a, BinaryConvertible b) => a -> [b] -> IO ()
hPutBufStr Handle
stdout

{- | Acts a wrapper around the standard function 'System.IO.hGetBuf',
this function returns a standard Haskell String (or [Word8]) instead of
modifying
a 'Ptr a' buffer.  The length is the maximum length to read and the
semantice are the same as with 'hGetBuf'; namely, the empty string
is returned with EOF is reached, and any given read may read fewer
bytes than the given length.

(Actually, it's a wrapper around 'System.IO.HVIO.vGetBuf') -}
hGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hGetBufStr :: forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hGetBufStr a
f Int
count = forall a.
BinaryConvertible a =>
Int -> (Ptr CChar -> IO Int) -> IO [a]
fromBuf Int
count (\Ptr CChar
buf -> forall a b. HVIO a => a -> Ptr b -> Int -> IO Int
vGetBuf a
f Ptr CChar
buf Int
count)

-- | An alias for 'hGetBufStr' 'stdin'
getBufStr :: (BinaryConvertible b) => Int -> IO [b]
getBufStr :: forall b. BinaryConvertible b => Int -> IO [b]
getBufStr = forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hGetBufStr Handle
stdin

{- | Like 'hGetBufStr', but guarantees that it will only return fewer than
the requested number of bytes when EOF is encountered. -}
hFullGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hFullGetBufStr :: forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hFullGetBufStr a
_ Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
hFullGetBufStr a
f Int
count = do
                         [b]
thisstr <- forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hGetBufStr a
f Int
count
                         if [b]
thisstr forall a. Eq a => a -> a -> Bool
== []
                            then forall (m :: * -> *) a. Monad m => a -> m a
return []
                            else do
                                 [b]
remainder <- forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hFullGetBufStr a
f (Int
count forall a. Num a => a -> a -> a
- (forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
thisstr))
                                 forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
thisstr forall a. [a] -> [a] -> [a]
++ [b]
remainder)

-- | An alias for 'hFullGetBufStr' 'stdin'
fullGetBufStr :: BinaryConvertible b => Int -> IO [b]
fullGetBufStr :: forall b. BinaryConvertible b => Int -> IO [b]
fullGetBufStr = forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hFullGetBufStr Handle
stdin

{- | Writes the list of blocks to the given file handle -- a wrapper around
'hPutBufStr'.

Think of this function as:

>Handle -> [String] -> IO ()

(You can use it that way) -}
hPutBlocks :: (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO ()
hPutBlocks :: forall a b. (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO ()
hPutBlocks a
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
hPutBlocks a
h ([b]
x:[[b]]
xs) = do
                      forall a b. (HVIO a, BinaryConvertible b) => a -> [b] -> IO ()
hPutBufStr a
h [b]
x
                      forall a b. (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO ()
hPutBlocks a
h [[b]]
xs

{- | An alias for 'hPutBlocks' 'stdout'
putBlocks :: (BinaryConvertible b) => [[b]] -> IO ()
putBlocks = hPutBlocks stdout -}

{- | Returns a lazily-evaluated list of all blocks in the input file,
as read by 'hGetBufStr'.  There will be no 0-length block in this list.
The list simply ends at EOF. -}
hGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hGetBlocks :: forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hGetBlocks = forall a b.
(HVIO a, BinaryConvertible b) =>
(a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hGetBufStr

-- | An alias for 'hGetBlocks' 'stdin'
getBlocks :: BinaryConvertible b => Int -> IO [[b]]
getBlocks :: forall b. BinaryConvertible b => Int -> IO [[b]]
getBlocks = forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hGetBlocks Handle
stdin

{- | Same as 'hGetBlocks', but using 'hFullGetBufStr' underneath. -}
hFullGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hFullGetBlocks :: forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hFullGetBlocks = forall a b.
(HVIO a, BinaryConvertible b) =>
(a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hFullGetBufStr

-- | An alias for 'hFullGetBlocks' 'stdin'
fullGetBlocks :: BinaryConvertible b => Int -> IO [[b]]
fullGetBlocks :: forall b. BinaryConvertible b => Int -> IO [[b]]
fullGetBlocks = forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hFullGetBlocks Handle
stdin

hGetBlocksUtil :: (HVIO a, BinaryConvertible b) => (a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil :: forall a b.
(HVIO a, BinaryConvertible b) =>
(a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil a -> Int -> IO [b]
readfunc a
h Int
count =
    forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
                       [b]
block <- a -> Int -> IO [b]
readfunc a
h Int
count
                       if [b]
block forall a. Eq a => a -> a -> Bool
== []
                          then forall (m :: * -> *) a. Monad m => a -> m a
return []
                          else do
                               [[b]]
remainder <- forall a b.
(HVIO a, BinaryConvertible b) =>
(a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil a -> Int -> IO [b]
readfunc a
h Int
count
                               forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
block forall a. a -> [a] -> [a]
: [[b]]
remainder)

{- | Binary block-based interaction.  This is useful for scenarios that
take binary blocks, manipulate them in some way, and then write them
out.  Take a look at 'hBlockCopy' for an example.  The integer argument
is the size of input binary blocks.  This function uses 'hGetBlocks'
internally.
-}
hBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
                  Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteract :: forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteract = forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
(a -> Int -> IO [[b]])
-> Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteractUtil forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hGetBlocks

-- | An alias for 'hBlockInteract' over 'stdin' and 'stdout'
blockInteract :: (BinaryConvertible b, BinaryConvertible c) => Int -> ([[b]] -> [[c]]) -> IO ()
blockInteract :: forall b c.
(BinaryConvertible b, BinaryConvertible c) =>
Int -> ([[b]] -> [[c]]) -> IO ()
blockInteract Int
x = forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteract Int
x Handle
stdin Handle
stdout

{- | Same as 'hBlockInteract', but uses 'hFullGetBlocks' instead of
'hGetBlocks' internally. -}
hFullBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
                      Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hFullBlockInteract :: forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hFullBlockInteract = forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
(a -> Int -> IO [[b]])
-> Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteractUtil forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hFullGetBlocks

-- | An alias for 'hFullBlockInteract' over 'stdin' and 'stdout'
fullBlockInteract :: (BinaryConvertible b, BinaryConvertible c) =>
                     Int -> ([[b]] -> [[c]]) -> IO ()
fullBlockInteract :: forall b c.
(BinaryConvertible b, BinaryConvertible c) =>
Int -> ([[b]] -> [[c]]) -> IO ()
fullBlockInteract Int
x = forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hFullBlockInteract Int
x Handle
stdin Handle
stdout

hBlockInteractUtil :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
                      (a -> Int -> IO [[b]]) -> Int ->
                      a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteractUtil :: forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
(a -> Int -> IO [[b]])
-> Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteractUtil a -> Int -> IO [[b]]
blockreader Int
blocksize a
hin d
hout [[b]] -> [[c]]
func =
    do
    [[b]]
blocks <- a -> Int -> IO [[b]]
blockreader a
hin Int
blocksize
    forall a b. (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO ()
hPutBlocks d
hout ([[b]] -> [[c]]
func [[b]]
blocks)

{- | Copies everything from the input handle to the output handle using binary
blocks of the given size.  This was once the following
beautiful implementation:

> hBlockCopy bs hin hout = hBlockInteract bs hin hout id

('id' is the built-in Haskell function that just returns whatever is given
to it)

In more recent versions of MissingH, it uses a more optimized routine that
avoids ever having to convert the binary buffer at all.
-}
hBlockCopy :: (HVIO a, HVIO b) => Int -> a -> b -> IO ()
hBlockCopy :: forall a b. (HVIO a, HVIO b) => Int -> a -> b -> IO ()
hBlockCopy Int
bs a
hin b
hout =
    do (ForeignPtr CChar
fbuf::ForeignPtr CChar) <- forall a. Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray (Int
bs forall a. Num a => a -> a -> a
+ Int
1)
       forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuf forall {b}. Ptr b -> IO ()
handler
    where handler :: Ptr b -> IO ()
handler Ptr b
ptr =
              do Int
bytesread <- forall a b. HVIO a => a -> Ptr b -> Int -> IO Int
vGetBuf a
hin Ptr b
ptr Int
bs
                 if Int
bytesread forall a. Ord a => a -> a -> Bool
> Int
0
                    then do forall a b. HVIO a => a -> Ptr b -> Int -> IO ()
vPutBuf b
hout Ptr b
ptr Int
bytesread
                            Ptr b -> IO ()
handler Ptr b
ptr
                    else forall (m :: * -> *) a. Monad m => a -> m a
return ()

{- | Copies from 'stdin' to 'stdout' using binary blocks of the given size.
An alias for 'hBlockCopy' over 'stdin' and 'stdout'
-}
blockCopy :: Int -> IO ()
blockCopy :: Int -> IO ()
blockCopy Int
bs = forall a b. (HVIO a, HVIO b) => Int -> a -> b -> IO ()
hBlockCopy Int
bs Handle
stdin Handle
stdout

{- | Copies one filename to another in binary mode.

Please note that the Unix permission bits on the output file cannot
be set due to a limitation of the Haskell 'System.IO.openBinaryFile'
function.  Therefore, you may need to adjust those bits after the copy
yourself.

This function is implemented using 'hBlockCopy' internally. -}
copyFileBlocksToFile :: Int -> FilePath -> FilePath -> IO ()
copyFileBlocksToFile :: Int -> [Char] -> [Char] -> IO ()
copyFileBlocksToFile Int
bs [Char]
infn [Char]
outfn = do
                                     Handle
hin <- [Char] -> IOMode -> IO Handle
openBinaryFile [Char]
infn IOMode
ReadMode
                                     Handle
hout <- [Char] -> IOMode -> IO Handle
openBinaryFile [Char]
outfn IOMode
WriteMode
                                     forall a b. (HVIO a, HVIO b) => Int -> a -> b -> IO ()
hBlockCopy Int
bs Handle
hin Handle
hout
                                     Handle -> IO ()
hClose Handle
hin
                                     Handle -> IO ()
hClose Handle
hout
                                     forall (m :: * -> *) a. Monad m => a -> m a
return ()

{- | Like the built-in 'readFile', but opens the file in binary instead
of text mode. -}
readBinaryFile :: FilePath -> IO String
readBinaryFile :: [Char] -> IO [Char]
readBinaryFile = forall a. HVFSOpenable a => a -> [Char] -> IO [Char]
vReadBinaryFile SystemFS
SystemFS

{- | Same as 'readBinaryFile', but works with HVFS objects. -}
vReadBinaryFile :: (HVFSOpenable a) => a -> FilePath -> IO String
vReadBinaryFile :: forall a. HVFSOpenable a => a -> [Char] -> IO [Char]
vReadBinaryFile a
fs [Char]
fp =
    forall a.
HVFSOpenable a =>
a -> [Char] -> IOMode -> IO HVFSOpenEncap
vOpenBinaryFile a
fs [Char]
fp IOMode
ReadMode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(HVFSOpenEncap a
h) -> forall a. HVIO a => a -> IO [Char]
vGetContents a
h)

{- | Like the built-in 'writeFile', but opens the file in binary instead
of text mode. -}
writeBinaryFile :: FilePath -> String -> IO ()
writeBinaryFile :: [Char] -> [Char] -> IO ()
writeBinaryFile = forall a. HVFSOpenable a => a -> [Char] -> [Char] -> IO ()
vWriteBinaryFile SystemFS
SystemFS

{- | Like 'writeBinaryFile', but works on HVFS objects. -}
vWriteBinaryFile :: (HVFSOpenable a) => a -> FilePath -> String -> IO ()
vWriteBinaryFile :: forall a. HVFSOpenable a => a -> [Char] -> [Char] -> IO ()
vWriteBinaryFile a
fs [Char]
name [Char]
str =
    do HVFSOpenEncap
h <- forall a.
HVFSOpenable a =>
a -> [Char] -> IOMode -> IO HVFSOpenEncap
vOpenBinaryFile a
fs [Char]
name IOMode
WriteMode
       case HVFSOpenEncap
h of
              HVFSOpenEncap a
x -> do forall a. HVIO a => a -> [Char] -> IO ()
vPutStr a
x [Char]
str
                                    forall a. HVIO a => a -> IO ()
vClose a
x