Armor.hs

{-# LANGUAGE RecordWildCards #-}

-- Armor.hs: hOpenPGP-tools common ASCII de-Armor function
-- Copyright © 2012-2026  Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module HOpenPGP.Tools.Common.Armor
    ( doDeArmor
    ) where

import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor (..))
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types (Pkt (..))
import Control.Applicative (many)
import Control.Exception
    ( ErrorCall
    , catch
    , displayException
    , evaluate
    )
import qualified Data.Binary as Bin
import Data.Binary.Get (runGet)
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.IO (hPutStrLn, stderr, stdin)

doDeArmor :: IO ()
doDeArmor = do
    a <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
    let lbs = BL.fromChunks a
    case BL.uncons lbs of
        Just (firstByte, _)
            | firstByte >= 0x80 -> do
                packets <- parseBinaryPackets lbs
                validatePackets packets
                BL.putStr lbs
            | otherwise ->
                case (AA.decode (BL.toStrict lbs) :: Either String [Armor]) of
                    Right [] -> do
                        hPutStrLn stderr "dearmor: no ASCII armor blocks found"
                        exitWith (ExitFailure 41)
                    Right msgs
                        | length msgs /= 1 ->
                            failBadData "dearmor: expected exactly one ASCII armor block"
                        | otherwise -> do
                            let payloads = [bs | Armor _ _ bs <- msgs]
                            packets <- parseBinaryPackets (BL.concat payloads)
                            validatePackets packets
                            BL.putStr $ BL.concat payloads
                    Left err -> do
                        hPutStrLn stderr $ "dearmor: malformed ASCII armor: " ++ err
                        exitWith (ExitFailure 41)
        Nothing -> failBadData "dearmor: no OpenPGP packets found"

parseBinaryPackets :: BL.ByteString -> IO [Pkt]
parseBinaryPackets bytes =
    evaluate (runGet (many Bin.get) bytes) `catch` parseFailure
  where
    parseFailure :: ErrorCall -> IO [Pkt]
    parseFailure err =
        failBadData
            ( "dearmor: malformed OpenPGP packet stream: "
                ++ displayException err
            )

validatePackets :: [Pkt] -> IO ()
validatePackets packets
    | null packets = failBadData "dearmor: no OpenPGP packets found"
    | any isBroken packets =
        failBadData "dearmor: malformed OpenPGP packet stream"
    | not (validShape packets) =
        failBadData "dearmor: unexpected OpenPGP packet sequence"
    | otherwise = pure ()
  where
    isBroken BrokenPacketPkt {} = True
    isBroken _ = False
    validShape ps =
        all isSignature ps
            || validKeyStream ps
            || validCiphertext ps
            || validInlineSigned ps
    isSignature SignaturePkt {} = True
    isSignature _ = False
    validKeyStream (SecretKeyPkt {} : _) = True
    validKeyStream (PublicKeyPkt {} : _) = True
    validKeyStream _ = False
    validCiphertext (firstPacket : rest) =
        isSessionKeyPacket firstPacket
            && not (null rest)
            && all isSessionKeyPacket (init rest)
            && isEncryptedPayloadPacket (last rest)
    validCiphertext _ = False
    isSessionKeyPacket PKESKPkt {} = True
    isSessionKeyPacket SKESKPkt {} = True
    isSessionKeyPacket _ = False
    validInlineSigned (firstPacket : rest) =
        any isLiteralDataPacket rest
            && (isOnePassSignaturePacket firstPacket || isSignature firstPacket)
    validInlineSigned _ = False
    isLiteralDataPacket LiteralDataPkt {} = True
    isLiteralDataPacket _ = False
    isOnePassSignaturePacket OnePassSignaturePkt {} = True
    isOnePassSignaturePacket _ = False
    isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True
    isEncryptedPayloadPacket SymEncDataPkt {} = True
    isEncryptedPayloadPacket _ = False

failBadData :: String -> IO a
failBadData message = do
    hPutStrLn stderr message
    exitWith (ExitFailure 41)