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.Signatures
  ( VerificationError
  , 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 key =
  first show $ verifyUnknownTKWith
    (verifySigWith (verifyAgainstKeys [key]))
    (fmap posixSecondsToUTCTime mpt) .
  stripOlderSigs .
  stripOtherSigs $
  key
  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 = key ^. 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