{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy         #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Binary.Tagged
-- Copyright   :  (C) 2015-2020 Oleg Grenrus
-- License     :  BSD3
-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>
--
-- Structurally tag binary serialisation stream.
--
-- Say you have a data type
--
-- @
-- data Record = Record
--   { _recordFields  :: HM.HashMap Text (Integer, ByteString)
--   , _recordEnabled :: Bool
--   }
--   deriving (Eq, Show, Generic)
--
-- instance 'Binary.Binary' Record
-- instance 'Structured' Record
-- @
--
-- then you can serialise and deserialise @Record@ values with a structure tag by simply
--
-- @
-- 'structuredEncode' record :: LBS.ByteString
-- 'structuredDecode' lbs    :: Either String Record
-- @
--
-- If structure of @Record@ changes in between, deserialisation will fail early.
--
module Data.Binary.Tagged (
    -- * Encoding and decoding
    -- | These functions operate like @binary@'s counterparts,
    -- but the serialised version has a structure hash in front.
    structuredEncode,
    structuredEncodeFile,
    structuredDecode,
    structuredDecodeOrFailIO,
    structuredDecodeFileOrFail,
    -- * Structured class
    Structured (structure),
    structureHash,
    structureBuilder,
    genericStructure,
    GStructured,
    nominalStructure,
    containerStructure,
    -- * Structure type
    Structure (..),
    TypeName,
    ConstructorName,
    TypeVersion,
    SopStructure,
    hashStructure,
    typeVersion,
    typeName,
    -- * MD5
    MD5,
    showMD5,
    md5,
    md5FromInteger,
    binaryPutMD5,
    binaryGetMD5,
) where

import Data.Structured
import Data.Structured.Internal

import qualified Data.Binary          as Binary
import qualified Data.Binary.Get      as Binary
import qualified Data.Binary.Put      as Binary
import qualified Data.ByteString.Lazy as LBS

import Control.Exception (ErrorCall (..), catch, evaluate)
import Data.Tagged       (Tagged (..), untag)
import GHC.Fingerprint   (Fingerprint (..))

-------------------------------------------------------------------------------
-- Helper data
-------------------------------------------------------------------------------

data Tag a = Tag

instance Structured a => Binary.Binary (Tag a) where
    get :: Get (Tag a)
get = do
        MD5
actual <- Get MD5
binaryGetMD5
        if MD5
actual MD5 -> MD5 -> Bool
forall a. Eq a => a -> a -> Bool
== MD5
expected
        then Tag a -> Get (Tag a)
forall (m :: * -> *) a. Monad m => a -> m a
return Tag a
forall a. Tag a
Tag
        else String -> Get (Tag a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get (Tag a)) -> String -> Get (Tag a)
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Non-matching structured hashes: "
            , MD5 -> String
showMD5 MD5
actual
            , String
"; expected: "
            , MD5 -> String
showMD5 MD5
expected
            ]
      where
        expected :: MD5
expected = Tagged a MD5 -> MD5
forall k (s :: k) b. Tagged s b -> b
untag (Tagged a MD5
forall a. Structured a => Tagged a MD5
structureHash' :: Tagged a MD5)

    put :: Tag a -> Put
put Tag a
_ = MD5 -> Put
binaryPutMD5 MD5
expected
      where
        expected :: MD5
expected = Tagged a MD5 -> MD5
forall k (s :: k) b. Tagged s b -> b
untag (Tagged a MD5
forall a. Structured a => Tagged a MD5
structureHash' :: Tagged a MD5)

-------------------------------------------------------------------------------
-- Functions
-------------------------------------------------------------------------------

-- | Structured 'Binary.encode'.
-- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'.
-- Encoding starts with 16 byte large structure hash.
structuredEncode
  :: forall a. (Binary.Binary a, Structured a)
  => a -> LBS.ByteString
structuredEncode :: a -> ByteString
structuredEncode a
x = (Tag a, a) -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode (Tag a
forall a. Tag a
Tag :: Tag a, a
x)

-- | Lazily serialise a value to a file
structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO ()
structuredEncodeFile :: String -> a -> IO ()
structuredEncodeFile String
f = String -> ByteString -> IO ()
LBS.writeFile String
f (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. (Binary a, Structured a) => a -> ByteString
structuredEncode

-- | Structured 'Binary.decode'.
-- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure.
-- Throws pure exception on invalid inputs.
structuredDecode
  :: forall a. (Binary.Binary a, Structured a)
  => LBS.ByteString -> a
structuredDecode :: ByteString -> a
structuredDecode ByteString
lbs = (Tag a, a) -> a
forall a b. (a, b) -> b
snd (ByteString -> (Tag a, a)
forall a. Binary a => ByteString -> a
Binary.decode ByteString
lbs :: (Tag a, a))

structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a)
structuredDecodeOrFailIO :: ByteString -> IO (Either String a)
structuredDecodeOrFailIO ByteString
bs =
    IO (Either String a)
-> (ErrorCall -> IO (Either String a)) -> IO (Either String a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> IO a
forall a. a -> IO a
evaluate (ByteString -> a
forall a. (Binary a, Structured a) => ByteString -> a
structuredDecode ByteString
bs) IO a -> (a -> IO (Either String a)) -> IO (Either String a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (a -> Either String a) -> a -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String a
forall a b. b -> Either a b
Right) ErrorCall -> IO (Either String a)
forall (m :: * -> *) b. Monad m => ErrorCall -> m (Either String b)
handler
  where
#if MIN_VERSION_base(4,9,0)
    handler :: ErrorCall -> m (Either String b)
handler (ErrorCallWithLocation String
str String
_) = Either String b -> m (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m (Either String b))
-> Either String b -> m (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a b. a -> Either a b
Left String
str
#else
    handler (ErrorCall str) = return $ Left str
#endif

-- | Lazily reconstruct a value previously written to a file.
structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a)
structuredDecodeFileOrFail :: String -> IO (Either String a)
structuredDecodeFileOrFail String
f = ByteString -> IO (Either String a)
forall a.
(Binary a, Structured a) =>
ByteString -> IO (Either String a)
structuredDecodeOrFailIO (ByteString -> IO (Either String a))
-> IO ByteString -> IO (Either String a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
LBS.readFile String
f

-------------------------------------------------------------------------------
-- MD5 extras
-------------------------------------------------------------------------------

binaryPutMD5 :: MD5 -> Binary.Put
binaryPutMD5 :: MD5 -> Put
binaryPutMD5 (Fingerprint Word64
a Word64
b) = do
    Word64 -> Put
Binary.putWord64le Word64
a
    Word64 -> Put
Binary.putWord64le Word64
b

binaryGetMD5 :: Binary.Get MD5
binaryGetMD5 :: Get MD5
binaryGetMD5 = do
    Word64
a <- Get Word64
Binary.getWord64le
    Word64
b <- Get Word64
Binary.getWord64le
    MD5 -> Get MD5
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Word64 -> MD5
Fingerprint Word64
a Word64
b)