hopenpgp-tools 0.25.3.1 → 0.25.3.2
raw patch · 3 files changed
+355/−373 lines, 3 files
Files
- HOpenPGP/Tools/Common/Armor.hs +15/−10
- hop.hs +338/−361
- hopenpgp-tools.cabal +2/−2
HOpenPGP/Tools/Common/Armor.hs view
@@ -19,21 +19,26 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. module HOpenPGP.Tools.Common.Armor- ( doDeArmor- ) where+ ( doDeArmor+ ) where import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA-import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..))-import qualified Data.ByteString as B+import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor (..)) import qualified Data.ByteString.Lazy as BL-import Data.Conduit ((.|), runConduitRes)+import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL-import System.IO (hPutStrLn, stderr, stdin)+import System.IO (stdin) doDeArmor :: IO () doDeArmor = do- a <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- case AA.decode (B.concat a) of- Left e -> hPutStrLn stderr $ "Failure to decode ASCII Armor:" ++ e- Right msgs -> BL.putStr $ BL.concat [ bs | Armor _ _ bs <- msgs ]+ a <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ let lbs = BL.fromChunks a+ case BL.uncons lbs of+ Just (firstByte, _)+ | firstByte >= 0x80 -> 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 ()
hop.hs view
@@ -85,7 +85,6 @@ import Codec.Encryption.OpenPGP.Signatures ( SignError (..) , renderSignError- , signCertRevocationWithRSA , signDataWithEd25519 , signDataWithEd25519Legacy , signDataWithEd25519V6@@ -98,6 +97,7 @@ ) import qualified Codec.Encryption.OpenPGP.Subpackets as SP import Codec.Encryption.OpenPGP.Types+import qualified Codec.Encryption.OpenPGP.Version as HOV import Control.Applicative (many, optional, some, (<|>)) import Control.Error.Util (note) import Control.Exception@@ -107,6 +107,7 @@ , displayException , evaluate , throwIO+ , try ) import Control.Lens ((^..)) import Control.Monad (forM, forM_, unless, when, (>=>))@@ -273,7 +274,6 @@ | ValidateUserIdC ValidateUserIdOptions | CertifyUserIdC CertifyUserIdOptions | RevokeKeyC RevokeKeyOptions- | RevokeUserIdC RevokeUserIdOptions | UpdateKeyC UpdateKeyOptions | VerifyC VerifyOptions | InlineVerifyC InlineVerifyOptions@@ -285,7 +285,7 @@ | SignC SignOptions | UnsupportedC String | DeArmorC- | ArmorC ArmoringOptions+ | ArmorC data OutputFormat = Unstructured@@ -312,14 +312,12 @@ data EncryptOptions = EncryptOptions { encNoArmor :: Bool- , encArmor :: Bool , encProfile :: Maybe String , encAs :: AsBinaryText , encSignWithKeyFiles :: [String] , encSignWithKeyPasswords :: [String] , encSessionKeyOutFile :: Maybe String , encFor :: EncryptFor- , encWithoutIntegrityCheck :: Bool , encPasswords :: [String] , encRecipientCerts :: [String] }@@ -329,11 +327,30 @@ | EncryptProfileRFC4880 deriving (Eq) +data Profile p = Profile+ { profileName :: String+ , profileDescription :: String+ , profileValue :: p+ , profileAliases :: [String]+ }++encryptProfiles :: [Profile EncryptProfile]+encryptProfiles =+ [ Profile+ "rfc9580"+ "SEIPDv2"+ EncryptProfileRFC9580+ ["default", "security", "performance"]+ , Profile+ "rfc4880"+ "SEIPDv1"+ EncryptProfileRFC4880+ ["compatibility"]+ ]+ data DecryptOptions = DecryptOptions { decNoArmor :: Bool- , decArmor :: Bool- , decWithoutIntegrityCheck :: Bool , decVerifyNotBefore :: Maybe String , decVerifyNotAfter :: Maybe String , decSessionKeys :: [String]@@ -343,14 +360,11 @@ , decKeyFiles :: [String] , decVerifyCerts :: [String] , decVerificationsOutFile :: Maybe String- , decDeprecatedVerifyOutFile :: Maybe String } data InlineSignOptions = InlineSignOptions { inlineSignNoArmor :: Bool- , inlineSignArmor :: Bool- , inlineSignProfile :: Maybe String , inlineSignAs :: Maybe InlineSignMode , inlineSignKeyFiles :: [String] , inlineSignKeyPasswords :: [String]@@ -366,7 +380,7 @@ = ChangeKeyPasswordOptions { changeKeyPasswordNoArmor :: Bool , changeKeyPasswordOldPasswords :: [String]- , changeKeyPasswordNewPasswords :: [String]+ , changeKeyPasswordNewPassword :: Maybe String } data MergeCertsOptions@@ -386,7 +400,7 @@ data CertifyUserIdOptions = CertifyUserIdOptions { certifyUserIds :: [String]- , certifyUserIdOutputFormat :: Maybe String+ , certifyUserIdNoArmor :: Bool , certifyUserIdNoRequireSelfSig :: Bool , certifyUserIdKeyPasswordFiles :: [String] , certifyUserIdSignerFiles :: [String]@@ -398,12 +412,6 @@ , revokeKeyPasswordFiles :: [String] } -data RevokeUserIdOptions- = RevokeUserIdOptions- { revokeUserIdString :: String- , revokeUserIdNoArmor :: Bool- }- data UpdateKeyOptions = UpdateKeyOptions { updateKeyNoArmor :: Bool@@ -560,7 +568,6 @@ encP = EncryptOptions <$> switch (long "no-armor" <> help "output binary")- <*> switch (long "armor" <> help "output ASCII Armor") <*> optional (strOption (long "profile" <> help "encryption profile")) <*> option@@ -589,10 +596,6 @@ "select recipient key purpose (any, storage, communications)" <> value EncryptForAny )- <*> switch- ( long "without-integrity-check"- <> help "disable integrity protection"- ) <*> many ( strOption (long "with-password" <> help "symmetric encryption password")@@ -612,11 +615,6 @@ decP = DecryptOptions <$> switch (long "no-armor" <> help "output binary")- <*> switch (long "armor" <> help "output ASCII Armor")- <*> switch- ( long "without-integrity-check"- <> help "disable integrity verification"- ) <*> optional ( strOption ( long "verify-not-before"@@ -662,19 +660,11 @@ <> help "write verification results to file" ) )- <*> optional- ( strOption- ( long "verify-out"- <> help "deprecated alias for --verifications-out"- )- ) inlineSignP :: Parser InlineSignOptions inlineSignP = InlineSignOptions <$> switch (long "no-armor" <> help "output binary")- <*> switch (long "armor" <> help "output ASCII Armor")- <*> optional (strOption (long "profile" <> help "signature profile")) <*> optional ( option (eitherReader inlineSignModeReader)@@ -747,12 +737,9 @@ <> help "user ID to certify (repeatable)" ) )- <*> optional- ( strOption- ( long "output-format"- <> metavar "FORMAT"- <> help "output format (text or binary)"- )+ <*> switch+ ( long "no-armor"+ <> help "output binary" ) <*> switch ( long "no-require-self-sig"@@ -780,12 +767,6 @@ ) ) -revokeUserIdP :: Parser RevokeUserIdOptions-revokeUserIdP =- RevokeUserIdOptions- <$> argument str (metavar "USERID" <> help "user ID to revoke")- <*> switch (long "no-armor" <> help "output binary")- updateKeyP :: Parser UpdateKeyOptions updateKeyP = UpdateKeyOptions@@ -828,7 +809,7 @@ <> help "password(s) used to unlock existing secret key material" ) )- <*> many+ <*> optional ( strOption ( long "new-key-password" <> help "password used to protect rewritten secret key material"@@ -846,7 +827,6 @@ dispatch' t (ValidateUserIdC o) = doValidateUserId t o dispatch' t (CertifyUserIdC o) = doCertifyUserId t o dispatch' t (RevokeKeyC o) = doRevokeKey t o- dispatch' t (RevokeUserIdC o) = doRevokeUserId t o dispatch' t (UpdateKeyC o) = doUpdateKey t o dispatch' t (VerifyC o') = doVerify t o' dispatch' t (InlineVerifyC o') = doInlineVerify t o'@@ -861,7 +841,7 @@ UnsupportedSubcommand ("command not yet implemented: " ++ c) dispatch' _ DeArmorC = doDeArmor- dispatch' _ (ArmorC o) = doArmor o+ dispatch' _ ArmorC = doArmor main :: IO () main = do@@ -869,18 +849,32 @@ args <- getArgs ensureKnownSubcommand knownSopSubcommands args cpt <- getPOSIXTime- CliOptions {..} <-- customExecParser- (prefs showHelpOnError)- ( info- (helper <*> versioner "hop" <*> cliP)- ( headerDoc (Just (banner "hop"))- <> progDesc "hOpenPGP Validator Tool"- <> footerDoc (Just (warranty "hop"))- )+ exitCode <-+ try+ ( do+ CliOptions {..} <-+ customExecParser+ (prefs showHelpOnError)+ ( info+ (helper <*> versioner "hop" <*> cliP)+ ( headerDoc (Just (banner "hop"))+ <> progDesc "hOpenPGP Validator Tool"+ <> footerDoc (Just (warranty "hop"))+ )+ )+ let _ = cliDebug+ dispatch cpt cliCommand )- let _ = cliDebug- dispatch cpt cliCommand+ :: IO (Either ExitCode ())+ case exitCode of+ Left (ExitFailure n) ->+ exitWith+ ( if n == 1+ then ExitFailure 19+ else ExitFailure n+ )+ Left _ -> exitWith (ExitFailure 1)+ Right () -> pure () knownSopSubcommands :: [String] knownSopSubcommands =@@ -898,7 +892,6 @@ , "list-profiles" , "merge-certs" , "revoke-key"- , "revoke-userid" , "sign" , "update-key" , "validate-userid"@@ -944,7 +937,7 @@ hsubparser ( command "armor"- (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout"))+ (info (pure ArmorC) (progDesc "Armor stdin to stdout")) <> command "dearmor" (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))@@ -1014,12 +1007,6 @@ (progDesc "Create a key revocation certificate") ) <> command- "revoke-userid"- ( info- (RevokeUserIdC <$> revokeUserIdP)- (progDesc "Revoke a user ID")- )- <> command "sign" ( info (SignC <$> soP)@@ -1045,61 +1032,31 @@ ) ) -armorTypes :: [(String, Maybe ArmorType)]-armorTypes =- [ ("auto", Nothing)- , ("sig", Just ArmorSignature)- , ("key", Just ArmorPrivateKeyBlock)- , ("cert", Just ArmorPublicKeyBlock)- , ("message", Just ArmorMessage)- ]--armorTypeReader :: String -> Either String (Maybe ArmorType)-armorTypeReader = note "unknown armor type" . flip lookup armorTypes--aoP :: Parser ArmoringOptions-aoP =- ArmoringOptions- <$> option- (eitherReader armorTypeReader)- (long "label" <> metavar "LABEL" <> armortypeHelp)- <*> switch- ( long "allow-nested"- <> help "do the sane thing and unconditionally armor the output"- )- where- armortypeHelp =- helpDoc . Just $- pretty "ASCII armor type"- <> softline- <> list (map (pretty . fst) armorTypes)--data ArmoringOptions- = ArmoringOptions- { label :: Maybe ArmorType- , allowNested :: Bool- }--doArmor :: ArmoringOptions -> IO ()-doArmor ArmoringOptions {..} = do+doArmor :: IO ()+doArmor = do m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume let lbs = BL.fromChunks m armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs- label' = guessLabel label (decodeFirstPacket lbs)- a = Armor label' [] lbs- BL.putStr $- if armoredAlready && not allowNested- then lbs- else AA.encodeLazy [a]+ if armoredAlready+ then BL.putStr lbs+ else do+ let label' = guessLabel (decodeAllPackets lbs) lbs+ a = Armor label' [] lbs+ BL.putStr $ AA.encodeLazy [a] where- decodeFirstPacket = runGet Bin.get- -- UPSTREAM: openpgp-asciiarmor should export selectArmorType helper- -- to eliminate this pattern-matching boilerplate- guessLabel (Just l) _ = l- guessLabel Nothing (SignaturePkt _) = ArmorSignature- guessLabel Nothing (SecretKeyPkt _ _) = ArmorPrivateKeyBlock- guessLabel Nothing (PublicKeyPkt _) = ArmorPublicKeyBlock- guessLabel Nothing _ = ArmorMessage+ decodeAllPackets lbs = runGet (many Bin.get) lbs+ guessLabel [] _ = ArmorMessage+ guessLabel (pkt : _) lbs =+ case pkt of+ SignaturePkt _ ->+ if all isSignaturePacket (decodeAllPackets lbs)+ then ArmorSignature+ else ArmorMessage+ SecretKeyPkt _ _ -> ArmorPrivateKeyBlock+ PublicKeyPkt _ -> ArmorPublicKeyBlock+ _ -> ArmorMessage+ isSignaturePacket SignaturePkt {} = True+ isSignaturePacket _ = False doVersion :: VersionOptions -> IO () doVersion VersionOptions {..} = do@@ -1108,19 +1065,29 @@ failWith IncompatibleOptions "version: --backend, --extended, --sop-spec, and --sopv are mutually exclusive"- putStrLn $ "hop " ++ showVersion version- when vBackend $ putStrLn "backend: hOpenPGP"- when vExtended $ putStrLn "extended: yes"+ when vBackend $+ putStrLn $+ "hOpenPGP " ++ HOV.version+ when vExtended $ do+ mapM_ putStrLn $+ [ "hop " ++ showVersion version+ , ""+ , "This is hop, from hopenpgp-tools " ++ showVersion version ++ ","+ , "built with hOpenPGP " ++ HOV.version+ ] when vSopSpec $- putStrLn "spec: draft-dkg-openpgp-stateless-cli-16"- when vSopv $ putStrLn "sopv: 1.0"+ putStrLn "draft-dkg-openpgp-stateless-cli-16"+ when vSopv $+ putStrLn "1.0"+ unless (vBackend || vExtended || vSopSpec || vSopv) $+ putStrLn $+ "hop " ++ showVersion version gkoP :: Parser KeyGenOptions gkoP = KeyGenOptions- <$> switch (long "armor" <> help "armor the output")- <*> switch (long "no-armor" <> help "don't armor the output")- <*> many+ <$> switch (long "no-armor" <> help "don't armor the output")+ <*> optional ( strOption ( long "with-key-password" <> help "password used to protect generated secret key material"@@ -1143,9 +1110,8 @@ data KeyGenOptions = KeyGenOptions- { armor :: Bool- , noArmor :: Bool- , keyPasswords :: [String]+ { noArmor :: Bool+ , keyPassword :: Maybe String , keyProfile :: Maybe String , keySigningOnly :: Bool , userIds :: [String]@@ -1153,16 +1119,8 @@ doGenerateKey :: POSIXTime -> KeyGenOptions -> IO () doGenerateKey pt KeyGenOptions {..} = do- when (armor && noArmor) $- failWith- IncompatibleOptions- "generate-key: --armor and --no-armor are mutually exclusive"- baseProfile <- parseKeyGenProfile keyProfile- let profile =- if keySigningOnly- then KeyGenSigningOnly- else baseProfile- password <- parseGenerateKeyPassword keyPasswords+ profile <- parseKeyGenProfile keyProfile+ password <- parseGenerateKeyPassword keyPassword let ts = ThirtyTwoBitTimeStamp (floor pt) -- UPSTREAM: hOpenPGP should expose a supported legacy secret-key -- re-encryption path so password-protected v4 key generation does not@@ -1180,7 +1138,7 @@ addUserId ts True (T.pack primaryUid) mapM_ (addUserId ts False . T.pack) restUids [] -> pure ()- addSubkeysForProfile ts keyVersion profile+ addSubkeysForProfile ts keyVersion profile keySigningOnly newkey <- get return newkey s <-@@ -1190,7 +1148,7 @@ password let lbs = runPut $ Bin.put (someTKToUnknown s) BL.putStr $- if not armor && not noArmor+ if not noArmor then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs] else lbs @@ -1263,39 +1221,54 @@ (SUUnencrypted (X25519PrivateKey privBytes) 0) data KeyGenProfile- = KeyGenDefault- | KeyGenRFC4880+ = KeyGenRFC4880 | KeyGenSecurity- | KeyGenPerformance | KeyGenSigningOnly deriving (Eq) +keyGenProfiles :: [Profile KeyGenProfile]+keyGenProfiles =+ [ Profile+ "security"+ "Ed25519 signing key, X25519 encryption subkey"+ KeyGenSecurity+ ["default", "performance", "rfc9580"]+ , Profile+ "rfc4880"+ "RSA-4096 (v4 keys)"+ KeyGenRFC4880+ ["compatibility"]+ ]++resolveProfile :: String -> [Profile p] -> Maybe p+resolveProfile name profiles =+ lookup name [(profileName p, profileValue p) | p <- profiles]+ <|> profileValue+ <$> find (\p -> name `elem` profileAliases p) profiles+ parseKeyGenProfile :: Maybe String -> IO KeyGenProfile-parseKeyGenProfile Nothing = pure KeyGenDefault-parseKeyGenProfile (Just "default") = pure KeyGenDefault-parseKeyGenProfile (Just "rfc4880") = pure KeyGenRFC4880-parseKeyGenProfile (Just "compatibility") = pure KeyGenRFC4880-parseKeyGenProfile (Just "security") = pure KeyGenSecurity-parseKeyGenProfile (Just "performance") = pure KeyGenPerformance-parseKeyGenProfile (Just profile) =- failWith- UnsupportedProfile- ("generate-key: unsupported profile " ++ profile)+parseKeyGenProfile Nothing = pure KeyGenSecurity+parseKeyGenProfile (Just name) =+ case resolveProfile name keyGenProfiles of+ Just p -> pure p+ Nothing ->+ failWith+ UnsupportedProfile+ ("generate-key: unsupported profile " ++ name) keyVersionForProfile :: KeyGenProfile -> KeyVersion-keyVersionForProfile KeyGenDefault = V6 keyVersionForProfile KeyGenRFC4880 = V4 keyVersionForProfile KeyGenSecurity = V6-keyVersionForProfile KeyGenPerformance = V6 keyVersionForProfile KeyGenSigningOnly = V6 primaryKeySpecForProfile :: KeyGenProfile -> GeneratedKeySpec primaryKeySpecForProfile KeyGenRFC4880 = GeneratedRSAKey 4096 primaryKeySpecForProfile _ = GeneratedEd25519Key -parseGenerateKeyPassword :: [String] -> IO (Maybe BL.ByteString)-parseGenerateKeyPassword [] = pure Nothing-parseGenerateKeyPassword [passwordFile] =+parseGenerateKeyPassword+ :: Maybe String -> IO (Maybe BL.ByteString)+parseGenerateKeyPassword Nothing = pure Nothing+parseGenerateKeyPassword (Just passwordFile) = Just <$> ( loadPasswordFromFile "generate-key"@@ -1305,10 +1278,6 @@ "generate-key" "--with-key-password" )-parseGenerateKeyPassword _ =- failWith- UnsupportedOption- "generate-key: multiple --with-key-password values are not supported" loadPasswordFiles :: String -> String -> [String] -> IO [BL.ByteString]@@ -1417,6 +1386,109 @@ ++ fdSpec ) +loadInputFromFile+ :: String -> String -> FilePath -> IO BL.ByteString+loadInputFromFile 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 -> loadInputFromFD 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+ ++ ": file does not exist for "+ ++ optionName+ ++ ": "+ ++ path+ )+ BL.readFile path++loadInputFromFD+ :: String -> String -> String -> IO BL.ByteString+loadInputFromFD 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+ )+ normalizeHumanReadablePassword :: String -> String -> BL.ByteString -> IO BL.ByteString normalizeHumanReadablePassword context optionName passwordBytes =@@ -1446,19 +1518,17 @@ :: ThirtyTwoBitTimeStamp -> KeyVersion -> KeyGenProfile+ -> Bool -> KeyBuilder ()-addSubkeysForProfile ts keyVersion profile =- case profile of- KeyGenSigningOnly ->- addSubkey ts keyVersion profile [SignDataKey]- _ -> do- addSubkey- ts- keyVersion- profile- [EncryptStorageKey, EncryptCommunicationsKey]- addSubkey ts keyVersion profile [SignDataKey]- addSubkey ts keyVersion profile [AuthKey]+addSubkeysForProfile ts keyVersion _profile signingOnly = do+ addSubkey ts keyVersion _profile [SignDataKey]+ unless signingOnly $ do+ addSubkey+ ts+ keyVersion+ _profile+ [EncryptStorageKey, EncryptCommunicationsKey]+ addSubkey ts keyVersion _profile [AuthKey] subkeySpecForProfile :: KeyGenProfile -> [KeyFlag] -> GeneratedKeySpec@@ -1692,13 +1762,11 @@ ecoP :: Parser ExtractCertOptions ecoP = ExtractCertOptions- <$> switch (long "armor" <> help "armor the output")- <*> switch (long "no-armor" <> help "don't armor the output")+ <$> switch (long "no-armor" <> help "don't armor the output") data ExtractCertOptions = ExtractCertOptions- { ecArmor :: Bool- , ecNoArmor :: Bool+ { ecNoArmor :: Bool } doExtractCert :: ExtractCertOptions -> IO ()@@ -1718,7 +1786,7 @@ "extract-cert: no transferable secret key found on standard input" let output = runPut $ mapM_ (Bin.put . someTKToUnknown . pubToSecret) tks BL.putStr $- if not ecArmor && not ecNoArmor+ if not ecNoArmor then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output] else output where@@ -1752,7 +1820,7 @@ changeKeyPasswordOldPasswords let oldPasswords = concatMap passwordRetryCandidates oldPasswordsRaw newPassword <-- parseChangeKeyPasswordNewPassword changeKeyPasswordNewPasswords+ parseChangeKeyPasswordNewPassword changeKeyPasswordNewPassword unlockedTks <- mapM ( unlockTransferableSecretKeyMaterial@@ -1773,9 +1841,9 @@ else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output] parseChangeKeyPasswordNewPassword- :: [String] -> IO (Maybe BL.ByteString)-parseChangeKeyPasswordNewPassword [] = pure Nothing-parseChangeKeyPasswordNewPassword [passwordFile] =+ :: Maybe String -> IO (Maybe BL.ByteString)+parseChangeKeyPasswordNewPassword Nothing = pure Nothing+parseChangeKeyPasswordNewPassword (Just passwordFile) = Just <$> ( loadPasswordFromFile "change-key-password"@@ -1785,10 +1853,6 @@ "change-key-password" "--new-key-password" )-parseChangeKeyPasswordNewPassword _ =- failWith- UnsupportedOption- "change-key-password: multiple --new-key-password values are not supported" hasSecretKeyMaterial :: SomeTK -> Bool hasSecretKeyMaterial tk =@@ -1917,7 +1981,9 @@ signerTks <- concat <$> mapM- (loadCertifySignerTKsFromFile signerPasswords)+ ( \p ->+ loadCertifySignerTKsFromFile signerPasswords "certify-userid" p+ ) certifyUserIdSignerFiles when (null signerTks) $ failWith@@ -1948,16 +2014,15 @@ ) targetTks let output = runPut (mapM_ (Bin.put . someTKToUnknown) updatedTargets)- armorOutput =- case certifyUserIdOutputFormat of- Just "binary" -> output- _ -> AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]- BL.putStr armorOutput+ BL.putStr $+ if certifyUserIdNoArmor+ then output+ else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output] loadCertifySignerTKsFromFile- :: [BL.ByteString] -> String -> IO [SomeTK]-loadCertifySignerTKsFromFile signerPasswords path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ :: [BL.ByteString] -> String -> String -> IO [SomeTK]+loadCertifySignerTKsFromFile signerPasswords context path = do+ lbs <- loadInputFromFile context "file" path packets <- decodeOpenPGPInput path lbs tks <- runConduitRes $@@ -2121,72 +2186,6 @@ ("revoke-key: failed to create revocation: " ++ show err) Right sig -> pure (SignaturePkt sig) -doRevokeUserId :: POSIXTime -> RevokeUserIdOptions -> IO ()-doRevokeUserId _cpt RevokeUserIdOptions {..} = do- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- keyPkts <- decodeOpenPGPInput "standard input" input- keyTks <-- runConduitRes $- CL.sourceList keyPkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- when (null keyTks) $- failWith- MissingInput- "revoke-userid: no key found on standard input"- let keyTk = case keyTks of- (kt : _) -> kt- _ ->- error- "revoke-userid: no key found on standard input (should be caught above)"- pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK keyTk))- mSka = case keyTk of- SomeSecretTK secretTk -> case _tkPrimaryKey secretTk of- KeyPktSecretPrimary _ ska -> Just ska- _ -> Nothing- SomePublicTK _ -> Nothing- targetUserId = T.pack revokeUserIdString- unless- ( any- ((== targetUserId) . fst)- (_tkUIDs (someTKToPublicViewTK keyTk))- )- $ failWith- MissingInput- ( "revoke-userid: key has no user ID matching "- ++ revokeUserIdString- )- ska <-- case mSka of- Just s -> pure s- Nothing ->- failWith- KeyCannotCertify- "revoke-userid: key has no secret key material"- signingKey <- rsaSigningKey ska- issuer <- issuerSubpacketsFor "revoke-userid" pkp- let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]- revocation =- signCertRevocationWithRSA- pkp- (UserId targetUserId)- hashed- issuer- signingKey- case revocation of- Left err ->- failWith- BadData- ("revoke-userid: failed to create revocation: " ++ show err)- Right sig -> do- let revocationSigPkt = SignaturePkt sig- output = runPut (Bin.put revocationSigPkt)- BL.putStr $- if revokeUserIdNoArmor- then output- else AA.encodeLazy [Armor ArmorSignature [] output]- doUpdateKey :: POSIXTime -> UpdateKeyOptions -> IO () doUpdateKey cpt UpdateKeyOptions {..} = do keyPasswordsRaw <-@@ -2213,7 +2212,10 @@ MissingInput "update-key: no key found on standard input" updateSourceTks <-- concat <$> mapM loadVerifyTKsFromFile updateKeyMergeCerts+ concat+ <$> mapM+ (\p -> loadVerifyTKsFromFile "update-key" p)+ updateKeyMergeCerts when (null updateSourceTks) $ failWith MissingInput "update-key: no update keys found" stdinUnlocked <-@@ -2276,7 +2278,10 @@ .| conduitDropErrorsAndNothings .| CC.sinkList mergeInTks <-- concat <$> mapM loadVerifyTKsFromFile mergeCertsFiles+ concat+ <$> mapM+ (\p -> loadVerifyTKsFromFile "merge-certs" p)+ mergeCertsFiles let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedTks) BL.putStr $@@ -2373,8 +2378,7 @@ soP :: Parser SignOptions soP = SignOptions- <$> switch (long "armor" <> help "armor the output")- <*> switch (long "no-armor" <> help "don't armor the output")+ <$> switch (long "no-armor" <> help "don't armor the output") <*> optional ( strOption ( long "micalg-out"@@ -2406,8 +2410,7 @@ data SignOptions = SignOptions- { sArmor :: Bool- , sNoArmor :: Bool+ { sNoArmor :: Bool , sMicalgOut :: Maybe String , sKeyPasswords :: [String] , sAs :: AsBinaryText@@ -2447,10 +2450,6 @@ doSign :: POSIXTime -> SignOptions -> IO () doSign pt SignOptions {..} = do- when (sNoArmor && sArmor) $- failWith- IncompatibleOptions- "sign: --armor and --no-armor are mutually exclusive" forM_ sMicalgOut (ensureOutputPathAvailable "sign") mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume when (sAs == AsText) $@@ -2461,7 +2460,7 @@ signingPasswordsRaw <- loadPasswordFiles "sign" "--with-key-password" sKeyPasswords let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw- ks <- loadSigningKeys sKeyFiles signingPasswords+ ks <- loadSigningKeys "sign" sKeyFiles signingPasswords let ts = ThirtyTwoBitTimeStamp (floor pt) payload' = BL.fromChunks mbs payload = payload'@@ -2489,7 +2488,7 @@ (renderMicalg signatures) Nothing -> pure () BL.putStr $- if not sArmor && not sNoArmor+ if not sNoArmor then AA.encodeLazy [Armor ArmorSignature [] output] else output where@@ -2525,11 +2524,12 @@ ) ] unhashed pkp = issuerSubpacketsFor "sign" pkp-loadSigningKeys :: [String] -> [BL.ByteString] -> IO [SomeTK]-loadSigningKeys keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles+loadSigningKeys+ :: String -> [String] -> [BL.ByteString] -> IO [SomeTK]+loadSigningKeys context keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles where loadFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ lbs <- loadInputFromFile context "file" path packets <- decodeOpenPGPInput path lbs tks <- runConduitRes $@@ -3665,17 +3665,9 @@ doEncrypt :: POSIXTime -> EncryptOptions -> IO () doEncrypt cpt EncryptOptions {..} = do- when (encNoArmor && encArmor) $- failWith- IncompatibleOptions- "encrypt: --armor and --no-armor are mutually exclusive" payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy when (encAs == AsText) $ ensureUTF8TextInput "encrypt" payload- when encWithoutIntegrityCheck $- failWith- UnsupportedOption- "encrypt: --without-integrity-check is not supported by this backend" symmetricPasswordsRaw <- loadPasswordFiles "encrypt" "--with-password" encPasswords symmetricPasswords <-@@ -3707,7 +3699,7 @@ then pure [] else do signingKeys <-- loadSigningKeys encSignWithKeyFiles signingKeyPasswords+ loadSigningKeys "encrypt" encSignWithKeyFiles signingKeyPasswords signPayloadWithKeys cpt encAs@@ -3981,34 +3973,19 @@ parseEncryptProfile :: Maybe String -> IO EncryptProfile parseEncryptProfile Nothing = pure EncryptProfileRFC9580-parseEncryptProfile (Just profileName) =- case profileName of- "default" -> pure EncryptProfileRFC9580- "rfc9580" -> pure EncryptProfileRFC9580- "security" -> pure EncryptProfileRFC9580- "performance" -> pure EncryptProfileRFC9580- "rfc4880" -> pure EncryptProfileRFC4880- "compatibility" -> pure EncryptProfileRFC4880- _ ->+parseEncryptProfile (Just name) =+ case resolveProfile name encryptProfiles of+ Just p -> pure p+ Nothing -> failWith UnsupportedProfile- ("encrypt: unsupported profile " ++ profileName)+ ("encrypt: unsupported profile " ++ name) doDecrypt :: POSIXTime -> DecryptOptions -> IO () doDecrypt cpt DecryptOptions {..} = do- when (decNoArmor && decArmor) $- failWith- IncompatibleOptions- "decrypt: --armor and --no-armor are mutually exclusive"- when decWithoutIntegrityCheck $- failWith- UnsupportedOption- "decrypt: --without-integrity-check is not supported by this backend" sessionKeys <- parseDecryptSessionKeys decSessionKeys- (verificationOutputPath, usingDeprecatedVerifyOut) <-- resolveDecryptVerificationsOut- decVerificationsOutFile- decDeprecatedVerifyOutFile+ verificationOutputPath <-+ resolveDecryptVerificationsOut decVerificationsOutFile let hasVerifyWith = not (null decVerifyCerts) hasVerifyOut = isJust verificationOutputPath hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter@@ -4051,7 +4028,7 @@ failWith BadData "decrypt input: no encrypted data packet found" validateCiphertextPacketLayout ciphertextPkts recipientKeys <-- loadDecryptRecipientKeys cpt decKeyFiles keyPasswords+ loadDecryptRecipientKeys cpt "decrypt" decKeyFiles keyPasswords when ( null recipientKeys && not (null decKeyFiles)@@ -4187,10 +4164,6 @@ decVerifyNotBefore decVerifyNotAfter decryptedPkts- when usingDeprecatedVerifyOut $- hPutStrLn- stderr- "Warning: --verify-out is deprecated; use --verifications-out instead." data DecryptSessionKey = DecryptSessionKey@@ -4663,23 +4636,24 @@ "decrypt failed: malformed signed message structure (multiple literal payloads)" resolveDecryptVerificationsOut- :: Maybe String -> Maybe String -> IO (Maybe String, Bool)-resolveDecryptVerificationsOut newPath oldPath =- case (newPath, oldPath) of- (Just p, Nothing) -> pure (Just p, False)- (Nothing, Just p) -> pure (Just p, True)- (Just pNew, Just pOld)- | pNew == pOld -> pure (Just pNew, True)- | otherwise ->- failWith- IncompatibleOptions- "decrypt: --verifications-out and --verify-out cannot target different files"- (Nothing, Nothing) -> pure (Nothing, False)+ :: Maybe String -> IO (Maybe String)+resolveDecryptVerificationsOut newPath =+ pure $ case newPath of+ Just p -> Just p+ Nothing -> Nothing renderSOPVerificationLine :: [SomeTK] -> Verification -> String renderSOPVerificationLine verifyTks v =- ts ++ " " ++ signerFp ++ " " ++ certFp ++ " " ++ modeLabel+ ts+ ++ " "+ ++ signerFp+ ++ " "+ ++ certFp+ ++ " "+ ++ modeLabel+ ++ " "+ ++ jsonTrailer where sig = _verificationSignature v ts = renderSOPVerificationTimestamp sig@@ -4698,6 +4672,7 @@ ) ) Nothing -> signerFp+ jsonTrailer = "{\"signers\":[{\"fingerprint\":\"" ++ signerFp ++ "\"}]}" signatureModeField :: SignaturePayload -> String signatureModeField sig =@@ -4923,9 +4898,9 @@ runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap pure (keyring, allTks) -loadVerifyTKsFromFile :: String -> IO [SomeTK]-loadVerifyTKsFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+loadVerifyTKsFromFile :: String -> String -> IO [SomeTK]+loadVerifyTKsFromFile context path = do+ lbs <- loadInputFromFile context "file" path certPkts <- decodeOpenPGPInput path lbs runConduitRes $ CL.sourceList certPkts@@ -4935,7 +4910,7 @@ loadCertTKsFromFile :: String -> String -> IO [SomeTK] loadCertTKsFromFile context path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ lbs <- loadInputFromFile context "file" path certPkts <- decodeOpenPGPInput path lbs rejectSecretKeyPackets context path certPkts runConduitRes $@@ -5047,14 +5022,15 @@ loadDecryptRecipientKeys :: POSIXTime+ -> String -> [String] -> [BL.ByteString] -> IO [PKESKRecipientKey]-loadDecryptRecipientKeys _ [] _ = pure []-loadDecryptRecipientKeys cpt keyFiles passwords = concat <$> mapM loadFromFile keyFiles+loadDecryptRecipientKeys _ _ [] _ = pure []+loadDecryptRecipientKeys cpt context keyFiles passwords = concat <$> mapM loadFromFile keyFiles where loadFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ lbs <- loadInputFromFile context "file" path packets <- decodeOpenPGPInput path lbs -- Build the set of fingerprints that are explicitly non-encryption-capable. -- Keys not resolvable via TK (processTK failure, bare material) are allowed.@@ -5329,7 +5305,7 @@ concat <$> mapM loadFromFile certFiles where loadFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ lbs <- loadInputFromFile "encrypt" "file" path pkts <- decodeOpenPGPInput path lbs rejectSecretKeyPackets "encrypt" path pkts tks <-@@ -5365,7 +5341,7 @@ else pure recipients where loadRecipientsFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ lbs <- loadInputFromFile "encrypt" "file" path pkts <- decodeOpenPGPInput path lbs rejectSecretKeyPackets "encrypt" path pkts rejectCriticalUnknownRecipientPackets path pkts@@ -5729,17 +5705,6 @@ doInlineSign :: POSIXTime -> InlineSignOptions -> IO () doInlineSign pt InlineSignOptions {..} = do- when (inlineSignNoArmor && inlineSignArmor) $- failWith- IncompatibleOptions- "inline-sign: --armor and --no-armor are mutually exclusive"- forM_- inlineSignProfile- ( \profile ->- failWith- UnsupportedOption- ("inline-sign: unsupported option --profile=" ++ profile)- ) let inlineMode = fromMaybe InlineSignAsBinary inlineSignAs mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume when (inlineMode /= InlineSignAsBinary) $@@ -5750,7 +5715,8 @@ "--with-key-password" inlineSignKeyPasswords let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw- ks <- loadSigningKeys inlineSignKeyFiles signingPasswords+ ks <-+ loadSigningKeys "inline-sign" inlineSignKeyFiles signingPasswords processedKeys <- mapM (normalizeSigningKey pt) ks let ts = ThirtyTwoBitTimeStamp (floor pt) payloadRaw = BL.fromChunks mbs@@ -5810,12 +5776,9 @@ ) ) BL.putStr $- if not inlineSignNoArmor && not inlineSignArmor+ if not inlineSignNoArmor then AA.encodeLazy [Armor ArmorMessage [] pktBytes]- else- if inlineSignArmor- then AA.encodeLazy [Armor ArmorMessage [] pktBytes]- else pktBytes+ else pktBytes inlineSignModeReader :: String -> Either String InlineSignMode inlineSignModeReader "binary" = Right InlineSignAsBinary@@ -6193,14 +6156,28 @@ doListProfiles :: ListProfilesOptions -> IO () doListProfiles lpos =- case profileSubcommand lpos of+ ( case profileSubcommand lpos of "generate-key" ->- putStr- "default: implementation defaults\nrfc4880: RSA-4096 interoperability-focused key generation\ncompatibility: broad interoperability defaults (alias of rfc4880)\nsecurity: security-oriented key generation\nperformance: performance-oriented key generation\n"+ mapM_+ ( \p ->+ putStrLn $+ profileName p ++ ": " ++ profileDescription p ++ aliasesSuffix p+ )+ keyGenProfiles "encrypt" ->- putStr- "default: implementation defaults (alias of rfc9580, security, and performance)\nrfc9580: RFC 9580 packet format preferences\nrfc4880: RFC 4880 packet format preferences\ncompatibility: broad interoperability defaults (alias of rfc4880)\n"+ mapM_+ ( \p ->+ putStrLn $+ profileName p ++ ": " ++ profileDescription p ++ aliasesSuffix p+ )+ encryptProfiles _ -> failWith UnsupportedProfile "Subcommand does not support profiles"+ )+ where+ aliasesSuffix p = case profileAliases p of+ [] -> ""+ s : [] -> " (alias: " ++ s ++ ")"+ as -> " (aliases: " ++ intercalate ", " as ++ ")"
hopenpgp-tools.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hopenpgp-tools-version: 0.25.3.1+version: 0.25.3.2 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: https://salsa.debian.org/clint/hOpenPGP-tools@@ -130,4 +130,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hopenpgp-tools.git- tag: hopenpgp-tools/0.25.3.1+ tag: hopenpgp-tools/0.25.3.2