-- Lint.hs: hOpenPGP key tool lint subcommand
-- Copyright © 2013-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/>.
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

module HOpenPGP.Tools.Hokey.Lint
    ( doLint
    ) where

import Codec.Encryption.OpenPGP.Expirations
    ( getKeyExpirationTimesFromSignature
    )
import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.KeyInfo
    ( pkalgoAbbrev
    , pubkeySize
    )
import Codec.Encryption.OpenPGP.Ontology
    ( isCT
    , isCertRevocationSig
    , isKUF
    , isPHA
    , isPKBindingSig
    , isSKBindingSig
    )
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Control.Arrow ((***))
import Control.Error.Util (hush)
import Control.Lens ((&))
import Control.Monad (void)
import Control.Monad.Trans.Writer.Lazy (execWriter, tell)
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
import qualified Data.Aeson as A
import Data.Binary (get)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BC8
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 Data.Conduit.OpenPGP.Keyring
    ( conduitDropErrorsAndNothings
    , conduitToSomeTKsDroppingEither
    )
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Foldable (find, maximumBy, sequenceA_, traverse_)
import Data.List (elemIndex, findIndex, intercalate, nub, sortOn)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord (comparing)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock.POSIX
    ( POSIXTime
    , getPOSIXTime
    , posixSecondsToUTCTime
    )
import Data.Time.Format (formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import qualified Data.Yaml as Y
import GHC.Generics
import Prettyprinter
    ( Doc
    , annotate
    , colon
    , flatAlt
    , indent
    , line
    , list
    , pretty
    , vsep
    , (<+>)
    )
import qualified Prettyprinter.Render.Terminal as PPA
import System.IO
    ( stdin
    )

import HOpenPGP.Tools.Common.Common
    ( renderFingerprint
    , renderKeyID
    )
import HOpenPGP.Tools.Common.TKUtils (processTK)
import HOpenPGP.Tools.Hokey.Options
    ( LintOptions (..)
    , LintOutputFormat (..)
    )

linebreak :: Doc ann
linebreak = flatAlt line mempty

green, yellow, red :: Doc PPA.AnsiStyle -> Doc PPA.AnsiStyle
green = annotate (PPA.color PPA.Green)
yellow = annotate (PPA.color PPA.Yellow)
red = annotate (PPA.color PPA.Red)

data KAS
    = KAS
    { pubkeyalgo :: Result PubKeyAlgorithm
    , pubkeysize :: Result (Maybe Int)
    , stringrep :: String
    }
    deriving (Generic)

data Color
    = Green
    | Yellow
    | Red
    deriving (Eq, Generic, Ord)

data Result a = Result
    { resultColor :: Maybe Color
    , resultFindings :: Maybe [String]
    , resultValue :: a
    }
    deriving (Functor, Generic)

instance Applicative Result where
    pure x = Result Nothing Nothing x
    (Result c1 e1 f) <*> (Result c2 e2 x) =
        Result (max c1 c2) (e1 <> e2) (f x)

instance Monad Result where
    (Result c1 e1 x) >>= f =
        let Result c2 e2 y = f x
         in Result (max c1 c2) (e1 <> e2) y

colored :: Maybe Color -> Maybe [String] -> a -> Result a
colored c e x = Result c e x

withColor :: Maybe Color -> a -> Result a
withColor c x = Result c Nothing x

getResult :: Result a -> a
getResult (Result _ _ x) = x

newtype LintPolicy src a
    = LintPolicy
    { unPolicy :: src -> Maybe POSIXTime -> Result a
    }
    deriving (Functor, Generic)

instance Applicative (LintPolicy src) where
    pure x = LintPolicy (\_ _ -> pure x)
    (LintPolicy f) <*> (LintPolicy x) = LintPolicy (\src mpt -> f src mpt <*> x src mpt)

data KeyReport
    = KeyReport
    { keyStatus :: Result String
    , keyFingerprint :: Result Fingerprint
    , keyVer :: Result KeyVersion
    , keyCreationTime :: Result ThirtyTwoBitTimeStamp
    , keyAlgorithmAndSize :: Result KAS
    , keyUIDsAndUAts :: Map.Map Text (Result UIDReport)
    , keyBestOf :: Maybe UIDReport
    , keySubkeys :: [Result SubkeyReport]
    , keyHasEncryptionCapableSubkey :: Result Bool
    }
    deriving (Generic)

data UIDReport
    = UIDReport
    { uidSelfSigHashAlgorithms :: [Result HashAlgorithm]
    , uidPreferredHashAlgorithms :: [Result [HashAlgorithm]]
    , uidKeyExpirationTimes :: [Result [ThirtyTwoBitDuration]]
    , uidKeyUsageFlags :: [Result (Set.Set KeyFlag)]
    , uidRevocationStatus :: [RevocationStatus]
    }
    deriving (Generic)

data SubkeyReport
    = SubkeyReport
    { skFingerprint :: Result Fingerprint
    , skVer :: Result KeyVersion
    , skCreationTime :: ThirtyTwoBitTimeStamp
    , skAlgorithmAndSize :: Result KAS
    , skBindingSigHashAlgorithms :: [Result HashAlgorithm]
    , skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning]
    , skUsageFlags :: [Result (Set.Set KeyFlag)]
    , skCrossCerts :: CrossCertReport
    }
    deriving (Generic)

data SubkeyRevocationDigestWarning
    = SubkeyRevocationDigestWarning
    { srwHashAlgorithm :: HashAlgorithm
    , srwSubkeyFingerprint :: String
    , srwSubkeyKeyID :: Maybe String
    , srwMessage :: String
    }
    deriving (Generic)

data CrossCertReport
    = CrossCertReport
    { ccPresent :: Result Bool
    , ccHashAlgorithms :: [Result HashAlgorithm]
    }
    deriving (Generic)

data RevocationStatus
    = RevocationStatus
    { isRevoked :: Bool
    , revocationCode :: String
    , revocationReason :: Text
    }
    deriving (Generic)

instance A.ToJSON KAS

instance A.ToJSON Color

instance (A.ToJSON a) => A.ToJSON (Result a)

instance A.ToJSON KeyReport

instance A.ToJSON UIDReport

instance A.ToJSON SubkeyReport

instance A.ToJSON SubkeyRevocationDigestWarning

instance A.ToJSON CrossCertReport

instance A.ToJSON RevocationStatus

instance Semigroup UIDReport where
    (<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') =
        UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e')

instance Monoid UIDReport where
    mempty = UIDReport [] [] [] [] []
    mappend = (<>)

checkKey :: LintPolicy SomeTK KeyReport
checkKey = LintPolicy $ \tk mpt -> checkKey' mpt tk

checkKey' :: Maybe POSIXTime -> SomeTK -> Result KeyReport
checkKey' mpt stk =
    kr
        <$ sequenceA_
            [ void (keyStatus kr)
            , void (keyFingerprint kr)
            , void (keyVer kr)
            , void (keyAlgorithmAndSize kr)
            , void (keyHasEncryptionCapableSubkey kr)
            , traverse_ void (keySubkeys kr)
            , traverse_ void (keyUIDsAndUAts kr)
            ]
  where
    procResult = processTK mpt stk
    processedTK = either (const stk) id procResult
    publicView = someTKToPublicViewTK processedTK
    primaryKey = keyPktPKPayload (_tkPrimaryKey publicView)
    kr =
        KeyReport
            { keyStatus = pure (either id (const "good") procResult)
            , keyFingerprint = pure (fingerprint primaryKey)
            , keyVer = colorizeKV (_keyVersion primaryKey)
            , keyCreationTime = pure (_timestamp primaryKey)
            , keyAlgorithmAndSize = kasIt primaryKey
            , keyUIDsAndUAts = uidMap
            , keyBestOf = populateBestOf uidMap
            , keySubkeys = subkeys
            , keyHasEncryptionCapableSubkey =
                hasEncryptionCapableSubkey
                    (concatMap (skUsageFlags . getResult) subkeys)
            }
    uidMap =
        Map.fromListWith (liftA2 (<>)) $
            map
                (\(x, y) -> (x, uidr (Just x) y))
                (_tkUIDs publicView)
                ++ map
                    (uatspsToText *** uidr Nothing)
                    (_tkUAts publicView)
    subkeys = map (checkSK (fingerprint primaryKey)) (_tkSubs publicView)
    uidr :: Maybe Text -> [SignaturePayload] -> Result UIDReport
    uidr Nothing sps =
        UIDReport
            <$> pure (has sps)
            <*> pure (map phas sps)
            <*> pure
                ( map
                    ( colorizeKETs
                        (fromMaybe 0 mpt)
                        (unThirtyTwoBitTimeStamp (_timestamp primaryKey))
                        . getKeyExpirationTimesFromSignature
                    )
                    sps -- should that be 0?
                )
            <*> pure (kufs False sps)
            <*> pure (findRevocationReason sps)
    uidr (Just u) sps =
        colorizeUID
            u
            ( UIDReport
                (has sps)
                (map phas sps)
                ( map
                    ( colorizeKETs
                        (fromMaybe 0 mpt)
                        (unThirtyTwoBitTimeStamp (_timestamp primaryKey))
                        . getKeyExpirationTimesFromSignature
                    )
                    sps -- should that be 0?
                )
                (kufs False sps)
                (findRevocationReason sps)
            )
    kasIt :: SomePKPayload -> Result KAS
    kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize)
    kasIt' :: PubKeyAlgorithm -> Either String Int -> Result KAS
    kasIt' pka epks =
        let pr = colorizePKA pka
            prs = colorizePKS pka epks
            strRep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka)
         in colored
                (max (resultColor pr) (resultColor prs))
                (resultFindings pr <> resultFindings prs)
                (KAS pr prs strRep)
    colorizeKV :: KeyVersion -> Result KeyVersion
    colorizeKV kv
        | kv `elem` [V4, V6] = withColor (Just Green) kv
        | otherwise =
            colored (Just Red) (Just ["not a V4 or V6 key"]) kv
    colorizePKA :: PubKeyAlgorithm -> Result PubKeyAlgorithm
    colorizePKA pka
        | pka `elem` [RSA, EdDSA, ECDH, X25519, X448] -- FIXME: incomplete
            =
            colored (Just Green) Nothing pka
        | otherwise =
            colored
                (Just Yellow)
                (Just ["public key algorithm neither RSA nor EdDSA"])
                pka
    colorizePKS
        :: PubKeyAlgorithm -> Either String Int -> Result (Maybe Int)
    colorizePKS pka (Right pks)
        -- Group 256-bit ECC curves
        | pka `elem` [X25519, ECDH, EdDSA] && pks >= 256 -- FIXME: incomplete
            =
            withColor (Just Green) (Just pks)
        -- Group 448-bit ECC curves
        | pka `elem` [X448] && pks >= 448 -- FIXME: incomplete
            =
            withColor (Just Green) (Just pks)
        -- Catch-all for undersized ECC curves
        | pka `elem` [X25519, X448, ECDH, EdDSA] -- FIXME: incomplete
            =
            colored
                (Just Yellow)
                (Just ["Public key size insufficient for ECC algorithm"])
                (Just pks)
        -- RSA size checks
        | pka == RSA && pks >= 3072 =
            withColor (Just Green) (Just pks)
        | pka == RSA && pks >= 2048 =
            colored
                (Just Yellow)
                (Just ["Public key size between 2048 and 3072 bits"])
                (Just pks)
        | pka == RSA =
            colored
                (Just Red)
                (Just ["Public key size under 2048 bits"])
                (Just pks)
        -- Fallback for unknown algorithms but known sizes
        | otherwise =
            pure (Just pks)
    colorizePKS _ (Left _) =
        colored
            (Just Red)
            (Just ["public key algorithm not understood"])
            Nothing
    colorizePHAs :: [HashAlgorithm] -> Result [HashAlgorithm]
    colorizePHAs x
        | preferredWeakHash x =
            colored (Just Red) (Just ["weak hash with higher preference"]) x
        | otherwise = withColor (Just Green) x
    fSHA2or3Family =
        fi (`elem` [SHA512, SHA384, SHA256, SHA224, SHA3_512, SHA3_256])
    firstStrongSHA2or3 xs = fSHA2or3Family xs
    preferredWeakHash xs =
        any
            ( \ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2or3 xs
            )
            knownWeakHashAlgorithms
    fi x y = fromMaybe maxBound (findIndex x y)
    colorizeKETs ct ts kes
        | null kes = colored (Just Red) (Just ["no expiration set"]) kes
        | any (\ke -> realToFrac ts + realToFrac ke < ct) kes =
            colored (Just Red) (Just ["expiration passed"]) kes
        | any
            (\ke -> realToFrac ts + realToFrac ke > ct + (5 * 31557600))
            kes =
            colored (Just Yellow) (Just ["expiration too far in future"]) kes
        | otherwise = colored (Just Green) Nothing kes
    eoki pkp
        | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
        | _keyVersion pkp == DeprecatedV3
            && elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
            hush . eightOctetKeyID $ pkp
        | otherwise = Nothing
    phas sig =
        colorizePHAs
            ( concatMap
                ( \case
                    SigSubPacket _ (PreferredHashAlgorithms x) -> x
                    _ -> []
                )
                (filter isPHA (hasheds sig))
            )
    has = map (colorizeHA . hashAlgo) . alleged
    colorizeHA :: HashAlgorithm -> Result HashAlgorithm
    colorizeHA ha
        | isKnownWeakHashAlgorithm ha =
            colored (Just Red) (Just ["weak hash algorithm"]) ha
        | otherwise = pure ha
    sigcts sig =
        map
            ( \case
                SigSubPacket _ (SigCreationTime x) -> x
                _ -> error "unexpected subpacket type"
            )
            (filter isCT (hasheds sig))
    alleged =
        filter
            ( \sig ->
                primaryFingerprint `elem` sigissuerFPs sig
                    || ((==) <$> sigissuer sig <*> eoki primaryKey)
                        == Just True
            )
      where
        primaryFingerprint = fingerprint primaryKey
    uatspsToText = T.pack . uatspsToString
    uatspsToString us =
        "<uat:[" ++ intercalate "," (map uaspToString us) ++ "]>"
    uaspToString (ImageAttribute hdr d) =
        hdrToString hdr
            ++ ':'
            : show (BL.length d)
            ++ ':'
            : BC8.unpack
                (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
    uaspToString (OtherUASub t d) =
        "other-"
            ++ show t
            ++ ':'
            : show (BL.length d)
            ++ ':'
            : BC8.unpack
                (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
    hdrToString (ImageHV1 JPEG) = "jpeg"
    hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)
    populateBestOf
        :: Map.Map Text (Result UIDReport) -> Maybe UIDReport
    populateBestOf um
        | Map.null um = Nothing
        | otherwise =
            Just
                ( UIDReport
                    <$> best . uidSelfSigHashAlgorithms
                    <*> best
                        . uidPreferredHashAlgorithms
                    <*> best
                        . uidKeyExpirationTimes
                    <*> best
                        . uidKeyUsageFlags
                    <*> pure []
                    $ mconcat (justTheUIDRs um)
                )
    justTheUIDRs = map getResult . Map.elems
    -- Pick the single most favorable Result from a list, for display as
    -- a representative "best of" example.
    --
    -- This doesn't use Ord because there could be a Nothing in the list
    -- and that would be "best".
    --
    -- That also implies that this should get an overhaul.
    best :: [Result a] -> [Result a]
    best = take 1 . sortOn (bestOfRank . resultColor)
    bestOfRank :: Maybe Color -> Int
    bestOfRank (Just Green) = 0
    bestOfRank (Just Yellow) = 1
    bestOfRank (Just Red) = 2
    bestOfRank Nothing = 3
    colorizeUID :: Text -> UIDReport -> Result UIDReport
    colorizeUID u ur =
        let strU = T.unpack u
            check cond msg =
                if cond
                    then colored (Just Yellow) (Just [msg]) ()
                    else pure ()
         in check ('(' `elem` strU) "parenthesis in uid"
                *> check ('<' `notElem` strU) "no left angle bracket in uid"
                *> pure ur
    findRevocationReason = concatMap grabReasons . filter isCertRevocationSig
    grabReasons (SigV4 CertRevocationSig _ _ hashedSubs _ _ _) =
        mapMaybe (grabReasons' . _sspPayload) hashedSubs
    grabReasons (SigV6 CertRevocationSig _ _ _ hashedSubs _ _ _) =
        mapMaybe (grabReasons' . _sspPayload) hashedSubs
    grabReasons _ = []
    grabReasons' (ReasonForRevocation a b) =
        Just (RevocationStatus True (show a) b)
    grabReasons' _ = Nothing
    kufs s =
        mapMaybe
            ( \sig ->
                case find isKUF (hasheds sig) of
                    Just (SigSubPacket _ (KeyFlags x)) -> Just (colorizeKUFs s x)
                    _ -> Nothing
            )
            . newestWith (any isKUF . hasheds)
    colorizeKUFs
        :: Bool -> Set.Set KeyFlag -> Result (Set.Set KeyFlag)
    colorizeKUFs False x
        | encrypts && signsOrCertifies =
            colored (Just Yellow) (Just ["both signing & encryption"]) x
        | otherwise = withColor (Just Green) x
      where
        encrypts =
            Set.member EncryptStorageKey x
                || Set.member EncryptCommunicationsKey x
        signsOrCertifies = Set.member SignDataKey x || Set.member CertifyKeysKey x
    colorizeKUFs True x
        | certifies =
            colored (Just Red) (Just ["certification-capable subkey"]) x
        | encryptsAndSigns =
            colored (Just Yellow) (Just ["both signing & encryption"]) x
        | otherwise = withColor (Just Green) x
      where
        certifies = Set.member CertifyKeysKey x
        encryptsAndSigns =
            ( Set.member EncryptStorageKey x
                || Set.member EncryptCommunicationsKey x
            )
                && Set.member SignDataKey x
    sigTime :: SignaturePayload -> ThirtyTwoBitTimeStamp
    sigTime sig = case sigcts sig of
        (t : _) -> t
        [] -> 0
    newestWith p sigs =
        let filtered = filter p sigs
         in if null filtered
                then []
                else [maximumBy (comparing sigTime) filtered]
    checkSK
        :: Fingerprint
        -> (KeyPkt k, [SignaturePayload])
        -> Result SubkeyReport
    checkSK pf (KeyPktPublicSubkey pkp, sigs) = checkSK' pf pkp sigs
    checkSK pf (KeyPktSecretSubkey pkp _, sigs) = checkSK' pf pkp sigs
    checkSK _ _ = error "checkSK: unexpected packet type"
    checkSK' pf pkp sigs =
        skr
            <$ sequenceA_
                [ void (skFingerprint skr)
                , void (skVer skr)
                , void (skAlgorithmAndSize skr)
                , traverse_ void (skBindingSigHashAlgorithms skr)
                , traverse_ void (skUsageFlags skr)
                , void (ccPresent (skCrossCerts skr))
                , traverse_ void (ccHashAlgorithms (skCrossCerts skr))
                ]
      where
        skr =
            ( \x -> x {skCrossCerts = ccr (map getResult (skUsageFlags x)) sigs}
            )
                SubkeyReport
                    { skFingerprint = colorizeF pf (fingerprint pkp)
                    , skVer = colorizeKV (_keyVersion pkp)
                    , skCreationTime = _timestamp pkp
                    , skAlgorithmAndSize = kasIt pkp
                    , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)
                    , skRevocationSigWeakDigests =
                        subkeyRevocationSigWeakDigests pkp sigs
                    , skUsageFlags = kufs True (filter isSKBindingSig sigs)
                    , skCrossCerts = CrossCertReport (pure False) []
                    }
    hasEncryptionCapableSubkey
        :: [Result (Set.Set KeyFlag)] -> Result Bool
    hasEncryptionCapableSubkey skrs =
        let hasEncryption =
                any
                    ( ( \x ->
                            Set.member EncryptStorageKey x
                                || Set.member EncryptCommunicationsKey x
                      )
                        . getResult
                    )
                    skrs
         in if hasEncryption
                then withColor (Just Green) True
                else
                    colored
                        (Just Red)
                        (Just ["no encryption-capable subkey present"])
                        False
    embeddedSigs =
        filter isPKBindingSig
            . concatMap getEmbeds
            . filter isSKBindingSig
    getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
    getEmbeds (SigV6 _ _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
    getEmbeds _ = []
    getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]
    getEmbed _ = []
    ccr kufs' sigs =
        CrossCertReport
            (colorES kufs' sigs)
            (map (colorizeHA . hashAlgo) sigs)
    colorES :: [Set.Set KeyFlag] -> [SignaturePayload] -> Result Bool
    colorES kufs' sigs =
        let noEmbedded = null (embeddedSigs sigs)
            signCapable = any (Set.member SignDataKey) kufs'
            authCapable = any (Set.member AuthKey) kufs'
         in case (noEmbedded, signCapable, authCapable) of
                (True, True, True) ->
                    colored
                        (Just Red)
                        (Just ["signing- and auth-capable subkey without cross-cert"])
                        False
                (True, True, False) ->
                    colored
                        (Just Red)
                        (Just ["signing-capable subkey without cross-cert"])
                        False
                (True, False, True) ->
                    colored
                        (Just Yellow)
                        (Just ["auth-capable subkey without cross-cert"])
                        False
                _ ->
                    withColor (Just Green) True
    colorizeF :: Fingerprint -> Fingerprint -> Result Fingerprint
    colorizeF pf fp
        | pf == fp =
            colored
                (Just Red)
                (Just ["subkey has same fingerprint as primary key"])
                fp
        | otherwise = withColor (Just Green) fp
    subkeyRevocationSigWeakDigests pkp =
        mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp)
            . filter isSubkeyRevocationSignature
    mkSubkeyRevocationSigWeakDigestWarning pkp sig =
        let ha = hashAlgo sig
         in if isKnownWeakHashAlgorithm ha
                then
                    Just
                        SubkeyRevocationDigestWarning
                            { srwHashAlgorithm = ha
                            , srwSubkeyFingerprint = renderFingerprint (fingerprint pkp)
                            , srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp))
                            , srwMessage =
                                "subkey revocation signature uses known-weak digest algorithm"
                            }
                else Nothing

prettyKeyReport :: POSIXTime -> SomeTK -> Doc PPA.AnsiStyle
prettyKeyReport cpt stk = do
    let keyReportResult = unPolicy checkKey stk (Just cpt)
        keyReport = getResult keyReportResult
    execWriter $
        tell $
            vsep
                [ pretty "Key has potential validity"
                    <> colon
                    <+> pretty (getResult (keyStatus keyReport))
                , pretty "Key has fingerprint"
                    <> colon
                    <+> pretty (SpacedFingerprint (getResult (keyFingerprint keyReport)))
                , pretty "Checking to see if key is OpenPGPv4 or v6"
                    <> colon
                    <+> coloredToColor (pretty . show) (keyVer keyReport)
                , ( \kas ->
                        pretty "Checking the strength of your primary asymmetric key"
                            <> colon
                            <+> coloredToColor pretty (pubkeyalgo kas)
                            <+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)
                  )
                    (getResult (keyAlgorithmAndSize keyReport))
                , pretty "Checking user-ID- and user-attribute-related items"
                    <> colon
                    <> mconcat
                        ( map
                            (uidtrip (getResult (keyCreationTime keyReport)))
                            (Map.toList (keyUIDsAndUAts keyReport))
                        )
                , pretty "Checking subkeys" <> colon
                , indent
                    2
                    ( pretty "one of the subkeys is encryption-capable"
                        <> colon
                        <+> coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)
                    )
                    <> mconcat (map subkeyrep (keySubkeys keyReport))
                ]
                <> linebreak
  where
    coloredToColor f (Result (Just Green) _ x) = green (f x)
    coloredToColor f (Result (Just Yellow) _ x) = yellow (f x)
    coloredToColor f (Result (Just Red) _ x) = red (f x)
    coloredToColor f (Result Nothing _ x) = f x
    uidtrip ts (uText, r@(Result _ _ ur))
        | null (uidRevocationStatus ur) =
            linebreak
                <> indent 2 (coloredToColor pretty (T.unpack uText <$ r))
                <> colon
                <> linebreak
                <> indent
                    4
                    ( pretty "Self-sig hash algorithms"
                        <> colon
                        <+> (list . map (coloredToColor pretty) . uidSelfSigHashAlgorithms)
                            ur
                    )
                <> linebreak
                <> indent
                    4
                    ( pretty "Preferred hash algorithms"
                        <> colon
                        <+> mconcat
                            (map (coloredToColor pretty) (uidPreferredHashAlgorithms ur))
                    )
                <> linebreak
                <> indent
                    4
                    ( pretty "Key expiration times"
                        <> colon
                        <+> mconcat
                            ( map
                                (coloredToColor list . fmap (map (pretty . keyExp ts)))
                                (uidKeyExpirationTimes ur)
                            )
                    )
                <> linebreak
                <> indent
                    4
                    ( pretty "Key usage flags"
                        <> colon
                        <+> (list . map (coloredToColor (pretty . Set.toList)))
                            (uidKeyUsageFlags ur)
                    )
        | otherwise =
            linebreak
                <> indent 2 (coloredToColor pretty (T.unpack uText <$ r))
                <> colon
                <+> pretty "[revoked]"
                <> linebreak
                <> indent
                    4
                    ( pretty "Revocation code"
                        <> colon
                        <+> list (map (pretty . revocationCode) (uidRevocationStatus ur))
                    )
                <> linebreak
                <> indent
                    4
                    ( pretty "Revocation reason"
                        <> colon
                        <+> list
                            ( map
                                (pretty . T.unpack . revocationReason)
                                (uidRevocationStatus ur)
                            )
                    )
    keyExp ts ke =
        (show . pretty) ke
            ++ " = "
            ++ formatTime
                defaultTimeLocale
                "%c"
                (posixSecondsToUTCTime (realToFrac ts + realToFrac ke))
    subkeyrep skrResult =
        let skr = getResult skrResult
         in subkeydetail skr
    subkeydetail skr =
        linebreak
            <> indent
                2
                ( pretty "fpr"
                    <> colon
                    <+> coloredToColor
                        pretty
                        (fmap SpacedFingerprint (skFingerprint skr))
                )
            <> linebreak
            <> indent
                4
                (pretty "version" <> colon <+> coloredToColor pretty (skVer skr))
            <> linebreak
            <> indent
                4
                (pretty "timestamp" <> colon <+> pretty (skCreationTime skr))
            <> linebreak
            <> indent
                4
                ( ( \kas ->
                        pretty "algo/size"
                            <> colon
                            <+> coloredToColor pretty (pubkeyalgo kas)
                            <+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)
                  )
                    (getResult (skAlgorithmAndSize skr))
                )
            <> linebreak
            <> indent
                4
                ( pretty "binding sig hash algorithms"
                    <> colon
                    <+> (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms)
                        skr
                )
            <> linebreak
            <> indent
                4
                ( pretty "weak subkey revocation digests"
                    <> colon
                    <+> if null (skRevocationSigWeakDigests skr)
                        then pretty "[]"
                        else
                            list
                                ( map
                                    ( \w ->
                                        red
                                            ( pretty (srwHashAlgorithm w)
                                                <> colon
                                                <+> pretty (srwSubkeyFingerprint w)
                                                <> colon
                                                <+> maybe (pretty "<no-key-id>") pretty (srwSubkeyKeyID w)
                                            )
                                    )
                                    (skRevocationSigWeakDigests skr)
                                )
                )
            <> linebreak
            <> indent
                4
                ( pretty "usage flags"
                    <> colon
                    <+> (list . map (coloredToColor (pretty . Set.toList)))
                        (skUsageFlags skr)
                )
            <> linebreak
            <> indent
                4
                ( pretty "embedded cross-cert"
                    <> colon
                    <+> (coloredToColor pretty . ccPresent . skCrossCerts) skr
                )
            <> linebreak
            <> indent
                4
                ( pretty "cross-cert hash algorithms"
                    <> colon
                    <+> ( list
                            . map (coloredToColor pretty)
                            . ccHashAlgorithms
                            . skCrossCerts
                        )
                        skr
                )

jsonReport :: POSIXTime -> SomeTK -> BL.ByteString
jsonReport ps stk = A.encode (getResult (unPolicy checkKey stk (Just ps)))

yamlReport :: POSIXTime -> SomeTK -> B.ByteString
yamlReport ps stk =
    Y.encode . (: []) $ getResult (unPolicy checkKey stk (Just ps))

doLint :: LintOptions -> IO ()
doLint o = do
    cpt <- getPOSIXTime
    keys <-
        runConduitRes $
            CB.sourceHandle stdin
                .| conduitGet get
                .| conduitToSomeTKsDroppingEither
                .| conduitDropErrorsAndNothings
                .| CL.consume
    output (lintOutputFormat o) cpt keys
  where
    output Pretty cpt = mapM_ (PPA.putDoc . prettyKeyReport cpt)
    output JSON cpt =
        mapM_
            (BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt)
    output YAML cpt = mapM_ (B.putStr . yamlReport cpt)

sigissuer :: SignaturePayload -> Maybe EightOctetKeyId
getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId
hashAlgo :: SignaturePayload -> HashAlgorithm
sigissuer (SigVOther 2 _) = Nothing
sigissuer SigV3 {} = Nothing
sigissuer (SigV4 _ _ _ ys xs _ _) =
    let issuers = mapMaybe (getIssuer . _sspPayload) (ys ++ xs)
     in case nub issuers of
            [issuer] -> Just issuer
            _ -> Nothing
sigissuer (SigV6 {}) = Nothing -- v6 signatures are forbidden from carrying Issuer subpackets; see sigissuerFPs
sigissuer (SigVOther _ _) = Nothing

getIssuer (Issuer i) = Just i
getIssuer _ = Nothing

sigissuerFPs :: SignaturePayload -> [Fingerprint]
sigissuerFPs (SigV4 _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)
sigissuerFPs (SigV6 _ _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)
sigissuerFPs _ = []

getIssuerFP :: SigSubPacketPayload -> Maybe Fingerprint
getIssuerFP (IssuerFingerprint _ fp) = Just fp
getIssuerFP _ = Nothing

hashAlgo (SigV3 _ _ _ _ x _ _) = x
hashAlgo (SigV4 _ _ x _ _ _ _) = x
hashAlgo (SigV6 _ _ x _ _ _ _ _) = x
hashAlgo (SigVOther _ _) = OtherHA 0

knownWeakHashAlgorithms :: [HashAlgorithm]
knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]

isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool
isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms

isSubkeyRevocationSignature :: SignaturePayload -> Bool
isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig
isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig
isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig
isSubkeyRevocationSignature _ = False

hasheds :: SignaturePayload -> [SigSubPacket]
hasheds (SigV4 _ _ _ xs _ _ _) = xs
hasheds (SigV6 _ _ _ _ xs _ _ _) = xs
hasheds _ = []
