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
    ) where

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

-- should this fail or should verifyUnknownTKWith fail if there are no self-sigs?
processTK
    :: Maybe POSIXTime -> TKUnknown -> Either String TKUnknown
processTK mpt tk =
    first show
        $ verifyUnknownTKWith
            (verifySigWith defaultVerificationPolicy (verifyAgainstKeys [tk]))
            (fmap posixSecondsToUTCTime mpt)
            . stripOlderSigs
            . stripOtherSigs
        $ tk
  where
    stripOtherSigs tk' =
        tk'
            { _tkuUIDs = map (second alleged) (_tkuUIDs tk')
            , _tkuUAts = map (second alleged) (_tkuUAts tk')
            }
    stripOlderSigs tk' =
        tk'
            { _tkuUIDs = map (second newest) (_tkuUIDs tk')
            , _tkuUAts = map (second newest) (_tkuUAts tk')
            }
    newest = take 1 . sortOn (Down . take 1 . sigcts) -- FIXME: this is terrible
    sigcts (SigV4 _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs
    sigcts (SigV6 _ _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs
    sigcts _ = []
    pkp = tk ^. tkuKey . _1
    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) -- FIXME: what should this be if there are multiple matches?
    sigissuer (SigV6 _ _ _ _ ys xs _ _) =
        listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
    sigissuer (SigVOther _ _) = Nothing
    sigissuerfp (SigV4 _ _ _ ys xs _ _) =
        listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
    sigissuerfp (SigV6 _ _ _ _ ys xs _ _) =
        listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
    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