diff --git a/HOpenPGP/Tools/Common/Common.hs b/HOpenPGP/Tools/Common/Common.hs --- a/HOpenPGP/Tools/Common/Common.hs +++ b/HOpenPGP/Tools/Common/Common.hs @@ -17,123 +17,152 @@ -- along with this program. If not, see . module HOpenPGP.Tools.Common.Common - ( banner - , versioner - , warranty - , prependAuto - , keyMatchesFingerprint - , keyMatchesEightOctetKeyId - , keyMatchesExactUIDString - , keyMatchesUIDSubString - , keyMatchesPKPred - -- hmm - , pkpGetPKVersion - , pkpGetPKAlgo - , pkpGetKeysize - , pkpGetTimestamp - , pkpGetFingerprint - , pkpGetEOKI - , tkUsingPKP - , pUsingPKP - , pUsingSP - , tkGetUIDs - , tkGetSubs - , anyOrAll - , anyReader - , oGetTag - , oGetLength - , spGetSigVersion - , spGetSigType - , spGetPKAlgo - , spGetHashAlgo - , spGetSCT - , maybeR - , renderKeyID - , renderFingerprint - ) where - -import Data.Version (showVersion) -import Paths_hopenpgp_tools (version) + ( banner + , versioner + , warranty + , prependAuto + , keyMatchesFingerprint + , keyMatchesEightOctetKeyId + , keyMatchesExactUIDString + , keyMatchesUIDSubString + , keyMatchesPKPred + -- hmm + , pkpGetPKVersion + , pkpGetPKAlgo + , pkpGetKeysize + , pkpGetTimestamp + , pkpGetFingerprint + , pkpGetEOKI + , tkUsingPKP + , pUsingPKP + , pUsingSP + , tkGetUIDs + , tkGetSubs + , anyOrAll + , anyReader + , oGetTag + , oGetLength + , spGetSigVersion + , spGetSigType + , spGetPKAlgo + , spGetHashAlgo + , spGetSCT + , maybeR + , renderKeyID + , renderFingerprint + , primaryPKP + ) where -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Fingerprint + ( eightOctetKeyID + , fingerprint + ) +import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize) import Codec.Encryption.OpenPGP.SignatureQualities (sigCT) import Codec.Encryption.OpenPGP.Types -import Control.Lens ((^..)) +import Control.Error.Util (hush) +import Control.Monad.Trans.Reader + ( Reader + , ReaderT + , ask + , local + , reader + , runReader + , withReader + ) import Data.Binary (put) import Data.Binary.Put (runPut) import qualified Data.ByteString.Lazy as BL -import Data.Data.Lens (biplate) +-- hmm -- +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T -import Options.Applicative.Builder (auto, help, hidden, infoOption, long, short) -import Options.Applicative.Types (Parser, ReadM(..)) -import Prettyprinter (Doc, (<+>), hardline, pretty, defaultLayoutOptions, layoutPretty) +import Data.Version (showVersion) +import Options.Applicative.Builder + ( auto + , help + , hidden + , infoOption + , long + , short + ) +import Options.Applicative.Types (Parser, ReadM (..)) +import Prettyprinter + ( Doc + , defaultLayoutOptions + , hardline + , layoutPretty + , pretty + , (<+>) + ) import qualified Prettyprinter.Render.Text as PPA -import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize) -import Control.Error.Util (hush) -import Control.Monad.Trans.Reader - ( Reader - , ReaderT - , ask - , local - , reader - , runReader - , withReader - ) --- hmm -- -import Data.Maybe (fromMaybe, mapMaybe) +import Paths_hopenpgp_tools (version) + banner :: String -> Doc ann {-# INLINE banner #-} banner name = - pretty name <+> - pretty "(hopenpgp-tools)" <+> - pretty (showVersion version) <> - hardline <> pretty "Copyright (C) 2012-2026 Clint Adams" + pretty name + <+> pretty "(hopenpgp-tools)" + <+> pretty (showVersion version) + <> hardline + <> pretty "Copyright (C) 2012-2026 Clint Adams" warranty :: String -> Doc ann {-# INLINE warranty #-} warranty name = - pretty name <+> - pretty "comes with ABSOLUTELY NO WARRANTY." <+> - pretty "This is free software, and you are welcome to redistribute it" <+> - pretty "under certain conditions." + pretty name + <+> pretty "comes with ABSOLUTELY NO WARRANTY." + <+> pretty + "This is free software, and you are welcome to redistribute it" + <+> pretty "under certain conditions." versioner :: String -> Parser (a -> a) {-# INLINE versioner #-} versioner name = - infoOption (name ++ " (hopenpgp-tools) " ++ showVersion version) $ - long "version" <> short 'V' <> help "Show version information" <> hidden + infoOption (name ++ " (hopenpgp-tools) " ++ showVersion version) $ + long "version" + <> short 'V' + <> help "Show version information" + <> hidden prependAuto :: Read a => String -> ReadM a prependAuto s = ReadM (local (s ++) (unReadM auto)) -keyMatchesFingerprint :: Bool -> TKUnknown -> Fingerprint -> Bool +keyMatchesFingerprint :: Bool -> SomeTK -> Fingerprint -> Bool keyMatchesFingerprint = keyMatchesPKPred fingerprint -keyMatchesEightOctetKeyId :: Bool -> TKUnknown -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow +keyMatchesEightOctetKeyId + :: Bool -> SomeTK -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID -keyMatchesExactUIDString :: Text -> TKUnknown -> Bool -keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkuUIDs +keyMatchesExactUIDString :: Text -> SomeTK -> Bool +keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkUIDs . someTKToPublicViewTK -keyMatchesUIDSubString :: Text -> TKUnknown -> Bool -keyMatchesUIDSubString uidstr = - any (T.toLower uidstr `T.isInfixOf`) . map (T.toLower . fst) . _tkuUIDs +keyMatchesUIDSubString :: Text -> SomeTK -> Bool +keyMatchesUIDSubString uidstr stk = + any (T.toLower uidstr `T.isInfixOf`) + . map (T.toLower . fst) + . _tkUIDs $ + someTKToPublicViewTK stk -keyMatchesPKPred :: Eq a => (SomePKPayload -> a) -> Bool -> TKUnknown -> a -> Bool -keyMatchesPKPred p False = (==) . p . fst . _tkuKey -keyMatchesPKPred p True = \tk v -> elem v (map p (tk ^.. biplate)) +keyMatchesPKPred + :: Eq a => (SomePKPayload -> a) -> Bool -> SomeTK -> a -> Bool +keyMatchesPKPred p False = (==) . p . primaryPKP +keyMatchesPKPred p True = \stk v -> elem v (p (primaryPKP stk) : map p (tkGetSubs stk)) +primaryPKP :: SomeTK -> SomePKPayload +primaryPKP = keyPktPKPayload . _tkPrimaryKey . someTKToPublicViewTK + -- The following should probably be moved elsewhere -tkUsingPKP :: Reader SomePKPayload a -> Reader TKUnknown a -tkUsingPKP = withReader (fst . _tkuKey) +tkUsingPKP :: Reader SomePKPayload a -> Reader SomeTK a +tkUsingPKP = withReader primaryPKP pkpGetPKVersion :: SomePKPayload -> Integer pkpGetPKVersion t = - if _keyVersion t == DeprecatedV3 - then 3 - else 4 + if _keyVersion t == DeprecatedV3 + then 3 + else 4 pkpGetPKAlgo :: SomePKPayload -> Integer pkpGetPKAlgo = fromIntegral . fromFVal . _pkalgo @@ -150,21 +179,19 @@ pkpGetEOKI :: SomePKPayload -> String pkpGetEOKI = either (const "UNKNOWN") show . eightOctetKeyID -tkGetUIDs :: TKUnknown -> [Text] -tkGetUIDs = map fst . _tkuUIDs +tkGetUIDs :: SomeTK -> [Text] +tkGetUIDs = map fst . _tkUIDs . someTKToPublicViewTK -tkGetSubs :: TKUnknown -> [SomePKPayload] -tkGetSubs = mapMaybe (grabPKP . fst) . _tkuSubs +tkGetSubs :: SomeTK -> [SomePKPayload] +tkGetSubs stk = mapMaybe (grabPKP . fst) (_tkSubs (someTKToPublicViewTK stk)) where - grabPKP (PublicSubkeyPkt p) = Just p - grabPKP (SecretSubkeyPkt p _) = Just p - grabPKP _ = Nothing + grabPKP kp = Just (keyPktPKPayload kp) -anyOrAll :: - (Monad m, Monad m1) - => ((a1 -> c) -> a -> ReaderT a m b) - -> (m1 a1 -> c) - -> ReaderT a m b +anyOrAll + :: (Monad m, Monad m1) + => ((a1 -> c) -> a -> ReaderT a m b) + -> (m1 a1 -> c) + -> ReaderT a m b anyOrAll aa op = ask >>= aa (op . return) anyReader :: Reader a Bool -> Reader [a] Bool @@ -187,8 +214,9 @@ spGetSigType :: Pkt -> Maybe Integer spGetSigType (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigType s) - -- FIXME: deduplicate this and hOpenPGP .Internal where + -- FIXME: deduplicate this and hOpenPGP .Internal + sigType :: SignaturePayload -> Maybe SigType sigType (SigV3 st _ _ _ _ _ _) = Just st sigType (SigV4 st _ _ _ _ _ _) = Just st @@ -235,8 +263,14 @@ renderKeyID :: EightOctetKeyId -> String renderKeyID = - T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty + T.unpack + . PPA.renderStrict + . layoutPretty defaultLayoutOptions + . pretty renderFingerprint :: Fingerprint -> String renderFingerprint = - T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty + T.unpack + . PPA.renderStrict + . layoutPretty defaultLayoutOptions + . pretty diff --git a/HOpenPGP/Tools/Common/HKP.hs b/HOpenPGP/Tools/Common/HKP.hs --- a/HOpenPGP/Tools/Common/HKP.hs +++ b/HOpenPGP/Tools/Common/HKP.hs @@ -32,7 +32,12 @@ import Codec.Encryption.OpenPGP.Types ( Block (..) , Fingerprint - , TKUnknown (..) + , SomePKPayload (..) + , SomeTK (..) + , TK (..) + , keyPktPKPayload + , someTKToPublicViewTK + , someTKToUnknown ) import Control.Arrow ((&&&)) import Control.Lens ((^..)) @@ -46,7 +51,10 @@ import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither) +import Data.Conduit.OpenPGP.Keyring + ( conduitDropErrorsAndNothings + , conduitToSomeTKsDroppingEither + ) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Data.Lens (biplate) import Data.Either (rights) @@ -64,6 +72,9 @@ import HOpenPGP.Tools.Common.TKUtils (processTK) +primaryPKP :: SomeTK -> SomePKPayload +primaryPKP = keyPktPKPayload . _tkPrimaryKey . someTKToPublicViewTK + data FetchValidationMethod = MatchPrimaryKeyFingerprint | MatchPrimaryOrAnySubkeyFingerprint @@ -74,7 +85,7 @@ :: String -> FetchValidationMethod -> Fingerprint - -> ExceptT String IO [TKUnknown] + -> ExceptT String IO [SomeTK] fetchKeys ks fvm q = do manager <- liftIO $ newManager tlsManagerSettings request <- liftIO $ parseUrlThrow (ks <> basereq) @@ -86,7 +97,7 @@ else throwE ("HTTP status: " ++ show (responseStatus response)) return $ map fst $ - filter (fvp fvm . fst . _tkuKey . snd) processedKeys + filter (fvp fvm . primaryPKP . snd) processedKeys where fvp MatchPrimaryKeyFingerprint k = fingerprint k == q fvp MatchPrimaryOrAnySubkeyFingerprint k' = @@ -101,7 +112,7 @@ ] validateKeys - :: BL.ByteString -> ExceptT String IO [(TKUnknown, TKUnknown)] -- FIXME: conduit fail + :: BL.ByteString -> ExceptT String IO [(SomeTK, SomeTK)] -- FIXME: conduit fail validateKeys larmors = do bytestrings <- ExceptT $ @@ -111,8 +122,8 @@ liftIO . runConduitRes $ CB.sourceLbs bytestrings .| conduitGet get - .| conduitToTKsDroppingEither - .| CL.mapMaybe (either (const Nothing) id) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CL.consume cpt <- liftIO getPOSIXTime return . rights $ @@ -121,9 +132,9 @@ armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs armorToBS _ = mempty -rearmorKeys :: [TKUnknown] -> B.ByteString -rearmorKeys keys = - if null keys +rearmorKeys :: [SomeTK] -> B.ByteString +rearmorKeys stks = + if null stks then mempty else AA.encode @@ -132,4 +143,4 @@ . runPut . put . Block - $ keys + $ map someTKToUnknown stks 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 @@ -221,7 +221,7 @@ (l,c) <- getPosn error (show l ++ ":" ++ show c ++ ": Parse error on Token: " ++ show t ++ "\n") -parseTKExp :: String -> Either String (Reader TKUnknown Bool) +parseTKExp :: String -> Either String (Reader SomeTK Bool) parseTKExp s = runAlex s parseTK parsePExp :: String -> Either String (Reader Pkt Bool) diff --git a/HOpenPGP/Tools/Common/TKUtils.hs b/HOpenPGP/Tools/Common/TKUtils.hs --- a/HOpenPGP/Tools/Common/TKUtils.hs +++ b/HOpenPGP/Tools/Common/TKUtils.hs @@ -15,9 +15,9 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . - module HOpenPGP.Tools.Common.TKUtils ( processTK + , verifyTKWithTyped ) where import Codec.Encryption.OpenPGP.Fingerprint @@ -25,64 +25,91 @@ , fingerprint ) import Codec.Encryption.OpenPGP.Policy - ( defaultVerificationPolicy + ( VerificationPolicy + , defaultVerificationPolicy ) import Codec.Encryption.OpenPGP.Signatures - ( verifyAgainstKeys + ( renderVerificationError + , verifyAgainstKeys , verifySigWith - , verifyUnknownTKWith + , verifyTKWith ) import Codec.Encryption.OpenPGP.Types import Control.Arrow (second) import Control.Error.Util (hush) -import Control.Lens ((^.), _1) import Data.Bifunctor (first) import Data.List (sortOn) import Data.Maybe (listToMaybe, mapMaybe) import Data.Ord (Down (..)) +import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) --- should this fail or should verifyUnknownTKWith fail if there are no self-sigs? +verifyTKWithTyped + :: VerificationPolicy + -> [SomeTK] + -> Maybe UTCTime + -> SomeTK + -> Either String SomeTK +verifyTKWithTyped policy keyring mt stk = do + verifiedStk <- case stk of + SomePublicTK publicTk -> + first + renderVerificationError + (SomePublicTK <$> verifyTKWith vsf mt publicTk) + SomeSecretTK secretTk -> + first + renderVerificationError + (SomeSecretTK <$> verifyTKWith vsf mt secretTk) + pure verifiedStk + where + vsf = + verifySigWith + policy + (verifyAgainstKeys (map someTKToUnknown keyring)) + processTK - :: Maybe POSIXTime -> TKUnknown -> Either String TKUnknown -processTK mpt tk = - first show - $ verifyUnknownTKWith - (verifySigWith defaultVerificationPolicy (verifyAgainstKeys [tk])) - (fmap posixSecondsToUTCTime mpt) - . stripOlderSigs - . stripOtherSigs - $ tk + :: Maybe POSIXTime -> SomeTK -> Either String SomeTK +processTK mpt stk = + verifyTKWithTyped + defaultVerificationPolicy + [stk] + (fmap posixSecondsToUTCTime mpt) + strippedStk where - stripOtherSigs tk' = - tk' - { _tkuUIDs = map (second alleged) (_tkuUIDs tk') - , _tkuUAts = map (second alleged) (_tkuUAts tk') + strippedStk = stripOlderSigs (stripOtherSigs stk) + stripOtherSigs (SomePublicTK tk) = SomePublicTK (stripOtherSigsTK tk) + stripOtherSigs (SomeSecretTK tk) = SomeSecretTK (stripOtherSigsTK tk) + stripOlderSigs (SomePublicTK tk) = SomePublicTK (stripOlderSigsTK tk) + stripOlderSigs (SomeSecretTK tk) = SomeSecretTK (stripOlderSigsTK tk) + stripOtherSigsTK tk = + tk + { _tkUIDs = map (second alleged) (_tkUIDs tk) + , _tkUAts = map (second alleged) (_tkUAts tk) } - stripOlderSigs tk' = - tk' - { _tkuUIDs = map (second newest) (_tkuUIDs tk') - , _tkuUAts = map (second newest) (_tkuUAts tk') + stripOlderSigsTK tk = + tk + { _tkUIDs = map (second newest) (_tkUIDs tk) + , _tkUAts = map (second newest) (_tkUAts tk) } - newest = take 1 . sortOn (Down . take 1 . sigcts) -- FIXME: this is terrible + newest = take 1 . sortOn (Down . take 1 . sigcts) sigcts (SigV4 _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs sigcts (SigV6 _ _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs sigcts _ = [] - pkp = tk ^. tkuKey . _1 + pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk)) alleged = filter (\x -> assI x || assIFP x) sigCreationTimeFromSubpacket (SigSubPacket _ (SigCreationTime x)) = Just x sigCreationTimeFromSubpacket _ = Nothing sigissuer (SigVOther 2 _) = Nothing sigissuer SigV3 {} = Nothing sigissuer (SigV4 _ _ _ ys xs _ _) = - listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches? + listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) sigissuer (SigV6 _ _ _ _ ys xs _ _) = - listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches? - sigissuer (SigVOther _ _) = Nothing + listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) + sigissuer _ = Nothing sigissuerfp (SigV4 _ _ _ ys xs _ _) = - listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches? + listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) sigissuerfp (SigV6 _ _ _ _ ys xs _ _) = - listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches? + listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) sigissuerfp _ = Nothing eoki | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp diff --git a/HOpenPGP/Tools/Common/WKD.hs b/HOpenPGP/Tools/Common/WKD.hs --- a/HOpenPGP/Tools/Common/WKD.hs +++ b/HOpenPGP/Tools/Common/WKD.hs @@ -27,7 +27,11 @@ ( Armor (Armor) , ArmorType (ArmorPublicKeyBlock) ) -import Codec.Encryption.OpenPGP.Types (TKUnknown (..)) +import Codec.Encryption.OpenPGP.Types + ( SomeTK (..) + , someTKToPublicViewTK + , _tkUIDs + ) import Control.Arrow ((&&&)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT (..), throwE) @@ -42,7 +46,10 @@ import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither) +import Data.Conduit.OpenPGP.Keyring + ( conduitDropErrorsAndNothings + , conduitToSomeTKsDroppingEither + ) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Either (rights) import Data.Text (Text) @@ -67,7 +74,7 @@ fetchKeys :: FetchValidationMethod -> Text - -> ExceptT String IO [TKUnknown] + -> ExceptT String IO [SomeTK] fetchKeys fvm mailbox = do parsedMailbox <- ExceptT . return $ parseMailbox mailbox manager <- liftIO $ newManager tlsManagerSettings @@ -124,7 +131,7 @@ :: FetchValidationMethod -> (Text, Text) -> BL.ByteString - -> ExceptT String IO [TKUnknown] + -> ExceptT String IO [SomeTK] validateAndFilterKeys fvm mailbox body = do keys <- decodeWkdResponse body cpt <- liftIO getPOSIXTime @@ -140,23 +147,22 @@ MatchPrimaryOrAnySubkeyFingerprint -> mailboxFiltered decodeWkdResponse - :: BL.ByteString -> ExceptT String IO [TKUnknown] + :: BL.ByteString -> ExceptT String IO [SomeTK] decodeWkdResponse body = if isArmored body then decodeArmored body else decodeBinary body -decodeBinary :: BL.ByteString -> ExceptT String IO [TKUnknown] +decodeBinary :: BL.ByteString -> ExceptT String IO [SomeTK] decodeBinary bytes = liftIO . runConduitRes $ CB.sourceLbs bytes .| conduitGet get - .| conduitToTKsDroppingEither - .| CL.mapFoldable id - .| CL.mapMaybe id + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CL.consume -decodeArmored :: BL.ByteString -> ExceptT String IO [TKUnknown] +decodeArmored :: BL.ByteString -> ExceptT String IO [SomeTK] decodeArmored larmors = do bytestrings <- ExceptT . return $ @@ -164,9 +170,8 @@ liftIO . runConduitRes $ CB.sourceLbs bytestrings .| conduitGet get - .| conduitToTKsDroppingEither - .| CL.mapFoldable id - .| CL.mapMaybe id + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CL.consume where armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs @@ -178,16 +183,17 @@ . BL.toStrict . BL.take 40 -mailboxMatchesKey :: (Text, Text) -> TKUnknown -> Bool -mailboxMatchesKey (localPart, domain) tk = +mailboxMatchesKey :: (Text, Text) -> SomeTK -> Bool +mailboxMatchesKey (localPart, domain) stk = let mailbox = T.toLower (localPart <> "@" <> domain) bracketedMailbox = "<" <> mailbox <> ">" + uids = map fst (_tkUIDs (someTKToPublicViewTK stk)) in any ( \uid -> let lowered = T.toLower uid in lowered == mailbox || bracketedMailbox `T.isInfixOf` lowered ) - (map fst (_tkuUIDs tk)) + uids sha1 :: B.ByteString -> B.ByteString sha1 bs = BA.convert (CH.hashWith CHA.SHA1 bs :: CH.Digest CHA.SHA1) diff --git a/HOpenPGP/Tools/Hokey/Canonicalize.hs b/HOpenPGP/Tools/Hokey/Canonicalize.hs --- a/HOpenPGP/Tools/Hokey/Canonicalize.hs +++ b/HOpenPGP/Tools/Hokey/Canonicalize.hs @@ -22,14 +22,22 @@ import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types -import Control.Error.Util (hush) + ( SomeTK (..) + , someTKToUnknown + , _tkRevs + , _tkSubs + , _tkUAts + , _tkUIDs + ) import Control.Lens (mapped, over, _2) -import Control.Monad (join) import Data.Binary (get, put) import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither) +import Data.Conduit.OpenPGP.Keyring + ( conduitDropErrorsAndNothings + , conduitToSomeTKsDroppingEither + ) import Data.Conduit.Serialization.Binary (conduitGet, conduitPut) import Data.List (nub, sort) import System.IO @@ -42,19 +50,22 @@ runConduitRes $ CB.sourceHandle stdin .| conduitGet get - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CL.map canonicalize + .| CL.map someTKToUnknown .| CL.map put .| conduitPut .| CB.sinkHandle stdout where - canonicalize tk = + canonicalize (SomePublicTK tk) = SomePublicTK (canonicalizeTK tk) + canonicalize (SomeSecretTK tk) = SomeSecretTK (canonicalizeTK tk) + canonicalizeTK tk = tk - { _tkuRevs = sort (_tkuRevs tk) - , _tkuUIDs = indepthsort (_tkuUIDs tk) - , _tkuUAts = indepthsort (_tkuUAts tk) - , _tkuSubs = indepthsort (_tkuSubs tk) + { _tkRevs = sort (_tkRevs tk) + , _tkUIDs = indepthsort (_tkUIDs tk) + , _tkUAts = indepthsort (_tkUAts tk) + , _tkSubs = indepthsort (_tkSubs tk) } indepthsort :: (Ord a, Ord b) => [(a, [b])] -> [(a, [b])] indepthsort = nub . sort . over (mapped . _2) sort diff --git a/HOpenPGP/Tools/Hokey/Lint.hs b/HOpenPGP/Tools/Hokey/Lint.hs --- a/HOpenPGP/Tools/Hokey/Lint.hs +++ b/HOpenPGP/Tools/Hokey/Lint.hs @@ -49,8 +49,8 @@ import Codec.Encryption.OpenPGP.Types import Control.Arrow ((***)) import Control.Error.Util (hush) -import Control.Lens ((&), (^.), _1) -import Control.Monad (join, void) +import Control.Lens ((&)) +import Control.Monad (void) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHA @@ -64,7 +64,10 @@ import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither) +import Data.Conduit.OpenPGP.Keyring + ( conduitDropErrorsAndNothings + , conduitToSomeTKsDroppingEither + ) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Foldable (find, maximumBy, sequenceA_, traverse_) import Data.List (elemIndex, findIndex, intercalate, nub, sortOn) @@ -255,11 +258,11 @@ mempty = UIDReport [] [] [] [] [] mappend = (<>) -checkKey :: LintPolicy TKUnknown KeyReport +checkKey :: LintPolicy SomeTK KeyReport checkKey = LintPolicy $ \tk mpt -> checkKey' mpt tk -checkKey' :: Maybe POSIXTime -> TKUnknown -> Result KeyReport -checkKey' mpt tk = +checkKey' :: Maybe POSIXTime -> SomeTK -> Result KeyReport +checkKey' mpt stk = kr <$ sequenceA_ [ void (keyStatus kr) @@ -271,6 +274,10 @@ , traverse_ void (keyUIDsAndUAts kr) ] where + procResult = processTK mpt stk + processedTK = either (const stk) id procResult + publicView = someTKToPublicViewTK processedTK + primaryKey = keyPktPKPayload (_tkPrimaryKey publicView) kr = KeyReport { keyStatus = pure (either id (const "good") procResult) @@ -289,15 +296,11 @@ Map.fromListWith (liftA2 (<>)) $ map (\(x, y) -> (x, uidr (Just x) y)) - (processedTK ^. tkuUIDs) + (_tkUIDs publicView) ++ map (uatspsToText *** uidr Nothing) - (processedTK ^. tkuUAts) - subkeys = - map (checkSK (fingerprint primaryKey)) (processedTK ^. tkuSubs) - procResult = processTK mpt tk - processedTK = either (const tk) id procResult - primaryKey = processedTK ^. tkuKey . _1 + (_tkUAts publicView) + subkeys = map (checkSK (fingerprint primaryKey)) (_tkSubs publicView) uidr :: Maybe Text -> [SignaturePayload] -> Result UIDReport uidr Nothing sps = UIDReport @@ -569,9 +572,11 @@ then [] else [maximumBy (comparing sigTime) filtered] checkSK - :: Fingerprint -> (Pkt, [SignaturePayload]) -> Result SubkeyReport - checkSK pf (PublicSubkeyPkt pkp, sigs) = checkSK' pf pkp sigs - checkSK pf (SecretSubkeyPkt pkp _, sigs) = checkSK' pf pkp sigs + :: Fingerprint + -> (KeyPkt k, [SignaturePayload]) + -> Result SubkeyReport + checkSK pf (KeyPktPublicSubkey pkp, sigs) = checkSK' pf pkp sigs + checkSK pf (KeyPktSecretSubkey pkp _, sigs) = checkSK' pf pkp sigs checkSK _ _ = error "checkSK: unexpected packet type" checkSK' pf pkp sigs = skr @@ -679,9 +684,9 @@ } else Nothing -prettyKeyReport :: POSIXTime -> TKUnknown -> Doc PPA.AnsiStyle -prettyKeyReport cpt tk = do - let keyReportResult = unPolicy checkKey tk (Just cpt) +prettyKeyReport :: POSIXTime -> SomeTK -> Doc PPA.AnsiStyle +prettyKeyReport cpt stk = do + let keyReportResult = unPolicy checkKey stk (Just cpt) keyReport = getResult keyReportResult execWriter $ tell $ @@ -884,11 +889,12 @@ skr ) -jsonReport :: POSIXTime -> TKUnknown -> BL.ByteString -jsonReport ps tk = A.encode (getResult (unPolicy checkKey tk (Just ps))) +jsonReport :: POSIXTime -> SomeTK -> BL.ByteString +jsonReport ps stk = A.encode (getResult (unPolicy checkKey stk (Just ps))) -yamlReport :: POSIXTime -> TKUnknown -> B.ByteString -yamlReport ps tk = Y.encode . (: []) $ getResult (unPolicy checkKey tk (Just ps)) +yamlReport :: POSIXTime -> SomeTK -> B.ByteString +yamlReport ps stk = + Y.encode . (: []) $ getResult (unPolicy checkKey stk (Just ps)) doLint :: LintOptions -> IO () doLint o = do @@ -897,8 +903,8 @@ runConduitRes $ CB.sourceHandle stdin .| conduitGet get - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CL.consume output (lintOutputFormat o) cpt keys where diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -33,18 +33,32 @@ ( defaultVerificationPolicy ) import Codec.Encryption.OpenPGP.Serialize () -import Codec.Encryption.OpenPGP.Signatures - ( verifyAgainstKeyring - , verifySigWith - , verifyUnknownTKWith - ) import Codec.Encryption.OpenPGP.Types + ( EightOctetKeyId + , Fingerprint + , HashAlgorithm (..) + , PublicKey (..) + , PublicKeyring + , SigSubPacket (_sspPayload) + , SigSubPacketPayload (..) + , Signature (..) + , SignaturePayload (..) + , SomePKPayload (..) + , SomeTK (..) + , TK (..) + , UserAttribute (..) + , UserId (..) + , keyPktPKPayload + , keyPktToPkt + , someTKToPublicViewTK + , someTKToUnknown + , _pkalgo + , _pubkey + ) import Control.Applicative (optional, (<|>)) import Control.Arrow ((&&&)) -import Control.Error.Util (hush) import Control.Exception (ErrorCall, evaluate, try) -import Control.Lens ((^.), (^..), _1, _2) -import Control.Monad (join) +import Control.Lens ((^..), _1) import Control.Monad.Trans.Except (except, runExcept) import Control.Monad.Trans.Resource (MonadResource, MonadThrow) import qualified Data.Aeson as A @@ -56,11 +70,12 @@ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Filter - ( FilterPredicates (RTKFilterPredicate) - , conduitTKFilter + ( FilterPredicates (RFilterPredicate) + , runPredicate ) import Data.Conduit.OpenPGP.Keyring - ( conduitToTKsDroppingEither + ( conduitDropErrorsAndNothings + , conduitToSomeTKsDroppingEither , sinkPublicKeyringMap ) import Data.Conduit.Serialization.Binary (conduitGet) @@ -83,6 +98,7 @@ import Data.GraphViz.Types (printDotGraph) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap +import qualified Data.IxSet.Typed as IxSet import Data.List (nub, sort) import Data.Map (Map) import qualified Data.Map as Map @@ -156,21 +172,22 @@ , warranty ) import HOpenPGP.Tools.Common.Parser (parseTKExp) +import HOpenPGP.Tools.Common.TKUtils (verifyTKWithTyped) grabMatchingKeysConduit :: (MonadResource m, MonadThrow m) => FilePath -> Bool - -> FilterPredicates Void TKUnknown + -> FilterPredicates Void SomeTK -> Text - -> ConduitM () TKUnknown m () + -> ConduitM () SomeTK m () grabMatchingKeysConduit fp filt ufp srch = CB.sourceFile fp .| conduitGet get - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| ( if filt - then conduitTKFilter ufp + then CL.filter (runPredicate ufp) else CL.filter matchAny ) where @@ -183,7 +200,7 @@ efp = (except . parseFingerprint) srch eeok = (except . parseEightOctetKeyId) srch -grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TKUnknown] +grabMatchingKeys :: FilePath -> Bool -> Text -> IO [SomeTK] grabMatchingKeys fp filt srch = if filt then do @@ -198,8 +215,8 @@ runConduitRes $ CB.sourceFile fp .| conduitGet get - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CL.filter matchAny .| CL.consume where @@ -212,17 +229,14 @@ efp = (except . parseFingerprint) srch eeok = (except . parseEightOctetKeyId) srch -grabMatchingPublicKeyring :: [TKUnknown] -> IO PublicKeyring +grabMatchingPublicKeyring :: [SomeTK] -> IO PublicKeyring grabMatchingPublicKeyring keys = runConduitRes $ - CL.sourceList (mapMaybe unknownToPublicTK keys) + CL.sourceList (mapMaybe someTKToPublicTk keys) .| sinkPublicKeyringMap where - unknownToPublicTK tk = - case fromUnknownToTK tk of - Right (SomePublicTK publicTk) -> Just publicTk - Right (SomeSecretTK secretTk) -> Just (publicViewTK secretTk) - Left _ -> Nothing + someTKToPublicTk (SomePublicTK publicTk) = Just publicTk + someTKToPublicTk (SomeSecretTK secretTk) = Just (someTKToPublicViewTK (SomeSecretTK secretTk)) data Key = Key @@ -245,21 +259,18 @@ instance A.ToJSON TKey -tkToTKey :: TKUnknown -> TKey -tkToTKey tk = +tkToTKey :: SomeTK -> TKey +tkToTKey stk = TKey - { publickey = mkey (tk ^. tkuKey . _1) - , uids = tk ^. tkuUIDs ^.. traverse . _1 + { publickey = mkey (keyPktPKPayload (_tkPrimaryKey publicView)) + , uids = _tkUIDs publicView ^.. traverse . _1 , subkeys = mapMaybe - ( \t -> case t of - (PublicSubkeyPkt x, _) -> Just (mkey x) - (SecretSubkeyPkt x _, _) -> Just (mkey x) - _ -> Nothing - ) - (tk ^. tkuSubs) + (\kp -> Just (mkey (keyPktPKPayload kp))) + (map fst (_tkSubs publicView)) } where + publicView = someTKToPublicViewTK stk mkey = Key <$> either (const Nothing) Just . pubkeySize . _pubkey @@ -517,16 +528,20 @@ grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o) case pathsOutputFormat o of Unstructured -> mapM_ (BL.putStr . putTK') keys - JSON -> BL.putStr . A.encode $ keys - YAML -> B.putStr . Y.encode $ keys + JSON -> BL.putStr . A.encode $ map someTKToUnknown keys + YAML -> B.putStr . Y.encode $ map someTKToUnknown keys where putTK' tk = runPut $ do - put (PublicKey (tk ^. tkuKey . _1)) - mapM_ (put . Signature) (_tkuRevs tk) - mapM_ putUid' (_tkuUIDs tk) - mapM_ putUat' (_tkuUAts tk) - mapM_ putSub' (_tkuSubs tk) + put (PublicKey (keyPktPKPayload (_tkPrimaryKey publicView))) + mapM_ (put . Signature) (_tkRevs publicView) + mapM_ putUid' (_tkUIDs publicView) + mapM_ putUat' (_tkUAts publicView) + mapM_ + putSub' + (map (\(kp, sigs) -> (keyPktToPkt kp, sigs)) (_tkSubs publicView)) + where + publicView = someTKToPublicViewTK tk putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps putSub' (p, sps) = put p >> mapM_ (put . Signature) sps @@ -543,8 +558,9 @@ ( (buildMaps &&& id) ( rights ( map - ( verifyUnknownTKWith - (verifySigWith defaultVerificationPolicy (verifyAgainstKeyring kr)) + ( verifyTKWithTyped + defaultVerificationPolicy + (map SomePublicTK (IxSet.toList kr)) (Just (posixSecondsToUTCTime cpt)) ) keys @@ -567,7 +583,7 @@ { fmtNode = \(_, l) -> [toLabel $ renderFingerprint l] } -buildMaps :: [TKUnknown] -> (KeyMaps, Int) +buildMaps :: [SomeTK] -> (KeyMaps, Int) buildMaps = foldr mapsInsertions @@ -581,12 +597,13 @@ , _i2f :: HashMap Int Fingerprint } -mapsInsertions :: TKUnknown -> (KeyMaps, Int) -> (KeyMaps, Int) -mapsInsertions tk (KeyMaps k2f f2i i2f, i) = - let fp = fingerprint (tk ^. tkuKey . _1) +mapsInsertions :: SomeTK -> (KeyMaps, Int) -> (KeyMaps, Int) +mapsInsertions stk (KeyMaps k2f f2i i2f, i) = + let publicView = someTKToPublicViewTK stk + fp = fingerprint (keyPktPKPayload (_tkPrimaryKey publicView)) keyids = rights . map eightOctetKeyID $ - (tk ^.. biplate :: [SomePKPayload]) + (someTKToUnknown stk ^.. biplate :: [SomePKPayload]) i' = i + 1 k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids f2i' = HashMap.insert fp i' f2i @@ -594,7 +611,7 @@ in (KeyMaps k2f' f2i' i2f', i') buildKeyGraph - :: ((KeyMaps, Int), [TKUnknown]) + :: ((KeyMaps, Int), [SomeTK]) -> Either String (Gr Fingerprint HashAlgorithm) buildKeyGraph ((KeyMaps k2f f2i _, _), ks) = do edges <- fmap concat (mapM tkToEdges ks) @@ -603,7 +620,10 @@ where nodes = map swap . HashMap.toList $ f2i tkToEdges tk = do - target <- lookupNode (fingerprint (tk ^. tkuKey . _1)) + let publicView = someTKToPublicViewTK tk + target <- + lookupNode + (fingerprint (keyPktPKPayload (_tkPrimaryKey publicView))) mapM (edgeFor target) (mapMaybe (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk)) @@ -624,10 +644,7 @@ ("hkt: no graph node for fingerprint " ++ renderFingerprint fp) fakejoin (x, y) = fmap ((,) x) y sigs tk = - concat - ( (tk ^.. tkuUIDs . traverse . _2) - ++ (tk ^.. tkuUAts . traverse . _2) - ) + someTKToUnknown tk ^.. biplate :: [SignaturePayload] samesies (x, y, _) = x == y data PaF @@ -658,7 +675,7 @@ runConduitRes $ CL.sourceList keys .| ( if filt - then conduitTKFilter filter2 + then CL.filter (runPredicate filter2) else CL.filter (matchAny (ttarget2 o)) ) .| CL.consume @@ -666,7 +683,7 @@ runConduitRes $ CL.sourceList keys .| ( if filt - then conduitTKFilter filter3 + then CL.filter (runPredicate filter3) else CL.filter (matchAny (ttarget3 o)) ) .| CL.consume @@ -674,8 +691,9 @@ (buildMaps &&& id) ( rights ( map - ( verifyUnknownTKWith - (verifySigWith defaultVerificationPolicy (verifyAgainstKeyring kr)) + ( verifyTKWithTyped + defaultVerificationPolicy + (map SomePublicTK (IxSet.toList kr)) (Just (posixSecondsToUTCTime cpt)) ) keys @@ -685,7 +703,13 @@ either dieHKT pure (buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks)) let keysToIs = mapMaybe - (\x -> HashMap.lookup (fingerprint (x ^. tkuKey . _1)) f2i) + ( \x -> + HashMap.lookup + ( fingerprint + (keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK x))) + ) + f2i + ) froms = keysToIs keys1 tos = keysToIs keys2 combos = froms >>= \f -> tos >>= \t -> return (f, t) @@ -731,14 +755,14 @@ <|> return (keyMatchesUIDSubString srch tk) parseFilterPredicateIO - :: Text -> IO (Either String (FilterPredicates Void TKUnknown)) + :: Text -> IO (Either String (FilterPredicates Void SomeTK)) parseFilterPredicateIO e = do parsed <- - try (evaluate (RTKFilterPredicate <$> parseTKExp (T.unpack e))) + try (evaluate (RFilterPredicate <$> parseTKExp (T.unpack e))) :: IO ( Either ErrorCall - (Either String (FilterPredicates Void TKUnknown)) + (Either String (FilterPredicates Void SomeTK)) ) pure $ case parsed of diff --git a/hop.hs b/hop.hs --- a/hop.hs +++ b/hop.hs @@ -15,7 +15,9 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA @@ -34,12 +36,12 @@ , RecipientEncryptRequest (..) , RecipientEncryptRequestOverrides (..) , RecipientEncryptResult (..) - , RecipientPKESKVersionStrategy (..) + , RecipientPKESKVersionStrategyW (..) , RecipientPayloadShape (..) , defaultRecipientPayloadShape , encryptForRecipients , recipientEncryptionTarget - , recipientEncryptionTargetWithStrategy + , recipientEncryptionTargetWithStrategyTyped ) import Codec.Encryption.OpenPGP.Expirations ( effectiveKeyPreferencesAt @@ -93,14 +95,11 @@ , signDataWithRSAV6 , signKeyRevocationWithRSA , signUserIDwithRSA - , verifyAgainstKeys - , verifySigWith - , verifyUnknownTKWith ) import qualified Codec.Encryption.OpenPGP.Subpackets as SP import Codec.Encryption.OpenPGP.Types import Control.Applicative (many, optional, some, (<|>)) -import Control.Error.Util (hush, note) +import Control.Error.Util (note) import Control.Exception ( IOException , SomeException @@ -109,8 +108,9 @@ , evaluate , throwIO ) -import Control.Monad (forM, forM_, join, unless, when, (>=>)) -import Control.Monad.IO.Class (liftIO) +import Control.Lens ((^..)) +import Control.Monad (forM, forM_, unless, when, (>=>)) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Lazy (StateT, evalStateT, get, modify) import Crypto.Error (eitherCryptoError) import Crypto.Number.Serialize (i2ospOf_, os2ip) @@ -119,7 +119,7 @@ import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as P15 -import Crypto.Random.Types (getRandomBytes) +import Crypto.Random.Types (MonadRandom, getRandomBytes) import qualified Data.Aeson as A import Data.Bifunctor (first) import qualified Data.Binary as Bin @@ -149,13 +149,15 @@ ) import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt import Data.Conduit.OpenPGP.Keyring - ( conduitToTKsDroppingEither + ( conduitDropErrorsAndNothings + , conduitToSomeTKsDroppingEither , sinkPublicKeyringMap ) import Data.Conduit.OpenPGP.Verify ( conduitVerify , verifyPacketsBatch ) +import Data.Data.Lens (biplate) import Data.Either (fromRight, isLeft, isRight, rights) import Data.IORef (IORef, atomicModifyIORef', newIORef) import Data.List @@ -256,7 +258,10 @@ , versioner , warranty ) -import HOpenPGP.Tools.Common.TKUtils (processTK) +import HOpenPGP.Tools.Common.TKUtils + ( processTK + , verifyTKWithTyped + ) import Paths_hopenpgp_tools (version) data Command @@ -472,8 +477,8 @@ failureCode CertUserIdNoMatch = 107 failureCode KeyCannotCertify = 109 -failWith :: SopFailure -> String -> IO a -failWith f msg = do +failWith :: MonadIO m => SopFailure -> String -> m a +failWith f msg = liftIO $ do BLC8.hPutStrLn stderr (BLC8.pack msg) exitWith (ExitFailure (failureCode f)) @@ -1180,21 +1185,28 @@ return newkey s <- maybe - (pure baseKey) - (`encryptTransferableSecretKey` baseKey) + (pure (SomeSecretTK baseKey)) + (`encryptTransferableSecretKey` (SomeSecretTK baseKey)) password - let lbs = runPut $ Bin.put s + let lbs = runPut $ Bin.put (someTKToUnknown s) BL.putStr $ if not armor && not noArmor then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs] else lbs -type KeyBuilder = StateT TKUnknown IO +type KeyBuilder = StateT (TK 'SecretTK) IO buildKeyWith :: SecretKey -> KeyBuilder a -> IO a buildKeyWith sk a = evalStateT a (bareTK sk) where - bareTK (SecretKey pkp ska) = TKUnknown (pkp, Just ska) [] [] [] [] + bareTK (SecretKey pkp ska) = + TK + { _tkPrimaryKey = KeyPktSecretPrimary pkp ska + , _tkRevs = [] + , _tkUIDs = [] + , _tkUAts = [] + , _tkSubs = [] + } data GeneratedKeySpec = GeneratedRSAKey Int @@ -1459,20 +1471,29 @@ | otherwise = GeneratedEd25519Key encryptTransferableSecretKey - :: BL.ByteString -> TKUnknown -> IO TKUnknown -encryptTransferableSecretKey password tk = do - keyPair' <- encryptKeyPair (_tkuKey tk) - subs' <- mapM encryptSub (_tkuSubs tk) - pure tk {_tkuKey = keyPair', _tkuSubs = subs'} + :: 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 where - encryptKeyPair (pkp, Just ska) = do - encrypted <- encryptSecretAddendumForOutput pkp ska - pure (pkp, Just encrypted) - encryptKeyPair keyPair = pure keyPair - encryptSub (SecretSubkeyPkt pkp ska, sigs) = do - encrypted <- encryptSecretAddendumForOutput pkp ska - pure (SecretSubkeyPkt pkp encrypted, sigs) - encryptSub sub = pure sub + 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 = case ska of SUUnencrypted {} -> doEncryptSecret @@ -1513,11 +1534,16 @@ :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder () addUserId ts primary userid = do tk <- get - signed <- selfsign (_tkuKey tk) userid + let pkp = keyPktPKPayload (_tkPrimaryKey tk) + ska :: SKAddendum + ska = case _tkPrimaryKey tk of + KeyPktSecretPrimary _ ska' -> ska' + _ -> error "addUserId: expected secret primary key" + signed <- selfsign pkp ska userid modify (newUID signed) where - newUID signed tk = tk {_tkuUIDs = _tkuUIDs tk ++ [signed]} - selfsign (pkp, Just ska) u = do + newUID signed tk = tk {_tkUIDs = _tkUIDs tk ++ [signed]} + selfsign pkp ska u = do issuer <- liftIO (unhashed pkp) sig <- liftIO $ @@ -1531,11 +1557,6 @@ (userIdPayloadForSigning pkp (UserId u)) (Just ska) pure (u, [sig]) - selfsign _ _ = - liftIO $ - failWith - BadData - "generate-key: primary key is missing secret key material" hashed pkp = [ SigSubPacket False (SigCreationTime ts) , SigSubPacket @@ -1569,14 +1590,11 @@ ts keyVersion (subkeySpecForProfile profile keyflags) - (pkp, ska) <- - case _tkuKey tk of - (primaryPkp, Just primarySka) -> pure (primaryPkp, primarySka) - _ -> - liftIO $ - failWith - BadData - "generate-key: primary key is missing secret key material" + let pkp = keyPktPKPayload (_tkPrimaryKey tk) + ska :: SKAddendum + ska = case _tkPrimaryKey tk of + KeyPktSecretPrimary _ ska' -> ska' + _ -> error "addSubkey: expected secret primary key" issuerPrimary <- liftIO (unhashed pkp) issuerSub <- liftIO (unhashed subpkp) embeddedBacksig <- @@ -1615,7 +1633,7 @@ where addIt sp ss binding tk = tk - { _tkuSubs = _tkuSubs tk ++ [(SecretSubkeyPkt sp ss, [binding])] + { _tkSubs = _tkSubs tk ++ [(KeyPktSecretSubkey sp ss, [binding])] } hashed pkp = [ SigSubPacket False (SigCreationTime ts) @@ -1691,28 +1709,23 @@ tks <- runConduitRes $ CL.sourceList pkts - .| conduitToTKsDroppingEither - .| CL.mapMaybe (either (const Nothing) id) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList when (null tks) $ failWith MissingInput "extract-cert: no transferable secret key found on standard input" - let output = runPut $ mapM_ (Bin.put . pubToSecret) tks + let output = runPut $ mapM_ (Bin.put . someTKToUnknown . pubToSecret) tks BL.putStr $ if not ecArmor && not ecNoArmor then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output] else output where pubToSecret tk = - tk - { _tkuKey = pToS (_tkuKey tk) - , _tkuSubs = map subPToS (_tkuSubs tk) - } - pToS (pkp, _) = (pkp, Nothing) - subPToS (SecretSubkeyPkt pkp _, sigs) = (PublicSubkeyPkt pkp, sigs) - subPToS (PublicSubkeyPkt pkp, sigs) = (PublicSubkeyPkt pkp, sigs) - subPToS x = x + case tk of + SomeSecretTK _ -> SomePublicTK (someTKToPublicViewTK tk) + SomePublicTK publicTk -> SomePublicTK publicTk doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO () doChangeKeyPassword ChangeKeyPasswordOptions {..} = do @@ -1721,8 +1734,8 @@ tks <- runConduitRes $ CL.sourceList packets - .| conduitToTKsDroppingEither - .| CL.mapMaybe (either (const Nothing) id) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList when (null tks) $ failWith @@ -1753,7 +1766,7 @@ case newPassword of Just password -> mapM (encryptTransferableSecretKey password) unlockedTks Nothing -> pure unlockedTks - let output = runPut (mapM_ Bin.put rewrittenTks) + let output = runPut (mapM_ (Bin.put . someTKToUnknown) rewrittenTks) BL.putStr $ if changeKeyPasswordNoArmor || BL.null output then output @@ -1777,14 +1790,11 @@ UnsupportedOption "change-key-password: multiple --new-key-password values are not supported" -hasSecretKeyMaterial :: TKUnknown -> Bool +hasSecretKeyMaterial :: SomeTK -> Bool hasSecretKeyMaterial tk = - case _tkuKey tk of - (_, Just _) -> True - _ -> any isSecretSubkeyPkt (_tkuSubs tk) - where - isSecretSubkeyPkt (SecretSubkeyPkt _ _, _) = True - isSecretSubkeyPkt _ = False + case tk of + SomeSecretTK _ -> True + SomePublicTK _ -> False doValidateUserId :: POSIXTime -> ValidateUserIdOptions -> IO () doValidateUserId cpt ValidateUserIdOptions {..} = do @@ -1799,8 +1809,8 @@ certTks <- runConduitRes $ CL.sourceList certPkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList when (null certTks) $ failWith @@ -1825,16 +1835,17 @@ ) certificateHasMatchingValidatedUserId - :: [TKUnknown] -> Maybe UTCTime -> Bool -> Text -> TKUnknown -> Bool + :: [SomeTK] -> Maybe UTCTime -> Bool -> Text -> SomeTK -> Bool certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk = - case verifyUnknownTKWith verifier validateAtTime certTk of + case verifyTKWithTyped + defaultVerificationPolicy + (certTk : authorityTks) + validateAtTime + certTk of Left _ -> False - Right verifiedTk -> any matchingBoundUid (_tkuUIDs verifiedTk) + Right verifiedTk -> + any matchingBoundUid (_tkUIDs (someTKToPublicViewTK verifiedTk)) where - verifier = - verifySigWith - defaultVerificationPolicy - (verifyAgainstKeys (certTk : authorityTks)) matchingBoundUid (uid, sigs) = useridMatches addrSpecOnly targetUserId uid && any (signatureMatchesSigner certTk) sigs @@ -1864,7 +1875,7 @@ | T.null text = Nothing | otherwise = Just text -signatureMatchesSigner :: TKUnknown -> SignaturePayload -> Bool +signatureMatchesSigner :: SomeTK -> SignaturePayload -> Bool signatureMatchesSigner signer sig = maybe False @@ -1917,8 +1928,8 @@ targetTks <- runConduitRes $ CL.sourceList certPkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList when (null targetTks) $ failWith @@ -1936,7 +1947,7 @@ signerTks ) targetTks - let output = runPut (mapM_ Bin.put updatedTargets) + let output = runPut (mapM_ (Bin.put . someTKToUnknown) updatedTargets) armorOutput = case certifyUserIdOutputFormat of Just "binary" -> output @@ -1944,15 +1955,15 @@ BL.putStr armorOutput loadCertifySignerTKsFromFile - :: [BL.ByteString] -> String -> IO [TKUnknown] + :: [BL.ByteString] -> String -> IO [SomeTK] loadCertifySignerTKsFromFile signerPasswords path = do lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy packets <- decodeOpenPGPInput path lbs tks <- runConduitRes $ CL.sourceList packets - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList let fallbackTks = signingFallbackTKs packets when (null tks && null fallbackTks) $ @@ -1969,10 +1980,12 @@ (if null tks then fallbackTks else tks) addUserIdCertifications - :: TKUnknown -> [Text] -> Bool -> [TKUnknown] -> IO TKUnknown + :: SomeTK -> [Text] -> Bool -> [SomeTK] -> IO SomeTK addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do forM_ targetUserIds $ \targetUserId -> - case find ((== targetUserId) . fst) (_tkuUIDs targetTk) of + case find + ((== targetUserId) . fst) + (_tkUIDs (someTKToPublicViewTK targetTk)) of Nothing -> failWith CertUserIdNoMatch @@ -2005,19 +2018,28 @@ if uid `elem` targetUserIds then (uid, sigs ++ map snd (filter ((== uid) . fst) newSigs)) else (uid, sigs) - pure $ targetTk {_tkuUIDs = map updateUID (_tkuUIDs targetTk)} + pure $ case targetTk of + SomePublicTK tk -> SomePublicTK tk {_tkUIDs = map updateUID (_tkUIDs tk)} + SomeSecretTK tk -> SomeSecretTK tk {_tkUIDs = map updateUID (_tkUIDs tk)} createUIDCertification - :: Text -> TKUnknown -> IO SignaturePayload + :: Text -> SomeTK -> IO SignaturePayload createUIDCertification targetUserId signerTk = do - let (signerPkp, mSignerSka) = _tkuKey signerTk signerSka <- - case mSignerSka of - Just ska -> pure ska - Nothing -> + case signerTk of + SomeSecretTK secretTk -> + case _tkPrimaryKey secretTk of + KeyPktSecretPrimary _ ska -> pure ska + _ -> + failWith + KeyCannotCertify + "certify-userid: signer certificate has no secret key material" + SomePublicTK _ -> failWith KeyCannotCertify "certify-userid: signer certificate has no secret key material" + let signerPkp = + keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK signerTk)) signingKey <- rsaSigningKey signerSka issuer <- issuerSubpacketsFor "certify-userid" signerPkp let hashed = [SigSubPacket False (SigCreationTime (_timestamp signerPkp))] @@ -2048,8 +2070,8 @@ keyTks <- runConduitRes $ CL.sourceList keyPkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList when (null keyTks) $ failWith @@ -2071,7 +2093,16 @@ "--with-key-password" keyPasswords' keyTk - let (pkp, mSka) = _tkuKey unlockedTk + (pkp, mSka) <- + case unlockedTk of + SomeSecretTK secretTk -> + pure $ case _tkPrimaryKey secretTk of + KeyPktSecretPrimary pkp ska -> (pkp, Just ska) + _ -> error "createKeyRevocation: unexpected primary key type" + SomePublicTK publicTk -> + pure $ case _tkPrimaryKey publicTk of + KeyPktPublicPrimary pkp -> (pkp, Nothing) + _ -> error "createKeyRevocation: unexpected primary key type" ska <- case mSka of Just s -> pure s @@ -2097,8 +2128,8 @@ keyTks <- runConduitRes $ CL.sourceList keyPkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList when (null keyTks) $ failWith @@ -2109,10 +2140,19 @@ _ -> error "revoke-userid: no key found on standard input (should be caught above)" - (pkp, mSka) = _tkuKey keyTk + 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) (_tkuUIDs keyTk)) $ - failWith + unless + ( any + ((== targetUserId) . fst) + (_tkUIDs (someTKToPublicViewTK keyTk)) + ) + $ failWith MissingInput ( "revoke-userid: key has no user ID matching " ++ revokeUserIdString @@ -2165,8 +2205,8 @@ stdinTks <- runConduitRes $ CL.sourceList stdinPkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList when (null stdinTks) $ failWith @@ -2195,15 +2235,22 @@ let updatedTks = map ( \targetTk -> - foldl' - (<>) - targetTk - ( selectUpdateMergeInputs - cpt - updateKeyNoAddedCapabilities - targetTk - updateTks - ) + let mergedTkUnknown = + foldl' + (<>) + (someTKToUnknown targetTk) + ( map + someTKToUnknown + ( selectUpdateMergeInputs + cpt + updateKeyNoAddedCapabilities + targetTk + updateTks + ) + ) + in case fromUnknownToTKEither mergedTkUnknown of + Right mergedStk -> mergedStk + Left _ -> targetTk ) stdinUnlocked -- Choose armor type based on whether updated key has secret material @@ -2211,7 +2258,7 @@ if any hasSecretKeyMaterial updatedTks then ArmorPrivateKeyBlock else ArmorPublicKeyBlock - output = runPut (mapM_ Bin.put updatedTks) + output = runPut (mapM_ (Bin.put . someTKToUnknown) updatedTks) BL.putStr $ if updateKeyNoArmor then output @@ -2225,20 +2272,20 @@ stdinTks <- runConduitRes $ CL.sourceList stdinPkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList mergeInTks <- concat <$> mapM loadVerifyTKsFromFile mergeCertsFiles let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks - output = runPut (mapM_ Bin.put mergedTks) + output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedTks) BL.putStr $ if mergeCertsNoArmor || BL.null output then output else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output] mergeCertificatesForOutput - :: [TKUnknown] -> [TKUnknown] -> [TKUnknown] + :: [SomeTK] -> [SomeTK] -> [SomeTK] mergeCertificatesForOutput stdinTks mergeInTks = map mergeGroup (groupByPrimaryKey stdinTks) where @@ -2246,12 +2293,25 @@ -- so downstreams can keep packet provenance while merging certs. mergeGroup (base, rest) = let primary = certificatePrimaryFingerprint base - mergedStdin = foldl' (<>) base rest + mergedStdin = + case fromUnknownToTKEither + (foldl' (<>) (someTKToUnknown base) (map someTKToUnknown rest)) of + Right mergedStk -> mergedStk + Left _ -> base matchingMergeInputs = filter ((== primary) . certificatePrimaryFingerprint) mergeInTks - in foldl' (<>) mergedStdin matchingMergeInputs + mergedAll = + case fromUnknownToTKEither + ( foldl' + (<>) + (someTKToUnknown mergedStdin) + (map someTKToUnknown matchingMergeInputs) + ) of + Right mergedStk -> mergedStk + Left _ -> mergedStdin + in mergedAll -groupByPrimaryKey :: [TKUnknown] -> [(TKUnknown, [TKUnknown])] +groupByPrimaryKey :: [SomeTK] -> [(SomeTK, [SomeTK])] groupByPrimaryKey [] = [] groupByPrimaryKey (tk : rest) = let primary = certificatePrimaryFingerprint tk @@ -2259,12 +2319,17 @@ partition ((== primary) . certificatePrimaryFingerprint) rest in (tk, samePrimary) : groupByPrimaryKey differentPrimary -certificatePrimaryFingerprint :: TKUnknown -> B.ByteString +certificatePrimaryFingerprint :: SomeTK -> B.ByteString certificatePrimaryFingerprint = - BL.toStrict . unFingerprint . fingerprint . fst . _tkuKey + BL.toStrict + . unFingerprint + . fingerprint + . keyPktPKPayload + . _tkPrimaryKey + . someTKToPublicViewTK unlockUpdateKeyMaterial - :: String -> [BL.ByteString] -> TKUnknown -> IO TKUnknown + :: String -> [BL.ByteString] -> SomeTK -> IO SomeTK unlockUpdateKeyMaterial _ [] tk = pure tk unlockUpdateKeyMaterial source keyPasswords tk = unlockTransferableSecretKeyMaterial @@ -2274,7 +2339,7 @@ keyPasswords tk -updateKeyHasSigningCapability :: POSIXTime -> TKUnknown -> Bool +updateKeyHasSigningCapability :: POSIXTime -> SomeTK -> Bool updateKeyHasSigningCapability cpt tk = any ( \funKey -> @@ -2285,9 +2350,9 @@ selectUpdateMergeInputs :: POSIXTime -> Bool - -> TKUnknown - -> [TKUnknown] - -> [TKUnknown] + -> SomeTK + -> [SomeTK] + -> [SomeTK] selectUpdateMergeInputs cpt noAddedCaps targetTk updateTks = filteredByCaps where @@ -2460,7 +2525,7 @@ ) ] unhashed pkp = issuerSubpacketsFor "sign" pkp -loadSigningKeys :: [String] -> [BL.ByteString] -> IO [TKUnknown] +loadSigningKeys :: [String] -> [BL.ByteString] -> IO [SomeTK] loadSigningKeys keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles where loadFromFile path = do @@ -2469,8 +2534,8 @@ tks <- runConduitRes $ CL.sourceList packets - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList let fallbackTks = signingFallbackTKs packets when (null tks && null fallbackTks) $ @@ -2482,7 +2547,7 @@ (if null tks then fallbackTks else tks) decryptSigningKeyMaterial - :: FilePath -> [BL.ByteString] -> TKUnknown -> IO TKUnknown + :: FilePath -> [BL.ByteString] -> SomeTK -> IO SomeTK decryptSigningKeyMaterial path keyPasswords = unlockTransferableSecretKeyMaterial "sign failed" @@ -2495,27 +2560,35 @@ -> FilePath -> String -> [BL.ByteString] - -> TKUnknown - -> IO TKUnknown + -> 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 tk = do - keyPair' <- decryptSecretPart (_tkuKey tk) - subs' <- mapM decryptSub (_tkuSubs tk) - pure tk {_tkuKey = keyPair', _tkuSubs = subs'} +unlockTransferableSecretKeyMaterial context path passwordOption keyPasswords stk = do + 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 - decryptSecretPart (pkp, Just ska) = do - ska' <- - unlockSecretAddendum - context - path - passwordOption - keyPasswords - pkp - ska - pure (pkp, Just ska') - decryptSecretPart keyPair = pure keyPair - decryptSub (SecretSubkeyPkt pkp ska, sigs) = do + decryptSub :: MonadIO m => (KeyPkt k, b) -> m (KeyPkt k, b) + decryptSub (KeyPktSecretSubkey pkp ska, sigs) = do ska' <- unlockSecretAddendum context @@ -2524,17 +2597,18 @@ keyPasswords pkp ska - pure (SecretSubkeyPkt pkp ska', sigs) - decryptSub sub = pure sub + pure (KeyPktSecretSubkey pkp ska', sigs) + decryptSub other = pure other unlockSecretAddendum - :: String + :: MonadIO m + => String -> FilePath -> String -> [BL.ByteString] -> SomePKPayload -> SKAddendum - -> IO SKAddendum + -> m SKAddendum unlockSecretAddendum _ _ _ _ _ sk@(SUUnencrypted _ _) = pure sk unlockSecretAddendum context path passwordOption [] _ _ = failWith @@ -2565,7 +2639,7 @@ Left _ -> tryDecrypt rest Right decrypted -> Right decrypted -normalizeSigningKey :: POSIXTime -> TKUnknown -> IO TKUnknown +normalizeSigningKey :: POSIXTime -> SomeTK -> IO SomeTK normalizeSigningKey pt tk = case processTK (Just pt) tk of Left err -> @@ -2578,7 +2652,7 @@ :: POSIXTime -> AsBinaryText -> BL.ByteString - -> [TKUnknown] + -> [SomeTK] -> [HashAlgorithm] -> [HashAlgorithm] -> IO [SignaturePayload] @@ -2632,7 +2706,7 @@ ] unhashed pkp = issuerSubpacketsFor "encrypt" pkp -signingCapableFunKeys :: POSIXTime -> TKUnknown -> [FunKey] +signingCapableFunKeys :: POSIXTime -> SomeTK -> [FunKey] signingCapableFunKeys pt = filter canSign . tkToFunKeysAt pt where @@ -2649,7 +2723,7 @@ canSignDataUsage keyFlags = S.null keyFlags || S.member SignDataKey keyFlags -- Legacy alias kept for internal call sites that have not been updated. -signingCapableRSAFunKeys :: POSIXTime -> TKUnknown -> [FunKey] +signingCapableRSAFunKeys :: POSIXTime -> SomeTK -> [FunKey] signingCapableRSAFunKeys = signingCapableFunKeys {- | Algorithm-dispatching signature helper used by all sign paths. @@ -2681,34 +2755,34 @@ (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 + 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 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 + 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 Just (SUUnencrypted (UnknownSKey rawBytes) _) -> case () of _ @@ -2979,9 +3053,16 @@ hashAlgorithmMicalg SHA3_512 = Just "pgp-sha3-512" hashAlgorithmMicalg (OtherHA _) = Nothing -signingFallbackTKs :: [Pkt] -> [TKUnknown] +signingFallbackTKs :: [Pkt] -> [SomeTK] signingFallbackTKs packets = - [ TKUnknown (pkp, Just ska) [] [] [] [] + [ SomeSecretTK + TK + { _tkPrimaryKey = KeyPktSecretPrimary pkp ska + , _tkRevs = [] + , _tkUIDs = [] + , _tkUAts = [] + , _tkSubs = [] + } | SecretKeyPkt pkp ska <- packets ] @@ -2996,13 +3077,25 @@ } deriving (Show) -tkToFunKeysAt :: POSIXTime -> TKUnknown -> [FunKey] -tkToFunKeysAt pt tk@(TKUnknown (pkp, mska) _ uids _ subs) = - catMaybes (mainKey : map extract subs) +tkToFunKeysAt :: POSIXTime -> SomeTK -> [FunKey] +tkToFunKeysAt pt stk = + catMaybes + ( mainKey : case stk of + SomePublicTK _ -> map extractPublic (_tkSubs publicView) + SomeSecretTK secretTk -> map extractSecret (_tkSubs secretTk) + ) where - mainPreferredHashes = effectiveHashPreferencesAt pt tk - mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt tk - mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt tk + publicView = someTKToPublicViewTK stk + pkp = keyPktPKPayload (_tkPrimaryKey publicView) + mska = case stk of + SomeSecretTK secretTk -> case _tkPrimaryKey secretTk of + KeyPktSecretPrimary _ ska -> Just ska + _ -> Nothing + SomePublicTK _ -> Nothing + uids = _tkUIDs publicView + mainPreferredHashes = effectiveHashPreferencesAt pt stk + mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt stk + mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt stk mainKey = Just ( FunKey @@ -3023,57 +3116,60 @@ getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag) getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs getKUFs _ = Nothing - extract ((SecretSubkeyPkt spkp sska), sigs) = + extractPublic :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey + extractPublic (KeyPktPublicSubkey spkp, sigs) = return ( FunKey spkp - (Just sska) + Nothing (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs)) mainPreferredHashes mainPreferredSymmetricAlgorithms mainSupportsSEIPDv2 ) - extract ((PublicSubkeyPkt spkp), sigs) = + extractPublic _ = Nothing + extractSecret :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey + extractSecret (KeyPktSecretSubkey spkp sska, sigs) = return ( FunKey spkp - Nothing + (Just sska) (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs)) mainPreferredHashes mainPreferredSymmetricAlgorithms mainSupportsSEIPDv2 ) - extract _ = Nothing + extractSecret _ = Nothing effectiveHashPreferencesAt - :: POSIXTime -> TKUnknown -> [HashAlgorithm] + :: POSIXTime -> SomeTK -> [HashAlgorithm] effectiveHashPreferencesAt pt tk = concatMap toHashes $ fromMaybe [] ( effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) - tk + (someTKToUnknown tk) ) where toHashes (PreferredHashAlgorithms hashes) = hashes toHashes _ = [] effectiveSymmetricPreferencesAt - :: POSIXTime -> TKUnknown -> [SymmetricAlgorithm] + :: POSIXTime -> SomeTK -> [SymmetricAlgorithm] effectiveSymmetricPreferencesAt pt tk = concatMap toSymmetricAlgorithms $ fromMaybe [] ( effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) - tk + (someTKToUnknown tk) ) where toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms toSymmetricAlgorithms _ = [] -effectiveSEIPDv2SupportAt :: POSIXTime -> TKUnknown -> Bool +effectiveSEIPDv2SupportAt :: POSIXTime -> SomeTK -> Bool effectiveSEIPDv2SupportAt pt tk = any supportsSEIPDv2Flag $ concatMap toFeatureFlags $ @@ -3081,7 +3177,7 @@ [] ( effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) - tk + (someTKToUnknown tk) ) where toFeatureFlags (Features flags) = S.toList flags @@ -3208,7 +3304,7 @@ enforceVerificationSignerPolicy :: POSIXTime - -> [TKUnknown] + -> [SomeTK] -> Either String Verification -> Either String Verification enforceVerificationSignerPolicy _ _ result@(Left _) = result @@ -3230,7 +3326,12 @@ | not (keyMatchesFingerprint True tk signerFp) = False | keyMatchesFingerprint False tk signerFp = True | otherwise = - any (subkeyAllowsSigning verificationTime signerFp) (_tkuSubs tk) + any + (subkeyAllowsSigning verificationTime signerFp) + ( map + (\(kp, sigs) -> (keyPktToPkt kp, sigs)) + (_tkSubs (someTKToPublicViewTK tk)) + ) subkeyAllowsSigning :: UTCTime -> Fingerprint -> (Pkt, [SignaturePayload]) -> Bool @@ -3816,7 +3917,9 @@ && (fsupportsSEIPDv2 funkey || _keyVersion recipient == V6) in if _keyVersion recipient == V6 then - recipientEncryptionTargetWithStrategy recipient RecipientPreferV6 + recipientEncryptionTargetWithStrategyTyped + recipient + RecipientPreferV6W else case _pkalgo recipient of ECDH -> -- Under strict (SEIPDv2) mode, keep Curve25519-compatible v4 ECDH keys on @@ -3824,35 +3927,43 @@ if recipientNeedsV6PKESK then case normalizeX25519CompatibleECDHRecipient recipient of Just x25519Recipient -> - recipientEncryptionTargetWithStrategy + recipientEncryptionTargetWithStrategyTyped x25519Recipient - RecipientPreferV6 + RecipientPreferV6W Nothing -> - recipientEncryptionTargetWithStrategy recipient RecipientPreferV6 + recipientEncryptionTargetWithStrategyTyped + recipient + RecipientPreferV6W else - recipientEncryptionTargetWithStrategy + recipientEncryptionTargetWithStrategyTyped recipient - RecipientForceV3Interop + RecipientForceV3InteropW DeprecatedRSAEncryptOnly -> if recipientNeedsV6PKESK then - recipientEncryptionTargetWithStrategy recipient RecipientPreferV6 + recipientEncryptionTargetWithStrategyTyped + recipient + RecipientPreferV6W else - recipientEncryptionTargetWithStrategy + recipientEncryptionTargetWithStrategyTyped recipient - RecipientForceV3Interop + RecipientForceV3InteropW RSA -> if recipientNeedsV6PKESK then - recipientEncryptionTargetWithStrategy recipient RecipientPreferV6 + recipientEncryptionTargetWithStrategyTyped + recipient + RecipientPreferV6W else - recipientEncryptionTargetWithStrategy + recipientEncryptionTargetWithStrategyTyped recipient - RecipientForceV3Interop + RecipientForceV3InteropW _ -> if recipientNeedsV6PKESK then - recipientEncryptionTargetWithStrategy recipient RecipientPreferV6 + recipientEncryptionTargetWithStrategyTyped + recipient + RecipientPreferV6W else recipientEncryptionTarget recipient normalizeX25519CompatibleECDHRecipient pkp = @@ -4566,7 +4677,7 @@ (Nothing, Nothing) -> pure (Nothing, False) renderSOPVerificationLine - :: [TKUnknown] -> Verification -> String + :: [SomeTK] -> Verification -> String renderSOPVerificationLine verifyTks v = ts ++ " " ++ signerFp ++ " " ++ certFp ++ " " ++ modeLabel where @@ -4579,7 +4690,13 @@ case find (\tk -> keyMatchesFingerprint True tk signer) verifyTks of Just tk -> hexEncodeBytes - (BL.toStrict (unFingerprint (fingerprint (fst (_tkuKey tk))))) + ( BL.toStrict + ( unFingerprint + ( fingerprint + (keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk))) + ) + ) + ) Nothing -> signerFp signatureModeField :: SignaturePayload -> String @@ -4787,7 +4904,7 @@ (subcommand ++ ": output path already exists: " ++ path) loadVerifyContext - :: POSIXTime -> [String] -> IO (PublicKeyring, [TKUnknown]) + :: POSIXTime -> [String] -> IO (PublicKeyring, [SomeTK]) loadVerifyContext _ certFiles = do allTks <- mapMaybe enforceVerifyPrimaryKeyPolicy @@ -4797,34 +4914,34 @@ let publicTks = mapMaybe ( \tk -> - case fromUnknownToTK tk of - Right (SomePublicTK publicTk) -> Just publicTk - _ -> Nothing + case tk of + SomePublicTK publicTk -> Just publicTk + SomeSecretTK secretTk -> Just (publicViewTK secretTk) ) allTks keyring <- runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap pure (keyring, allTks) -loadVerifyTKsFromFile :: String -> IO [TKUnknown] +loadVerifyTKsFromFile :: String -> IO [SomeTK] loadVerifyTKsFromFile path = do lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy certPkts <- decodeOpenPGPInput path lbs runConduitRes $ CL.sourceList certPkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList -loadCertTKsFromFile :: String -> String -> IO [TKUnknown] +loadCertTKsFromFile :: String -> String -> IO [SomeTK] loadCertTKsFromFile context path = do lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy certPkts <- decodeOpenPGPInput path lbs rejectSecretKeyPackets context path certPkts runConduitRes $ CL.sourceList certPkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList rejectSecretKeyPackets :: String -> String -> [Pkt] -> IO () @@ -4841,52 +4958,59 @@ isSecretKeyPacket SecretSubkeyPkt {} = True isSecretKeyPacket _ = False -sanitizeVerifyTK :: TKUnknown -> TKUnknown -sanitizeVerifyTK tk = - case primaryKeyIdentity (_tkuKey tk) of - Nothing -> tk - Just (primaryFp, primaryKeyId) -> - tk - { _tkuSubs = - map - ( \(pkt, sigs) -> - let sanitized = - mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs - in if isSubkeyPacket pkt - then (pkt, sanitized) - else (pkt, sigs) - ) - (_tkuSubs tk) - } +sanitizeVerifyTK :: SomeTK -> SomeTK +sanitizeVerifyTK stk = + case primaryKeyIdentity stk of + Nothing -> stk + Just _ -> + case stk of + SomePublicTK tk -> SomePublicTK tk {_tkSubs = map sanitize (_tkSubs tk)} + SomeSecretTK tk -> SomeSecretTK tk {_tkSubs = map sanitize (_tkSubs tk)} where - isSubkeyPacket PublicSubkeyPkt {} = True - isSubkeyPacket SecretSubkeyPkt {} = True + publicView = someTKToPublicViewTK stk + pkp = keyPktPKPayload (_tkPrimaryKey publicView) + primaryFp = fingerprint pkp + primaryKeyId = + either + (error "sanitizeVerifyTK: no key ID") + id + (eightOctetKeyID pkp) + sanitize + :: (KeyPkt k, [SignaturePayload]) -> (KeyPkt k, [SignaturePayload]) + sanitize (kp, sigs) = + let sanitized = + mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs + in if isSubkeyPacket (keyPktToPkt kp) + then (kp, sanitized) + else (kp, sigs) + isSubkeyPacket (PublicSubkeyPkt {}) = True + isSubkeyPacket (SecretSubkeyPkt {}) = True isSubkeyPacket _ = False -enforceVerifyPrimaryKeyPolicy :: TKUnknown -> Maybe TKUnknown +enforceVerifyPrimaryKeyPolicy :: SomeTK -> Maybe SomeTK enforceVerifyPrimaryKeyPolicy tk = - if primaryKeyTooSmallForVerification (_tkuKey tk) + if primaryKeyTooSmallForVerification tk then Nothing else Just tk -primaryKeyTooSmallForVerification - :: (SomePKPayload, Maybe SKAddendum) -> Bool -primaryKeyTooSmallForVerification (pkp, _) = +primaryKeyTooSmallForVerification :: SomeTK -> Bool +primaryKeyTooSmallForVerification stk = case _pkalgo pkp of RSA -> rsaTooSmall DeprecatedRSASignOnly -> rsaTooSmall DeprecatedRSAEncryptOnly -> rsaTooSmall _ -> False where + pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk)) rsaTooSmall = case pubkeySize (_pubkey pkp) of Right bits -> bits < 2048 Left _ -> False primaryKeyIdentity - :: (SomePKPayload, Maybe SKAddendum) - -> Maybe (Fingerprint, EightOctetKeyId) -primaryKeyIdentity (pkp, _) = do + :: SomeTK -> Maybe (Fingerprint, EightOctetKeyId) +primaryKeyIdentity stk = do + let pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk)) keyId <- either (const Nothing) Just (eightOctetKeyID pkp) pure (fingerprint pkp, keyId) @@ -4963,8 +5087,8 @@ tks <- runConduitRes $ CL.sourceList packets - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList let normTks = rights (map (processTK (Just cpt)) tks) let tkDerived = S.fromList (concatMap nonEncryptionFingerprints normTks) @@ -4973,18 +5097,19 @@ nonEncryptionFingerprints tk = -- Primary key: add to blocklist only if explicit key-flags are present -- and all of them exclude encryption usage. - let (primaryPkp, _) = _tkuKey tk + let primaryPkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk)) primaryFp = unFingerprint (fingerprint primaryPkp) + publicView = someTKToPublicViewTK tk primarySigs = - concatMap snd (_tkuUIDs tk) - ++ concatMap snd (_tkuUAts tk) - ++ _tkuRevs tk + concatMap snd (_tkUIDs publicView) + ++ concatMap snd (_tkUAts publicView) + ++ _tkRevs publicView primaryEntry = [primaryFp | not (sigsAllowEncryption primarySigs)] -- Subkeys: same rule as primary. subEntries = [ unFingerprint (fingerprint pkp) - | (pkt, sigs) <- _tkuSubs tk - , Just pkp <- [secretOrPublicSubkeyPayload pkt] + | (kp, sigs) <- _tkSubs publicView + , let pkp = keyPktPKPayload kp , not (sigsAllowEncryption sigs) ] blocked = primaryEntry ++ subEntries @@ -5028,23 +5153,22 @@ | sawKeyFlags && not hasEnc = fp : blocked | otherwise = blocked tkHasAnyEncryptionCapableKey tk = - let (primaryPkp, _) = _tkuKey tk + let primaryPkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk)) + publicView = someTKToPublicViewTK tk primarySigs = - concatMap snd (_tkuUIDs tk) - ++ concatMap snd (_tkuUAts tk) - ++ _tkuRevs tk + concatMap snd (_tkUIDs publicView) + ++ concatMap snd (_tkUAts publicView) + ++ _tkRevs publicView primaryAllows = supportsRecipientPKESKAlgorithm primaryPkp && sigsAllowEncryption primarySigs subAllows = any - ( \(pkt, sigs) -> - case secretOrPublicSubkeyPayload pkt of - Just pkp -> - supportsRecipientPKESKAlgorithm pkp && sigsAllowEncryption sigs - Nothing -> False + ( \(kp, sigs) -> + supportsRecipientPKESKAlgorithm (keyPktPKPayload kp) + && sigsAllowEncryption sigs ) - (_tkuSubs tk) + (_tkSubs publicView) in primaryAllows || subAllows sigsAllowEncryption [] = True sigsAllowEncryption sigs = @@ -5079,9 +5203,6 @@ [ flags | SigSubPacket _ (KeyFlags flags) <- subpackets ] - secretOrPublicSubkeyPayload (SecretSubkeyPkt pkp _) = Just pkp - secretOrPublicSubkeyPayload (PublicSubkeyPkt pkp) = Just pkp - secretOrPublicSubkeyPayload _ = Nothing packetRecipientKey path nonEncFps (SecretKeyPkt pkp ska) = let fp = unFingerprint (fingerprint pkp) in if S.member fp nonEncFps @@ -5214,8 +5335,8 @@ tks <- runConduitRes $ CL.sourceList pkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList normalized <- mapM (normalizeRecipient path) tks pure @@ -5251,8 +5372,8 @@ tks <- runConduitRes $ CL.sourceList pkts - .| conduitToTKsDroppingEither - .| CL.mapFoldable (join . hush) + .| conduitToSomeTKsDroppingEither + .| conduitDropErrorsAndNothings .| CC.sinkList normalized <- mapM (normalizeEncryptRecipientTK path) tks let selected = @@ -5281,7 +5402,10 @@ ) Right normalized -> if not - (isTKTimeValid (posixSecondsToUTCTime (realToFrac cpt)) normalized) + ( isTKTimeValid + (posixSecondsToUTCTime (realToFrac cpt)) + (someTKToUnknown normalized) + ) then failWith CertCannotEncrypt @@ -5326,7 +5450,7 @@ isForwardCompatRecipientPacketTag tag = tag `elem` [5, 6, 7, 14] payloadToFunKey pkp = FunKey pkp Nothing S.empty [] [] False -primaryUserIDExpirationAllowsAt :: POSIXTime -> TKUnknown -> Bool +primaryUserIDExpirationAllowsAt :: POSIXTime -> SomeTK -> Bool primaryUserIDExpirationAllowsAt now tk = case primaryUidSigs of [] -> True @@ -5335,10 +5459,13 @@ (signatureKeyExpirationAllowsAt now primaryCreatedAt) primaryUidSigs where - primaryCreatedAt = fromIntegral (_timestamp (fst (_tkuKey tk))) + publicView = someTKToPublicViewTK tk + primaryCreatedAt = + fromIntegral + (_timestamp (keyPktPKPayload (_tkPrimaryKey publicView))) primaryUidSigs = [ sig - | (_, sigs) <- _tkuUIDs tk + | (_, sigs) <- _tkUIDs publicView , sig <- sigs , signatureMarksPrimaryUserId sig ] @@ -5379,15 +5506,11 @@ | null matchingPurpose -> unrestrictedPurpose _ -> matchingPurpose -tkToEncryptPayloads :: TKUnknown -> [SomePKPayload] -tkToEncryptPayloads (TKUnknown (pkp, _) _ _ _ subs) = +tkToEncryptPayloads :: SomeTK -> [SomePKPayload] +tkToEncryptPayloads stk = filter supportsRecipientPKESKAlgorithm - (pkp : mapMaybe extractSubkeyPayload subs) - where - extractSubkeyPayload (PublicSubkeyPkt subPkp, _) = Just subPkp - extractSubkeyPayload (SecretSubkeyPkt subPkp _, _) = Just subPkp - extractSubkeyPayload _ = Nothing + (someTKToUnknown stk ^.. biplate :: [SomePKPayload]) extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload extractEncryptRecipientPayload pkt = 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 +version: 0.25.3.1 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.1 && < 3.2 + , hOpenPGP >= 3.1.1 && < 3.2 , lens , optparse-applicative >= 0.18.1 , prettyprinter >= 1.7 @@ -83,6 +83,7 @@ main-is: hkt.hs other-modules: HOpenPGP.Tools.Common.Lexer , HOpenPGP.Tools.Common.Parser + , HOpenPGP.Tools.Common.TKUtils build-depends: array , containers , conduit-extra >= 1.1 @@ -129,4 +130,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hopenpgp-tools.git - tag: hopenpgp-tools/0.25.3 + tag: hopenpgp-tools/0.25.3.1