bytepatch-0.3.0: app/Main.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
module Main ( main ) where
import Config
import qualified CLI
import StreamPatch.Patch
import qualified StreamPatch.Patch.Align as Align
import qualified StreamPatch.Patch.Linearize as Linear
import qualified StreamPatch.Patch.Binary as Bin
import StreamPatch.Patch.Binary ( BinRep )
import qualified StreamPatch.Apply as Apply
import BytePatch as BP
import qualified BytePatch.HexByteString as HexBS
import BytePatch.HexByteString ( HexByteString )
import qualified System.Exit as System
import Numeric.Natural
import Data.Vinyl
import Data.Vinyl.TypeLevel
import Data.Functor.Const
import Data.Either.Combinators ( mapLeft )
import Control.Monad.IO.Class
import Control.Monad.Reader
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Yaml as Yaml
import Data.Yaml ( FromJSON )
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Text ( Text )
import Optics
import Data.Generics.Product.Any
type Bytes = BS.ByteString
data Error
= ErrorYaml Yaml.ParseException
| ErrorAlign String
| ErrorBin String
| ErrorLinear String
| ErrorBinPatch String
| Error String
deriving (Show)
main :: IO ()
main = CLI.parse >>= runReaderT run
run :: forall m. (MonadIO m, MonadReader Config m) => m ()
run = readPatchscript >>= processPatchScript >>= writePatched
where
readPatchscript = asks cfgPatchscript >>= readStream . CStreamFile
processPatchScript psBs = do
cpf <- asks cfgPatchFormat
case cpfDataType cpf of
CTextPatch -> processText psBs
CBinPatch -> processBin' @HexByteString psBs
CTextBinPatch -> processBin' @Text psBs
processText :: Bytes -> m Bytes
processText psBs = do
cpf <- asks cfgPatchFormat
case processAny @Text psBs (cpfAlign cpf) of
Left err -> quit err
Right ps -> patchTextAwkward ps
processBin' :: forall a. (BinRep a, FromJSON a, Show a) => Bytes -> m Bytes
processBin' psBs = do
cpf <- asks cfgPatchFormat
case processBin @a psBs (cpfAlign cpf) of
Left err -> quit err
Right ps -> patchBin ps
patchBin ps = do
bsIn <- asks (cStreamPairIn . cfgStreamPair) >>= readStream
binCfg <- asks $ cpfBinCfg . cfgPatchFormat
case Apply.runPureFwdBin binCfg ps bsIn of
Left err -> quit $ ErrorBinPatch (showErrorBin err)
Right bsOut -> return $ BL.toStrict bsOut
patchTextAwkward :: [Patch 'FwdSeek '[] Text] -> m Bytes
patchTextAwkward ps = do
bsIn <- asks (cStreamPairIn . cfgStreamPair) >>= readStream
let psStr = map (fmap Text.unpack) ps
strIn = Text.unpack $ Text.decodeUtf8 bsIn
strOut = Apply.runPureSimpleFwdList psStr strIn
bsOut = Text.encodeUtf8 $ Text.pack strOut
return bsOut
writePatched bs =
asks (cStreamPairOut . cfgStreamPair) >>= \case
CStreamFile fp -> liftIO $ BS.writeFile fp bs
CStreamStd -> asks (cpfDataType . cfgPatchFormat) >>= \case
CTextPatch -> liftIO $ BS.putStr bs
_ -> asks cfgPrintBinary >>= \case
True -> liftIO $ BS.putStr bs
False -> liftIO $ logWarn $
"refusing to print binary to stdout:"
<> " write to a file with --out-file FILE"
<> " or use --print-binary flag to override"
logWarn :: MonadIO m => String -> m ()
logWarn msg = liftIO $ putStrLn $ "bytepatch: warning: " <> msg
-- | Parses your bytes into some binreppable patch form (aligned or not,
-- depending on flag), converts it to the internal patch form, binreps it, and
-- linearizes. The binrep type is consumed inside the function, making it
-- ambiguous, so you need to pass it a type via @processBin \@Text@.
--
-- Note that we linearize *after* binrepping. This is important -- it means the
-- seeks are byte offsets, not using the pre-binrepped type.
processBin
:: forall a. (BinRep a, FromJSON a, Show a) => Bytes -> CPatchAlign
-> Either Error [Patch 'FwdSeek '[Bin.MetaStream] Bytes]
processBin bs = \case
CAlignPatch -> mapLeft ErrorYaml (Yaml.decodeEither' @[Aligned (MultiPatch 'RelSeek a)] bs)
>>= mapLeft (ErrorAlign . show) . fmap concat . traverse (wrapAlign (BP.convertBinAlign @'AbsSeek))
>>= mapLeft (ErrorBin . showErrorBin) . traverse Bin.patchBinRep
>>= mapLeft (ErrorLinear . show) . Linear.linearize
CNoAlignPatch -> mapLeft ErrorYaml (Yaml.decodeEither' @[MultiPatch 'AbsSeek a] bs)
>>= mapLeft (ErrorBin . showErrorBin) . traverse Bin.patchBinRep . concat . map BP.convertBin
>>= mapLeft (ErrorLinear . show) . Linear.linearize
-- | Like 'processBin' but no binrepping. Similarly beautiful and ambiguous.
processAny
:: forall a. (Show a, FromJSON a, Linear.HasLength a) => Bytes -> CPatchAlign
-> Either Error [Patch 'FwdSeek '[] a]
processAny bs = \case
CAlignPatch -> mapLeft ErrorYaml (Yaml.decodeEither' @[Aligned (MultiPatch 'RelSeek a)] bs)
>>= mapLeft (ErrorAlign . show) . fmap concat . traverse (wrapAlign (BP.convertAlign @'AbsSeek))
>>= mapLeft (ErrorLinear . show) . Linear.linearize
CNoAlignPatch -> mapLeft ErrorYaml (Yaml.decodeEither' @[MultiPatch 'AbsSeek a] bs)
>>= mapLeft (ErrorLinear . show) . Linear.linearize . concat . map BP.convertEmpty
wrapAlign
:: ( SeekRep s ~ Natural
, r ~ Const (Align.Meta s)
, rs ~ RDelete r ss
, RElem r ss i
, RSubset rs ss is )
=> (MultiPatch 'RelSeek a -> [Patch 'RelSeek ss a])
-> Aligned (MultiPatch 'RelSeek a)
-> Either (Align.Error s) [Patch s rs a]
wrapAlign f = align . over (the @"alignedPatches") (concat . map f)
quit :: MonadIO m => Error -> m a
quit err = do
liftIO $ putStrLn $ "bytepatch: error: " <> errStr
liftIO $ System.exitWith $ System.ExitFailure errExitCode
where
(errExitCode, errStr) = case err of
ErrorYaml e -> (1, "while parsing YAML: " <> show e)
ErrorAlign e -> (2, "while aligning: " <> e)
ErrorBin e -> (3, "while converting to binary representation: " <> e)
ErrorLinear e -> (4, "while linearizing: " <> e)
ErrorBinPatch e -> (5, "while applying binaryized patch: " <> e)
Error e -> (10, e)
readStream :: MonadIO m => CStream -> m Bytes
readStream s = liftIO $
case s of
CStreamStd -> BS.getContents
CStreamFile fp -> BS.readFile fp
-- stupid but how else do I do this without pluggin HexByteString into Binary
-- guess I just gotta write ACTUAL error handling. ffs
showErrorBin :: Show a => Bin.Error a -> String
showErrorBin = \case
Bin.ErrorBadBinRep a s -> "ErrorBadBinRep " <> show a <> " " <> s
Bin.ErrorUnexpectedNonNull bs -> "ErrorUnexpectedNonNull " <> go bs
Bin.ErrorDidNotMatchExpected bs1 bs2 -> "ErrorDidNotMatchExpected " <> go bs1 <> " " <> go bs2
Bin.ErrorBinRepTooLong bs n -> "ErrorBinRepTooLong " <> go bs <> " " <> show n
where go bs = "\"" <> Text.unpack (HexBS.prettyHexByteString bs) <> "\""
{-
writeStream :: MonadIO m => Bytes -> CStream -> m ()
writeStream bs s = liftIO $
case s of
CStreamStd -> BS.putStr bs
CStreamFile fp -> BS.writeFile fp bs
tryDecodeYaml
:: forall a m. (FromJSON a, MonadIO m)
=> FilePath -> m (Either Yaml.ParseException a)
tryDecodeYaml fp = Yaml.decodeEither' <$> liftIO (BS.readFile fp)
-}