TKUtils.hs

-- TKUtils.hs: hOpenPGP-tools TK-related common functions
-- Copyright © 2013-2018  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)
import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys)
import Codec.Encryption.OpenPGP.Types
import Control.Error.Util (hush)
import Control.Arrow (second)
import Control.Lens ((^.), _1)
import Data.List (sortBy)
import Data.Maybe (mapMaybe, listToMaybe)
import Data.Ord (comparing, Down(..))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, POSIXTime)

-- 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 . sortBy (comparing (Down . take 1 . sigcts)) -- FIXME: this is terrible
        sigcts (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs
        alleged = filter (\x -> ((==) <$> sigissuer x <*> eoki (key^.tkKey._1)) == Just True)
        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
        eoki pkp
            | pkp^.keyVersion == V4 = hush . eightOctetKeyID $ pkp
            | pkp^.keyVersion == DeprecatedV3 && elem (pkp^.pkalgo) [RSA,DeprecatedRSASignOnly] = hush . eightOctetKeyID $ pkp
            | otherwise = Nothing
        getIssuer (Issuer i) = Just i
        getIssuer _ = Nothing