-- hkt.hs: hOpenPGP key tool
-- 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/>.
{-# LANGUAGE DeriveGeneric #-}
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.KeyInfo
( pkalgoAbbrev
, pubkeySize
)
import Codec.Encryption.OpenPGP.KeySelection
( parseEightOctetKeyId
, parseFingerprint
)
import Codec.Encryption.OpenPGP.Policy
( defaultVerificationPolicy
)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
( EightOctetKeyId
, Fingerprint
, HashAlgorithm (..)
, PublicKey (..)
, PublicKeyring
, SigSubPacket (_sspPayload)
, SigSubPacketPayload (..)
, Signature (..)
, SignaturePayload (..)
, SomePKPayload (..)
, SomeTK (..)
, TK (..)
, UserAttribute (..)
, UserId (..)
, keyPktPKPayload
, keyPktToPkt
, someTKToPublicViewTK
, someTKToUnknown
, _pkalgo
, _pubkey
)
import Control.Applicative (optional, (<|>))
import Control.Arrow ((&&&))
import Control.Exception (ErrorCall, evaluate, try)
import Control.Lens ((^..), _1)
import Control.Monad.Trans.Except (except, runExcept)
import Control.Monad.Trans.Resource (MonadResource, MonadThrow)
import qualified Data.Aeson as A
import Data.Binary (get, put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (ConduitM, runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Filter
( FilterPredicates (RFilterPredicate)
, runPredicate
)
import Data.Conduit.OpenPGP.Keyring
( conduitDropErrorsAndNothings
, conduitToSomeTKsDroppingEither
, sinkPublicKeyringMap
)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Data.Lens (biplate)
import Data.Either (rights)
import Data.Graph.Inductive.Graph
( Graph (mkGraph)
, Path
, emap
, prettyPrint
)
import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.SP (sp)
import Data.GraphViz
( GraphvizParams (..)
, graphToDot
, nonClusteredParams
)
import Data.GraphViz.Attributes (toLabel)
import Data.GraphViz.Types (printDotGraph)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.IxSet.Typed as IxSet
import Data.List (nub, sort)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TLIO
import Data.Time.Clock.POSIX
( getPOSIXTime
, posixSecondsToUTCTime
)
import Data.Tuple (swap)
import Data.Void (Void)
import qualified Data.Yaml as Y
import GHC.Generics
import Options.Applicative.Builder
( argument
, auto
, command
, footerDoc
, headerDoc
, help
, helpDoc
, info
, long
, metavar
, option
, prefs
, progDesc
, showDefault
, showHelpOnError
, str
, strOption
, switch
, value
)
import Options.Applicative.Extra
( customExecParser
, helper
, hsubparser
)
import Options.Applicative.Types (Parser)
import Prettyprinter
( defaultLayoutOptions
, fillSep
, hardline
, layoutPretty
, list
, pretty
, (<+>)
)
import Prettyprinter.Render.Text (hPutDoc, putDoc)
import qualified Prettyprinter.Render.Text as PPA
import System.Directory (getHomeDirectory)
import System.Exit (exitFailure)
import System.IO
( BufferMode (..)
, Handle
, hFlush
, hPutStrLn
, hSetBuffering
, stderr
)
import HOpenPGP.Tools.Common.Common
( banner
, keyMatchesEightOctetKeyId
, keyMatchesFingerprint
, keyMatchesUIDSubString
, versioner
, warranty
)
import HOpenPGP.Tools.Common.Parser (parseTKExp)
import HOpenPGP.Tools.Common.TKUtils (verifyTKWithTyped)
grabMatchingKeysConduit
:: (MonadResource m, MonadThrow m)
=> FilePath
-> Bool
-> FilterPredicates Void SomeTK
-> Text
-> ConduitM () SomeTK m ()
grabMatchingKeysConduit fp filt ufp srch =
CB.sourceFile fp
.| conduitGet get
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| ( if filt
then CL.filter (runPredicate ufp)
else CL.filter matchAny
)
where
matchAny tk =
either (const False) id $
runExcept $
fmap (keyMatchesFingerprint True tk) efp
<|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok
<|> return (keyMatchesUIDSubString srch tk)
efp = (except . parseFingerprint) srch
eeok = (except . parseEightOctetKeyId) srch
grabMatchingKeys :: FilePath -> Bool -> Text -> IO [SomeTK]
grabMatchingKeys fp filt srch =
if filt
then do
parsed <- parseFilterPredicateIO srch
case parsed of
Left err -> dieHKT err
Right ufp ->
runConduitRes $
grabMatchingKeysConduit fp filt ufp srch .| CL.consume
else
-- When not using filter syntax, treat TARGET as a fingerprint, key ID or UID substring
runConduitRes $
CB.sourceFile fp
.| conduitGet get
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| CL.filter matchAny
.| CL.consume
where
matchAny tk =
either (const False) id $
runExcept $
fmap (keyMatchesFingerprint True tk) efp
<|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok
<|> return (keyMatchesUIDSubString srch tk)
efp = (except . parseFingerprint) srch
eeok = (except . parseEightOctetKeyId) srch
grabMatchingPublicKeyring :: [SomeTK] -> IO PublicKeyring
grabMatchingPublicKeyring keys =
runConduitRes $
CL.sourceList (mapMaybe someTKToPublicTk keys)
.| sinkPublicKeyringMap
where
someTKToPublicTk (SomePublicTK publicTk) = Just publicTk
someTKToPublicTk (SomeSecretTK secretTk) = Just (someTKToPublicViewTK (SomeSecretTK secretTk))
data Key
= Key
{ keysize :: Maybe Int
, keyalgo :: String
, keyalgoabbreviation :: String
, fpr :: String
}
deriving (Generic)
data TKey
= TKey
{ publickey :: Key
, uids :: [Text]
, subkeys :: [Key]
}
deriving (Generic)
instance A.ToJSON Key
instance A.ToJSON TKey
tkToTKey :: SomeTK -> TKey
tkToTKey stk =
TKey
{ publickey = mkey (keyPktPKPayload (_tkPrimaryKey publicView))
, uids = _tkUIDs publicView ^.. traverse . _1
, subkeys =
mapMaybe
(\kp -> Just (mkey (keyPktPKPayload kp)))
(map fst (_tkSubs publicView))
}
where
publicView = someTKToPublicViewTK stk
mkey =
Key
<$> either (const Nothing) Just . pubkeySize . _pubkey
<*> show
. _pkalgo
<*> pkalgoAbbrev
. _pkalgo
<*> renderFingerprint
. fingerprint
showTKey :: TKey -> IO ()
showTKey tkey =
putDoc $
pretty "pub "
<+> sizeabbrevkeyid (publickey tkey)
<> hardline
<> mconcat
( map
( \x ->
pretty "uid "
<+> pretty (T.unpack x)
<> hardline
)
(uids tkey)
)
<> mconcat
( map
(\x -> pretty "sub " <+> sizeabbrevkeyid x <> hardline)
(subkeys tkey)
)
<> hardline
where
sizeabbrevkeyid k =
pretty (maybe "unknown" show (keysize k))
<> pretty (keyalgoabbreviation k)
<> pretty "/"
<> pretty (fpr k)
renderFingerprint :: Fingerprint -> String
renderFingerprint =
T.unpack
. PPA.renderStrict
. layoutPretty defaultLayoutOptions
. pretty
data Options
= Options
{ keyring :: String
, graphOutputFormat :: GraphOutputFormat
, pathsOutputFormat :: PathsOutputFormat
, targetIsFilter :: Bool
, target1 :: String
, target2 :: String
, target3 :: String
}
data Command
= CmdList Options
| CmdExportPubkeys Options
| CmdGraph Options
| CmdFindPaths Options
data GraphOutputFormat
= GraphViz
| LossyPretty
deriving (Bounded, Enum, Eq, Read, Show)
data PathsOutputFormat
= Unstructured
| JSON
| YAML
deriving (Eq, Read, Show)
listO :: String -> Parser Options
listO _ =
Options
<$> strOption
( long "keyring"
<> metavar "FILE"
<> help "file containing keyring"
)
<*> pure GraphViz -- unused
<*> option
auto
( long "output-format"
<> metavar "FORMAT"
<> value Unstructured
<> showDefault
<> help "output format"
)
<*> switch (long "filter" <> help "treat target as filter")
<*> ( fromMaybe ""
<$> optional (argument str (metavar "TARGET" <> targetHelp))
)
<*> pure ""
<*> pure ""
where
targetHelp =
helpDoc . Just $ pretty "target (which keys to output)*"
graphO :: String -> Parser Options
graphO _homedir =
Options
<$> strOption
( long "keyring"
<> metavar "FILE"
<> help "file containing keyring"
)
<*> option
auto
( long "output-format"
<> metavar "FORMAT"
<> value GraphViz
<> showDefault
<> ofhelp
)
<*> pure Unstructured -- unused
<*> switch (long "filter" <> help "treat target as filter")
<*> ( fromMaybe ""
<$> optional (argument str (metavar "TARGET" <> targetHelp))
)
<*> pure ""
<*> pure ""
where
ofhelp =
helpDoc . Just $
pretty "output format"
<> hardline
<> list (map (pretty . show) ofchoices)
ofchoices = [minBound .. maxBound] :: [GraphOutputFormat]
targetHelp =
helpDoc . Just $ pretty "target (which keys to graph)*"
findPathsO :: String -> Parser Options
findPathsO _homedir =
Options
<$> strOption
( long "keyring"
<> metavar "FILE"
<> help "file containing keyring"
)
<*> pure GraphViz -- unused
<*> option
auto
( long "output-format"
<> metavar "FORMAT"
<> value Unstructured
<> showDefault
<> help "output format"
)
<*> switch (long "filter" <> help "treat targets as filter")
<*> argument str (metavar "TARGET-SET" <> targetHelp)
<*> argument str (metavar "FROM-KEYS" <> fromHelp)
<*> argument str (metavar "TO-KEYS" <> toHelp)
where
targetHelp =
helpDoc . Just $
pretty "target (which keys to use in pathfinding)*"
fromHelp =
helpDoc . Just $
pretty "from (which keys to use for the source of paths)*"
toHelp =
helpDoc . Just $
pretty "to (which keys to use for the destinations of paths)*"
dispatch :: Command -> IO ()
dispatch (CmdList o) = banner' stderr >> hFlush stderr >> doList o
dispatch (CmdExportPubkeys o) =
banner' stderr >> hFlush stderr >> doExportPubkeys o
dispatch (CmdGraph o) = banner' stderr >> hFlush stderr >> doGraph o
dispatch (CmdFindPaths o) = banner' stderr >> hFlush stderr >> doFindPaths o
main :: IO ()
main = do
hSetBuffering stderr LineBuffering
homedir <- getHomeDirectory
customExecParser
(prefs showHelpOnError)
( info
(helper <*> versioner "hkt" <*> cmd homedir)
( headerDoc (Just (banner "hkt"))
<> progDesc "hOpenPGP Keyring Tool"
<> footerDoc (Just (warranty "hkt"))
)
)
>>= dispatch
cmd :: String -> Parser Command
cmd homedir =
hsubparser
( command
"export-pubkeys"
( info
(CmdExportPubkeys <$> listO homedir)
( progDesc "export matching keys to stdout"
<> footerDoc (Just foot)
)
)
<> command
"findpaths"
( info
(CmdFindPaths <$> findPathsO homedir)
(progDesc "find short paths between keys" <> footerDoc (Just foot))
)
<> command
"graph"
( info
(CmdGraph <$> graphO homedir)
(progDesc "graph certifications" <> footerDoc (Just foot))
)
<> command
"list"
( info
(CmdList <$> listO homedir)
(progDesc "list matching keys" <> footerDoc (Just foot))
)
)
where
foot =
hardline
<> fillSep
[ pretty "*if --filter is not specified, this must be"
, pretty "a fingerprint,"
, pretty "an eight-octet key ID,"
, pretty "or a substring of a UID (including an empty string)"
]
<> hardline
<> fillSep
[ pretty "if --filter is specified, it must be"
, pretty "something in filter syntax (see source)."
]
banner' :: Handle -> IO ()
banner' h =
hPutDoc
h
(banner "hkt" <> hardline <> warranty "hkt" <> hardline)
doList :: Options -> IO ()
doList o = do
let ttarget1 = T.pack . target1
keys' <-
grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
let keys = map tkToTKey keys'
case pathsOutputFormat o of
Unstructured -> mapM_ showTKey keys
JSON -> BL.putStr . A.encode $ keys
YAML -> B.putStr . Y.encode $ keys
putStrLn ""
doExportPubkeys :: Options -> IO ()
doExportPubkeys o = do
let ttarget1 = T.pack . target1
keys <-
grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
case pathsOutputFormat o of
Unstructured -> mapM_ (BL.putStr . putTK') keys
JSON -> BL.putStr . A.encode $ map someTKToUnknown keys
YAML -> B.putStr . Y.encode $ map someTKToUnknown keys
where
putTK' tk =
runPut $ do
put (PublicKey (keyPktPKPayload (_tkPrimaryKey publicView)))
mapM_ (put . Signature) (_tkRevs publicView)
mapM_ putUid' (_tkUIDs publicView)
mapM_ putUat' (_tkUAts publicView)
mapM_
putSub'
(map (\(kp, sigs) -> (keyPktToPkt kp, sigs)) (_tkSubs publicView))
where
publicView = someTKToPublicViewTK tk
putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps
putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps
putSub' (p, sps) = put p >> mapM_ (put . Signature) sps
doGraph :: Options -> IO ()
doGraph o = do
let ttarget1 = T.pack . target1
cpt <- getPOSIXTime
keys <-
grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
kr <- grabMatchingPublicKeyring keys
let g =
buildKeyGraph
( (buildMaps &&& id)
( rights
( map
( verifyTKWithTyped
defaultVerificationPolicy
(map SomePublicTK (IxSet.toList kr))
(Just (posixSecondsToUTCTime cpt))
)
keys
)
)
)
case g of
Left err -> dieHKT err
Right graph ->
case graphOutputFormat o of
LossyPretty -> prettyPrint graph
GraphViz ->
TLIO.putStrLn
. printDotGraph
. graphToDot nonClusteredLabeledNodesParams
$ graph
where
nonClusteredLabeledNodesParams =
nonClusteredParams
{ fmtNode = \(_, l) -> [toLabel $ renderFingerprint l]
}
buildMaps :: [SomeTK] -> (KeyMaps, Int)
buildMaps =
foldr
mapsInsertions
(KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0)
-- FIXME: this presumes no keyID collisions in the input
data KeyMaps
= KeyMaps
{ _k2f :: HashMap EightOctetKeyId Fingerprint
, _f2i :: HashMap Fingerprint Int
, _i2f :: HashMap Int Fingerprint
}
mapsInsertions :: SomeTK -> (KeyMaps, Int) -> (KeyMaps, Int)
mapsInsertions stk (KeyMaps k2f f2i i2f, i) =
let publicView = someTKToPublicViewTK stk
fp = fingerprint (keyPktPKPayload (_tkPrimaryKey publicView))
keyids =
rights . map eightOctetKeyID $
(someTKToUnknown stk ^.. biplate :: [SomePKPayload])
i' = i + 1
k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids
f2i' = HashMap.insert fp i' f2i
i2f' = HashMap.insert i' fp i2f
in (KeyMaps k2f' f2i' i2f', i')
buildKeyGraph
:: ((KeyMaps, Int), [SomeTK])
-> Either String (Gr Fingerprint HashAlgorithm)
buildKeyGraph ((KeyMaps k2f f2i _, _), ks) = do
edges <- fmap concat (mapM tkToEdges ks)
pure
(mkGraph nodes (filter (not . samesies) . nub . sort $ edges))
where
nodes = map swap . HashMap.toList $ f2i
tkToEdges tk = do
let publicView = someTKToPublicViewTK tk
target <-
lookupNode
(fingerprint (keyPktPKPayload (_tkPrimaryKey publicView)))
mapM
(edgeFor target)
(mapMaybe (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk))
edgeFor target (ha, i) = do
source <- lookupSource i
pure (source, target, ha)
lookupSource i =
case HashMap.lookup i k2f >>= flip HashMap.lookup f2i of
Just source -> Right source
Nothing ->
Left
("hkt: no source node for signature issuer key ID " ++ show i)
lookupNode fp =
case HashMap.lookup fp f2i of
Just node -> Right node
Nothing ->
Left
("hkt: no graph node for fingerprint " ++ renderFingerprint fp)
fakejoin (x, y) = fmap ((,) x) y
sigs tk =
someTKToUnknown tk ^.. biplate :: [SignaturePayload]
samesies (x, y, _) = x == y
data PaF
= PaF
{ certPaths :: [Path]
, keyFingerprints :: Map String Fingerprint
}
deriving (Generic)
instance A.ToJSON PaF
doFindPaths :: Options -> IO ()
doFindPaths o = do
let ttarget1 = T.pack . target1
ttarget2 = T.pack . target2
ttarget3 = T.pack . target3
filt = targetIsFilter o
cpt <- getPOSIXTime
keys <-
grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
kr <- grabMatchingPublicKeyring keys
-- FIXME: seriously clean this up
filter2 <-
parseFilterPredicateIO (ttarget2 o) >>= either dieHKT pure
filter3 <-
parseFilterPredicateIO (ttarget3 o) >>= either dieHKT pure
keys1 <-
runConduitRes $
CL.sourceList keys
.| ( if filt
then CL.filter (runPredicate filter2)
else CL.filter (matchAny (ttarget2 o))
)
.| CL.consume
keys2 <-
runConduitRes $
CL.sourceList keys
.| ( if filt
then CL.filter (runPredicate filter3)
else CL.filter (matchAny (ttarget3 o))
)
.| CL.consume
let ((KeyMaps k2f f2i i2f, i), ks) =
(buildMaps &&& id)
( rights
( map
( verifyTKWithTyped
defaultVerificationPolicy
(map SomePublicTK (IxSet.toList kr))
(Just (posixSecondsToUTCTime cpt))
)
keys
)
)
keygraph <-
either dieHKT pure (buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks))
let keysToIs =
mapMaybe
( \x ->
HashMap.lookup
( fingerprint
(keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK x)))
)
f2i
)
froms = keysToIs keys1
tos = keysToIs keys2
combos = froms >>= \f -> tos >>= \t -> return (f, t)
paths =
map
( \(x, y) ->
fromMaybe [] (sp x y (emap (const (1.0 :: Double)) keygraph))
)
combos
paf =
PaF
paths
( Map.fromList
( mapMaybe
(\x -> HashMap.lookup x i2f >>= \y -> return (show x, y))
(nub (sort (concat paths)))
)
)
case pathsOutputFormat o of
Unstructured ->
-- FIXME: do something about this
do
putStrLn . unlines $ map (show . ((,) =<< length)) paths
putStrLn . unlines $
map
( \x ->
maybe (show x) renderFingerprint (HashMap.lookup x i2f)
)
(nub (sort (concat paths)))
JSON -> BL.putStr . A.encode $ paf
YAML -> B.putStr . Y.encode $ paf
putStrLn ""
where
matchAny srch tk =
either (const False) id $
runExcept $
fmap
(keyMatchesFingerprint True tk)
((except . parseFingerprint) srch)
<|> fmap
(keyMatchesEightOctetKeyId True tk . Right)
((except . parseEightOctetKeyId) srch)
<|> return (keyMatchesUIDSubString srch tk)
parseFilterPredicateIO
:: Text -> IO (Either String (FilterPredicates Void SomeTK))
parseFilterPredicateIO e = do
parsed <-
try (evaluate (RFilterPredicate <$> parseTKExp (T.unpack e)))
:: IO
( Either
ErrorCall
(Either String (FilterPredicates Void SomeTK))
)
pure $
case parsed of
Left err -> Left (show err)
Right result -> result
dieHKT :: String -> IO a
dieHKT msg = hPutStrLn stderr msg >> exitFailure
-- FIXME: deduplicate the following code
sigissuer :: SignaturePayload -> Maybe EightOctetKeyId
getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId
hashAlgo :: SignaturePayload -> HashAlgorithm
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
getIssuer (Issuer i) = Just i
getIssuer _ = Nothing
hashAlgo (SigV3 _ _ _ _ x _ _) = x
hashAlgo (SigV4 _ _ x _ _ _ _) = x
hashAlgo (SigV6 _ _ x _ _ _ _ _) = x
hashAlgo (SigVOther _ _) = OtherHA 0