hopenpgp-tools 0.25.3 → 0.25.3.1
raw patch · 10 files changed
+791/−548 lines, 10 filesdep ~hOpenPGP
Dependency ranges changed: hOpenPGP
Files
- HOpenPGP/Tools/Common/Common.hs +130/−96
- HOpenPGP/Tools/Common/HKP.hs +22/−11
- HOpenPGP/Tools/Common/Parser.y +1/−1
- HOpenPGP/Tools/Common/TKUtils.hs +57/−30
- HOpenPGP/Tools/Common/WKD.hs +22/−16
- HOpenPGP/Tools/Hokey/Canonicalize.hs +21/−10
- HOpenPGP/Tools/Hokey/Lint.hs +31/−25
- hkt.hs +88/−64
- hop.hs +415/−292
- hopenpgp-tools.cabal +4/−3
HOpenPGP/Tools/Common/Common.hs view
@@ -17,123 +17,152 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. 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
HOpenPGP/Tools/Common/HKP.hs view
@@ -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
HOpenPGP/Tools/Common/Parser.y view
@@ -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)
HOpenPGP/Tools/Common/TKUtils.hs view
@@ -15,9 +15,9 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>.- 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
HOpenPGP/Tools/Common/WKD.hs view
@@ -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)
HOpenPGP/Tools/Hokey/Canonicalize.hs view
@@ -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
HOpenPGP/Tools/Hokey/Lint.hs view
@@ -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
hkt.hs view
@@ -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
hop.hs view
@@ -15,7 +15,9 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>.+{-# 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 =
hopenpgp-tools.cabal view
@@ -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