diff --git a/HOpenPGP/Tools/Common/Armor.hs b/HOpenPGP/Tools/Common/Armor.hs --- a/HOpenPGP/Tools/Common/Armor.hs +++ b/HOpenPGP/Tools/Common/Armor.hs @@ -24,11 +24,23 @@ import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor (..)) +import Codec.Encryption.OpenPGP.Serialize () +import Codec.Encryption.OpenPGP.Types (Pkt (..)) +import Control.Applicative (many) +import Control.Exception + ( ErrorCall + , catch + , displayException + , evaluate + ) +import qualified Data.Binary as Bin +import Data.Binary.Get (runGet) 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 (stdin) +import System.Exit (ExitCode (ExitFailure), exitWith) +import System.IO (hPutStrLn, stderr, stdin) doDeArmor :: IO () doDeArmor = do @@ -36,9 +48,82 @@ let lbs = BL.fromChunks a case BL.uncons lbs of Just (firstByte, _) - | firstByte >= 0x80 -> BL.putStr lbs + | firstByte >= 0x80 -> do + packets <- parseBinaryPackets lbs + validatePackets packets + BL.putStr lbs | otherwise -> case (AA.decode (BL.toStrict lbs) :: Either String [Armor]) of - Right msgs -> BL.putStr $ BL.concat [bs | Armor _ _ bs <- msgs] - Left _ -> BL.putStr lbs - Nothing -> pure () + Right [] -> do + hPutStrLn stderr "dearmor: no ASCII armor blocks found" + exitWith (ExitFailure 41) + Right msgs + | length msgs /= 1 -> + failBadData "dearmor: expected exactly one ASCII armor block" + | otherwise -> do + let payloads = [bs | Armor _ _ bs <- msgs] + packets <- parseBinaryPackets (BL.concat payloads) + validatePackets packets + BL.putStr $ BL.concat payloads + Left err -> do + hPutStrLn stderr $ "dearmor: malformed ASCII armor: " ++ err + exitWith (ExitFailure 41) + Nothing -> failBadData "dearmor: no OpenPGP packets found" + +parseBinaryPackets :: BL.ByteString -> IO [Pkt] +parseBinaryPackets bytes = + evaluate (runGet (many Bin.get) bytes) `catch` parseFailure + where + parseFailure :: ErrorCall -> IO [Pkt] + parseFailure err = + failBadData + ( "dearmor: malformed OpenPGP packet stream: " + ++ displayException err + ) + +validatePackets :: [Pkt] -> IO () +validatePackets packets + | null packets = failBadData "dearmor: no OpenPGP packets found" + | any isBroken packets = + failBadData "dearmor: malformed OpenPGP packet stream" + | not (validShape packets) = + failBadData "dearmor: unexpected OpenPGP packet sequence" + | otherwise = pure () + where + isBroken BrokenPacketPkt {} = True + isBroken _ = False + validShape ps = + all isSignature ps + || validKeyStream ps + || validCiphertext ps + || validInlineSigned ps + isSignature SignaturePkt {} = True + isSignature _ = False + validKeyStream (SecretKeyPkt {} : _) = True + validKeyStream (PublicKeyPkt {} : _) = True + validKeyStream _ = False + validCiphertext (firstPacket : rest) = + isSessionKeyPacket firstPacket + && not (null rest) + && all isSessionKeyPacket (init rest) + && isEncryptedPayloadPacket (last rest) + validCiphertext _ = False + isSessionKeyPacket PKESKPkt {} = True + isSessionKeyPacket SKESKPkt {} = True + isSessionKeyPacket _ = False + validInlineSigned (firstPacket : rest) = + any isLiteralDataPacket rest + && (isOnePassSignaturePacket firstPacket || isSignature firstPacket) + validInlineSigned _ = False + isLiteralDataPacket LiteralDataPkt {} = True + isLiteralDataPacket _ = False + isOnePassSignaturePacket OnePassSignaturePkt {} = True + isOnePassSignaturePacket _ = False + isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True + isEncryptedPayloadPacket SymEncDataPkt {} = True + isEncryptedPayloadPacket _ = False + +failBadData :: String -> IO a +failBadData message = do + hPutStrLn stderr message + exitWith (ExitFailure 41) diff --git a/HOpenPGP/Tools/Common/Common.hs b/HOpenPGP/Tools/Common/Common.hs --- a/HOpenPGP/Tools/Common/Common.hs +++ b/HOpenPGP/Tools/Common/Common.hs @@ -133,7 +133,7 @@ keyMatchesFingerprint = keyMatchesPKPred fingerprint keyMatchesEightOctetKeyId - :: Bool -> SomeTK -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow + :: Bool -> SomeTK -> Either KeyIdError EightOctetKeyId -> Bool -- FIXME: refactor this somehow keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID keyMatchesExactUIDString :: Text -> SomeTK -> Bool @@ -143,8 +143,8 @@ keyMatchesUIDSubString uidstr stk = any (T.toLower uidstr `T.isInfixOf`) . map (T.toLower . fst) - . _tkUIDs $ - someTKToPublicViewTK stk + . _tkUIDs + $ someTKToPublicViewTK stk keyMatchesPKPred :: Eq a => (SomePKPayload -> a) -> Bool -> SomeTK -> a -> Bool 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 @@ -32,6 +32,7 @@ import Codec.Encryption.OpenPGP.Types ( Block (..) , Fingerprint + , KeySelectionError (..) , SomePKPayload (..) , SomeTK (..) , TK (..) @@ -43,6 +44,7 @@ import Control.Lens ((^..)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Data.Bifunctor (first) import Data.Binary (get, put) import Data.Binary.Put (runPut) import qualified Data.ByteString as B @@ -58,6 +60,7 @@ import Data.Conduit.Serialization.Binary (conduitGet) import Data.Data.Lens (biplate) import Data.Either (rights) +import qualified Data.Text as T import Data.Time.Clock.POSIX (getPOSIXTime) import Network.HTTP.Client ( Response (..) @@ -85,7 +88,7 @@ :: String -> FetchValidationMethod -> Fingerprint - -> ExceptT String IO [SomeTK] + -> ExceptT KeySelectionError IO [SomeTK] fetchKeys ks fvm q = do manager <- liftIO $ newManager tlsManagerSettings request <- liftIO $ parseUrlThrow (ks <> basereq) @@ -94,7 +97,9 @@ processedKeys <- if responseStatus response == ok200 then validateKeys (responseBody response) - else throwE ("HTTP status: " ++ show (responseStatus response)) + else + throwE . KeySelectionParseError . T.pack $ + "HTTP status: " ++ show (responseStatus response) return $ map fst $ filter (fvp fvm . primaryPKP . snd) processedKeys @@ -112,12 +117,11 @@ ] validateKeys - :: BL.ByteString -> ExceptT String IO [(SomeTK, SomeTK)] -- FIXME: conduit fail + :: BL.ByteString -> ExceptT KeySelectionError IO [(SomeTK, SomeTK)] -- FIXME: conduit fail validateKeys larmors = do bytestrings <- - ExceptT $ - return $ - fmap (mconcat . map armorToBS) (AA.decodeLazy larmors) + ExceptT . return . first (KeySelectionParseError . T.pack) $ + fmap (mconcat . map armorToBS) (AA.decodeLazy larmors) keys <- liftIO . runConduitRes $ CB.sourceLbs bytestrings diff --git a/HOpenPGP/Tools/Common/TKUtils.hs b/HOpenPGP/Tools/Common/TKUtils.hs --- a/HOpenPGP/Tools/Common/TKUtils.hs +++ b/HOpenPGP/Tools/Common/TKUtils.hs @@ -29,8 +29,7 @@ , defaultVerificationPolicy ) import Codec.Encryption.OpenPGP.Signatures - ( renderVerificationError - , verifyAgainstKeys + ( verifyAgainstKeys , verifySigWith , verifyTKWith ) 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 @@ -28,7 +28,8 @@ , ArmorType (ArmorPublicKeyBlock) ) import Codec.Encryption.OpenPGP.Types - ( SomeTK (..) + ( KeySelectionError (..) + , SomeTK (..) , someTKToPublicViewTK , _tkUIDs ) @@ -37,6 +38,7 @@ import Control.Monad.Trans.Except (ExceptT (..), throwE) import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHA +import Data.Bifunctor (first) import Data.Binary (get) import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import qualified Data.ByteArray as BA @@ -74,15 +76,19 @@ fetchKeys :: FetchValidationMethod -> Text - -> ExceptT String IO [SomeTK] + -> ExceptT KeySelectionError IO [SomeTK] fetchKeys fvm mailbox = do - parsedMailbox <- ExceptT . return $ parseMailbox mailbox + parsedMailbox <- + ExceptT . return . first (KeySelectionParseError . T.pack) $ + 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)) + else + throwE . KeySelectionParseError . T.pack $ + "HTTP status: " ++ show (responseStatus response) validateAndFilterKeys fvm parsedMailbox body parseMailbox :: Text -> Either String (Text, Text) @@ -100,7 +106,7 @@ fetchWKD :: Manager -> (Text, Text) - -> ExceptT String IO (Response BL.ByteString) + -> ExceptT KeySelectionError IO (Response BL.ByteString) fetchWKD manager (localPart, domain) = do let localPartLower = T.toLower localPart hu = BC8.unpack . zbase32 . sha1 . TE.encodeUtf8 $ localPartLower @@ -131,7 +137,7 @@ :: FetchValidationMethod -> (Text, Text) -> BL.ByteString - -> ExceptT String IO [SomeTK] + -> ExceptT KeySelectionError IO [SomeTK] validateAndFilterKeys fvm mailbox body = do keys <- decodeWkdResponse body cpt <- liftIO getPOSIXTime @@ -147,13 +153,14 @@ MatchPrimaryOrAnySubkeyFingerprint -> mailboxFiltered decodeWkdResponse - :: BL.ByteString -> ExceptT String IO [SomeTK] + :: BL.ByteString -> ExceptT KeySelectionError IO [SomeTK] decodeWkdResponse body = if isArmored body then decodeArmored body else decodeBinary body -decodeBinary :: BL.ByteString -> ExceptT String IO [SomeTK] +decodeBinary + :: BL.ByteString -> ExceptT KeySelectionError IO [SomeTK] decodeBinary bytes = liftIO . runConduitRes $ CB.sourceLbs bytes @@ -162,10 +169,11 @@ .| conduitDropErrorsAndNothings .| CL.consume -decodeArmored :: BL.ByteString -> ExceptT String IO [SomeTK] +decodeArmored + :: BL.ByteString -> ExceptT KeySelectionError IO [SomeTK] decodeArmored larmors = do bytestrings <- - ExceptT . return $ + ExceptT . return . first (KeySelectionParseError . T.pack) $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors) liftIO . runConduitRes $ CB.sourceLbs bytestrings diff --git a/HOpenPGP/Tools/Hokey/Fetch.hs b/HOpenPGP/Tools/Hokey/Fetch.hs --- a/HOpenPGP/Tools/Hokey/Fetch.hs +++ b/HOpenPGP/Tools/Hokey/Fetch.hs @@ -48,5 +48,5 @@ 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 + Left e -> hPutStrLn stderr $ "error fetching keys: " ++ show e Right ks -> B.putStr $ rearmorKeys ks diff --git a/HOpenPGP/Tools/Hokey/Lint/Policy.hs b/HOpenPGP/Tools/Hokey/Lint/Policy.hs --- a/HOpenPGP/Tools/Hokey/Lint/Policy.hs +++ b/HOpenPGP/Tools/Hokey/Lint/Policy.hs @@ -464,7 +464,14 @@ kasIt :: SomePKPayload -> Result KAS kasIt pkp = - kasIt' (_pkalgo pkp) (_keyVersion pkp) (_pubkey pkp & pubkeySize) + kasIt' + (_pkalgo pkp) + (_keyVersion pkp) + (mapLeft show (_pubkey pkp & pubkeySize)) + where + mapLeft :: (a -> b) -> Either a c -> Either b c + mapLeft f (Left x) = Left (f x) + mapLeft _ (Right x) = Right x kasIt' :: PubKeyAlgorithm -> KeyVersion -> Either String Int -> Result KAS diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -37,6 +37,7 @@ ( EightOctetKeyId , Fingerprint , HashAlgorithm (..) + , KeySelectionError (..) , PublicKey (..) , PublicKeyring , SigSubPacket (_sspPayload) @@ -435,6 +436,13 @@ banner' stderr >> hFlush stderr >> doExportPubkeys o dispatch (CmdGraph o) = banner' stderr >> hFlush stderr >> doGraph o dispatch (CmdFindPaths o) = banner' stderr >> hFlush stderr >> doFindPaths o + +instance Semigroup KeySelectionError where + KeySelectionParseError a <> KeySelectionParseError b = + KeySelectionParseError (a <> b) + +instance Monoid KeySelectionError where + mempty = KeySelectionParseError mempty main :: IO () main = do diff --git a/hop.hs b/hop.hs --- a/hop.hs +++ b/hop.hs @@ -18,6 +18,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA @@ -27,13 +28,10 @@ ) import Codec.Encryption.OpenPGP.CFB (encryptNoNonce) import Codec.Encryption.OpenPGP.Compression - ( CompressionError - , decompressPkt - , renderCompressionError + ( decompressPkt ) import Codec.Encryption.OpenPGP.Encrypt - ( PKESKEncryptError (..) - , PKESKSessionMaterial (..) + ( PKESKSessionMaterial (..) , RecipientEncryptRequest (..) , RecipientEncryptRequestOverrides (..) , RecipientEncryptResult (..) @@ -41,9 +39,10 @@ , RecipientPayloadShape (..) , defaultRecipientPayloadShape , encryptForRecipients + , encryptSEIPDv2Payload + , generateSessionKeyMaterial , recipientEncryptionTarget , recipientEncryptionTargetWithStrategyTyped - , renderPKESKEncryptError ) import Codec.Encryption.OpenPGP.Expirations ( effectiveKeyPreferencesAt @@ -85,29 +84,34 @@ , defaultPolicy , defaultVerificationPolicy , lenientDecryptPolicy + , messageDefaultAEADAlgorithm + , messageDefaultChunkSize + , messageSEIPDv2SaltOctets + , policyMessageEncryption ) import Codec.Encryption.OpenPGP.S2K ( decodeOpenPGPEncodedSessionKey - , renderS2KError , skesk2Key , skesk2SessionKey , string2Key ) +import Codec.Encryption.OpenPGP.SEIPDv2 + ( aeadModeAndNonceSizeForSEIPDv2 + , deriveSKESK6KEK + , encryptSKESK6SessionKey + ) import Codec.Encryption.OpenPGP.SecretKey ( SecretKeyEncryptOptions (..) , decryptSecretKeyAddendum , encryptSecretKeyWithPolicy , reencryptSecretKey - , renderSecretKeyError ) import Codec.Encryption.OpenPGP.Serialize ( parsePkts , putSKeyForPKPayload ) import Codec.Encryption.OpenPGP.Signatures - ( SignError (..) - , renderSignError - , signDataWithEd25519 + ( signDataWithEd25519 , signDataWithEd25519Legacy , signDataWithEd25519V6 , signDataWithEd448 @@ -122,11 +126,193 @@ ) import qualified Codec.Encryption.OpenPGP.Subpackets as SP import Codec.Encryption.OpenPGP.Types + ( AEADAlgorithm (EAX, GCM, OCB) + , Block (..) + , CompressionAlgorithm (BZip2, Uncompressed, ZIP, ZLIB) + , CompressionError + , EdSigningCurve (EdSigningCurve25519, EdSigningCurve448) + , EightOctetKeyId + , FeatureFlag (FeatureSEIPDv2) + , FileName (..) + , Fingerprint (Fingerprint, unFingerprint) + , HashAlgorithm + ( DeprecatedMD5 + , OtherHA + , RIPEMD160 + , SHA1 + , SHA224 + , SHA256 + , SHA384 + , SHA3_256 + , SHA3_512 + , SHA512 + ) + , IV (..) + , IssuerFingerprintVersion + ( IssuerFingerprintV4 + , IssuerFingerprintV6 + ) + , KeyFlag (..) + , KeyIdentifier (..) + , KeyPkt + ( KeyPktPublicPrimary + , KeyPktPublicSubkey + , KeyPktSecretPrimary + , KeyPktSecretSubkey + ) + , KeyPktKind (SecretPkt) + , KeyVersion (V4, V6) + , LiteralDataType (BinaryData, TextData, UTF8Data) + , MPI (..) + , PKESKEncryptError (..) + , PKESKPayload (PKESKPayloadV3Packet, PKESKPayloadV6Packet) + , PKESKPayloadV3 (..) + , PKESKPayloadV6 (..) + , PKPayload + , PKey (..) + , Passphrase (..) + , Pkt + ( BrokenPacketPkt + , CompressedDataPkt + , LiteralDataPkt + , MarkerPkt + , OnePassSignaturePkt + , OtherPacketPkt + , PKESKPkt + , PublicKeyPkt + , PublicSubkeyPkt + , SKESKPkt + , SecretKeyPkt + , SecretSubkeyPkt + , SignaturePkt + , SymEncDataPkt + , SymEncIntegrityProtectedDataPkt + ) + , PubKeyAlgorithm + ( DeprecatedRSAEncryptOnly + , DeprecatedRSASignOnly + , ECDH + , Ed25519 + , Ed448 + , EdDSALegacy + , ElgamalEncryptOnly + , RSA + , X25519 + , X448 + ) + , PublicKeyring + , RSA_PrivateKey (..) + , RevocationCode (KeyRetiredAndNoLongerUsed, KeySuperseded) + , S2K (Argon2, IteratedSalted, OtherS2K, Simple) + , SEIPDPayload (..) + , SKAddendum + ( SUSCFB + , SUSLegacyCFB + , SUSMalleableCFB + , SUSUnprotected + ) + , SKESK (SKESK4Packet) + , SKESKPayload (SKESKPayloadV4Packet, SKESKPayloadV6Packet) + , SKESKPayloadV4 (..) + , SKESKPayloadV6 (..) + , SKey + ( ECDHPrivateKey + , ECDSAPrivateKey + , Ed25519PrivateKey + , Ed448PrivateKey + , EdDSAPrivateKey + , ElGamalPrivateKey + , RSAPrivateKey + , UnknownSKey + , X25519PrivateKey + , X448PrivateKey + ) + , Salt (..) + , Salt16 (..) + , Salt8 (..) + , SecretKey (..) + , SessionKey (..) + , SigSubPacket (..) + , SigSubPacketPayload + ( EmbeddedSignature + , Features + , Issuer + , IssuerFingerprint + , KeyExpirationTime + , KeyFlags + , NotationData + , OtherSigSub + , PreferredAEADCiphersuites + , PreferredCompressionAlgorithms + , PreferredHashAlgorithms + , PreferredSymmetricAlgorithms + , PrimaryUserId + , ReasonForRevocation + , SigCreationTime + , SigExpirationTime + , UserDefinedSigSub + ) + , SigType (..) + , SignError (..) + , SignaturePayload (SigV3, SigV4, SigV6, SigVOther) + , SignatureSalt (..) + , SomePKPayload (..) + , SomeTK (SomePublicTK, SomeSecretTK) + , SymmetricAlgorithm + ( AES128 + , AES192 + , AES256 + , CAST5 + , IDEA + , OtherSA + , TripleDES + ) + , TK (..) + , TKKind (SecretTK) + , ThirtyTwoBitDuration (..) + , ThirtyTwoBitTimeStamp (..) + , UserAttrSubPacket + , UserAttribute (..) + , UserId (..) + , Verification (..) + , fromFVal + , fromUnknownToTK + , fromUnknownToTKEither + , keyPktPKPayload + , keyPktToPkt + , modifyTKSecretKeys + , publicViewTK + , renderCompressionError + , renderPKESKEncryptError + , renderS2KError + , renderSEIPDv2Failure + , renderSecretKeyError + , renderSerializeError + , renderSignError + , someTKToPublicViewTK + , someTKToSecretTK + , someTKToUnknown + , tkSecretKeyPairs + , toFVal + , _keyVersion + , _pkalgo + , _pubkey + , _timestamp + , _tkDirectKeySigs + , _tkRevs + , _tkSubs + , _tkUAts + , _tkUIDs + , _v3exp + , _verificationSignature + , pattern PKPayload + ) import qualified Codec.Encryption.OpenPGP.Version as HOV import Control.Applicative (many, optional, some, (<|>)) import Control.Error.Util (note) import Control.Exception - ( IOException + ( ErrorCall + , IOException , SomeException , catch , displayException @@ -258,7 +444,6 @@ , pretty , softline ) -import Prettyprinter.Render.Text (hPutDoc) import System.Directory (doesFileExist) import System.Environment (getArgs, getProgName, lookupEnv) import System.Exit @@ -268,7 +453,6 @@ ) import System.IO ( BufferMode (..) - , Handle , hPutStrLn , hSetBuffering , stderr @@ -485,6 +669,7 @@ | IncompatibleOptions | UnsupportedProfile | UnsupportedSubcommand + | AmbiguousInput | PrimaryKeyBad | CertUserIdNoMatch | KeyCannotCertify @@ -508,6 +693,7 @@ failureCode IncompatibleOptions = 83 failureCode UnsupportedProfile = 89 failureCode UnsupportedSubcommand = 69 +failureCode AmbiguousInput = 73 failureCode PrimaryKeyBad = 103 failureCode CertUserIdNoMatch = 107 failureCode KeyCannotCertify = 109 @@ -843,8 +1029,10 @@ ) ) -dispatch :: POSIXTime -> Command -> IO () -dispatch cpt cmd' = dispatch' cpt cmd' +dispatch :: Bool -> POSIXTime -> Command -> IO () +dispatch debug cpt cmd' = do + when debug $ hPutStrLn stderr "hop: debug mode enabled" + dispatch' cpt cmd' where dispatch' _ (VersionC o') = doVersion o' dispatch' _ (ListProfilesC o') = doListProfiles o' @@ -889,8 +1077,7 @@ args case result of Success cliOptions -> do - let _ = cliDebug cliOptions - dispatch cpt (cliCommand cliOptions) + dispatch (cliDebug cliOptions) cpt (cliCommand cliOptions) Failure f -> do let (msg, ec) = renderFailure f "hop" case ec of @@ -1064,18 +1251,32 @@ let lbs = BL.fromChunks m armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs if armoredAlready - then BL.putStr lbs + then do + armors <- + case AA.decodeLazy lbs of + Left err -> failWith BadData ("armor: malformed ASCII armor: " ++ err) + Right blocks -> pure blocks + when (length armors /= 1) $ + failWith BadData "armor: expected exactly one ASCII armor block" + case armors of + [Armor _ _ payload] -> do + packets <- decodeAllPackets payload `catch` armorFailure + validateTransportPackets "armor" packets + [_] -> pure () + _ -> pure () + BL.putStr lbs else do - let label' = guessLabel (decodeAllPackets lbs) lbs + packets <- decodeAllPackets lbs `catch` armorFailure + validateTransportPackets "armor" packets + let label' = guessLabel packets packets a = Armor label' [] lbs BL.putStr $ AA.encodeLazy [a] where - decodeAllPackets lbs = runGet (many Bin.get) lbs guessLabel [] _ = ArmorMessage - guessLabel (pkt : _) lbs = + guessLabel (pkt : _) packets = case pkt of SignaturePkt _ -> - if all isSignaturePacket (decodeAllPackets lbs) + if all isSignaturePacket packets then ArmorSignature else ArmorMessage SecretKeyPkt _ _ -> ArmorPrivateKeyBlock @@ -1084,6 +1285,60 @@ isSignaturePacket SignaturePkt {} = True isSignaturePacket _ = False +decodeAllPackets :: BL.ByteString -> IO [Pkt] +decodeAllPackets lbs = evaluate (runGet (many Bin.get) lbs) + +armorFailure :: ErrorCall -> IO [Pkt] +armorFailure err = + failWith + BadData + ( "armor: failed to parse OpenPGP packets: " + ++ displayException err + ) + +validateTransportPackets :: String -> [Pkt] -> IO () +validateTransportPackets context packets + | null packets = + failWith BadData (context ++ ": no OpenPGP packets found") + | any isBrokenTransportPacket packets = + failWith BadData (context ++ ": malformed OpenPGP packet stream") + | not (validTransportShape packets) = + failWith + BadData + (context ++ ": unexpected OpenPGP packet sequence") + | otherwise = + pure () + where + isBrokenTransportPacket BrokenPacketPkt {} = True + isBrokenTransportPacket _ = False + validTransportShape ps = + all isSignature ps + || validKeyStream ps + || validCiphertext ps + || validInlineSigned ps + isSignature SignaturePkt {} = True + isSignature _ = False + validKeyStream (SecretKeyPkt {} : _) = True + validKeyStream (PublicKeyPkt {} : _) = True + validKeyStream _ = False + validCiphertext (firstPacket : rest) = + isSessionKeyPacket firstPacket + && not (null rest) + && all isSessionKeyPacket (init rest) + && isEncryptedPayloadPacket (last rest) + validCiphertext _ = False + isSessionKeyPacket PKESKPkt {} = True + isSessionKeyPacket SKESKPkt {} = True + isSessionKeyPacket _ = False + validInlineSigned (firstPacket : rest) = + any isLiteralDataPacket rest + && (isOnePassSignaturePacket firstPacket || isSignature firstPacket) + validInlineSigned _ = False + isLiteralDataPacket LiteralDataPkt {} = True + isLiteralDataPacket _ = False + isOnePassSignaturePacket OnePassSignaturePkt {} = True + isOnePassSignaturePacket _ = False + doVersion :: VersionOptions -> IO () doVersion VersionOptions {..} = do let selected = length (filter id [vBackend, vExtended, vSopSpec, vSopv]) @@ -1102,9 +1357,9 @@ , "built with hOpenPGP " ++ HOV.version ] when vSopSpec $ - putStrLn "draft-dkg-openpgp-stateless-cli-16" + putStrLn "~draft-dkg-openpgp-stateless-cli-16" when vSopv $ - putStrLn "1.0" + putStrLn "1.2" unless (vBackend || vExtended || vSopSpec || vSopv) $ putStrLn $ "hop " ++ showVersion version @@ -1147,6 +1402,7 @@ doGenerateKey pt KeyGenOptions {..} = do profile <- parseKeyGenProfile keyProfile password <- parseGenerateKeyPassword keyPassword + mapM_ validateGenerateKeyUserId userIds let ts = ThirtyTwoBitTimeStamp (floor pt) keyVersion = keyVersionForProfile profile result <- runTKGen (keyVersion, ts) $ do @@ -1242,15 +1498,24 @@ <|> profileValue <$> find (\p -> name `elem` profileAliases p) profiles +validProfileName :: String -> Bool +validProfileName name = + not (null name) && not (any isSpace name) + parseKeyGenProfile :: Maybe String -> IO KeyGenProfile parseKeyGenProfile Nothing = pure KeyGenSecurity parseKeyGenProfile (Just name) = - case resolveProfile name keyGenProfiles of - Just p -> pure p - Nothing -> + if not (validProfileName name) + then failWith UnsupportedProfile - ("generate-key: unsupported profile " ++ name) + ("generate-key: invalid profile name " ++ name) + else case resolveProfile name keyGenProfiles of + Just p -> pure p + Nothing -> + failWith + UnsupportedProfile + ("generate-key: unsupported profile " ++ name) keyVersionForProfile :: KeyGenProfile -> KeyVersion keyVersionForProfile KeyGenRFC4880 = V4 @@ -1272,6 +1537,13 @@ . BL.toStrict ) +validateGenerateKeyUserId :: String -> IO () +validateGenerateKeyUserId uid = + when (T.any (== '\xFFFD') (T.pack uid)) $ + failWith + ExpectedText + "generate-key: USERID must be valid UTF-8 text" + loadPasswordFiles :: String -> String -> [String] -> IO [BL.ByteString] loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName) @@ -1288,27 +1560,51 @@ :: String -> String -> String -> FilePath -> IO BL.ByteString loadFromFile fileKind 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) + Just varName -> do + doesFileExist path >>= \exists -> + when exists $ + failWith + AmbiguousInput + ( context + ++ ": indirect input designator " + ++ optionName + ++ " (" + ++ path + ++ ") collides with a file of the same name" + ) + if null varName + then + failWith + BadData + (context ++ ": empty environment variable name in " ++ optionName) + else 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 -> loadFromFD context optionName fdSpec + Just fdSpec -> do + doesFileExist path >>= \exists -> + when exists $ + failWith + AmbiguousInput + ( context + ++ ": indirect input designator " + ++ optionName + ++ " (" + ++ path + ++ ") collides with a file of the same name" + ) + loadFromFD context optionName fdSpec Nothing -> case path of '@' : _ -> @@ -1458,7 +1754,7 @@ Left err -> Left (renderS2KError err) Right keyMaterial -> case putSKeyForPKPayload pkp skey of - Left err -> Left err + Left err -> Left (renderSerializeError err) Right putAction -> let cleartext = runPut putAction sha1Checksum = @@ -1698,7 +1994,7 @@ case sequence changed of Left err -> failWith - BadData + KeyIsProtected err Right rewrittenTks -> let output = runPut (mapM_ (Bin.put . someTKToUnknown) rewrittenTks) @@ -1754,6 +2050,10 @@ validateAtTime <- verificationUpperBound cpt validateUserIdAt input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy certPkts <- decodeOpenPGPInput "standard input" input + rejectSecretKeyPackets + "validate-userid" + "standard input" + certPkts certTks <- runConduitRes $ CL.sourceList certPkts @@ -1881,6 +2181,7 @@ "certify-userid: no signer certificate found" input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy certPkts <- decodeOpenPGPInput "standard input" input + rejectSecretKeyPackets "certify-userid" "standard input" certPkts targetTks <- runConduitRes $ CL.sourceList certPkts @@ -2180,11 +2481,19 @@ BadData ("revoke-key: failed: " ++ show err) Right sig -> pure sig - let output = runPut (mapM_ Bin.put revocationSigPkts) + let mergedCerts = + zipWith + ( \sk sig -> + let pubTk = someTKToPublicViewTK (SomeSecretTK sk) + in SomePublicTK pubTk {_tkRevs = _tkRevs pubTk ++ [sig]} + ) + secretKeyTks + revocationSigPkts + output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedCerts) BL.putStr $ if revokeKeyNoArmor then output - else AA.encodeLazy [Armor ArmorSignature [] output] + else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output] hasBadPrimaryKey :: TK 'SecretTK -> Bool hasBadPrimaryKey tk = @@ -2313,6 +2622,7 @@ stdinInput <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy stdinPkts <- decodeOpenPGPInput "stdin" stdinInput + rejectSecretKeyPackets "merge-certs" "stdin" stdinPkts stdinTks <- runConduitRes $ CL.sourceList stdinPkts @@ -2322,7 +2632,7 @@ mergeInTks <- concat <$> mapM - (\p -> loadVerifyTKsFromFile "merge-certs" p) + (\p -> loadCertTKsFromFile "merge-certs" p) mergeCertsFiles let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedTks) @@ -2893,9 +3203,9 @@ ( \salt -> signDataWithRSAV6Builder ( SP.addUnhashedSubs - (SubpacketList usd) + (SP.listToUnhashedSubs usd) ( SP.addHashedSubs - (SubpacketList hsd) + (SP.listToHashedSubs hsd) (SP.sigBuilderInitV6 st signHash salt) ) ) @@ -2924,9 +3234,9 @@ signWithRSABuilder hashToUse privateKey = let builder = SP.addUnhashedSubs - (SubpacketList usd) + (SP.listToUnhashedSubs usd) ( SP.addHashedSubs - (SubpacketList hsd) + (SP.listToHashedSubs hsd) (SP.sigBuilderInit st hashToUse) ) in case signDataWithRSABuilder builder privateKey payload of @@ -3001,7 +3311,7 @@ Left err -> failWith BadData - (ctx ++ " failed: unable to determine RSA key size: " ++ err) + (ctx ++ " failed: unable to determine RSA key size: " ++ show err) -- ============================== -- update-key modernization helpers @@ -3895,6 +4205,7 @@ _ -> "" where signatureMicalg (SigV4 _ _ ha _ _ _ _) = hashAlgorithmMicalg ha + signatureMicalg (SigV6 _ _ ha _ _ _ _ _) = hashAlgorithmMicalg ha signatureMicalg _ = Nothing hashAlgorithmMicalg DeprecatedMD5 = Just "pgp-md5" hashAlgorithmMicalg SHA1 = Just "pgp-sha1" @@ -4047,7 +4358,7 @@ doVerify cpt VerifyOptions {..} = do (krs, verifyTks) <- loadVerifyContext cpt verifyCertFiles signatureInput <- - runConduitRes $ CC.sourceFile verifySigFile .| CC.sinkLazy + loadInputFromFile "verify" "signature file" verifySigFile sigPkts <- decodeLikeSignaturePackets signatureInput let sigs = V.fromList (filter isDetachedVerificationSignaturePkt sigPkts) blob <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy @@ -4597,69 +4908,151 @@ -> Maybe String -> IO BL.ByteString doEncryptWithPassword encryptProfile payload passwords sessionKeyOutFile = do - password <- - case passwords of - [] -> - failWith - MissingArg - "encrypt: supply at least one recipient certificate or --with-password" - [p] -> pure p - _ -> - failWith - UnsupportedOption - "encrypt: multiple --with-password values are not yet supported" - let exposure = - if isJust sessionKeyOutFile - then ExposeSessionMaterial - else DoNotExposeSessionMaterial - encrypted <- - case encryptProfile of - EncryptProfileRFC9580 -> do - s2kSalt <- Salt16 <$> getRandomBytes 16 - iv <- IV <$> getRandomBytes 32 - pure $ - encryptMessage - RFC9580EncryptMessageOptions - { rfc9580EncryptMessageExposure = exposure - , rfc9580EncryptMessageSymmetricAlgorithm = AES256 - , rfc9580EncryptMessageS2K = Argon2 s2kSalt 1 4 15 - , rfc9580EncryptMessageIV = iv - } - password - (mkClearPayload payload) - EncryptProfileRFC4880 -> do - salt <- Salt8 <$> getRandomBytes 8 - iv <- IV <$> getRandomBytes 16 - pure $ - encryptMessage - RFC4880EncryptMessageOptions - { rfc4880EncryptMessageExposure = exposure - , rfc4880EncryptMessageSymmetricAlgorithm = AES256 - , rfc4880EncryptMessageS2K = IteratedSalted SHA256 salt 65536 - , rfc4880EncryptMessageIV = iv - } - password - (mkClearPayload payload) - case encrypted of - Left err -> failWith BadData ("encrypt failed: " ++ show err) - Right (ciphertext, mRecoveredSession) -> do - forM_ sessionKeyOutFile $ \path -> - case mRecoveredSession of - Just recoveredSession -> - writeFileWithOutputExistsCheck - "encrypt" - path - ( renderSessionKeyOutLine - (fromFVal (recoveredSessionAlgorithm recoveredSession)) - (unSessionKey (recoveredSessionKey recoveredSession)) - ++ "\n" - ) - Nothing -> - failWith - UnsupportedOption - "encrypt: --session-key-out unavailable for this password encryption mode" - pure (encryptedPayloadBytes ciphertext) + case passwords of + [] -> + failWith + MissingArg + "encrypt: supply at least one recipient certificate or --with-password" + [p] -> + encryptWithSinglePassword + encryptProfile + payload + p + sessionKeyOutFile + _ -> + case encryptProfile of + EncryptProfileRFC9580 -> + encryptWithSharedSessionKey payload passwords sessionKeyOutFile + EncryptProfileRFC4880 -> + failWith + UnsupportedOption + "encrypt: multiple --with-password values are not supported with the rfc4880 profile" + where + encryptWithSinglePassword prof pl pw skOut = do + let exposure = + if isJust skOut + then ExposeSessionMaterial + else DoNotExposeSessionMaterial + encrypted <- + case prof of + EncryptProfileRFC9580 -> do + s2kSalt <- Salt16 <$> getRandomBytes 16 + iv <- IV <$> getRandomBytes 32 + pure $ + encryptMessage + RFC9580EncryptMessageOptions + { rfc9580EncryptMessageExposure = exposure + , rfc9580EncryptMessageSymmetricAlgorithm = AES256 + , rfc9580EncryptMessageS2K = Argon2 s2kSalt 1 4 15 + , rfc9580EncryptMessageIV = iv + } + pw + (mkClearPayload pl) + EncryptProfileRFC4880 -> do + salt <- Salt8 <$> getRandomBytes 8 + iv <- IV <$> getRandomBytes 16 + pure $ + encryptMessage + RFC4880EncryptMessageOptions + { rfc4880EncryptMessageExposure = exposure + , rfc4880EncryptMessageSymmetricAlgorithm = AES256 + , rfc4880EncryptMessageS2K = IteratedSalted SHA256 salt 65536 + , rfc4880EncryptMessageIV = iv + } + pw + (mkClearPayload pl) + case encrypted of + Left err -> failWith BadData ("encrypt failed: " ++ show err) + Right (ciphertext, mRecoveredSession) -> do + forM_ skOut $ \path -> + case mRecoveredSession of + Just recoveredSession -> + writeFileWithOutputExistsCheck + "encrypt" + path + ( renderSessionKeyOutLine + (fromFVal (recoveredSessionAlgorithm recoveredSession)) + (unSessionKey (recoveredSessionKey recoveredSession)) + ++ "\n" + ) + Nothing -> + failWith + UnsupportedOption + "encrypt: --session-key-out unavailable for this password encryption mode" + pure (encryptedPayloadBytes ciphertext) + encryptWithSharedSessionKey pl pws skOut = do + let messagePolicy = policyMessageEncryption defaultPolicy + aead = messageDefaultAEADAlgorithm messagePolicy + chunkSize = messageDefaultChunkSize messagePolicy + saltOctets = messageSEIPDv2SaltOctets messagePolicy + genRes <- generateSessionKeyMaterial AES256 + sessionMaterial <- + either (failWith BadData . show) (pure . pkeskSessionKey) genRes + let skBytes = unSessionKey sessionMaterial + iv <- IV <$> getRandomBytes 32 + let salt = defaultSEIPDv2SaltFromIV saltOctets iv + (_, nonceSize) <- + either + (failWith BadData . renderSEIPDv2Failure) + pure + (aeadModeAndNonceSizeForSEIPDv2 aead) + let skeskIV = B.take nonceSize (unSalt salt) + s2kSalt = Salt16 (B.take 16 (unSalt salt)) + s2k = Argon2 s2kSalt 1 4 15 + literalBlock = + Block [LiteralDataPkt BinaryData (FileName B.empty) 0 pl] + literalBytes = BL.toStrict (runPut (Bin.put literalBlock)) + encRes = + encryptSEIPDv2Payload + AES256 + aead + chunkSize + salt + (SessionKey skBytes) + literalBytes + encBytes <- + either (failWith BadData . renderSEIPDv2Failure) pure encRes + let seipdPkt = + SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 aead chunkSize salt (BL.fromStrict encBytes)) + skeskPkts <- forM pws $ \pw -> do + let keyLen = 32 + ikm <- + either + (failWith BadData . renderS2KError) + pure + (string2Key s2k keyLen (unPassphrase pw)) + kek <- + either + (failWith BadData . renderSEIPDv2Failure) + pure + (deriveSKESK6KEK AES256 aead ikm) + (wrapped, tag) <- + either + (failWith BadData . renderSEIPDv2Failure) + pure + (encryptSKESK6SessionKey AES256 aead kek skeskIV skBytes) + pure + ( SKESKPkt + ( SKESKPayloadV6Packet + (SKESKPayloadV6 AES256 aead s2k skeskIV wrapped tag) + ) + ) + let out = runPut (mapM_ Bin.put (skeskPkts ++ [seipdPkt])) + forM_ skOut $ \path -> + writeFileWithOutputExistsCheck + "encrypt" + path + (renderSessionKeyOutLine (fromFVal AES256) skBytes ++ "\n") + pure out + +defaultSEIPDv2SaltFromIV :: Int -> IV -> Salt +defaultSEIPDv2SaltFromIV outputLen (IV ivBytes) = + Salt (B.take outputLen (B.concat (replicate outputLen seed))) + where + seed = if B.null ivBytes then B.singleton 0 else ivBytes + doEncryptForRecipients :: EncryptProfile -> AsBinaryText @@ -4833,20 +5226,23 @@ parseEncryptProfile :: Maybe String -> IO EncryptProfile parseEncryptProfile Nothing = pure EncryptProfileRFC9580 parseEncryptProfile (Just name) = - case resolveProfile name encryptProfiles of - Just p -> pure p - Nothing -> + if not (validProfileName name) + then failWith UnsupportedProfile - ("encrypt: unsupported profile " ++ name) + ("encrypt: invalid profile name " ++ name) + else case resolveProfile name encryptProfiles of + Just p -> pure p + Nothing -> + failWith + UnsupportedProfile + ("encrypt: unsupported profile " ++ name) doDecrypt :: POSIXTime -> DecryptOptions -> IO () doDecrypt cpt DecryptOptions {..} = do sessionKeys <- parseDecryptSessionKeys decSessionKeys - verificationOutputPath <- - resolveDecryptVerificationsOut decVerificationsOutFile let hasVerifyWith = not (null decVerifyCerts) - hasVerifyOut = isJust verificationOutputPath + hasVerifyOut = isJust decVerificationsOutFile hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter doingVerification = hasVerifyWith && hasVerifyOut when (hasVerifyWith /= hasVerifyOut) $ @@ -5029,7 +5425,7 @@ doDecryptVerifyOutput cpt decVerifyCerts - verificationOutputPath + decVerificationsOutFile decVerifyNotBefore decVerifyNotAfter decryptedPkts @@ -5229,13 +5625,14 @@ ("decrypt: invalid --with-session-key algorithm: " ++ algoSpec) decodeHexBytes :: String -> IO B.ByteString -decodeHexBytes hex = - if odd (length hex) - then - failWith - BadData - "decrypt: hex key material must have an even number of digits" - else B.pack <$> go hex +decodeHexBytes rawHex = + let hex = filter (`notElem` (" \t\r\n\f\v" :: String)) rawHex + in if odd (length hex) + then + failWith + BadData + "decrypt: hex key material must have an even number of digits" + else B.pack <$> go hex where go [] = pure [] go (a : b : rest) = do @@ -5504,13 +5901,6 @@ BadData "decrypt failed: malformed signed message structure (multiple literal payloads)" -resolveDecryptVerificationsOut - :: Maybe String -> IO (Maybe String) -resolveDecryptVerificationsOut newPath = - pure $ case newPath of - Just p -> Just p - Nothing -> Nothing - renderSOPVerificationLine :: [SomeTK] -> Verification -> String renderSOPVerificationLine verifyTks v = @@ -5560,8 +5950,28 @@ :: String -> FilePath -> String -> IO () writeFileWithOutputExistsCheck subcommand path content = do ensureOutputPathAvailable subcommand path - writeFile path content + outputPath <- outputPathForWrite subcommand path + writeFile outputPath content `catch` outputFailure + where + outputFailure :: IOException -> IO () + outputFailure err = + failWith + BadData + (subcommand ++ ": failed writing output: " ++ displayException err) +writeLazyByteStringWithOutputExistsCheck + :: String -> FilePath -> BL.ByteString -> IO () +writeLazyByteStringWithOutputExistsCheck subcommand path content = do + ensureOutputPathAvailable subcommand path + outputPath <- outputPathForWrite subcommand path + BL.writeFile outputPath content `catch` outputFailure + where + outputFailure :: IOException -> IO () + outputFailure err = + failWith + BadData + (subcommand ++ ": failed writing output: " ++ displayException err) + parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt] parseOpenPGPPackets context bytes = ( do @@ -5739,13 +6149,47 @@ noteLeft err = maybe (Left err) Right ensureOutputPathAvailable :: String -> FilePath -> IO () -ensureOutputPathAvailable subcommand path = do - exists <- doesFileExist path - when exists $ - failWith - OutputExists - (subcommand ++ ": output path already exists: " ++ path) +ensureOutputPathAvailable subcommand path = + case stripPrefix "@ENV:" path of + Just _ -> + failWith + UnsupportedSpecialPrefix + (subcommand ++ ": @ENV: is not supported for output: " ++ path) + Nothing -> + case stripPrefix "@FD:" path of + Just fdSpec -> + case readMaybe fdSpec :: Maybe Int of + Just fdNum + | fdNum >= 0 -> pure () + _ -> + failWith + BadData + (subcommand ++ ": invalid output file descriptor: " ++ path) + Nothing + | "@" `isPrefixOf` path -> + failWith + UnsupportedSpecialPrefix + (subcommand ++ ": unsupported output prefix: " ++ path) + | otherwise -> do + exists <- doesFileExist path + when exists $ + failWith + OutputExists + (subcommand ++ ": output path already exists: " ++ path) +outputPathForWrite :: String -> FilePath -> IO FilePath +outputPathForWrite subcommand path = + case stripPrefix "@FD:" path of + Just fdSpec -> + case readMaybe fdSpec :: Maybe Int of + Just fdNum + | fdNum >= 0 -> pure ("/dev/fd/" ++ show fdNum) + _ -> + failWith + BadData + (subcommand ++ ": invalid output file descriptor: " ++ path) + Nothing -> pure path + loadVerifyContext :: POSIXTime -> [String] -> IO (PublicKeyring, [SomeTK]) loadVerifyContext _ certFiles = do @@ -6448,8 +6892,10 @@ partition ( \pkt -> case pkt of - PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)) -> - any (matchesRecipientIdentifier rid) keyInfos + PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 (Just (_, fp)) _ _)) -> + any (matchesRecipientIdentifier (unFingerprint fp)) keyInfos + PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 Nothing _ _)) -> False PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ eoki _ _)) -> any (matchesLegacyRecipientKeyId eoki) keyInfos _ -> False @@ -6567,8 +7013,12 @@ signingKeys = filter isInlineRSASigner funkeys inlineSignHash = selectSigningHash signingKeys [] legacySigningHashFallbackOrder + when (null processedKeys) $ + failWith MissingInput "inline-sign: no signing key found" when (null signingKeys) $ - failWith MissingInput "inline-sign: no signing-capable key found" + failWith + KeyCannotSign + "inline-sign: supplied key is not capable of signing" sigs <- mapM ( signInlineData @@ -6704,7 +7154,12 @@ splitInlineSigned lbs = do decodedArmors <- decodeAsciiArmorInput "inline-detach input" lbs case decodedArmors of - Just armors -> + Just armors -> do + let candidates = filter isInlineSignedArmorCandidate armors + when (length candidates > 1) $ + failWith + BadData + "inline-detach: more than one inline-signed object found in input" case firstBy isInlineSignedArmorCandidate armors of Just (Armor ArmorMessage _ bs) -> parseOpenPGPPackets @@ -6997,7 +7452,10 @@ else BL.fromStrict (BLC8.toStrict (AA.encodeLazy [Armor ArmorSignature [] sigBytes])) - BL.writeFile outPath out + writeLazyByteStringWithOutputExistsCheck + "inline-detach" + outPath + out doListProfiles :: ListProfilesOptions -> IO () doListProfiles lpos = @@ -7024,5 +7482,5 @@ where aliasesSuffix p = case profileAliases p of [] -> "" - s : [] -> " (alias: " ++ s ++ ")" + [s] -> " (alias: " ++ s ++ ")" as -> " (aliases: " ++ intercalate ", " as ++ ")" 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.9 +version: 0.25.10 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.5 && < 3.6 + , hOpenPGP >= 3.6 && < 3.7 , 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.9 + tag: hopenpgp-tools/0.25.10