Common.hs

-- Common.hs: hOpenPGP-tools common functions
-- Copyright © 2012-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.Common
    ( banner
    , versioner
    , warranty
    , prependAuto
    , keyMatchesFingerprint
    , keyMatchesEightOctetKeyId
    , keyMatchesExactUIDString
    , keyMatchesUIDSubString
    , keyMatchesPKPred
    -- hmm
    , pkpGetPKVersion
    , pkpGetPKAlgo
    , pkpGetKeysize
    , pkpGetTimestamp
    , pkpGetFingerprint
    , pkpGetEOKI
    , tkUsingPKP
    , pUsingPKP
    , pUsingSP
    , tkGetUIDs
    , tkGetSubs
    , anyOrAll
    , anyReader
    , oGetTag
    , oGetLength
    , spGetSigVersion
    , spGetSigType
    , spGetPKAlgo
    , spGetHashAlgo
    , spGetSCT
    , maybeR
    , renderKeyID
    , renderFingerprint
    , primaryPKP
    ) where

import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Codec.Encryption.OpenPGP.SignatureQualities (sigCT)
import Codec.Encryption.OpenPGP.Types
import Control.Error.Util (hush)
import Control.Monad.Trans.Reader
    ( Reader
    , ReaderT
    , ask
    , local
    , reader
    , runReader
    , withReader
    )
import Data.Binary (put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString.Lazy as BL
-- hmm --
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Version (showVersion)
import Options.Applicative.Builder
    ( auto
    , help
    , hidden
    , infoOption
    , long
    , short
    )
import Options.Applicative.Types (Parser, ReadM (..))
import Prettyprinter
    ( Doc
    , defaultLayoutOptions
    , hardline
    , layoutPretty
    , pretty
    , (<+>)
    )
import qualified Prettyprinter.Render.Text as PPA

import Paths_hopenpgp_tools (version)

banner :: String -> Doc ann
{-# INLINE banner #-}
banner name =
    pretty name
        <+> pretty "(hopenpgp-tools)"
        <+> pretty (showVersion version)
        <> hardline
        <> pretty "Copyright (C) 2012-2026  Clint Adams"

warranty :: String -> Doc ann
{-# INLINE warranty #-}
warranty name =
    pretty name
        <+> pretty "comes with ABSOLUTELY NO WARRANTY."
        <+> pretty
            "This is free software, and you are welcome to redistribute it"
        <+> pretty "under certain conditions."

versioner :: String -> Parser (a -> a)
{-# INLINE versioner #-}
versioner name =
    infoOption (name ++ " (hopenpgp-tools) " ++ showVersion version) $
        long "version"
            <> short 'V'
            <> help "Show version information"
            <> hidden

prependAuto :: Read a => String -> ReadM a
prependAuto s = ReadM (local (s ++) (unReadM auto))

keyMatchesFingerprint :: Bool -> SomeTK -> Fingerprint -> Bool
keyMatchesFingerprint = keyMatchesPKPred fingerprint

keyMatchesEightOctetKeyId
    :: Bool -> SomeTK -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow
keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID

keyMatchesExactUIDString :: Text -> SomeTK -> Bool
keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkUIDs . someTKToPublicViewTK

keyMatchesUIDSubString :: Text -> SomeTK -> Bool
keyMatchesUIDSubString uidstr stk =
    any (T.toLower uidstr `T.isInfixOf`)
        . map (T.toLower . fst)
        . _tkUIDs $
        someTKToPublicViewTK stk

keyMatchesPKPred
    :: Eq a => (SomePKPayload -> a) -> Bool -> SomeTK -> a -> Bool
keyMatchesPKPred p False = (==) . p . primaryPKP
keyMatchesPKPred p True = \stk v -> elem v (p (primaryPKP stk) : map p (tkGetSubs stk))

primaryPKP :: SomeTK -> SomePKPayload
primaryPKP = keyPktPKPayload . _tkPrimaryKey . someTKToPublicViewTK

-- The following should probably be moved elsewhere
tkUsingPKP :: Reader SomePKPayload a -> Reader SomeTK a
tkUsingPKP = withReader primaryPKP

pkpGetPKVersion :: SomePKPayload -> Integer
pkpGetPKVersion t =
    if _keyVersion t == DeprecatedV3
        then 3
        else 4

pkpGetPKAlgo :: SomePKPayload -> Integer
pkpGetPKAlgo = fromIntegral . fromFVal . _pkalgo

pkpGetKeysize :: SomePKPayload -> Integer
pkpGetKeysize = fromIntegral . fromMaybe 0 . hush . pubkeySize . _pubkey

pkpGetTimestamp :: SomePKPayload -> Integer
pkpGetTimestamp = fromIntegral . _timestamp

pkpGetFingerprint :: SomePKPayload -> Fingerprint
pkpGetFingerprint = fingerprint

pkpGetEOKI :: SomePKPayload -> String
pkpGetEOKI = either (const "UNKNOWN") show . eightOctetKeyID

tkGetUIDs :: SomeTK -> [Text]
tkGetUIDs = map fst . _tkUIDs . someTKToPublicViewTK

tkGetSubs :: SomeTK -> [SomePKPayload]
tkGetSubs stk = mapMaybe (grabPKP . fst) (_tkSubs (someTKToPublicViewTK stk))
  where
    grabPKP kp = Just (keyPktPKPayload kp)

anyOrAll
    :: (Monad m, Monad m1)
    => ((a1 -> c) -> a -> ReaderT a m b)
    -> (m1 a1 -> c)
    -> ReaderT a m b
anyOrAll aa op = ask >>= aa (op . return)

anyReader :: Reader a Bool -> Reader [a] Bool
anyReader p = any (runReader p) `fmap` ask

oGetTag :: Pkt -> Integer
oGetTag = fromIntegral . pktTag

oGetLength :: Pkt -> Integer
oGetLength = fromIntegral . BL.length . runPut . put -- FIXME: this should be a length that makes sense

spGetSigVersion :: Pkt -> Maybe Integer
spGetSigVersion (SignaturePkt s) = Just (sigVersion s)
  where
    sigVersion SigV3 {} = 3
    sigVersion SigV4 {} = 4
    sigVersion SigV6 {} = 6
    sigVersion (SigVOther v _) = fromIntegral v
spGetSigVersion _ = Nothing

spGetSigType :: Pkt -> Maybe Integer
spGetSigType (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigType s)
  where
    -- FIXME: deduplicate this and hOpenPGP .Internal

    sigType :: SignaturePayload -> Maybe SigType
    sigType (SigV3 st _ _ _ _ _ _) = Just st
    sigType (SigV4 st _ _ _ _ _ _) = Just st
    sigType _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild
spGetSigType _ = Nothing

spGetPKAlgo :: Pkt -> Maybe Integer
spGetPKAlgo (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigPKA s)
  where
    sigPKA (SigV3 _ _ _ pka _ _ _) = Just pka
    sigPKA (SigV4 _ pka _ _ _ _ _) = Just pka
    sigPKA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild
spGetPKAlgo _ = Nothing

spGetHashAlgo :: Pkt -> Maybe Integer
spGetHashAlgo (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigHA s)
  where
    sigHA (SigV3 _ _ _ _ ha _ _) = Just ha
    sigHA (SigV4 _ _ ha _ _ _ _) = Just ha
    sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild
spGetHashAlgo _ = Nothing

spGetSCT :: Pkt -> Maybe Integer
spGetSCT (SignaturePkt s) = fmap fromIntegral (sigCT s)
spGetSCT _ = Nothing

pUsingPKP :: Reader (Maybe SomePKPayload) a -> Reader Pkt a
pUsingPKP = withReader grabPayload
  where
    grabPayload (SecretKeyPkt p _) = Just p
    grabPayload (PublicKeyPkt p) = Just p
    grabPayload (SecretSubkeyPkt p _) = Just p
    grabPayload (PublicSubkeyPkt p) = Just p
    grabPayload _ = Nothing

pUsingSP :: Reader (Maybe SignaturePayload) a -> Reader Pkt a
pUsingSP = withReader grabPayload
  where
    grabPayload (SignaturePkt s) = Just s
    grabPayload _ = Nothing

maybeR :: a -> Reader r a -> Reader (Maybe r) a
maybeR x r = reader (maybe x (runReader r))

renderKeyID :: EightOctetKeyId -> String
renderKeyID =
    T.unpack
        . PPA.renderStrict
        . layoutPretty defaultLayoutOptions
        . pretty

renderFingerprint :: Fingerprint -> String
renderFingerprint =
    T.unpack
        . PPA.renderStrict
        . layoutPretty defaultLayoutOptions
        . pretty