{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Sytem.IO.Streams.Binary
-- Copyright   :  Petter Bergman, Winterland
-- License     :  BSD3
--
-- Maintainer  :  Winterland
-- Stability   :  experimental
--
-- Use binary to encode/decode io-streams.
--------------------------------------------------------------------------------

module System.IO.Streams.Binary (
    -- * single element encode/decode
      getFromStream
    , decodeFromStream
    , putToStream
    -- * 'InputStream' encode/decode
    , getInputStream
    , decodeInputStream
    -- * 'OutputStream' encode
    , putOutputStream
    , encodeOutputStream
    -- * exception type
    , DecodeException(..)
    ) where

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

import           Control.Exception            (Exception, throwIO)
import           Control.Monad                (unless)
import           Data.Binary                  (Binary, get, put)
import qualified Data.Binary.Parser           as P
import           Data.Binary.Get              (ByteOffset, Decoder(..), Get)
import           Data.Binary.Put              (runPut, Put)
import           Data.ByteString              (ByteString)
import qualified Data.ByteString              as S
import           Data.Typeable                (Typeable)
import           System.IO.Streams            (InputStream, OutputStream)
import qualified System.IO.Streams            as Streams
import           System.IO.Streams.ByteString (writeLazyByteString)

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

-- | An Exception raised when binary decoding fails.
--
-- it contains offset information where cereal don't.
data DecodeException = DecodeException ByteString ByteOffset String
  deriving (Typeable)

instance Show DecodeException where
  show :: DecodeException -> String
show (DecodeException ByteString
buf ByteOffset
offset String
message) =
        String
"DecodeException\nbuf:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
buf forall a. [a] -> [a] -> [a]
++ String
"\noffset:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteOffset
offset forall a. [a] -> [a] -> [a]
++ String
"\nmessage:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
message

instance Exception DecodeException

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

-- | Write an instance of 'Binary' to an 'OutputStream'.
putToStream :: Binary a => Maybe a -> OutputStream ByteString -> IO ()
putToStream :: forall a. Binary a => Maybe a -> OutputStream ByteString -> IO ()
putToStream Maybe a
Nothing  OutputStream ByteString
os = forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream ByteString
os
putToStream (Just a
x) OutputStream ByteString
os = ByteString -> OutputStream ByteString -> IO ()
writeLazyByteString ((Put -> ByteString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Binary t => t -> Put
put) a
x) OutputStream ByteString
os
{-# INLINE putToStream #-}

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

-- | Take a 'Get' and an 'InputStream' and decode a
-- value. Consumes only as much input as necessary to decode the
-- value. Unconsumed input will be unread. If there is
-- an error while deserializing, a 'DecodeException' is thrown, and
-- unconsumed part will be unread. binary decoder use 'Nothing'
-- to indicate input end, so EOFs/Nothing will close a binary decoder.
-- Examples:
--
-- >>> import qualified System.IO.Streams as Streams
-- >>> getFromStream (get :: Get String) =<< Streams.fromLazyByteString (Data.ByteString.Lazy.drop 1 $ runPut $ put "encode me")
-- *** Exception: System.IO.Streams.Binary: binary decode exception: offset 16, "not enough bytes"
--
getFromStream :: Get a -> InputStream ByteString -> IO (Maybe a)
getFromStream :: forall a. Get a -> InputStream ByteString -> IO (Maybe a)
getFromStream Get a
g InputStream ByteString
is = forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall {a}. Decoder a -> IO (Maybe a)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Get a -> ByteString -> Decoder a
P.parse Get a
g)
  where go :: Decoder a -> IO (Maybe a)
go (Fail ByteString
s ByteOffset
offset String
message) = do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
s) (forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
s InputStream ByteString
is)
            forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ ByteString -> ByteOffset -> String -> DecodeException
DecodeException ByteString
s ByteOffset
offset String
message
        go (Done ByteString
s ByteOffset
_ a
x) = do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
s) (forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
s InputStream ByteString
is)
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)
        go (Partial Maybe ByteString -> Decoder a
p) = forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
is forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Decoder a -> IO (Maybe a)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Maybe ByteString -> Decoder a
p
{-# INLINE getFromStream #-}

-- | typeclass version of 'getFromStream'
decodeFromStream :: Binary a => InputStream ByteString -> IO (Maybe a)
decodeFromStream :: forall a. Binary a => InputStream ByteString -> IO (Maybe a)
decodeFromStream = forall a. Get a -> InputStream ByteString -> IO (Maybe a)
getFromStream forall t. Binary t => Get t
get
{-# INLINE decodeFromStream #-}

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

-- | Convert a stream of individual encoded 'ByteString's to a stream
-- of Results. Throws a 'DecodeException' on error.
getInputStream :: Get a -> InputStream ByteString -> IO (InputStream a)
getInputStream :: forall a. Get a -> InputStream ByteString -> IO (InputStream a)
getInputStream Get a
g = forall a. IO (Maybe a) -> IO (InputStream a)
Streams.makeInputStream forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Get a -> InputStream ByteString -> IO (Maybe a)
getFromStream Get a
g
{-# INLINE getInputStream #-}

-- | typeclass version of 'getInputStream'
decodeInputStream :: Binary a => InputStream ByteString -> IO (InputStream a)
decodeInputStream :: forall a. Binary a => InputStream ByteString -> IO (InputStream a)
decodeInputStream = forall a. IO (Maybe a) -> IO (InputStream a)
Streams.makeInputStream forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => InputStream ByteString -> IO (Maybe a)
decodeFromStream
{-# INLINE decodeInputStream #-}

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

-- | create an 'OutputStream' of serializable values from an 'OutputStream'
-- of bytestrings with a 'Putter'.
putOutputStream :: (a -> Put) -> OutputStream ByteString -> IO (OutputStream a)
putOutputStream :: forall a.
(a -> Put) -> OutputStream ByteString -> IO (OutputStream a)
putOutputStream a -> Put
p OutputStream ByteString
os = forall a. (Maybe a -> IO ()) -> IO (OutputStream a)
Streams.makeOutputStream forall a b. (a -> b) -> a -> b
$ \ Maybe a
ma ->
    case Maybe a
ma of Maybe a
Nothing -> forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream ByteString
os
               Just a
a -> ByteString -> OutputStream ByteString -> IO ()
writeLazyByteString (Put -> ByteString
runPut (a -> Put
p a
a)) OutputStream ByteString
os
{-# INLINE putOutputStream #-}

-- | typeclass version of 'putOutputStream'
encodeOutputStream :: Binary a => OutputStream ByteString -> IO (OutputStream a)
encodeOutputStream :: forall a.
Binary a =>
OutputStream ByteString -> IO (OutputStream a)
encodeOutputStream = forall a.
(a -> Put) -> OutputStream ByteString -> IO (OutputStream a)
putOutputStream forall t. Binary t => t -> Put
put
{-# INLINE encodeOutputStream #-}