{-# LANGUAGE AllowAmbiguousTypes #-}

module StreamPatch.Apply where

import GHC.Generics ( Generic )

import StreamPatch.Patch
import StreamPatch.Stream
import StreamPatch.HFunctorList
import StreamPatch.Patch.Binary qualified as Bin
import StreamPatch.Patch.Compare qualified as Compare
import StreamPatch.Patch.Compare ( Compare(..), compareTo )
import StreamPatch.Patch.Linearize.InPlace ( HasLength, getLength )

import Data.Vinyl
import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as BB
import Data.ByteString.Lazy qualified as BL
import Control.Monad.State
import StreamPatch.Util ( traverseM_ )

import Control.Monad.Except

data Error
  = ErrorCompare String
  | ErrorBinUnexpectedNonNull BS.ByteString
    deriving (forall x. Rep Error x -> Error
forall x. Error -> Rep Error x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Error x -> Error
$cfrom :: forall x. Error -> Rep Error x
Generic, Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

applyBinCompareFwd
    :: forall v m
    .  ( FwdInplaceStream m, Chunk m ~ BS.ByteString
       , Compare v BS.ByteString, Num (Index m) )
    => [Patch (Index m) '[Compare.Meta v, Bin.Meta] BS.ByteString]
    -> m (Either Error ())
applyBinCompareFwd :: forall (v :: Via) (m :: * -> *).
(FwdInplaceStream m, Chunk m ~ ByteString, Compare v ByteString,
 Num (Index m)) =>
[Patch (Index m) '[Meta v, Meta] ByteString] -> m (Either Error ())
applyBinCompareFwd = forall (t :: * -> *) (f :: * -> *) (m :: * -> *) v.
(Traversable t, Applicative f, Monad m) =>
(v -> m (f ())) -> t v -> m (f ())
traverseM_ forall a b. (a -> b) -> a -> b
$ \(Patch ByteString
bs Index m
s (HFunctorList (Flap r ByteString
cm :& Flap r ByteString
bm :& Rec (Flap ByteString) rs
RNil))) -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    -- advance to patch location
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). FwdInplaceStream m => Index m -> m ()
advance Index m
s

    -- read same number of bytes as patch data
    ByteString
bsStream  <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). FwdInplaceStream m => Index m -> m (Chunk m)
readahead forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. HasLength a => a -> Int
getLength ByteString
bs

    -- check for & strip expected terminating nulls
    ByteString
bsStream' <- ByteString -> Maybe Natural -> ExceptT Error m ByteString
doNullTermCheck ByteString
bsStream (forall {k} (a :: k). Meta a -> Maybe Natural
Bin.mNullTerminates r ByteString
bm)

    -- compare with expected data
    ByteString -> Maybe (CompareRep v ByteString) -> ExceptT Error m ()
doCompare ByteString
bsStream' forall a b. (a -> b) -> a -> b
$ forall (v :: Via) a. Meta v a -> Maybe (CompareRep v a)
Compare.mCompare r ByteString
cm

    -- if that was all successful, write patch in-place
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). FwdInplaceStream m => Chunk m -> m ()
overwrite ByteString
bs
  where
    err :: Error -> ExceptT Error m a
err = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    doCompare :: ByteString -> Maybe (CompareRep v ByteString) -> ExceptT Error m ()
doCompare ByteString
bs' = \case
      Maybe (CompareRep v ByteString)
Nothing   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just CompareRep v ByteString
cmp -> do
        case forall (v :: Via) a.
Compare v a =>
CompareRep v a -> a -> Maybe String
compareTo @v CompareRep v ByteString
cmp ByteString
bs' of
          Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just String
e -> forall {a}. Error -> ExceptT Error m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ErrorCompare String
e
    doNullTermCheck :: ByteString -> Maybe Natural -> ExceptT Error m ByteString
doNullTermCheck ByteString
bs' = \case
      Maybe Natural
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs'
      Just Natural
nt ->
        let (ByteString
bs'', ByteString
bsNulls) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
nt) ByteString
bs'
         in if   ByteString
bsNulls forall a. Eq a => a -> a -> Bool
== Int -> Word8 -> ByteString
BS.replicate (ByteString -> Int
BS.length ByteString
bsNulls) Word8
0x00
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs''
            else forall {a}. Error -> ExceptT Error m a
err forall a b. (a -> b) -> a -> b
$ ByteString -> Error
ErrorBinUnexpectedNonNull ByteString
bs'

runPureBinCompareFwd
    :: (Compare v BS.ByteString)
    => [Patch Int '[Compare.Meta v, Bin.Meta] BS.ByteString]
    -> BS.ByteString
    -> Either Error BL.ByteString
runPureBinCompareFwd :: forall (v :: Via).
Compare v ByteString =>
[Patch Int '[Meta v, Meta] ByteString]
-> ByteString -> Either Error ByteString
runPureBinCompareFwd [Patch Int '[Meta v, Meta] ByteString]
ps ByteString
bs =
    let initState :: (ByteString, Builder, Int)
initState = (ByteString
bs, forall a. Monoid a => a
mempty :: BB.Builder, Int
0 :: Int)
        (Either Error ()
mErr, (ByteString
bsRemaining, Builder
bbPatched, Int
_)) = forall s a. State s a -> s -> (a, s)
runState (forall (v :: Via) (m :: * -> *).
(FwdInplaceStream m, Chunk m ~ ByteString, Compare v ByteString,
 Num (Index m)) =>
[Patch (Index m) '[Meta v, Meta] ByteString] -> m (Either Error ())
applyBinCompareFwd [Patch Int '[Meta v, Meta] ByteString]
ps) (ByteString, Builder, Int)
initState
        bbPatched' :: Builder
bbPatched' = Builder
bbPatched forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BB.byteString ByteString
bsRemaining
     in case Either Error ()
mErr of
          Left  Error
e  -> forall a b. a -> Either a b
Left Error
e
          Right () -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString Builder
bbPatched'

applyFwd
    :: (FwdInplaceStream m, Chunk m ~ a)
    => [Patch (Index m) '[] a]
    -> m ()
applyFwd :: forall (m :: * -> *) a.
(FwdInplaceStream m, Chunk m ~ a) =>
[Patch (Index m) '[] a] -> m ()
applyFwd =
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a b. (a -> b) -> a -> b
$ \(Patch a
a Index m
s (HFunctorList Rec (Flap a) '[]
RNil)) ->
        forall (m :: * -> *). FwdInplaceStream m => Index m -> m ()
advance Index m
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). FwdInplaceStream m => Chunk m -> m ()
overwrite a
a

runPureFwdList
    :: [Patch Int '[] [a]]
    -> [a]
    -> [a]
runPureFwdList :: forall a. [Patch Int '[] [a]] -> [a] -> [a]
runPureFwdList [Patch Int '[] [a]]
ps [a]
start =
    let ((), ([a]
remaining, [a]
patched, Int
_)) = forall s a. State s a -> s -> (a, s)
runState (forall (m :: * -> *) a.
(FwdInplaceStream m, Chunk m ~ a) =>
[Patch (Index m) '[] a] -> m ()
applyFwd [Patch Int '[] [a]]
ps) ([a]
start, forall a. Monoid a => a
mempty, Int
0 :: Int)
     in [a]
patched forall a. Semigroup a => a -> a -> a
<> [a]
remaining

applyFwdCompare
    :: forall a v m
    .  ( FwdInplaceStream m, Chunk m ~ a
       , Compare v a, HasLength a, Num (Index m) )
    => [Patch (Index m) '[Compare.Meta v] a]
    -> m (Either Error ())
applyFwdCompare :: forall a (v :: Via) (m :: * -> *).
(FwdInplaceStream m, Chunk m ~ a, Compare v a, HasLength a,
 Num (Index m)) =>
[Patch (Index m) '[Meta v] a] -> m (Either Error ())
applyFwdCompare = forall (t :: * -> *) (f :: * -> *) (m :: * -> *) v.
(Traversable t, Applicative f, Monad m) =>
(v -> m (f ())) -> t v -> m (f ())
traverseM_ forall a b. (a -> b) -> a -> b
$ \(Patch a
a Index m
s (HFunctorList (Flap r a
cm :& Rec (Flap a) rs
RNil))) -> do
    forall (m :: * -> *). FwdInplaceStream m => Index m -> m ()
advance Index m
s
    a
aStream <- forall (m :: * -> *). FwdInplaceStream m => Index m -> m (Chunk m)
readahead forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. HasLength a => a -> Int
getLength a
a
    case forall (v :: Via) a. Meta v a -> Maybe (CompareRep v a)
Compare.mCompare r a
cm of
      Maybe (CompareRep v a)
Nothing   -> do
        ()
x <- forall (m :: * -> *). FwdInplaceStream m => Chunk m -> m ()
overwrite a
a
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
x
      Just CompareRep v a
aCmp -> case forall (v :: Via) a.
Compare v a =>
CompareRep v a -> a -> Maybe String
compareTo @v CompareRep v a
aCmp a
aStream of
                     Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
                     Just String
e  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Error
ErrorCompare String
e

runPureFwdCompareString
    :: Compare v String
    => [Patch Int '[Compare.Meta v] String]
    -> String
    -> Either Error String
runPureFwdCompareString :: forall (v :: Via).
Compare v String =>
[Patch Int '[Meta v] String] -> String -> Either Error String
runPureFwdCompareString [Patch Int '[Meta v] String]
ps String
start =
    let (Either Error ()
r, (String
remaining, String
patched, Int
_)) = forall s a. State s a -> s -> (a, s)
runState (forall a (v :: Via) (m :: * -> *).
(FwdInplaceStream m, Chunk m ~ a, Compare v a, HasLength a,
 Num (Index m)) =>
[Patch (Index m) '[Meta v] a] -> m (Either Error ())
applyFwdCompare [Patch Int '[Meta v] String]
ps) (String
start, String
"", Int
0 :: Int)
    in  case Either Error ()
r of
          Left Error
err -> forall a b. a -> Either a b
Left Error
err
          Right () -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String
patched forall a. Semigroup a => a -> a -> a
<> String
remaining