TKUtils.hs

-- TKUtils.hs: hOpenPGP-tools TK-related common functions
-- Copyright © 2013-2021  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.TKUtils
  ( processTK
  ) where

import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.Signatures
  ( verifyAgainstKeys
  , verifySigWith
  , verifyTKWith
  )
import Codec.Encryption.OpenPGP.Types
import Control.Arrow (second)
import Control.Error.Util (hush)
import Control.Lens ((^.), _1)
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 verifyTKWith fail if there are no self-sigs?
processTK :: Maybe POSIXTime -> TK -> Either String TK
processTK mpt key =
  verifyTKWith
    (verifySigWith (verifyAgainstKeys [key]))
    (fmap posixSecondsToUTCTime mpt) .
  stripOlderSigs .
  stripOtherSigs $
  key
  where
    stripOtherSigs tk =
      tk
        { _tkUIDs = map (second alleged) (_tkUIDs tk)
        , _tkUAts = map (second alleged) (_tkUAts tk)
        }
    stripOlderSigs tk =
      tk
        { _tkUIDs = map (second newest) (_tkUIDs tk)
        , _tkUAts = map (second newest) (_tkUAts tk)
        }
    newest = take 1 . sortOn (Down . take 1 . sigcts) -- FIXME: this is terrible
    sigcts (SigV4 _ _ _ xs _ _ _) =
      map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs
    pkp = key ^. tkKey . _1
    alleged = filter (\x -> assI x || assIFP x)
    isCT (SigSubPacket _ (SigCreationTime _)) = True
    isCT _ = False
    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 (SigVOther _ _) = error "We're in the future." -- FIXME
    sigissuerfp (SigV4 _ _ _ ys xs _ _) =
      listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
    sigissuerfp _ = Nothing
    eoki
      | pkp ^. keyVersion == V4 = hush . eightOctetKeyID $ pkp
      | pkp ^. keyVersion == DeprecatedV3 &&
          elem (pkp ^. pkalgo) [RSA, DeprecatedRSASignOnly] =
        hush . eightOctetKeyID $ pkp
      | otherwise = Nothing
    fp
      | pkp ^. keyVersion == V4 = Just . fingerprint $ pkp
      | otherwise = Nothing
    getIssuer (Issuer i) = Just i
    getIssuer _ = Nothing
    getIssuerFP (IssuerFingerprint 4 i) = Just i
    getIssuerFP _ = Nothing
    assI x = ((==) <$> sigissuer x <*> eoki) == Just True
    assIFP x = ((==) <$> sigissuerfp x <*> fp) == Just True