hopenpgp-tools 0.25.5 → 0.25.6
raw patch · 4 files changed
+81/−226 lines, 4 filesdep ~hOpenPGP
Dependency ranges changed: hOpenPGP
Files
- HOpenPGP/Tools/Hokey/Lint.hs +5/−9
- hkt.hs +13/−31
- hop.hs +60/−183
- hopenpgp-tools.cabal +3/−3
HOpenPGP/Tools/Hokey/Lint.hs view
@@ -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"])
hkt.hs view
@@ -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))
hop.hs view
@@ -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 =
hopenpgp-tools.cabal view
@@ -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