sr-extra-1.85: Extra/SafeCopy.hs

-- | This module exports a template haskell function to create
-- Serialize instances based on the SafeCopy instance, and an
-- alternative decode function that puts the decode type in the error
-- message.  It also re-exports all other Data.Serialize symbols

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

module Extra.SafeCopy
    ( module Data.SafeCopy
    , DecodeError(..)
    , encodeSafe
    , decodeAllSafe
#if 0
    , decodeMSafe
    , decodeMSafe'
#endif
    , decodePrismSafe
    , encodeGetterSafe
    ) where

import Control.Exception (ErrorCall(..))
import Control.Lens (Getter, Prism', prism, re)
import Control.Monad.Catch (catch, MonadCatch)
import Control.Monad.Except (MonadError)
import Data.ByteString as B (ByteString, null)
import Data.Data (Proxy(Proxy), Typeable)
import Data.SafeCopy (base, SafeCopy, safeGet, safePut)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup((<>)))
#endif
import Data.Serialize hiding (decode, encode)
import Data.UUID.Orphans ()
--import Extra.Errors (Member, OneOf, throwMember)
import Extra.Orphans ()
import Extra.Serialize (DecodeError(..), fakeTypeRep)

encodeSafe :: SafeCopy a => a -> ByteString
encodeSafe = runPut . safePut

-- Version of decode that errors if all input is not consumed.
decodeAllSafe :: forall a. (SafeCopy a) => ByteString -> Either String a
decodeAllSafe b =
  case runGetState safeGet b 0 of
    Left s -> Left s
    Right (a, more) | B.null more -> Right a
    Right (_, more) -> Left ("decode " <> show b <> " failed to consume " <> show more)

#if 0
-- | Monadic version of decode.
decodeMSafe ::
  forall a e m. (SafeCopy a, Typeable a, Member DecodeError e, MonadError (OneOf e) m)
  => ByteString
  -> m a
decodeMSafe bs =
  case decodeAllSafe bs of
    Left s -> throwMember (DecodeError bs (fakeTypeRep (Proxy @a)) s)
    Right a -> return a

-- | Like 'decodeM', but also catches any ErrorCall thrown and lifts
-- it into the MonadError instance.  I'm not sure whether this can
-- actually happen.  What I'm seeing is probably an error call from
-- outside the serialize package, in which case this (and decode') are
-- pointless.
decodeMSafe' ::
  forall e m a. (SafeCopy a, Typeable a, Member DecodeError e, MonadError (OneOf e) m, MonadCatch m)
  => ByteString
  -> m a
decodeMSafe' bs = go `catch` handle
  where
    go = case decodeAllSafe bs of
           Left s -> throwMember (DecodeError bs (fakeTypeRep (Proxy @a)) s)
           Right a -> return a
    handle :: ErrorCall -> m a
    handle (ErrorCall s) = throwMember (DecodeError bs (fakeTypeRep (Proxy @a)) s)
#endif

-- | Serialize/deserialize prism.
decodePrismSafe :: forall a. (SafeCopy a) => Prism' ByteString a
decodePrismSafe = prism encodeSafe (\s -> either (\_ -> Left s) Right (decodeAllSafe s :: Either String a))

-- | Inverting a prism turns it into a getter.
encodeGetterSafe :: forall a. (SafeCopy a) => Getter a ByteString
encodeGetterSafe = re decodePrismSafe