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 @@ -19,21 +19,26 @@ -- along with this program. If not, see . 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 () diff --git a/hop.hs b/hop.hs --- a/hop.hs +++ b/hop.hs @@ -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 ++ ")" 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.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