packages feed

hopenpgp-tools 0.25 → 0.25.1

raw patch · 24 files changed

+2590/−2337 lines, 24 filesdep ~binarydep ~conduitdep ~fgl

Dependency ranges changed: binary, conduit, fgl, hOpenPGP, optparse-applicative, prettyprinter

Files

− HOpenPGP/Tools/Armor.hs 
@@ -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 <http://www.gnu.org/licenses/>.-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)
− HOpenPGP/Tools/Common.hs 
@@ -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 <http://www.gnu.org/licenses/>.--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))
+ HOpenPGP/Tools/Common/Armor.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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 ]
+ HOpenPGP/Tools/Common/Common.hs view
@@ -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 <http://www.gnu.org/licenses/>.++module HOpenPGP.Tools.Common.Common+  ( banner+  , versioner+  , warranty+  , prependAuto+  , keyMatchesFingerprint+  , keyMatchesEightOctetKeyId+  , keyMatchesExactUIDString+  , keyMatchesUIDSubString+  , keyMatchesPKPred+  -- hmm+  , pkpGetPKVersion+  , pkpGetPKAlgo+  , pkpGetKeysize+  , pkpGetTimestamp+  , pkpGetFingerprint+  , pkpGetEOKI+  , tkUsingPKP+  , pUsingPKP+  , pUsingSP+  , tkGetUIDs+  , tkGetSubs+  , anyOrAll+  , anyReader+  , oGetTag+  , oGetLength+  , spGetSigVersion+  , spGetSigType+  , spGetPKAlgo+  , spGetHashAlgo+  , spGetSCT+  , maybeR+  , renderKeyID+  , renderFingerprint+  ) 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
+ HOpenPGP/Tools/Common/HKP.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
+ HOpenPGP/Tools/Common/Lexer.x view
@@ -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++}
+ HOpenPGP/Tools/Common/Parser.y view
@@ -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+}
+ HOpenPGP/Tools/Common/TKUtils.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ HOpenPGP/Tools/Common/WKD.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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
− HOpenPGP/Tools/HKP.hs 
@@ -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 <http://www.gnu.org/licenses/>.--{-# 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
+ HOpenPGP/Tools/Hokey/Canonicalize.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ HOpenPGP/Tools/Hokey/Fetch.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ HOpenPGP/Tools/Hokey/InjectSSHAgent.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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+    }
+ HOpenPGP/Tools/Hokey/Lint.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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 =+      "<uat:[" ++ intercalate "," (map uaspToString 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 "<no-key-id>") 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++
+ HOpenPGP/Tools/Hokey/Options.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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"))
− HOpenPGP/Tools/Lexer.x 
@@ -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--}
− HOpenPGP/Tools/Parser.y 
@@ -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-}
− HOpenPGP/Tools/TKUtils.hs 
@@ -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 <http://www.gnu.org/licenses/>.--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
− HOpenPGP/Tools/WKD.hs 
@@ -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 <http://www.gnu.org/licenses/>.--{-# 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
hkt.hs view
@@ -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 =
hokey.hs view
@@ -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 =-      "<uat:[" ++ intercalate "," (map uaspToString 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 "<no-key-id>") 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)+
hop.hs view
@@ -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.
hopenpgp-tools.cabal view
@@ -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
hot.hs view
@@ -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(..)