Types.hs

-- Types.hs: hOpenPGP key tool lint subcommand types
-- 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 DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}

module HOpenPGP.Tools.Hokey.Lint.Types
    ( Color (..)
    , Result (..)
    , KAS (..)
    , LintContext (..)
    , KeyReport (..)
    , UIDReport (..)
    , SubkeyReport (..)
    , SubkeyRevocationDigestWarning (..)
    , CrossCertReport (..)
    , RevocationStatus (..)
    , colored
    , withColor
    , getResult
    , populateBestOf
    , best
    , bestOfRank
    , justTheUIDRs
    ) where

import Codec.Encryption.OpenPGP.Types
    ( Fingerprint
    , HashAlgorithm
    , KeyFlag
    , KeyVersion
    , PubKeyAlgorithm
    , SomePKPayload
    , SomeTK (..)
    , TK (..)
    , TKKind (..)
    , ThirtyTwoBitDuration
    , ThirtyTwoBitTimeStamp
    )
import Data.Aeson (ToJSON)
import Data.List (sortOn)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Time.Clock.POSIX (POSIXTime)
import GHC.Generics

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

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

instance ToJSON KAS

instance ToJSON Color

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

data KeyReport
    = KeyReport
    { keyStatus :: Result String
    , keyFingerprint :: Result Fingerprint
    , keyVer :: Result KeyVersion
    , keyCreationTime :: Result ThirtyTwoBitTimeStamp
    , keyAlgorithmAndSize :: Result KAS
    , keyUIDsAndUAts :: Result (Map.Map Text (Result UIDReport))
    , keyBestOf :: Result (Maybe UIDReport)
    , keySubkeys :: Result [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 ToJSON KeyReport

instance ToJSON UIDReport

instance ToJSON SubkeyReport

instance ToJSON SubkeyRevocationDigestWarning

instance ToJSON CrossCertReport

instance 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 = (<>)

data LintContext = LintContext
    { lcMpt :: Maybe POSIXTime
    , lcProcessedTK :: TK 'PublicTK
    , lcProcResult :: Either String SomeTK
    , lcPrimaryKey :: SomePKPayload
    , lcFingerprint :: Fingerprint
    }

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.Map Text (Result UIDReport) -> [UIDReport]
justTheUIDRs = map getResult . Map.elems

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