-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Module contains helper functions when dealing with encoding
-- and decoding 'Binary'
module Util.Binary
  ( UnpackError (..)
  , ensureEnd
  , launchGet
  ) where

import Prelude hiding (EQ, Ordering(..), get)

import Data.Binary (Get)
import qualified Data.Binary.Get as Get
import qualified Data.ByteString.Lazy as LBS
import Fmt (Buildable, build, pretty, (+|), (+||), (|+), (||+))
import Text.Hex (encodeHex)

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- | Any decoding error.
newtype UnpackError = UnpackError { UnpackError -> Text
unUnpackError :: Text }
  deriving stock (Int -> UnpackError -> ShowS
[UnpackError] -> ShowS
UnpackError -> String
(Int -> UnpackError -> ShowS)
-> (UnpackError -> String)
-> ([UnpackError] -> ShowS)
-> Show UnpackError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnpackError] -> ShowS
$cshowList :: [UnpackError] -> ShowS
show :: UnpackError -> String
$cshow :: UnpackError -> String
showsPrec :: Int -> UnpackError -> ShowS
$cshowsPrec :: Int -> UnpackError -> ShowS
Show, UnpackError -> UnpackError -> Bool
(UnpackError -> UnpackError -> Bool)
-> (UnpackError -> UnpackError -> Bool) -> Eq UnpackError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnpackError -> UnpackError -> Bool
$c/= :: UnpackError -> UnpackError -> Bool
== :: UnpackError -> UnpackError -> Bool
$c== :: UnpackError -> UnpackError -> Bool
Eq)

instance Buildable UnpackError where
  build :: UnpackError -> Builder
build (UnpackError msg :: Text
msg) = Text -> Builder
forall p. Buildable p => p -> Builder
build Text
msg

instance Exception UnpackError where
  displayException :: UnpackError -> String
displayException = UnpackError -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty

ensureEnd :: Get ()
ensureEnd :: Get ()
ensureEnd =
  Get Bool -> Get () -> Get ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM Get Bool
Get.isEmpty (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ do
    ByteString
remainder <- Get ByteString
Get.getRemainingLazyByteString
    String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ "Expected end of entry, unconsumed bytes \
           \(" Builder -> Builder -> String
forall b. FromBuilder b => Builder -> Builder -> b
+| ByteString -> Int
forall t. Container t => t -> Int
length ByteString
remainder Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ "): "
           Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|| ByteString -> Text
encodeHex (ByteString -> ByteString
LBS.toStrict ByteString
remainder) Text -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ ""

launchGet :: Get a -> LByteString -> Either UnpackError a
launchGet :: Get a -> ByteString -> Either UnpackError a
launchGet decoder :: Get a
decoder bs :: ByteString
bs =
  case Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Get.runGetOrFail Get a
decoder ByteString
bs of
    Left (_remainder :: ByteString
_remainder, _offset :: ByteOffset
_offset, err :: String
err) -> UnpackError -> Either UnpackError a
forall a b. a -> Either a b
Left (UnpackError -> Either UnpackError a)
-> (Text -> UnpackError) -> Text -> Either UnpackError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UnpackError
UnpackError (Text -> Either UnpackError a) -> Text -> Either UnpackError a
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
err
    Right (_remainder :: ByteString
_remainder, _offset :: ByteOffset
_offset, res :: a
res) -> a -> Either UnpackError a
forall a b. b -> Either a b
Right a
res