diff --git a/HOpenPGP/Tools/Common/HKP.hs b/HOpenPGP/Tools/Common/HKP.hs --- a/HOpenPGP/Tools/Common/HKP.hs +++ b/HOpenPGP/Tools/Common/HKP.hs @@ -38,7 +38,6 @@ , TK (..) , keyPktPKPayload , someTKToPublicViewTK - , someTKToUnknown ) import Control.Arrow ((&&&)) import Control.Lens ((^..)) @@ -147,4 +146,4 @@ . runPut . put . Block - $ map someTKToUnknown stks + $ stks diff --git a/HOpenPGP/Tools/Common/WKD.hs b/HOpenPGP/Tools/Common/WKD.hs --- a/HOpenPGP/Tools/Common/WKD.hs +++ b/HOpenPGP/Tools/Common/WKD.hs @@ -210,16 +210,29 @@ zbase32 = BC8.pack . encodeZBase32 . B.unpack encodeZBase32 :: [Word8] -> String -encodeZBase32 = go 0 0 +encodeZBase32 = go (0 :: Integer) (0 :: Int) where alphabet = "ybndrfg8ejkmcpqxot1uwisza345h769" pick i = alphabet !! i + go :: Integer -> Int -> [Word8] -> String go _ 0 [] = [] go acc bits [] = - [pick (fromIntegral (((acc `shiftL` (5 - bits)) .&. 31) :: Int))] + if bits >= 5 + then + pick + (fromIntegral (((acc `shiftR` (bits - 5)) .&. 31) :: Integer)) + : go acc (bits - 5) [] + else + if bits > 0 + then + [ pick + (fromIntegral (((acc `shiftL` (5 - bits)) .&. 31) :: Integer)) + ] + else [] go acc bits (x : xs) | bits >= 5 = - pick (fromIntegral (((acc `shiftR` (bits - 5)) .&. 31) :: Int)) + pick + (fromIntegral (((acc `shiftR` (bits - 5)) .&. 31) :: Integer)) : go acc (bits - 5) (x : xs) | otherwise = go ((acc `shiftL` 8) .|. fromIntegral x) (bits + 8) xs diff --git a/HOpenPGP/Tools/Hokey/Canonicalize.hs b/HOpenPGP/Tools/Hokey/Canonicalize.hs --- a/HOpenPGP/Tools/Hokey/Canonicalize.hs +++ b/HOpenPGP/Tools/Hokey/Canonicalize.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + -- Canonicalize.hs: hOpenPGP key tool canonicalize subcommand -- Copyright © 2013-2026 Clint Adams -- @@ -23,7 +25,6 @@ import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types ( SomeTK (..) - , someTKToUnknown , _tkRevs , _tkSubs , _tkUAts @@ -53,13 +54,13 @@ .| conduitToSomeTKsDroppingEither .| conduitDropErrorsAndNothings .| CL.map canonicalize - .| CL.map someTKToUnknown .| CL.map put .| conduitPut .| CB.sinkHandle stdout where canonicalize (SomePublicTK tk) = SomePublicTK (canonicalizeTK tk) canonicalize (SomeSecretTK tk) = SomeSecretTK (canonicalizeTK tk) + canonicalize (SomeMixedTK tk) = SomeMixedTK (canonicalizeTK tk) canonicalizeTK tk = tk { _tkRevs = sort (_tkRevs tk) diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -49,10 +49,10 @@ , TK (..) , UserAttribute (..) , UserId (..) + , asMixedTK , keyPktPKPayload , keyPktToPkt , someTKToPublicViewTK - , someTKToUnknown , _pkalgo , _pubkey ) @@ -529,8 +529,8 @@ grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o) case pathsOutputFormat o of Unstructured -> mapM_ (BL.putStr . putTK') keys - JSON -> BL.putStr . A.encode $ map someTKToUnknown keys - YAML -> B.putStr . Y.encode $ map someTKToUnknown keys + JSON -> BL.putStr . A.encode $ keys + YAML -> B.putStr . Y.encode $ keys where putTK' tk = runPut $ do @@ -604,7 +604,7 @@ fp = fingerprint (keyPktPKPayload (_tkPrimaryKey publicView)) keyids = rights . map eightOctetKeyID $ - (someTKToUnknown stk ^.. biplate :: [SomePKPayload]) + (asMixedTK stk ^.. biplate :: [SomePKPayload]) i' = i + 1 k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids f2i' = HashMap.insert fp i' f2i @@ -645,7 +645,7 @@ ("hkt: no graph node for fingerprint " ++ renderFingerprint fp) fakejoin (x, y) = fmap ((,) x) y sigs tk = - someTKToUnknown tk ^.. biplate :: [SignaturePayload] + asMixedTK tk ^.. biplate :: [SignaturePayload] samesies (x, y, _) = x == y data PaF diff --git a/hop.hs b/hop.hs --- a/hop.hs +++ b/hop.hs @@ -260,7 +260,7 @@ , SignaturePayload (SigV3, SigV4, SigV6, SigVOther) , SignatureSalt (..) , SomePKPayload (..) - , SomeTK (SomePublicTK, SomeSecretTK) + , SomeTK (SomeMixedTK, SomePublicTK, SomeSecretTK) , SymmetricAlgorithm ( AES128 , AES192 @@ -279,9 +279,8 @@ , UserAttribute (..) , UserId (..) , Verification (..) + , asMixedTK , fromFVal - , fromUnknownToTK - , fromUnknownToTKEither , keyPktPKPayload , keyPktToPkt , modifyTKSecretKeys @@ -295,7 +294,6 @@ , renderSignError , someTKToPublicViewTK , someTKToSecretTK - , someTKToUnknown , tkSecretKeyPairs , toFVal , _keyVersion @@ -377,6 +375,7 @@ ( conduitVerify , verifyPacketsBatch ) +import Data.Containers.ListUtils (nubOrd) import Data.Data.Lens (biplate) import Data.Either (fromRight, isLeft, isRight, rights) import Data.IORef (IORef, atomicModifyIORef', newIORef) @@ -1449,7 +1448,7 @@ encryptTransferableSecretKey password tk - let lbs = runPut $ Bin.put (someTKToUnknown (SomeSecretTK tk')) + let lbs = runPut $ Bin.put (SomeSecretTK tk') BL.putStr $ if not noArmor then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs] @@ -1485,18 +1484,17 @@ \pkp ska -> (pkp, fromMaybe ska (lookup pkp index)) data KeyGenProfile - = KeyGenRFC4880 - | KeyGenSecurity - | KeyGenSigningOnly + = KeyGenRFC9580 + | KeyGenRFC4880 deriving (Eq) keyGenProfiles :: [Profile KeyGenProfile] keyGenProfiles = [ Profile - "security" + "rfc9580" "Ed25519 signing key, X25519 encryption subkey" - KeyGenSecurity - ["default", "performance", "rfc9580"] + KeyGenRFC9580 + ["default", "performance", "security"] , Profile "rfc4880" "RSA-4096 (v4 keys)" @@ -1515,7 +1513,7 @@ not (null name) && not (any isSpace name) parseKeyGenProfile :: Maybe String -> IO KeyGenProfile -parseKeyGenProfile Nothing = pure KeyGenSecurity +parseKeyGenProfile Nothing = pure KeyGenRFC9580 parseKeyGenProfile (Just name) = if not (validProfileName name) then @@ -1531,8 +1529,7 @@ keyVersionForProfile :: KeyGenProfile -> KeyVersion keyVersionForProfile KeyGenRFC4880 = V4 -keyVersionForProfile KeyGenSecurity = V6 -keyVersionForProfile KeyGenSigningOnly = V6 +keyVersionForProfile KeyGenRFC9580 = V6 parseGenerateKeyPassword :: Maybe String -> IO (Maybe Passphrase) @@ -1720,7 +1717,7 @@ passwordRetryCandidates :: B.ByteString -> [B.ByteString] passwordRetryCandidates passwordBytes = - case TE.decodeUtf8' passwordBytes of + nubOrd $ case TE.decodeUtf8' passwordBytes of Left _ -> [passwordBytes] Right txt -> let trimmed = TE.encodeUtf8 (T.dropWhileEnd isSpace txt) @@ -1738,16 +1735,13 @@ _ <- addSubkey RSA [EncryptStorageKey, EncryptCommunicationsKey] _ <- addSubkey RSA [AuthKey] pure () -addSubkeysForProfile KeyGenSecurity signingOnly = do +addSubkeysForProfile KeyGenRFC9580 signingOnly = do _ <- addSubkey Ed25519 [SignDataKey] unless signingOnly $ do _ <- addSubkey X25519 [EncryptStorageKey, EncryptCommunicationsKey] _ <- addSubkey Ed25519 [AuthKey] pure () -addSubkeysForProfile KeyGenSigningOnly _ = do - _ <- addSubkey Ed25519 [SignDataKey] - pure () encryptUnencryptedV4SecretKey :: SomePKPayload @@ -1956,7 +1950,7 @@ failWith MissingInput "extract-cert: no transferable secret key found on standard input" - let output = runPut $ mapM_ (Bin.put . someTKToUnknown . pubToSecret) tks + let output = runPut $ mapM_ (Bin.put . pubToSecret) tks BL.putStr $ if not ecNoArmor then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output] @@ -2009,7 +2003,7 @@ KeyIsProtected err Right rewrittenTks -> - let output = runPut (mapM_ (Bin.put . someTKToUnknown) rewrittenTks) + let output = runPut (mapM_ Bin.put rewrittenTks) in BL.putStr $ if changeKeyPasswordNoArmor || BL.null output then output @@ -2216,7 +2210,7 @@ signerTks ) targetTks - let output = runPut (mapM_ (Bin.put . someTKToUnknown) updatedTargets) + let output = runPut (mapM_ Bin.put updatedTargets) BL.putStr $ if certifyUserIdNoArmor then output @@ -2501,7 +2495,7 @@ ) secretKeyTks revocationSigPkts - output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedCerts) + output = runPut (mapM_ Bin.put mergedCerts) BL.putStr $ if revokeKeyNoArmor then output @@ -2582,22 +2576,19 @@ let mergedTks = map ( \targetTk -> - let mergedTkUnknown = + let merged = foldl' (<>) - (someTKToUnknown (SomeSecretTK targetTk)) - ( map - someTKToUnknown - ( selectUpdateMergeInputs - cpt - updateKeyNoAddedCapabilities - (SomeSecretTK targetTk) - updateTks - ) + (SomeSecretTK targetTk) + ( selectUpdateMergeInputs + cpt + updateKeyNoAddedCapabilities + (SomeSecretTK targetTk) + updateTks ) - in case fromUnknownToTKEither mergedTkUnknown of - Right mergedStk -> mergedStk - Left _ -> SomeSecretTK targetTk + in case merged of + SomeSecretTK mergedStk -> SomeSecretTK mergedStk + _ -> SomeSecretTK targetTk ) stdinUnlocked strippedTks = @@ -2623,7 +2614,7 @@ if any hasSecretKeyMaterial modernizedTks then ArmorPrivateKeyBlock else ArmorPublicKeyBlock - output = runPut (mapM_ (Bin.put . someTKToUnknown) modernizedTks) + output = runPut (mapM_ Bin.put modernizedTks) BL.putStr $ if updateKeyNoArmor then output @@ -2647,7 +2638,7 @@ (\p -> loadCertTKsFromFile "merge-certs" p) mergeCertsFiles let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks - output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedTks) + output = runPut (mapM_ Bin.put mergedTks) BL.putStr $ if mergeCertsNoArmor || BL.null output then output @@ -2663,21 +2654,15 @@ mergeGroup (base, rest) = let primary = certificatePrimaryFingerprint base mergedStdin = - case fromUnknownToTKEither - (foldl' (<>) (someTKToUnknown base) (map someTKToUnknown rest)) of - Right mergedStk -> mergedStk - Left _ -> base + case foldl' (<>) base rest of + SomeMixedTK _ -> base + x -> x matchingMergeInputs = filter ((== primary) . certificatePrimaryFingerprint) mergeInTks mergedAll = - case fromUnknownToTKEither - ( foldl' - (<>) - (someTKToUnknown mergedStdin) - (map someTKToUnknown matchingMergeInputs) - ) of - Right mergedStk -> mergedStk - Left _ -> mergedStdin + case foldl' (<>) mergedStdin matchingMergeInputs of + SomeMixedTK _ -> mergedStdin + x -> x in mergedAll groupByPrimaryKey :: [SomeTK] -> [(SomeTK, [SomeTK])] @@ -7038,7 +7023,7 @@ tkToEncryptPayloads stk = filter supportsRecipientPKESKAlgorithm - (someTKToUnknown stk ^.. biplate :: [SomePKPayload]) + (asMixedTK stk ^.. biplate :: [SomePKPayload]) extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload extractEncryptRecipientPayload pkt = diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal --- a/hopenpgp-tools.cabal +++ b/hopenpgp-tools.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hopenpgp-tools -version: 0.25.13 +version: 0.26 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: https://salsa.debian.org/clint/hOpenPGP-tools @@ -25,7 +25,7 @@ , bytestring , conduit >= 1.3 , errors - , hOpenPGP >= 3.6.3 && < 3.7 + , hOpenPGP >= 3.7 && < 3.8 , lens , optparse-applicative >= 0.18.1 , prettyprinter >= 1.7 @@ -132,4 +132,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hopenpgp-tools.git - tag: hopenpgp-tools/0.25.13 + tag: hopenpgp-tools/0.26