diff --git a/HOpenPGP/Tools/Armor.hs b/HOpenPGP/Tools/Armor.hs
deleted file mode 100644
--- a/HOpenPGP/Tools/Armor.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
--- Armor.hs: hOpenPGP-tools common ASCII de-Armor function
--- Copyright © 2012-2023 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 .
-module HOpenPGP.Tools.Armor
- ( doDeArmor
- ) where
-
-import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
-import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..))
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as BL
-import Data.Conduit ((.|), runConduitRes)
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.List as CL
-import System.IO (hPutStrLn, stderr, stdin)
-
-doDeArmor :: IO ()
-doDeArmor = do
- a <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
- case AA.decode (B.concat a) of
- Left e -> hPutStrLn stderr $ "Failure to decode ASCII Armor:" ++ e
- Right msgs -> BL.putStr $ BL.concat (map (\(Armor _ _ bs) -> bs) msgs)
diff --git a/HOpenPGP/Tools/Common.hs b/HOpenPGP/Tools/Common.hs
deleted file mode 100644
--- a/HOpenPGP/Tools/Common.hs
+++ /dev/null
@@ -1,230 +0,0 @@
--- 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 .
-
-module HOpenPGP.Tools.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
- ) where
-
-import Data.Version (showVersion)
-import Paths_hopenpgp_tools (version)
-
-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
-import Codec.Encryption.OpenPGP.SignatureQualities (sigCT)
-import Codec.Encryption.OpenPGP.Types
-import Control.Lens ((^..))
-import Data.Binary (put)
-import Data.Binary.Put (runPut)
-import qualified Data.ByteString.Lazy as BL
-import Data.Data.Lens (biplate)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Options.Applicative.Builder (auto, help, hidden, infoOption, long, short)
-import Options.Applicative.Types (Parser, ReadM(..))
-import Prettyprinter (Doc, (<+>), hardline, pretty)
-
-import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
-import Control.Error.Util (hush)
-import Control.Monad.Trans.Reader
- ( Reader
- , ReaderT
- , ask
- , local
- , reader
- , runReader
- , withReader
- )
--- hmm --
-import Data.Maybe (fromMaybe, mapMaybe)
-
-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 -> TKUnknown -> Fingerprint -> Bool
-keyMatchesFingerprint = keyMatchesPKPred fingerprint
-
-keyMatchesEightOctetKeyId :: Bool -> TKUnknown -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow
-keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID
-
-keyMatchesExactUIDString :: Text -> TKUnknown -> Bool
-keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkuUIDs
-
-keyMatchesUIDSubString :: Text -> TKUnknown -> Bool
-keyMatchesUIDSubString uidstr =
- any (T.toLower uidstr `T.isInfixOf`) . map (T.toLower . fst) . _tkuUIDs
-
-keyMatchesPKPred :: Eq a => (SomePKPayload -> a) -> Bool -> TKUnknown -> a -> Bool
-keyMatchesPKPred p False = (==) . p . fst . _tkuKey
-keyMatchesPKPred p True = \tk v -> elem v (map p (tk ^.. biplate))
-
--- The following should probably be moved elsewhere
-tkUsingPKP :: Reader SomePKPayload a -> Reader TKUnknown a
-tkUsingPKP = withReader (fst . _tkuKey)
-
-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 :: TKUnknown -> [Text]
-tkGetUIDs = map fst . _tkuUIDs
-
-tkGetSubs :: TKUnknown -> [SomePKPayload]
-tkGetSubs = mapMaybe (grabPKP . fst) . _tkuSubs
- where
- grabPKP (PublicSubkeyPkt p) = Just p
- grabPKP (SecretSubkeyPkt p _) = Just p
- grabPKP _ = Nothing
-
-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 (SigVOther v _) = fromIntegral v
-spGetSigVersion _ = Nothing
-
-spGetSigType :: Pkt -> Maybe Integer
-spGetSigType (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigType s)
- -- FIXME: deduplicate this and hOpenPGP .Internal
- where
- 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)
-
-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))
diff --git a/HOpenPGP/Tools/Common/Armor.hs b/HOpenPGP/Tools/Common/Armor.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Common/Armor.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- Armor.hs: hOpenPGP-tools common ASCII de-Armor function
+-- 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 .
+
+module HOpenPGP.Tools.Common.Armor
+ ( doDeArmor
+ ) where
+
+import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
+import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..))
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import Data.Conduit ((.|), runConduitRes)
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.List as CL
+import System.IO (hPutStrLn, stderr, stdin)
+
+doDeArmor :: IO ()
+doDeArmor = do
+ a <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
+ case AA.decode (B.concat a) of
+ Left e -> hPutStrLn stderr $ "Failure to decode ASCII Armor:" ++ e
+ Right msgs -> BL.putStr $ BL.concat [ bs | Armor _ _ bs <- msgs ]
diff --git a/HOpenPGP/Tools/Common/Common.hs b/HOpenPGP/Tools/Common/Common.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Common/Common.hs
@@ -0,0 +1,242 @@
+-- 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 .
+
+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
+ ) where
+
+import Data.Version (showVersion)
+import Paths_hopenpgp_tools (version)
+
+import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
+import Codec.Encryption.OpenPGP.SignatureQualities (sigCT)
+import Codec.Encryption.OpenPGP.Types
+import Control.Lens ((^..))
+import Data.Binary (put)
+import Data.Binary.Put (runPut)
+import qualified Data.ByteString.Lazy as BL
+import Data.Data.Lens (biplate)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Options.Applicative.Builder (auto, help, hidden, infoOption, long, short)
+import Options.Applicative.Types (Parser, ReadM(..))
+import Prettyprinter (Doc, (<+>), hardline, pretty, defaultLayoutOptions, layoutPretty)
+import qualified Prettyprinter.Render.Text as PPA
+import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
+import Control.Error.Util (hush)
+import Control.Monad.Trans.Reader
+ ( Reader
+ , ReaderT
+ , ask
+ , local
+ , reader
+ , runReader
+ , withReader
+ )
+-- hmm --
+import Data.Maybe (fromMaybe, mapMaybe)
+
+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 -> TKUnknown -> Fingerprint -> Bool
+keyMatchesFingerprint = keyMatchesPKPred fingerprint
+
+keyMatchesEightOctetKeyId :: Bool -> TKUnknown -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow
+keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID
+
+keyMatchesExactUIDString :: Text -> TKUnknown -> Bool
+keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkuUIDs
+
+keyMatchesUIDSubString :: Text -> TKUnknown -> Bool
+keyMatchesUIDSubString uidstr =
+ any (T.toLower uidstr `T.isInfixOf`) . map (T.toLower . fst) . _tkuUIDs
+
+keyMatchesPKPred :: Eq a => (SomePKPayload -> a) -> Bool -> TKUnknown -> a -> Bool
+keyMatchesPKPred p False = (==) . p . fst . _tkuKey
+keyMatchesPKPred p True = \tk v -> elem v (map p (tk ^.. biplate))
+
+-- The following should probably be moved elsewhere
+tkUsingPKP :: Reader SomePKPayload a -> Reader TKUnknown a
+tkUsingPKP = withReader (fst . _tkuKey)
+
+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 :: TKUnknown -> [Text]
+tkGetUIDs = map fst . _tkuUIDs
+
+tkGetSubs :: TKUnknown -> [SomePKPayload]
+tkGetSubs = mapMaybe (grabPKP . fst) . _tkuSubs
+ where
+ grabPKP (PublicSubkeyPkt p) = Just p
+ grabPKP (SecretSubkeyPkt p _) = Just p
+ grabPKP _ = Nothing
+
+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)
+ -- FIXME: deduplicate this and hOpenPGP .Internal
+ where
+ 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
diff --git a/HOpenPGP/Tools/Common/HKP.hs b/HOpenPGP/Tools/Common/HKP.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Common/HKP.hs
@@ -0,0 +1,126 @@
+-- HKP.hs: hOpenPGP key tool
+-- Copyright © 2016-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 .
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module HOpenPGP.Tools.Common.HKP
+ ( fetchKeys
+ , FetchValidationMethod(..)
+ , rearmorKeys
+ ) where
+
+import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
+import Codec.Encryption.OpenPGP.ASCIIArmor.Types
+ ( Armor(Armor)
+ , ArmorType(ArmorPublicKeyBlock)
+ )
+import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
+import Codec.Encryption.OpenPGP.Types
+ ( Block(..)
+ , TKUnknown(..)
+ , Fingerprint
+ )
+import Control.Applicative (liftA2)
+import Control.Arrow ((&&&))
+import Control.Lens ((^..))
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (ExceptT(..), throwE)
+import Data.Binary (get, put)
+import Data.Binary.Put (runPut)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC8
+import qualified Data.ByteString.Lazy as BL
+import Data.Conduit ((.|), runConduitRes)
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.List as CL
+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
+import Data.Conduit.Serialization.Binary (conduitGet)
+import Data.Data.Lens (biplate)
+import Data.Either (rights)
+import Data.Monoid ((<>), mempty)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import HOpenPGP.Tools.Common.TKUtils (processTK)
+import Network.HTTP.Client
+ ( Response(..)
+ , httpLbs
+ , newManager
+ , parseUrlThrow
+ , setQueryString
+ )
+import Network.HTTP.Client.TLS (tlsManagerSettings)
+import Network.HTTP.Types.Status (ok200)
+import Prettyprinter (pretty)
+
+data FetchValidationMethod
+ = MatchPrimaryKeyFingerprint
+ | MatchPrimaryOrAnySubkeyFingerprint
+ | AnySelfSigned
+ deriving (Bounded, Enum, Eq, Read, Show)
+
+fetchKeys ::
+ String
+ -> FetchValidationMethod
+ -> Fingerprint
+ -> ExceptT String IO [TKUnknown]
+fetchKeys ks fvm q = do
+ manager <- liftIO $ newManager tlsManagerSettings
+ request <- liftIO $ parseUrlThrow (ks <> basereq)
+ let newreq = setQueryString (newqs q) request
+ response <- liftIO $ httpLbs newreq manager
+ processedKeys <-
+ if responseStatus response == ok200
+ then validateKeys (responseBody response)
+ else throwE ("HTTP status: " ++ show (responseStatus response))
+ return $ map fst $ filter (fvp fvm . fst . _tkuKey . snd) processedKeys
+ where
+ fvp MatchPrimaryKeyFingerprint k = fingerprint k == q
+ fvp MatchPrimaryOrAnySubkeyFingerprint k =
+ any (\k -> fingerprint k == q) (k ^.. biplate)
+ fvp AnySelfSigned k = True
+ basereq = "/pks/lookup"
+ newqs q =
+ [ ("op", Just "get")
+ , ("options", Just "mr")
+ , ("exact", Just "on")
+ , ("search", Just (BC8.pack ("0x" <> show (pretty q)))) -- FIXME: butter
+ ]
+
+validateKeys :: BL.ByteString -> ExceptT String IO [(TKUnknown, TKUnknown)] -- FIXME: conduit fail
+validateKeys larmors = do
+ bytestrings <-
+ ExceptT $ return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
+ keys <-
+ liftIO . runConduitRes $
+ CB.sourceLbs bytestrings .| conduitGet get .| conduitToTKsDropping .|
+ CL.consume
+ cpt <- liftIO getPOSIXTime
+ return . rights $
+ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
+ where
+ armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs
+ armorToBS _ = mempty
+
+rearmorKeys :: [TKUnknown] -> B.ByteString
+rearmorKeys keys =
+ if null keys
+ then mempty
+ else AA.encode .
+ return .
+ Armor ArmorPublicKeyBlock [("Comment", "filtered by hokey")] .
+ runPut . put . Block $
+ keys
diff --git a/HOpenPGP/Tools/Common/Lexer.x b/HOpenPGP/Tools/Common/Lexer.x
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Common/Lexer.x
@@ -0,0 +1,175 @@
+{
+{-# OPTIONS -w #-}
+module HOpenPGP.Tools.Common.Lexer
+( alexEOF
+, alexSetInput
+, alexGetInput
+, alexError
+, alexScan
+, ignorePendingBytes
+, alexGetStartCode
+, runAlex
+, Alex(..)
+, Token(..)
+, AlexReturn(..)
+, AlexPosn(..)
+) where
+
+import Prelude hiding (lex)
+import Numeric (readHex)
+import Codec.Encryption.OpenPGP.Types (Fingerprint(..), EightOctetKeyId(..))
+
+}
+
+%wrapper "monad"
+
+$digit = 0-9
+$hexdigit = [0-9A-Fa-f]
+
+tokens :-
+ $white+ ;
+ a { lex' TokenA }
+ and { lex' TokenAnd }
+ any { lex' TokenAny }
+ every { lex' TokenEvery }
+ not { lex' TokenNot }
+ now { lex' TokenNow }
+ one { lex' TokenOne }
+ or { lex' TokenOr }
+ subkey { lex' TokenSubkey }
+ tag { lex' TokenTag }
+ of { lex' TokenOf }
+ \=\= { lex' TokenEq }
+ \= { lex' TokenEq }
+ equals { lex' TokenEq }
+ \< { lex' TokenLt }
+ \> { lex' TokenGt }
+ \( { lex' TokenLParen }
+ \) { lex' TokenRParen }
+ contains { lex' TokenContains }
+ pkversion { lex' TokenPKVersion }
+ sigversion { lex' TokenSigVersion }
+ [Ss]ig[Tt]ype { lex' TokenSigType }
+ [Pp][Kk][Aa]lgo { lex' TokenPKAlgo }
+ [Ss]ig[Pp][Kk][Aa]lgo { lex' TokenSigPKAlgo }
+ [Hh]ash[Aa]lgo { lex' TokenHashAlgo }
+ [Rr][Ss][Aa] { lex' TokenRSA }
+ [Dd][Ss][Aa] { lex' TokenDSA }
+ [Ee]l[Gg]amal { lex' TokenElgamal }
+ [Ee][Cc][Dd][Ss][Aa] { lex' TokenECDSA }
+ [Ee][Cc][Dd][Hh] { lex' TokenECDH }
+ [Dd][Hh] { lex' TokenDH }
+ [Bb]inary { lex' TokenBinary }
+ [Cc]anonical[Tt]ext { lex' TokenCanonicalText }
+ [Ss]tandalone { lex' TokenStandalone }
+ [Gg]eneric[Cc]ert { lex' TokenGenericCert }
+ [Pp]ersona[Cc]ert { lex' TokenPersonaCert }
+ [Cc]asual[Cc]ert { lex' TokenCasualCert }
+ [Pp]ositive[Cc]ert { lex' TokenPositiveCert }
+ [Ss]ubkey[Bb]inding[Ss]ig { lex' TokenSubkeyBindingSig }
+ [Pp]rimary[Kk]ey[Bb]inding[Ss]ig { lex' TokenPrimaryKeyBindingSig }
+ [Ss]ignature[Dd]irectly[Oo]n[Aa][Kk]ey { lex' TokenSignatureDirectlyOnAKey }
+ [Kk]ey[Rr]evocation[Ss]ig { lex' TokenKeyRevocationSig }
+ [Ss]ubkey[Rr]evocation[Ss]ig { lex' TokenSubkeyRevocationSig }
+ [Cc]ert[Rr]evocation[Ss]ig { lex' TokenCertRevocationSig }
+ [Tt]imestamp[Ss]ig { lex' TokenTimestampSig }
+ [Mm][Dd]5 { lex' TokenMD5 }
+ [Ss][Hh][Aa]1 { lex' TokenSHA1 }
+ [Rr][Ii][Pp][Ee][Mm][Dd]160 { lex' TokenRIPEMD160 }
+ [Ss][Hh][Aa]256 { lex' TokenSHA256 }
+ [Ss][Hh][Aa]384 { lex' TokenSHA384 }
+ [Ss][Hh][Aa]512 { lex' TokenSHA512 }
+ [Ss][Hh][Aa]224 { lex' TokenSHA224 }
+ [Uu][Ii][Dd]s { lex' TokenUids }
+ keysize { lex' TokenKeysize }
+ length { lex' TokenLength }
+ timestamp { lex' TokenTimestamp }
+ fingerprint { lex' TokenFingerprint }
+ keyid { lex' TokenKeyID }
+ [Ss]ig[Cc]reation[Tt]ime { lex' TokenSigCreationTime }
+ $hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{4} { lex (TokenFpr . read) }
+ 0x$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{4} { lex (TokenFpr . read . drop 2) }
+ $hexdigit{8}$hexdigit{8} { lex (TokenLongID . Right . read) }
+ 0x$hexdigit{8}$hexdigit{8} { lex (TokenLongID . Right . read . drop 2) }
+ $digit+ { lex (TokenInt . fromIntegral . read) }
+ $hexdigit+ { lex (TokenInt . fromIntegral . fst . head . readHex) }
+ 0x$hexdigit+ { lex (TokenInt . fromIntegral . fst . head . readHex . drop 2) }
+ \".*\" { lex (TokenStr . ((zipWith const . drop 1) <*> (drop 2))) }
+
+{
+data Token
+ = TokenTag
+ | TokenAfter
+ | TokenAnd
+ | TokenAny
+ | TokenBefore
+ | TokenNot
+ | TokenNow
+ | TokenOr
+ | TokenInt Integer
+ | TokenEq
+ | TokenLt
+ | TokenGt
+ | TokenLParen
+ | TokenRParen
+ | TokenEOF
+ | TokenPKVersion
+ | TokenSigVersion
+ | TokenSigType
+ | TokenPKAlgo
+ | TokenSigPKAlgo
+ | TokenHashAlgo
+ | TokenRSA
+ | TokenDSA
+ | TokenElgamal
+ | TokenECDSA
+ | TokenECDH
+ | TokenDH
+ | TokenBinary
+ | TokenCanonicalText
+ | TokenStandalone
+ | TokenGenericCert
+ | TokenPersonaCert
+ | TokenCasualCert
+ | TokenPositiveCert
+ | TokenSubkeyBindingSig
+ | TokenPrimaryKeyBindingSig
+ | TokenSignatureDirectlyOnAKey
+ | TokenKeyRevocationSig
+ | TokenSubkeyRevocationSig
+ | TokenCertRevocationSig
+ | TokenTimestampSig
+ | TokenMD5
+ | TokenSHA1
+ | TokenRIPEMD160
+ | TokenSHA256
+ | TokenSHA384
+ | TokenSHA512
+ | TokenSHA224
+ | TokenKeysize
+ | TokenTimestamp
+ | TokenFingerprint
+ | TokenKeyID
+ | TokenFpr Fingerprint
+ | TokenLongID (Either String EightOctetKeyId)
+ | TokenLength
+ | TokenEvery
+ | TokenOne
+ | TokenOf
+ | TokenContains
+ | TokenUids
+ | TokenStr String
+ | TokenA
+ | TokenSubkey
+ | TokenSigCreationTime
+ deriving (Eq,Show)
+
+alexEOF = return TokenEOF
+
+lex :: (String -> a) -> AlexAction a
+lex f = \(_,_,_,s) i -> return (f (take i s))
+
+lex' :: a -> AlexAction a
+lex' = lex . const
+
+}
diff --git a/HOpenPGP/Tools/Common/Parser.y b/HOpenPGP/Tools/Common/Parser.y
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Common/Parser.y
@@ -0,0 +1,229 @@
+{
+{-# OPTIONS -w #-}
+module HOpenPGP.Tools.Common.Parser( parseTKExp, parsePExp ) where
+import Codec.Encryption.OpenPGP.Types
+-- import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..))
+import HOpenPGP.Tools.Common.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, spGetSCT, pUsingPKP, pUsingSP, maybeR)
+
+import HOpenPGP.Tools.Common.Lexer
+
+import Control.Applicative (liftA2)
+import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
+import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
+import Control.Error.Util (hush)
+import Control.Monad.Loops (allM, anyM)
+import Control.Monad.Trans.Reader (ask, reader, Reader, withReader)
+import Data.List (isInfixOf)
+import qualified Data.Text as T
+import Prettyprinter (pretty)
+
+}
+
+%name parseTK Exp
+%name parseP CFExp
+%tokentype { Token }
+%monad { Alex }
+%lexer { lexwrap } { TokenEOF }
+%error { happyError }
+%token
+ a { TokenA }
+ and { TokenAnd }
+ any { TokenAny }
+ contains { TokenContains }
+ every { TokenEvery }
+ not { TokenNot }
+ now { TokenNow }
+ of { TokenOf }
+ one { TokenOne }
+ or { TokenOr }
+ subkey { TokenSubkey }
+ tag { TokenTag }
+ int { TokenInt $$ }
+ '=' { TokenEq }
+ '<' { TokenLt }
+ '>' { TokenGt }
+ '(' { TokenLParen }
+ ')' { TokenRParen }
+ pkversion { TokenPKVersion }
+ sigversion { TokenSigVersion }
+ sigtype { TokenSigType }
+ pkalgo { TokenPKAlgo }
+ sigpkalgo { TokenSigPKAlgo }
+ hashalgo { TokenHashAlgo }
+ rsa { TokenRSA }
+ dsa { TokenDSA }
+ elgamal { TokenElgamal }
+ ecdsa { TokenECDSA }
+ ecdh { TokenECDH }
+ dh { TokenDH }
+ binary { TokenBinary }
+ canonicaltext { TokenCanonicalText }
+ standalone { TokenStandalone }
+ genericcert { TokenGenericCert }
+ personacert { TokenPersonaCert }
+ casualcert { TokenCasualCert }
+ positivecert { TokenPositiveCert }
+ subkeybindingsig { TokenSubkeyBindingSig }
+ primarykeybindingsig { TokenPrimaryKeyBindingSig }
+ signaturedirectlyonakey { TokenSignatureDirectlyOnAKey }
+ keyrevocationsig { TokenKeyRevocationSig }
+ subkeyrevocationsig { TokenSubkeyRevocationSig }
+ certrevocationsig { TokenCertRevocationSig }
+ timestampsig { TokenTimestampSig }
+ md5 { TokenMD5 }
+ sha1 { TokenSHA1 }
+ ripemd160 { TokenRIPEMD160 }
+ sha256 { TokenSHA256 }
+ sha384 { TokenSHA384 }
+ sha512 { TokenSHA512 }
+ sha224 { TokenSHA224 }
+ keysize { TokenKeysize }
+ timestamp { TokenTimestamp }
+ fingerprint { TokenFingerprint }
+ keyid { TokenKeyID }
+ sigcreationtime { TokenSigCreationTime }
+ fpr { TokenFpr $$ }
+ longid { TokenLongID $$ }
+ length { TokenLength }
+ str { TokenStr $$ }
+ uids { TokenUids }
+
+%%
+
+Exp : any { return True }
+ | not Exp { fmap not $2 }
+ | Exp and Exp { liftA2 (&&) $1 $3 }
+ | Exp or Exp { liftA2 (||) $1 $3 }
+ | PExp { tkUsingPKP $1 }
+ | TExp { $1 }
+
+PExp : pkversion PIOp int { $2 (reader pkpGetPKVersion) (return $3) }
+ | pkalgo PIOp Ppkalgos { $2 (reader pkpGetPKAlgo) (return $3) }
+ | keysize PIOp int { $2 (reader pkpGetKeysize) (return $3) }
+ | timestamp PIOp int { $2 (reader pkpGetTimestamp) (return $3) }
+ | fingerprint PSOp Pfingerprint { $2 (reader (show . pretty . pkpGetFingerprint)) (return $3) }
+ | keyid PSOp Plongid { $2 (reader pkpGetEOKI) (return $3) }
+
+TExp : every one of uids AATOp str { withReader tkGetUIDs (anyOrAll allM ($5 (return (T.pack $6)))) }
+ | any one of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($5 (return (T.pack $6)))) }
+ | any of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($4 (return (T.pack $5)))) }
+ | a subkey PExp { withReader tkGetSubs (anyReader $3) }
+
+PIOp : '=' { liftA2 (==) }
+ | '<' { liftA2 (<) }
+ | '>' { liftA2 (>) }
+
+PSOp : '=' { liftA2 (==) }
+ | contains { liftA2 (flip isInfixOf) }
+
+AATOp : '=' { liftA2 (==) }
+ | contains { liftA2 T.isInfixOf }
+
+Ppkalgos : rsa { fromIntegral (fromFVal RSA) }
+ | dsa { fromIntegral (fromFVal DSA) }
+ | elgamal { fromIntegral (fromFVal ElgamalEncryptOnly) }
+ | ecdsa { fromIntegral (fromFVal ECDSA) }
+ | ecdh { fromIntegral (fromFVal ECDH) }
+ | dh { fromIntegral (fromFVal DH) }
+ | int { fromIntegral $1 }
+
+Pfingerprint : fpr { (show . pretty) $1 }
+
+Plongid : longid { either (const "BROKEN") show $1 }
+
+CFExp : any { return True }
+ | not CFExp { fmap not $2 }
+ | CFExp and CFExp { liftA2 (&&) $1 $3 }
+ | CFExp or CFExp { liftA2 (||) $1 $3 }
+ | OExp { $1 }
+ | SPExp { $1 }
+ | PExp { pUsingPKP (maybeR True $1) }
+
+OExp : tag OIOp int { $2 (reader oGetTag) (return $3) }
+ | length OIOp int { $2 (reader oGetLength) (return $3) }
+
+OIOp : '=' { liftA2 (==) }
+ | '<' { liftA2 (<) }
+ | '>' { liftA2 (>) }
+
+SPExp : sigversion SIOp int { $2 (reader spGetSigVersion) (return (Just $3)) }
+ | sigtype SIOp Ssigtypes { $2 (reader spGetSigType) (return (Just $3)) }
+ | sigpkalgo SIOp Spkalgos { $2 (reader spGetPKAlgo) (return (Just $3)) }
+ | hashalgo SIOp Shashalgos { $2 (reader spGetHashAlgo) (return (Just $3)) }
+ | sigcreationtime SIOp Stimespec { $2 (reader spGetSCT) (return (Just $3)) }
+
+SIOp : '=' { liftA2 (==) }
+ | '<' { liftA2 (<) }
+ | '>' { liftA2 (>) }
+
+Ssigtypes : binary { fromIntegral (fromFVal BinarySig) }
+ | canonicaltext { fromIntegral (fromFVal CanonicalTextSig) }
+ | standalone { fromIntegral (fromFVal StandaloneSig) }
+ | genericcert { fromIntegral (fromFVal GenericCert) }
+ | personacert { fromIntegral (fromFVal PersonaCert) }
+ | casualcert { fromIntegral (fromFVal CasualCert) }
+ | positivecert { fromIntegral (fromFVal PositiveCert) }
+ | subkeybindingsig { fromIntegral (fromFVal SubkeyBindingSig) }
+ | primarykeybindingsig { fromIntegral (fromFVal PrimaryKeyBindingSig) }
+ | signaturedirectlyonakey { fromIntegral (fromFVal SignatureDirectlyOnAKey) }
+ | keyrevocationsig { fromIntegral (fromFVal KeyRevocationSig) }
+ | subkeyrevocationsig { fromIntegral (fromFVal SubkeyRevocationSig) }
+ | certrevocationsig { fromIntegral (fromFVal CertRevocationSig) }
+ | timestampsig { fromIntegral (fromFVal TimestampSig) }
+ | int { fromIntegral $1 }
+
+Spkalgos : rsa { fromIntegral (fromFVal RSA) }
+ | dsa { fromIntegral (fromFVal DSA) }
+ | elgamal { fromIntegral (fromFVal ElgamalEncryptOnly) }
+ | ecdsa { fromIntegral (fromFVal ECDSA) }
+ | ecdh { fromIntegral (fromFVal ECDH) }
+ | dh { fromIntegral (fromFVal DH) }
+ | int { fromIntegral $1 }
+
+Shashalgos : md5 { fromIntegral (fromFVal DeprecatedMD5) }
+ | sha1 { fromIntegral (fromFVal SHA1) }
+ | ripemd160 { fromIntegral (fromFVal RIPEMD160) }
+ | sha256 { fromIntegral (fromFVal SHA256) }
+ | sha384 { fromIntegral (fromFVal SHA384) }
+ | sha512 { fromIntegral (fromFVal SHA512) }
+ | sha224 { fromIntegral (fromFVal SHA224) }
+ | int { fromIntegral $1 }
+
+Stimespec : now { 0 }
+ | int { fromIntegral $1 }
+
+{
+lexwrap :: (Token -> Alex a) -> Alex a
+lexwrap cont = do
+ t <- alexMonadScan'
+ cont t
+
+alexMonadScan' = do
+ inp <- alexGetInput
+ sc <- alexGetStartCode
+ case alexScan inp sc of
+ AlexEOF -> alexEOF
+ AlexError (pos, _, _, _) -> alexError (show pos)
+ AlexSkip inp' len -> do
+ alexSetInput inp'
+ alexMonadScan'
+ AlexToken inp' len action -> do
+ alexSetInput inp'
+ action (ignorePendingBytes inp) len
+
+getPosn :: Alex (Int,Int)
+getPosn = do
+ (AlexPn _ l c,_,_,_) <- alexGetInput
+ return (l,c)
+
+happyError :: Token -> Alex a
+happyError t = do
+ (l,c) <- getPosn
+ error (show l ++ ":" ++ show c ++ ": Parse error on Token: " ++ show t ++ "\n")
+
+parseTKExp :: String -> Either String (Reader TKUnknown Bool)
+parseTKExp s = runAlex s parseTK
+
+parsePExp :: String -> Either String (Reader Pkt Bool)
+parsePExp s = runAlex s parseP
+}
diff --git a/HOpenPGP/Tools/Common/TKUtils.hs b/HOpenPGP/Tools/Common/TKUtils.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Common/TKUtils.hs
@@ -0,0 +1,94 @@
+-- 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 .
+
+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
diff --git a/HOpenPGP/Tools/Common/WKD.hs b/HOpenPGP/Tools/Common/WKD.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Common/WKD.hs
@@ -0,0 +1,183 @@
+-- WKD.hs: hOpenPGP key tool
+-- Copyright © 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 .
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module HOpenPGP.Tools.Common.WKD
+ ( fetchKeys
+ , parseMailbox
+ ) where
+
+import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
+import Codec.Encryption.OpenPGP.ASCIIArmor.Types
+ ( Armor(Armor)
+ , ArmorType(ArmorPublicKeyBlock)
+ )
+import Codec.Encryption.OpenPGP.Types (TKUnknown(..))
+import Control.Arrow ((&&&))
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (ExceptT(..), throwE)
+import qualified Crypto.Hash as CH
+import qualified Crypto.Hash.Algorithms as CHA
+import Data.Binary (get)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC8
+import qualified Data.ByteString.Lazy as BL
+import Data.Bits ((.&.), (.|.), shiftL, shiftR)
+import Data.Conduit ((.|), runConduitRes)
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.List as CL
+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
+import Data.Conduit.Serialization.Binary (conduitGet)
+import Data.Either (rights)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Word (Word8)
+import HOpenPGP.Tools.Common.HKP (FetchValidationMethod(..))
+import HOpenPGP.Tools.Common.TKUtils (processTK)
+import Network.HTTP.Client
+ ( Manager
+ , Response(..)
+ , httpLbs
+ , newManager
+ , parseUrlThrow
+ , setQueryString
+ )
+import Network.HTTP.Client.TLS (tlsManagerSettings)
+import Network.HTTP.Types.Status (ok200)
+
+fetchKeys ::
+ FetchValidationMethod
+ -> Text
+ -> ExceptT String IO [TKUnknown]
+fetchKeys fvm mailbox = do
+ parsedMailbox <- ExceptT . return $ parseMailbox mailbox
+ manager <- liftIO $ newManager tlsManagerSettings
+ response <- fetchWKD manager parsedMailbox
+ body <-
+ if responseStatus response == ok200
+ then return (responseBody response)
+ else throwE ("HTTP status: " ++ show (responseStatus response))
+ validateAndFilterKeys fvm parsedMailbox body
+
+parseMailbox :: Text -> Either String (Text, Text)
+parseMailbox rawMailbox =
+ let mailbox = T.strip rawMailbox
+ parts = T.splitOn "@" mailbox
+ in case parts of
+ [localPart, domain]
+ | T.null localPart -> Left "mailbox local part cannot be empty"
+ | T.null domain -> Left "mailbox domain cannot be empty"
+ | T.any (== ' ') mailbox -> Left "mailbox cannot contain spaces"
+ | otherwise -> Right (localPart, T.toLower domain)
+ _ -> Left "mailbox must contain exactly one @"
+
+fetchWKD ::
+ Manager
+ -> (Text, Text)
+ -> ExceptT String IO (Response BL.ByteString)
+fetchWKD manager (localPart, domain) = do
+ let localPartLower = T.toLower localPart
+ hu = BC8.unpack . zbase32 . sha1 . TE.encodeUtf8 $ localPartLower
+ advancedUrl =
+ "https://openpgpkey." <>
+ T.unpack domain <>
+ "/.well-known/openpgpkey/" <> T.unpack domain <> "/hu/" <> hu
+ directUrl =
+ "https://" <> T.unpack domain <> "/.well-known/openpgpkey/hu/" <> hu
+ mailboxParam = TE.encodeUtf8 localPartLower
+ withMailbox req = setQueryString [("l", Just mailboxParam)] req
+ advancedRequest <- liftIO $ parseUrlThrow advancedUrl
+ advancedResponse <- liftIO $ httpLbs (withMailbox advancedRequest) manager
+ if responseStatus advancedResponse == ok200
+ then return advancedResponse
+ else do
+ directRequest <- liftIO $ parseUrlThrow directUrl
+ liftIO $ httpLbs (withMailbox directRequest) manager
+
+validateAndFilterKeys ::
+ FetchValidationMethod
+ -> (Text, Text)
+ -> BL.ByteString
+ -> ExceptT String IO [TKUnknown]
+validateAndFilterKeys fvm mailbox body = do
+ keys <- decodeWkdResponse body
+ cpt <- liftIO getPOSIXTime
+ let processedKeys = rights $ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
+ mailboxFiltered = filter (mailboxMatchesKey mailbox . snd) processedKeys
+ return $
+ map fst $
+ case fvm of
+ AnySelfSigned -> processedKeys
+ MatchPrimaryKeyFingerprint -> mailboxFiltered
+ MatchPrimaryOrAnySubkeyFingerprint -> mailboxFiltered
+
+decodeWkdResponse :: BL.ByteString -> ExceptT String IO [TKUnknown]
+decodeWkdResponse body =
+ if isArmored body
+ then decodeArmored body
+ else decodeBinary body
+
+decodeBinary :: BL.ByteString -> ExceptT String IO [TKUnknown]
+decodeBinary bytes =
+ liftIO . runConduitRes $
+ CB.sourceLbs bytes .| conduitGet get .| conduitToTKsDropping .| CL.consume
+
+decodeArmored :: BL.ByteString -> ExceptT String IO [TKUnknown]
+decodeArmored larmors = do
+ bytestrings <- ExceptT . return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
+ liftIO . runConduitRes $
+ CB.sourceLbs bytestrings .| conduitGet get .| conduitToTKsDropping .| CL.consume
+ where
+ armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs
+ armorToBS _ = mempty
+
+isArmored :: BL.ByteString -> Bool
+isArmored =
+ BC8.isPrefixOf "-----BEGIN PGP PUBLIC KEY BLOCK-----" . BL.toStrict . BL.take 40
+
+mailboxMatchesKey :: (Text, Text) -> TKUnknown -> Bool
+mailboxMatchesKey (localPart, domain) tk =
+ let mailbox = T.toLower (localPart <> "@" <> domain)
+ bracketedMailbox = "<" <> mailbox <> ">"
+ in any
+ (\uid -> let lowered = T.toLower uid in lowered == mailbox || bracketedMailbox `T.isInfixOf` lowered)
+ (map fst (_tkuUIDs tk))
+
+sha1 :: B.ByteString -> B.ByteString
+sha1 bs = BA.convert (CH.hashWith CHA.SHA1 bs :: CH.Digest CHA.SHA1)
+
+zbase32 :: B.ByteString -> B.ByteString
+zbase32 = BC8.pack . encodeZBase32 . B.unpack
+
+encodeZBase32 :: [Word8] -> String
+encodeZBase32 = go 0 0
+ where
+ alphabet = "ybndrfg8ejkmcpqxot1uwisza345h769"
+ pick i = alphabet !! i
+ go _ 0 [] = []
+ go acc bits [] =
+ [pick (fromIntegral (((acc `shiftL` (5 - bits)) .&. 31) :: Int))]
+ go acc bits (x:xs)
+ | bits >= 5 =
+ pick (fromIntegral (((acc `shiftR` (bits - 5)) .&. 31) :: Int)) :
+ go acc (bits - 5) (x : xs)
+ | otherwise = go ((acc `shiftL` 8) .|. fromIntegral x) (bits + 8) xs
diff --git a/HOpenPGP/Tools/HKP.hs b/HOpenPGP/Tools/HKP.hs
deleted file mode 100644
--- a/HOpenPGP/Tools/HKP.hs
+++ /dev/null
@@ -1,126 +0,0 @@
--- HKP.hs: hOpenPGP key tool
--- Copyright © 2016-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 .
-
-{-# LANGUAGE OverloadedStrings #-}
-
-module HOpenPGP.Tools.HKP
- ( fetchKeys
- , FetchValidationMethod(..)
- , rearmorKeys
- ) where
-
-import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
-import Codec.Encryption.OpenPGP.ASCIIArmor.Types
- ( Armor(Armor)
- , ArmorType(ArmorPublicKeyBlock)
- )
-import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
-import Codec.Encryption.OpenPGP.Types
- ( Block(..)
- , TKUnknown(..)
- , Fingerprint
- )
-import Control.Applicative (liftA2)
-import Control.Arrow ((&&&))
-import Control.Lens ((^..))
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (ExceptT(..), throwE)
-import Data.Binary (get, put)
-import Data.Binary.Put (runPut)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as BC8
-import qualified Data.ByteString.Lazy as BL
-import Data.Conduit ((.|), runConduitRes)
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.List as CL
-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
-import Data.Conduit.Serialization.Binary (conduitGet)
-import Data.Data.Lens (biplate)
-import Data.Either (rights)
-import Data.Monoid ((<>), mempty)
-import Data.Time.Clock.POSIX (getPOSIXTime)
-import HOpenPGP.Tools.TKUtils (processTK)
-import Network.HTTP.Client
- ( Response(..)
- , httpLbs
- , newManager
- , parseUrlThrow
- , setQueryString
- )
-import Network.HTTP.Client.TLS (tlsManagerSettings)
-import Network.HTTP.Types.Status (ok200)
-import Prettyprinter (pretty)
-
-data FetchValidationMethod
- = MatchPrimaryKeyFingerprint
- | MatchPrimaryOrAnySubkeyFingerprint
- | AnySelfSigned
- deriving (Bounded, Enum, Eq, Read, Show)
-
-fetchKeys ::
- String
- -> FetchValidationMethod
- -> Fingerprint
- -> ExceptT String IO [TKUnknown]
-fetchKeys ks fvm q = do
- manager <- liftIO $ newManager tlsManagerSettings
- request <- liftIO $ parseUrlThrow (ks <> basereq)
- let newreq = setQueryString (newqs q) request
- response <- liftIO $ httpLbs newreq manager
- processedKeys <-
- if responseStatus response == ok200
- then validateKeys (responseBody response)
- else throwE ("HTTP status: " ++ show (responseStatus response))
- return $ map fst $ filter (fvp fvm . fst . _tkuKey . snd) processedKeys
- where
- fvp MatchPrimaryKeyFingerprint k = fingerprint k == q
- fvp MatchPrimaryOrAnySubkeyFingerprint k =
- any (\k -> fingerprint k == q) (k ^.. biplate)
- fvp AnySelfSigned k = True
- basereq = "/pks/lookup"
- newqs q =
- [ ("op", Just "get")
- , ("options", Just "mr")
- , ("exact", Just "on")
- , ("search", Just (BC8.pack ("0x" <> show (pretty q)))) -- FIXME: butter
- ]
-
-validateKeys :: BL.ByteString -> ExceptT String IO [(TKUnknown, TKUnknown)] -- FIXME: conduit fail
-validateKeys larmors = do
- bytestrings <-
- ExceptT $ return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
- keys <-
- liftIO . runConduitRes $
- CB.sourceLbs bytestrings .| conduitGet get .| conduitToTKsDropping .|
- CL.consume
- cpt <- liftIO getPOSIXTime
- return . rights $
- map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
- where
- armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs
- armorToBS _ = mempty
-
-rearmorKeys :: [TKUnknown] -> B.ByteString
-rearmorKeys keys =
- if null keys
- then mempty
- else AA.encode .
- return .
- Armor ArmorPublicKeyBlock [("Comment", "filtered by hokey")] .
- runPut . put . Block $
- keys
diff --git a/HOpenPGP/Tools/Hokey/Canonicalize.hs b/HOpenPGP/Tools/Hokey/Canonicalize.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Hokey/Canonicalize.hs
@@ -0,0 +1,57 @@
+-- Canonicalize.hs: hOpenPGP key tool canonicalize subcommand
+-- 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 .
+
+module HOpenPGP.Tools.Hokey.Canonicalize
+ (
+ doCanonicalize
+ ) where
+
+import Codec.Encryption.OpenPGP.Serialize ()
+import Codec.Encryption.OpenPGP.Types
+import Control.Lens (_2, mapped, over)
+import Data.Binary (get, put)
+import Data.Conduit ((.|), runConduitRes)
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.List as CL
+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
+import Data.Conduit.Serialization.Binary (conduitGet, conduitPut)
+import Data.List (nub, sort)
+
+import System.IO
+ ( stdin
+ , stdout
+ )
+
+doCanonicalize :: IO ()
+doCanonicalize =
+ runConduitRes $ CB.sourceHandle stdin .| conduitGet get .|
+ conduitToTKsDropping .|
+ CL.map canonicalize .|
+ CL.map put .|
+ conduitPut .|
+ CB.sinkHandle stdout
+ where
+ canonicalize tk =
+ tk
+ { _tkuRevs = sort (_tkuRevs tk)
+ , _tkuUIDs = indepthsort (_tkuUIDs tk)
+ , _tkuUAts = indepthsort (_tkuUAts tk)
+ , _tkuSubs = indepthsort (_tkuSubs tk)
+ }
+ indepthsort :: (Ord a, Ord b) => [(a, [b])] -> [(a, [b])]
+ indepthsort = nub . sort . over (mapped . _2) sort
diff --git a/HOpenPGP/Tools/Hokey/Fetch.hs b/HOpenPGP/Tools/Hokey/Fetch.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Hokey/Fetch.hs
@@ -0,0 +1,50 @@
+-- Fetch.hs: hOpenPGP key tool fetch subcommand
+-- 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 .
+
+module HOpenPGP.Tools.Hokey.Fetch
+ (
+ doFetch
+ ) where
+
+import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)
+import Codec.Encryption.OpenPGP.Serialize ()
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import HOpenPGP.Tools.Common.HKP (rearmorKeys)
+import qualified HOpenPGP.Tools.Common.HKP as HKP
+import qualified HOpenPGP.Tools.Common.WKD as WKD
+import HOpenPGP.Tools.Hokey.Options (FetchOptions(..), FetchMethod(..))
+
+import System.IO
+ ( hPutStrLn
+ , stderr
+ )
+
+doFetch :: FetchOptions -> IO ()
+doFetch o = do
+ ekeys <-
+ runExceptT $
+ case fetchMethod o of
+ HKP -> do
+ fp <- ExceptT . return . parseFingerprint . T.pack $ fetchQuery o
+ HKP.fetchKeys (keyServer o) (fetchValidation o) fp
+ WKD -> WKD.fetchKeys (fetchValidation o) (T.pack (fetchQuery o))
+ case ekeys of
+ Left e -> hPutStrLn stderr $ "error fetching keys: " ++ e
+ Right ks -> B.putStr $ rearmorKeys ks
diff --git a/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs b/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs
@@ -0,0 +1,374 @@
+-- InjectSSHAgent.hs: hOpenPGP key tool inject-ssh-agent subcommand
+-- 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 .
+
+{-# LANGUAGE GADTs #-}
+
+module HOpenPGP.Tools.Hokey.InjectSSHAgent
+ (
+ doInjectSSHAgent
+ ) where
+import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
+import Codec.Encryption.OpenPGP.Ontology
+ ( isKUF
+ , isSKBindingSig
+ )
+import Codec.Encryption.OpenPGP.Serialize ()
+import Codec.Encryption.OpenPGP.Types
+import Control.Exception (bracket)
+import qualified Crypto.PubKey.RSA as RSA
+import Data.Binary (get)
+import Data.Binary.Get (getWord32be, runGet)
+import Data.Binary.Put (Put, putByteString, putLazyByteString, putWord32be, putWord8, runPut)
+import Data.Bits ((.&.), shiftR, testBit)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8 as BC8
+import qualified Data.ByteString.Lazy as BL
+import Data.Conduit ((.|), runConduitRes)
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.List as CL
+import Data.Conduit.OpenPGP.Keyring (AuthSecretSubkeyAtTime, authSecretSubkeyPrimaryUID, authSecretSubkeyValue, conduitToAuthSecretSubkeysAt, conduitToSecretTKs)
+import Data.Conduit.Serialization.Binary (conduitGet)
+import Data.Foldable (find)
+import Data.List (intercalate, sortOn)
+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
+import Data.Ord (Down(..))
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
+import HOpenPGP.Tools.Common.Common (renderFingerprint)
+import Network.Socket (Family(AF_UNIX), SockAddr(..), Socket, SocketType(Stream), close, connect, defaultProtocol, socket)
+import qualified Network.Socket.ByteString as NSB
+import System.Environment (lookupEnv)
+import System.Exit (exitFailure)
+import HOpenPGP.Tools.Hokey.Options (InjectSSHAgentOptions(..))
+import System.IO
+ ( hPutStrLn
+ , stderr
+ , stdin
+ )
+
+doInjectSSHAgent :: InjectSSHAgentOptions -> IO ()
+doInjectSSHAgent opts = do
+ socketPath <- resolveSSHAgentSocketPath (injectSSHAgentSocket opts)
+ input <- readInjectedSecretKeyMaterial opts
+ cpt <- getPOSIXTime
+ authCandidates <-
+ runConduitRes $
+ CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|
+ conduitToAuthSecretSubkeysAt (posixSecondsToUTCTime cpt) .|
+ CL.consume
+ injectableCandidates <-
+ if null authCandidates
+ then inferInjectableAuthSubkeys cpt input
+ else pure (map candidateFromAuthSecretSubkey authCandidates)
+ whenEmpty injectableCandidates "inject-ssh-agent: no authentication-capable secret subkey found"
+ selectedRequests <-
+ selectInjectableAuthSubkeys
+ (injectSSHAgentComment opts)
+ injectableCandidates
+ mapM_
+ (\(selected, request) -> do
+ sendAddIdentityToSSHAgent socketPath request
+ hPutStrLn stderr $
+ "inject-ssh-agent: added authentication subkey " ++
+ renderFingerprint (fingerprint (injectableAuthSubkeyPKP selected)) ++
+ " to ssh-agent")
+ selectedRequests
+
+candidateFromAuthSecretSubkey :: AuthSecretSubkeyAtTime -> InjectableAuthSubkey
+candidateFromAuthSecretSubkey authSubkey =
+ InjectableAuthSubkey
+ { injectableAuthSubkeyPKP = authSecretSubkeyPKP authSubkey
+ , injectableAuthSubkeySKA = authSecretSubkeySKA authSubkey
+ , injectableAuthSubkeyPrimaryUID = authSecretSubkeyPrimaryUID authSubkey
+ }
+
+inferInjectableAuthSubkeys ::
+ POSIXTime -> BL.ByteString -> IO [InjectableAuthSubkey]
+inferInjectableAuthSubkeys _cpt input = do
+ tks <-
+ runConduitRes $
+ CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|
+ CL.consume
+ pure (concatMap inferFromTK tks)
+ where
+ inferFromTK tk =
+ let mPrimaryUID = fst <$> listToMaybe (_tkUIDs tk)
+ in mapMaybe (inferFromSubkey mPrimaryUID) (_tkSubs tk)
+ inferFromSubkey :: Maybe Text -> (KeyPkt k, [SignaturePayload]) -> Maybe InjectableAuthSubkey
+ inferFromSubkey mPrimaryUID (KeyPktSecretSubkey pkp ska, sigs)
+ | hasAuthCapability sigs =
+ Just
+ InjectableAuthSubkey
+ { injectableAuthSubkeyPKP = pkp
+ , injectableAuthSubkeySKA = ska
+ , injectableAuthSubkeyPrimaryUID = mPrimaryUID
+ }
+ inferFromSubkey _ _ = Nothing
+ hasAuthCapability sigs =
+ any
+ (Set.member AuthKey)
+ (mapMaybe signatureKeyFlags (newestWithUsageFlags (filter isSKBindingSig sigs)))
+ newestWithUsageFlags =
+ take 1 . sortOn (Down . take 1 . sigCreationTimes) . filter (any isKUF . signatureHashedSubpackets)
+ sigCreationTimes = mapMaybe sigCreationTimeFromSubpacket . signatureHashedSubpackets
+ sigCreationTimeFromSubpacket (SigSubPacket _ (SigCreationTime ct)) = Just ct
+ sigCreationTimeFromSubpacket _ = Nothing
+ signatureHashedSubpackets (SigV4 _ _ _ hasheds _ _ _) = hasheds
+ signatureHashedSubpackets (SigV6 _ _ _ _ hasheds _ _ _) = hasheds
+ signatureHashedSubpackets _ = []
+ signatureKeyFlags sig = do
+ sp <- find isKUF (signatureHashedSubpackets sig)
+ case sp of
+ SigSubPacket _ (KeyFlags flags) -> Just flags
+ _ -> Nothing
+
+resolveSSHAgentSocketPath :: Maybe String -> IO String
+resolveSSHAgentSocketPath (Just path) = pure path
+resolveSSHAgentSocketPath Nothing = do
+ envPath <- lookupEnv "SSH_AUTH_SOCK"
+ case envPath of
+ Just path -> pure path
+ Nothing ->
+ failInject
+ "inject-ssh-agent: SSH_AUTH_SOCK is not set; use --ssh-agent-socket"
+
+readInjectedSecretKeyMaterial :: InjectSSHAgentOptions -> IO BL.ByteString
+readInjectedSecretKeyMaterial opts = do
+ chunks <-
+ case injectSSHAgentFromFD opts of
+ Nothing -> runConduitRes $ CB.sourceHandle stdin .| CL.consume
+ Just fd
+ | fd < 0 ->
+ failInject "inject-ssh-agent: --from-fd must be a non-negative integer"
+ | otherwise ->
+ runConduitRes $ CB.sourceFile ("/dev/fd/" ++ show fd) .| CL.consume
+ let input = BL.fromChunks chunks
+ if BL.null input
+ then
+ failInject
+ "inject-ssh-agent: no secret key bytes were provided on the selected input stream"
+ else pure input
+
+selectInjectableAuthSubkeys ::
+ Maybe String -> [InjectableAuthSubkey] -> IO [(InjectableAuthSubkey, BL.ByteString)]
+selectInjectableAuthSubkeys mComment candidates
+ | null selectedRequests =
+ failInject
+ ("inject-ssh-agent: auth-capable subkeys were found, but none are supported for ssh-agent injection: " ++
+ intercalate "; " (reverse errs))
+ | otherwise = pure (reverse selectedRequests)
+ where
+ (errs, selectedRequests) = foldl' pick ([], []) candidates
+ pick (accErrs, accSelected) candidate =
+ case
+ sshAddIdentityRequest
+ (fromMaybe (defaultSSHComment candidate) mComment)
+ (injectableAuthSubkeyPKP candidate)
+ (injectableAuthSubkeySKA candidate) of
+ Left err -> (err : accErrs, accSelected)
+ Right request -> (accErrs, (candidate, request) : accSelected)
+ defaultSSHComment candidate =
+ case injectableAuthSubkeyPrimaryUID candidate of
+ Just uid -> T.unpack uid
+ Nothing -> "openpgp:" ++ BC8.unpack (Base16.encode (BL.toStrict (unFingerprint (fingerprint (injectableAuthSubkeyPKP candidate)))))
+
+sshAddIdentityRequest ::
+ String -> SomePKPayload -> SKAddendum -> Either String BL.ByteString
+sshAddIdentityRequest comment subkeyPKP subkeySKA =
+ case subkeySKA of
+ SUUnencrypted (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) _ ->
+ Right $ frameSSHAgentRequest (rsaAddIdentityPayload (BC8.pack comment) rsaPrivateKey)
+ SUUnencrypted (EdDSAPrivateKey Ed25519 secretSeed) _ ->
+ frameSSHAgentRequest <$>
+ ed25519AddIdentityPayload (BC8.pack comment) subkeyPKP secretSeed
+ SUUnencrypted (UnknownSKey rawSecret) _
+ | isEd25519PKA (_pkalgo subkeyPKP) ->
+ frameSSHAgentRequest <$>
+ ed25519AddIdentityPayload
+ (BC8.pack comment)
+ subkeyPKP
+ (BL.toStrict rawSecret)
+ SUUnencrypted (EdDSAPrivateKey Ed448 _) _ ->
+ Left
+ ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
+ " uses Ed448, which is not supported by ssh-agent add-identity")
+ SUUnencrypted _ _ ->
+ Left
+ ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
+ " uses an unsupported key algorithm for ssh-agent injection")
+ _ ->
+ Left
+ ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
+ " is encrypted; decrypt it before injection")
+
+authSecretSubkeyPKP :: AuthSecretSubkeyAtTime -> SomePKPayload
+authSecretSubkeyPKP = keyPktPKPayload . authSecretSubkeyValue
+
+authSecretSubkeySKA :: AuthSecretSubkeyAtTime -> SKAddendum
+authSecretSubkeySKA = secretKeyPktSKAddendum . authSecretSubkeyValue
+
+rsaAddIdentityPayload :: B.ByteString -> RSA.PrivateKey -> BL.ByteString
+rsaAddIdentityPayload comment privateKey =
+ runPut $ do
+ putWord8 17
+ putSSHString (BC8.pack "ssh-rsa")
+ putSSHMpint (RSA.public_n (RSA.private_pub privateKey))
+ putSSHMpint (RSA.public_e (RSA.private_pub privateKey))
+ putSSHMpint (RSA.private_d privateKey)
+ putSSHMpint (RSA.private_qinv privateKey)
+ putSSHMpint (RSA.private_p privateKey)
+ putSSHMpint (RSA.private_q privateKey)
+ putSSHString comment
+
+ed25519AddIdentityPayload ::
+ B.ByteString -> SomePKPayload -> B.ByteString -> Either String BL.ByteString
+ed25519AddIdentityPayload comment pkp rawSecret = do
+ publicKey <- ed25519PublicPoint pkp
+ secretSeed <- normalizeEd25519Secret rawSecret
+ pure $
+ runPut $ do
+ putWord8 17
+ putSSHString (BC8.pack "ssh-ed25519")
+ putSSHString publicKey
+ putSSHString (secretSeed <> publicKey)
+ putSSHString comment
+
+ed25519PublicPoint :: SomePKPayload -> Either String B.ByteString
+ed25519PublicPoint pkp =
+ case _pubkey pkp of
+ EdDSAPubKey Ed25519 point ->
+ maybe
+ (Left ("invalid Ed25519 public point for subkey " ++ renderFingerprint (fingerprint pkp)))
+ Right
+ (edPointToRawBytes point)
+ _ -> Left ("subkey " ++ renderFingerprint (fingerprint pkp) ++ " does not have an Ed25519 public key")
+
+edPointToRawBytes :: EdPoint -> Maybe B.ByteString
+edPointToRawBytes (NativeEPoint (EPoint i)) = integerToFixedBytes 32 i
+edPointToRawBytes (PrefixedNativeEPoint (EPoint i)) = do
+ prefixed <- integerToFixedBytes 33 i
+ case B.uncons prefixed of
+ Just (0x40, raw) -> Just raw
+ _ -> Nothing
+
+normalizeEd25519Secret :: B.ByteString -> Either String B.ByteString
+normalizeEd25519Secret rawSecret
+ | B.length rawSecret == 32 = Right rawSecret
+ | otherwise =
+ Left
+ ("expected 32-byte Ed25519 secret seed, got " ++ show (B.length rawSecret) ++ " bytes")
+
+putSSHString :: B.ByteString -> Put
+putSSHString bs = putWord32be (fromIntegral (B.length bs)) >> putByteString bs
+
+putSSHMpint :: Integer -> Put
+putSSHMpint n
+ | n <= 0 = putWord32be 0
+ | otherwise = putSSHString encoded
+ where
+ raw = integerToUnsignedBytes n
+ encoded =
+ case B.uncons raw of
+ Just (firstByte, _)
+ | testBit firstByte 7 -> B.cons 0x00 raw
+ _ -> raw
+
+integerToFixedBytes :: Int -> Integer -> Maybe B.ByteString
+integerToFixedBytes width n
+ | n < 0 = Nothing
+ | B.length raw > width = Nothing
+ | otherwise = Just (B.replicate (width - B.length raw) 0x00 <> raw)
+ where
+ raw =
+ if n == 0
+ then B.singleton 0x00
+ else integerToUnsignedBytes n
+
+integerToUnsignedBytes :: Integer -> B.ByteString
+integerToUnsignedBytes n =
+ B.reverse $
+ B.unfoldr
+ (\value ->
+ if value == 0
+ then Nothing
+ else Just (fromIntegral (value .&. 0xff), value `shiftR` 8))
+ n
+
+isEd25519PKA :: PubKeyAlgorithm -> Bool
+isEd25519PKA pka = fromFVal pka == 27
+
+frameSSHAgentRequest :: BL.ByteString -> BL.ByteString
+frameSSHAgentRequest body =
+ runPut $ putWord32be (fromIntegral (BL.length body)) >> putLazyByteString body
+
+sendAddIdentityToSSHAgent :: FilePath -> BL.ByteString -> IO ()
+sendAddIdentityToSSHAgent socketPath request =
+ bracket
+ (socket AF_UNIX Stream defaultProtocol)
+ close
+ (\sock -> do
+ connect sock (SockAddrUnix socketPath)
+ NSB.sendAll sock (BL.toStrict request)
+ response <- readSSHAgentPacket sock
+ case B.uncons response of
+ Just (6, _) -> pure ()
+ Just (5, _) ->
+ failInject "inject-ssh-agent: ssh-agent rejected the supplied key"
+ Just (code, _) ->
+ failInject
+ ("inject-ssh-agent: ssh-agent returned unexpected response type " ++
+ show code)
+ Nothing ->
+ failInject
+ "inject-ssh-agent: ssh-agent returned an empty response packet")
+
+readSSHAgentPacket :: Socket -> IO B.ByteString
+readSSHAgentPacket sock = do
+ lenPrefix <- recvExact sock 4
+ let packetLen = fromIntegral (runGet getWord32be (BL.fromStrict lenPrefix))
+ recvExact sock packetLen
+
+recvExact :: Socket -> Int -> IO B.ByteString
+recvExact _ 0 = pure B.empty
+recvExact sock remaining = go B.empty remaining
+ where
+ go acc 0 = pure acc
+ go acc bytesRemaining = do
+ chunk <- NSB.recv sock bytesRemaining
+ if B.null chunk
+ then
+ failInject
+ "inject-ssh-agent: ssh-agent socket closed while reading response"
+ else go (acc <> chunk) (bytesRemaining - B.length chunk)
+
+whenEmpty :: [a] -> String -> IO ()
+whenEmpty [] msg = failInject msg
+whenEmpty _ _ = pure ()
+
+failInject :: String -> IO a
+failInject msg = hPutStrLn stderr msg >> exitFailure
+
+data InjectableAuthSubkey =
+ InjectableAuthSubkey
+ { injectableAuthSubkeyPKP :: SomePKPayload
+ , injectableAuthSubkeySKA :: SKAddendum
+ , injectableAuthSubkeyPrimaryUID :: Maybe Text
+ }
diff --git a/HOpenPGP/Tools/Hokey/Lint.hs b/HOpenPGP/Tools/Hokey/Lint.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Hokey/Lint.hs
@@ -0,0 +1,710 @@
+-- Lint.hs: hOpenPGP key tool lint subcommand
+-- 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 .
+
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+
+module HOpenPGP.Tools.Hokey.Lint
+ (
+ doLint
+ ) where
+
+import Codec.Encryption.OpenPGP.Expirations (getKeyExpirationTimesFromSignature)
+import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
+import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)
+import Codec.Encryption.OpenPGP.Ontology
+ ( isCT
+ , isCertRevocationSig
+ , isKUF
+ , isPHA
+ , isPKBindingSig
+ , isSKBindingSig
+ )
+import Codec.Encryption.OpenPGP.Serialize ()
+import Codec.Encryption.OpenPGP.Types
+import Control.Arrow ((***))
+import Control.Error.Util (hush)
+import Control.Lens ((&), (^.), _1)
+import Control.Monad.Trans.Writer.Lazy (execWriter, tell)
+import qualified Crypto.Hash as CH
+import qualified Crypto.Hash.Algorithms as CHA
+import qualified Data.Aeson as A
+import Data.Binary (get)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8 as BC8
+import qualified Data.ByteString.Lazy as BL
+import Data.Conduit ((.|), runConduitRes)
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.List as CL
+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
+import Data.Conduit.Serialization.Binary (conduitGet)
+import Data.Foldable (find)
+import Data.List (elemIndex, findIndex, intercalate, sortOn)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
+import Data.Ord (Down(..))
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
+import Data.Time.Format (formatTime)
+import qualified Data.Yaml as Y
+import GHC.Generics
+import HOpenPGP.Tools.Common.Common (renderKeyID, renderFingerprint)
+import HOpenPGP.Tools.Common.TKUtils (processTK)
+import HOpenPGP.Tools.Hokey.Options (LintOptions(..), LintOutputFormat(..))
+
+import Data.Time.Locale.Compat (defaultTimeLocale)
+import System.IO
+ ( stdin
+ )
+
+import Prettyprinter
+ ( Doc
+ , (<+>)
+ , annotate
+ , colon
+ , flatAlt
+ , indent
+ , line
+ , list
+ , pretty
+ )
+import qualified Prettyprinter.Render.Terminal as PPA
+
+linebreak :: Doc ann
+linebreak = flatAlt line mempty
+
+green, yellow, red :: Doc PPA.AnsiStyle -> Doc PPA.AnsiStyle
+green = annotate (PPA.color PPA.Green)
+yellow = annotate (PPA.color PPA.Yellow)
+red = annotate (PPA.color PPA.Red)
+
+data KAS =
+ KAS
+ { pubkeyalgo :: Colored PubKeyAlgorithm
+ , pubkeysize :: Colored (Maybe Int)
+ , stringrep :: String
+ }
+ deriving (Generic)
+
+data Color
+ = Green
+ | Yellow
+ | Red
+ deriving (Eq, Generic, Ord)
+
+data Colored a =
+ Colored
+ { color :: Maybe Color
+ , explanation :: Maybe String
+ , val :: a
+ }
+ deriving (Functor, Generic)
+
+newtype FakeMap a b =
+ FakeMap
+ { unFakeMap :: [(a, b)]
+ }
+
+data KeyReport =
+ KeyReport
+ { keyStatus :: String
+ , keyFingerprint :: Fingerprint
+ , keyVer :: Colored KeyVersion
+ , keyCreationTime :: ThirtyTwoBitTimeStamp
+ , keyAlgorithmAndSize :: KAS
+ , keyUIDsAndUAts :: FakeMap Text (Colored UIDReport)
+ , keyBestOf :: Maybe UIDReport
+ , keySubkeys :: [SubkeyReport]
+ , keyHasEncryptionCapableSubkey :: Colored Bool
+ }
+ deriving (Generic)
+
+data UIDReport =
+ UIDReport
+ { uidSelfSigHashAlgorithms :: [Colored HashAlgorithm]
+ , uidPreferredHashAlgorithms :: [Colored [HashAlgorithm]]
+ , uidKeyExpirationTimes :: [Colored [ThirtyTwoBitDuration]]
+ , uidKeyUsageFlags :: [Colored (Set.Set KeyFlag)]
+ , uidRevocationStatus :: [RevocationStatus]
+ }
+ deriving (Generic)
+
+data SubkeyReport =
+ SubkeyReport
+ { skFingerprint :: Colored Fingerprint
+ , skVer :: Colored KeyVersion
+ , skCreationTime :: ThirtyTwoBitTimeStamp
+ , skAlgorithmAndSize :: KAS
+ , skBindingSigHashAlgorithms :: [Colored HashAlgorithm]
+ , skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning]
+ , skUsageFlags :: [Colored (Set.Set KeyFlag)]
+ , skCrossCerts :: CrossCertReport
+ }
+ deriving (Generic)
+
+data SubkeyRevocationDigestWarning =
+ SubkeyRevocationDigestWarning
+ { srwHashAlgorithm :: HashAlgorithm
+ , srwSubkeyFingerprint :: String
+ , srwSubkeyKeyID :: Maybe String
+ , srwMessage :: String
+ }
+ deriving (Generic)
+
+data CrossCertReport =
+ CrossCertReport
+ { ccPresent :: Colored Bool
+ , ccHashAlgorithms :: [Colored HashAlgorithm]
+ }
+ deriving (Generic)
+
+data RevocationStatus =
+ RevocationStatus
+ { isRevoked :: Bool
+ , revocationCode :: String
+ , revocationReason :: Text
+ }
+ deriving (Generic)
+
+instance A.ToJSON KAS
+
+instance A.ToJSON Color
+
+instance (A.ToJSON a) => A.ToJSON (Colored a)
+
+instance A.ToJSON KeyReport
+
+instance A.ToJSON UIDReport
+
+instance A.ToJSON SubkeyReport
+
+instance A.ToJSON SubkeyRevocationDigestWarning
+
+instance A.ToJSON CrossCertReport
+
+instance A.ToJSON b => A.ToJSON (FakeMap Text b) where
+ toJSON = A.toJSON . Map.fromList . unFakeMap
+
+instance A.ToJSON RevocationStatus
+
+instance Semigroup UIDReport where
+ (<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') =
+ UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e')
+
+instance Monoid UIDReport where
+ mempty = UIDReport [] [] [] [] []
+ mappend = (<>)
+
+checkKey :: Maybe POSIXTime -> TKUnknown -> KeyReport
+checkKey mpt key =
+ (\x ->
+ x
+ { keyBestOf = populateBestOf x
+ , keyHasEncryptionCapableSubkey =
+ hasEncryptionCapableSubkey (concatMap skUsageFlags (keySubkeys x))
+ })
+ KeyReport
+ { keyStatus = either id (const "good") processedTK
+ , keyFingerprint = key ^. tkuKey . _1 & fingerprint
+ , keyVer = key ^. tkuKey . _1 & _keyVersion & colorizeKV
+ , keyCreationTime = key ^. tkuKey . _1 & _timestamp
+ , keyAlgorithmAndSize = kasIt (key ^. tkuKey . _1)
+ , keyUIDsAndUAts =
+ FakeMap
+ (map (\(x, y) -> (x, uidr (Just x) y)) (processedOrOrig ^. tkuUIDs) ++
+ map (uatspsToText *** uidr Nothing) (processedOrOrig ^. tkuUAts))
+ , keyBestOf = Nothing
+ , keySubkeys =
+ map (checkSK (key ^. tkuKey . _1 & fingerprint)) (key ^. tkuSubs)
+ , keyHasEncryptionCapableSubkey = Colored Nothing Nothing False
+ }
+ where
+ processedOrOrig = either (const key) id processedTK
+ processedTK = processTK mpt key
+ kasIt :: SomePKPayload -> KAS
+ kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize)
+ kasIt' :: PubKeyAlgorithm -> Either String Int -> KAS
+ kasIt' pka epks =
+ KAS
+ { pubkeyalgo = colorizePKA pka
+ , pubkeysize = colorizePKS pka epks
+ , stringrep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka)
+ }
+ colorizeKV kv =
+ uncurry
+ Colored
+ (if kv == V4
+ then (Just Green, Nothing)
+ else (Just Red, Just "not a V4 key"))
+ kv
+ colorizePKA pka
+ | pka `elem` [RSA, EdDSA, ECDH] = Colored (Just Green) Nothing pka
+ | otherwise =
+ Colored
+ (Just Yellow)
+ (Just "public key algorithm neither RSA nor EdDSA")
+ pka
+ colorizePKS pka epks = uncurry Colored (colorizePKS' pka epks) (hush epks)
+ colorizePKS' pka (Right pks)
+ | pka `elem` [EdDSA, ECDH] && pks >= 256 = (Just Green, Nothing)
+ | pka `elem` [EdDSA, ECDH] =
+ (Just Yellow, Just "Public key size under 256 bits")
+ | pka == RSA && pks >= 3072 = (Just Green, Nothing)
+ | pka == RSA && pks >= 2048 =
+ (Just Yellow, Just "Public key size between 2048 and 3072 bits")
+ | pka == RSA = (Just Red, Just "Public key size under 2048 bits")
+ | otherwise = (Nothing, Nothing)
+ colorizePKS' _ (Left _) =
+ (Just Red, Just "public key algorithm not understood")
+ colorizePHAs x =
+ uncurry
+ Colored
+ (if preferredWeakHash x
+ then (Just Red, Just "weak hash with higher preference")
+ else (Just Green, Nothing))
+ x
+ fSHA2Family = fi (`elem` [SHA512, SHA384, SHA256, SHA224])
+ firstStrongSHA2 xs = fSHA2Family xs
+ preferredWeakHash xs =
+ any
+ (\ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2 xs)
+ knownWeakHashAlgorithms
+ fi x y = fromMaybe maxBound (findIndex x y)
+ colorizeKETs ct ts kes
+ | null kes = Colored (Just Red) (Just "no expiration set") kes
+ | any (\ke -> realToFrac ts + realToFrac ke < ct) kes =
+ Colored (Just Red) (Just "expiration passed") kes
+ | any (\ke -> realToFrac ts + realToFrac ke > ct + (5 * 31557600)) kes =
+ Colored (Just Yellow) (Just "expiration too far in future") kes
+ | otherwise = Colored (Just Green) Nothing kes
+ eoki pkp
+ | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
+ | _keyVersion pkp == DeprecatedV3 &&
+ elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
+ hush . eightOctetKeyID $ pkp
+ | otherwise = Nothing
+ phas (SigV4 _ _ _ xs _ _ _) =
+ colorizePHAs .
+ concatMap (\(SigSubPacket _ (PreferredHashAlgorithms x)) -> x) $
+ filter isPHA xs
+ phas _ = Colored Nothing Nothing []
+ has = map (colorizeHA . hashAlgo) . alleged
+ colorizeHA ha =
+ uncurry
+ Colored
+ (if isKnownWeakHashAlgorithm ha
+ then (Just Red, Just "weak hash algorithm")
+ else (Nothing, Nothing))
+ ha
+ sigcts (SigV4 _ _ _ xs _ _ _) =
+ map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs
+ sigcts (SigV6 _ _ _ _ xs _ _ _) =
+ map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs
+ alleged =
+ filter
+ (\x -> ((==) <$> sigissuer x <*> eoki (key ^. tkuKey . _1)) == Just True)
+ uatspsToText = T.pack . uatspsToString
+ uatspsToString us =
+ ""
+ uaspToString (ImageAttribute hdr d) =
+ hdrToString hdr ++ ':' : show (BL.length d) ++ ':' :
+ BC8.unpack (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
+ uaspToString (OtherUASub t d) =
+ "other-" ++ show t ++ ':' : show (BL.length d) ++ ':' :
+ BC8.unpack (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
+ hdrToString (ImageHV1 JPEG) = "jpeg"
+ hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)
+ uidr Nothing sps =
+ Colored
+ Nothing
+ Nothing
+ (UIDReport
+ (has sps)
+ (map phas sps)
+ (map
+ (colorizeKETs
+ (fromMaybe 0 mpt)
+ (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) .
+ getKeyExpirationTimesFromSignature)
+ sps -- should that be 0?
+ )
+ (kufs False sps)
+ (findRevocationReason sps))
+ uidr (Just u) sps =
+ colorizeUID
+ u
+ (UIDReport
+ (has sps)
+ (map phas sps)
+ (map
+ (colorizeKETs
+ (fromMaybe 0 mpt)
+ (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) .
+ getKeyExpirationTimesFromSignature)
+ sps -- should that be 0?
+ )
+ (kufs False sps)
+ (findRevocationReason sps))
+ populateBestOf krep =
+ Just
+ (UIDReport <$> best . uidSelfSigHashAlgorithms <*> best .
+ uidPreferredHashAlgorithms <*>
+ best .
+ uidKeyExpirationTimes <*>
+ best .
+ uidKeyUsageFlags <*>
+ pure [] $
+ mconcat (justTheUIDRs krep))
+ justTheUIDRs = map (decolorize . snd) . unFakeMap . keyUIDsAndUAts
+ best = take 1 . sortOn color
+ decolorize (Colored _ _ x) = x
+ colorizeUID u
+ | '(' `elem` T.unpack u =
+ Colored (Just Yellow) (Just "parenthesis in uid") -- FIXME: be more discerning
+ | '<' `notElem` T.unpack u =
+ Colored (Just Yellow) (Just "no left angle bracket in uid") -- FIXME: be more discerning
+ | otherwise = Colored Nothing Nothing
+ findRevocationReason = concatMap grabReasons . filter isCertRevocationSig
+ grabReasons (SigV4 CertRevocationSig _ _ has _ _ _) =
+ mapMaybe (grabReasons' . _sspPayload) has
+ grabReasons _ = []
+ grabReasons' (ReasonForRevocation a b) =
+ Just (RevocationStatus True (show a) b)
+ grabReasons' _ = Nothing
+ kufs s =
+ map
+ (colorizeKUFs s . (\(SigSubPacket _ (KeyFlags x)) -> x) .
+ fromMaybe undefined .
+ find isKUF .
+ hasheds) .
+ newestWith (any isKUF . hasheds)
+ colorizeKUFs False x =
+ uncurry
+ Colored
+ (if (Set.member EncryptStorageKey x ||
+ Set.member EncryptCommunicationsKey x) &&
+ (Set.member SignDataKey x || Set.member CertifyKeysKey x)
+ then (Just Yellow, Just "both signing & encryption")
+ else (Just Green, Nothing))
+ x
+ colorizeKUFs True x =
+ uncurry
+ Colored
+ (if Set.member CertifyKeysKey x
+ then (Just Red, Just "certification-capable subkey")
+ else (if (Set.member EncryptStorageKey x ||
+ Set.member EncryptCommunicationsKey x) &&
+ Set.member SignDataKey x
+ then (Just Yellow, Just "both signing & encryption")
+ else (Just Green, Nothing)))
+ x
+ newestWith p = take 1 . sortOn (Down . take 1 . sigcts) . filter p -- FIXME: this is terrible
+ hasheds (SigV4 _ _ _ xs _ _ _) = xs
+ hasheds (SigV6 _ _ _ _ xs _ _ _) = xs
+ hasheds _ = []
+ checkSK ::
+ Fingerprint -> (Pkt, [SignaturePayload]) -> SubkeyReport
+ checkSK pf (PublicSubkeyPkt pkp, sigs) = checkSK' pf pkp sigs
+ checkSK pf (SecretSubkeyPkt pkp _, sigs) = checkSK' pf pkp sigs
+ checkSK' pf pkp sigs =
+ (\x -> x {skCrossCerts = ccr (map decolorize (skUsageFlags x)) sigs})
+ SubkeyReport
+ { skFingerprint = colorizeF pf (fingerprint pkp)
+ , skVer = colorizeKV (_keyVersion pkp)
+ , skCreationTime = _timestamp pkp
+ , skAlgorithmAndSize = kasIt pkp
+ , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)
+ , skRevocationSigWeakDigests =
+ subkeyRevocationSigWeakDigests pkp sigs
+ , skUsageFlags = kufs True (filter isSKBindingSig sigs)
+ , skCrossCerts = CrossCertReport (Colored Nothing Nothing False) []
+ }
+ hasEncryptionCapableSubkey skrs =
+ if any
+ ((\x ->
+ Set.member EncryptStorageKey x ||
+ Set.member EncryptCommunicationsKey x) .
+ decolorize)
+ skrs
+ then Colored (Just Green) Nothing True
+ else Colored
+ (Just Red)
+ (Just "no encryption-capable subkey present")
+ False
+ embeddedSigs =
+ filter isPKBindingSig . concatMap getEmbeds . filter isSKBindingSig
+ getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
+ getEmbeds _ = []
+ getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]
+ getEmbed _ = []
+ ccr kufs sigs =
+ CrossCertReport (colorES kufs sigs) (map (colorizeHA . hashAlgo) sigs)
+ colorES kufs sigs =
+ case ( null (embeddedSigs sigs)
+ , any (Set.member SignDataKey) kufs
+ , any (Set.member AuthKey) kufs) of
+ (True, True, True) ->
+ Colored
+ (Just Red)
+ (Just "signing- and auth-capable subkey without cross-cert")
+ False
+ (True, True, False) ->
+ Colored
+ (Just Red)
+ (Just "signing-capable subkey without cross-cert")
+ False
+ (True, False, True) ->
+ Colored
+ (Just Yellow)
+ (Just "auth-capable subkey without cross-cert")
+ False
+ (False, True, True) -> Colored (Just Green) Nothing True
+ (False, True, False) -> Colored (Just Green) Nothing True
+ (False, False, True) -> Colored (Just Green) Nothing True
+ (False, False, False) -> Colored Nothing Nothing True
+ (True, _, _) -> Colored Nothing Nothing False
+ colorizeF pf fp =
+ uncurry
+ Colored
+ (if pf == fp
+ then (Just Red, Just "subkey has same fingerprint as primary key")
+ else (Just Green, Nothing))
+ fp
+ subkeyRevocationSigWeakDigests pkp =
+ mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp) .
+ filter isSubkeyRevocationSignature
+ mkSubkeyRevocationSigWeakDigestWarning pkp sig =
+ let ha = hashAlgo sig
+ in if isKnownWeakHashAlgorithm ha
+ then
+ Just
+ SubkeyRevocationDigestWarning
+ { srwHashAlgorithm = ha
+ , srwSubkeyFingerprint = renderFingerprint (fingerprint pkp)
+ , srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp))
+ , srwMessage =
+ "subkey revocation signature uses known-weak digest algorithm"
+ }
+ else Nothing
+
+prettyKeyReport :: POSIXTime -> TKUnknown -> Doc PPA.AnsiStyle
+prettyKeyReport cpt key = do
+ let keyReport = checkKey (Just cpt) key
+ execWriter $
+ tell
+ (linebreak <> pretty "Key has potential validity" <> colon <+>
+ pretty (keyStatus keyReport) <>
+ linebreak <>
+ pretty "Key has fingerprint" <>
+ colon <+>
+ pretty (SpacedFingerprint (keyFingerprint keyReport)) <>
+ linebreak <>
+ pretty "Checking to see if key is OpenPGPv4" <>
+ colon <+>
+ coloredToColor (pretty . show) (keyVer keyReport) <>
+ linebreak <>
+ (\kas ->
+ pretty "Checking the strength of your primary asymmetric key" <> colon <+>
+ coloredToColor pretty (pubkeyalgo kas) <+>
+ coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas))
+ (keyAlgorithmAndSize keyReport) <>
+ linebreak <>
+ pretty "Checking user-ID- and user-attribute-related items" <>
+ colon <>
+ mconcat
+ (map
+ (uidtrip (keyCreationTime keyReport) . gottabeabetterway)
+ (unFakeMap (keyUIDsAndUAts keyReport))) <>
+ linebreak <>
+ pretty "Checking subkeys" <>
+ colon <>
+ linebreak <>
+ indent
+ 2
+ (pretty "one of the subkeys is encryption-capable" <> colon <+>
+ coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)) <>
+ mconcat (map subkeyrep (keySubkeys keyReport)) <>
+ linebreak)
+ where
+ coloredToColor f (Colored (Just Green) _ x) = green (f x)
+ coloredToColor f (Colored (Just Yellow) _ x) = yellow (f x)
+ coloredToColor f (Colored (Just Red) _ x) = red (f x)
+ coloredToColor f (Colored Nothing _ x) = f x
+ uidtrip ts (u, ur)
+ | null (uidRevocationStatus ur) =
+ linebreak <> indent 2 (coloredToColor pretty (fmap T.unpack u)) <> colon <>
+ linebreak <>
+ indent
+ 4
+ (pretty "Self-sig hash algorithms" <> colon <+>
+ (list . map (coloredToColor pretty) . uidSelfSigHashAlgorithms) ur) <>
+ linebreak <>
+ indent
+ 4
+ (pretty "Preferred hash algorithms" <> colon <+>
+ mconcat (map (coloredToColor pretty) (uidPreferredHashAlgorithms ur))) <>
+ linebreak <>
+ indent
+ 4
+ (pretty "Key expiration times" <> colon <+>
+ mconcat
+ (map
+ (coloredToColor list . fmap (map (pretty . keyExp ts)))
+ (uidKeyExpirationTimes ur))) <>
+ linebreak <>
+ indent
+ 4
+ (pretty "Key usage flags" <> colon <+>
+ (list . map (coloredToColor (pretty . Set.toList)))
+ (uidKeyUsageFlags ur))
+ | otherwise =
+ linebreak <> indent 2 (coloredToColor pretty (fmap T.unpack u)) <> colon <+>
+ pretty "[revoked]" <>
+ linebreak <>
+ indent
+ 4
+ (pretty "Revocation code" <> colon <+>
+ list (map (pretty . revocationCode) (uidRevocationStatus ur))) <>
+ linebreak <>
+ indent
+ 4
+ (pretty "Revocation reason" <> colon <+>
+ list
+ (map
+ (pretty . T.unpack . revocationReason)
+ (uidRevocationStatus ur)))
+ keyExp ts ke =
+ (show . pretty) ke ++ " = " ++
+ formatTime
+ defaultTimeLocale
+ "%c"
+ (posixSecondsToUTCTime (realToFrac ts + realToFrac ke))
+ gottabeabetterway (a, Colored x y z) = (Colored x y a, z)
+ subkeyrep skr =
+ linebreak <>
+ indent
+ 2
+ (pretty "fpr" <> colon <+>
+ coloredToColor pretty (fmap SpacedFingerprint (skFingerprint skr))) <>
+ linebreak <>
+ indent 4 (pretty "version" <> colon <+> coloredToColor pretty (skVer skr)) <>
+ linebreak <>
+ indent 4 (pretty "timestamp" <> colon <+> pretty (skCreationTime skr)) <>
+ linebreak <>
+ indent
+ 4
+ ((\kas ->
+ pretty "algo/size" <> colon <+>
+ coloredToColor pretty (pubkeyalgo kas) <+>
+ coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas))
+ (skAlgorithmAndSize skr)) <>
+ linebreak <>
+ indent
+ 4
+ (pretty "binding sig hash algorithms" <> colon <+>
+ (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms) skr) <>
+ linebreak <>
+ indent
+ 4
+ (pretty "weak subkey revocation digests" <> colon <+>
+ if null (skRevocationSigWeakDigests skr)
+ then pretty "[]"
+ else
+ list
+ (map
+ (\w ->
+ red
+ (pretty (srwHashAlgorithm w) <> colon <+>
+ pretty (srwSubkeyFingerprint w) <> colon <+>
+ maybe (pretty "") pretty (srwSubkeyKeyID w)))
+ (skRevocationSigWeakDigests skr))) <>
+ linebreak <>
+ indent
+ 4
+ (pretty "usage flags" <> colon <+>
+ (list . map (coloredToColor (pretty . Set.toList))) (skUsageFlags skr)) <>
+ linebreak <>
+ indent
+ 4
+ (pretty "embedded cross-cert" <> colon <+>
+ (coloredToColor pretty . ccPresent . skCrossCerts) skr) <>
+ linebreak <>
+ indent
+ 4
+ (pretty "cross-cert hash algorithms" <> colon <+>
+ (list . map (coloredToColor pretty) . ccHashAlgorithms . skCrossCerts)
+ skr)
+
+jsonReport :: POSIXTime -> TKUnknown -> BL.ByteString
+jsonReport ps = A.encode . checkKey (Just ps)
+
+yamlReport :: POSIXTime -> TKUnknown -> B.ByteString
+yamlReport ps = Y.encode . (: []) . checkKey (Just ps)
+
+doLint :: LintOptions -> IO ()
+doLint o = do
+ cpt <- getPOSIXTime
+ keys <-
+ runConduitRes $ CB.sourceHandle stdin .| conduitGet get .|
+ conduitToTKsDropping .|
+ CL.consume
+ output (lintOutputFormat o) cpt keys
+ where
+ output Pretty cpt = mapM_ (PPA.putDoc . prettyKeyReport cpt)
+ output JSON cpt =
+ mapM_ (BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt)
+ output YAML cpt = mapM_ (B.putStr . yamlReport cpt)
+
+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
+
+knownWeakHashAlgorithms :: [HashAlgorithm]
+knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]
+
+isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool
+isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms
+
+isSubkeyRevocationSignature :: SignaturePayload -> Bool
+isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig
+isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig
+isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig
+isSubkeyRevocationSignature _ = False
+
+
diff --git a/HOpenPGP/Tools/Hokey/Options.hs b/HOpenPGP/Tools/Hokey/Options.hs
new file mode 100644
--- /dev/null
+++ b/HOpenPGP/Tools/Hokey/Options.hs
@@ -0,0 +1,146 @@
+-- Options.hs: hOpenPGP key tool command-line options
+-- 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 .
+
+module HOpenPGP.Tools.Hokey.Options
+ (
+ -- CanonicalizeOptions
+ FetchOptions(..)
+ , InjectSSHAgentOptions(..)
+ , LintOptions(..)
+ , fetchO
+ , injectSSHAgentO
+ , lintO
+ , FetchMethod(..)
+ , LintOutputFormat(..)
+ ) where
+
+import Codec.Encryption.OpenPGP.Serialize ()
+import Control.Applicative (optional)
+import HOpenPGP.Tools.Common.HKP (FetchValidationMethod(..))
+
+import Options.Applicative.Builder
+ ( argument
+ , auto
+ , help
+ , helpDoc
+ , long
+ , metavar
+ , option
+ , showDefault
+ , str
+ , value
+ )
+import Options.Applicative.Types (Parser)
+import Prettyprinter
+ ( hardline
+ , list
+ , pretty
+ )
+
+data LintOutputFormat
+ = Pretty
+ | JSON
+ | YAML
+ deriving (Bounded, Enum, Eq, Read, Show)
+
+data LintOptions =
+ LintOptions
+ { lintOutputFormat :: LintOutputFormat
+ }
+
+data FetchOptions =
+ FetchOptions
+ { keyServer :: String
+ , fetchMethod :: FetchMethod
+ , fetchValidation :: FetchValidationMethod
+ , fetchQuery :: String
+ }
+
+data InjectSSHAgentOptions =
+ InjectSSHAgentOptions
+ { injectSSHAgentFromFD :: Maybe Int
+ , injectSSHAgentSocket :: Maybe String
+ , injectSSHAgentComment :: Maybe String
+ }
+
+data FetchMethod
+ = HKP
+ | WKD
+ deriving (Bounded, Enum, Eq, Read, Show)
+
+lintO :: Parser LintOptions
+lintO =
+ LintOptions <$>
+ option
+ auto
+ (long "output-format" <> metavar "FORMAT" <> value Pretty <> showDefault <>
+ ofHelp)
+ where
+ ofHelp =
+ helpDoc . Just $ pretty "output format" <> hardline <>
+ list (map (pretty . show) ofchoices)
+ ofchoices = [minBound .. maxBound] :: [LintOutputFormat]
+
+fetchO :: Parser FetchOptions
+fetchO =
+ FetchOptions <$>
+ option
+ str
+ (long "keyserver" <> metavar "URL" <>
+ value "http://pool.sks-keyservers.net:11371" <>
+ showDefault <>
+ help "HKP server (used only when --method=HKP)") <*>
+ option
+ auto
+ (long "method" <> metavar "METHOD" <> value HKP <> showDefault <> fmHelp) <*>
+ option
+ auto
+ (long "validation-method" <> metavar "METHOD" <>
+ value MatchPrimaryKeyFingerprint <>
+ showDefault <>
+ vmHelp) <*>
+ argument str (metavar "QUERY")
+ where
+ fmHelp =
+ helpDoc . Just $ pretty "fetch method" <> hardline <>
+ list (map (pretty . show) fmchoices)
+ fmchoices = [minBound .. maxBound] :: [FetchMethod]
+ vmHelp =
+ helpDoc . Just $ pretty "validation method" <> hardline <>
+ list (map (pretty . show) vmchoices)
+ vmchoices = [minBound .. maxBound] :: [FetchValidationMethod]
+
+injectSSHAgentO :: Parser InjectSSHAgentOptions
+injectSSHAgentO =
+ InjectSSHAgentOptions <$>
+ optional
+ (option
+ auto
+ (long "from-fd" <>
+ metavar "FD" <>
+ help "read binary gpg --export-secret-keys bytes from this already-open file descriptor")) <*>
+ optional
+ (option
+ str
+ (long "ssh-agent-socket" <>
+ metavar "PATH" <> help "path to ssh-agent socket (defaults to SSH_AUTH_SOCK)")) <*>
+ optional
+ (option
+ str
+ (long "comment" <>
+ metavar "TEXT" <> help "comment string stored with the injected SSH identity"))
diff --git a/HOpenPGP/Tools/Lexer.x b/HOpenPGP/Tools/Lexer.x
deleted file mode 100644
--- a/HOpenPGP/Tools/Lexer.x
+++ /dev/null
@@ -1,175 +0,0 @@
-{
-{-# OPTIONS -w #-}
-module HOpenPGP.Tools.Lexer
-( alexEOF
-, alexSetInput
-, alexGetInput
-, alexError
-, alexScan
-, ignorePendingBytes
-, alexGetStartCode
-, runAlex
-, Alex(..)
-, Token(..)
-, AlexReturn(..)
-, AlexPosn(..)
-) where
-
-import Prelude hiding (lex)
-import Numeric (readHex)
-import Codec.Encryption.OpenPGP.Types (Fingerprint(..), EightOctetKeyId(..))
-
-}
-
-%wrapper "monad"
-
-$digit = 0-9
-$hexdigit = [0-9A-Fa-f]
-
-tokens :-
- $white+ ;
- a { lex' TokenA }
- and { lex' TokenAnd }
- any { lex' TokenAny }
- every { lex' TokenEvery }
- not { lex' TokenNot }
- now { lex' TokenNow }
- one { lex' TokenOne }
- or { lex' TokenOr }
- subkey { lex' TokenSubkey }
- tag { lex' TokenTag }
- of { lex' TokenOf }
- \=\= { lex' TokenEq }
- \= { lex' TokenEq }
- equals { lex' TokenEq }
- \< { lex' TokenLt }
- \> { lex' TokenGt }
- \( { lex' TokenLParen }
- \) { lex' TokenRParen }
- contains { lex' TokenContains }
- pkversion { lex' TokenPKVersion }
- sigversion { lex' TokenSigVersion }
- [Ss]ig[Tt]ype { lex' TokenSigType }
- [Pp][Kk][Aa]lgo { lex' TokenPKAlgo }
- [Ss]ig[Pp][Kk][Aa]lgo { lex' TokenSigPKAlgo }
- [Hh]ash[Aa]lgo { lex' TokenHashAlgo }
- [Rr][Ss][Aa] { lex' TokenRSA }
- [Dd][Ss][Aa] { lex' TokenDSA }
- [Ee]l[Gg]amal { lex' TokenElgamal }
- [Ee][Cc][Dd][Ss][Aa] { lex' TokenECDSA }
- [Ee][Cc][Dd][Hh] { lex' TokenECDH }
- [Dd][Hh] { lex' TokenDH }
- [Bb]inary { lex' TokenBinary }
- [Cc]anonical[Tt]ext { lex' TokenCanonicalText }
- [Ss]tandalone { lex' TokenStandalone }
- [Gg]eneric[Cc]ert { lex' TokenGenericCert }
- [Pp]ersona[Cc]ert { lex' TokenPersonaCert }
- [Cc]asual[Cc]ert { lex' TokenCasualCert }
- [Pp]ositive[Cc]ert { lex' TokenPositiveCert }
- [Ss]ubkey[Bb]inding[Ss]ig { lex' TokenSubkeyBindingSig }
- [Pp]rimary[Kk]ey[Bb]inding[Ss]ig { lex' TokenPrimaryKeyBindingSig }
- [Ss]ignature[Dd]irectly[Oo]n[Aa][Kk]ey { lex' TokenSignatureDirectlyOnAKey }
- [Kk]ey[Rr]evocation[Ss]ig { lex' TokenKeyRevocationSig }
- [Ss]ubkey[Rr]evocation[Ss]ig { lex' TokenSubkeyRevocationSig }
- [Cc]ert[Rr]evocation[Ss]ig { lex' TokenCertRevocationSig }
- [Tt]imestamp[Ss]ig { lex' TokenTimestampSig }
- [Mm][Dd]5 { lex' TokenMD5 }
- [Ss][Hh][Aa]1 { lex' TokenSHA1 }
- [Rr][Ii][Pp][Ee][Mm][Dd]160 { lex' TokenRIPEMD160 }
- [Ss][Hh][Aa]256 { lex' TokenSHA256 }
- [Ss][Hh][Aa]384 { lex' TokenSHA384 }
- [Ss][Hh][Aa]512 { lex' TokenSHA512 }
- [Ss][Hh][Aa]224 { lex' TokenSHA224 }
- [Uu][Ii][Dd]s { lex' TokenUids }
- keysize { lex' TokenKeysize }
- length { lex' TokenLength }
- timestamp { lex' TokenTimestamp }
- fingerprint { lex' TokenFingerprint }
- keyid { lex' TokenKeyID }
- [Ss]ig[Cc]reation[Tt]ime { lex' TokenSigCreationTime }
- $hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{4} { lex (TokenFpr . read) }
- 0x$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{4} { lex (TokenFpr . read . drop 2) }
- $hexdigit{8}$hexdigit{8} { lex (TokenLongID . Right . read) }
- 0x$hexdigit{8}$hexdigit{8} { lex (TokenLongID . Right . read . drop 2) }
- $digit+ { lex (TokenInt . fromIntegral . read) }
- $hexdigit+ { lex (TokenInt . fromIntegral . fst . head . readHex) }
- 0x$hexdigit+ { lex (TokenInt . fromIntegral . fst . head . readHex . drop 2) }
- \".*\" { lex (TokenStr . ((zipWith const . drop 1) <*> (drop 2))) }
-
-{
-data Token
- = TokenTag
- | TokenAfter
- | TokenAnd
- | TokenAny
- | TokenBefore
- | TokenNot
- | TokenNow
- | TokenOr
- | TokenInt Integer
- | TokenEq
- | TokenLt
- | TokenGt
- | TokenLParen
- | TokenRParen
- | TokenEOF
- | TokenPKVersion
- | TokenSigVersion
- | TokenSigType
- | TokenPKAlgo
- | TokenSigPKAlgo
- | TokenHashAlgo
- | TokenRSA
- | TokenDSA
- | TokenElgamal
- | TokenECDSA
- | TokenECDH
- | TokenDH
- | TokenBinary
- | TokenCanonicalText
- | TokenStandalone
- | TokenGenericCert
- | TokenPersonaCert
- | TokenCasualCert
- | TokenPositiveCert
- | TokenSubkeyBindingSig
- | TokenPrimaryKeyBindingSig
- | TokenSignatureDirectlyOnAKey
- | TokenKeyRevocationSig
- | TokenSubkeyRevocationSig
- | TokenCertRevocationSig
- | TokenTimestampSig
- | TokenMD5
- | TokenSHA1
- | TokenRIPEMD160
- | TokenSHA256
- | TokenSHA384
- | TokenSHA512
- | TokenSHA224
- | TokenKeysize
- | TokenTimestamp
- | TokenFingerprint
- | TokenKeyID
- | TokenFpr Fingerprint
- | TokenLongID (Either String EightOctetKeyId)
- | TokenLength
- | TokenEvery
- | TokenOne
- | TokenOf
- | TokenContains
- | TokenUids
- | TokenStr String
- | TokenA
- | TokenSubkey
- | TokenSigCreationTime
- deriving (Eq,Show)
-
-alexEOF = return TokenEOF
-
-lex :: (String -> a) -> AlexAction a
-lex f = \(_,_,_,s) i -> return (f (take i s))
-
-lex' :: a -> AlexAction a
-lex' = lex . const
-
-}
diff --git a/HOpenPGP/Tools/Parser.y b/HOpenPGP/Tools/Parser.y
deleted file mode 100644
--- a/HOpenPGP/Tools/Parser.y
+++ /dev/null
@@ -1,229 +0,0 @@
-{
-{-# OPTIONS -w #-}
-module HOpenPGP.Tools.Parser( parseTKExp, parsePExp ) where
-import Codec.Encryption.OpenPGP.Types
--- import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..))
-import HOpenPGP.Tools.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, spGetSCT, pUsingPKP, pUsingSP, maybeR)
-
-import HOpenPGP.Tools.Lexer
-
-import Control.Applicative (liftA2)
-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
-import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
-import Control.Error.Util (hush)
-import Control.Monad.Loops (allM, anyM)
-import Control.Monad.Trans.Reader (ask, reader, Reader, withReader)
-import Data.List (isInfixOf)
-import qualified Data.Text as T
-import Prettyprinter (pretty)
-
-}
-
-%name parseTK Exp
-%name parseP CFExp
-%tokentype { Token }
-%monad { Alex }
-%lexer { lexwrap } { TokenEOF }
-%error { happyError }
-%token
- a { TokenA }
- and { TokenAnd }
- any { TokenAny }
- contains { TokenContains }
- every { TokenEvery }
- not { TokenNot }
- now { TokenNow }
- of { TokenOf }
- one { TokenOne }
- or { TokenOr }
- subkey { TokenSubkey }
- tag { TokenTag }
- int { TokenInt $$ }
- '=' { TokenEq }
- '<' { TokenLt }
- '>' { TokenGt }
- '(' { TokenLParen }
- ')' { TokenRParen }
- pkversion { TokenPKVersion }
- sigversion { TokenSigVersion }
- sigtype { TokenSigType }
- pkalgo { TokenPKAlgo }
- sigpkalgo { TokenSigPKAlgo }
- hashalgo { TokenHashAlgo }
- rsa { TokenRSA }
- dsa { TokenDSA }
- elgamal { TokenElgamal }
- ecdsa { TokenECDSA }
- ecdh { TokenECDH }
- dh { TokenDH }
- binary { TokenBinary }
- canonicaltext { TokenCanonicalText }
- standalone { TokenStandalone }
- genericcert { TokenGenericCert }
- personacert { TokenPersonaCert }
- casualcert { TokenCasualCert }
- positivecert { TokenPositiveCert }
- subkeybindingsig { TokenSubkeyBindingSig }
- primarykeybindingsig { TokenPrimaryKeyBindingSig }
- signaturedirectlyonakey { TokenSignatureDirectlyOnAKey }
- keyrevocationsig { TokenKeyRevocationSig }
- subkeyrevocationsig { TokenSubkeyRevocationSig }
- certrevocationsig { TokenCertRevocationSig }
- timestampsig { TokenTimestampSig }
- md5 { TokenMD5 }
- sha1 { TokenSHA1 }
- ripemd160 { TokenRIPEMD160 }
- sha256 { TokenSHA256 }
- sha384 { TokenSHA384 }
- sha512 { TokenSHA512 }
- sha224 { TokenSHA224 }
- keysize { TokenKeysize }
- timestamp { TokenTimestamp }
- fingerprint { TokenFingerprint }
- keyid { TokenKeyID }
- sigcreationtime { TokenSigCreationTime }
- fpr { TokenFpr $$ }
- longid { TokenLongID $$ }
- length { TokenLength }
- str { TokenStr $$ }
- uids { TokenUids }
-
-%%
-
-Exp : any { return True }
- | not Exp { fmap not $2 }
- | Exp and Exp { liftA2 (&&) $1 $3 }
- | Exp or Exp { liftA2 (||) $1 $3 }
- | PExp { tkUsingPKP $1 }
- | TExp { $1 }
-
-PExp : pkversion PIOp int { $2 (reader pkpGetPKVersion) (return $3) }
- | pkalgo PIOp Ppkalgos { $2 (reader pkpGetPKAlgo) (return $3) }
- | keysize PIOp int { $2 (reader pkpGetKeysize) (return $3) }
- | timestamp PIOp int { $2 (reader pkpGetTimestamp) (return $3) }
- | fingerprint PSOp Pfingerprint { $2 (reader (show . pretty . pkpGetFingerprint)) (return $3) }
- | keyid PSOp Plongid { $2 (reader pkpGetEOKI) (return $3) }
-
-TExp : every one of uids AATOp str { withReader tkGetUIDs (anyOrAll allM ($5 (return (T.pack $6)))) }
- | any one of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($5 (return (T.pack $6)))) }
- | any of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($4 (return (T.pack $5)))) }
- | a subkey PExp { withReader tkGetSubs (anyReader $3) }
-
-PIOp : '=' { liftA2 (==) }
- | '<' { liftA2 (<) }
- | '>' { liftA2 (>) }
-
-PSOp : '=' { liftA2 (==) }
- | contains { liftA2 (flip isInfixOf) }
-
-AATOp : '=' { liftA2 (==) }
- | contains { liftA2 T.isInfixOf }
-
-Ppkalgos : rsa { fromIntegral (fromFVal RSA) }
- | dsa { fromIntegral (fromFVal DSA) }
- | elgamal { fromIntegral (fromFVal ElgamalEncryptOnly) }
- | ecdsa { fromIntegral (fromFVal ECDSA) }
- | ecdh { fromIntegral (fromFVal ECDH) }
- | dh { fromIntegral (fromFVal DH) }
- | int { fromIntegral $1 }
-
-Pfingerprint : fpr { (show . pretty) $1 }
-
-Plongid : longid { either (const "BROKEN") show $1 }
-
-CFExp : any { return True }
- | not CFExp { fmap not $2 }
- | CFExp and CFExp { liftA2 (&&) $1 $3 }
- | CFExp or CFExp { liftA2 (||) $1 $3 }
- | OExp { $1 }
- | SPExp { $1 }
- | PExp { pUsingPKP (maybeR True $1) }
-
-OExp : tag OIOp int { $2 (reader oGetTag) (return $3) }
- | length OIOp int { $2 (reader oGetLength) (return $3) }
-
-OIOp : '=' { liftA2 (==) }
- | '<' { liftA2 (<) }
- | '>' { liftA2 (>) }
-
-SPExp : sigversion SIOp int { $2 (reader spGetSigVersion) (return (Just $3)) }
- | sigtype SIOp Ssigtypes { $2 (reader spGetSigType) (return (Just $3)) }
- | sigpkalgo SIOp Spkalgos { $2 (reader spGetPKAlgo) (return (Just $3)) }
- | hashalgo SIOp Shashalgos { $2 (reader spGetHashAlgo) (return (Just $3)) }
- | sigcreationtime SIOp Stimespec { $2 (reader spGetSCT) (return (Just $3)) }
-
-SIOp : '=' { liftA2 (==) }
- | '<' { liftA2 (<) }
- | '>' { liftA2 (>) }
-
-Ssigtypes : binary { fromIntegral (fromFVal BinarySig) }
- | canonicaltext { fromIntegral (fromFVal CanonicalTextSig) }
- | standalone { fromIntegral (fromFVal StandaloneSig) }
- | genericcert { fromIntegral (fromFVal GenericCert) }
- | personacert { fromIntegral (fromFVal PersonaCert) }
- | casualcert { fromIntegral (fromFVal CasualCert) }
- | positivecert { fromIntegral (fromFVal PositiveCert) }
- | subkeybindingsig { fromIntegral (fromFVal SubkeyBindingSig) }
- | primarykeybindingsig { fromIntegral (fromFVal PrimaryKeyBindingSig) }
- | signaturedirectlyonakey { fromIntegral (fromFVal SignatureDirectlyOnAKey) }
- | keyrevocationsig { fromIntegral (fromFVal KeyRevocationSig) }
- | subkeyrevocationsig { fromIntegral (fromFVal SubkeyRevocationSig) }
- | certrevocationsig { fromIntegral (fromFVal CertRevocationSig) }
- | timestampsig { fromIntegral (fromFVal TimestampSig) }
- | int { fromIntegral $1 }
-
-Spkalgos : rsa { fromIntegral (fromFVal RSA) }
- | dsa { fromIntegral (fromFVal DSA) }
- | elgamal { fromIntegral (fromFVal ElgamalEncryptOnly) }
- | ecdsa { fromIntegral (fromFVal ECDSA) }
- | ecdh { fromIntegral (fromFVal ECDH) }
- | dh { fromIntegral (fromFVal DH) }
- | int { fromIntegral $1 }
-
-Shashalgos : md5 { fromIntegral (fromFVal DeprecatedMD5) }
- | sha1 { fromIntegral (fromFVal SHA1) }
- | ripemd160 { fromIntegral (fromFVal RIPEMD160) }
- | sha256 { fromIntegral (fromFVal SHA256) }
- | sha384 { fromIntegral (fromFVal SHA384) }
- | sha512 { fromIntegral (fromFVal SHA512) }
- | sha224 { fromIntegral (fromFVal SHA224) }
- | int { fromIntegral $1 }
-
-Stimespec : now { 0 }
- | int { fromIntegral $1 }
-
-{
-lexwrap :: (Token -> Alex a) -> Alex a
-lexwrap cont = do
- t <- alexMonadScan'
- cont t
-
-alexMonadScan' = do
- inp <- alexGetInput
- sc <- alexGetStartCode
- case alexScan inp sc of
- AlexEOF -> alexEOF
- AlexError (pos, _, _, _) -> alexError (show pos)
- AlexSkip inp' len -> do
- alexSetInput inp'
- alexMonadScan'
- AlexToken inp' len action -> do
- alexSetInput inp'
- action (ignorePendingBytes inp) len
-
-getPosn :: Alex (Int,Int)
-getPosn = do
- (AlexPn _ l c,_,_,_) <- alexGetInput
- return (l,c)
-
-happyError :: Token -> Alex a
-happyError t = do
- (l,c) <- getPosn
- error (show l ++ ":" ++ show c ++ ": Parse error on Token: " ++ show t ++ "\n")
-
-parseTKExp :: String -> Either String (Reader TKUnknown Bool)
-parseTKExp s = runAlex s parseTK
-
-parsePExp :: String -> Either String (Reader Pkt Bool)
-parsePExp s = runAlex s parseP
-}
diff --git a/HOpenPGP/Tools/TKUtils.hs b/HOpenPGP/Tools/TKUtils.hs
deleted file mode 100644
--- a/HOpenPGP/Tools/TKUtils.hs
+++ /dev/null
@@ -1,94 +0,0 @@
--- 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 .
-
-module HOpenPGP.Tools.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
diff --git a/HOpenPGP/Tools/WKD.hs b/HOpenPGP/Tools/WKD.hs
deleted file mode 100644
--- a/HOpenPGP/Tools/WKD.hs
+++ /dev/null
@@ -1,183 +0,0 @@
--- WKD.hs: hOpenPGP key tool
--- Copyright © 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 .
-
-{-# LANGUAGE OverloadedStrings #-}
-
-module HOpenPGP.Tools.WKD
- ( fetchKeys
- , parseMailbox
- ) where
-
-import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
-import Codec.Encryption.OpenPGP.ASCIIArmor.Types
- ( Armor(Armor)
- , ArmorType(ArmorPublicKeyBlock)
- )
-import Codec.Encryption.OpenPGP.Types (TKUnknown(..))
-import Control.Arrow ((&&&))
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (ExceptT(..), throwE)
-import qualified Crypto.Hash as CH
-import qualified Crypto.Hash.Algorithms as CHA
-import Data.Binary (get)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as BC8
-import qualified Data.ByteString.Lazy as BL
-import Data.Bits ((.&.), (.|.), shiftL, shiftR)
-import Data.Conduit ((.|), runConduitRes)
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.List as CL
-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
-import Data.Conduit.Serialization.Binary (conduitGet)
-import Data.Either (rights)
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import Data.Time.Clock.POSIX (getPOSIXTime)
-import Data.Word (Word8)
-import HOpenPGP.Tools.HKP (FetchValidationMethod(..))
-import HOpenPGP.Tools.TKUtils (processTK)
-import Network.HTTP.Client
- ( Manager
- , Response(..)
- , httpLbs
- , newManager
- , parseUrlThrow
- , setQueryString
- )
-import Network.HTTP.Client.TLS (tlsManagerSettings)
-import Network.HTTP.Types.Status (ok200)
-
-fetchKeys ::
- FetchValidationMethod
- -> Text
- -> ExceptT String IO [TKUnknown]
-fetchKeys fvm mailbox = do
- parsedMailbox <- ExceptT . return $ parseMailbox mailbox
- manager <- liftIO $ newManager tlsManagerSettings
- response <- fetchWKD manager parsedMailbox
- body <-
- if responseStatus response == ok200
- then return (responseBody response)
- else throwE ("HTTP status: " ++ show (responseStatus response))
- validateAndFilterKeys fvm parsedMailbox body
-
-parseMailbox :: Text -> Either String (Text, Text)
-parseMailbox rawMailbox =
- let mailbox = T.strip rawMailbox
- parts = T.splitOn "@" mailbox
- in case parts of
- [localPart, domain]
- | T.null localPart -> Left "mailbox local part cannot be empty"
- | T.null domain -> Left "mailbox domain cannot be empty"
- | T.any (== ' ') mailbox -> Left "mailbox cannot contain spaces"
- | otherwise -> Right (localPart, T.toLower domain)
- _ -> Left "mailbox must contain exactly one @"
-
-fetchWKD ::
- Manager
- -> (Text, Text)
- -> ExceptT String IO (Response BL.ByteString)
-fetchWKD manager (localPart, domain) = do
- let localPartLower = T.toLower localPart
- hu = BC8.unpack . zbase32 . sha1 . TE.encodeUtf8 $ localPartLower
- advancedUrl =
- "https://openpgpkey." <>
- T.unpack domain <>
- "/.well-known/openpgpkey/" <> T.unpack domain <> "/hu/" <> hu
- directUrl =
- "https://" <> T.unpack domain <> "/.well-known/openpgpkey/hu/" <> hu
- mailboxParam = TE.encodeUtf8 localPartLower
- withMailbox req = setQueryString [("l", Just mailboxParam)] req
- advancedRequest <- liftIO $ parseUrlThrow advancedUrl
- advancedResponse <- liftIO $ httpLbs (withMailbox advancedRequest) manager
- if responseStatus advancedResponse == ok200
- then return advancedResponse
- else do
- directRequest <- liftIO $ parseUrlThrow directUrl
- liftIO $ httpLbs (withMailbox directRequest) manager
-
-validateAndFilterKeys ::
- FetchValidationMethod
- -> (Text, Text)
- -> BL.ByteString
- -> ExceptT String IO [TKUnknown]
-validateAndFilterKeys fvm mailbox body = do
- keys <- decodeWkdResponse body
- cpt <- liftIO getPOSIXTime
- let processedKeys = rights $ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
- mailboxFiltered = filter (mailboxMatchesKey mailbox . snd) processedKeys
- return $
- map fst $
- case fvm of
- AnySelfSigned -> processedKeys
- MatchPrimaryKeyFingerprint -> mailboxFiltered
- MatchPrimaryOrAnySubkeyFingerprint -> mailboxFiltered
-
-decodeWkdResponse :: BL.ByteString -> ExceptT String IO [TKUnknown]
-decodeWkdResponse body =
- if isArmored body
- then decodeArmored body
- else decodeBinary body
-
-decodeBinary :: BL.ByteString -> ExceptT String IO [TKUnknown]
-decodeBinary bytes =
- liftIO . runConduitRes $
- CB.sourceLbs bytes .| conduitGet get .| conduitToTKsDropping .| CL.consume
-
-decodeArmored :: BL.ByteString -> ExceptT String IO [TKUnknown]
-decodeArmored larmors = do
- bytestrings <- ExceptT . return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
- liftIO . runConduitRes $
- CB.sourceLbs bytestrings .| conduitGet get .| conduitToTKsDropping .| CL.consume
- where
- armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs
- armorToBS _ = mempty
-
-isArmored :: BL.ByteString -> Bool
-isArmored =
- BC8.isPrefixOf "-----BEGIN PGP PUBLIC KEY BLOCK-----" . BL.toStrict . BL.take 40
-
-mailboxMatchesKey :: (Text, Text) -> TKUnknown -> Bool
-mailboxMatchesKey (localPart, domain) tk =
- let mailbox = T.toLower (localPart <> "@" <> domain)
- bracketedMailbox = "<" <> mailbox <> ">"
- in any
- (\uid -> let lowered = T.toLower uid in lowered == mailbox || bracketedMailbox `T.isInfixOf` lowered)
- (map fst (_tkuUIDs tk))
-
-sha1 :: B.ByteString -> B.ByteString
-sha1 bs = BA.convert (CH.hashWith CHA.SHA1 bs :: CH.Digest CHA.SHA1)
-
-zbase32 :: B.ByteString -> B.ByteString
-zbase32 = BC8.pack . encodeZBase32 . B.unpack
-
-encodeZBase32 :: [Word8] -> String
-encodeZBase32 = go 0 0
- where
- alphabet = "ybndrfg8ejkmcpqxot1uwisza345h769"
- pick i = alphabet !! i
- go _ 0 [] = []
- go acc bits [] =
- [pick (fromIntegral (((acc `shiftL` (5 - bits)) .&. 31) :: Int))]
- go acc bits (x:xs)
- | bits >= 5 =
- pick (fromIntegral (((acc `shiftR` (bits - 5)) .&. 31) :: Int)) :
- go acc (bits - 5) (x : xs)
- | otherwise = go ((acc `shiftL` 8) .|. fromIntegral x) (bits + 8) xs
diff --git a/hkt.hs b/hkt.hs
--- a/hkt.hs
+++ b/hkt.hs
@@ -76,7 +76,7 @@
import Data.Tuple (swap)
import qualified Data.Yaml as Y
import GHC.Generics
-import HOpenPGP.Tools.Common
+import HOpenPGP.Tools.Common.Common
( banner
, keyMatchesEightOctetKeyId
, keyMatchesFingerprint
@@ -84,7 +84,7 @@
, versioner
, warranty
)
-import HOpenPGP.Tools.Parser (parseTKExp)
+import HOpenPGP.Tools.Common.Parser (parseTKExp)
import System.Directory (getHomeDirectory)
import System.Exit (exitFailure)
import Options.Applicative.Builder
@@ -139,11 +139,23 @@
grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TKUnknown]
grabMatchingKeys fp filt srch =
- parseFilterPredicateIO srch >>= \parsed ->
- case parsed of
- Left err -> dieHKT err
- Right ufp ->
- runConduitRes $ grabMatchingKeysConduit fp filt ufp srch .| CL.consume
+ 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 .| conduitToTKsDropping .| 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 :: [TKUnknown] -> IO PublicKeyring
grabMatchingPublicKeyring keys =
@@ -182,7 +194,10 @@
TKey
{ publickey = mkey (tk ^. tkuKey . _1)
, uids = tk ^. tkuUIDs ^.. traverse . _1
- , subkeys = map (mkey . \(PublicSubkeyPkt x, _) -> x) (tk ^. tkuSubs)
+ , subkeys = mapMaybe (\t -> case t of
+ (PublicSubkeyPkt x, _) -> Just (mkey x)
+ (SecretSubkeyPkt x _, _) -> Just (mkey x)
+ _ -> Nothing) (tk ^. tkuSubs)
}
where
mkey =
diff --git a/hokey.hs b/hokey.hs
--- a/hokey.hs
+++ b/hokey.hs
@@ -22,1221 +22,89 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
-import Codec.Encryption.OpenPGP.Expirations (getKeyExpirationTimesFromSignature)
-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
-import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)
-import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)
-import Codec.Encryption.OpenPGP.Ontology
- ( isCT
- , isCertRevocationSig
- , isKUF
- , isPHA
- , isPKBindingSig
- , isSKBindingSig
- )
-import Codec.Encryption.OpenPGP.Serialize ()
-import Codec.Encryption.OpenPGP.Types
-import Control.Applicative (optional)
-import Control.Arrow ((***))
-import Control.Error.Util (hush)
-import Control.Exception (bracket)
-import Control.Lens ((&), (^.), _1, _2, mapped, over)
-import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
-import Control.Monad.Trans.Writer.Lazy (execWriter, tell)
-import qualified Crypto.Hash as CH
-import qualified Crypto.Hash.Algorithms as CHA
-import qualified Crypto.PubKey.RSA as RSA
-import qualified Data.Aeson as A
-import Data.Binary (get, put)
-import Data.Binary.Get (getWord32be, runGet)
-import Data.Binary.Put (Put, putByteString, putLazyByteString, putWord32be, putWord8, runPut)
-import Data.Bits ((.&.), shiftR, testBit)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Base16 as Base16
-import qualified Data.ByteString.Char8 as BC8
-import qualified Data.ByteString.Lazy as BL
-import Data.Conduit ((.|), runConduitRes)
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.List as CL
-import Data.Conduit.OpenPGP.Keyring (AuthSecretSubkeyAtTime, authSecretSubkeyPrimaryUID, authSecretSubkeyValue, conduitToAuthSecretSubkeysAt, conduitToSecretTKs, conduitToTKsDropping)
-import Data.Conduit.Serialization.Binary (conduitGet, conduitPut)
-import Data.Foldable (find)
-import Data.List (elemIndex, findIndex, intercalate, nub, sort, sortOn)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
-import Data.Ord (Down(..))
-import Data.Semigroup (Semigroup, (<>))
-import qualified Data.Set as Set
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
-import Data.Time.Format (formatTime)
-import qualified Data.Word as Word
-import qualified Data.Yaml as Y
-import GHC.Generics
-import HOpenPGP.Tools.Common (banner, versioner, warranty)
-import HOpenPGP.Tools.HKP (FetchValidationMethod(..), rearmorKeys)
-import qualified HOpenPGP.Tools.HKP as HKP
-import HOpenPGP.Tools.TKUtils (processTK)
-import Network.Socket (Family(AF_UNIX), SockAddr(..), Socket, SocketType(Stream), close, connect, defaultProtocol, socket)
-import qualified Network.Socket.ByteString as NSB
-import System.Environment (lookupEnv)
-import System.Exit (exitFailure)
-import qualified HOpenPGP.Tools.WKD as WKD
-
-import Options.Applicative.Builder
- ( argument
- , auto
- , command
- , footerDoc
- , headerDoc
- , help
- , helpDoc
- , info
- , long
- , metavar
- , option
- , prefs
- , progDesc
- , showDefault
- , showHelpOnError
- , str
- , value
- )
-import Options.Applicative.Extra (customExecParser, helper, hsubparser)
-import Options.Applicative.Types (Parser)
-
-import Data.Time.Locale.Compat (defaultTimeLocale)
-import System.IO
- ( BufferMode(..)
- , Handle
- , hFlush
- , hPutStrLn
- , hSetBuffering
- , stderr
- , stdin
- , stdout
- )
-
-import Prettyprinter
- ( Doc
- , (<+>)
- , annotate
- , colon
- , defaultLayoutOptions
- , flatAlt
- , hardline
- , indent
- , layoutPretty
- , line
- , list
- , pretty
- )
-import qualified Prettyprinter.Render.Terminal as PPA
-
-linebreak = flatAlt line mempty
-
-green = annotate (PPA.color PPA.Green)
-
-yellow = annotate (PPA.color PPA.Yellow)
-
-red = annotate (PPA.color PPA.Red)
-
-data KAS =
- KAS
- { pubkeyalgo :: Colored PubKeyAlgorithm
- , pubkeysize :: Colored (Maybe Int)
- , stringrep :: String
- }
- deriving (Generic)
-
-data Color
- = Green
- | Yellow
- | Red
- deriving (Eq, Generic, Ord)
-
-data Colored a =
- Colored
- { color :: Maybe Color
- , explanation :: Maybe String
- , val :: a
- }
- deriving (Functor, Generic)
-
-newtype FakeMap a b =
- FakeMap
- { unFakeMap :: [(a, b)]
- }
-
-data KeyReport =
- KeyReport
- { keyStatus :: String
- , keyFingerprint :: Fingerprint
- , keyVer :: Colored KeyVersion
- , keyCreationTime :: ThirtyTwoBitTimeStamp
- , keyAlgorithmAndSize :: KAS
- , keyUIDsAndUAts :: FakeMap Text (Colored UIDReport)
- , keyBestOf :: Maybe UIDReport
- , keySubkeys :: [SubkeyReport]
- , keyHasEncryptionCapableSubkey :: Colored Bool
- }
- deriving (Generic)
-
-data UIDReport =
- UIDReport
- { uidSelfSigHashAlgorithms :: [Colored HashAlgorithm]
- , uidPreferredHashAlgorithms :: [Colored [HashAlgorithm]]
- , uidKeyExpirationTimes :: [Colored [ThirtyTwoBitDuration]]
- , uidKeyUsageFlags :: [Colored (Set.Set KeyFlag)]
- , uidRevocationStatus :: [RevocationStatus]
- }
- deriving (Generic)
-
-data SubkeyReport =
- SubkeyReport
- { skFingerprint :: Colored Fingerprint
- , skVer :: Colored KeyVersion
- , skCreationTime :: ThirtyTwoBitTimeStamp
- , skAlgorithmAndSize :: KAS
- , skBindingSigHashAlgorithms :: [Colored HashAlgorithm]
- , skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning]
- , skUsageFlags :: [Colored (Set.Set KeyFlag)]
- , skCrossCerts :: CrossCertReport
- }
- deriving (Generic)
-
-data SubkeyRevocationDigestWarning =
- SubkeyRevocationDigestWarning
- { srwHashAlgorithm :: HashAlgorithm
- , srwSubkeyFingerprint :: String
- , srwSubkeyKeyID :: Maybe String
- , srwMessage :: String
- }
- deriving (Generic)
-
-data CrossCertReport =
- CrossCertReport
- { ccPresent :: Colored Bool
- , ccHashAlgorithms :: [Colored HashAlgorithm]
- }
- deriving (Generic)
-
-data RevocationStatus =
- RevocationStatus
- { isRevoked :: Bool
- , revocationCode :: String
- , revocationReason :: Text
- }
- deriving (Generic)
-
-instance A.ToJSON KAS
-
-instance A.ToJSON Color
-
-instance (A.ToJSON a) => A.ToJSON (Colored a)
-
-instance A.ToJSON KeyReport
-
-instance A.ToJSON UIDReport
-
-instance A.ToJSON SubkeyReport
-
-instance A.ToJSON SubkeyRevocationDigestWarning
-
-instance A.ToJSON CrossCertReport
-
-instance A.ToJSON b => A.ToJSON (FakeMap Text b) where
- toJSON = A.toJSON . Map.fromList . unFakeMap
-
-instance A.ToJSON RevocationStatus
-
-instance Semigroup UIDReport where
- (<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') =
- UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e')
-
-instance Monoid UIDReport where
- mempty = UIDReport [] [] [] [] []
- mappend = (<>)
-
-checkKey :: Maybe POSIXTime -> TKUnknown -> KeyReport
-checkKey mpt key =
- (\x ->
- x
- { keyBestOf = populateBestOf x
- , keyHasEncryptionCapableSubkey =
- hasEncryptionCapableSubkey (concatMap skUsageFlags (keySubkeys x))
- })
- KeyReport
- { keyStatus = either id (const "good") processedTK
- , keyFingerprint = key ^. tkuKey . _1 & fingerprint
- , keyVer = key ^. tkuKey . _1 & _keyVersion & colorizeKV
- , keyCreationTime = key ^. tkuKey . _1 & _timestamp
- , keyAlgorithmAndSize = kasIt (key ^. tkuKey . _1)
- , keyUIDsAndUAts =
- FakeMap
- (map (\(x, y) -> (x, uidr (Just x) y)) (processedOrOrig ^. tkuUIDs) ++
- map (uatspsToText *** uidr Nothing) (processedOrOrig ^. tkuUAts))
- , keyBestOf = Nothing
- , keySubkeys =
- map (checkSK (key ^. tkuKey . _1 & fingerprint)) (key ^. tkuSubs)
- , keyHasEncryptionCapableSubkey = Colored Nothing Nothing False
- }
- where
- processedOrOrig = either (const key) id processedTK
- processedTK = processTK mpt key
- kasIt :: SomePKPayload -> KAS
- kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize)
- kasIt' :: PubKeyAlgorithm -> Either String Int -> KAS
- kasIt' pka epks =
- KAS
- { pubkeyalgo = colorizePKA pka
- , pubkeysize = colorizePKS pka epks
- , stringrep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka)
- }
- colorizeKV kv =
- uncurry
- Colored
- (if kv == V4
- then (Just Green, Nothing)
- else (Just Red, Just "not a V4 key"))
- kv
- colorizePKA pka
- | pka `elem` [RSA, EdDSA, ECDH] = Colored (Just Green) Nothing pka
- | otherwise =
- Colored
- (Just Yellow)
- (Just "public key algorithm neither RSA nor EdDSA")
- pka
- colorizePKS pka epks = uncurry Colored (colorizePKS' pka epks) (hush epks)
- colorizePKS' pka (Right pks)
- | pka `elem` [EdDSA, ECDH] && pks >= 256 = (Just Green, Nothing)
- | pka `elem` [EdDSA, ECDH] =
- (Just Yellow, Just "Public key size under 256 bits")
- | pka == RSA && pks >= 3072 = (Just Green, Nothing)
- | pka == RSA && pks >= 2048 =
- (Just Yellow, Just "Public key size between 2048 and 3072 bits")
- | pka == RSA = (Just Red, Just "Public key size under 2048 bits")
- | otherwise = (Nothing, Nothing)
- colorizePKS' _ (Left _) =
- (Just Red, Just "public key algorithm not understood")
- colorizePHAs x =
- uncurry
- Colored
- (if preferredWeakHash x
- then (Just Red, Just "weak hash with higher preference")
- else (Just Green, Nothing))
- x
- fSHA2Family = fi (`elem` [SHA512, SHA384, SHA256, SHA224])
- firstStrongSHA2 xs = fSHA2Family xs
- preferredWeakHash xs =
- any
- (\ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2 xs)
- knownWeakHashAlgorithms
- fi x y = fromMaybe maxBound (findIndex x y)
- colorizeKETs ct ts kes
- | null kes = Colored (Just Red) (Just "no expiration set") kes
- | any (\ke -> realToFrac ts + realToFrac ke < ct) kes =
- Colored (Just Red) (Just "expiration passed") kes
- | any (\ke -> realToFrac ts + realToFrac ke > ct + (5 * 31557600)) kes =
- Colored (Just Yellow) (Just "expiration too far in future") kes
- | otherwise = Colored (Just Green) Nothing kes
- eoki pkp
- | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
- | _keyVersion pkp == DeprecatedV3 &&
- elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
- hush . eightOctetKeyID $ pkp
- | otherwise = Nothing
- phas (SigV4 _ _ _ xs _ _ _) =
- colorizePHAs .
- concatMap (\(SigSubPacket _ (PreferredHashAlgorithms x)) -> x) $
- filter isPHA xs
- phas _ = Colored Nothing Nothing []
- has = map (colorizeHA . hashAlgo) . alleged
- colorizeHA ha =
- uncurry
- Colored
- (if isKnownWeakHashAlgorithm ha
- then (Just Red, Just "weak hash algorithm")
- else (Nothing, Nothing))
- ha
- sigcts (SigV4 _ _ _ xs _ _ _) =
- map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs
- alleged =
- filter
- (\x -> ((==) <$> sigissuer x <*> eoki (key ^. tkuKey . _1)) == Just True)
- uatspsToText = T.pack . uatspsToString
- uatspsToString us =
- ""
- uaspToString (ImageAttribute hdr d) =
- hdrToString hdr ++ ':' : show (BL.length d) ++ ':' :
- BC8.unpack (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
- uaspToString (OtherUASub t d) =
- "other-" ++ show t ++ ':' : show (BL.length d) ++ ':' :
- BC8.unpack (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
- hdrToString (ImageHV1 JPEG) = "jpeg"
- hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)
- uidr Nothing sps =
- Colored
- Nothing
- Nothing
- (UIDReport
- (has sps)
- (map phas sps)
- (map
- (colorizeKETs
- (fromMaybe 0 mpt)
- (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) .
- getKeyExpirationTimesFromSignature)
- sps -- should that be 0?
- )
- (kufs False sps)
- (findRevocationReason sps))
- uidr (Just u) sps =
- colorizeUID
- u
- (UIDReport
- (has sps)
- (map phas sps)
- (map
- (colorizeKETs
- (fromMaybe 0 mpt)
- (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) .
- getKeyExpirationTimesFromSignature)
- sps -- should that be 0?
- )
- (kufs False sps)
- (findRevocationReason sps))
- populateBestOf krep =
- Just
- (UIDReport <$> best . uidSelfSigHashAlgorithms <*> best .
- uidPreferredHashAlgorithms <*>
- best .
- uidKeyExpirationTimes <*>
- best .
- uidKeyUsageFlags <*>
- pure [] $
- mconcat (justTheUIDRs krep))
- justTheUIDRs = map (decolorize . snd) . unFakeMap . keyUIDsAndUAts
- best = take 1 . sortOn color
- decolorize (Colored _ _ x) = x
- colorizeUID u
- | '(' `elem` T.unpack u =
- Colored (Just Yellow) (Just "parenthesis in uid") -- FIXME: be more discerning
- | '<' `notElem` T.unpack u =
- Colored (Just Yellow) (Just "no left angle bracket in uid") -- FIXME: be more discerning
- | otherwise = Colored Nothing Nothing
- findRevocationReason = concatMap grabReasons . filter isCertRevocationSig
- grabReasons (SigV4 CertRevocationSig _ _ has _ _ _) =
- mapMaybe (grabReasons' . _sspPayload) has
- grabReasons _ = []
- grabReasons' (ReasonForRevocation a b) =
- Just (RevocationStatus True (show a) b)
- grabReasons' _ = Nothing
- kufs s =
- map
- (colorizeKUFs s . (\(SigSubPacket _ (KeyFlags x)) -> x) .
- fromMaybe undefined .
- find isKUF .
- hasheds) .
- newestWith (any isKUF . hasheds)
- colorizeKUFs False x =
- uncurry
- Colored
- (if (Set.member EncryptStorageKey x ||
- Set.member EncryptCommunicationsKey x) &&
- (Set.member SignDataKey x || Set.member CertifyKeysKey x)
- then (Just Yellow, Just "both signing & encryption")
- else (Just Green, Nothing))
- x
- colorizeKUFs True x =
- uncurry
- Colored
- (if Set.member CertifyKeysKey x
- then (Just Red, Just "certification-capable subkey")
- else (if (Set.member EncryptStorageKey x ||
- Set.member EncryptCommunicationsKey x) &&
- Set.member SignDataKey x
- then (Just Yellow, Just "both signing & encryption")
- else (Just Green, Nothing)))
- x
- newestWith p = take 1 . sortOn (Down . take 1 . sigcts) . filter p -- FIXME: this is terrible
- hasheds (SigV4 _ _ _ xs _ _ _) = xs
- hasheds _ = []
- checkSK ::
- Fingerprint -> (Pkt, [SignaturePayload]) -> SubkeyReport
- checkSK pf (PublicSubkeyPkt pkp, sigs) = checkSK' pf pkp sigs
- checkSK pf (SecretSubkeyPkt pkp _, sigs) = checkSK' pf pkp sigs
- checkSK' pf pkp sigs =
- (\x -> x {skCrossCerts = ccr (map decolorize (skUsageFlags x)) sigs})
- SubkeyReport
- { skFingerprint = colorizeF pf (fingerprint pkp)
- , skVer = colorizeKV (_keyVersion pkp)
- , skCreationTime = _timestamp pkp
- , skAlgorithmAndSize = kasIt pkp
- , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)
- , skRevocationSigWeakDigests =
- subkeyRevocationSigWeakDigests pkp sigs
- , skUsageFlags = kufs True (filter isSKBindingSig sigs)
- , skCrossCerts = CrossCertReport (Colored Nothing Nothing False) []
- }
- hasEncryptionCapableSubkey skrs =
- if any
- ((\x ->
- Set.member EncryptStorageKey x ||
- Set.member EncryptCommunicationsKey x) .
- decolorize)
- skrs
- then Colored (Just Green) Nothing True
- else Colored
- (Just Red)
- (Just "no encryption-capable subkey present")
- False
- embeddedSigs =
- filter isPKBindingSig . concatMap getEmbeds . filter isSKBindingSig
- getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
- getEmbeds _ = []
- getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]
- getEmbed _ = []
- ccr kufs sigs =
- CrossCertReport (colorES kufs sigs) (map (colorizeHA . hashAlgo) sigs)
- colorES kufs sigs =
- case ( null (embeddedSigs sigs)
- , any (Set.member SignDataKey) kufs
- , any (Set.member AuthKey) kufs) of
- (True, True, True) ->
- Colored
- (Just Red)
- (Just "signing- and auth-capable subkey without cross-cert")
- False
- (True, True, False) ->
- Colored
- (Just Red)
- (Just "signing-capable subkey without cross-cert")
- False
- (True, False, True) ->
- Colored
- (Just Yellow)
- (Just "auth-capable subkey without cross-cert")
- False
- (False, True, True) -> Colored (Just Green) Nothing True
- (False, True, False) -> Colored (Just Green) Nothing True
- (False, False, True) -> Colored (Just Green) Nothing True
- (False, False, False) -> Colored Nothing Nothing True
- (True, _, _) -> Colored Nothing Nothing False
- colorizeF pf fp =
- uncurry
- Colored
- (if pf == fp
- then (Just Red, Just "subkey has same fingerprint as primary key")
- else (Just Green, Nothing))
- fp
- subkeyRevocationSigWeakDigests pkp =
- mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp) .
- filter isSubkeyRevocationSignature
- mkSubkeyRevocationSigWeakDigestWarning pkp sig =
- let ha = hashAlgo sig
- in if isKnownWeakHashAlgorithm ha
- then
- Just
- SubkeyRevocationDigestWarning
- { srwHashAlgorithm = ha
- , srwSubkeyFingerprint = renderFingerprint (fingerprint pkp)
- , srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp))
- , srwMessage =
- "subkey revocation signature uses known-weak digest algorithm"
- }
- else Nothing
-
-prettyKeyReport :: POSIXTime -> TKUnknown -> Doc PPA.AnsiStyle
-prettyKeyReport cpt key = do
- let keyReport = checkKey (Just cpt) key
- execWriter $
- tell
- (linebreak <> pretty "Key has potential validity" <> colon <+>
- pretty (keyStatus keyReport) <>
- linebreak <>
- pretty "Key has fingerprint" <>
- colon <+>
- pretty (SpacedFingerprint (keyFingerprint keyReport)) <>
- linebreak <>
- pretty "Checking to see if key is OpenPGPv4" <>
- colon <+>
- coloredToColor (pretty . show) (keyVer keyReport) <>
- linebreak <>
- (\kas ->
- pretty "Checking the strength of your primary asymmetric key" <> colon <+>
- coloredToColor pretty (pubkeyalgo kas) <+>
- coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas))
- (keyAlgorithmAndSize keyReport) <>
- linebreak <>
- pretty "Checking user-ID- and user-attribute-related items" <>
- colon <>
- mconcat
- (map
- (uidtrip (keyCreationTime keyReport) . gottabeabetterway)
- (unFakeMap (keyUIDsAndUAts keyReport))) <>
- linebreak <>
- pretty "Checking subkeys" <>
- colon <>
- linebreak <>
- indent
- 2
- (pretty "one of the subkeys is encryption-capable" <> colon <+>
- coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)) <>
- mconcat (map subkeyrep (keySubkeys keyReport)) <>
- linebreak)
- where
- coloredToColor f (Colored (Just Green) _ x) = green (f x)
- coloredToColor f (Colored (Just Yellow) _ x) = yellow (f x)
- coloredToColor f (Colored (Just Red) _ x) = red (f x)
- coloredToColor f (Colored Nothing _ x) = f x
- uidtrip ts (u, ur)
- | null (uidRevocationStatus ur) =
- linebreak <> indent 2 (coloredToColor pretty (fmap T.unpack u)) <> colon <>
- linebreak <>
- indent
- 4
- (pretty "Self-sig hash algorithms" <> colon <+>
- (list . map (coloredToColor pretty) . uidSelfSigHashAlgorithms) ur) <>
- linebreak <>
- indent
- 4
- (pretty "Preferred hash algorithms" <> colon <+>
- mconcat (map (coloredToColor pretty) (uidPreferredHashAlgorithms ur))) <>
- linebreak <>
- indent
- 4
- (pretty "Key expiration times" <> colon <+>
- mconcat
- (map
- (coloredToColor list . fmap (map (pretty . keyExp ts)))
- (uidKeyExpirationTimes ur))) <>
- linebreak <>
- indent
- 4
- (pretty "Key usage flags" <> colon <+>
- (list . map (coloredToColor (pretty . Set.toList)))
- (uidKeyUsageFlags ur))
- | otherwise =
- linebreak <> indent 2 (coloredToColor pretty (fmap T.unpack u)) <> colon <+>
- pretty "[revoked]" <>
- linebreak <>
- indent
- 4
- (pretty "Revocation code" <> colon <+>
- list (map (pretty . revocationCode) (uidRevocationStatus ur))) <>
- linebreak <>
- indent
- 4
- (pretty "Revocation reason" <> colon <+>
- list
- (map
- (pretty . T.unpack . revocationReason)
- (uidRevocationStatus ur)))
- keyExp ts ke =
- (show . pretty) ke ++ " = " ++
- formatTime
- defaultTimeLocale
- "%c"
- (posixSecondsToUTCTime (realToFrac ts + realToFrac ke))
- gottabeabetterway (a, Colored x y z) = (Colored x y a, z)
- subkeyrep skr =
- linebreak <>
- indent
- 2
- (pretty "fpr" <> colon <+>
- coloredToColor pretty (fmap SpacedFingerprint (skFingerprint skr))) <>
- linebreak <>
- indent 4 (pretty "version" <> colon <+> coloredToColor pretty (skVer skr)) <>
- linebreak <>
- indent 4 (pretty "timestamp" <> colon <+> pretty (skCreationTime skr)) <>
- linebreak <>
- indent
- 4
- ((\kas ->
- pretty "algo/size" <> colon <+>
- coloredToColor pretty (pubkeyalgo kas) <+>
- coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas))
- (skAlgorithmAndSize skr)) <>
- linebreak <>
- indent
- 4
- (pretty "binding sig hash algorithms" <> colon <+>
- (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms) skr) <>
- linebreak <>
- indent
- 4
- (pretty "weak subkey revocation digests" <> colon <+>
- if null (skRevocationSigWeakDigests skr)
- then pretty "[]"
- else
- list
- (map
- (\w ->
- red
- (pretty (srwHashAlgorithm w) <> colon <+>
- pretty (srwSubkeyFingerprint w) <> colon <+>
- maybe (pretty "") pretty (srwSubkeyKeyID w)))
- (skRevocationSigWeakDigests skr))) <>
- linebreak <>
- indent
- 4
- (pretty "usage flags" <> colon <+>
- (list . map (coloredToColor (pretty . Set.toList))) (skUsageFlags skr)) <>
- linebreak <>
- indent
- 4
- (pretty "embedded cross-cert" <> colon <+>
- (coloredToColor pretty . ccPresent . skCrossCerts) skr) <>
- linebreak <>
- indent
- 4
- (pretty "cross-cert hash algorithms" <> colon <+>
- (list . map (coloredToColor pretty) . ccHashAlgorithms . skCrossCerts)
- skr)
-
-jsonReport :: POSIXTime -> TKUnknown -> BL.ByteString
-jsonReport ps = A.encode . checkKey (Just ps)
-
-yamlReport :: POSIXTime -> TKUnknown -> B.ByteString
-yamlReport ps = Y.encode . (: []) . checkKey (Just ps)
-
-data LintOutputFormat
- = Pretty
- | JSON
- | YAML
- deriving (Bounded, Enum, Eq, Read, Show)
-
-data LintOptions =
- LintOptions
- { lintOutputFormat :: LintOutputFormat
- }
-
-data FetchOptions =
- FetchOptions
- { keyServer :: String
- , fetchMethod :: FetchMethod
- , fetchValidation :: FetchValidationMethod
- , fetchQuery :: String
- }
-
-data InjectSSHAgentOptions =
- InjectSSHAgentOptions
- { injectSSHAgentFromFD :: Maybe Int
- , injectSSHAgentSocket :: Maybe String
- , injectSSHAgentComment :: Maybe String
- }
-
-data FetchMethod
- = HKP
- | WKD
- deriving (Bounded, Enum, Eq, Read, Show)
-
-data Command
- = CmdLint LintOptions
- | CmdCanonicalize
- | CmdFetch FetchOptions
- | CmdInjectSSHAgent InjectSSHAgentOptions
-
-data InjectableAuthSubkey =
- InjectableAuthSubkey
- { injectableAuthSubkeyPKP :: SomePKPayload
- , injectableAuthSubkeySKA :: SKAddendum
- , injectableAuthSubkeyPrimaryUID :: Maybe Text
- }
-
-lintO :: Parser LintOptions
-lintO =
- LintOptions <$>
- option
- auto
- (long "output-format" <> metavar "FORMAT" <> value Pretty <> showDefault <>
- ofHelp)
- where
- ofHelp =
- helpDoc . Just $ pretty "output format" <> hardline <>
- list (map (pretty . show) ofchoices)
- ofchoices = [minBound .. maxBound] :: [LintOutputFormat]
-
-fetchO :: Parser FetchOptions
-fetchO =
- FetchOptions <$>
- option
- str
- (long "keyserver" <> metavar "URL" <>
- value "http://pool.sks-keyservers.net:11371" <>
- showDefault <>
- help "HKP server (used only when --method=HKP)") <*>
- option
- auto
- (long "method" <> metavar "METHOD" <> value HKP <> showDefault <> fmHelp) <*>
- option
- auto
- (long "validation-method" <> metavar "METHOD" <>
- value MatchPrimaryKeyFingerprint <>
- showDefault <>
- vmHelp) <*>
- argument str (metavar "QUERY")
- where
- fmHelp =
- helpDoc . Just $ pretty "fetch method" <> hardline <>
- list (map (pretty . show) fmchoices)
- fmchoices = [minBound .. maxBound] :: [FetchMethod]
- vmHelp =
- helpDoc . Just $ pretty "validation method" <> hardline <>
- list (map (pretty . show) vmchoices)
- vmchoices = [minBound .. maxBound] :: [FetchValidationMethod]
-
-injectSSHAgentO :: Parser InjectSSHAgentOptions
-injectSSHAgentO =
- InjectSSHAgentOptions <$>
- optional
- (option
- auto
- (long "from-fd" <>
- metavar "FD" <>
- help "read binary gpg --export-secret-keys bytes from this already-open file descriptor")) <*>
- optional
- (option
- str
- (long "ssh-agent-socket" <>
- metavar "PATH" <> help "path to ssh-agent socket (defaults to SSH_AUTH_SOCK)")) <*>
- optional
- (option
- str
- (long "comment" <>
- metavar "TEXT" <> help "comment string stored with the injected SSH identity"))
-
-dispatch :: Command -> IO ()
-dispatch (CmdFetch o) = banner' stderr >> hFlush stderr >> doFetch o
-dispatch (CmdLint o) = banner' stderr >> hFlush stderr >> doLint o
-dispatch CmdCanonicalize = banner' stderr >> hFlush stderr >> doCanonicalize
-dispatch (CmdInjectSSHAgent o) =
- banner' stderr >> hFlush stderr >> doInjectSSHAgent o
-
-main :: IO ()
-main = do
- hSetBuffering stderr LineBuffering
- customExecParser
- (prefs showHelpOnError)
- (info
- (helper <*> versioner "hokey" <*> cmd)
- (headerDoc (Just (banner "hokey")) <>
- progDesc "hOpenPGP Key utility" <>
- footerDoc (Just (warranty "hokey")))) >>=
- dispatch
-
-cmd :: Parser Command
-cmd =
- hsubparser
- (command
- "canonicalize"
- (info
- (pure CmdCanonicalize)
- (progDesc "arrange key components in a canonical ordering")) <>
- command
- "fetch"
- (info
- (CmdFetch <$> fetchO)
- (progDesc "fetch key(s) via HKP or WKD")) <>
- command
- "inject-ssh-agent"
- (info
- (CmdInjectSSHAgent <$> injectSSHAgentO)
- (progDesc "Read exported secret key bytes, pick an auth-capable subkey, and add it to ssh-agent")) <>
- command
- "lint"
- (info (CmdLint <$> lintO) (progDesc "check key(s) for 'best practices'")))
-
-doLint :: LintOptions -> IO ()
-doLint o = do
- cpt <- getPOSIXTime
- keys <-
- runConduitRes $ CB.sourceHandle stdin .| conduitGet get .|
- conduitToTKsDropping .|
- CL.consume
- output (lintOutputFormat o) cpt keys
- where
- output Pretty cpt = mapM_ (PPA.putDoc . prettyKeyReport cpt)
- output JSON cpt =
- mapM_ (BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt)
- output YAML cpt = mapM_ (B.putStr . yamlReport cpt)
-
-doCanonicalize :: IO ()
-doCanonicalize =
- runConduitRes $ CB.sourceHandle stdin .| conduitGet get .|
- conduitToTKsDropping .|
- CL.map canonicalize .|
- CL.map put .|
- conduitPut .|
- CB.sinkHandle stdout
- where
- canonicalize tk =
- tk
- { _tkuRevs = sort (_tkuRevs tk)
- , _tkuUIDs = indepthsort (_tkuUIDs tk)
- , _tkuUAts = indepthsort (_tkuUAts tk)
- , _tkuSubs = indepthsort (_tkuSubs tk)
- }
- indepthsort :: (Ord a, Ord b) => [(a, [b])] -> [(a, [b])]
- indepthsort = nub . sort . over (mapped . _2) sort
-
-doFetch :: FetchOptions -> IO ()
-doFetch o = do
- ekeys <-
- runExceptT $
- case fetchMethod o of
- HKP -> do
- fp <- ExceptT . return . parseFingerprint . T.pack $ fetchQuery o
- HKP.fetchKeys (keyServer o) (fetchValidation o) fp
- WKD -> WKD.fetchKeys (fetchValidation o) (T.pack (fetchQuery o))
- case ekeys of
- Left e -> hPutStrLn stderr $ "error fetching keys: " ++ e
- Right ks -> B.putStr $ rearmorKeys ks
-
-doInjectSSHAgent :: InjectSSHAgentOptions -> IO ()
-doInjectSSHAgent opts = do
- socketPath <- resolveSSHAgentSocketPath (injectSSHAgentSocket opts)
- input <- readInjectedSecretKeyMaterial opts
- cpt <- getPOSIXTime
- authCandidates <-
- runConduitRes $
- CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|
- conduitToAuthSecretSubkeysAt (posixSecondsToUTCTime cpt) .|
- CL.consume
- injectableCandidates <-
- if null authCandidates
- then inferInjectableAuthSubkeys cpt input
- else pure (map candidateFromAuthSecretSubkey authCandidates)
- whenEmpty injectableCandidates "inject-ssh-agent: no authentication-capable secret subkey found"
- selectedRequests <-
- selectInjectableAuthSubkeys
- (injectSSHAgentComment opts)
- injectableCandidates
- mapM_
- (\(selected, request) -> do
- sendAddIdentityToSSHAgent socketPath request
- hPutStrLn stderr $
- "inject-ssh-agent: added authentication subkey " ++
- renderFingerprint (fingerprint (injectableAuthSubkeyPKP selected)) ++
- " to ssh-agent")
- selectedRequests
-
-candidateFromAuthSecretSubkey :: AuthSecretSubkeyAtTime -> InjectableAuthSubkey
-candidateFromAuthSecretSubkey authSubkey =
- InjectableAuthSubkey
- { injectableAuthSubkeyPKP = authSecretSubkeyPKP authSubkey
- , injectableAuthSubkeySKA = authSecretSubkeySKA authSubkey
- , injectableAuthSubkeyPrimaryUID = authSecretSubkeyPrimaryUID authSubkey
- }
-
-inferInjectableAuthSubkeys ::
- POSIXTime -> BL.ByteString -> IO [InjectableAuthSubkey]
-inferInjectableAuthSubkeys _cpt input = do
- tks <-
- runConduitRes $
- CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|
- CL.consume
- pure (concatMap inferFromTK tks)
- where
- inferFromTK tk =
- let mPrimaryUID = fst <$> listToMaybe (_tkUIDs tk)
- in mapMaybe (inferFromSubkey mPrimaryUID) (_tkSubs tk)
- inferFromSubkey :: Maybe Text -> (KeyPkt k, [SignaturePayload]) -> Maybe InjectableAuthSubkey
- inferFromSubkey mPrimaryUID (KeyPktSecretSubkey pkp ska, sigs)
- | hasAuthCapability sigs =
- Just
- InjectableAuthSubkey
- { injectableAuthSubkeyPKP = pkp
- , injectableAuthSubkeySKA = ska
- , injectableAuthSubkeyPrimaryUID = mPrimaryUID
- }
- inferFromSubkey _ _ = Nothing
- hasAuthCapability sigs =
- any
- (Set.member AuthKey)
- (mapMaybe signatureKeyFlags (newestWithUsageFlags (filter isSKBindingSig sigs)))
- newestWithUsageFlags =
- take 1 . sortOn (Down . take 1 . sigCreationTimes) . filter (any isKUF . signatureHashedSubpackets)
- sigCreationTimes = mapMaybe sigCreationTimeFromSubpacket . signatureHashedSubpackets
- sigCreationTimeFromSubpacket (SigSubPacket _ (SigCreationTime ct)) = Just ct
- sigCreationTimeFromSubpacket _ = Nothing
- signatureHashedSubpackets (SigV4 _ _ _ hasheds _ _ _) = hasheds
- signatureHashedSubpackets (SigV6 _ _ _ _ hasheds _ _ _) = hasheds
- signatureHashedSubpackets _ = []
- signatureKeyFlags sig = do
- sp <- find isKUF (signatureHashedSubpackets sig)
- case sp of
- SigSubPacket _ (KeyFlags flags) -> Just flags
- _ -> Nothing
-
-resolveSSHAgentSocketPath :: Maybe String -> IO String
-resolveSSHAgentSocketPath (Just path) = pure path
-resolveSSHAgentSocketPath Nothing = do
- envPath <- lookupEnv "SSH_AUTH_SOCK"
- case envPath of
- Just path -> pure path
- Nothing ->
- failInject
- "inject-ssh-agent: SSH_AUTH_SOCK is not set; use --ssh-agent-socket"
-
-readInjectedSecretKeyMaterial :: InjectSSHAgentOptions -> IO BL.ByteString
-readInjectedSecretKeyMaterial opts = do
- chunks <-
- case injectSSHAgentFromFD opts of
- Nothing -> runConduitRes $ CB.sourceHandle stdin .| CL.consume
- Just fd
- | fd < 0 ->
- failInject "inject-ssh-agent: --from-fd must be a non-negative integer"
- | otherwise ->
- runConduitRes $ CB.sourceFile ("/dev/fd/" ++ show fd) .| CL.consume
- let input = BL.fromChunks chunks
- if BL.null input
- then
- failInject
- "inject-ssh-agent: no secret key bytes were provided on the selected input stream"
- else pure input
-
-selectInjectableAuthSubkeys ::
- Maybe String -> [InjectableAuthSubkey] -> IO [(InjectableAuthSubkey, BL.ByteString)]
-selectInjectableAuthSubkeys mComment candidates
- | null selectedRequests =
- failInject
- ("inject-ssh-agent: auth-capable subkeys were found, but none are supported for ssh-agent injection: " ++
- intercalate "; " (reverse errs))
- | otherwise = pure (reverse selectedRequests)
- where
- (errs, selectedRequests) = foldl' pick ([], []) candidates
- pick (accErrs, accSelected) candidate =
- case
- sshAddIdentityRequest
- (fromMaybe (defaultSSHComment candidate) mComment)
- (injectableAuthSubkeyPKP candidate)
- (injectableAuthSubkeySKA candidate) of
- Left err -> (err : accErrs, accSelected)
- Right request -> (accErrs, (candidate, request) : accSelected)
- defaultSSHComment candidate =
- case injectableAuthSubkeyPrimaryUID candidate of
- Just uid -> T.unpack uid
- Nothing -> "openpgp:" ++ BC8.unpack (Base16.encode (BL.toStrict (unFingerprint (fingerprint (injectableAuthSubkeyPKP candidate)))))
-
-sshAddIdentityRequest ::
- String -> SomePKPayload -> SKAddendum -> Either String BL.ByteString
-sshAddIdentityRequest comment subkeyPKP subkeySKA =
- case subkeySKA of
- SUUnencrypted (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) _ ->
- Right $ frameSSHAgentRequest (rsaAddIdentityPayload (BC8.pack comment) rsaPrivateKey)
- SUUnencrypted (EdDSAPrivateKey Ed25519 secretSeed) _ ->
- frameSSHAgentRequest <$>
- ed25519AddIdentityPayload (BC8.pack comment) subkeyPKP secretSeed
- SUUnencrypted (UnknownSKey rawSecret) _
- | isEd25519PKA (_pkalgo subkeyPKP) ->
- frameSSHAgentRequest <$>
- ed25519AddIdentityPayload
- (BC8.pack comment)
- subkeyPKP
- (BL.toStrict rawSecret)
- SUUnencrypted (EdDSAPrivateKey Ed448 _) _ ->
- Left
- ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
- " uses Ed448, which is not supported by ssh-agent add-identity")
- SUUnencrypted _ _ ->
- Left
- ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
- " uses an unsupported key algorithm for ssh-agent injection")
- _ ->
- Left
- ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
- " is encrypted; decrypt it before injection")
-
-authSecretSubkeyPKP :: AuthSecretSubkeyAtTime -> SomePKPayload
-authSecretSubkeyPKP = keyPktPKPayload . authSecretSubkeyValue
-
-authSecretSubkeySKA :: AuthSecretSubkeyAtTime -> SKAddendum
-authSecretSubkeySKA = secretKeyPktSKAddendum . authSecretSubkeyValue
-
-rsaAddIdentityPayload :: B.ByteString -> RSA.PrivateKey -> BL.ByteString
-rsaAddIdentityPayload comment privateKey =
- runPut $ do
- putWord8 17
- putSSHString (BC8.pack "ssh-rsa")
- putSSHMpint (RSA.public_n (RSA.private_pub privateKey))
- putSSHMpint (RSA.public_e (RSA.private_pub privateKey))
- putSSHMpint (RSA.private_d privateKey)
- putSSHMpint (RSA.private_qinv privateKey)
- putSSHMpint (RSA.private_p privateKey)
- putSSHMpint (RSA.private_q privateKey)
- putSSHString comment
-
-ed25519AddIdentityPayload ::
- B.ByteString -> SomePKPayload -> B.ByteString -> Either String BL.ByteString
-ed25519AddIdentityPayload comment pkp rawSecret = do
- publicKey <- ed25519PublicPoint pkp
- secretSeed <- normalizeEd25519Secret rawSecret
- pure $
- runPut $ do
- putWord8 17
- putSSHString (BC8.pack "ssh-ed25519")
- putSSHString publicKey
- putSSHString (secretSeed <> publicKey)
- putSSHString comment
-
-ed25519PublicPoint :: SomePKPayload -> Either String B.ByteString
-ed25519PublicPoint pkp =
- case _pubkey pkp of
- EdDSAPubKey Ed25519 point ->
- maybe
- (Left ("invalid Ed25519 public point for subkey " ++ renderFingerprint (fingerprint pkp)))
- Right
- (edPointToRawBytes point)
- _ -> Left ("subkey " ++ renderFingerprint (fingerprint pkp) ++ " does not have an Ed25519 public key")
-
-renderFingerprint :: Fingerprint -> String
-renderFingerprint =
- T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty
-
-renderKeyID :: EightOctetKeyId -> String
-renderKeyID =
- T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty
-
-knownWeakHashAlgorithms :: [HashAlgorithm]
-knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]
-
-isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool
-isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms
-
-isSubkeyRevocationSignature :: SignaturePayload -> Bool
-isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig
-isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig
-isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig
-isSubkeyRevocationSignature _ = False
-
-edPointToRawBytes :: EdPoint -> Maybe B.ByteString
-edPointToRawBytes (NativeEPoint (EPoint i)) = integerToFixedBytes 32 i
-edPointToRawBytes (PrefixedNativeEPoint (EPoint i)) = do
- prefixed <- integerToFixedBytes 33 i
- case B.uncons prefixed of
- Just (0x40, raw) -> Just raw
- _ -> Nothing
-
-normalizeEd25519Secret :: B.ByteString -> Either String B.ByteString
-normalizeEd25519Secret rawSecret
- | B.length rawSecret == 32 = Right rawSecret
- | otherwise =
- Left
- ("expected 32-byte Ed25519 secret seed, got " ++ show (B.length rawSecret) ++ " bytes")
-
-putSSHString :: B.ByteString -> Put
-putSSHString bs = putWord32be (fromIntegral (B.length bs)) >> putByteString bs
-
-putSSHMpint :: Integer -> Put
-putSSHMpint n
- | n <= 0 = putWord32be 0
- | otherwise = putSSHString encoded
- where
- raw = integerToUnsignedBytes n
- encoded =
- case B.uncons raw of
- Just (firstByte, _)
- | testBit firstByte 7 -> B.cons 0x00 raw
- _ -> raw
-
-integerToFixedBytes :: Int -> Integer -> Maybe B.ByteString
-integerToFixedBytes width n
- | n < 0 = Nothing
- | B.length raw > width = Nothing
- | otherwise = Just (B.replicate (width - B.length raw) 0x00 <> raw)
- where
- raw =
- if n == 0
- then B.singleton 0x00
- else integerToUnsignedBytes n
-
-integerToUnsignedBytes :: Integer -> B.ByteString
-integerToUnsignedBytes n =
- B.reverse $
- B.unfoldr
- (\value ->
- if value == 0
- then Nothing
- else Just (fromIntegral (value .&. 0xff), value `shiftR` 8))
- n
-
-isEd25519PKA :: PubKeyAlgorithm -> Bool
-isEd25519PKA pka = fromFVal pka == 27
-
-frameSSHAgentRequest :: BL.ByteString -> BL.ByteString
-frameSSHAgentRequest body =
- runPut $ putWord32be (fromIntegral (BL.length body)) >> putLazyByteString body
-
-sendAddIdentityToSSHAgent :: FilePath -> BL.ByteString -> IO ()
-sendAddIdentityToSSHAgent socketPath request =
- bracket
- (socket AF_UNIX Stream defaultProtocol)
- close
- (\sock -> do
- connect sock (SockAddrUnix socketPath)
- NSB.sendAll sock (BL.toStrict request)
- response <- readSSHAgentPacket sock
- case B.uncons response of
- Just (6, _) -> pure ()
- Just (5, _) ->
- failInject "inject-ssh-agent: ssh-agent rejected the supplied key"
- Just (code, _) ->
- failInject
- ("inject-ssh-agent: ssh-agent returned unexpected response type " ++
- show code)
- Nothing ->
- failInject
- "inject-ssh-agent: ssh-agent returned an empty response packet")
-
-readSSHAgentPacket :: Socket -> IO B.ByteString
-readSSHAgentPacket sock = do
- lenPrefix <- recvExact sock 4
- let packetLen = fromIntegral (runGet getWord32be (BL.fromStrict lenPrefix))
- recvExact sock packetLen
-
-recvExact :: Socket -> Int -> IO B.ByteString
-recvExact _ 0 = pure B.empty
-recvExact sock remaining = go B.empty remaining
- where
- go acc 0 = pure acc
- go acc bytesRemaining = do
- chunk <- NSB.recv sock bytesRemaining
- if B.null chunk
- then
- failInject
- "inject-ssh-agent: ssh-agent socket closed while reading response"
- else go (acc <> chunk) (bytesRemaining - B.length chunk)
-
-whenEmpty :: [a] -> String -> IO ()
-whenEmpty [] msg = failInject msg
-whenEmpty _ _ = pure ()
-
-failInject :: String -> IO a
-failInject msg = hPutStrLn stderr msg >> exitFailure
-
-banner' :: Handle -> IO ()
-banner' h =
- PPA.hPutDoc h (banner "hokey" <> hardline <> warranty "hokey" <> hardline)
-
-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
+import HOpenPGP.Tools.Common.Common (banner, versioner, warranty)
+
+import Options.Applicative.Builder
+ ( command
+ , footerDoc
+ , headerDoc
+ , info
+ , prefs
+ , progDesc
+ , showHelpOnError
+ )
+import Options.Applicative.Extra (customExecParser, helper, hsubparser)
+import Options.Applicative.Types (Parser)
+import System.IO
+ ( BufferMode(..)
+ , Handle
+ , hFlush
+ , hSetBuffering
+ , stderr
+ )
+import Prettyprinter (hardline)
+import qualified Prettyprinter.Render.Terminal as PPA
+import HOpenPGP.Tools.Hokey.Options
+ ( FetchOptions
+ , InjectSSHAgentOptions
+ , LintOptions
+ , fetchO
+ , injectSSHAgentO
+ , lintO
+ )
+import HOpenPGP.Tools.Hokey.Canonicalize (doCanonicalize)
+import HOpenPGP.Tools.Hokey.Fetch (doFetch)
+import HOpenPGP.Tools.Hokey.InjectSSHAgent (doInjectSSHAgent)
+import HOpenPGP.Tools.Hokey.Lint (doLint)
+
+data Command
+ = CmdLint LintOptions
+ | CmdCanonicalize
+ | CmdFetch FetchOptions
+ | CmdInjectSSHAgent InjectSSHAgentOptions
+
+dispatch :: Command -> IO ()
+dispatch (CmdFetch o) = banner' stderr >> hFlush stderr >> doFetch o
+dispatch (CmdLint o) = banner' stderr >> hFlush stderr >> doLint o
+dispatch CmdCanonicalize = banner' stderr >> hFlush stderr >> doCanonicalize
+dispatch (CmdInjectSSHAgent o) =
+ banner' stderr >> hFlush stderr >> doInjectSSHAgent o
+
+main :: IO ()
+main = do
+ hSetBuffering stderr LineBuffering
+ customExecParser
+ (prefs showHelpOnError)
+ (info
+ (helper <*> versioner "hokey" <*> cmd)
+ (headerDoc (Just (banner "hokey")) <>
+ progDesc "hOpenPGP Key utility" <>
+ footerDoc (Just (warranty "hokey")))) >>=
+ dispatch
+
+cmd :: Parser Command
+cmd =
+ hsubparser
+ (command
+ "canonicalize"
+ (info
+ (pure CmdCanonicalize)
+ (progDesc "arrange key components in a canonical ordering")) <>
+ command
+ "fetch"
+ (info
+ (CmdFetch <$> fetchO)
+ (progDesc "fetch key(s) via HKP or WKD")) <>
+ command
+ "inject-ssh-agent"
+ (info
+ (CmdInjectSSHAgent <$> injectSSHAgentO)
+ (progDesc "Read exported secret key bytes, pick an auth-capable subkey, and add it to ssh-agent")) <>
+ command
+ "lint"
+ (info (CmdLint <$> lintO) (progDesc "check key(s) for 'best practices'")))
+
+banner' :: Handle -> IO ()
+banner' h =
+ PPA.hPutDoc h (banner "hokey" <> hardline <> warranty "hokey" <> hardline)
+
diff --git a/hop.hs b/hop.hs
--- a/hop.hs
+++ b/hop.hs
@@ -71,6 +71,7 @@
, renderSignError
, signCertRevocationWithRSA
, signDataWithEd25519
+ , signDataWithEd25519Legacy
, signDataWithEd25519V6
, signDataWithEd448
, signDataWithEd448V6
@@ -153,8 +154,8 @@
import Data.Word (Word8)
import qualified Data.Yaml as Y
import GHC.Generics
-import HOpenPGP.Tools.Armor (doDeArmor)
-import HOpenPGP.Tools.Common
+import HOpenPGP.Tools.Common.Armor (doDeArmor)
+import HOpenPGP.Tools.Common.Common
( banner
, keyMatchesEightOctetKeyId
, keyMatchesFingerprint
@@ -162,8 +163,8 @@
, versioner
, warranty
)
-import HOpenPGP.Tools.Parser (parseTKExp)
-import HOpenPGP.Tools.TKUtils (processTK)
+import HOpenPGP.Tools.Common.Parser (parseTKExp)
+import HOpenPGP.Tools.Common.TKUtils (processTK)
import Paths_hopenpgp_tools (version)
import System.Exit (exitFailure, exitSuccess, exitWith, ExitCode(..))
@@ -306,6 +307,7 @@
, inlineSignProfile :: Maybe String
, inlineSignAs :: Maybe InlineSignMode
, inlineSignKeyFiles :: [String]
+ , inlineSignKeyPasswords :: [String]
}
data InlineDetachOptions =
@@ -592,7 +594,8 @@
(option
(eitherReader inlineSignModeReader)
(long "as" <> metavar "DATATYPE" <> inlineSignAsHelp)) <*>
- some (strArgument (metavar "KEY" <> help "signing key file(s)"))
+ some (strArgument (metavar "KEY" <> help "signing key file(s)")) <*>
+ many (strOption (long "with-key-password" <> metavar "PASSWORD" <> help "password for encrypted signing key"))
where
inlineSignAsHelp =
helpDoc . Just $
@@ -1398,6 +1401,8 @@
tk {_tkuKey = pToS (_tkuKey tk), _tkuSubs = map subPToS (_tkuSubs tk)}
pToS (pkp, _) = (pkp, Nothing)
subPToS (SecretSubkeyPkt pkp _, sigs) = (PublicSubkeyPkt pkp, sigs)
+ subPToS (PublicSubkeyPkt pkp, sigs) = (PublicSubkeyPkt pkp, sigs)
+ subPToS x = x
doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()
doChangeKeyPassword ChangeKeyPasswordOptions {..} = do
@@ -2036,7 +2041,7 @@
Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
Just (SUUnencrypted (UnknownSKey _) _) ->
- isEd25519PKA (_pkalgo (fpkp k)) || isEd448PKA (_pkalgo (fpkp k))
+ isEd25519PKA (_pkalgo (fpkp k)) || isEdDSAPKA (_pkalgo (fpkp k)) || isEd448PKA (_pkalgo (fpkp k))
_ -> False
canSignDataUsage keyFlags = S.null keyFlags || S.member SignDataKey keyFlags
@@ -2071,6 +2076,10 @@
Left err -> failWith BadData (ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
Right sk
| _keyVersion signerPKP == V6 -> signEd25519 sk
+ | isEdDSAPKA (_pkalgo signerPKP) ->
+ case signDataWithEd25519Legacy st sk hsd usd payload of
+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
+ Right sig -> pure sig
| otherwise ->
case signDataWithEd25519 st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
@@ -2093,6 +2102,10 @@
Left err -> failWith BadData (ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
Right sk
| _keyVersion signerPKP == V6 -> signEd25519 sk
+ | isEdDSAPKA (_pkalgo signerPKP) ->
+ case signDataWithEd25519Legacy st sk hsd usd payload of
+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
+ Right sig -> pure sig
| otherwise ->
case signDataWithEd25519 st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
@@ -2180,10 +2193,10 @@
BadData
(ctx ++ " failed: unable to determine RSA key size: " ++ err)
-isEd25519PKA :: PubKeyAlgorithm -> Bool
+-- FIXME: clean this up
+isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool
isEd25519PKA pka = fromFVal pka == 27
-
-isEd448PKA :: PubKeyAlgorithm -> Bool
+isEdDSAPKA pka = fromFVal pka == 22
isEd448PKA pka = fromFVal pka == 28
selectSigningHash :: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm
@@ -4532,7 +4545,9 @@
mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
when (inlineMode /= InlineSignAsBinary) $
ensureUTF8TextInput "inline-sign" (BL.fromChunks mbs)
- ks <- mapM grabKey inlineSignKeyFiles
+ signingPasswordsRaw <- loadPasswordFiles "inline-sign" "--with-key-password" inlineSignKeyPasswords
+ let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw
+ ks <- loadSigningKeys inlineSignKeyFiles signingPasswords
processedKeys <- mapM (normalizeSigningKey pt) ks
let ts = ThirtyTwoBitTimeStamp (floor pt)
payloadRaw = BL.fromChunks mbs
@@ -4608,7 +4623,7 @@
Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
Just (SUUnencrypted (UnknownSKey _) _) ->
- isEd25519PKA (_pkalgo (fpkp k)) || isEd448PKA (_pkalgo (fpkp k))
+ isEd25519PKA (_pkalgo (fpkp k)) || isEdDSAPKA (_pkalgo (fpkp k)) || isEd448PKA (_pkalgo (fpkp k))
_ -> False
-- Legacy alias.
diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal
--- a/hopenpgp-tools.cabal
+++ b/hopenpgp-tools.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: hopenpgp-tools
-version: 0.25
+version: 0.25.1
synopsis: hOpenPGP-based command-line tools
description: command-line tools for performing some OpenPGP-related operations
homepage: https://salsa.debian.org/clint/hOpenPGP-tools
@@ -20,29 +20,29 @@
autogen-modules: Paths_hopenpgp_tools
build-depends: base >= 4.15 && < 5
, aeson
- , binary >= 0.6.4.0
+ , binary >= 0.6.4
, binary-conduit
, bytestring
- , conduit >= 1.3.0
+ , conduit >= 1.3
, errors
- , hOpenPGP >= 3 && < 3.1
+ , hOpenPGP >= 3.0.2 && < 3.1
, lens
- , optparse-applicative >= 0.18.1.0
- , prettyprinter >= 1.7.0
+ , optparse-applicative >= 0.18.1
+ , prettyprinter >= 1.7
, text
, transformers >= 0.4
, yaml
ghc-options: -Wall
- other-modules: HOpenPGP.Tools.Common
+ other-modules: HOpenPGP.Tools.Common.Common
, Paths_hopenpgp_tools
executable hot
import: deps
main-is: hot.hs
autogen-modules: Paths_hopenpgp_tools
- other-modules: HOpenPGP.Tools.Armor
- , HOpenPGP.Tools.Lexer
- , HOpenPGP.Tools.Parser
+ other-modules: HOpenPGP.Tools.Common.Armor
+ , HOpenPGP.Tools.Common.Lexer
+ , HOpenPGP.Tools.Common.Parser
build-depends: array
, conduit-extra >= 1.1
, monad-loops
@@ -53,9 +53,14 @@
executable hokey
import: deps
main-is: hokey.hs
- other-modules: HOpenPGP.Tools.HKP
- , HOpenPGP.Tools.TKUtils
- , HOpenPGP.Tools.WKD
+ other-modules: HOpenPGP.Tools.Common.HKP
+ , HOpenPGP.Tools.Common.TKUtils
+ , HOpenPGP.Tools.Common.WKD
+ , HOpenPGP.Tools.Hokey.Options
+ , HOpenPGP.Tools.Hokey.Canonicalize
+ , HOpenPGP.Tools.Hokey.Fetch
+ , HOpenPGP.Tools.Hokey.InjectSSHAgent
+ , HOpenPGP.Tools.Hokey.Lint
build-depends: base16-bytestring
, conduit-extra >= 1.1
, containers
@@ -76,13 +81,13 @@
executable hkt
import: deps
main-is: hkt.hs
- other-modules: HOpenPGP.Tools.Lexer
- , HOpenPGP.Tools.Parser
+ other-modules: HOpenPGP.Tools.Common.Lexer
+ , HOpenPGP.Tools.Common.Parser
build-depends: array
, containers
, conduit-extra >= 1.1
, directory
- , fgl >= 5.5.4.0
+ , fgl >= 5.5.4
, graphviz
, ixset-typed
, monad-loops
@@ -95,10 +100,10 @@
executable hop
import: deps
main-is: hop.hs
- other-modules: HOpenPGP.Tools.Armor
- , HOpenPGP.Tools.Lexer
- , HOpenPGP.Tools.Parser
- , HOpenPGP.Tools.TKUtils
+ other-modules: HOpenPGP.Tools.Common.Armor
+ , HOpenPGP.Tools.Common.Lexer
+ , HOpenPGP.Tools.Common.Parser
+ , HOpenPGP.Tools.Common.TKUtils
build-depends: array
, conduit-extra >= 1.1
, containers
@@ -124,4 +129,4 @@
source-repository this
type: git
location: https://salsa.debian.org/clint/hopenpgp-tools.git
- tag: hopenpgp-tools/0.25
+ tag: hopenpgp-tools/0.25.1
diff --git a/hot.hs b/hot.hs
--- a/hot.hs
+++ b/hot.hs
@@ -1,5 +1,5 @@
-- hot.hs: hOpenPGP Tool
--- Copyright © 2012-2022 Clint Adams
+-- Copyright © 2012-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
@@ -42,9 +42,9 @@
import Data.Conduit.Serialization.Binary (conduitGet, conduitPut)
import Data.Void (Void)
import qualified Data.Yaml as Y
-import HOpenPGP.Tools.Armor (doDeArmor)
-import HOpenPGP.Tools.Common (banner, prependAuto, versioner, warranty)
-import HOpenPGP.Tools.Parser (parsePExp)
+import HOpenPGP.Tools.Common.Armor (doDeArmor)
+import HOpenPGP.Tools.Common.Common (banner, prependAuto, versioner, warranty)
+import HOpenPGP.Tools.Common.Parser (parsePExp)
import System.IO
( BufferMode(..)