diff --git a/HOpenPGP/Tools/Hokey/Lint.hs b/HOpenPGP/Tools/Hokey/Lint.hs --- a/HOpenPGP/Tools/Hokey/Lint.hs +++ b/HOpenPGP/Tools/Hokey/Lint.hs @@ -353,28 +353,24 @@ colored (Just Red) (Just ["not a V4 or V6 key"]) kv colorizePKA :: PubKeyAlgorithm -> Result PubKeyAlgorithm colorizePKA pka - | pka `elem` [RSA, EdDSA, ECDH, X25519, X448] -- FIXME: incomplete - = + | pka `elem` [RSA, EdDSALegacy, ECDH, Ed25519, Ed448, X25519, X448] = colored (Just Green) Nothing pka | otherwise = colored (Just Yellow) - (Just ["public key algorithm neither RSA nor EdDSA"]) + (Just ["public key algorithm neither RSA nor elliptic-curve"]) pka colorizePKS :: PubKeyAlgorithm -> Either String Int -> Result (Maybe Int) colorizePKS pka (Right pks) -- Group 256-bit ECC curves - | pka `elem` [X25519, ECDH, EdDSA] && pks >= 256 -- FIXME: incomplete - = + | pka `elem` [Ed25519, X25519, ECDH, EdDSALegacy] && pks >= 256 = withColor (Just Green) (Just pks) -- Group 448-bit ECC curves - | pka `elem` [X448] && pks >= 448 -- FIXME: incomplete - = + | pka `elem` [Ed448, X448] && pks >= 448 = withColor (Just Green) (Just pks) -- Catch-all for undersized ECC curves - | pka `elem` [X25519, X448, ECDH, EdDSA] -- FIXME: incomplete - = + | pka `elem` [Ed25519, Ed448, X25519, X448, ECDH, EdDSALegacy] = colored (Just Yellow) (Just ["Public key size insufficient for ECC algorithm"]) diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -174,6 +174,17 @@ import HOpenPGP.Tools.Common.Parser (parseTKExp) import HOpenPGP.Tools.Common.TKUtils (verifyTKWithTyped) +matchAny :: Text -> SomeTK -> Bool +matchAny srch tk = + either (const False) id $ + runExcept $ + fmap (keyMatchesFingerprint True tk) efp + <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok + <|> return (keyMatchesUIDSubString srch tk) + where + efp = (except . parseFingerprint) srch + eeok = (except . parseEightOctetKeyId) srch + grabMatchingKeysConduit :: (MonadResource m, MonadThrow m) => FilePath @@ -188,17 +199,8 @@ .| conduitDropErrorsAndNothings .| ( if filt then CL.filter (runPredicate ufp) - else CL.filter matchAny + else CL.filter (matchAny srch) ) - where - matchAny tk = - either (const False) id $ - runExcept $ - fmap (keyMatchesFingerprint True tk) efp - <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok - <|> return (keyMatchesUIDSubString srch tk) - efp = (except . parseFingerprint) srch - eeok = (except . parseEightOctetKeyId) srch grabMatchingKeys :: FilePath -> Bool -> Text -> IO [SomeTK] grabMatchingKeys fp filt srch = @@ -217,17 +219,8 @@ .| conduitGet get .| conduitToSomeTKsDroppingEither .| conduitDropErrorsAndNothings - .| CL.filter matchAny + .| CL.filter (matchAny srch) .| CL.consume - where - matchAny tk = - either (const False) id $ - runExcept $ - fmap (keyMatchesFingerprint True tk) efp - <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok - <|> return (keyMatchesUIDSubString srch tk) - efp = (except . parseFingerprint) srch - eeok = (except . parseEightOctetKeyId) srch grabMatchingPublicKeyring :: [SomeTK] -> IO PublicKeyring grabMatchingPublicKeyring keys = @@ -742,17 +735,6 @@ JSON -> BL.putStr . A.encode $ paf YAML -> B.putStr . Y.encode $ paf putStrLn "" - where - matchAny srch tk = - either (const False) id $ - runExcept $ - fmap - (keyMatchesFingerprint True tk) - ((except . parseFingerprint) srch) - <|> fmap - (keyMatchesEightOctetKeyId True tk . Right) - ((except . parseEightOctetKeyId) srch) - <|> return (keyMatchesUIDSubString srch tk) parseFilterPredicateIO :: Text -> IO (Either String (FilterPredicates Void SomeTK)) diff --git a/hop.hs b/hop.hs --- a/hop.hs +++ b/hop.hs @@ -42,6 +42,7 @@ , encryptForRecipients , recipientEncryptionTarget , recipientEncryptionTargetWithStrategyTyped + , renderPKESKEncryptError ) import Codec.Encryption.OpenPGP.Expirations ( effectiveKeyPreferencesAt @@ -145,6 +146,7 @@ ( DecryptKeyResolution (..) , DecryptOutcome (..) , PKESKRecipientKey (..) + , renderDecryptStructureError ) import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt import Data.Conduit.OpenPGP.Keyring @@ -1295,110 +1297,15 @@ loadPasswordFromFile :: String -> String -> FilePath -> IO BL.ByteString -loadPasswordFromFile context optionName path = do - case stripPrefix "@ENV:" path of - Just varName - | null varName -> - failWith - BadData - (context ++ ": empty environment variable name in " ++ optionName) - | otherwise -> do - envValue <- lookupEnv varName - case envValue of - Nothing -> - failWith - MissingInput - ( context - ++ ": environment variable not found for " - ++ optionName - ++ ": " - ++ varName - ) - Just envVal -> pure (BLC8.pack envVal) - Nothing -> - case stripPrefix "@FD:" path of - Just fdSpec -> loadPasswordFromFD context optionName fdSpec - Nothing -> - case path of - '@' : _ -> - failWith - UnsupportedSpecialPrefix - ( context - ++ ": unsupported special prefix for " - ++ optionName - ++ ": " - ++ path - ) - _ -> do - exists <- doesFileExist path - unless exists $ - failWith - MissingInput - ( context - ++ ": password file does not exist for " - ++ optionName - ++ ": " - ++ path - ) - BL.readFile path - -loadPasswordFromFD - :: String -> String -> String -> IO BL.ByteString -loadPasswordFromFD context optionName fdSpec = - case readMaybe fdSpec :: Maybe Int of - Just fdNum - | fdNum >= 0 -> - ( do - let fdPath = "/dev/fd/" ++ show fdNum - exists <- doesFileExist fdPath - unless exists $ - failWith - MissingInput - ( context - ++ ": file descriptor not available for " - ++ optionName - ++ ": " - ++ fdSpec - ) - contents <- BL.readFile fdPath - _ <- evaluate (BL.length contents) - pure contents - ) - `catch` ( \err -> - failWith - MissingInput - ( context - ++ ": failed reading file descriptor for " - ++ optionName - ++ ": " - ++ fdSpec - ++ " (" - ++ displayException (err :: IOException) - ++ ")" - ) - ) - | otherwise -> - failWith - BadData - ( context - ++ ": invalid file descriptor in " - ++ optionName - ++ ": " - ++ fdSpec - ) - _ -> - failWith - BadData - ( context - ++ ": invalid file descriptor in " - ++ optionName - ++ ": " - ++ fdSpec - ) +loadPasswordFromFile = loadFromFile "password file" loadInputFromFile :: String -> String -> FilePath -> IO BL.ByteString -loadInputFromFile context optionName path = do +loadInputFromFile = loadFromFile "file" + +loadFromFile + :: String -> String -> String -> FilePath -> IO BL.ByteString +loadFromFile fileKind context optionName path = do case stripPrefix "@ENV:" path of Just varName | null varName -> @@ -1420,7 +1327,7 @@ Just envVal -> pure (BLC8.pack envVal) Nothing -> case stripPrefix "@FD:" path of - Just fdSpec -> loadInputFromFD context optionName fdSpec + Just fdSpec -> loadFromFD context optionName fdSpec Nothing -> case path of '@' : _ -> @@ -1438,16 +1345,18 @@ failWith MissingInput ( context - ++ ": file does not exist for " + ++ ": " + ++ fileKind + ++ " does not exist for " ++ optionName ++ ": " ++ path ) BL.readFile path -loadInputFromFD +loadFromFD :: String -> String -> String -> IO BL.ByteString -loadInputFromFD context optionName fdSpec = +loadFromFD context optionName fdSpec = case readMaybe fdSpec :: Maybe Int of Just fdNum | fdNum >= 0 -> @@ -3536,37 +3445,32 @@ inlineVerifyPackets :: BL.ByteString -> IO (Bool, [Pkt]) inlineVerifyPackets lbs = do decodedArmors <- decodeAsciiArmorInput "inline-verify input" lbs - case decodedArmors of - Just armors -> - case listToMaybe (filter isInlineVerifyCandidateArmor armors) of - Just (Armor ArmorMessage _ bs) -> do - let packetBytes = BL.fromStrict (BLC8.toStrict bs) - packets <- - parseInlineVerifyMessagePackets - "inline-verify armored message" - packetBytes - pure (False, packets) - Just (ClearSigned headers cleartext signatureArmor) -> do - validateClearSignedEnvelopeBounds lbs - validateClearSignedHeaders headers - sigPkts <- clearSignedSignaturePackets signatureArmor - pure - ( True - , LiteralDataPkt - TextData - BL.empty - 0 - (BL.fromStrict (BLC8.toStrict cleartext)) - : sigPkts - ) - Just (Armor _ _ _) -> - failWith - BadData - "inline-verify expects an armored OpenPGP message or cleartext signed message" - Nothing -> do - packets <- - parseInlineVerifyMessagePackets "inline-verify input" lbs - pure (False, packets) + case decodedArmors + >>= listToMaybe . filter isInlineVerifyCandidateArmor of + Just (Armor ArmorMessage _ bs) -> do + let packetBytes = BL.fromStrict (BLC8.toStrict bs) + packets <- + parseInlineVerifyMessagePackets + "inline-verify armored message" + packetBytes + pure (False, packets) + Just (ClearSigned headers cleartext signatureArmor) -> do + validateClearSignedEnvelopeBounds lbs + validateClearSignedHeaders headers + sigPkts <- clearSignedSignaturePackets signatureArmor + pure + ( True + , LiteralDataPkt + TextData + BL.empty + 0 + (BL.fromStrict (BLC8.toStrict cleartext)) + : sigPkts + ) + Just (Armor _ _ _) -> + failWith + BadData + "inline-verify expects an armored OpenPGP message or cleartext signed message" Nothing -> do packets <- parseInlineVerifyMessagePackets "inline-verify input" lbs @@ -4138,29 +4042,31 @@ passwordBytes case strictOutcome of Right pkts -> pure pkts - Left reason - | shouldRetryLenientDecrypt reason keyCandidates passwordBytes -> do - lenientOutcome <- - runDecryptAttemptWithPolicy - lenientDecryptPolicy - keyCandidates - passwordBytes - case lenientOutcome of - Right pkts -> pure pkts - Left lenientReason -> + Left reason -> + let reasonStr = renderDecryptStructureError reason + in if shouldRetryLenientDecrypt reasonStr keyCandidates passwordBytes + then do + lenientOutcome <- + runDecryptAttemptWithPolicy + lenientDecryptPolicy + keyCandidates + passwordBytes + case lenientOutcome of + Right pkts -> pure pkts + Left lenientReason -> + failWith + BadData + ( "decrypt failed: malformed encrypted message structure (" + ++ renderDecryptStructureError lenientReason + ++ ")" + ) + else failWith BadData ( "decrypt failed: malformed encrypted message structure (" - ++ lenientReason + ++ reasonStr ++ ")" ) - | otherwise -> - failWith - BadData - ( "decrypt failed: malformed encrypted message structure (" - ++ reason - ++ ")" - ) shouldRetryLenientDecrypt reason keyCandidates passwordBytes | "ESK packets must immediately precede encrypted data" `isInfixOf` reason = @@ -5569,35 +5475,6 @@ in keyIdentifierLen == 16 || keyIdentifierLen == 20 || keyIdentifierLen == 32 - -renderPKESKEncryptError :: PKESKEncryptError -> String -renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm symAlgo err) = - "unsupported session-key algorithm " - ++ show symAlgo - ++ ": " - ++ err -renderPKESKEncryptError (InvalidSessionKeyLength symAlgo expected got) = - "invalid session-key length for " - ++ show symAlgo - ++ " (expected " - ++ show expected - ++ ", got " - ++ show got - ++ ")" -renderPKESKEncryptError (UnsupportedRecipientAlgorithm pka) = - "unsupported recipient public-key algorithm: " ++ show pka -renderPKESKEncryptError (InvalidRecipientKeyMaterial pka err) = - "invalid recipient key material for " ++ show pka ++ ": " ++ err -renderPKESKEncryptError (RecipientKdfFailure pka err) = - "recipient KDF failure for " ++ show pka ++ ": " ++ err -renderPKESKEncryptError (RecipientKeyWrapFailure pka err) = - "recipient key-wrap failure for " ++ show pka ++ ": " ++ err -renderPKESKEncryptError (PayloadBuildFailure err) = "payload build failure: " ++ err -renderPKESKEncryptError NoRecipientsProvided = "no recipients were provided" -renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) = - "recipient capability selection failure: " ++ show err -renderPKESKEncryptError (InvalidRecipientIdentifier err) = - "invalid recipient identifier: " ++ err sopFailureForPKESKEncryptError :: PKESKEncryptError -> SopFailure sopFailureForPKESKEncryptError err = 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.5 +version: 0.25.6 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.2 && < 3.3 + , hOpenPGP >= 3.3 && < 3.4 , lens , optparse-applicative >= 0.18.1 , prettyprinter >= 1.7 @@ -130,4 +130,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hopenpgp-tools.git - tag: hopenpgp-tools/0.25.5 + tag: hopenpgp-tools/0.25.6