-- 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 LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

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

import Codec.Encryption.OpenPGP.Types
    ( SomeTK
    , SpacedFingerprint (..)
    )
import Control.Monad (void)
import Control.Monad.Trans.Writer.Lazy (execWriter, tell)
import qualified Data.Aeson as A
import Data.Binary (get)
import qualified Data.ByteString as B
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 (sequenceA_, traverse_)
import qualified Data.Map as Map
import qualified Data.Set as Set
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 Prettyprinter
    ( Doc
    , annotate
    , colon
    , flatAlt
    , indent
    , line
    , list
    , pretty
    , vsep
    , (<+>)
    )
import qualified Prettyprinter.Render.Terminal as PPA
import System.IO
    ( stdin
    )

import HOpenPGP.Tools.Hokey.Lint.Policy
    ( LintPolicy (..)
    , checkKeyAlgorithmAndSize
    , checkKeyBestOf
    , checkKeyCreationTime
    , checkKeyFingerprint
    , checkKeyHasEncryptionCapableSubkey
    , checkKeyStatus
    , checkKeySubkeys
    , checkKeyUIDsAndUAts
    , checkKeyVersion
    , mkLintContext
    )
import HOpenPGP.Tools.Hokey.Lint.Types
    ( Color (..)
    , CrossCertReport (..)
    , KAS (..)
    , KeyReport (..)
    , LintContext (..)
    , Result (..)
    , RevocationStatus (..)
    , SubkeyReport (..)
    , SubkeyRevocationDigestWarning (..)
    , UIDReport (..)
    , getResult
    )
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)

checkKey :: LintPolicy LintContext KeyReport
checkKey = LintPolicy $ \ctx ->
    let kr =
            KeyReport
                { keyStatus = unPolicy checkKeyStatus ctx
                , keyFingerprint = unPolicy checkKeyFingerprint ctx
                , keyVer = unPolicy checkKeyVersion ctx
                , keyCreationTime = unPolicy checkKeyCreationTime ctx
                , keyAlgorithmAndSize = unPolicy checkKeyAlgorithmAndSize ctx
                , keyUIDsAndUAts = unPolicy checkKeyUIDsAndUAts ctx
                , keyBestOf = unPolicy checkKeyBestOf ctx
                , keySubkeys = unPolicy checkKeySubkeys ctx
                , keyHasEncryptionCapableSubkey =
                    unPolicy checkKeyHasEncryptionCapableSubkey ctx
                }
     in kr
            <$ sequenceA_
                [ void (keyStatus kr)
                , void (keyFingerprint kr)
                , void (keyVer kr)
                , void (keyAlgorithmAndSize kr)
                , void (keyHasEncryptionCapableSubkey kr)
                , traverse_ void (getResult (keySubkeys kr))
                , traverse_ void (getResult (keyUIDsAndUAts kr))
                ]

prettyKeyReport :: POSIXTime -> SomeTK -> Doc PPA.AnsiStyle
prettyKeyReport cpt stk = do
    let keyReport = getResult (unPolicy checkKey (mkLintContext (Just cpt) stk))
    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 (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 (getResult (keyUIDsAndUAts keyReport)))
                        )
                , pretty "Checking subkeys" <> colon
                , indent
                    2
                    ( pretty "one of the subkeys is encryption-capable"
                        <> colon
                        <+> coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)
                    )
                    <> mconcat (map subkeyrep (getResult (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 (mkLintContext (Just ps) stk)))

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

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)
