diff --git a/HOpenPGP/Tools/Common/Lexer.x b/HOpenPGP/Tools/Common/Lexer.x --- a/HOpenPGP/Tools/Common/Lexer.x +++ b/HOpenPGP/Tools/Common/Lexer.x @@ -68,7 +68,7 @@ [Pp]ositive[Cc]ert { lex' TokenPositiveCert } [Ss]ubkey[Bb]inding[Ss]ig { lex' TokenSubkeyBindingSig } [Pp]rimary[Kk]ey[Bb]inding[Ss]ig { lex' TokenPrimaryKeyBindingSig } - [Ss]ignature[Dd]irectly[Oo]n[Aa][Kk]ey { lex' TokenSignatureDirectlyOnAKey } + [Dd]irect[Kk]ey[Ss]ignature { lex' TokenDirectKeySignature } [Kk]ey[Rr]evocation[Ss]ig { lex' TokenKeyRevocationSig } [Ss]ubkey[Rr]evocation[Ss]ig { lex' TokenSubkeyRevocationSig } [Cc]ert[Rr]evocation[Ss]ig { lex' TokenCertRevocationSig } @@ -134,7 +134,7 @@ | TokenPositiveCert | TokenSubkeyBindingSig | TokenPrimaryKeyBindingSig - | TokenSignatureDirectlyOnAKey + | TokenDirectKeySignature | TokenKeyRevocationSig | TokenSubkeyRevocationSig | TokenCertRevocationSig diff --git a/HOpenPGP/Tools/Common/Parser.y b/HOpenPGP/Tools/Common/Parser.y --- a/HOpenPGP/Tools/Common/Parser.y +++ b/HOpenPGP/Tools/Common/Parser.y @@ -65,7 +65,7 @@ positivecert { TokenPositiveCert } subkeybindingsig { TokenSubkeyBindingSig } primarykeybindingsig { TokenPrimaryKeyBindingSig } - signaturedirectlyonakey { TokenSignatureDirectlyOnAKey } + directkeysignature { TokenDirectKeySignature } keyrevocationsig { TokenKeyRevocationSig } subkeyrevocationsig { TokenSubkeyRevocationSig } certrevocationsig { TokenCertRevocationSig } @@ -165,7 +165,7 @@ | positivecert { fromIntegral (fromFVal PositiveCert) } | subkeybindingsig { fromIntegral (fromFVal SubkeyBindingSig) } | primarykeybindingsig { fromIntegral (fromFVal PrimaryKeyBindingSig) } - | signaturedirectlyonakey { fromIntegral (fromFVal SignatureDirectlyOnAKey) } + | directkeysignature { fromIntegral (fromFVal DirectKeySignature) } | keyrevocationsig { fromIntegral (fromFVal KeyRevocationSig) } | subkeyrevocationsig { fromIntegral (fromFVal SubkeyRevocationSig) } | certrevocationsig { fromIntegral (fromFVal CertRevocationSig) } 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 @@ -553,7 +553,7 @@ "" uaspToString :: UserAttrSubPacket -> String -uaspToString (ImageAttribute hdr d) = +uaspToString (ImageAttribute hdr (ImageData d)) = hdrToString hdr ++ ':' : show (BL.length d) @@ -707,7 +707,7 @@ grabReasons _ _ = [] grabReasons' :: SigSubPacketPayload -> Maybe RevocationStatus -grabReasons' (ReasonForRevocation a b) = +grabReasons' (ReasonForRevocation a (RevocationReason b)) = Just (RevocationStatus True (show a) b) grabReasons' _ = Nothing diff --git a/hop.hs b/hop.hs --- a/hop.hs +++ b/hop.hs @@ -25,6 +25,7 @@ ( Armor (..) , ArmorType (..) ) +import Codec.Encryption.OpenPGP.CFB (encryptNoNonce) import Codec.Encryption.OpenPGP.Compression ( CompressionError , decompressPkt @@ -52,6 +53,10 @@ ( eightOctetKeyID , fingerprint ) +import Codec.Encryption.OpenPGP.KeyGeneration + ( KeyGenSpec (..) + , generateSecretKey + ) import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize) import Codec.Encryption.OpenPGP.Message ( EncryptMessageOptions (..) @@ -74,14 +79,24 @@ ) import Codec.Encryption.OpenPGP.S2K ( decodeOpenPGPEncodedSessionKey + , renderS2KError , skesk2Key , skesk2SessionKey + , string2Key ) import Codec.Encryption.OpenPGP.SecretKey - ( decryptPrivateKey + ( SecretKeyEncryptOptions (..) + , SecretKeyError (..) + , decryptPrivateKey , encryptSecretKeyWithPolicy + , mkUnencryptedSKAddendum + , reencryptSecretKey + , renderSecretKeyError ) -import Codec.Encryption.OpenPGP.Serialize (parsePkts) +import Codec.Encryption.OpenPGP.Serialize + ( parsePkts + , putSKeyForPKPayload + ) import Codec.Encryption.OpenPGP.Signatures ( SignError (..) , renderSignError @@ -112,9 +127,11 @@ import Control.Monad (forM, forM_, unless, when, (>=>)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Lazy (StateT, evalStateT, get, modify) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Crypto.Error (eitherCryptoError) +import qualified Crypto.Hash as CH +import qualified Crypto.Hash.Algorithms as CHA import Crypto.Number.Serialize (i2ospOf_, os2ip) -import qualified Crypto.PubKey.Curve25519 as Curve25519 import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA as RSA @@ -1133,12 +1150,13 @@ profile <- parseKeyGenProfile keyProfile password <- parseGenerateKeyPassword keyPassword let ts = ThirtyTwoBitTimeStamp (floor pt) - keyVersion = - if isJust password && keyVersionForProfile profile == V4 - then V6 - else keyVersionForProfile profile - primaryKeySpec = primaryKeySpecForProfile profile - sk <- generateSecretKey ts keyVersion primaryKeySpec + keyVersion = keyVersionForProfile profile + sk <- + runExceptT + ( runSomeKeyGenSpec + (primaryKeySpecForProfile ts keyVersion profile) + ) + >>= either (failWith BadData) pure baseKey <- buildKeyWith sk $ do case userIds of @@ -1172,7 +1190,7 @@ signWithKey "generate-key" pkp - SignatureDirectlyOnAKey + DirectKeySignature SHA512 hashed issuer @@ -1195,72 +1213,68 @@ type KeyBuilder = StateT (TK 'SecretTK) IO -buildKeyWith :: SecretKey -> KeyBuilder a -> IO a -buildKeyWith sk a = evalStateT a (bareTK sk) +buildKeyWith :: (SomePKPayload, SKey) -> KeyBuilder a -> IO a +buildKeyWith (pkp, ska) a = + case secretAddendumForGeneratedKey pkp ska of + Right add -> evalStateT a (bareKT pkp add) + Left err -> + failWith + BadData + ("generate-key: invalid secret key material: " ++ err) where - bareTK (SecretKey pkp ska) = + bareKT pkp add = TK - { _tkPrimaryKey = KeyPktSecretPrimary pkp ska + { _tkPrimaryKey = KeyPktSecretPrimary pkp add , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] } -data GeneratedKeySpec - = GeneratedRSAKey Int - | GeneratedEd25519Key - | GeneratedX25519Key - deriving (Eq) +secretAddendumForGeneratedKey + :: SomePKPayload -> SKey -> Either String SKAddendum +secretAddendumForGeneratedKey pkp skey = + mkUnencryptedSKAddendum pkp skey -generateSecretKey - :: ThirtyTwoBitTimeStamp - -> KeyVersion - -> GeneratedKeySpec - -> IO SecretKey -generateSecretKey ts keyVersion (GeneratedRSAKey bits) = do - (pub, priv) <- liftIO $ RSA.generate (bits `div` 8) 0x10001 - return $ SecretKey (pkp pub) (ska priv) - where - pkp pub = PKPayload keyVersion ts 0 RSA (RSAPubKey (RSA_PublicKey pub)) - ska priv = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey priv)) 0 -- FIXME: calculate checksum -generateSecretKey ts keyVersion GeneratedEd25519Key = do - priv <- Ed25519.generateSecretKey - let pub = Ed25519.toPublic priv - pubBytes = BA.convert pub :: B.ByteString - privBytes = BA.convert priv :: B.ByteString - pure $ - SecretKey - ( PKPayload - keyVersion - ts - 0 - (toFVal 27) - ( EdDSAPubKey - EdSigningCurve25519 - (NativeEPoint (EPoint (os2ip pubBytes))) - ) - ) - (SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 privBytes) 0) -generateSecretKey ts keyVersion GeneratedX25519Key = do - priv <- Curve25519.generateSecretKey - let pub = Curve25519.toPublic priv - pubBytes = BA.convert pub :: B.ByteString - privBytes = BA.convert priv :: B.ByteString +data SomeKeyGenSpec where + SomeKeyGenSpec :: KeyGenSpec v -> SomeKeyGenSpec + +runSomeKeyGenSpec + :: MonadRandom m + => SomeKeyGenSpec + -> ExceptT String m (SomePKPayload, SKey) +runSomeKeyGenSpec (SomeKeyGenSpec spec) = generateSecretKey spec + +modifyTKSecretKeysM + :: Monad m + => TK 'SecretTK + -> (SomePKPayload -> SKAddendum -> m SKAddendum) + -> m (TK 'SecretTK) +modifyTKSecretKeysM tk cb = do + let keys = tkSecretKeyPairs tk + newSkas <- mapM (uncurry cb) keys + let index = zip (map fst keys) newSkas pure $ - SecretKey - ( PKPayload - keyVersion - ts - 0 - X25519 - ( EdDSAPubKey - EdSigningCurve25519 - (NativeEPoint (EPoint (os2ip pubBytes))) - ) - ) - (SUUnencrypted (X25519PrivateKey privBytes) 0) + modifyTKSecretKeys tk $ + \pkp ska -> (pkp, fromMaybe ska (lookup pkp index)) +modifyTKSecretKeysE + :: TK 'SecretTK + -> (SomePKPayload -> SKAddendum -> IO (Either String SKAddendum)) + -> IO (Either String (TK 'SecretTK)) +modifyTKSecretKeysE tk cb = do + let keys = tkSecretKeyPairs tk + result <- mapM (uncurry cb) keys + case sequence result of + Left err -> pure (Left err) + Right skas -> + let index = zip (map fst keys) skas + in pure $ + Right $ + modifyTKSecretKeys tk $ + \pkp ska -> (pkp, fromMaybe ska (lookup pkp index)) + data KeyGenProfile = KeyGenRFC4880 | KeyGenSecurity @@ -1302,9 +1316,18 @@ keyVersionForProfile KeyGenSecurity = V6 keyVersionForProfile KeyGenSigningOnly = V6 -primaryKeySpecForProfile :: KeyGenProfile -> GeneratedKeySpec -primaryKeySpecForProfile KeyGenRFC4880 = GeneratedRSAKey 4096 -primaryKeySpecForProfile _ = GeneratedEd25519Key +primaryKeySpecForProfile + :: ThirtyTwoBitTimeStamp + -> KeyVersion + -> KeyGenProfile + -> SomeKeyGenSpec +primaryKeySpecForProfile ts version KeyGenRFC4880 = + case version of + V4 -> SomeKeyGenSpec (KeyGenRSA ts 4096 :: KeyGenSpec V4) + V6 -> SomeKeyGenSpec (KeyGenRSA ts 4096 :: KeyGenSpec V6) + DeprecatedV3 -> error "primaryKeySpecForProfile: V3 unsupported" +primaryKeySpecForProfile ts _ _ = + SomeKeyGenSpec (KeyGenEd25519 ts) parseGenerateKeyPassword :: Maybe String -> IO (Maybe BL.ByteString) @@ -1485,60 +1508,189 @@ addSubkey ts keyVersion _profile [AuthKey] subkeySpecForProfile - :: KeyGenProfile -> [KeyFlag] -> GeneratedKeySpec -subkeySpecForProfile KeyGenRFC4880 _ = GeneratedRSAKey 4096 -subkeySpecForProfile _ keyflags + :: ThirtyTwoBitTimeStamp + -> KeyVersion + -> KeyGenProfile + -> [KeyFlag] + -> SomeKeyGenSpec +subkeySpecForProfile ts version KeyGenRFC4880 _ = + case version of + V4 -> SomeKeyGenSpec (KeyGenRSA ts 4096 :: KeyGenSpec V4) + V6 -> SomeKeyGenSpec (KeyGenRSA ts 4096 :: KeyGenSpec V6) + DeprecatedV3 -> error "subkeySpecForProfile: V3 unsupported" +subkeySpecForProfile ts _ _ keyflags | any (`elem` keyflags) [EncryptStorageKey, EncryptCommunicationsKey] = - GeneratedX25519Key - | otherwise = GeneratedEd25519Key + SomeKeyGenSpec (KeyGenX25519 ts) + | otherwise = + SomeKeyGenSpec (KeyGenEd25519 ts) +encryptUnencryptedV4SecretKey + :: SomePKPayload + -> SKey + -> BL.ByteString + -> IO (Either String SKAddendum) +encryptUnencryptedV4SecretKey pkp skey passphrase = do + saltBytes <- getRandomBytes 8 + ivBytes <- getRandomBytes 16 + let sa = AES256 + keyLen = 32 + s2k = IteratedSalted SHA256 (Salt8 saltBytes) 65536 + iv = IV ivBytes + pure $ + case string2Key s2k keyLen passphrase of + Left err -> Left (renderS2KError err) + Right keyMaterial -> + case putSKeyForPKPayload pkp skey of + Left err -> Left err + Right putAction -> + let cleartext = runPut putAction + sha1Checksum = + BA.convert + (CH.hash (BL.toStrict cleartext) :: CH.Digest CHA.SHA1) + clearWithChecksum = + BL.toStrict (cleartext <> BL.fromStrict sha1Checksum) + in case encryptNoNonce sa s2k iv clearWithChecksum keyMaterial of + Left err -> Left (show err) + Right encrypted -> + Right (SUSSHA1 sa s2k iv (BL.fromStrict encrypted)) + encryptTransferableSecretKey :: BL.ByteString -> SomeTK -> IO SomeTK encryptTransferableSecretKey password stk = case stk of SomePublicTK _ -> pure stk - SomeSecretTK tk -> - case _tkPrimaryKey tk of - KeyPktSecretPrimary pkp ska -> do - encrypted <- encryptSecretAddendumForOutput pkp ska - subs' <- mapM encryptSub (_tkSubs tk) - pure $ - SomeSecretTK - tk - { _tkPrimaryKey = KeyPktSecretPrimary pkp encrypted - , _tkSubs = subs' - } - _ -> pure stk + SomeSecretTK tk -> do + tk' <- + modifyTKSecretKeysM tk (encryptSecretAddendumForOutput password) + pure $ SomeSecretTK tk' where - encryptSub - :: (MonadIO m, MonadRandom m) => (KeyPkt k, b) -> m (KeyPkt k, b) - encryptSub (KeyPktSecretSubkey pkp ska, sigs) = do - encrypted <- liftIO $ encryptSecretAddendumForOutput pkp ska - pure (KeyPktSecretSubkey pkp encrypted, sigs) - encryptSub other = pure other - encryptSecretAddendumForOutput pkp ska = + encryptSecretAddendumForOutput + :: BL.ByteString -> SomePKPayload -> SKAddendum -> IO SKAddendum + encryptSecretAddendumForOutput password pkp ska = case ska of - SUUnencrypted skey _ -> doEncryptSecret skey - _ -> pure ska - where - doEncryptSecret skey = do - encryptedResult <- + SUUnencrypted skey _ + | _keyVersion pkp == V4 -> do + result <- encryptUnencryptedV4SecretKey pkp skey password + case result of + Left err -> + failWith + BadData + ( "generate-key: failed to protect V4 secret key material: " + ++ err + ) + Right val -> pure val + SUUnencrypted skey _ -> encryptSecretKeyWithPolicy defaultPolicy pkp skey (Passphrase password) - case encryptedResult of - Left err -> - failWith - BadData - ( "generate-key: failed to protect secret key material: " - ++ show err + >>= \result -> case result of + Left err -> + failWith + BadData + ( "generate-key: failed to protect secret key material: " + ++ show err + ) + Right val -> pure val + _ -> pure ska + +changeTKPassword + :: [BL.ByteString] + -> Maybe BL.ByteString + -> SomeTK + -> IO (Either String SomeTK) +changeTKPassword oldPasswords mNewPassword stk = + case stk of + SomePublicTK _ -> pure $ Right stk + SomeSecretTK tk -> do + result <- + modifyTKSecretKeysE + tk + (changeSKAddendum oldPasswords mNewPassword) + case result of + Left err -> pure $ Left err + Right tk' -> pure $ Right $ SomeSecretTK tk' + where + changeSKAddendum + :: [BL.ByteString] + -> Maybe BL.ByteString + -> SomePKPayload + -> SKAddendum + -> IO (Either String SKAddendum) + changeSKAddendum oldPasswords mNewPassword pkp ska = + case ska of + SUUnencrypted skey _ -> + case _keyVersion pkp of + V4 -> + case mNewPassword of + Just newPassword -> do + result <- encryptUnencryptedV4SecretKey pkp skey newPassword + case result of + Right newSka -> pure $ Right newSka + Left err -> pure $ Left err + Nothing -> pure $ Right ska + _ -> + case mNewPassword of + Just newPassword -> do + encryptedResult <- + encryptSecretKeyWithPolicy + defaultPolicy + pkp + skey + (Passphrase newPassword) + case encryptedResult of + Right newSka -> pure $ Right newSka + Left err -> pure $ Left (renderSecretKeyError err) + Nothing -> pure $ Right ska + _ -> + case mNewPassword of + Just newPassword -> + tryReencrypt oldPasswords newPassword pkp ska + Nothing -> + tryDecrypt oldPasswords pkp ska + + tryReencrypt [] _ _ _ = pure $ Left "no usable password for encrypted key material" + tryReencrypt (old : rest) newPassword pkp ska = do + if _keyVersion pkp == V4 + then do + case decryptPrivateKey (pkp, ska) old of + Left _ -> tryReencrypt rest newPassword pkp ska + Right (SUUnencrypted skey _) -> do + result <- encryptUnencryptedV4SecretKey pkp skey newPassword + case result of + Right newSka -> pure $ Right newSka + Left _ -> tryReencrypt rest newPassword pkp ska + Right _ -> tryReencrypt rest newPassword pkp ska + else do + result <- + reencryptSecretKey + ( SecretKey + { _secretKeyPKPayload = pkp + , _secretKeySKAddendum = ska + } ) - Right val -> pure val + (Passphrase old) + (Passphrase newPassword) + SecretKeyEncryptOptions + { skeoPolicy = defaultPolicy + , skeoGenerateSaltAndIV = True + , skeoSalt = Nothing + , skeoIV = Nothing + } + case result of + Right (SecretKey {_secretKeySKAddendum = newSka}) -> + pure $ Right newSka + Left _ -> tryReencrypt rest newPassword pkp ska + tryDecrypt [] _ _ = pure $ Left "no usable password for encrypted key material" + tryDecrypt (old : rest) pkp ska = + case decryptPrivateKey (pkp, ska) old of + Right decrypted -> pure $ Right decrypted + Left _ -> tryDecrypt rest pkp ska + rsaSigningKey :: SKAddendum -> IO RSA.PrivateKey rsaSigningKey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) = pure (k {RSA.private_p = 0, RSA.private_q = 0}) @@ -1614,12 +1766,20 @@ -> KeyBuilder () addSubkey ts keyVersion profile keyflags = do tk <- get - (SecretKey subpkp subska) <- + (subpkp, subska) <- liftIO $ - generateSecretKey - ts - keyVersion - (subkeySpecForProfile profile keyflags) + runExceptT + ( runSomeKeyGenSpec + (subkeySpecForProfile ts keyVersion profile keyflags) + ) + >>= either (failWith BadData) pure + subska <- + case secretAddendumForGeneratedKey subpkp subska of + Right add -> pure add + Left err -> + failWith + BadData + ("generate-key: invalid subkey material: " ++ err) let pkp = keyPktPKPayload (_tkPrimaryKey tk) ska :: SKAddendum ska = case _tkPrimaryKey tk of @@ -1681,7 +1841,7 @@ putKeyForSigning :: SomePKPayload -> Bin.Put putKeyForSigning pkp@(PKPayload V6 _ _ _ _) = do - putWord8 0x9A + putWord8 0x9B let bs = runPut (Bin.put pkp) putWord32be (fromIntegral (BL.length bs)) putLazyByteString bs @@ -1781,24 +1941,18 @@ let oldPasswords = concatMap passwordRetryCandidates oldPasswordsRaw newPassword <- parseChangeKeyPasswordNewPassword changeKeyPasswordNewPassword - unlockedTks <- - mapM - ( unlockTransferableSecretKeyMaterial - "change-key-password" - "standard input" - "--old-key-password" - oldPasswords - ) - tks - rewrittenTks <- - case newPassword of - Just password -> mapM (encryptTransferableSecretKey password) unlockedTks - Nothing -> pure unlockedTks - let output = runPut (mapM_ (Bin.put . someTKToUnknown) rewrittenTks) - BL.putStr $ - if changeKeyPasswordNoArmor || BL.null output - then output - else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output] + changed <- mapM (changeTKPassword oldPasswords newPassword) tks + case sequence changed of + Left err -> + failWith + BadData + err + Right rewrittenTks -> + let output = runPut (mapM_ (Bin.put . someTKToUnknown) rewrittenTks) + in BL.putStr $ + if changeKeyPasswordNoArmor || BL.null output + then output + else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output] parseChangeKeyPasswordNewPassword :: Maybe String -> IO (Maybe BL.ByteString) @@ -2545,43 +2699,15 @@ -> [BL.ByteString] -> SomeTK -> IO SomeTK --- Upstream could expose a TK-wide secret-key rewrite helper so SOP --- subcommands do not need to walk primary and subkey packets separately. -unlockTransferableSecretKeyMaterial context path passwordOption keyPasswords stk = do +unlockTransferableSecretKeyMaterial context path passwordOption keyPasswords stk = case stk of SomePublicTK _ -> pure stk SomeSecretTK tk -> do - let pkp = keyPktPKPayload (_tkPrimaryKey tk) - ska' <- - unlockSecretAddendum - context - path - passwordOption - keyPasswords - pkp - ( case _tkPrimaryKey tk of - KeyPktSecretPrimary _ ska -> ska - _ -> - error - "unlockTransferableSecretKeyMaterial: expected secret primary key" - ) - let primaryKey = KeyPktSecretPrimary pkp ska' - subs' <- mapM decryptSub (_tkSubs tk) - pure $ - SomeSecretTK tk {_tkPrimaryKey = primaryKey, _tkSubs = subs'} - where - decryptSub :: MonadIO m => (KeyPkt k, b) -> m (KeyPkt k, b) - decryptSub (KeyPktSecretSubkey pkp ska, sigs) = do - ska' <- - unlockSecretAddendum - context - path - passwordOption - keyPasswords - pkp - ska - pure (KeyPktSecretSubkey pkp ska', sigs) - decryptSub other = pure other + tk' <- + modifyTKSecretKeysM + tk + (unlockSecretAddendum context path passwordOption keyPasswords) + pure $ SomeSecretTK tk' unlockSecretAddendum :: MonadIO m @@ -2698,6 +2824,8 @@ && case fmska k of Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True + Just (SUUnencrypted (Ed25519PrivateKey _) _) -> True + Just (SUUnencrypted (Ed448PrivateKey _) _) -> True Just (SUUnencrypted (UnknownSKey _) _) -> isEd25519PKA (_pkalgo (fpkp k)) || isEdDSAPKA (_pkalgo (fpkp k)) @@ -2738,34 +2866,30 @@ (k {RSA.private_p = 0, RSA.private_q = 0}) Just (SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _) -> - case eitherCryptoError (Ed25519.secretKey rawBytes) of - Left err -> - failWith - BadData - (ctx ++ " failed: bad Ed25519 secret key: " ++ show err) - Right sk - | _keyVersion signerPKP == V6 -> signEd25519 sk - | isEdDSAPKA (_pkalgo signerPKP) -> - case signDataWithEd25519Legacy st sk hsd usd payload of - Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err') - Right sig -> pure sig - | otherwise -> - case signDataWithEd25519 st sk hsd usd payload of - Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err') - Right sig -> pure sig + signWithEd25519SecretKey + ctx + signerPKP + st + hsd + usd + payload + rawBytes Just + (SUUnencrypted (Ed25519PrivateKey rawBytes) _) -> + signWithEd25519SecretKey + ctx + signerPKP + st + hsd + usd + payload + rawBytes + Just (SUUnencrypted (EdDSAPrivateKey EdSigningCurve448 rawBytes) _) -> - case eitherCryptoError (Ed448.secretKey rawBytes) of - Left err -> - failWith - BadData - (ctx ++ " failed: bad Ed448 secret key: " ++ show err) - Right sk - | _keyVersion signerPKP == V6 -> signEd448 sk - | otherwise -> - case signDataWithEd448 st sk hsd usd payload of - Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err') - Right sig -> pure sig + signWithEd448SecretKey ctx signerPKP st hsd usd payload rawBytes + Just + (SUUnencrypted (Ed448PrivateKey rawBytes) _) -> + signWithEd448SecretKey ctx signerPKP st hsd usd payload rawBytes Just (SUUnencrypted (UnknownSKey rawBytes) _) -> case () of _ @@ -2853,6 +2977,35 @@ Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err) Right sig -> pure sig + signWithEd25519SecretKey ctx signerPKP st hsd usd payload rawBytes = + case eitherCryptoError (Ed25519.secretKey rawBytes) of + Left err -> + failWith + BadData + (ctx ++ " failed: bad Ed25519 secret key: " ++ show err) + Right sk + | _keyVersion signerPKP == V6 -> signEd25519 sk + | isEdDSAPKA (_pkalgo signerPKP) -> + case signDataWithEd25519Legacy st sk hsd usd payload of + Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err') + Right sig -> pure sig + | otherwise -> + case signDataWithEd25519 st sk hsd usd payload of + Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err') + Right sig -> pure sig + signWithEd448SecretKey ctx signerPKP st hsd usd payload rawBytes = + case eitherCryptoError (Ed448.secretKey rawBytes) of + Left err -> + failWith + BadData + (ctx ++ " failed: bad Ed448 secret key: " ++ show err) + Right sk + | _keyVersion signerPKP == V6 -> signEd448 sk + | otherwise -> + case signDataWithEd448 st sk hsd usd payload of + Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err') + Right sig -> pure sig + normalizeUnknownSecretForEdDSA :: String -> Int -> BL.ByteString -> IO B.ByteString normalizeUnknownSecretForEdDSA ctx expectedLen rawLbs @@ -3042,6 +3195,7 @@ TK { _tkPrimaryKey = KeyPktSecretPrimary pkp ska , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -3250,7 +3404,7 @@ verifyWithLiteralData format payload sigs keyring upperBound = runConduitRes $ CC.yieldMany - (V.cons (LiteralDataPkt format mempty 0 payload) sigs) + (V.cons (LiteralDataPkt format (FileName mempty) 0 payload) sigs) .| conduitVerify keyring upperBound .| CC.sinkList @@ -3496,7 +3650,7 @@ ( True , LiteralDataPkt TextData - BL.empty + (FileName B.empty) 0 (BL.fromStrict (BLC8.toStrict cleartext)) : sigPkts @@ -5721,7 +5875,7 @@ Bin.put ( Block ( map SignaturePkt sigs - ++ [LiteralDataPkt literalDataType BL.empty 0 payloadRaw] + ++ [LiteralDataPkt literalDataType (FileName B.empty) 0 payloadRaw] ) ) BL.putStr $ @@ -5742,6 +5896,8 @@ && case fmska k of Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True + Just (SUUnencrypted (Ed25519PrivateKey _) _) -> True + Just (SUUnencrypted (Ed448PrivateKey _) _) -> True Just (SUUnencrypted (UnknownSKey _) _) -> isEd25519PKA (_pkalgo (fpkp k)) || isEdDSAPKA (_pkalgo (fpkp k)) 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.7 +version: 0.25.8 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.3 && < 3.4 + , hOpenPGP >= 3.4 && < 3.5 , 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.7 + tag: hopenpgp-tools/0.25.8