hopenpgp-tools 0.23.11.1 → 0.24
raw patch · 10 files changed
+405/−168 lines, 10 filesdep ~basedep ~cryptondep ~hOpenPGP
Dependency ranges changed: base, crypton, hOpenPGP, openpgp-asciiarmor
Files
- HOpenPGP/Tools/Common.hs +23/−23
- HOpenPGP/Tools/HKP.hs +9/−8
- HOpenPGP/Tools/Lexer.x +2/−2
- HOpenPGP/Tools/Parser.y +1/−1
- HOpenPGP/Tools/TKUtils.hs +26/−20
- HOpenPGP/Tools/WKD.hs +183/−0
- hkt.hs +50/−35
- hokey.hs +65/−40
- hop.hs +38/−32
- hopenpgp-tools.cabal +8/−7
HOpenPGP/Tools/Common.hs view
@@ -1,5 +1,5 @@ -- Common.hs: hOpenPGP-tools common functions--- Copyright © 2012-2023 Clint Adams+-- Copyright © 2012-2026 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab --@@ -86,7 +86,7 @@ pretty name <+> pretty "(hopenpgp-tools)" <+> pretty (showVersion version) <>- hardline <> pretty "Copyright (C) 2012-2023 Clint Adams"+ hardline <> pretty "Copyright (C) 2012-2026 Clint Adams" warranty :: String -> Doc ann {-# INLINE warranty #-}@@ -105,53 +105,53 @@ prependAuto :: Read a => String -> ReadM a prependAuto s = ReadM (local (s ++) (unReadM auto)) -keyMatchesFingerprint :: Bool -> TK -> TwentyOctetFingerprint -> Bool+keyMatchesFingerprint :: Bool -> TKUnknown -> Fingerprint -> Bool keyMatchesFingerprint = keyMatchesPKPred fingerprint -keyMatchesEightOctetKeyId :: Bool -> TK -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow+keyMatchesEightOctetKeyId :: Bool -> TKUnknown -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID -keyMatchesExactUIDString :: Text -> TK -> Bool-keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkUIDs+keyMatchesExactUIDString :: Text -> TKUnknown -> Bool+keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkuUIDs -keyMatchesUIDSubString :: Text -> TK -> Bool+keyMatchesUIDSubString :: Text -> TKUnknown -> Bool keyMatchesUIDSubString uidstr =- any (T.toLower uidstr `T.isInfixOf`) . map (T.toLower . fst) . _tkUIDs+ any (T.toLower uidstr `T.isInfixOf`) . map (T.toLower . fst) . _tkuUIDs -keyMatchesPKPred :: Eq a => (PKPayload -> a) -> Bool -> TK -> a -> Bool-keyMatchesPKPred p False = (==) . p . fst . _tkKey+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 PKPayload a -> Reader TK a-tkUsingPKP = withReader (fst . _tkKey)+tkUsingPKP :: Reader SomePKPayload a -> Reader TKUnknown a+tkUsingPKP = withReader (fst . _tkuKey) -pkpGetPKVersion :: PKPayload -> Integer+pkpGetPKVersion :: SomePKPayload -> Integer pkpGetPKVersion t = if _keyVersion t == DeprecatedV3 then 3 else 4 -pkpGetPKAlgo :: PKPayload -> Integer+pkpGetPKAlgo :: SomePKPayload -> Integer pkpGetPKAlgo = fromIntegral . fromFVal . _pkalgo -pkpGetKeysize :: PKPayload -> Integer+pkpGetKeysize :: SomePKPayload -> Integer pkpGetKeysize = fromIntegral . fromMaybe 0 . hush . pubkeySize . _pubkey -pkpGetTimestamp :: PKPayload -> Integer+pkpGetTimestamp :: SomePKPayload -> Integer pkpGetTimestamp = fromIntegral . _timestamp -pkpGetFingerprint :: PKPayload -> TwentyOctetFingerprint+pkpGetFingerprint :: SomePKPayload -> Fingerprint pkpGetFingerprint = fingerprint -pkpGetEOKI :: PKPayload -> String+pkpGetEOKI :: SomePKPayload -> String pkpGetEOKI = either (const "UNKNOWN") show . eightOctetKeyID -tkGetUIDs :: TK -> [Text]-tkGetUIDs = map fst . _tkUIDs+tkGetUIDs :: TKUnknown -> [Text]+tkGetUIDs = map fst . _tkuUIDs -tkGetSubs :: TK -> [PKPayload]-tkGetSubs = mapMaybe (grabPKP . fst) . _tkSubs+tkGetSubs :: TKUnknown -> [SomePKPayload]+tkGetSubs = mapMaybe (grabPKP . fst) . _tkuSubs where grabPKP (PublicSubkeyPkt p) = Just p grabPKP (SecretSubkeyPkt p _) = Just p@@ -210,7 +210,7 @@ spGetSCT :: Pkt -> Maybe Integer spGetSCT (SignaturePkt s) = fmap fromIntegral (sigCT s) -pUsingPKP :: Reader (Maybe PKPayload) a -> Reader Pkt a+pUsingPKP :: Reader (Maybe SomePKPayload) a -> Reader Pkt a pUsingPKP = withReader grabPayload where grabPayload (SecretKeyPkt p _) = Just p
HOpenPGP/Tools/HKP.hs view
@@ -1,5 +1,5 @@ -- HKP.hs: hOpenPGP key tool--- Copyright © 2016-2023 Clint Adams+-- Copyright © 2016-2026 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab --@@ -15,6 +15,7 @@ -- -- 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@@ -31,8 +32,8 @@ import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Types ( Block(..)- , TK(..)- , TwentyOctetFingerprint+ , TKUnknown(..)+ , Fingerprint ) import Control.Applicative (liftA2) import Control.Arrow ((&&&))@@ -74,8 +75,8 @@ fetchKeys :: String -> FetchValidationMethod- -> TwentyOctetFingerprint- -> ExceptT String IO [TK]+ -> Fingerprint+ -> ExceptT String IO [TKUnknown] fetchKeys ks fvm q = do manager <- liftIO $ newManager tlsManagerSettings request <- liftIO $ parseUrlThrow (ks <> basereq)@@ -85,7 +86,7 @@ if responseStatus response == ok200 then validateKeys (responseBody response) else throwE ("HTTP status: " ++ show (responseStatus response))- return $ map fst $ filter (fvp fvm . fst . _tkKey . snd) processedKeys+ return $ map fst $ filter (fvp fvm . fst . _tkuKey . snd) processedKeys where fvp MatchPrimaryKeyFingerprint k = fingerprint k == q fvp MatchPrimaryOrAnySubkeyFingerprint k =@@ -99,7 +100,7 @@ , ("search", Just (BC8.pack ("0x" <> show (pretty q)))) -- FIXME: butter ] -validateKeys :: BL.ByteString -> ExceptT String IO [(TK, TK)] -- FIXME: conduit fail+validateKeys :: BL.ByteString -> ExceptT String IO [(TKUnknown, TKUnknown)] -- FIXME: conduit fail validateKeys larmors = do bytestrings <- ExceptT $ return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)@@ -114,7 +115,7 @@ armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs armorToBS _ = mempty -rearmorKeys :: [TK] -> B.ByteString+rearmorKeys :: [TKUnknown] -> B.ByteString rearmorKeys keys = if null keys then mempty
HOpenPGP/Tools/Lexer.x view
@@ -17,7 +17,7 @@ import Prelude hiding (lex) import Numeric (readHex)-import Codec.Encryption.OpenPGP.Types (TwentyOctetFingerprint(..), EightOctetKeyId(..))+import Codec.Encryption.OpenPGP.Types (Fingerprint(..), EightOctetKeyId(..)) } @@ -150,7 +150,7 @@ | TokenTimestamp | TokenFingerprint | TokenKeyID- | TokenFpr TwentyOctetFingerprint+ | TokenFpr Fingerprint | TokenLongID (Either String EightOctetKeyId) | TokenLength | TokenEvery
HOpenPGP/Tools/Parser.y view
@@ -221,7 +221,7 @@ (l,c) <- getPosn error (show l ++ ":" ++ show c ++ ": Parse error on Token: " ++ show t ++ "\n") -parseTKExp :: String -> Either String (Reader TK Bool)+parseTKExp :: String -> Either String (Reader TKUnknown Bool) parseTKExp s = runAlex s parseTK parsePExp :: String -> Either String (Reader Pkt Bool)
HOpenPGP/Tools/TKUtils.hs view
@@ -1,5 +1,5 @@ -- TKUtils.hs: hOpenPGP-tools TK-related common functions--- Copyright © 2013-2023 Clint Adams+-- Copyright © 2013-2026 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab --@@ -15,6 +15,7 @@ -- -- 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@@ -23,21 +24,21 @@ import Codec.Encryption.OpenPGP.Signatures ( verifyAgainstKeys , verifySigWith- , verifyTKWith+ , 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 verifyTKWith fail if there are no self-sigs?-processTK :: Maybe POSIXTime -> TK -> Either String TK+processTK :: Maybe POSIXTime -> TKUnknown -> Either String TKUnknown processTK mpt key =- verifyTKWith+ first show $ verifyUnknownTKWith (verifySigWith (verifyAgainstKeys [key])) (fmap posixSecondsToUTCTime mpt) . stripOlderSigs .@@ -46,41 +47,46 @@ where stripOtherSigs tk = tk- { _tkUIDs = map (second alleged) (_tkUIDs tk)- , _tkUAts = map (second alleged) (_tkUAts tk)+ { _tkuUIDs = map (second alleged) (_tkuUIDs tk)+ , _tkuUAts = map (second alleged) (_tkuUAts tk) } stripOlderSigs tk = tk- { _tkUIDs = map (second newest) (_tkUIDs tk)- , _tkUAts = map (second newest) (_tkUAts 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 _ _ _) =- map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs- pkp = key ^. tkKey . _1+ sigcts (SigV4 _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs+ sigcts (SigV6 _ _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs+ sigcts _ = []+ pkp = fst (_tkuKey key) alleged = filter (\x -> assI x || assIFP x)- isCT (SigSubPacket _ (SigCreationTime _)) = True- isCT _ = False+ 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 (SigVOther _ _) = error "We're in the future." -- FIXME+ 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- | pkp ^. keyVersion == V4 = hush . eightOctetKeyID $ pkp- | pkp ^. keyVersion == DeprecatedV3 &&- elem (pkp ^. pkalgo) [RSA, DeprecatedRSASignOnly] =+ | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp+ | _keyVersion pkp == DeprecatedV3 &&+ elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] = hush . eightOctetKeyID $ pkp | otherwise = Nothing fp- | pkp ^. keyVersion == V4 = Just . fingerprint $ pkp+ | _keyVersion pkp == V4 = Just . fingerprint $ pkp | otherwise = Nothing getIssuer (Issuer i) = Just i getIssuer _ = Nothing- getIssuerFP (IssuerFingerprint 4 i) = Just i+ 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 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.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
@@ -1,5 +1,5 @@ -- hkt.hs: hOpenPGP key tool--- Copyright © 2013-2022 Clint Adams+-- Copyright © 2013-2026 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab --@@ -15,7 +15,10 @@ -- -- 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 DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)@@ -32,7 +35,7 @@ import Codec.Encryption.OpenPGP.Types import Control.Applicative ((<|>), optional) import Control.Arrow ((&&&))-import Control.Lens ((^.), (^..), _1, _2)+import Control.Lens ((^.), (^..), _1, _2, (&)) import Control.Monad.Trans.Except (except, runExcept) import Control.Monad.Trans.Resource (MonadResource, MonadThrow) import qualified Data.Aeson as A@@ -40,14 +43,14 @@ import Data.Binary.Put (runPut) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.Conduit (ConduitM, (.|), runConduitRes)+import Data.Conduit (ConduitM, ConduitT, (.|), runConduitRes) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Filter ( FilterPredicates(RTKFilterPredicate) , conduitTKFilter )-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping, sinkKeyringMap)+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping, sinkPublicKeyringMap) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Data.Lens (biplate) import Data.Either (rights)@@ -115,7 +118,7 @@ => FilePath -> Bool -> Text- -> ConduitM () TK m ()+ -> ConduitM () TKUnknown m () grabMatchingKeysConduit fp filt srch = CB.sourceFile fp .| conduitGet get .| conduitToTKsDropping .| (if filt@@ -132,13 +135,13 @@ parseE = either (error . ("filter parse error: " ++)) id . parseTKExp . T.unpack -- this should be more specialized -grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TK]+grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TK 'PublicTK] grabMatchingKeys fp filt srch =- runConduitRes $ grabMatchingKeysConduit fp filt srch .| CL.consume+ runConduitRes $ grabMatchingKeysConduit fp filt srch .| CL.map fromUnknownToPublicTK .| CL.consume -grabMatchingKeysKeyring :: FilePath -> Bool -> Text -> IO Keyring+grabMatchingKeysKeyring :: FilePath -> Bool -> Text -> IO PublicKeyring grabMatchingKeysKeyring fp filt srch =- runConduitRes $ grabMatchingKeysConduit fp filt srch .| sinkKeyringMap+ runConduitRes $ grabMatchingKeysConduit fp filt srch .| CL.map fromUnknownToPublicTK .| sinkPublicKeyringMap data Key = Key@@ -161,12 +164,12 @@ instance A.ToJSON TKey -tkToTKey :: TK -> TKey+tkToTKey :: TK 'PublicTK -> TKey tkToTKey tk = TKey- { publickey = mkey (tk ^. tkKey . _1)+ { publickey = mkey (tk ^. tkPrimaryKey & keyPktPKPayload) , uids = tk ^. tkUIDs ^.. traverse . _1- , subkeys = map (mkey . \(PublicSubkeyPkt x, _) -> x) (tk ^. tkSubs)+ , subkeys = map (mkey . \(x, _) -> keyPktPKPayload x) (tk ^. tkSubs) } where mkey =@@ -369,17 +372,17 @@ let ttarget1 = T.pack . target1 keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o) case pathsOutputFormat o of- Unstructured -> mapM_ (BL.putStr . putTK') keys- JSON -> BL.putStr . A.encode $ keys- YAML -> B.putStr . Y.encode $ keys+ Unstructured -> mapM_ (BL.putStr . putTK' . someTKToUnknown . SomePublicTK) keys+ JSON -> BL.putStr . A.encode $ map (someTKToUnknown . SomePublicTK) keys+ YAML -> B.putStr . Y.encode $ map (someTKToUnknown . SomePublicTK) keys where putTK' key = runPut $ do- put (PublicKey (key ^. tkKey . _1))- mapM_ (put . Signature) (_tkRevs key)- mapM_ putUid' (_tkUIDs key)- mapM_ putUat' (_tkUAts key)- mapM_ putSub' (_tkSubs key)+ put (PublicKey (key ^. tkuKey . _1))+ mapM_ (put . Signature) (_tkuRevs key)+ mapM_ putUid' (_tkuUIDs key)+ mapM_ putUat' (_tkuUAts key)+ mapM_ putSub' (_tkuSubs key) putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps putSub' (p, sps) = put p >> mapM_ (put . Signature) sps@@ -407,22 +410,22 @@ nonClusteredLabeledNodesParams = nonClusteredParams {fmtNode = \(_, l) -> [toLabel $ show (pretty l)]} -buildMaps :: [TK] -> (KeyMaps, Int)+buildMaps :: [TK 'PublicTK] -> (KeyMaps, Int) buildMaps = foldr mapsInsertions (KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0) -- FIXME: this presumes no keyID collisions in the input data KeyMaps = KeyMaps- { _k2f :: HashMap EightOctetKeyId TwentyOctetFingerprint- , _f2i :: HashMap TwentyOctetFingerprint Int- , _i2f :: HashMap Int TwentyOctetFingerprint+ { _k2f :: HashMap EightOctetKeyId Fingerprint+ , _f2i :: HashMap Fingerprint Int+ , _i2f :: HashMap Int Fingerprint } -mapsInsertions :: TK -> (KeyMaps, Int) -> (KeyMaps, Int)+mapsInsertions :: TK 'PublicTK -> (KeyMaps, Int) -> (KeyMaps, Int) mapsInsertions tk (KeyMaps k2f f2i i2f, i) =- let fp = fingerprint (tk ^. tkKey . _1)- keyids = rights . map eightOctetKeyID $ (tk ^.. biplate :: [PKPayload])+ let fp = fingerprint (tk ^. tkPrimaryKey & keyPktPKPayload)+ keyids = rights . map eightOctetKeyID $ (tk ^.. biplate :: [SomePKPayload]) i' = i + 1 k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids f2i' = HashMap.insert fp i' f2i@@ -430,7 +433,7 @@ in (KeyMaps k2f' f2i' i2f', i') buildKeyGraph ::- ((KeyMaps, Int), [TK]) -> Gr TwentyOctetFingerprint HashAlgorithm+ ((KeyMaps, Int), [TK 'PublicTK]) -> Gr Fingerprint HashAlgorithm buildKeyGraph ((KeyMaps k2f f2i _, _), ks) = mkGraph nodes edges where nodes = map swap . HashMap.toList $ f2i@@ -442,7 +445,7 @@ target tk = fromMaybe (error "Epic fail")- (HashMap.lookup (fingerprint (tk ^. tkKey . _1)) f2i)+ (HashMap.lookup (fingerprint (tk ^. tkPrimaryKey & keyPktPKPayload)) f2i) source i = fromMaybe (-1) (HashMap.lookup i k2f >>= flip HashMap.lookup f2i) fakejoin (x, y) = fmap ((,) x) y sigs tk =@@ -453,7 +456,7 @@ data PaF = PaF { certPaths :: [Path]- , keyFingerprints :: Map String TwentyOctetFingerprint+ , keyFingerprints :: Map String Fingerprint } deriving (Generic) @@ -470,14 +473,14 @@ keys1 <- runConduitRes $ CL.sourceList (IxSet.toList kr) .| (if filt- then conduitTKFilter (ufpt (ttarget2 o))- else CL.filter (matchAny (ttarget2 o))) .|+ then pup (conduitTKFilter (ufpt (ttarget2 o)))+ else pup (CL.filter (matchAny (ttarget2 o)))) .| CL.consume keys2 <- runConduitRes $ CL.sourceList (IxSet.toList kr) .| (if filt- then conduitTKFilter (ufpt (ttarget3 o))- else CL.filter (matchAny (ttarget3 o))) .|+ then pup (conduitTKFilter (ufpt (ttarget3 o)))+ else pup (CL.filter (matchAny (ttarget3 o)))) .| CL.consume let ((KeyMaps k2f f2i i2f, i), ks) = (buildMaps &&& id)@@ -489,7 +492,7 @@ (IxSet.toList kr))) keygraph = buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks) keysToIs =- mapMaybe (\x -> HashMap.lookup (fingerprint (x ^. tkKey . _1)) f2i)+ mapMaybe (\x -> HashMap.lookup (fingerprint (x ^. tkPrimaryKey & keyPktPKPayload)) f2i) froms = keysToIs keys1 tos = keysToIs keys2 combos = froms >>= \f -> tos >>= \t -> return (f, t)@@ -546,3 +549,15 @@ hashAlgo (SigV4 _ _ x _ _ _ _) = x hashAlgo _ = error "V3 sig not supported here"++fromUnknownToPublicTK :: TKUnknown -> TK 'PublicTK+fromUnknownToPublicTK = either error fromSome . fromUnknownToTK+ where+ fromSome (SomePublicTK tk) = tk+ fromSome (SomeSecretTK _) = error "impossible"++pup :: Monad m+ => ConduitT TKUnknown TKUnknown m ()+ -> ConduitT (TK PublicTK) (TK PublicTK) m ()+pup c = CL.map (someTKToUnknown . SomePublicTK) .| c .| CL.map fromUnknownToPublicTK+-- upu c = CL.map fromUnknownToPublicTK .| c .| CL.map (someTKToUnknown . SomePublicTK)
hokey.hs view
@@ -1,5 +1,5 @@ -- hokey.hs: hOpenPGP key tool--- Copyright © 2013-2022 Clint Adams+-- Copyright © 2013-2026 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab --@@ -15,6 +15,7 @@ -- -- 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 #-}@@ -37,7 +38,7 @@ import Control.Arrow ((***)) import Control.Error.Util (hush) import Control.Lens ((&), (^.), _1, _2, mapped, over)-import Control.Monad.Trans.Except (runExceptT)+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@@ -67,14 +68,15 @@ import qualified Data.Yaml as Y import GHC.Generics import HOpenPGP.Tools.Common (banner, versioner, warranty)-import HOpenPGP.Tools.HKP (FetchValidationMethod(..), fetchKeys, rearmorKeys)+import HOpenPGP.Tools.HKP (FetchValidationMethod(..), rearmorKeys)+import qualified HOpenPGP.Tools.HKP as HKP import HOpenPGP.Tools.TKUtils (processTK)+import qualified HOpenPGP.Tools.WKD as WKD import Options.Applicative.Builder ( argument , auto , command- , eitherReader , footerDoc , headerDoc , help@@ -157,7 +159,7 @@ data KeyReport = KeyReport { keyStatus :: String- , keyFingerprint :: TwentyOctetFingerprint+ , keyFingerprint :: Fingerprint , keyVer :: Colored KeyVersion , keyCreationTime :: ThirtyTwoBitTimeStamp , keyAlgorithmAndSize :: KAS@@ -180,7 +182,7 @@ data SubkeyReport = SubkeyReport- { skFingerprint :: Colored TwentyOctetFingerprint+ { skFingerprint :: Colored Fingerprint , skVer :: Colored KeyVersion , skCreationTime :: ThirtyTwoBitTimeStamp , skAlgorithmAndSize :: KAS@@ -232,7 +234,7 @@ mempty = UIDReport [] [] [] [] [] mappend = (<>) -checkKey :: Maybe POSIXTime -> TK -> KeyReport+checkKey :: Maybe POSIXTime -> TKUnknown -> KeyReport checkKey mpt key = (\x -> x@@ -242,24 +244,24 @@ }) KeyReport { keyStatus = either id (const "good") processedTK- , keyFingerprint = key ^. tkKey . _1 & fingerprint- , keyVer = key ^. tkKey . _1 . keyVersion & colorizeKV- , keyCreationTime = key ^. tkKey . _1 . timestamp- , keyAlgorithmAndSize = kasIt (key ^. tkKey . _1)+ , 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 ^. tkUIDs) ++- map (uatspsToText *** uidr Nothing) (processedOrOrig ^. tkUAts))+ (map (\(x, y) -> (x, uidr (Just x) y)) (processedOrOrig ^. tkuUIDs) +++ map (uatspsToText *** uidr Nothing) (processedOrOrig ^. tkuUAts)) , keyBestOf = Nothing , keySubkeys =- map (checkSK (key ^. tkKey . _1 & fingerprint)) (key ^. tkSubs)+ 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 :: PKPayload -> KAS- kasIt pkp = kasIt' (pkp ^. pkalgo) (pkp ^. pubkey & pubkeySize)+ kasIt :: SomePKPayload -> KAS+ kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize) kasIt' :: PubKeyAlgorithm -> Either String Int -> KAS kasIt' pka epks = KAS@@ -311,9 +313,9 @@ Colored (Just Yellow) (Just "expiration too far in future") kes | otherwise = Colored (Just Green) Nothing kes eoki pkp- | pkp ^. keyVersion == V4 = hush . eightOctetKeyID $ pkp- | pkp ^. keyVersion == DeprecatedV3 &&- elem (pkp ^. pkalgo) [RSA, DeprecatedRSASignOnly] =+ | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp+ | _keyVersion pkp == DeprecatedV3 &&+ elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] = hush . eightOctetKeyID $ pkp | otherwise = Nothing phas (SigV4 _ _ _ xs _ _ _) =@@ -333,7 +335,7 @@ map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs alleged = filter- (\x -> ((==) <$> sigissuer x <*> eoki (key ^. tkKey . _1)) == Just True)+ (\x -> ((==) <$> sigissuer x <*> eoki (key ^. tkuKey . _1)) == Just True) uatspsToText = T.pack . uatspsToString uatspsToString us = "<uat:[" ++ intercalate "," (map uaspToString us) ++ "]>"@@ -355,7 +357,7 @@ (map (colorizeKETs (fromMaybe 0 mpt)- (key ^. tkKey . _1 . timestamp & unThirtyTwoBitTimeStamp) .+ (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) . getKeyExpirationTimesFromSignature) sps -- should that be 0? )@@ -370,7 +372,7 @@ (map (colorizeKETs (fromMaybe 0 mpt)- (key ^. tkKey . _1 . timestamp & unThirtyTwoBitTimeStamp) .+ (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) . getKeyExpirationTimesFromSignature) sps -- should that be 0? )@@ -433,15 +435,15 @@ hasheds (SigV4 _ _ _ xs _ _ _) = xs hasheds _ = [] checkSK ::- TwentyOctetFingerprint -> (Pkt, [SignaturePayload]) -> SubkeyReport+ 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 (pkp ^. keyVersion)- , skCreationTime = pkp ^. timestamp+ , skVer = colorizeKV (_keyVersion pkp)+ , skCreationTime = _timestamp pkp , skAlgorithmAndSize = kasIt pkp , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs) , skUsageFlags = kufs True (filter isSKBindingSig sigs)@@ -499,7 +501,7 @@ else (Just Green, Nothing)) fp -prettyKeyReport :: POSIXTime -> TK -> Doc PPA.AnsiStyle+prettyKeyReport :: POSIXTime -> TKUnknown -> Doc PPA.AnsiStyle prettyKeyReport cpt key = do let keyReport = checkKey (Just cpt) key execWriter $@@ -632,10 +634,10 @@ (list . map (coloredToColor pretty) . ccHashAlgorithms . skCrossCerts) skr) -jsonReport :: POSIXTime -> TK -> BL.ByteString+jsonReport :: POSIXTime -> TKUnknown -> BL.ByteString jsonReport ps = A.encode . checkKey (Just ps) -yamlReport :: POSIXTime -> TK -> B.ByteString+yamlReport :: POSIXTime -> TKUnknown -> B.ByteString yamlReport ps = Y.encode . (: []) . checkKey (Just ps) data LintOutputFormat@@ -652,10 +654,16 @@ data FetchOptions = FetchOptions { keyServer :: String+ , fetchMethod :: FetchMethod , fetchValidation :: FetchValidationMethod- , fetchQuery :: TwentyOctetFingerprint+ , fetchQuery :: String } +data FetchMethod+ = HKP+ | WKD+ deriving (Bounded, Enum, Eq, Read, Show)+ data Command = CmdLint LintOptions | CmdCanonicalize@@ -682,20 +690,26 @@ (long "keyserver" <> metavar "URL" <> value "http://pool.sks-keyservers.net:11371" <> showDefault <>- help "HKP server") <*>+ 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 (eitherReader strToFP) (metavar "FINGERPRINT")+ 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)+ helpDoc . Just $ pretty "validation method" <> hardline <>+ list (map (pretty . show) vmchoices) vmchoices = [minBound .. maxBound] :: [FetchValidationMethod]- strToFP = parseFingerprint . T.pack dispatch :: Command -> IO () dispatch (CmdFetch o) = banner' stderr >> hFlush stderr >> doFetch o@@ -724,7 +738,9 @@ (progDesc "arrange key components in a canonical ordering")) <> command "fetch"- (info (CmdFetch <$> fetchO) (progDesc "fetch key(s) from keyserver")) <>+ (info+ (CmdFetch <$> fetchO)+ (progDesc "fetch key(s) via HKP or WKD")) <> command "lint" (info (CmdLint <$> lintO) (progDesc "check key(s) for 'best practices'")))@@ -752,15 +768,20 @@ conduitPut .| CB.sinkHandle stdout where- canonicalize (TK k r ui ua s) =- TK k (sort r) (indepthsort ui) (indepthsort ua) (indepthsort s)+ canonicalize (TKUnknown k r ui ua s) =+ TKUnknown k (sort r) (indepthsort ui) (indepthsort ua) (indepthsort s) indepthsort :: (Ord a, Ord b) => [(a, [b])] -> [(a, [b])] indepthsort = nub . sort . over (mapped . _2) sort doFetch :: FetchOptions -> IO () doFetch o = do ekeys <-- runExceptT $ fetchKeys (keyServer o) (fetchValidation o) (fetchQuery o)+ 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@@ -776,10 +797,14 @@ sigissuer SigV3 {} = Nothing sigissuer (SigV4 _ _ _ ys xs _ _) = listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?-sigissuer (SigVOther _ _) = error "We're in the future." -- FIXME+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 _ = error "V3 sig not supported here"+hashAlgo (SigV6 _ _ x _ _ _ _ _) = x+hashAlgo (SigVOther _ _) = OtherHA 0
hop.hs view
@@ -1,5 +1,5 @@ -- hop.hs: hOpenPGP-stateless OpenPGP (sop) tool--- Copyright © 2019-2023 Clint Adams+-- Copyright © 2019-2026 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab --@@ -15,6 +15,8 @@ -- -- 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 DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} @@ -52,12 +54,15 @@ import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Keyring ( conduitToTKs+ , conduitToPublicViewTKs+ , conduitToSecretTKs , conduitToTKsDropping- , sinkKeyringMap+ , sinkPublicKeyringMap ) import Data.Conduit.OpenPGP.Verify (conduitVerify) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Either (fromRight, isRight, rights)+import Data.Bifunctor (first) import Data.List (find) import Data.Maybe (catMaybes, fromJust, listToMaybe) import Data.Monoid ((<>))@@ -202,7 +207,7 @@ data Vrf = Vrf { _vrfmsg :: String- , _vrfmfpr :: Maybe TwentyOctetFingerprint+ , _vrfmfpr :: Maybe Fingerprint } deriving (Eq, Generic, Show) @@ -213,7 +218,8 @@ let allkfiles = sequence_ (map CC.sourceFile (keyrings o)) krs <- runConduitRes $- allkfiles .| conduitGet Bin.get .| conduitToTKsDropping .| sinkKeyringMap+ allkfiles .| conduitGet Bin.get .| conduitToTKs .| CL.map (fromSomePub) .| sinkPublicKeyringMap+ sigs <- runConduitRes $ CC.sourceFile (sigFile o) .| conduitGet Bin.get .| CC.filter v4b .|@@ -236,7 +242,7 @@ where v4b (SignaturePkt s@(SigV4 BinarySig _ _ _ _ _ _)) = sf s v4b _ = False- v2v (Left l) = Vrf l Nothing+ v2v (Left l) = Vrf (show l) Nothing v2v (Right v) = Vrf "verified signature" (Just (fingerprint (_verificationSigner v))) sf = const True@@ -354,12 +360,12 @@ then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs] else lbs -type KeyBuilder = StateT TK IO+type KeyBuilder = StateT TKUnknown IO buildKeyWith :: SecretKey -> KeyBuilder a -> IO a buildKeyWith sk a = evalStateT a (bareTK sk) where- bareTK (SecretKey pkp ska) = TK (pkp, Just ska) [] [] [] []+ bareTK (SecretKey pkp ska) = TKUnknown (pkp, Just ska) [] [] [] [] generateSecretKey :: ThirtyTwoBitTimeStamp -> PubKeyAlgorithm -> IO SecretKey generateSecretKey ts RSA = do@@ -372,7 +378,7 @@ addUserId :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder () addUserId ts primary userid = modify (newUID userid) where- newUID u tk = tk {_tkUIDs = _tkUIDs tk ++ [selfsign (_tkKey tk) u]}+ newUID u tku = tku {_tkuUIDs = _tkuUIDs tku ++ [selfsign (_tkuKey tku) u]} selfsign (pkp, Just ska) u = ( u , [ fromRight@@ -386,7 +392,7 @@ ]) hashed pkp = [ SigSubPacket False (SigCreationTime ts)- , SigSubPacket False (IssuerFingerprint 4 (fingerprint pkp))+ , SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint pkp)) , SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey)) , SigSubPacket False (PrimaryUserId primary) , SigSubPacket@@ -402,9 +408,9 @@ addSubkey :: ThirtyTwoBitTimeStamp -> [KeyFlag] -> KeyBuilder () addSubkey ts keyflags = do- tk <- get+ tku <- get (SecretKey subpkp subska) <- liftIO $ generateSecretKey ts RSA- let (pkp, Just ska) = _tkKey tk+ let (pkp, Just ska) = _tkuKey tku Right crossig = crossSignSubkeyWithRSA pkp@@ -418,11 +424,11 @@ modify (addIt subpkp subska crossig) where skey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) = k- addIt sp ss cross tk =- tk {_tkSubs = _tkSubs tk ++ [(SecretSubkeyPkt sp ss, [cross])]}+ addIt sp ss cross tku =+ tku {_tkuSubs = _tkuSubs tku ++ [(SecretSubkeyPkt sp ss, [cross])]} hashed pkp = [ SigSubPacket False (SigCreationTime ts)- , SigSubPacket False (IssuerFingerprint 4 (fingerprint pkp))+ , SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint pkp)) ] hashedwithflags pkp = hashed pkp ++ [SigSubPacket False (KeyFlags (S.fromList keyflags))]@@ -454,18 +460,13 @@ else lbs k <- runConduitRes $- CL.sourceList (BL.toChunks lbs') .| conduitGet Bin.get .| conduitToTKs .|+ CL.sourceList (BL.toChunks lbs') .| conduitGet Bin.get .| conduitToPublicViewTKs .| CL.take 1- let output = runPut $ Bin.put (pubToSecret (head k))+ let output = runPut $ Bin.put (someTKToUnknown . SomePublicTK $ head k) BL.putStr $ if not ecArmor && not ecNoArmor then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output] else output- where- pubToSecret tk =- tk {_tkKey = pToS (_tkKey tk), _tkSubs = map subPToS (_tkSubs tk)}- pToS (pkp, _) = (pkp, Nothing)- subPToS (SecretSubkeyPkt pkp _, sigs) = (PublicSubkeyPkt pkp, sigs) soP :: Parser SignOptions soP =@@ -513,7 +514,7 @@ if sAs == AsText then canonicalize payload' else payload'- funkeys = concatMap tkToFunKeys . rights . map (processTK (Just pt)) $ ks+ funkeys = concatMap tkToFunKeys . rights . map (processTK (Just pt) . someTKToUnknown . SomeSecretTK) $ ks allSigningCapableKeys = filter (isSigner . fkufs) funkeys forM_ allSigningCapableKeys $ \k -> do let Right sig = signData sAs ts k payload@@ -530,23 +531,25 @@ -> FunKey -> BL.ByteString -> Either String SignaturePayload- signData AsBinary t k =- signDataWithRSA+ signData AsBinary t k d =+ first show $ signDataWithRSA BinarySig (skey (fromJust (fmska k))) (hashed (fpkp k) t) (unhashed (fpkp k))- signData AsText t k =- signDataWithRSA+ d+ signData AsText t k d =+ first show $ signDataWithRSA CanonicalTextSig (skey (fromJust (fmska k))) (hashed (fpkp k) t) (unhashed (fpkp k))+ (canonicalize d) skey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) = k {RSA.private_p = 0, RSA.private_q = 0} -- FIXME: why is this necessary? hashed pkp ct = [ SigSubPacket False (SigCreationTime ct)- , SigSubPacket False (IssuerFingerprint 4 (fingerprint pkp))+ , SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint pkp)) ] unhashed pkp = [SigSubPacket False (Issuer (fromRight undefined (eightOctetKeyID pkp)))]@@ -557,7 +560,7 @@ TE.encodeUtf8 . T.intercalate (T.pack "\r\n") . T.lines . TE.decodeUtf8 . BL.toStrict -grabKey :: String -> IO TK+grabKey :: String -> IO (TK 'SecretTK) grabKey fp = do kbs <- runConduitRes $ CB.sourceFile fp .| CL.consume let lbs = BL.fromChunks kbs@@ -571,20 +574,20 @@ else lbs Just k <- runConduitRes $- CL.sourceList (BL.toChunks lbs') .| conduitGet Bin.get .| conduitToTKs .|+ CL.sourceList (BL.toChunks lbs') .| conduitGet Bin.get .| conduitToSecretTKs .| CL.head return k data FunKey = FunKey- { fpkp :: PKPayload+ { fpkp :: SomePKPayload , fmska :: Maybe SKAddendum , fkufs :: S.Set KeyFlag } deriving (Show) -tkToFunKeys :: TK -> [FunKey]-tkToFunKeys (TK (pkp, mska) revs uids uats subs) =+tkToFunKeys :: TKUnknown -> [FunKey]+tkToFunKeys (TKUnknown (pkp, mska) revs uids uats subs) = catMaybes (mainKey : map extract subs) where mainKey = grabASig uids >>= sig2KUFs >>= \kf -> return (FunKey pkp mska kf)@@ -603,3 +606,6 @@ extract ((PublicSubkeyPkt spkp), sigs) = listToMaybe sigs >>= sig2KUFs >>= \kf -> return (FunKey spkp Nothing kf) extract _ = Nothing++fromSomePub :: SomeTK -> TK 'PublicTK+fromSomePub (SomePublicTK tk) = tk
hopenpgp-tools.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hopenpgp-tools-version: 0.23.11.1+version: 0.24 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: https://salsa.debian.org/clint/hOpenPGP-tools@@ -18,14 +18,14 @@ common deps autogen-modules: Paths_hopenpgp_tools- build-depends: base > 4.9 && < 5+ build-depends: base > 4.15 && < 5 , aeson , binary >= 0.6.4.0 , binary-conduit , bytestring , conduit >= 1.3.0 , errors- , hOpenPGP >= 2.10.1 && < 3+ , hOpenPGP >= 3 && < 3.1 , lens , optparse-applicative >= 0.18.1.0 , prettyprinter >= 1.7.0@@ -55,20 +55,21 @@ main-is: hokey.hs other-modules: HOpenPGP.Tools.HKP , HOpenPGP.Tools.TKUtils+ , HOpenPGP.Tools.WKD build-depends: base16-bytestring , conduit-extra >= 1.1 , containers , http-client >= 0.4.30 , http-client-tls , http-types- , openpgp-asciiarmor >= 0.1+ , openpgp-asciiarmor >= 1.0 , prettyprinter-ansi-terminal >= 1.1.2 , time , time-locale-compat if flag(use-memory)- build-depends: crypton < 1.1.0, memory+ build-depends: crypton < 1.1, memory else- build-depends: crypton >= 1.1.0, ram+ build-depends: crypton >= 1.1, ram default-language: Haskell2010 executable hkt@@ -117,4 +118,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hopenpgp-tools.git- tag: hopenpgp-tools/0.23.11.1+ tag: hopenpgp-tools/0.24