{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
module Data.Binary.Tagged (
structuredEncode,
structuredEncodeFile,
structuredDecode,
structuredDecodeOrFailIO,
structuredDecodeFileOrFail,
Structured (structure),
structureHash,
structureBuilder,
genericStructure,
GStructured,
nominalStructure,
containerStructure,
Structure (..),
TypeName,
ConstructorName,
TypeVersion,
SopStructure,
hashStructure,
typeVersion,
typeName,
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 (..))
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)
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)
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
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
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
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)