-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.Arrow.Binary
   Copyright  : Copyright (C) 2008 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : experimental
   Portability: portable

   De-/Serialisation arrows for XmlTrees and other arbitrary values with a Binary instance
-}

-- ------------------------------------------------------------

module Text.XML.HXT.Arrow.Binary
    ( readBinaryValue
    , writeBinaryValue
    )
where

import           Control.Arrow                             ()
import           Control.Arrow.ArrowExc
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList

import           Data.Binary
import qualified Data.ByteString.Lazy                      as B

import           System.IO                                 (IOMode (..), hClose,
                                                            openBinaryFile)

import           Text.XML.HXT.Arrow.XmlState.ErrorHandling
import           Text.XML.HXT.Arrow.XmlState.TypeDefs

-- ------------------------------------------------------------

readBinaryValue         :: (Binary a) => String -> IOStateArrow s b a
readBinaryValue :: String -> IOStateArrow s b a
readBinaryValue String
file
                        = ((Bool -> DeCompressionFct -> IOStateArrow s b a)
-> (Bool, DeCompressionFct) -> IOStateArrow s b a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Bool -> DeCompressionFct -> IOStateArrow s b a)
 -> (Bool, DeCompressionFct) -> IOStateArrow s b a)
-> (Bool -> DeCompressionFct -> IOStateArrow s b a)
-> (Bool, DeCompressionFct)
-> IOStateArrow s b a
forall a b. (a -> b) -> a -> b
$ String -> Bool -> DeCompressionFct -> IOStateArrow s b a
forall a s b.
Binary a =>
String -> Bool -> DeCompressionFct -> IOStateArrow s b a
decodeBinaryValue String
file)
                          ((Bool, DeCompressionFct) -> IOStateArrow s b a)
-> IOSLA (XIOState s) b (Bool, DeCompressionFct)
-> IOStateArrow s b a
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< Selector XIOSysState (Bool, DeCompressionFct)
-> IOSLA (XIOState s) b (Bool, DeCompressionFct)
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar ( Selector XIOSysState Bool
theStrictDeserialize
                                         Selector XIOSysState Bool
-> Selector XIOSysState DeCompressionFct
-> Selector XIOSysState (Bool, DeCompressionFct)
forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
.&&&.
                                         Selector XIOSysState DeCompressionFct
theBinaryDeCompression
                                       )

-- | Read a serialied value from a file, optionally decompress it and decode the value
-- In case of an error, the error message is issued and the arrow fails

decodeBinaryValue         :: (Binary a) => String -> Bool -> DeCompressionFct -> IOStateArrow s b a
decodeBinaryValue :: String -> Bool -> DeCompressionFct -> IOStateArrow s b a
decodeBinaryValue String
file Bool
strict DeCompressionFct
decompress
                          = IO a -> IOStateArrow s b a
forall (a :: * -> * -> *) c b. ArrowIO a => IO c -> a b c
arrIO0 IO a
dec
                            IOStateArrow s b a
-> IOSLA (XIOState s) SomeException a -> IOStateArrow s b a
forall (a :: * -> * -> *) b c.
ArrowExc a =>
a b c -> a SomeException c -> a b c
`catchA`
                            String -> IOSLA (XIOState s) SomeException a
forall s b. String -> IOStateArrow s SomeException b
issueExc String
"readBinaryValue"
    where
    dec :: IO a
dec                 = ( if Bool
strict
                            then IO ByteString
readItAll
                            else String -> IO ByteString
B.readFile String
file
                          ) IO ByteString -> (ByteString -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> (ByteString -> a) -> ByteString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> a
forall a. Binary a => ByteString -> a
decode (ByteString -> a) -> DeCompressionFct -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeCompressionFct
decompress
    readItAll :: IO ByteString
readItAll           = do
                          Handle
h <- String -> IOMode -> IO Handle
openBinaryFile String
file IOMode
ReadMode
                          ByteString
c <- Handle -> IO ByteString
B.hGetContents Handle
h
                          ByteString -> Int64
B.length ByteString
c Int64 -> IO ByteString -> IO ByteString
`seq`
                           do
                           Handle -> IO ()
hClose Handle
h
                           ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
c     -- hack: force reading whole file and close it immediately

-- | Serialize a value, optionally compress it, and write it to a file.
-- In case of an error, the error message is issued and the arrow fails

writeBinaryValue        :: (Binary a) => String -> IOStateArrow s a ()
writeBinaryValue :: String -> IOStateArrow s a ()
writeBinaryValue String
file   = (DeCompressionFct -> String -> IOStateArrow s a ())
-> String -> DeCompressionFct -> IOStateArrow s a ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip DeCompressionFct -> String -> IOStateArrow s a ()
forall a s.
Binary a =>
DeCompressionFct -> String -> IOStateArrow s a ()
encodeBinaryValue String
file (DeCompressionFct -> IOStateArrow s a ())
-> IOSLA (XIOState s) a DeCompressionFct -> IOStateArrow s a ()
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< Selector XIOSysState DeCompressionFct
-> IOSLA (XIOState s) a DeCompressionFct
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState DeCompressionFct
theBinaryCompression

encodeBinaryValue        :: (Binary a) => CompressionFct -> String -> IOStateArrow s a ()
encodeBinaryValue :: DeCompressionFct -> String -> IOStateArrow s a ()
encodeBinaryValue DeCompressionFct
compress String
file
                         = (a -> IO ()) -> IOStateArrow s a ()
forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
arrIO a -> IO ()
enc
                           IOStateArrow s a ()
-> IOSLA (XIOState s) SomeException () -> IOStateArrow s a ()
forall (a :: * -> * -> *) b c.
ArrowExc a =>
a b c -> a SomeException c -> a b c
`catchA`
                           String -> IOSLA (XIOState s) SomeException ()
forall s b. String -> IOStateArrow s SomeException b
issueExc String
"writeBinaryXmlTree"
    where
    enc :: a -> IO ()
enc                  = String -> ByteString -> IO ()
B.writeFile String
file (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeCompressionFct
compress DeCompressionFct -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Binary a => a -> ByteString
encode

-- ------------------------------------------------------------