-- Compression.hs: OpenPGP (RFC9580) compression and decompression
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).

module Codec.Encryption.OpenPGP.Compression
  ( CompressionError(..)
  , renderCompressionError
  , decompressPkt
  , compressPkts
  ) where

import qualified Codec.Compression.BZip as BZip
import qualified Codec.Compression.Zlib as Zlib
import qualified Codec.Compression.Zlib.Raw as ZlibRaw
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Data.Binary (get, put)
import Data.Binary.Get (runGetOrFail)
import Data.Binary.Put (runPut)
import qualified Data.ByteString.Lazy as BL

-- | Errors that can arise during decompression of an OpenPGP Compressed Data
-- packet.  Note that corrupt stream exceptions from the underlying
-- zlib\/bzip2 library are not captured here; they propagate as 'IOException'
-- through the call stack.
data CompressionError
  = -- | The compressed payload bytes are empty; nothing to decompress.
    EmptyCompressedPayload CompressionAlgorithm
  | -- | Decompression succeeded but the binary parse of the inner packet
    -- sequence failed.
    InnerPacketParseFailed CompressionAlgorithm String
  | -- | Decompression and parse succeeded but produced no packets at all
    -- (zero-length uncompressed payload).
    ZeroLengthDecompressedPayload CompressionAlgorithm
  | -- | The decompressed content contains only Marker packets (RFC4880 §5.8
    -- marker packets carry no semantic content).
    MarkerOnlyPayload CompressionAlgorithm
  deriving (CompressionError -> CompressionError -> Bool
(CompressionError -> CompressionError -> Bool)
-> (CompressionError -> CompressionError -> Bool)
-> Eq CompressionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompressionError -> CompressionError -> Bool
== :: CompressionError -> CompressionError -> Bool
$c/= :: CompressionError -> CompressionError -> Bool
/= :: CompressionError -> CompressionError -> Bool
Eq, Int -> CompressionError -> ShowS
[CompressionError] -> ShowS
CompressionError -> String
(Int -> CompressionError -> ShowS)
-> (CompressionError -> String)
-> ([CompressionError] -> ShowS)
-> Show CompressionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompressionError -> ShowS
showsPrec :: Int -> CompressionError -> ShowS
$cshow :: CompressionError -> String
show :: CompressionError -> String
$cshowList :: [CompressionError] -> ShowS
showList :: [CompressionError] -> ShowS
Show)

renderCompressionError :: CompressionError -> String
renderCompressionError :: CompressionError -> String
renderCompressionError (EmptyCompressedPayload CompressionAlgorithm
algo) =
  String
"Compressed Data packet (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CompressionAlgorithm -> String
forall a. Show a => a -> String
show CompressionAlgorithm
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"): empty compressed payload"
renderCompressionError (InnerPacketParseFailed CompressionAlgorithm
algo String
err) =
  String
"Compressed Data packet (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CompressionAlgorithm -> String
forall a. Show a => a -> String
show CompressionAlgorithm
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"): inner packet parse failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
renderCompressionError (ZeroLengthDecompressedPayload CompressionAlgorithm
algo) =
  String
"Compressed Data packet (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CompressionAlgorithm -> String
forall a. Show a => a -> String
show CompressionAlgorithm
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"): zero-length decompressed payload"
renderCompressionError (MarkerOnlyPayload CompressionAlgorithm
algo) =
  String
"Compressed Data packet (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CompressionAlgorithm -> String
forall a. Show a => a -> String
show CompressionAlgorithm
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"): decompressed content contains only Marker packets"

-- | Decompress an OpenPGP Compressed Data packet, classifying structural
-- failures as 'CompressionError'.  Non-Compressed-Data packets are returned
-- unchanged in @Right [p]@.  Corrupt compressed streams may still throw
-- 'IOException' from the underlying decompression library.
decompressPkt :: Pkt -> Either CompressionError [Pkt]
decompressPkt :: Pkt -> Either CompressionError [Pkt]
decompressPkt compressed :: Pkt
compressed@(CompressedDataPkt (OtherCA Word8
_) CompressedDataPayload
_) = [Pkt] -> Either CompressionError [Pkt]
forall a b. b -> Either a b
Right [Pkt
compressed]
decompressPkt (CompressedDataPkt CompressionAlgorithm
algo CompressedDataPayload
bs)
  | CompressedDataPayload -> Bool
BL.null CompressedDataPayload
bs = CompressionError -> Either CompressionError [Pkt]
forall a b. a -> Either a b
Left (CompressionAlgorithm -> CompressionError
EmptyCompressedPayload CompressionAlgorithm
algo)
  | Bool
otherwise =
      case Get (Block Pkt)
-> CompressedDataPayload
-> Either
     (CompressedDataPayload, ByteOffset, String)
     (CompressedDataPayload, ByteOffset, Block Pkt)
forall a.
Get a
-> CompressedDataPayload
-> Either
     (CompressedDataPayload, ByteOffset, String)
     (CompressedDataPayload, ByteOffset, a)
runGetOrFail Get (Block Pkt)
forall t. Binary t => Get t
get (CompressionAlgorithm
-> CompressedDataPayload -> CompressedDataPayload
dfunc CompressionAlgorithm
algo CompressedDataPayload
bs) of
        Left (CompressedDataPayload
_, ByteOffset
_, String
err) -> CompressionError -> Either CompressionError [Pkt]
forall a b. a -> Either a b
Left (CompressionAlgorithm -> String -> CompressionError
InnerPacketParseFailed CompressionAlgorithm
algo String
err)
        Right (CompressedDataPayload
_, ByteOffset
_, Block Pkt
packs) ->
          let pkts :: [Pkt]
pkts = Block Pkt -> [Pkt]
forall a. Block a -> [a]
unBlock Block Pkt
packs
          in case [Pkt]
pkts of
               [] -> CompressionError -> Either CompressionError [Pkt]
forall a b. a -> Either a b
Left (CompressionAlgorithm -> CompressionError
ZeroLengthDecompressedPayload CompressionAlgorithm
algo)
               [Pkt]
_ | (Pkt -> Bool) -> [Pkt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pkt -> Bool
isMarkerPkt [Pkt]
pkts -> CompressionError -> Either CompressionError [Pkt]
forall a b. a -> Either a b
Left (CompressionAlgorithm -> CompressionError
MarkerOnlyPayload CompressionAlgorithm
algo)
               [Pkt]
_ -> [Pkt] -> Either CompressionError [Pkt]
forall a b. b -> Either a b
Right [Pkt]
pkts
  where
    dfunc :: CompressionAlgorithm
-> CompressedDataPayload -> CompressedDataPayload
dfunc CompressionAlgorithm
Uncompressed = CompressedDataPayload -> CompressedDataPayload
forall a. a -> a
id
    dfunc CompressionAlgorithm
ZIP          = CompressedDataPayload -> CompressedDataPayload
ZlibRaw.decompress
    dfunc CompressionAlgorithm
ZLIB         = CompressedDataPayload -> CompressedDataPayload
Zlib.decompress
    dfunc CompressionAlgorithm
BZip2        = CompressedDataPayload -> CompressedDataPayload
BZip.decompress
    dfunc (OtherCA Word8
_)  = CompressedDataPayload -> CompressedDataPayload
forall a. a -> a
id
decompressPkt Pkt
p = [Pkt] -> Either CompressionError [Pkt]
forall a b. b -> Either a b
Right [Pkt
p]

isMarkerPkt :: Pkt -> Bool
isMarkerPkt :: Pkt -> Bool
isMarkerPkt (MarkerPkt CompressedDataPayload
_) = Bool
True
isMarkerPkt Pkt
_             = Bool
False

compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt
compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt
compressPkts CompressionAlgorithm
ca [Pkt]
packs =
  let bs :: CompressedDataPayload
bs = Put -> CompressedDataPayload
runPut (Put -> CompressedDataPayload) -> Put -> CompressedDataPayload
forall a b. (a -> b) -> a -> b
$ Block Pkt -> Put
forall t. Binary t => t -> Put
put ([Pkt] -> Block Pkt
forall a. [a] -> Block a
Block [Pkt]
packs)
      cbs :: CompressedDataPayload
cbs = CompressionAlgorithm
-> CompressedDataPayload -> CompressedDataPayload
cfunc CompressionAlgorithm
ca CompressedDataPayload
bs
      outAlgo :: CompressionAlgorithm
outAlgo = if CompressionAlgorithm -> Bool
isSupportedCompressionAlgorithm CompressionAlgorithm
ca then CompressionAlgorithm
ca else CompressionAlgorithm
Uncompressed
   in CompressionAlgorithm -> CompressedDataPayload -> Pkt
CompressedDataPkt CompressionAlgorithm
outAlgo CompressedDataPayload
cbs
  where
    cfunc :: CompressionAlgorithm
-> CompressedDataPayload -> CompressedDataPayload
cfunc CompressionAlgorithm
Uncompressed = CompressedDataPayload -> CompressedDataPayload
forall a. a -> a
id
    cfunc CompressionAlgorithm
ZIP = CompressedDataPayload -> CompressedDataPayload
ZlibRaw.compress
    cfunc CompressionAlgorithm
ZLIB = CompressedDataPayload -> CompressedDataPayload
Zlib.compress
    cfunc CompressionAlgorithm
BZip2 = CompressedDataPayload -> CompressedDataPayload
BZip.compress
    cfunc CompressionAlgorithm
_ = CompressedDataPayload -> CompressedDataPayload
forall a. a -> a
id

isSupportedCompressionAlgorithm :: CompressionAlgorithm -> Bool
isSupportedCompressionAlgorithm :: CompressionAlgorithm -> Bool
isSupportedCompressionAlgorithm CompressionAlgorithm
Uncompressed = Bool
True
isSupportedCompressionAlgorithm CompressionAlgorithm
ZIP = Bool
True
isSupportedCompressionAlgorithm CompressionAlgorithm
ZLIB = Bool
True
isSupportedCompressionAlgorithm CompressionAlgorithm
BZip2 = Bool
True
isSupportedCompressionAlgorithm (OtherCA Word8
_) = Bool
False