TKUtils.hs

-- TKUtils.hs: hOpenPGP-tools TK-related common functions
-- 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/>.
module HOpenPGP.Tools.Common.TKUtils
    ( processTK
    , verifyTKWithTyped
    ) where

import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.Policy
    ( VerificationPolicy
    , defaultVerificationPolicy
    )
import Codec.Encryption.OpenPGP.Signatures
    ( renderVerificationError
    , verifyAgainstKeys
    , verifySigWith
    , verifyTKWith
    )
import Codec.Encryption.OpenPGP.Types
import Control.Arrow (second)
import Control.Error.Util (hush)
import Data.Bifunctor (first)
import Data.List (sortOn)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Ord (Down (..))
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)

verifyTKWithTyped
    :: VerificationPolicy
    -> [SomeTK]
    -> Maybe UTCTime
    -> SomeTK
    -> Either String SomeTK
verifyTKWithTyped policy keyring mt stk = do
    verifiedStk <- case stk of
        SomePublicTK publicTk ->
            first
                renderVerificationError
                (SomePublicTK <$> verifyTKWith vsf mt publicTk)
        SomeSecretTK secretTk ->
            first
                renderVerificationError
                (SomeSecretTK <$> verifyTKWith vsf mt secretTk)
    pure verifiedStk
  where
    vsf =
        verifySigWith
            policy
            (verifyAgainstKeys (map someTKToUnknown keyring))

processTK
    :: Maybe POSIXTime -> SomeTK -> Either String SomeTK
processTK mpt stk =
    verifyTKWithTyped
        defaultVerificationPolicy
        [stk]
        (fmap posixSecondsToUTCTime mpt)
        strippedStk
  where
    strippedStk = stripOlderSigs (stripOtherSigs stk)
    stripOtherSigs (SomePublicTK tk) = SomePublicTK (stripOtherSigsTK tk)
    stripOtherSigs (SomeSecretTK tk) = SomeSecretTK (stripOtherSigsTK tk)
    stripOlderSigs (SomePublicTK tk) = SomePublicTK (stripOlderSigsTK tk)
    stripOlderSigs (SomeSecretTK tk) = SomeSecretTK (stripOlderSigsTK tk)
    stripOtherSigsTK tk =
        tk
            { _tkUIDs = map (second alleged) (_tkUIDs tk)
            , _tkUAts = map (second alleged) (_tkUAts tk)
            }
    stripOlderSigsTK tk =
        tk
            { _tkUIDs = map (second newest) (_tkUIDs tk)
            , _tkUAts = map (second newest) (_tkUAts tk)
            }
    newest = take 1 . sortOn (Down . take 1 . sigcts)
    sigcts (SigV4 _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs
    sigcts (SigV6 _ _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs
    sigcts _ = []
    pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))
    alleged = filter (\x -> assI x || assIFP x)
    sigCreationTimeFromSubpacket (SigSubPacket _ (SigCreationTime x)) = Just x
    sigCreationTimeFromSubpacket _ = Nothing
    sigissuer (SigVOther 2 _) = Nothing
    sigissuer SigV3 {} = Nothing
    sigissuer (SigV4 _ _ _ ys xs _ _) =
        listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs)
    sigissuer (SigV6 _ _ _ _ ys xs _ _) =
        listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs)
    sigissuer _ = Nothing
    sigissuerfp (SigV4 _ _ _ ys xs _ _) =
        listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs)
    sigissuerfp (SigV6 _ _ _ _ ys xs _ _) =
        listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs)
    sigissuerfp _ = Nothing
    eoki
        | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
        | _keyVersion pkp == DeprecatedV3
            && elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
            hush . eightOctetKeyID $ pkp
        | otherwise = Nothing
    fp
        | _keyVersion pkp == V4 = Just . fingerprint $ pkp
        | otherwise = Nothing
    getIssuer (Issuer i) = Just i
    getIssuer _ = Nothing
    getIssuerFP (IssuerFingerprint IssuerFingerprintV4 i) = Just i
    getIssuerFP _ = Nothing
    assI x = ((==) <$> sigissuer x <*> eoki) == Just True
    assIFP x = ((==) <$> sigissuerfp x <*> fp) == Just True