hopenpgp-tools 0.25.1 → 0.25.2
raw patch · 12 files changed
+8457/−6723 lines, 12 files
Files
- HOpenPGP/Tools/Common/HKP.hs +77/−68
- HOpenPGP/Tools/Common/TKUtils.hs +43/−39
- HOpenPGP/Tools/Common/WKD.hs +127/−99
- HOpenPGP/Tools/Hokey/Canonicalize.hs +25/−22
- HOpenPGP/Tools/Hokey/Fetch.hs +22/−20
- HOpenPGP/Tools/Hokey/InjectSSHAgent.hs +324/−229
- HOpenPGP/Tools/Hokey/Lint.hs +939/−693
- HOpenPGP/Tools/Hokey/Options.hs +113/−86
- hkt.hs +541/−385
- hop.hs +6054/−4926
- hopenpgp-tools.cabal +2/−2
- hot.hs +190/−154
HOpenPGP/Tools/Common/HKP.hs view
@@ -15,112 +15,121 @@ -- -- 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 OverloadedStrings #-} module HOpenPGP.Tools.Common.HKP- ( fetchKeys- , FetchValidationMethod(..)- , rearmorKeys- ) where+ ( fetchKeys+ , FetchValidationMethod (..)+ , rearmorKeys+ ) where import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA import Codec.Encryption.OpenPGP.ASCIIArmor.Types- ( Armor(Armor)- , ArmorType(ArmorPublicKeyBlock)- )+ ( Armor (Armor)+ , ArmorType (ArmorPublicKeyBlock)+ ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Types- ( Block(..)- , TKUnknown(..)- , Fingerprint- )-import Control.Applicative (liftA2)+ ( Block (..)+ , Fingerprint+ , TKUnknown (..)+ ) import Control.Arrow ((&&&)) import Control.Lens ((^..)) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Except (ExceptT(..), throwE)+import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Binary (get, put) import Data.Binary.Put (runPut) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL-import Data.Conduit ((.|), runConduitRes)+import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Data.Lens (biplate) import Data.Either (rights)-import Data.Monoid ((<>), mempty) import Data.Time.Clock.POSIX (getPOSIXTime)-import HOpenPGP.Tools.Common.TKUtils (processTK) import Network.HTTP.Client- ( Response(..)- , httpLbs- , newManager- , parseUrlThrow- , setQueryString- )+ ( Response (..)+ , httpLbs+ , newManager+ , parseUrlThrow+ , setQueryString+ ) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status (ok200) import Prettyprinter (pretty) +import HOpenPGP.Tools.Common.TKUtils (processTK)+ data FetchValidationMethod- = MatchPrimaryKeyFingerprint- | MatchPrimaryOrAnySubkeyFingerprint- | AnySelfSigned- deriving (Bounded, Enum, Eq, Read, Show)+ = MatchPrimaryKeyFingerprint+ | MatchPrimaryOrAnySubkeyFingerprint+ | AnySelfSigned+ deriving (Bounded, Enum, Eq, Read, Show) -fetchKeys ::- String- -> FetchValidationMethod- -> Fingerprint- -> ExceptT String IO [TKUnknown]+fetchKeys+ :: String+ -> FetchValidationMethod+ -> Fingerprint+ -> ExceptT String IO [TKUnknown] fetchKeys ks fvm q = do- manager <- liftIO $ newManager tlsManagerSettings- request <- liftIO $ parseUrlThrow (ks <> basereq)- let newreq = setQueryString (newqs q) request- response <- liftIO $ httpLbs newreq manager- processedKeys <-- if responseStatus response == ok200- then validateKeys (responseBody response)- else throwE ("HTTP status: " ++ show (responseStatus response))- return $ map fst $ filter (fvp fvm . fst . _tkuKey . snd) processedKeys+ manager <- liftIO $ newManager tlsManagerSettings+ request <- liftIO $ parseUrlThrow (ks <> basereq)+ let newreq = setQueryString (newqs q) request+ response <- liftIO $ httpLbs newreq manager+ processedKeys <-+ if responseStatus response == ok200+ then validateKeys (responseBody response)+ else throwE ("HTTP status: " ++ show (responseStatus response))+ return $+ map fst $+ filter (fvp fvm . fst . _tkuKey . snd) processedKeys where fvp MatchPrimaryKeyFingerprint k = fingerprint k == q- fvp MatchPrimaryOrAnySubkeyFingerprint k =- any (\k -> fingerprint k == q) (k ^.. biplate)- fvp AnySelfSigned k = True+ fvp MatchPrimaryOrAnySubkeyFingerprint k' =+ any (\k'' -> fingerprint k'' == q) (k' ^.. biplate)+ fvp AnySelfSigned _ = True basereq = "/pks/lookup"- newqs q =- [ ("op", Just "get")- , ("options", Just "mr")- , ("exact", Just "on")- , ("search", Just (BC8.pack ("0x" <> show (pretty q)))) -- FIXME: butter- ]+ newqs q' =+ [ ("op", Just "get")+ , ("options", Just "mr")+ , ("exact", Just "on")+ , ("search", Just (BC8.pack ("0x" <> show (pretty q')))) -- FIXME: butter+ ] -validateKeys :: BL.ByteString -> ExceptT String IO [(TKUnknown, TKUnknown)] -- FIXME: conduit fail+validateKeys+ :: BL.ByteString -> ExceptT String IO [(TKUnknown, TKUnknown)] -- FIXME: conduit fail validateKeys larmors = do- bytestrings <-- ExceptT $ return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)- keys <-- liftIO . runConduitRes $- CB.sourceLbs bytestrings .| conduitGet get .| conduitToTKsDropping .|- CL.consume- cpt <- liftIO getPOSIXTime- return . rights $- map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys+ bytestrings <-+ ExceptT $+ return $+ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)+ keys <-+ liftIO . runConduitRes $+ CB.sourceLbs bytestrings+ .| conduitGet get+ .| conduitToTKsDroppingEither+ .| CL.mapMaybe (either (const Nothing) id)+ .| CL.consume+ cpt <- liftIO getPOSIXTime+ return . rights $+ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys where armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs armorToBS _ = mempty rearmorKeys :: [TKUnknown] -> B.ByteString rearmorKeys keys =- if null keys- then mempty- else AA.encode .- return .- Armor ArmorPublicKeyBlock [("Comment", "filtered by hokey")] .- runPut . put . Block $- keys+ if null keys+ then mempty+ else+ AA.encode+ . return+ . Armor ArmorPublicKeyBlock [("Comment", "filtered by hokey")]+ . runPut+ . put+ . Block+ $ keys
HOpenPGP/Tools/Common/TKUtils.hs view
@@ -17,16 +17,18 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. module HOpenPGP.Tools.Common.TKUtils- ( processTK- ) where+ ( processTK+ ) where -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)+import Codec.Encryption.OpenPGP.Fingerprint+ ( eightOctetKeyID+ , fingerprint+ ) import Codec.Encryption.OpenPGP.Signatures- ( VerificationError- , verifyAgainstKeys- , verifySigWith- , verifyUnknownTKWith- )+ ( verifyAgainstKeys+ , verifySigWith+ , verifyUnknownTKWith+ ) import Codec.Encryption.OpenPGP.Types import Control.Arrow (second) import Control.Error.Util (hush)@@ -34,58 +36,60 @@ import Data.Bifunctor (first) import Data.List (sortOn) import Data.Maybe (listToMaybe, mapMaybe)-import Data.Ord (Down(..))+import Data.Ord (Down (..)) import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) -- should this fail or should verifyUnknownTKWith fail if there are no self-sigs?-processTK :: Maybe POSIXTime -> TKUnknown -> Either String TKUnknown-processTK mpt key =- first show $ verifyUnknownTKWith- (verifySigWith (verifyAgainstKeys [key]))- (fmap posixSecondsToUTCTime mpt) .- stripOlderSigs .- stripOtherSigs $- key+processTK+ :: Maybe POSIXTime -> TKUnknown -> Either String TKUnknown+processTK mpt tk =+ first show+ $ verifyUnknownTKWith+ (verifySigWith (verifyAgainstKeys [tk]))+ (fmap posixSecondsToUTCTime mpt)+ . stripOlderSigs+ . stripOtherSigs+ $ tk where- stripOtherSigs tk =- tk- { _tkuUIDs = map (second alleged) (_tkuUIDs tk)- , _tkuUAts = map (second alleged) (_tkuUAts tk)- }- stripOlderSigs tk =- tk- { _tkuUIDs = map (second newest) (_tkuUIDs tk)- , _tkuUAts = map (second newest) (_tkuUAts tk)- }+ stripOtherSigs tk' =+ tk'+ { _tkuUIDs = map (second alleged) (_tkuUIDs tk')+ , _tkuUAts = map (second alleged) (_tkuUAts tk')+ }+ stripOlderSigs tk' =+ tk'+ { _tkuUIDs = map (second newest) (_tkuUIDs tk')+ , _tkuUAts = map (second newest) (_tkuUAts tk')+ } newest = take 1 . sortOn (Down . take 1 . sigcts) -- FIXME: this is terrible sigcts (SigV4 _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs sigcts (SigV6 _ _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs sigcts _ = []- pkp = key ^. tkuKey . _1+ pkp = tk ^. tkuKey . _1 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) -- FIXME: what should this be if there are multiple matches? sigissuer (SigV6 _ _ _ _ ys xs _ _) =- listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?+ listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches? sigissuer (SigVOther _ _) = 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) -- FIXME: what should this be if there are multiple matches? 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) -- FIXME: what should this be if there are multiple matches? sigissuerfp _ = Nothing eoki- | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp- | _keyVersion pkp == DeprecatedV3 &&- elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =- hush . eightOctetKeyID $ pkp- | otherwise = Nothing+ | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp+ | _keyVersion pkp == DeprecatedV3+ && elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =+ hush . eightOctetKeyID $ pkp+ | otherwise = Nothing fp- | _keyVersion pkp == V4 = Just . fingerprint $ pkp- | otherwise = Nothing+ | _keyVersion pkp == V4 = Just . fingerprint $ pkp+ | otherwise = Nothing getIssuer (Issuer i) = Just i getIssuer _ = Nothing getIssuerFP (IssuerFingerprint IssuerFingerprintV4 i) = Just i
HOpenPGP/Tools/Common/WKD.hs view
@@ -15,35 +15,34 @@ -- -- 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 OverloadedStrings #-} module HOpenPGP.Tools.Common.WKD- ( fetchKeys- , parseMailbox- ) where+ ( fetchKeys+ , parseMailbox+ ) where import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA import Codec.Encryption.OpenPGP.ASCIIArmor.Types- ( Armor(Armor)- , ArmorType(ArmorPublicKeyBlock)- )-import Codec.Encryption.OpenPGP.Types (TKUnknown(..))+ ( Armor (Armor)+ , ArmorType (ArmorPublicKeyBlock)+ )+import Codec.Encryption.OpenPGP.Types (TKUnknown (..)) import Control.Arrow ((&&&)) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Except (ExceptT(..), throwE)+import Control.Monad.Trans.Except (ExceptT (..), throwE) import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHA import Data.Binary (get)+import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL-import Data.Bits ((.&.), (.|.), shiftL, shiftR)-import Data.Conduit ((.|), runConduitRes)+import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Either (rights) import Data.Text (Text)@@ -51,116 +50,144 @@ import qualified Data.Text.Encoding as TE import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word8)-import HOpenPGP.Tools.Common.HKP (FetchValidationMethod(..))-import HOpenPGP.Tools.Common.TKUtils (processTK) import Network.HTTP.Client- ( Manager- , Response(..)- , httpLbs- , newManager- , parseUrlThrow- , setQueryString- )+ ( Manager+ , Response (..)+ , httpLbs+ , newManager+ , parseUrlThrow+ , setQueryString+ ) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status (ok200) -fetchKeys ::- FetchValidationMethod- -> Text- -> ExceptT String IO [TKUnknown]+import HOpenPGP.Tools.Common.HKP (FetchValidationMethod (..))+import HOpenPGP.Tools.Common.TKUtils (processTK)++fetchKeys+ :: FetchValidationMethod+ -> Text+ -> ExceptT String IO [TKUnknown] fetchKeys fvm mailbox = do- parsedMailbox <- ExceptT . return $ parseMailbox mailbox- manager <- liftIO $ newManager tlsManagerSettings- response <- fetchWKD manager parsedMailbox- body <-- if responseStatus response == ok200- then return (responseBody response)- else throwE ("HTTP status: " ++ show (responseStatus response))- validateAndFilterKeys fvm parsedMailbox body+ parsedMailbox <- ExceptT . return $ parseMailbox mailbox+ manager <- liftIO $ newManager tlsManagerSettings+ response <- fetchWKD manager parsedMailbox+ body <-+ if responseStatus response == ok200+ then return (responseBody response)+ else throwE ("HTTP status: " ++ show (responseStatus response))+ validateAndFilterKeys fvm parsedMailbox body parseMailbox :: Text -> Either String (Text, Text) parseMailbox rawMailbox =- let mailbox = T.strip rawMailbox- parts = T.splitOn "@" mailbox- in case parts of- [localPart, domain]- | T.null localPart -> Left "mailbox local part cannot be empty"- | T.null domain -> Left "mailbox domain cannot be empty"- | T.any (== ' ') mailbox -> Left "mailbox cannot contain spaces"- | otherwise -> Right (localPart, T.toLower domain)- _ -> Left "mailbox must contain exactly one @"+ let mailbox = T.strip rawMailbox+ parts = T.splitOn "@" mailbox+ in case parts of+ [localPart, domain]+ | T.null localPart -> Left "mailbox local part cannot be empty"+ | T.null domain -> Left "mailbox domain cannot be empty"+ | T.any (== ' ') mailbox -> Left "mailbox cannot contain spaces"+ | otherwise -> Right (localPart, T.toLower domain)+ _ -> Left "mailbox must contain exactly one @" -fetchWKD ::- Manager- -> (Text, Text)- -> ExceptT String IO (Response BL.ByteString)+fetchWKD+ :: Manager+ -> (Text, Text)+ -> ExceptT String IO (Response BL.ByteString) fetchWKD manager (localPart, domain) = do- let localPartLower = T.toLower localPart- hu = BC8.unpack . zbase32 . sha1 . TE.encodeUtf8 $ localPartLower- advancedUrl =- "https://openpgpkey." <>- T.unpack domain <>- "/.well-known/openpgpkey/" <> T.unpack domain <> "/hu/" <> hu- directUrl =- "https://" <> T.unpack domain <> "/.well-known/openpgpkey/hu/" <> hu- mailboxParam = TE.encodeUtf8 localPartLower- withMailbox req = setQueryString [("l", Just mailboxParam)] req- advancedRequest <- liftIO $ parseUrlThrow advancedUrl- advancedResponse <- liftIO $ httpLbs (withMailbox advancedRequest) manager- if responseStatus advancedResponse == ok200- then return advancedResponse- else do- directRequest <- liftIO $ parseUrlThrow directUrl- liftIO $ httpLbs (withMailbox directRequest) manager+ let localPartLower = T.toLower localPart+ hu = BC8.unpack . zbase32 . sha1 . TE.encodeUtf8 $ localPartLower+ advancedUrl =+ "https://openpgpkey."+ <> T.unpack domain+ <> "/.well-known/openpgpkey/"+ <> T.unpack domain+ <> "/hu/"+ <> hu+ directUrl =+ "https://"+ <> T.unpack domain+ <> "/.well-known/openpgpkey/hu/"+ <> hu+ mailboxParam = TE.encodeUtf8 localPartLower+ withMailbox req = setQueryString [("l", Just mailboxParam)] req+ advancedRequest <- liftIO $ parseUrlThrow advancedUrl+ advancedResponse <-+ liftIO $ httpLbs (withMailbox advancedRequest) manager+ if responseStatus advancedResponse == ok200+ then return advancedResponse+ else do+ directRequest <- liftIO $ parseUrlThrow directUrl+ liftIO $ httpLbs (withMailbox directRequest) manager -validateAndFilterKeys ::- FetchValidationMethod- -> (Text, Text)- -> BL.ByteString- -> ExceptT String IO [TKUnknown]+validateAndFilterKeys+ :: FetchValidationMethod+ -> (Text, Text)+ -> BL.ByteString+ -> ExceptT String IO [TKUnknown] validateAndFilterKeys fvm mailbox body = do- keys <- decodeWkdResponse body- cpt <- liftIO getPOSIXTime- let processedKeys = rights $ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys- mailboxFiltered = filter (mailboxMatchesKey mailbox . snd) processedKeys- return $- map fst $- case fvm of- AnySelfSigned -> processedKeys- MatchPrimaryKeyFingerprint -> mailboxFiltered- MatchPrimaryOrAnySubkeyFingerprint -> mailboxFiltered+ keys <- decodeWkdResponse body+ cpt <- liftIO getPOSIXTime+ let processedKeys =+ rights $+ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys+ mailboxFiltered = filter (mailboxMatchesKey mailbox . snd) processedKeys+ return $+ map fst $+ case fvm of+ AnySelfSigned -> processedKeys+ MatchPrimaryKeyFingerprint -> mailboxFiltered+ MatchPrimaryOrAnySubkeyFingerprint -> mailboxFiltered -decodeWkdResponse :: BL.ByteString -> ExceptT String IO [TKUnknown]+decodeWkdResponse+ :: BL.ByteString -> ExceptT String IO [TKUnknown] decodeWkdResponse body =- if isArmored body- then decodeArmored body- else decodeBinary body+ if isArmored body+ then decodeArmored body+ else decodeBinary body decodeBinary :: BL.ByteString -> ExceptT String IO [TKUnknown] decodeBinary bytes =- liftIO . runConduitRes $- CB.sourceLbs bytes .| conduitGet get .| conduitToTKsDropping .| CL.consume+ liftIO . runConduitRes $+ CB.sourceLbs bytes+ .| conduitGet get+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable id+ .| CL.mapMaybe id+ .| CL.consume decodeArmored :: BL.ByteString -> ExceptT String IO [TKUnknown] decodeArmored larmors = do- bytestrings <- ExceptT . return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)- liftIO . runConduitRes $- CB.sourceLbs bytestrings .| conduitGet get .| conduitToTKsDropping .| CL.consume+ bytestrings <-+ ExceptT . return $+ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)+ liftIO . runConduitRes $+ CB.sourceLbs bytestrings+ .| conduitGet get+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable id+ .| CL.mapMaybe id+ .| CL.consume where armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs armorToBS _ = mempty isArmored :: BL.ByteString -> Bool isArmored =- BC8.isPrefixOf "-----BEGIN PGP PUBLIC KEY BLOCK-----" . BL.toStrict . BL.take 40+ BC8.isPrefixOf "-----BEGIN PGP PUBLIC KEY BLOCK-----"+ . BL.toStrict+ . BL.take 40 mailboxMatchesKey :: (Text, Text) -> TKUnknown -> Bool mailboxMatchesKey (localPart, domain) tk =- let mailbox = T.toLower (localPart <> "@" <> domain)- bracketedMailbox = "<" <> mailbox <> ">"- in any- (\uid -> let lowered = T.toLower uid in lowered == mailbox || bracketedMailbox `T.isInfixOf` lowered)- (map fst (_tkuUIDs tk))+ let mailbox = T.toLower (localPart <> "@" <> domain)+ bracketedMailbox = "<" <> mailbox <> ">"+ in any+ ( \uid ->+ let lowered = T.toLower uid+ in lowered == mailbox || bracketedMailbox `T.isInfixOf` lowered+ )+ (map fst (_tkuUIDs tk)) sha1 :: B.ByteString -> B.ByteString sha1 bs = BA.convert (CH.hashWith CHA.SHA1 bs :: CH.Digest CHA.SHA1)@@ -175,9 +202,10 @@ pick i = alphabet !! i go _ 0 [] = [] go acc bits [] =- [pick (fromIntegral (((acc `shiftL` (5 - bits)) .&. 31) :: Int))]- go acc bits (x:xs)- | bits >= 5 =- pick (fromIntegral (((acc `shiftR` (bits - 5)) .&. 31) :: Int)) :- go acc (bits - 5) (x : xs)- | otherwise = go ((acc `shiftL` 8) .|. fromIntegral x) (bits + 8) xs+ [pick (fromIntegral (((acc `shiftL` (5 - bits)) .&. 31) :: Int))]+ go acc bits (x : xs)+ | bits >= 5 =+ pick (fromIntegral (((acc `shiftR` (bits - 5)) .&. 31) :: Int))+ : go acc (bits - 5) (x : xs)+ | otherwise =+ go ((acc `shiftL` 8) .|. fromIntegral x) (bits + 8) xs
HOpenPGP/Tools/Hokey/Canonicalize.hs view
@@ -17,41 +17,44 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. module HOpenPGP.Tools.Hokey.Canonicalize- (- doCanonicalize- ) where+ ( doCanonicalize+ ) where import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types-import Control.Lens (_2, mapped, over)+import Control.Error.Util (hush)+import Control.Lens (mapped, over, _2)+import Control.Monad (join) import Data.Binary (get, put)-import Data.Conduit ((.|), runConduitRes)+import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither) import Data.Conduit.Serialization.Binary (conduitGet, conduitPut) import Data.List (nub, sort)- import System.IO- ( stdin- , stdout- )+ ( stdin+ , stdout+ ) doCanonicalize :: IO () doCanonicalize =- runConduitRes $ CB.sourceHandle stdin .| conduitGet get .|- conduitToTKsDropping .|- CL.map canonicalize .|- CL.map put .|- conduitPut .|- CB.sinkHandle stdout+ runConduitRes $+ CB.sourceHandle stdin+ .| conduitGet get+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CL.map canonicalize+ .| CL.map put+ .| conduitPut+ .| CB.sinkHandle stdout where canonicalize tk =- tk- { _tkuRevs = sort (_tkuRevs tk)- , _tkuUIDs = indepthsort (_tkuUIDs tk)- , _tkuUAts = indepthsort (_tkuUAts tk)- , _tkuSubs = indepthsort (_tkuSubs tk)- }+ tk+ { _tkuRevs = sort (_tkuRevs tk)+ , _tkuUIDs = indepthsort (_tkuUIDs tk)+ , _tkuUAts = indepthsort (_tkuUAts tk)+ , _tkuSubs = indepthsort (_tkuSubs tk)+ } indepthsort :: (Ord a, Ord b) => [(a, [b])] -> [(a, [b])] indepthsort = nub . sort . over (mapped . _2) sort
HOpenPGP/Tools/Hokey/Fetch.hs view
@@ -17,34 +17,36 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. module HOpenPGP.Tools.Hokey.Fetch- (- doFetch- ) where+ ( doFetch+ ) where import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) import Codec.Encryption.OpenPGP.Serialize ()-import Control.Monad.Trans.Except (ExceptT(..), runExceptT)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import qualified Data.ByteString as B import qualified Data.Text as T+import System.IO+ ( hPutStrLn+ , stderr+ )+ import HOpenPGP.Tools.Common.HKP (rearmorKeys) import qualified HOpenPGP.Tools.Common.HKP as HKP import qualified HOpenPGP.Tools.Common.WKD as WKD-import HOpenPGP.Tools.Hokey.Options (FetchOptions(..), FetchMethod(..))--import System.IO- ( hPutStrLn- , stderr- )+import HOpenPGP.Tools.Hokey.Options+ ( FetchMethod (..)+ , FetchOptions (..)+ ) doFetch :: FetchOptions -> IO () doFetch o = do- ekeys <-- runExceptT $- case fetchMethod o of- HKP -> do- fp <- ExceptT . return . parseFingerprint . T.pack $ fetchQuery o- HKP.fetchKeys (keyServer o) (fetchValidation o) fp- WKD -> WKD.fetchKeys (fetchValidation o) (T.pack (fetchQuery o))- case ekeys of- Left e -> hPutStrLn stderr $ "error fetching keys: " ++ e- Right ks -> B.putStr $ rearmorKeys ks+ ekeys <-+ runExceptT $+ case fetchMethod o of+ HKP -> do+ fp <- ExceptT . return . parseFingerprint . T.pack $ fetchQuery o+ HKP.fetchKeys (keyServer o) (fetchValidation o) fp+ WKD -> WKD.fetchKeys (fetchValidation o) (T.pack (fetchQuery o))+ case ekeys of+ Left e -> hPutStrLn stderr $ "error fetching keys: " ++ e+ Right ks -> B.putStr $ rearmorKeys ks
HOpenPGP/Tools/Hokey/InjectSSHAgent.hs view
@@ -15,209 +15,280 @@ -- -- 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 GADTs #-} module HOpenPGP.Tools.Hokey.InjectSSHAgent- (- doInjectSSHAgent- ) where+ ( doInjectSSHAgent+ ) where+ import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Ontology- ( isKUF- , isSKBindingSig- )+ ( isKUF+ , isSKBindingSig+ ) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types import Control.Exception (bracket) import qualified Crypto.PubKey.RSA as RSA import Data.Binary (get) import Data.Binary.Get (getWord32be, runGet)-import Data.Binary.Put (Put, putByteString, putLazyByteString, putWord32be, putWord8, runPut)-import Data.Bits ((.&.), shiftR, testBit)+import Data.Binary.Put+ ( Put+ , putByteString+ , putLazyByteString+ , putWord32be+ , putWord8+ , runPut+ )+import Data.Bits (shiftR, testBit, (.&.)) import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL-import Data.Conduit ((.|), runConduitRes)+import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL-import Data.Conduit.OpenPGP.Keyring (AuthSecretSubkeyAtTime, authSecretSubkeyPrimaryUID, authSecretSubkeyValue, conduitToAuthSecretSubkeysAt, conduitToSecretTKs)+import Data.Conduit.OpenPGP.Keyring+ ( AuthSecretSubkeyAtTime+ , authSecretSubkeyPrimaryUID+ , authSecretSubkeyValue+ , conduitToAuthSecretSubkeysAt+ , conduitToSomeTKsDroppingEither+ ) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Foldable (find) import Data.List (intercalate, sortOn) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)-import Data.Ord (Down(..))+import Data.Ord (Down (..)) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)-import HOpenPGP.Tools.Common.Common (renderFingerprint)-import Network.Socket (Family(AF_UNIX), SockAddr(..), Socket, SocketType(Stream), close, connect, defaultProtocol, socket)+import Data.Time.Clock.POSIX+ ( POSIXTime+ , getPOSIXTime+ , posixSecondsToUTCTime+ )+import Network.Socket+ ( Family (AF_UNIX)+ , SockAddr (..)+ , Socket+ , SocketType (Stream)+ , close+ , connect+ , defaultProtocol+ , socket+ ) import qualified Network.Socket.ByteString as NSB import System.Environment (lookupEnv) import System.Exit (exitFailure)-import HOpenPGP.Tools.Hokey.Options (InjectSSHAgentOptions(..)) import System.IO- ( hPutStrLn- , stderr- , stdin- )+ ( hPutStrLn+ , stderr+ , stdin+ ) +import HOpenPGP.Tools.Common.Common (renderFingerprint)+import HOpenPGP.Tools.Hokey.Options (InjectSSHAgentOptions (..))+ doInjectSSHAgent :: InjectSSHAgentOptions -> IO () doInjectSSHAgent opts = do- socketPath <- resolveSSHAgentSocketPath (injectSSHAgentSocket opts)- input <- readInjectedSecretKeyMaterial opts- cpt <- getPOSIXTime- authCandidates <-- runConduitRes $- CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|- conduitToAuthSecretSubkeysAt (posixSecondsToUTCTime cpt) .|- CL.consume- injectableCandidates <-- if null authCandidates- then inferInjectableAuthSubkeys cpt input- else pure (map candidateFromAuthSecretSubkey authCandidates)- whenEmpty injectableCandidates "inject-ssh-agent: no authentication-capable secret subkey found"- selectedRequests <-- selectInjectableAuthSubkeys- (injectSSHAgentComment opts)- injectableCandidates- mapM_- (\(selected, request) -> do- sendAddIdentityToSSHAgent socketPath request- hPutStrLn stderr $- "inject-ssh-agent: added authentication subkey " ++- renderFingerprint (fingerprint (injectableAuthSubkeyPKP selected)) ++- " to ssh-agent")- selectedRequests+ socketPath <-+ resolveSSHAgentSocketPath (injectSSHAgentSocket opts)+ input <- readInjectedSecretKeyMaterial opts+ cpt <- getPOSIXTime+ authCandidates <-+ runConduitRes $+ CL.sourceList (BL.toChunks input)+ .| conduitGet get+ .| conduitToSomeTKsDroppingEither+ .| CL.mapMaybe (either (const Nothing) (>>= someTKToSecretTK))+ .| conduitToAuthSecretSubkeysAt (posixSecondsToUTCTime cpt)+ .| CL.consume+ injectableCandidates <-+ if null authCandidates+ then inferInjectableAuthSubkeys cpt input+ else pure (map candidateFromAuthSecretSubkey authCandidates)+ whenEmpty+ injectableCandidates+ "inject-ssh-agent: no authentication-capable secret subkey found"+ selectedRequests <-+ selectInjectableAuthSubkeys+ (injectSSHAgentComment opts)+ injectableCandidates+ mapM_+ ( \(selected, request) -> do+ sendAddIdentityToSSHAgent socketPath request+ hPutStrLn stderr $+ "inject-ssh-agent: added authentication subkey "+ ++ renderFingerprint+ (fingerprint (injectableAuthSubkeyPKP selected))+ ++ " to ssh-agent"+ )+ selectedRequests -candidateFromAuthSecretSubkey :: AuthSecretSubkeyAtTime -> InjectableAuthSubkey+candidateFromAuthSecretSubkey+ :: AuthSecretSubkeyAtTime -> InjectableAuthSubkey candidateFromAuthSecretSubkey authSubkey =- InjectableAuthSubkey- { injectableAuthSubkeyPKP = authSecretSubkeyPKP authSubkey- , injectableAuthSubkeySKA = authSecretSubkeySKA authSubkey- , injectableAuthSubkeyPrimaryUID = authSecretSubkeyPrimaryUID authSubkey- }+ InjectableAuthSubkey+ { injectableAuthSubkeyPKP = authSecretSubkeyPKP authSubkey+ , injectableAuthSubkeySKA = authSecretSubkeySKA authSubkey+ , injectableAuthSubkeyPrimaryUID =+ authSecretSubkeyPrimaryUID authSubkey+ } -inferInjectableAuthSubkeys ::- POSIXTime -> BL.ByteString -> IO [InjectableAuthSubkey]+inferInjectableAuthSubkeys+ :: POSIXTime -> BL.ByteString -> IO [InjectableAuthSubkey] inferInjectableAuthSubkeys _cpt input = do- tks <-- runConduitRes $- CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|- CL.consume- pure (concatMap inferFromTK tks)+ tks <-+ runConduitRes $+ CL.sourceList (BL.toChunks input)+ .| conduitGet get+ .| conduitToSomeTKsDroppingEither+ .| CL.mapMaybe (either (const Nothing) (>>= someTKToSecretTK))+ .| CL.consume+ pure (concatMap inferFromTK tks) where inferFromTK tk =- let mPrimaryUID = fst <$> listToMaybe (_tkUIDs tk)- in mapMaybe (inferFromSubkey mPrimaryUID) (_tkSubs tk)- inferFromSubkey :: Maybe Text -> (KeyPkt k, [SignaturePayload]) -> Maybe InjectableAuthSubkey+ let mPrimaryUID = fst <$> listToMaybe (_tkUIDs tk)+ in mapMaybe (inferFromSubkey mPrimaryUID) (_tkSubs tk)+ inferFromSubkey+ :: Maybe Text+ -> (KeyPkt k, [SignaturePayload])+ -> Maybe InjectableAuthSubkey inferFromSubkey mPrimaryUID (KeyPktSecretSubkey pkp ska, sigs)- | hasAuthCapability sigs =- Just- InjectableAuthSubkey- { injectableAuthSubkeyPKP = pkp- , injectableAuthSubkeySKA = ska- , injectableAuthSubkeyPrimaryUID = mPrimaryUID- }+ | hasAuthCapability sigs =+ Just+ InjectableAuthSubkey+ { injectableAuthSubkeyPKP = pkp+ , injectableAuthSubkeySKA = ska+ , injectableAuthSubkeyPrimaryUID = mPrimaryUID+ } inferFromSubkey _ _ = Nothing hasAuthCapability sigs =- any- (Set.member AuthKey)- (mapMaybe signatureKeyFlags (newestWithUsageFlags (filter isSKBindingSig sigs)))+ any+ (Set.member AuthKey)+ ( mapMaybe+ signatureKeyFlags+ (newestWithUsageFlags (filter isSKBindingSig sigs))+ ) newestWithUsageFlags =- take 1 . sortOn (Down . take 1 . sigCreationTimes) . filter (any isKUF . signatureHashedSubpackets)- sigCreationTimes = mapMaybe sigCreationTimeFromSubpacket . signatureHashedSubpackets+ take 1+ . sortOn (Down . take 1 . sigCreationTimes)+ . filter (any isKUF . signatureHashedSubpackets)+ sigCreationTimes =+ mapMaybe sigCreationTimeFromSubpacket . signatureHashedSubpackets sigCreationTimeFromSubpacket (SigSubPacket _ (SigCreationTime ct)) = Just ct sigCreationTimeFromSubpacket _ = Nothing signatureHashedSubpackets (SigV4 _ _ _ hasheds _ _ _) = hasheds signatureHashedSubpackets (SigV6 _ _ _ _ hasheds _ _ _) = hasheds signatureHashedSubpackets _ = [] signatureKeyFlags sig = do- sp <- find isKUF (signatureHashedSubpackets sig)- case sp of- SigSubPacket _ (KeyFlags flags) -> Just flags- _ -> Nothing+ sp <- find isKUF (signatureHashedSubpackets sig)+ case sp of+ SigSubPacket _ (KeyFlags flags) -> Just flags+ _ -> Nothing resolveSSHAgentSocketPath :: Maybe String -> IO String resolveSSHAgentSocketPath (Just path) = pure path resolveSSHAgentSocketPath Nothing = do- envPath <- lookupEnv "SSH_AUTH_SOCK"- case envPath of- Just path -> pure path- Nothing ->- failInject- "inject-ssh-agent: SSH_AUTH_SOCK is not set; use --ssh-agent-socket"+ envPath <- lookupEnv "SSH_AUTH_SOCK"+ case envPath of+ Just path -> pure path+ Nothing ->+ failInject+ "inject-ssh-agent: SSH_AUTH_SOCK is not set; use --ssh-agent-socket" -readInjectedSecretKeyMaterial :: InjectSSHAgentOptions -> IO BL.ByteString+readInjectedSecretKeyMaterial+ :: InjectSSHAgentOptions -> IO BL.ByteString readInjectedSecretKeyMaterial opts = do- chunks <-- case injectSSHAgentFromFD opts of- Nothing -> runConduitRes $ CB.sourceHandle stdin .| CL.consume- Just fd- | fd < 0 ->- failInject "inject-ssh-agent: --from-fd must be a non-negative integer"- | otherwise ->- runConduitRes $ CB.sourceFile ("/dev/fd/" ++ show fd) .| CL.consume- let input = BL.fromChunks chunks- if BL.null input- then- failInject- "inject-ssh-agent: no secret key bytes were provided on the selected input stream"- else pure input+ chunks <-+ case injectSSHAgentFromFD opts of+ Nothing -> runConduitRes $ CB.sourceHandle stdin .| CL.consume+ Just fd+ | fd < 0 ->+ failInject+ "inject-ssh-agent: --from-fd must be a non-negative integer"+ | otherwise ->+ runConduitRes $+ CB.sourceFile ("/dev/fd/" ++ show fd) .| CL.consume+ let input = BL.fromChunks chunks+ if BL.null input+ then+ failInject+ "inject-ssh-agent: no secret key bytes were provided on the selected input stream"+ else pure input -selectInjectableAuthSubkeys ::- Maybe String -> [InjectableAuthSubkey] -> IO [(InjectableAuthSubkey, BL.ByteString)]+selectInjectableAuthSubkeys+ :: Maybe String+ -> [InjectableAuthSubkey]+ -> IO [(InjectableAuthSubkey, BL.ByteString)] selectInjectableAuthSubkeys mComment candidates- | null selectedRequests =- failInject- ("inject-ssh-agent: auth-capable subkeys were found, but none are supported for ssh-agent injection: " ++- intercalate "; " (reverse errs))- | otherwise = pure (reverse selectedRequests)+ | null selectedRequests =+ failInject+ ( "inject-ssh-agent: auth-capable subkeys were found, but none are supported for ssh-agent injection: "+ ++ intercalate "; " (reverse errs)+ )+ | otherwise = pure (reverse selectedRequests) where (errs, selectedRequests) = foldl' pick ([], []) candidates pick (accErrs, accSelected) candidate =- case- sshAddIdentityRequest- (fromMaybe (defaultSSHComment candidate) mComment)- (injectableAuthSubkeyPKP candidate)- (injectableAuthSubkeySKA candidate) of- Left err -> (err : accErrs, accSelected)- Right request -> (accErrs, (candidate, request) : accSelected)+ case sshAddIdentityRequest+ (fromMaybe (defaultSSHComment candidate) mComment)+ (injectableAuthSubkeyPKP candidate)+ (injectableAuthSubkeySKA candidate) of+ Left err -> (err : accErrs, accSelected)+ Right request -> (accErrs, (candidate, request) : accSelected) defaultSSHComment candidate =- case injectableAuthSubkeyPrimaryUID candidate of- Just uid -> T.unpack uid- Nothing -> "openpgp:" ++ BC8.unpack (Base16.encode (BL.toStrict (unFingerprint (fingerprint (injectableAuthSubkeyPKP candidate)))))+ case injectableAuthSubkeyPrimaryUID candidate of+ Just uid -> T.unpack uid+ Nothing ->+ "openpgp:"+ ++ BC8.unpack+ ( Base16.encode+ ( BL.toStrict+ (unFingerprint (fingerprint (injectableAuthSubkeyPKP candidate)))+ )+ ) -sshAddIdentityRequest ::- String -> SomePKPayload -> SKAddendum -> Either String BL.ByteString+sshAddIdentityRequest+ :: String+ -> SomePKPayload+ -> SKAddendum+ -> Either String BL.ByteString sshAddIdentityRequest comment subkeyPKP subkeySKA =- case subkeySKA of- SUUnencrypted (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) _ ->- Right $ frameSSHAgentRequest (rsaAddIdentityPayload (BC8.pack comment) rsaPrivateKey)- SUUnencrypted (EdDSAPrivateKey Ed25519 secretSeed) _ ->- frameSSHAgentRequest <$>- ed25519AddIdentityPayload (BC8.pack comment) subkeyPKP secretSeed- SUUnencrypted (UnknownSKey rawSecret) _- | isEd25519PKA (_pkalgo subkeyPKP) ->- frameSSHAgentRequest <$>- ed25519AddIdentityPayload- (BC8.pack comment)- subkeyPKP- (BL.toStrict rawSecret)- SUUnencrypted (EdDSAPrivateKey Ed448 _) _ ->- Left- ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++- " uses Ed448, which is not supported by ssh-agent add-identity")- SUUnencrypted _ _ ->- Left- ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++- " uses an unsupported key algorithm for ssh-agent injection")- _ ->- Left- ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++- " is encrypted; decrypt it before injection")+ case subkeySKA of+ SUUnencrypted (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) _ ->+ Right $+ frameSSHAgentRequest+ (rsaAddIdentityPayload (BC8.pack comment) rsaPrivateKey)+ SUUnencrypted (EdDSAPrivateKey Ed25519 secretSeed) _ ->+ frameSSHAgentRequest+ <$> ed25519AddIdentityPayload (BC8.pack comment) subkeyPKP secretSeed+ SUUnencrypted (UnknownSKey rawSecret) _+ | isEd25519PKA (_pkalgo subkeyPKP) ->+ frameSSHAgentRequest+ <$> ed25519AddIdentityPayload+ (BC8.pack comment)+ subkeyPKP+ (BL.toStrict rawSecret)+ SUUnencrypted (EdDSAPrivateKey Ed448 _) _ ->+ Left+ ( "subkey "+ ++ renderFingerprint (fingerprint subkeyPKP)+ ++ " uses Ed448, which is not supported by ssh-agent add-identity"+ )+ SUUnencrypted _ _ ->+ Left+ ( "subkey "+ ++ renderFingerprint (fingerprint subkeyPKP)+ ++ " uses an unsupported key algorithm for ssh-agent injection"+ )+ _ ->+ Left+ ( "subkey "+ ++ renderFingerprint (fingerprint subkeyPKP)+ ++ " is encrypted; decrypt it before injection"+ ) authSecretSubkeyPKP :: AuthSecretSubkeyAtTime -> SomePKPayload authSecretSubkeyPKP = keyPktPKPayload . authSecretSubkeyValue@@ -225,126 +296,150 @@ authSecretSubkeySKA :: AuthSecretSubkeyAtTime -> SKAddendum authSecretSubkeySKA = secretKeyPktSKAddendum . authSecretSubkeyValue -rsaAddIdentityPayload :: B.ByteString -> RSA.PrivateKey -> BL.ByteString+rsaAddIdentityPayload+ :: B.ByteString -> RSA.PrivateKey -> BL.ByteString rsaAddIdentityPayload comment privateKey =- runPut $ do- putWord8 17- putSSHString (BC8.pack "ssh-rsa")- putSSHMpint (RSA.public_n (RSA.private_pub privateKey))- putSSHMpint (RSA.public_e (RSA.private_pub privateKey))- putSSHMpint (RSA.private_d privateKey)- putSSHMpint (RSA.private_qinv privateKey)- putSSHMpint (RSA.private_p privateKey)- putSSHMpint (RSA.private_q privateKey)- putSSHString comment+ runPut $ do+ putWord8 17+ putSSHString (BC8.pack "ssh-rsa")+ putSSHMpint (RSA.public_n (RSA.private_pub privateKey))+ putSSHMpint (RSA.public_e (RSA.private_pub privateKey))+ putSSHMpint (RSA.private_d privateKey)+ putSSHMpint (RSA.private_qinv privateKey)+ putSSHMpint (RSA.private_p privateKey)+ putSSHMpint (RSA.private_q privateKey)+ putSSHString comment -ed25519AddIdentityPayload ::- B.ByteString -> SomePKPayload -> B.ByteString -> Either String BL.ByteString+ed25519AddIdentityPayload+ :: B.ByteString+ -> SomePKPayload+ -> B.ByteString+ -> Either String BL.ByteString ed25519AddIdentityPayload comment pkp rawSecret = do- publicKey <- ed25519PublicPoint pkp- secretSeed <- normalizeEd25519Secret rawSecret- pure $- runPut $ do- putWord8 17- putSSHString (BC8.pack "ssh-ed25519")- putSSHString publicKey- putSSHString (secretSeed <> publicKey)- putSSHString comment+ publicKey <- ed25519PublicPoint pkp+ secretSeed <- normalizeEd25519Secret rawSecret+ pure $+ runPut $ do+ putWord8 17+ putSSHString (BC8.pack "ssh-ed25519")+ putSSHString publicKey+ putSSHString (secretSeed <> publicKey)+ putSSHString comment ed25519PublicPoint :: SomePKPayload -> Either String B.ByteString ed25519PublicPoint pkp =- case _pubkey pkp of- EdDSAPubKey Ed25519 point ->- maybe- (Left ("invalid Ed25519 public point for subkey " ++ renderFingerprint (fingerprint pkp)))- Right- (edPointToRawBytes point)- _ -> Left ("subkey " ++ renderFingerprint (fingerprint pkp) ++ " does not have an Ed25519 public key")+ case _pubkey pkp of+ EdDSAPubKey Ed25519 point ->+ maybe+ ( Left+ ( "invalid Ed25519 public point for subkey "+ ++ renderFingerprint (fingerprint pkp)+ )+ )+ Right+ (edPointToRawBytes point)+ _ ->+ Left+ ( "subkey "+ ++ renderFingerprint (fingerprint pkp)+ ++ " does not have an Ed25519 public key"+ ) edPointToRawBytes :: EdPoint -> Maybe B.ByteString edPointToRawBytes (NativeEPoint (EPoint i)) = integerToFixedBytes 32 i edPointToRawBytes (PrefixedNativeEPoint (EPoint i)) = do- prefixed <- integerToFixedBytes 33 i- case B.uncons prefixed of- Just (0x40, raw) -> Just raw- _ -> Nothing+ prefixed <- integerToFixedBytes 33 i+ case B.uncons prefixed of+ Just (0x40, raw) -> Just raw+ _ -> Nothing -normalizeEd25519Secret :: B.ByteString -> Either String B.ByteString+normalizeEd25519Secret+ :: B.ByteString -> Either String B.ByteString normalizeEd25519Secret rawSecret- | B.length rawSecret == 32 = Right rawSecret- | otherwise =- Left- ("expected 32-byte Ed25519 secret seed, got " ++ show (B.length rawSecret) ++ " bytes")+ | B.length rawSecret == 32 = Right rawSecret+ | otherwise =+ Left+ ( "expected 32-byte Ed25519 secret seed, got "+ ++ show (B.length rawSecret)+ ++ " bytes"+ ) putSSHString :: B.ByteString -> Put putSSHString bs = putWord32be (fromIntegral (B.length bs)) >> putByteString bs putSSHMpint :: Integer -> Put putSSHMpint n- | n <= 0 = putWord32be 0- | otherwise = putSSHString encoded+ | n <= 0 = putWord32be 0+ | otherwise = putSSHString encoded where raw = integerToUnsignedBytes n encoded =- case B.uncons raw of- Just (firstByte, _)- | testBit firstByte 7 -> B.cons 0x00 raw- _ -> raw+ case B.uncons raw of+ Just (firstByte, _)+ | testBit firstByte 7 -> B.cons 0x00 raw+ _ -> raw integerToFixedBytes :: Int -> Integer -> Maybe B.ByteString integerToFixedBytes width n- | n < 0 = Nothing- | B.length raw > width = Nothing- | otherwise = Just (B.replicate (width - B.length raw) 0x00 <> raw)+ | n < 0 = Nothing+ | B.length raw > width = Nothing+ | otherwise =+ Just (B.replicate (width - B.length raw) 0x00 <> raw) where raw =- if n == 0- then B.singleton 0x00- else integerToUnsignedBytes n+ if n == 0+ then B.singleton 0x00+ else integerToUnsignedBytes n integerToUnsignedBytes :: Integer -> B.ByteString integerToUnsignedBytes n =- B.reverse $- B.unfoldr- (\value ->- if value == 0- then Nothing- else Just (fromIntegral (value .&. 0xff), value `shiftR` 8))- n+ B.reverse $+ B.unfoldr+ ( \value ->+ if value == 0+ then Nothing+ else Just (fromIntegral (value .&. 0xff), value `shiftR` 8)+ )+ n isEd25519PKA :: PubKeyAlgorithm -> Bool isEd25519PKA pka = fromFVal pka == 27 frameSSHAgentRequest :: BL.ByteString -> BL.ByteString frameSSHAgentRequest body =- runPut $ putWord32be (fromIntegral (BL.length body)) >> putLazyByteString body+ runPut $+ putWord32be (fromIntegral (BL.length body))+ >> putLazyByteString body sendAddIdentityToSSHAgent :: FilePath -> BL.ByteString -> IO () sendAddIdentityToSSHAgent socketPath request =- bracket- (socket AF_UNIX Stream defaultProtocol)- close- (\sock -> do- connect sock (SockAddrUnix socketPath)- NSB.sendAll sock (BL.toStrict request)- response <- readSSHAgentPacket sock- case B.uncons response of- Just (6, _) -> pure ()- Just (5, _) ->- failInject "inject-ssh-agent: ssh-agent rejected the supplied key"- Just (code, _) ->- failInject- ("inject-ssh-agent: ssh-agent returned unexpected response type " ++- show code)- Nothing ->- failInject- "inject-ssh-agent: ssh-agent returned an empty response packet")+ bracket+ (socket AF_UNIX Stream defaultProtocol)+ close+ ( \sock -> do+ connect sock (SockAddrUnix socketPath)+ NSB.sendAll sock (BL.toStrict request)+ response <- readSSHAgentPacket sock+ case B.uncons response of+ Just (6, _) -> pure ()+ Just (5, _) ->+ failInject+ "inject-ssh-agent: ssh-agent rejected the supplied key"+ Just (code, _) ->+ failInject+ ( "inject-ssh-agent: ssh-agent returned unexpected response type "+ ++ show code+ )+ Nothing ->+ failInject+ "inject-ssh-agent: ssh-agent returned an empty response packet"+ ) readSSHAgentPacket :: Socket -> IO B.ByteString readSSHAgentPacket sock = do- lenPrefix <- recvExact sock 4- let packetLen = fromIntegral (runGet getWord32be (BL.fromStrict lenPrefix))- recvExact sock packetLen+ lenPrefix <- recvExact sock 4+ let packetLen = fromIntegral (runGet getWord32be (BL.fromStrict lenPrefix))+ recvExact sock packetLen recvExact :: Socket -> Int -> IO B.ByteString recvExact _ 0 = pure B.empty@@ -352,12 +447,12 @@ where go acc 0 = pure acc go acc bytesRemaining = do- chunk <- NSB.recv sock bytesRemaining- if B.null chunk- then- failInject- "inject-ssh-agent: ssh-agent socket closed while reading response"- else go (acc <> chunk) (bytesRemaining - B.length chunk)+ chunk <- NSB.recv sock bytesRemaining+ if B.null chunk+ then+ failInject+ "inject-ssh-agent: ssh-agent socket closed while reading response"+ else go (acc <> chunk) (bytesRemaining - B.length chunk) whenEmpty :: [a] -> String -> IO () whenEmpty [] msg = failInject msg@@ -366,8 +461,8 @@ failInject :: String -> IO a failInject msg = hPutStrLn stderr msg >> exitFailure -data InjectableAuthSubkey =- InjectableAuthSubkey+data InjectableAuthSubkey+ = InjectableAuthSubkey { injectableAuthSubkeyPKP :: SomePKPayload , injectableAuthSubkeySKA :: SKAddendum , injectableAuthSubkeyPrimaryUID :: Maybe Text
HOpenPGP/Tools/Hokey/Lint.hs view
@@ -15,696 +15,942 @@ -- -- 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 DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeApplications #-}--module HOpenPGP.Tools.Hokey.Lint- (- doLint- ) where--import Codec.Encryption.OpenPGP.Expirations (getKeyExpirationTimesFromSignature)-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)-import Codec.Encryption.OpenPGP.Ontology- ( isCT- , isCertRevocationSig- , isKUF- , isPHA- , isPKBindingSig- , isSKBindingSig- )-import Codec.Encryption.OpenPGP.Serialize ()-import Codec.Encryption.OpenPGP.Types-import Control.Arrow ((***))-import Control.Error.Util (hush)-import Control.Lens ((&), (^.), _1)-import Control.Monad.Trans.Writer.Lazy (execWriter, tell)-import qualified Crypto.Hash as CH-import qualified Crypto.Hash.Algorithms as CHA-import qualified Data.Aeson as A-import Data.Binary (get)-import qualified Data.ByteArray as BA-import qualified Data.ByteString as B-import qualified Data.ByteString.Base16 as Base16-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString.Lazy as BL-import Data.Conduit ((.|), runConduitRes)-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)-import Data.Conduit.Serialization.Binary (conduitGet)-import Data.Foldable (find)-import Data.List (elemIndex, findIndex, intercalate, sortOn)-import qualified Data.Map as Map-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)-import Data.Ord (Down(..))-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)-import Data.Time.Format (formatTime)-import qualified Data.Yaml as Y-import GHC.Generics-import HOpenPGP.Tools.Common.Common (renderKeyID, renderFingerprint)-import HOpenPGP.Tools.Common.TKUtils (processTK)-import HOpenPGP.Tools.Hokey.Options (LintOptions(..), LintOutputFormat(..))--import Data.Time.Locale.Compat (defaultTimeLocale)-import System.IO- ( stdin- )--import Prettyprinter- ( Doc- , (<+>)- , annotate- , colon- , flatAlt- , indent- , line- , list- , pretty- )-import qualified Prettyprinter.Render.Terminal as PPA--linebreak :: Doc ann-linebreak = flatAlt line mempty--green, yellow, red :: Doc PPA.AnsiStyle -> Doc PPA.AnsiStyle-green = annotate (PPA.color PPA.Green)-yellow = annotate (PPA.color PPA.Yellow)-red = annotate (PPA.color PPA.Red)--data KAS =- KAS- { pubkeyalgo :: Colored PubKeyAlgorithm- , pubkeysize :: Colored (Maybe Int)- , stringrep :: String- }- deriving (Generic)--data Color- = Green- | Yellow- | Red- deriving (Eq, Generic, Ord)--data Colored a =- Colored- { color :: Maybe Color- , explanation :: Maybe String- , val :: a- }- deriving (Functor, Generic)--newtype FakeMap a b =- FakeMap- { unFakeMap :: [(a, b)]- }--data KeyReport =- KeyReport- { keyStatus :: String- , keyFingerprint :: Fingerprint- , keyVer :: Colored KeyVersion- , keyCreationTime :: ThirtyTwoBitTimeStamp- , keyAlgorithmAndSize :: KAS- , keyUIDsAndUAts :: FakeMap Text (Colored UIDReport)- , keyBestOf :: Maybe UIDReport- , keySubkeys :: [SubkeyReport]- , keyHasEncryptionCapableSubkey :: Colored Bool- }- deriving (Generic)--data UIDReport =- UIDReport- { uidSelfSigHashAlgorithms :: [Colored HashAlgorithm]- , uidPreferredHashAlgorithms :: [Colored [HashAlgorithm]]- , uidKeyExpirationTimes :: [Colored [ThirtyTwoBitDuration]]- , uidKeyUsageFlags :: [Colored (Set.Set KeyFlag)]- , uidRevocationStatus :: [RevocationStatus]- }- deriving (Generic)--data SubkeyReport =- SubkeyReport- { skFingerprint :: Colored Fingerprint- , skVer :: Colored KeyVersion- , skCreationTime :: ThirtyTwoBitTimeStamp- , skAlgorithmAndSize :: KAS- , skBindingSigHashAlgorithms :: [Colored HashAlgorithm]- , skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning]- , skUsageFlags :: [Colored (Set.Set KeyFlag)]- , skCrossCerts :: CrossCertReport- }- deriving (Generic)--data SubkeyRevocationDigestWarning =- SubkeyRevocationDigestWarning- { srwHashAlgorithm :: HashAlgorithm- , srwSubkeyFingerprint :: String- , srwSubkeyKeyID :: Maybe String- , srwMessage :: String- }- deriving (Generic)--data CrossCertReport =- CrossCertReport- { ccPresent :: Colored Bool- , ccHashAlgorithms :: [Colored HashAlgorithm]- }- deriving (Generic)--data RevocationStatus =- RevocationStatus- { isRevoked :: Bool- , revocationCode :: String- , revocationReason :: Text- }- deriving (Generic)--instance A.ToJSON KAS--instance A.ToJSON Color--instance (A.ToJSON a) => A.ToJSON (Colored a)--instance A.ToJSON KeyReport--instance A.ToJSON UIDReport--instance A.ToJSON SubkeyReport--instance A.ToJSON SubkeyRevocationDigestWarning--instance A.ToJSON CrossCertReport--instance A.ToJSON b => A.ToJSON (FakeMap Text b) where- toJSON = A.toJSON . Map.fromList . unFakeMap--instance A.ToJSON RevocationStatus--instance Semigroup UIDReport where- (<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') =- UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e')--instance Monoid UIDReport where- mempty = UIDReport [] [] [] [] []- mappend = (<>)--checkKey :: Maybe POSIXTime -> TKUnknown -> KeyReport-checkKey mpt key =- (\x ->- x- { keyBestOf = populateBestOf x- , keyHasEncryptionCapableSubkey =- hasEncryptionCapableSubkey (concatMap skUsageFlags (keySubkeys x))- })- KeyReport- { keyStatus = either id (const "good") processedTK- , keyFingerprint = key ^. tkuKey . _1 & fingerprint- , keyVer = key ^. tkuKey . _1 & _keyVersion & colorizeKV- , keyCreationTime = key ^. tkuKey . _1 & _timestamp- , keyAlgorithmAndSize = kasIt (key ^. tkuKey . _1)- , keyUIDsAndUAts =- FakeMap- (map (\(x, y) -> (x, uidr (Just x) y)) (processedOrOrig ^. tkuUIDs) ++- map (uatspsToText *** uidr Nothing) (processedOrOrig ^. tkuUAts))- , keyBestOf = Nothing- , keySubkeys =- map (checkSK (key ^. tkuKey . _1 & fingerprint)) (key ^. tkuSubs)- , keyHasEncryptionCapableSubkey = Colored Nothing Nothing False- }- where- processedOrOrig = either (const key) id processedTK- processedTK = processTK mpt key- kasIt :: SomePKPayload -> KAS- kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize)- kasIt' :: PubKeyAlgorithm -> Either String Int -> KAS- kasIt' pka epks =- KAS- { pubkeyalgo = colorizePKA pka- , pubkeysize = colorizePKS pka epks- , stringrep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka)- }- colorizeKV kv =- uncurry- Colored- (if kv == V4- then (Just Green, Nothing)- else (Just Red, Just "not a V4 key"))- kv- colorizePKA pka- | pka `elem` [RSA, EdDSA, ECDH] = Colored (Just Green) Nothing pka- | otherwise =- Colored- (Just Yellow)- (Just "public key algorithm neither RSA nor EdDSA")- pka- colorizePKS pka epks = uncurry Colored (colorizePKS' pka epks) (hush epks)- colorizePKS' pka (Right pks)- | pka `elem` [EdDSA, ECDH] && pks >= 256 = (Just Green, Nothing)- | pka `elem` [EdDSA, ECDH] =- (Just Yellow, Just "Public key size under 256 bits")- | pka == RSA && pks >= 3072 = (Just Green, Nothing)- | pka == RSA && pks >= 2048 =- (Just Yellow, Just "Public key size between 2048 and 3072 bits")- | pka == RSA = (Just Red, Just "Public key size under 2048 bits")- | otherwise = (Nothing, Nothing)- colorizePKS' _ (Left _) =- (Just Red, Just "public key algorithm not understood")- colorizePHAs x =- uncurry- Colored- (if preferredWeakHash x- then (Just Red, Just "weak hash with higher preference")- else (Just Green, Nothing))- x- fSHA2Family = fi (`elem` [SHA512, SHA384, SHA256, SHA224])- firstStrongSHA2 xs = fSHA2Family xs- preferredWeakHash xs =- any- (\ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2 xs)- knownWeakHashAlgorithms- fi x y = fromMaybe maxBound (findIndex x y)- colorizeKETs ct ts kes- | null kes = Colored (Just Red) (Just "no expiration set") kes- | any (\ke -> realToFrac ts + realToFrac ke < ct) kes =- Colored (Just Red) (Just "expiration passed") kes- | any (\ke -> realToFrac ts + realToFrac ke > ct + (5 * 31557600)) kes =- Colored (Just Yellow) (Just "expiration too far in future") kes- | otherwise = Colored (Just Green) Nothing kes- eoki pkp- | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp- | _keyVersion pkp == DeprecatedV3 &&- elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =- hush . eightOctetKeyID $ pkp- | otherwise = Nothing- phas (SigV4 _ _ _ xs _ _ _) =- colorizePHAs .- concatMap (\(SigSubPacket _ (PreferredHashAlgorithms x)) -> x) $- filter isPHA xs- phas _ = Colored Nothing Nothing []- has = map (colorizeHA . hashAlgo) . alleged- colorizeHA ha =- uncurry- Colored- (if isKnownWeakHashAlgorithm ha- then (Just Red, Just "weak hash algorithm")- else (Nothing, Nothing))- ha- sigcts (SigV4 _ _ _ xs _ _ _) =- map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs- sigcts (SigV6 _ _ _ _ xs _ _ _) =- map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs- alleged =- filter- (\x -> ((==) <$> sigissuer x <*> eoki (key ^. tkuKey . _1)) == Just True)- uatspsToText = T.pack . uatspsToString- uatspsToString us =- "<uat:[" ++ intercalate "," (map uaspToString us) ++ "]>"- uaspToString (ImageAttribute hdr d) =- hdrToString hdr ++ ':' : show (BL.length d) ++ ':' :- BC8.unpack (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))- uaspToString (OtherUASub t d) =- "other-" ++ show t ++ ':' : show (BL.length d) ++ ':' :- BC8.unpack (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))- hdrToString (ImageHV1 JPEG) = "jpeg"- hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)- uidr Nothing sps =- Colored- Nothing- Nothing- (UIDReport- (has sps)- (map phas sps)- (map- (colorizeKETs- (fromMaybe 0 mpt)- (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) .- getKeyExpirationTimesFromSignature)- sps -- should that be 0?- )- (kufs False sps)- (findRevocationReason sps))- uidr (Just u) sps =- colorizeUID- u- (UIDReport- (has sps)- (map phas sps)- (map- (colorizeKETs- (fromMaybe 0 mpt)- (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) .- getKeyExpirationTimesFromSignature)- sps -- should that be 0?- )- (kufs False sps)- (findRevocationReason sps))- populateBestOf krep =- Just- (UIDReport <$> best . uidSelfSigHashAlgorithms <*> best .- uidPreferredHashAlgorithms <*>- best .- uidKeyExpirationTimes <*>- best .- uidKeyUsageFlags <*>- pure [] $- mconcat (justTheUIDRs krep))- justTheUIDRs = map (decolorize . snd) . unFakeMap . keyUIDsAndUAts- best = take 1 . sortOn color- decolorize (Colored _ _ x) = x- colorizeUID u- | '(' `elem` T.unpack u =- Colored (Just Yellow) (Just "parenthesis in uid") -- FIXME: be more discerning- | '<' `notElem` T.unpack u =- Colored (Just Yellow) (Just "no left angle bracket in uid") -- FIXME: be more discerning- | otherwise = Colored Nothing Nothing- findRevocationReason = concatMap grabReasons . filter isCertRevocationSig- grabReasons (SigV4 CertRevocationSig _ _ has _ _ _) =- mapMaybe (grabReasons' . _sspPayload) has- grabReasons _ = []- grabReasons' (ReasonForRevocation a b) =- Just (RevocationStatus True (show a) b)- grabReasons' _ = Nothing- kufs s =- map- (colorizeKUFs s . (\(SigSubPacket _ (KeyFlags x)) -> x) .- fromMaybe undefined .- find isKUF .- hasheds) .- newestWith (any isKUF . hasheds)- colorizeKUFs False x =- uncurry- Colored- (if (Set.member EncryptStorageKey x ||- Set.member EncryptCommunicationsKey x) &&- (Set.member SignDataKey x || Set.member CertifyKeysKey x)- then (Just Yellow, Just "both signing & encryption")- else (Just Green, Nothing))- x- colorizeKUFs True x =- uncurry- Colored- (if Set.member CertifyKeysKey x- then (Just Red, Just "certification-capable subkey")- else (if (Set.member EncryptStorageKey x ||- Set.member EncryptCommunicationsKey x) &&- Set.member SignDataKey x- then (Just Yellow, Just "both signing & encryption")- else (Just Green, Nothing)))- x- newestWith p = take 1 . sortOn (Down . take 1 . sigcts) . filter p -- FIXME: this is terrible- hasheds (SigV4 _ _ _ xs _ _ _) = xs- hasheds (SigV6 _ _ _ _ xs _ _ _) = xs- hasheds _ = []- checkSK ::- Fingerprint -> (Pkt, [SignaturePayload]) -> SubkeyReport- checkSK pf (PublicSubkeyPkt pkp, sigs) = checkSK' pf pkp sigs- checkSK pf (SecretSubkeyPkt pkp _, sigs) = checkSK' pf pkp sigs- checkSK' pf pkp sigs =- (\x -> x {skCrossCerts = ccr (map decolorize (skUsageFlags x)) sigs})- SubkeyReport- { skFingerprint = colorizeF pf (fingerprint pkp)- , skVer = colorizeKV (_keyVersion pkp)- , skCreationTime = _timestamp pkp- , skAlgorithmAndSize = kasIt pkp- , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)- , skRevocationSigWeakDigests =- subkeyRevocationSigWeakDigests pkp sigs- , skUsageFlags = kufs True (filter isSKBindingSig sigs)- , skCrossCerts = CrossCertReport (Colored Nothing Nothing False) []- }- hasEncryptionCapableSubkey skrs =- if any- ((\x ->- Set.member EncryptStorageKey x ||- Set.member EncryptCommunicationsKey x) .- decolorize)- skrs- then Colored (Just Green) Nothing True- else Colored- (Just Red)- (Just "no encryption-capable subkey present")- False- embeddedSigs =- filter isPKBindingSig . concatMap getEmbeds . filter isSKBindingSig- getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)- getEmbeds _ = []- getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]- getEmbed _ = []- ccr kufs sigs =- CrossCertReport (colorES kufs sigs) (map (colorizeHA . hashAlgo) sigs)- colorES kufs sigs =- case ( null (embeddedSigs sigs)- , any (Set.member SignDataKey) kufs- , any (Set.member AuthKey) kufs) of- (True, True, True) ->- Colored- (Just Red)- (Just "signing- and auth-capable subkey without cross-cert")- False- (True, True, False) ->- Colored- (Just Red)- (Just "signing-capable subkey without cross-cert")- False- (True, False, True) ->- Colored- (Just Yellow)- (Just "auth-capable subkey without cross-cert")- False- (False, True, True) -> Colored (Just Green) Nothing True- (False, True, False) -> Colored (Just Green) Nothing True- (False, False, True) -> Colored (Just Green) Nothing True- (False, False, False) -> Colored Nothing Nothing True- (True, _, _) -> Colored Nothing Nothing False- colorizeF pf fp =- uncurry- Colored- (if pf == fp- then (Just Red, Just "subkey has same fingerprint as primary key")- else (Just Green, Nothing))- fp- subkeyRevocationSigWeakDigests pkp =- mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp) .- filter isSubkeyRevocationSignature- mkSubkeyRevocationSigWeakDigestWarning pkp sig =- let ha = hashAlgo sig- in if isKnownWeakHashAlgorithm ha- then- Just- SubkeyRevocationDigestWarning- { srwHashAlgorithm = ha- , srwSubkeyFingerprint = renderFingerprint (fingerprint pkp)- , srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp))- , srwMessage =- "subkey revocation signature uses known-weak digest algorithm"- }- else Nothing--prettyKeyReport :: POSIXTime -> TKUnknown -> Doc PPA.AnsiStyle-prettyKeyReport cpt key = do- let keyReport = checkKey (Just cpt) key- execWriter $- tell- (linebreak <> pretty "Key has potential validity" <> colon <+>- pretty (keyStatus keyReport) <>- linebreak <>- pretty "Key has fingerprint" <>- colon <+>- pretty (SpacedFingerprint (keyFingerprint keyReport)) <>- linebreak <>- pretty "Checking to see if key is OpenPGPv4" <>- colon <+>- coloredToColor (pretty . show) (keyVer keyReport) <>- linebreak <>- (\kas ->- pretty "Checking the strength of your primary asymmetric key" <> colon <+>- coloredToColor pretty (pubkeyalgo kas) <+>- coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas))- (keyAlgorithmAndSize keyReport) <>- linebreak <>- pretty "Checking user-ID- and user-attribute-related items" <>- colon <>- mconcat- (map- (uidtrip (keyCreationTime keyReport) . gottabeabetterway)- (unFakeMap (keyUIDsAndUAts keyReport))) <>- linebreak <>- pretty "Checking subkeys" <>- colon <>- linebreak <>- indent- 2- (pretty "one of the subkeys is encryption-capable" <> colon <+>- coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)) <>- mconcat (map subkeyrep (keySubkeys keyReport)) <>- linebreak)- where- coloredToColor f (Colored (Just Green) _ x) = green (f x)- coloredToColor f (Colored (Just Yellow) _ x) = yellow (f x)- coloredToColor f (Colored (Just Red) _ x) = red (f x)- coloredToColor f (Colored Nothing _ x) = f x- uidtrip ts (u, ur)- | null (uidRevocationStatus ur) =- linebreak <> indent 2 (coloredToColor pretty (fmap T.unpack u)) <> colon <>- linebreak <>- indent- 4- (pretty "Self-sig hash algorithms" <> colon <+>- (list . map (coloredToColor pretty) . uidSelfSigHashAlgorithms) ur) <>- linebreak <>- indent- 4- (pretty "Preferred hash algorithms" <> colon <+>- mconcat (map (coloredToColor pretty) (uidPreferredHashAlgorithms ur))) <>- linebreak <>- indent- 4- (pretty "Key expiration times" <> colon <+>- mconcat- (map- (coloredToColor list . fmap (map (pretty . keyExp ts)))- (uidKeyExpirationTimes ur))) <>- linebreak <>- indent- 4- (pretty "Key usage flags" <> colon <+>- (list . map (coloredToColor (pretty . Set.toList)))- (uidKeyUsageFlags ur))- | otherwise =- linebreak <> indent 2 (coloredToColor pretty (fmap T.unpack u)) <> colon <+>- pretty "[revoked]" <>- linebreak <>- indent- 4- (pretty "Revocation code" <> colon <+>- list (map (pretty . revocationCode) (uidRevocationStatus ur))) <>- linebreak <>- indent- 4- (pretty "Revocation reason" <> colon <+>- list- (map- (pretty . T.unpack . revocationReason)- (uidRevocationStatus ur)))- keyExp ts ke =- (show . pretty) ke ++ " = " ++- formatTime- defaultTimeLocale- "%c"- (posixSecondsToUTCTime (realToFrac ts + realToFrac ke))- gottabeabetterway (a, Colored x y z) = (Colored x y a, z)- subkeyrep skr =- linebreak <>- indent- 2- (pretty "fpr" <> colon <+>- coloredToColor pretty (fmap SpacedFingerprint (skFingerprint skr))) <>- linebreak <>- indent 4 (pretty "version" <> colon <+> coloredToColor pretty (skVer skr)) <>- linebreak <>- indent 4 (pretty "timestamp" <> colon <+> pretty (skCreationTime skr)) <>- linebreak <>- indent- 4- ((\kas ->- pretty "algo/size" <> colon <+>- coloredToColor pretty (pubkeyalgo kas) <+>- coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas))- (skAlgorithmAndSize skr)) <>- linebreak <>- indent- 4- (pretty "binding sig hash algorithms" <> colon <+>- (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms) skr) <>- linebreak <>- indent- 4- (pretty "weak subkey revocation digests" <> colon <+>- if null (skRevocationSigWeakDigests skr)- then pretty "[]"- else- list- (map- (\w ->- red- (pretty (srwHashAlgorithm w) <> colon <+>- pretty (srwSubkeyFingerprint w) <> colon <+>- maybe (pretty "<no-key-id>") pretty (srwSubkeyKeyID w)))- (skRevocationSigWeakDigests skr))) <>- linebreak <>- indent- 4- (pretty "usage flags" <> colon <+>- (list . map (coloredToColor (pretty . Set.toList))) (skUsageFlags skr)) <>- linebreak <>- indent- 4- (pretty "embedded cross-cert" <> colon <+>- (coloredToColor pretty . ccPresent . skCrossCerts) skr) <>- linebreak <>- indent- 4- (pretty "cross-cert hash algorithms" <> colon <+>- (list . map (coloredToColor pretty) . ccHashAlgorithms . skCrossCerts)- skr)--jsonReport :: POSIXTime -> TKUnknown -> BL.ByteString-jsonReport ps = A.encode . checkKey (Just ps)--yamlReport :: POSIXTime -> TKUnknown -> B.ByteString-yamlReport ps = Y.encode . (: []) . checkKey (Just ps)--doLint :: LintOptions -> IO ()-doLint o = do- cpt <- getPOSIXTime- keys <-- runConduitRes $ CB.sourceHandle stdin .| conduitGet get .|- conduitToTKsDropping .|- CL.consume- output (lintOutputFormat o) cpt keys- where- output Pretty cpt = mapM_ (PPA.putDoc . prettyKeyReport cpt)- output JSON cpt =- mapM_ (BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt)- output YAML cpt = mapM_ (B.putStr . yamlReport cpt)--sigissuer :: SignaturePayload -> Maybe EightOctetKeyId-getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId-hashAlgo :: SignaturePayload -> HashAlgorithm-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?-sigissuer (SigV6 _ _ _ _ ys xs _ _) =- listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?-sigissuer (SigVOther _ _) = Nothing--getIssuer (Issuer i) = Just i-getIssuer _ = Nothing--hashAlgo (SigV3 _ _ _ _ x _ _) = x-hashAlgo (SigV4 _ _ x _ _ _ _) = x-hashAlgo (SigV6 _ _ x _ _ _ _ _) = x-hashAlgo (SigVOther _ _) = OtherHA 0--knownWeakHashAlgorithms :: [HashAlgorithm]-knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]--isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool-isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms--isSubkeyRevocationSignature :: SignaturePayload -> Bool-isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig-isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig-isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig-isSubkeyRevocationSignature _ = False--+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}++module HOpenPGP.Tools.Hokey.Lint+ ( doLint+ ) where++import Codec.Encryption.OpenPGP.Expirations+ ( getKeyExpirationTimesFromSignature+ )+import Codec.Encryption.OpenPGP.Fingerprint+ ( eightOctetKeyID+ , fingerprint+ )+import Codec.Encryption.OpenPGP.KeyInfo+ ( pkalgoAbbrev+ , pubkeySize+ )+import Codec.Encryption.OpenPGP.Ontology+ ( isCT+ , isCertRevocationSig+ , isKUF+ , isPHA+ , isPKBindingSig+ , isSKBindingSig+ )+import Codec.Encryption.OpenPGP.Serialize ()+import Codec.Encryption.OpenPGP.Types+import Control.Arrow ((***))+import Control.Error.Util (hush)+import Control.Lens ((&), (^.), _1)+import Control.Monad (join, void)+import Control.Monad.Trans.Writer.Lazy (execWriter, tell)+import qualified Crypto.Hash as CH+import qualified Crypto.Hash.Algorithms as CHA+import qualified Data.Aeson as A+import Data.Binary (get)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Lazy as BL+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.Serialization.Binary (conduitGet)+import Data.Foldable (find, maximumBy, sequenceA_, traverse_)+import Data.List (elemIndex, findIndex, intercalate, nub, sortOn)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Ord (comparing)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Clock.POSIX+ ( POSIXTime+ , getPOSIXTime+ , posixSecondsToUTCTime+ )+import Data.Time.Format (formatTime)+import Data.Time.Locale.Compat (defaultTimeLocale)+import qualified Data.Yaml as Y+import GHC.Generics+import Prettyprinter+ ( Doc+ , annotate+ , colon+ , flatAlt+ , indent+ , line+ , list+ , pretty+ , vsep+ , (<+>)+ )+import qualified Prettyprinter.Render.Terminal as PPA+import System.IO+ ( stdin+ )++import HOpenPGP.Tools.Common.Common+ ( renderFingerprint+ , renderKeyID+ )+import HOpenPGP.Tools.Common.TKUtils (processTK)+import HOpenPGP.Tools.Hokey.Options+ ( LintOptions (..)+ , LintOutputFormat (..)+ )++linebreak :: Doc ann+linebreak = flatAlt line mempty++green, yellow, red :: Doc PPA.AnsiStyle -> Doc PPA.AnsiStyle+green = annotate (PPA.color PPA.Green)+yellow = annotate (PPA.color PPA.Yellow)+red = annotate (PPA.color PPA.Red)++data KAS+ = KAS+ { pubkeyalgo :: Result PubKeyAlgorithm+ , pubkeysize :: Result (Maybe Int)+ , stringrep :: String+ }+ deriving (Generic)++data Color+ = Green+ | Yellow+ | Red+ deriving (Eq, Generic, Ord)++data Result a = Result+ { resultColor :: Maybe Color+ , resultFindings :: Maybe [String]+ , resultValue :: a+ }+ deriving (Functor, Generic)++instance Applicative Result where+ pure x = Result Nothing Nothing x+ (Result c1 e1 f) <*> (Result c2 e2 x) =+ Result (max c1 c2) (e1 <> e2) (f x)++instance Monad Result where+ (Result c1 e1 x) >>= f =+ let Result c2 e2 y = f x+ in Result (max c1 c2) (e1 <> e2) y++colored :: Maybe Color -> Maybe [String] -> a -> Result a+colored c e x = Result c e x++withColor :: Maybe Color -> a -> Result a+withColor c x = Result c Nothing x++getResult :: Result a -> a+getResult (Result _ _ x) = x++newtype LintPolicy src a+ = LintPolicy+ { unPolicy :: src -> Maybe POSIXTime -> Result a+ }+ deriving (Functor, Generic)++instance Applicative (LintPolicy src) where+ pure x = LintPolicy (\_ _ -> pure x)+ (LintPolicy f) <*> (LintPolicy x) = LintPolicy (\src mpt -> f src mpt <*> x src mpt)++data KeyReport+ = KeyReport+ { keyStatus :: Result String+ , keyFingerprint :: Result Fingerprint+ , keyVer :: Result KeyVersion+ , keyCreationTime :: Result ThirtyTwoBitTimeStamp+ , keyAlgorithmAndSize :: Result KAS+ , keyUIDsAndUAts :: Map.Map Text (Result UIDReport)+ , keyBestOf :: Maybe UIDReport+ , keySubkeys :: [Result SubkeyReport]+ , keyHasEncryptionCapableSubkey :: Result Bool+ }+ deriving (Generic)++data UIDReport+ = UIDReport+ { uidSelfSigHashAlgorithms :: [Result HashAlgorithm]+ , uidPreferredHashAlgorithms :: [Result [HashAlgorithm]]+ , uidKeyExpirationTimes :: [Result [ThirtyTwoBitDuration]]+ , uidKeyUsageFlags :: [Result (Set.Set KeyFlag)]+ , uidRevocationStatus :: [RevocationStatus]+ }+ deriving (Generic)++data SubkeyReport+ = SubkeyReport+ { skFingerprint :: Result Fingerprint+ , skVer :: Result KeyVersion+ , skCreationTime :: ThirtyTwoBitTimeStamp+ , skAlgorithmAndSize :: Result KAS+ , skBindingSigHashAlgorithms :: [Result HashAlgorithm]+ , skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning]+ , skUsageFlags :: [Result (Set.Set KeyFlag)]+ , skCrossCerts :: CrossCertReport+ }+ deriving (Generic)++data SubkeyRevocationDigestWarning+ = SubkeyRevocationDigestWarning+ { srwHashAlgorithm :: HashAlgorithm+ , srwSubkeyFingerprint :: String+ , srwSubkeyKeyID :: Maybe String+ , srwMessage :: String+ }+ deriving (Generic)++data CrossCertReport+ = CrossCertReport+ { ccPresent :: Result Bool+ , ccHashAlgorithms :: [Result HashAlgorithm]+ }+ deriving (Generic)++data RevocationStatus+ = RevocationStatus+ { isRevoked :: Bool+ , revocationCode :: String+ , revocationReason :: Text+ }+ deriving (Generic)++instance A.ToJSON KAS++instance A.ToJSON Color++instance (A.ToJSON a) => A.ToJSON (Result a)++instance A.ToJSON KeyReport++instance A.ToJSON UIDReport++instance A.ToJSON SubkeyReport++instance A.ToJSON SubkeyRevocationDigestWarning++instance A.ToJSON CrossCertReport++instance A.ToJSON RevocationStatus++instance Semigroup UIDReport where+ (<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') =+ UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e')++instance Monoid UIDReport where+ mempty = UIDReport [] [] [] [] []+ mappend = (<>)++checkKey :: LintPolicy TKUnknown KeyReport+checkKey = LintPolicy $ \tk mpt -> checkKey' mpt tk++checkKey' :: Maybe POSIXTime -> TKUnknown -> Result KeyReport+checkKey' mpt tk =+ kr+ <$ sequenceA_+ [ void (keyStatus kr)+ , void (keyFingerprint kr)+ , void (keyVer kr)+ , void (keyAlgorithmAndSize kr)+ , void (keyHasEncryptionCapableSubkey kr)+ , traverse_ void (keySubkeys kr)+ , traverse_ void (keyUIDsAndUAts kr)+ ]+ where+ kr =+ KeyReport+ { keyStatus = pure (either id (const "good") procResult)+ , keyFingerprint = pure (fingerprint primaryKey)+ , keyVer = colorizeKV (_keyVersion primaryKey)+ , keyCreationTime = pure (_timestamp primaryKey)+ , keyAlgorithmAndSize = kasIt primaryKey+ , keyUIDsAndUAts = uidMap+ , keyBestOf = populateBestOf uidMap+ , keySubkeys = subkeys+ , keyHasEncryptionCapableSubkey =+ hasEncryptionCapableSubkey+ (concatMap (skUsageFlags . getResult) subkeys)+ }+ uidMap =+ Map.fromListWith (liftA2 (<>)) $+ map+ (\(x, y) -> (x, uidr (Just x) y))+ (processedTK ^. tkuUIDs)+ ++ 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+ uidr :: Maybe Text -> [SignaturePayload] -> Result UIDReport+ uidr Nothing sps =+ UIDReport+ <$> pure (has sps)+ <*> pure (map phas sps)+ <*> pure+ ( map+ ( colorizeKETs+ (fromMaybe 0 mpt)+ (unThirtyTwoBitTimeStamp (_timestamp primaryKey))+ . getKeyExpirationTimesFromSignature+ )+ sps -- should that be 0?+ )+ <*> pure (kufs False sps)+ <*> pure (findRevocationReason sps)+ uidr (Just u) sps =+ colorizeUID+ u+ ( UIDReport+ (has sps)+ (map phas sps)+ ( map+ ( colorizeKETs+ (fromMaybe 0 mpt)+ (unThirtyTwoBitTimeStamp (_timestamp primaryKey))+ . getKeyExpirationTimesFromSignature+ )+ sps -- should that be 0?+ )+ (kufs False sps)+ (findRevocationReason sps)+ )+ kasIt :: SomePKPayload -> Result KAS+ kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize)+ kasIt' :: PubKeyAlgorithm -> Either String Int -> Result KAS+ kasIt' pka epks =+ let pr = colorizePKA pka+ prs = colorizePKS pka epks+ strRep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka)+ in colored+ (max (resultColor pr) (resultColor prs))+ (resultFindings pr <> resultFindings prs)+ (KAS pr prs strRep)+ colorizeKV :: KeyVersion -> Result KeyVersion+ colorizeKV kv+ | kv `elem` [V4, V6] = withColor (Just Green) kv+ | otherwise =+ colored (Just Red) (Just ["not a V4 or V6 key"]) kv+ colorizePKA :: PubKeyAlgorithm -> Result PubKeyAlgorithm+ colorizePKA pka+ | pka `elem` [RSA, EdDSA, ECDH, X25519, X448] -- FIXME: incomplete+ =+ colored (Just Green) Nothing pka+ | otherwise =+ colored+ (Just Yellow)+ (Just ["public key algorithm neither RSA nor EdDSA"])+ pka+ colorizePKS+ :: PubKeyAlgorithm -> Either String Int -> Result (Maybe Int)+ colorizePKS pka (Right pks)+ -- Group 256-bit ECC curves+ | pka `elem` [X25519, ECDH, EdDSA] && pks >= 256 -- FIXME: incomplete+ =+ withColor (Just Green) (Just pks)+ -- Group 448-bit ECC curves+ | pka `elem` [X448] && pks >= 448 -- FIXME: incomplete+ =+ withColor (Just Green) (Just pks)+ -- Catch-all for undersized ECC curves+ | pka `elem` [X25519, X448, ECDH, EdDSA] -- FIXME: incomplete+ =+ colored+ (Just Yellow)+ (Just ["Public key size insufficient for ECC algorithm"])+ (Just pks)+ -- RSA size checks+ | pka == RSA && pks >= 3072 =+ withColor (Just Green) (Just pks)+ | pka == RSA && pks >= 2048 =+ colored+ (Just Yellow)+ (Just ["Public key size between 2048 and 3072 bits"])+ (Just pks)+ | pka == RSA =+ colored+ (Just Red)+ (Just ["Public key size under 2048 bits"])+ (Just pks)+ -- Fallback for unknown algorithms but known sizes+ | otherwise =+ pure (Just pks)+ colorizePKS _ (Left _) =+ colored+ (Just Red)+ (Just ["public key algorithm not understood"])+ Nothing+ colorizePHAs :: [HashAlgorithm] -> Result [HashAlgorithm]+ colorizePHAs x+ | preferredWeakHash x =+ colored (Just Red) (Just ["weak hash with higher preference"]) x+ | otherwise = withColor (Just Green) x+ fSHA2or3Family =+ fi (`elem` [SHA512, SHA384, SHA256, SHA224, SHA3_512, SHA3_256])+ firstStrongSHA2or3 xs = fSHA2or3Family xs+ preferredWeakHash xs =+ any+ ( \ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2or3 xs+ )+ knownWeakHashAlgorithms+ fi x y = fromMaybe maxBound (findIndex x y)+ colorizeKETs ct ts kes+ | null kes = colored (Just Red) (Just ["no expiration set"]) kes+ | any (\ke -> realToFrac ts + realToFrac ke < ct) kes =+ colored (Just Red) (Just ["expiration passed"]) kes+ | any+ (\ke -> realToFrac ts + realToFrac ke > ct + (5 * 31557600))+ kes =+ colored (Just Yellow) (Just ["expiration too far in future"]) kes+ | otherwise = colored (Just Green) Nothing kes+ eoki pkp+ | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp+ | _keyVersion pkp == DeprecatedV3+ && elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =+ hush . eightOctetKeyID $ pkp+ | otherwise = Nothing+ phas sig =+ colorizePHAs+ ( concatMap+ ( \case+ SigSubPacket _ (PreferredHashAlgorithms x) -> x+ _ -> []+ )+ (filter isPHA (hasheds sig))+ )+ has = map (colorizeHA . hashAlgo) . alleged+ colorizeHA :: HashAlgorithm -> Result HashAlgorithm+ colorizeHA ha+ | isKnownWeakHashAlgorithm ha =+ colored (Just Red) (Just ["weak hash algorithm"]) ha+ | otherwise = pure ha+ sigcts sig =+ map+ ( \case+ SigSubPacket _ (SigCreationTime x) -> x+ _ -> error "unexpected subpacket type"+ )+ (filter isCT (hasheds sig))+ alleged =+ filter+ ( \sig ->+ primaryFingerprint `elem` sigissuerFPs sig+ || ((==) <$> sigissuer sig <*> eoki primaryKey)+ == Just True+ )+ where+ primaryFingerprint = fingerprint primaryKey+ uatspsToText = T.pack . uatspsToString+ uatspsToString us =+ "<uat:[" ++ intercalate "," (map uaspToString us) ++ "]>"+ uaspToString (ImageAttribute hdr d) =+ hdrToString hdr+ ++ ':'+ : show (BL.length d)+ ++ ':'+ : BC8.unpack+ (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))+ uaspToString (OtherUASub t d) =+ "other-"+ ++ show t+ ++ ':'+ : show (BL.length d)+ ++ ':'+ : BC8.unpack+ (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))+ hdrToString (ImageHV1 JPEG) = "jpeg"+ hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)+ populateBestOf+ :: Map.Map Text (Result UIDReport) -> Maybe UIDReport+ populateBestOf um+ | Map.null um = Nothing+ | otherwise =+ Just+ ( UIDReport+ <$> best . uidSelfSigHashAlgorithms+ <*> best+ . uidPreferredHashAlgorithms+ <*> best+ . uidKeyExpirationTimes+ <*> best+ . uidKeyUsageFlags+ <*> pure []+ $ mconcat (justTheUIDRs um)+ )+ justTheUIDRs = map getResult . Map.elems+ -- Pick the single most favorable Result from a list, for display as+ -- a representative "best of" example.+ --+ -- This doesn't use Ord because there could be a Nothing in the list+ -- and that would be "best".+ --+ -- That also implies that this should get an overhaul.+ best :: [Result a] -> [Result a]+ best = take 1 . sortOn (bestOfRank . resultColor)+ bestOfRank :: Maybe Color -> Int+ bestOfRank (Just Green) = 0+ bestOfRank (Just Yellow) = 1+ bestOfRank (Just Red) = 2+ bestOfRank Nothing = 3+ colorizeUID :: Text -> UIDReport -> Result UIDReport+ colorizeUID u ur =+ let strU = T.unpack u+ check cond msg =+ if cond+ then colored (Just Yellow) (Just [msg]) ()+ else pure ()+ in check ('(' `elem` strU) "parenthesis in uid"+ *> check ('<' `notElem` strU) "no left angle bracket in uid"+ *> pure ur+ findRevocationReason = concatMap grabReasons . filter isCertRevocationSig+ grabReasons (SigV4 CertRevocationSig _ _ hashedSubs _ _ _) =+ mapMaybe (grabReasons' . _sspPayload) hashedSubs+ grabReasons (SigV6 CertRevocationSig _ _ _ hashedSubs _ _ _) =+ mapMaybe (grabReasons' . _sspPayload) hashedSubs+ grabReasons _ = []+ grabReasons' (ReasonForRevocation a b) =+ Just (RevocationStatus True (show a) b)+ grabReasons' _ = Nothing+ kufs s =+ mapMaybe+ ( \sig ->+ case find isKUF (hasheds sig) of+ Just (SigSubPacket _ (KeyFlags x)) -> Just (colorizeKUFs s x)+ _ -> Nothing+ )+ . newestWith (any isKUF . hasheds)+ colorizeKUFs+ :: Bool -> Set.Set KeyFlag -> Result (Set.Set KeyFlag)+ colorizeKUFs False x+ | encrypts && signsOrCertifies =+ colored (Just Yellow) (Just ["both signing & encryption"]) x+ | otherwise = withColor (Just Green) x+ where+ encrypts =+ Set.member EncryptStorageKey x+ || Set.member EncryptCommunicationsKey x+ signsOrCertifies = Set.member SignDataKey x || Set.member CertifyKeysKey x+ colorizeKUFs True x+ | certifies =+ colored (Just Red) (Just ["certification-capable subkey"]) x+ | encryptsAndSigns =+ colored (Just Yellow) (Just ["both signing & encryption"]) x+ | otherwise = withColor (Just Green) x+ where+ certifies = Set.member CertifyKeysKey x+ encryptsAndSigns =+ ( Set.member EncryptStorageKey x+ || Set.member EncryptCommunicationsKey x+ )+ && Set.member SignDataKey x+ sigTime :: SignaturePayload -> ThirtyTwoBitTimeStamp+ sigTime sig = case sigcts sig of+ (t : _) -> t+ [] -> 0+ newestWith p sigs =+ let filtered = filter p sigs+ in if null filtered+ 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+ checkSK _ _ = error "checkSK: unexpected packet type"+ checkSK' pf pkp sigs =+ skr+ <$ sequenceA_+ [ void (skFingerprint skr)+ , void (skVer skr)+ , void (skAlgorithmAndSize skr)+ , traverse_ void (skBindingSigHashAlgorithms skr)+ , traverse_ void (skUsageFlags skr)+ , void (ccPresent (skCrossCerts skr))+ , traverse_ void (ccHashAlgorithms (skCrossCerts skr))+ ]+ where+ skr =+ ( \x -> x {skCrossCerts = ccr (map getResult (skUsageFlags x)) sigs}+ )+ SubkeyReport+ { skFingerprint = colorizeF pf (fingerprint pkp)+ , skVer = colorizeKV (_keyVersion pkp)+ , skCreationTime = _timestamp pkp+ , skAlgorithmAndSize = kasIt pkp+ , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)+ , skRevocationSigWeakDigests =+ subkeyRevocationSigWeakDigests pkp sigs+ , skUsageFlags = kufs True (filter isSKBindingSig sigs)+ , skCrossCerts = CrossCertReport (pure False) []+ }+ hasEncryptionCapableSubkey+ :: [Result (Set.Set KeyFlag)] -> Result Bool+ hasEncryptionCapableSubkey skrs =+ let hasEncryption =+ any+ ( ( \x ->+ Set.member EncryptStorageKey x+ || Set.member EncryptCommunicationsKey x+ )+ . getResult+ )+ skrs+ in if hasEncryption+ then withColor (Just Green) True+ else+ colored+ (Just Red)+ (Just ["no encryption-capable subkey present"])+ False+ embeddedSigs =+ filter isPKBindingSig+ . concatMap getEmbeds+ . filter isSKBindingSig+ getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)+ getEmbeds (SigV6 _ _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)+ getEmbeds _ = []+ getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]+ getEmbed _ = []+ ccr kufs' sigs =+ CrossCertReport+ (colorES kufs' sigs)+ (map (colorizeHA . hashAlgo) sigs)+ colorES :: [Set.Set KeyFlag] -> [SignaturePayload] -> Result Bool+ colorES kufs' sigs =+ let noEmbedded = null (embeddedSigs sigs)+ signCapable = any (Set.member SignDataKey) kufs'+ authCapable = any (Set.member AuthKey) kufs'+ in case (noEmbedded, signCapable, authCapable) of+ (True, True, True) ->+ colored+ (Just Red)+ (Just ["signing- and auth-capable subkey without cross-cert"])+ False+ (True, True, False) ->+ colored+ (Just Red)+ (Just ["signing-capable subkey without cross-cert"])+ False+ (True, False, True) ->+ colored+ (Just Yellow)+ (Just ["auth-capable subkey without cross-cert"])+ False+ _ ->+ withColor (Just Green) True+ colorizeF :: Fingerprint -> Fingerprint -> Result Fingerprint+ colorizeF pf fp+ | pf == fp =+ colored+ (Just Red)+ (Just ["subkey has same fingerprint as primary key"])+ fp+ | otherwise = withColor (Just Green) fp+ subkeyRevocationSigWeakDigests pkp =+ mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp)+ . filter isSubkeyRevocationSignature+ mkSubkeyRevocationSigWeakDigestWarning pkp sig =+ let ha = hashAlgo sig+ in if isKnownWeakHashAlgorithm ha+ then+ Just+ SubkeyRevocationDigestWarning+ { srwHashAlgorithm = ha+ , srwSubkeyFingerprint = renderFingerprint (fingerprint pkp)+ , srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp))+ , srwMessage =+ "subkey revocation signature uses known-weak digest algorithm"+ }+ else Nothing++prettyKeyReport :: POSIXTime -> TKUnknown -> Doc PPA.AnsiStyle+prettyKeyReport cpt tk = do+ let keyReportResult = unPolicy checkKey tk (Just cpt)+ keyReport = getResult keyReportResult+ execWriter $+ tell $+ vsep+ [ pretty "Key has potential validity"+ <> colon+ <+> pretty (getResult (keyStatus keyReport))+ , pretty "Key has fingerprint"+ <> colon+ <+> pretty (SpacedFingerprint (getResult (keyFingerprint keyReport)))+ , pretty "Checking to see if key is OpenPGPv4 or v6"+ <> colon+ <+> coloredToColor (pretty . show) (keyVer keyReport)+ , ( \kas ->+ pretty "Checking the strength of your primary asymmetric key"+ <> colon+ <+> coloredToColor pretty (pubkeyalgo kas)+ <+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)+ )+ (getResult (keyAlgorithmAndSize keyReport))+ , pretty "Checking user-ID- and user-attribute-related items"+ <> colon+ <> mconcat+ ( map+ (uidtrip (getResult (keyCreationTime keyReport)))+ (Map.toList (keyUIDsAndUAts keyReport))+ )+ , pretty "Checking subkeys" <> colon+ , indent+ 2+ ( pretty "one of the subkeys is encryption-capable"+ <> colon+ <+> coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)+ )+ <> mconcat (map subkeyrep (keySubkeys keyReport))+ ]+ <> linebreak+ where+ coloredToColor f (Result (Just Green) _ x) = green (f x)+ coloredToColor f (Result (Just Yellow) _ x) = yellow (f x)+ coloredToColor f (Result (Just Red) _ x) = red (f x)+ coloredToColor f (Result Nothing _ x) = f x+ uidtrip ts (uText, r@(Result _ _ ur))+ | null (uidRevocationStatus ur) =+ linebreak+ <> indent 2 (coloredToColor pretty (T.unpack uText <$ r))+ <> colon+ <> linebreak+ <> indent+ 4+ ( pretty "Self-sig hash algorithms"+ <> colon+ <+> (list . map (coloredToColor pretty) . uidSelfSigHashAlgorithms)+ ur+ )+ <> linebreak+ <> indent+ 4+ ( pretty "Preferred hash algorithms"+ <> colon+ <+> mconcat+ (map (coloredToColor pretty) (uidPreferredHashAlgorithms ur))+ )+ <> linebreak+ <> indent+ 4+ ( pretty "Key expiration times"+ <> colon+ <+> mconcat+ ( map+ (coloredToColor list . fmap (map (pretty . keyExp ts)))+ (uidKeyExpirationTimes ur)+ )+ )+ <> linebreak+ <> indent+ 4+ ( pretty "Key usage flags"+ <> colon+ <+> (list . map (coloredToColor (pretty . Set.toList)))+ (uidKeyUsageFlags ur)+ )+ | otherwise =+ linebreak+ <> indent 2 (coloredToColor pretty (T.unpack uText <$ r))+ <> colon+ <+> pretty "[revoked]"+ <> linebreak+ <> indent+ 4+ ( pretty "Revocation code"+ <> colon+ <+> list (map (pretty . revocationCode) (uidRevocationStatus ur))+ )+ <> linebreak+ <> indent+ 4+ ( pretty "Revocation reason"+ <> colon+ <+> list+ ( map+ (pretty . T.unpack . revocationReason)+ (uidRevocationStatus ur)+ )+ )+ keyExp ts ke =+ (show . pretty) ke+ ++ " = "+ ++ formatTime+ defaultTimeLocale+ "%c"+ (posixSecondsToUTCTime (realToFrac ts + realToFrac ke))+ subkeyrep skrResult =+ let skr = getResult skrResult+ in subkeydetail skr+ subkeydetail skr =+ linebreak+ <> indent+ 2+ ( pretty "fpr"+ <> colon+ <+> coloredToColor+ pretty+ (fmap SpacedFingerprint (skFingerprint skr))+ )+ <> linebreak+ <> indent+ 4+ (pretty "version" <> colon <+> coloredToColor pretty (skVer skr))+ <> linebreak+ <> indent+ 4+ (pretty "timestamp" <> colon <+> pretty (skCreationTime skr))+ <> linebreak+ <> indent+ 4+ ( ( \kas ->+ pretty "algo/size"+ <> colon+ <+> coloredToColor pretty (pubkeyalgo kas)+ <+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)+ )+ (getResult (skAlgorithmAndSize skr))+ )+ <> linebreak+ <> indent+ 4+ ( pretty "binding sig hash algorithms"+ <> colon+ <+> (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms)+ skr+ )+ <> linebreak+ <> indent+ 4+ ( pretty "weak subkey revocation digests"+ <> colon+ <+> if null (skRevocationSigWeakDigests skr)+ then pretty "[]"+ else+ list+ ( map+ ( \w ->+ red+ ( pretty (srwHashAlgorithm w)+ <> colon+ <+> pretty (srwSubkeyFingerprint w)+ <> colon+ <+> maybe (pretty "<no-key-id>") pretty (srwSubkeyKeyID w)+ )+ )+ (skRevocationSigWeakDigests skr)+ )+ )+ <> linebreak+ <> indent+ 4+ ( pretty "usage flags"+ <> colon+ <+> (list . map (coloredToColor (pretty . Set.toList)))+ (skUsageFlags skr)+ )+ <> linebreak+ <> indent+ 4+ ( pretty "embedded cross-cert"+ <> colon+ <+> (coloredToColor pretty . ccPresent . skCrossCerts) skr+ )+ <> linebreak+ <> indent+ 4+ ( pretty "cross-cert hash algorithms"+ <> colon+ <+> ( list+ . map (coloredToColor pretty)+ . ccHashAlgorithms+ . skCrossCerts+ )+ skr+ )++jsonReport :: POSIXTime -> TKUnknown -> BL.ByteString+jsonReport ps tk = A.encode (getResult (unPolicy checkKey tk (Just ps)))++yamlReport :: POSIXTime -> TKUnknown -> B.ByteString+yamlReport ps tk = Y.encode . (: []) $ getResult (unPolicy checkKey tk (Just ps))++doLint :: LintOptions -> IO ()+doLint o = do+ cpt <- getPOSIXTime+ keys <-+ runConduitRes $+ CB.sourceHandle stdin+ .| conduitGet get+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CL.consume+ output (lintOutputFormat o) cpt keys+ where+ output Pretty cpt = mapM_ (PPA.putDoc . prettyKeyReport cpt)+ output JSON cpt =+ mapM_+ (BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt)+ output YAML cpt = mapM_ (B.putStr . yamlReport cpt)++sigissuer :: SignaturePayload -> Maybe EightOctetKeyId+getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId+hashAlgo :: SignaturePayload -> HashAlgorithm+sigissuer (SigVOther 2 _) = Nothing+sigissuer SigV3 {} = Nothing+sigissuer (SigV4 _ _ _ ys xs _ _) =+ let issuers = mapMaybe (getIssuer . _sspPayload) (ys ++ xs)+ in case nub issuers of+ [issuer] -> Just issuer+ _ -> Nothing+sigissuer (SigV6 {}) = Nothing -- v6 signatures are forbidden from carrying Issuer subpackets; see sigissuerFPs+sigissuer (SigVOther _ _) = Nothing++getIssuer (Issuer i) = Just i+getIssuer _ = Nothing++sigissuerFPs :: SignaturePayload -> [Fingerprint]+sigissuerFPs (SigV4 _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)+sigissuerFPs (SigV6 _ _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)+sigissuerFPs _ = []++getIssuerFP :: SigSubPacketPayload -> Maybe Fingerprint+getIssuerFP (IssuerFingerprint _ fp) = Just fp+getIssuerFP _ = Nothing++hashAlgo (SigV3 _ _ _ _ x _ _) = x+hashAlgo (SigV4 _ _ x _ _ _ _) = x+hashAlgo (SigV6 _ _ x _ _ _ _ _) = x+hashAlgo (SigVOther _ _) = OtherHA 0++knownWeakHashAlgorithms :: [HashAlgorithm]+knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]++isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool+isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms++isSubkeyRevocationSignature :: SignaturePayload -> Bool+isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig+isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig+isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig+isSubkeyRevocationSignature _ = False++hasheds :: SignaturePayload -> [SigSubPacket]+hasheds (SigV4 _ _ _ xs _ _ _) = xs+hasheds (SigV6 _ _ _ _ xs _ _ _) = xs+hasheds _ = []
HOpenPGP/Tools/Hokey/Options.hs view
@@ -17,130 +17,157 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. module HOpenPGP.Tools.Hokey.Options- (- -- CanonicalizeOptions- FetchOptions(..)- , InjectSSHAgentOptions(..)- , LintOptions(..)- , fetchO- , injectSSHAgentO- , lintO- , FetchMethod(..)- , LintOutputFormat(..)- ) where+ ( -- CanonicalizeOptions+ FetchOptions (..)+ , InjectSSHAgentOptions (..)+ , LintOptions (..)+ , fetchO+ , injectSSHAgentO+ , lintO+ , FetchMethod (..)+ , LintOutputFormat (..)+ ) where import Codec.Encryption.OpenPGP.Serialize () import Control.Applicative (optional)-import HOpenPGP.Tools.Common.HKP (FetchValidationMethod(..))- import Options.Applicative.Builder- ( argument- , auto- , help- , helpDoc- , long- , metavar- , option- , showDefault- , str- , value- )+ ( argument+ , auto+ , help+ , helpDoc+ , long+ , metavar+ , option+ , showDefault+ , str+ , value+ ) import Options.Applicative.Types (Parser) import Prettyprinter- ( hardline- , list- , pretty- )+ ( hardline+ , list+ , pretty+ ) +import HOpenPGP.Tools.Common.HKP (FetchValidationMethod (..))+ data LintOutputFormat- = Pretty- | JSON- | YAML- deriving (Bounded, Enum, Eq, Read, Show)+ = Pretty+ | JSON+ | YAML+ deriving (Bounded, Enum, Eq, Read, Show) -data LintOptions =- LintOptions+data LintOptions+ = LintOptions { lintOutputFormat :: LintOutputFormat } -data FetchOptions =- FetchOptions+data FetchOptions+ = FetchOptions { keyServer :: String , fetchMethod :: FetchMethod , fetchValidation :: FetchValidationMethod , fetchQuery :: String } -data InjectSSHAgentOptions =- InjectSSHAgentOptions+data InjectSSHAgentOptions+ = InjectSSHAgentOptions { injectSSHAgentFromFD :: Maybe Int , injectSSHAgentSocket :: Maybe String , injectSSHAgentComment :: Maybe String } data FetchMethod- = HKP- | WKD- deriving (Bounded, Enum, Eq, Read, Show)+ = HKP+ | WKD+ deriving (Bounded, Enum, Eq, Read, Show) lintO :: Parser LintOptions lintO =- LintOptions <$>- option- auto- (long "output-format" <> metavar "FORMAT" <> value Pretty <> showDefault <>- ofHelp)+ LintOptions+ <$> option+ auto+ ( long "output-format"+ <> metavar "FORMAT"+ <> value Pretty+ <> showDefault+ <> ofHelp+ ) where ofHelp =- helpDoc . Just $ pretty "output format" <> hardline <>- list (map (pretty . show) ofchoices)+ helpDoc . Just $+ pretty "output format"+ <> hardline+ <> list (map (pretty . show) ofchoices) ofchoices = [minBound .. maxBound] :: [LintOutputFormat] fetchO :: Parser FetchOptions fetchO =- FetchOptions <$>- option- str- (long "keyserver" <> metavar "URL" <>- value "http://pool.sks-keyservers.net:11371" <>- showDefault <>- help "HKP server (used only when --method=HKP)") <*>- option- auto- (long "method" <> metavar "METHOD" <> value HKP <> showDefault <> fmHelp) <*>- option- auto- (long "validation-method" <> metavar "METHOD" <>- value MatchPrimaryKeyFingerprint <>- showDefault <>- vmHelp) <*>- argument str (metavar "QUERY")+ FetchOptions+ <$> option+ str+ ( long "keyserver"+ <> metavar "URL"+ <> value "http://pool.sks-keyservers.net:11371"+ <> showDefault+ <> help "HKP server (used only when --method=HKP)"+ )+ <*> option+ auto+ ( long "method"+ <> metavar "METHOD"+ <> value HKP+ <> showDefault+ <> fmHelp+ )+ <*> option+ auto+ ( long "validation-method"+ <> metavar "METHOD"+ <> value MatchPrimaryKeyFingerprint+ <> showDefault+ <> vmHelp+ )+ <*> argument str (metavar "QUERY") where fmHelp =- helpDoc . Just $ pretty "fetch method" <> hardline <>- list (map (pretty . show) fmchoices)+ helpDoc . Just $+ pretty "fetch method"+ <> hardline+ <> list (map (pretty . show) fmchoices) fmchoices = [minBound .. maxBound] :: [FetchMethod] vmHelp =- helpDoc . Just $ pretty "validation method" <> hardline <>- list (map (pretty . show) vmchoices)+ helpDoc . Just $+ pretty "validation method"+ <> hardline+ <> list (map (pretty . show) vmchoices) vmchoices = [minBound .. maxBound] :: [FetchValidationMethod] injectSSHAgentO :: Parser InjectSSHAgentOptions injectSSHAgentO =- InjectSSHAgentOptions <$>- optional- (option- auto- (long "from-fd" <>- metavar "FD" <>- help "read binary gpg --export-secret-keys bytes from this already-open file descriptor")) <*>- optional- (option- str- (long "ssh-agent-socket" <>- metavar "PATH" <> help "path to ssh-agent socket (defaults to SSH_AUTH_SOCK)")) <*>- optional- (option- str- (long "comment" <>- metavar "TEXT" <> help "comment string stored with the injected SSH identity"))+ InjectSSHAgentOptions+ <$> optional+ ( option+ auto+ ( long "from-fd"+ <> metavar "FD"+ <> help+ "read binary gpg --export-secret-keys bytes from this already-open file descriptor"+ )+ )+ <*> optional+ ( option+ str+ ( long "ssh-agent-socket"+ <> metavar "PATH"+ <> help "path to ssh-agent socket (defaults to SSH_AUTH_SOCK)"+ )+ )+ <*> optional+ ( option+ str+ ( long "comment"+ <> metavar "TEXT"+ <> help "comment string stored with the injected SSH identity"+ )+ )
hkt.hs view
@@ -15,26 +15,33 @@ -- -- 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 DeriveGeneric #-} -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)+import Codec.Encryption.OpenPGP.Fingerprint+ ( eightOctetKeyID+ , fingerprint+ )+import Codec.Encryption.OpenPGP.KeyInfo+ ( pkalgoAbbrev+ , pubkeySize+ ) import Codec.Encryption.OpenPGP.KeySelection- ( parseEightOctetKeyId- , parseFingerprint- )+ ( parseEightOctetKeyId+ , parseFingerprint+ ) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Signatures- ( verifyAgainstKeyring- , verifySigWith- , verifyUnknownTKWith- )+ ( verifyAgainstKeyring+ , verifySigWith+ , verifyUnknownTKWith+ ) import Codec.Encryption.OpenPGP.Types-import Control.Applicative ((<|>), optional)+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.Monad.Trans.Except (except, runExcept) import Control.Monad.Trans.Resource (MonadResource, MonadThrow) import qualified Data.Aeson as A@@ -42,24 +49,33 @@ import Data.Binary.Put (runPut) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.Conduit (ConduitM, (.|), runConduitRes)+import Data.Conduit (ConduitM, runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Filter- ( FilterPredicates(RTKFilterPredicate)- , conduitTKFilter- )+ ( FilterPredicates (RTKFilterPredicate)+ , conduitTKFilter+ ) import Data.Conduit.OpenPGP.Keyring- ( conduitToTKsDropping- , sinkPublicKeyringMap- )+ ( conduitToTKsDroppingEither+ , sinkPublicKeyringMap+ ) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Data.Lens (biplate) import Data.Either (rights)-import Data.Graph.Inductive.Graph (Graph(mkGraph), Path, emap, prettyPrint)+import Data.Graph.Inductive.Graph+ ( Graph (mkGraph)+ , Path+ , emap+ , prettyPrint+ ) import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Graph.Inductive.Query.SP (sp)-import Data.GraphViz (GraphvizParams(..), graphToDot, nonClusteredParams)+import Data.GraphViz+ ( GraphvizParams (..)+ , graphToDot+ , nonClusteredParams+ ) import Data.GraphViz.Attributes (toLabel) import Data.GraphViz.Types (printDotGraph) import Data.HashMap.Lazy (HashMap)@@ -71,119 +87,156 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy.IO as TLIO-import Data.Void (Void)-import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)+import Data.Time.Clock.POSIX+ ( getPOSIXTime+ , posixSecondsToUTCTime+ ) import Data.Tuple (swap)+import Data.Void (Void) import qualified Data.Yaml as Y import GHC.Generics-import HOpenPGP.Tools.Common.Common- ( banner- , keyMatchesEightOctetKeyId- , keyMatchesFingerprint- , keyMatchesUIDSubString- , versioner- , warranty- )-import HOpenPGP.Tools.Common.Parser (parseTKExp)-import System.Directory (getHomeDirectory)-import System.Exit (exitFailure) import Options.Applicative.Builder- ( argument- , auto- , command- , footerDoc- , headerDoc- , help- , helpDoc- , info- , long- , metavar- , option- , prefs- , progDesc- , showDefault- , showHelpOnError- , str- , strOption- , switch- , value- )-import Options.Applicative.Extra (customExecParser, helper, hsubparser)+ ( argument+ , auto+ , command+ , footerDoc+ , headerDoc+ , help+ , helpDoc+ , info+ , long+ , metavar+ , option+ , prefs+ , progDesc+ , showDefault+ , showHelpOnError+ , str+ , strOption+ , switch+ , value+ )+import Options.Applicative.Extra+ ( customExecParser+ , helper+ , hsubparser+ ) import Options.Applicative.Types (Parser)-+import Prettyprinter+ ( defaultLayoutOptions+ , fillSep+ , hardline+ , layoutPretty+ , list+ , pretty+ , (<+>)+ ) import Prettyprinter.Render.Text (hPutDoc, putDoc)-import Prettyprinter ((<+>), fillSep, hardline, list, pretty) import qualified Prettyprinter.Render.Text as PPA-import Prettyprinter (layoutPretty, defaultLayoutOptions)-import System.IO (BufferMode(..), Handle, hFlush, hPutStrLn, hSetBuffering, stderr)+import System.Directory (getHomeDirectory)+import System.Exit (exitFailure)+import System.IO+ ( BufferMode (..)+ , Handle+ , hFlush+ , hPutStrLn+ , hSetBuffering+ , stderr+ ) -grabMatchingKeysConduit ::- (MonadResource m, MonadThrow m)- => FilePath- -> Bool- -> FilterPredicates Void TKUnknown- -> Text- -> ConduitM () TKUnknown m ()+import HOpenPGP.Tools.Common.Common+ ( banner+ , keyMatchesEightOctetKeyId+ , keyMatchesFingerprint+ , keyMatchesUIDSubString+ , versioner+ , warranty+ )+import HOpenPGP.Tools.Common.Parser (parseTKExp)++grabMatchingKeysConduit+ :: (MonadResource m, MonadThrow m)+ => FilePath+ -> Bool+ -> FilterPredicates Void TKUnknown+ -> Text+ -> ConduitM () TKUnknown m () grabMatchingKeysConduit fp filt ufp srch =- CB.sourceFile fp .| conduitGet get .| conduitToTKsDropping .|- (if filt- then conduitTKFilter ufp- else CL.filter matchAny)+ CB.sourceFile fp+ .| conduitGet get+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| ( if filt+ then conduitTKFilter ufp+ else CL.filter matchAny+ ) where matchAny tk =- either (const False) id $ runExcept $ fmap (keyMatchesFingerprint True tk) efp <|>- fmap (keyMatchesEightOctetKeyId True tk . Right) eeok <|>- return (keyMatchesUIDSubString srch tk)+ either (const False) id $+ runExcept $+ fmap (keyMatchesFingerprint True tk) efp+ <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok+ <|> return (keyMatchesUIDSubString srch tk) efp = (except . parseFingerprint) srch eeok = (except . parseEightOctetKeyId) srch grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TKUnknown] grabMatchingKeys fp filt srch =- if filt- then do- parsed <- parseFilterPredicateIO srch- case parsed of- Left err -> dieHKT err- Right ufp -> runConduitRes $ grabMatchingKeysConduit fp filt ufp srch .| CL.consume- else- -- When not using filter syntax, treat TARGET as a fingerprint, key ID or UID substring- runConduitRes $- CB.sourceFile fp .| conduitGet get .| conduitToTKsDropping .| CL.filter matchAny .| CL.consume+ if filt+ then do+ parsed <- parseFilterPredicateIO srch+ case parsed of+ Left err -> dieHKT err+ Right ufp ->+ runConduitRes $+ grabMatchingKeysConduit fp filt ufp srch .| CL.consume+ else+ -- When not using filter syntax, treat TARGET as a fingerprint, key ID or UID substring+ runConduitRes $+ CB.sourceFile fp+ .| conduitGet get+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CL.filter matchAny+ .| CL.consume where matchAny tk =- either (const False) id $ runExcept $ fmap (keyMatchesFingerprint True tk) efp <|>- fmap (keyMatchesEightOctetKeyId True tk . Right) eeok <|>- return (keyMatchesUIDSubString srch tk)+ either (const False) id $+ runExcept $+ fmap (keyMatchesFingerprint True tk) efp+ <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok+ <|> return (keyMatchesUIDSubString srch tk) efp = (except . parseFingerprint) srch eeok = (except . parseEightOctetKeyId) srch grabMatchingPublicKeyring :: [TKUnknown] -> IO PublicKeyring grabMatchingPublicKeyring keys =- runConduitRes $- CL.sourceList (mapMaybe unknownToPublicTK keys) .| sinkPublicKeyringMap+ runConduitRes $+ CL.sourceList (mapMaybe unknownToPublicTK keys)+ .| sinkPublicKeyringMap where unknownToPublicTK tk =- case fromUnknownToTK tk of- Right (SomePublicTK publicTk) -> Just publicTk- Right (SomeSecretTK secretTk) -> Just (publicViewTK secretTk)- Left _ -> Nothing+ case fromUnknownToTK tk of+ Right (SomePublicTK publicTk) -> Just publicTk+ Right (SomeSecretTK secretTk) -> Just (publicViewTK secretTk)+ Left _ -> Nothing -data Key =- Key+data Key+ = Key { keysize :: Maybe Int , keyalgo :: String , keyalgoabbreviation :: String , fpr :: String }- deriving (Generic)+ deriving (Generic) -data TKey =- TKey+data TKey+ = TKey { publickey :: Key , uids :: [Text] , subkeys :: [Key] }- deriving (Generic)+ deriving (Generic) instance A.ToJSON Key @@ -191,48 +244,66 @@ tkToTKey :: TKUnknown -> TKey tkToTKey tk =- TKey- { publickey = mkey (tk ^. tkuKey . _1)- , uids = tk ^. tkuUIDs ^.. traverse . _1- , subkeys = mapMaybe (\t -> case t of- (PublicSubkeyPkt x, _) -> Just (mkey x)- (SecretSubkeyPkt x _, _) -> Just (mkey x)- _ -> Nothing) (tk ^. tkuSubs)- }+ TKey+ { publickey = mkey (tk ^. tkuKey . _1)+ , uids = tk ^. tkuUIDs ^.. traverse . _1+ , subkeys =+ mapMaybe+ ( \t -> case t of+ (PublicSubkeyPkt x, _) -> Just (mkey x)+ (SecretSubkeyPkt x _, _) -> Just (mkey x)+ _ -> Nothing+ )+ (tk ^. tkuSubs)+ } where mkey =- Key <$> either (const Nothing) Just . pubkeySize . _pubkey <*> show .- _pkalgo <*>- pkalgoAbbrev .- _pkalgo <*>- renderFingerprint .- fingerprint+ Key+ <$> either (const Nothing) Just . pubkeySize . _pubkey+ <*> show+ . _pkalgo+ <*> pkalgoAbbrev+ . _pkalgo+ <*> renderFingerprint+ . fingerprint showTKey :: TKey -> IO ()-showTKey key =- putDoc $ pretty "pub " <+> sizeabbrevkeyid (publickey key) <> hardline <>- mconcat- (map- (\x ->- pretty "uid " <+> pretty (T.unpack x) <>- hardline)- (uids key)) <>- mconcat- (map (\x -> pretty "sub " <+> sizeabbrevkeyid x <> hardline) (subkeys key)) <>- hardline+showTKey tkey =+ putDoc $+ pretty "pub "+ <+> sizeabbrevkeyid (publickey tkey)+ <> hardline+ <> mconcat+ ( map+ ( \x ->+ pretty "uid "+ <+> pretty (T.unpack x)+ <> hardline+ )+ (uids tkey)+ )+ <> mconcat+ ( map+ (\x -> pretty "sub " <+> sizeabbrevkeyid x <> hardline)+ (subkeys tkey)+ )+ <> hardline where sizeabbrevkeyid k =- pretty (maybe "unknown" show (keysize k)) <>- pretty (keyalgoabbreviation k) <>- pretty "/" <>- pretty (fpr k)+ pretty (maybe "unknown" show (keysize k))+ <> pretty (keyalgoabbreviation k)+ <> pretty "/"+ <> pretty (fpr k) renderFingerprint :: Fingerprint -> String renderFingerprint =- T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty+ T.unpack+ . PPA.renderStrict+ . layoutPretty defaultLayoutOptions+ . pretty -data Options =- Options+data Options+ = Options { keyring :: String , graphOutputFormat :: GraphOutputFormat , pathsOutputFormat :: PathsOutputFormat@@ -243,215 +314,265 @@ } data Command- = CmdList Options- | CmdExportPubkeys Options- | CmdGraph Options- | CmdFindPaths Options+ = CmdList Options+ | CmdExportPubkeys Options+ | CmdGraph Options+ | CmdFindPaths Options data GraphOutputFormat- = GraphViz- | LossyPretty- deriving (Bounded, Enum, Eq, Read, Show)+ = GraphViz+ | LossyPretty+ deriving (Bounded, Enum, Eq, Read, Show) data PathsOutputFormat- = Unstructured- | JSON- | YAML- deriving (Eq, Read, Show)+ = Unstructured+ | JSON+ | YAML+ deriving (Eq, Read, Show) listO :: String -> Parser Options-listO homedir =- Options <$>- strOption (long "keyring" <> metavar "FILE" <> help "file containing keyring") <*>- pure GraphViz -- unused- <*>- option- auto- (long "output-format" <> metavar "FORMAT" <> value Unstructured <>- showDefault <>- help "output format") <*>- switch (long "filter" <> help "treat target as filter") <*>- (fromMaybe "" <$> optional (argument str (metavar "TARGET" <> targetHelp))) <*>- pure "" <*>- pure ""+listO _ =+ Options+ <$> strOption+ ( long "keyring"+ <> metavar "FILE"+ <> help "file containing keyring"+ )+ <*> pure GraphViz -- unused+ <*> option+ auto+ ( long "output-format"+ <> metavar "FORMAT"+ <> value Unstructured+ <> showDefault+ <> help "output format"+ )+ <*> switch (long "filter" <> help "treat target as filter")+ <*> ( fromMaybe ""+ <$> optional (argument str (metavar "TARGET" <> targetHelp))+ )+ <*> pure ""+ <*> pure "" where targetHelp =- helpDoc . Just $ pretty "target (which keys to output)*"+ helpDoc . Just $ pretty "target (which keys to output)*" graphO :: String -> Parser Options-graphO homedir =- Options <$>- strOption (long "keyring" <> metavar "FILE" <> help "file containing keyring") <*>- option- auto- (long "output-format" <> metavar "FORMAT" <> value GraphViz <> showDefault <>- ofhelp) <*>- pure Unstructured -- unused- <*>- switch (long "filter" <> help "treat target as filter") <*>- (fromMaybe "" <$> optional (argument str (metavar "TARGET" <> targetHelp))) <*>- pure "" <*>- pure ""+graphO _homedir =+ Options+ <$> strOption+ ( long "keyring"+ <> metavar "FILE"+ <> help "file containing keyring"+ )+ <*> option+ auto+ ( long "output-format"+ <> metavar "FORMAT"+ <> value GraphViz+ <> showDefault+ <> ofhelp+ )+ <*> pure Unstructured -- unused+ <*> switch (long "filter" <> help "treat target as filter")+ <*> ( fromMaybe ""+ <$> optional (argument str (metavar "TARGET" <> targetHelp))+ )+ <*> pure ""+ <*> pure "" where ofhelp =- helpDoc . Just $ pretty "output format" <> hardline <>- list (map (pretty . show) ofchoices)+ helpDoc . Just $+ pretty "output format"+ <> hardline+ <> list (map (pretty . show) ofchoices) ofchoices = [minBound .. maxBound] :: [GraphOutputFormat] targetHelp =- helpDoc . Just $ pretty "target (which keys to graph)*"+ helpDoc . Just $ pretty "target (which keys to graph)*" findPathsO :: String -> Parser Options-findPathsO homedir =- Options <$>- strOption (long "keyring" <> metavar "FILE" <> help "file containing keyring") <*>- pure GraphViz -- unused- <*>- option- auto- (long "output-format" <> metavar "FORMAT" <> value Unstructured <>- showDefault <>- help "output format") <*>- switch (long "filter" <> help "treat targets as filter") <*>- argument str (metavar "TARGET-SET" <> targetHelp) <*>- argument str (metavar "FROM-KEYS" <> fromHelp) <*>- argument str (metavar "TO-KEYS" <> toHelp)+findPathsO _homedir =+ Options+ <$> strOption+ ( long "keyring"+ <> metavar "FILE"+ <> help "file containing keyring"+ )+ <*> pure GraphViz -- unused+ <*> option+ auto+ ( long "output-format"+ <> metavar "FORMAT"+ <> value Unstructured+ <> showDefault+ <> help "output format"+ )+ <*> switch (long "filter" <> help "treat targets as filter")+ <*> argument str (metavar "TARGET-SET" <> targetHelp)+ <*> argument str (metavar "FROM-KEYS" <> fromHelp)+ <*> argument str (metavar "TO-KEYS" <> toHelp) where targetHelp =- helpDoc . Just $- pretty "target (which keys to use in pathfinding)*"+ helpDoc . Just $+ pretty "target (which keys to use in pathfinding)*" fromHelp =- helpDoc . Just $- pretty "from (which keys to use for the source of paths)*"+ helpDoc . Just $+ pretty "from (which keys to use for the source of paths)*" toHelp =- helpDoc . Just $- pretty "to (which keys to use for the destinations of paths)*"+ helpDoc . Just $+ pretty "to (which keys to use for the destinations of paths)*" dispatch :: Command -> IO () dispatch (CmdList o) = banner' stderr >> hFlush stderr >> doList o dispatch (CmdExportPubkeys o) =- banner' stderr >> hFlush stderr >> doExportPubkeys o+ banner' stderr >> hFlush stderr >> doExportPubkeys o dispatch (CmdGraph o) = banner' stderr >> hFlush stderr >> doGraph o dispatch (CmdFindPaths o) = banner' stderr >> hFlush stderr >> doFindPaths o main :: IO () main = do- hSetBuffering stderr LineBuffering- homedir <- getHomeDirectory- customExecParser- (prefs showHelpOnError)- (info- (helper <*> versioner "hkt" <*> cmd homedir)- (headerDoc (Just (banner "hkt")) <>- progDesc "hOpenPGP Keyring Tool" <>- footerDoc (Just (warranty "hkt")))) >>=- dispatch+ hSetBuffering stderr LineBuffering+ homedir <- getHomeDirectory+ customExecParser+ (prefs showHelpOnError)+ ( info+ (helper <*> versioner "hkt" <*> cmd homedir)+ ( headerDoc (Just (banner "hkt"))+ <> progDesc "hOpenPGP Keyring Tool"+ <> footerDoc (Just (warranty "hkt"))+ )+ )+ >>= dispatch cmd :: String -> Parser Command cmd homedir =- hsubparser- (command- "export-pubkeys"- (info- (CmdExportPubkeys <$> listO homedir)- (progDesc "export matching keys to stdout" <> footerDoc (Just foot))) <>- command- "findpaths"- (info- (CmdFindPaths <$> findPathsO homedir)- (progDesc "find short paths between keys" <> footerDoc (Just foot))) <>- command- "graph"- (info- (CmdGraph <$> graphO homedir)- (progDesc "graph certifications" <> footerDoc (Just foot))) <>- command- "list"- (info- (CmdList <$> listO homedir)- (progDesc "list matching keys" <> footerDoc (Just foot))))+ hsubparser+ ( command+ "export-pubkeys"+ ( info+ (CmdExportPubkeys <$> listO homedir)+ ( progDesc "export matching keys to stdout"+ <> footerDoc (Just foot)+ )+ )+ <> command+ "findpaths"+ ( info+ (CmdFindPaths <$> findPathsO homedir)+ (progDesc "find short paths between keys" <> footerDoc (Just foot))+ )+ <> command+ "graph"+ ( info+ (CmdGraph <$> graphO homedir)+ (progDesc "graph certifications" <> footerDoc (Just foot))+ )+ <> command+ "list"+ ( info+ (CmdList <$> listO homedir)+ (progDesc "list matching keys" <> footerDoc (Just foot))+ )+ ) where foot =- hardline <>- fillSep- [ pretty "*if --filter is not specified, this must be"- , pretty "a fingerprint,"- , pretty "an eight-octet key ID,"- , pretty "or a substring of a UID (including an empty string)"- ] <>- hardline <>- fillSep- [ pretty "if --filter is specified, it must be"- , pretty "something in filter syntax (see source)."- ]+ hardline+ <> fillSep+ [ pretty "*if --filter is not specified, this must be"+ , pretty "a fingerprint,"+ , pretty "an eight-octet key ID,"+ , pretty "or a substring of a UID (including an empty string)"+ ]+ <> hardline+ <> fillSep+ [ pretty "if --filter is specified, it must be"+ , pretty "something in filter syntax (see source)."+ ] banner' :: Handle -> IO ()-banner' h = hPutDoc h (banner "hkt" <> hardline <> warranty "hkt" <> hardline)+banner' h =+ hPutDoc+ h+ (banner "hkt" <> hardline <> warranty "hkt" <> hardline) doList :: Options -> IO () doList o = do- let ttarget1 = T.pack . target1- keys' <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)- let keys = map tkToTKey keys'- case pathsOutputFormat o of- Unstructured -> mapM_ showTKey keys- JSON -> BL.putStr . A.encode $ keys- YAML -> B.putStr . Y.encode $ keys- putStrLn ""+ let ttarget1 = T.pack . target1+ keys' <-+ grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)+ let keys = map tkToTKey keys'+ case pathsOutputFormat o of+ Unstructured -> mapM_ showTKey keys+ JSON -> BL.putStr . A.encode $ keys+ YAML -> B.putStr . Y.encode $ keys+ putStrLn "" doExportPubkeys :: Options -> IO () doExportPubkeys o = do- let ttarget1 = T.pack . target1- keys <- 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+ let ttarget1 = T.pack . target1+ keys <-+ 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 where- putTK' key =- runPut $ do- put (PublicKey (key ^. tkuKey . _1))- mapM_ (put . Signature) (_tkuRevs key)- mapM_ putUid' (_tkuUIDs key)- mapM_ putUat' (_tkuUAts key)- mapM_ putSub' (_tkuSubs key)+ 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) 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 doGraph :: Options -> IO () doGraph o = do- let ttarget1 = T.pack . target1- cpt <- getPOSIXTime- keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)- kr <- grabMatchingPublicKeyring keys- let g =- buildKeyGraph- ((buildMaps &&& id)- (rights- (map- (verifyUnknownTKWith- (verifySigWith (verifyAgainstKeyring kr))- (Just (posixSecondsToUTCTime cpt)))- keys)))- case g of- Left err -> dieHKT err- Right graph ->- case graphOutputFormat o of- LossyPretty -> prettyPrint graph- GraphViz ->- TLIO.putStrLn . printDotGraph . graphToDot nonClusteredLabeledNodesParams $- graph+ let ttarget1 = T.pack . target1+ cpt <- getPOSIXTime+ keys <-+ grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)+ kr <- grabMatchingPublicKeyring keys+ let g =+ buildKeyGraph+ ( (buildMaps &&& id)+ ( rights+ ( map+ ( verifyUnknownTKWith+ (verifySigWith (verifyAgainstKeyring kr))+ (Just (posixSecondsToUTCTime cpt))+ )+ keys+ )+ )+ )+ case g of+ Left err -> dieHKT err+ Right graph ->+ case graphOutputFormat o of+ LossyPretty -> prettyPrint graph+ GraphViz ->+ TLIO.putStrLn+ . printDotGraph+ . graphToDot nonClusteredLabeledNodesParams+ $ graph where nonClusteredLabeledNodesParams =- nonClusteredParams {fmtNode = \(_, l) -> [toLabel $ renderFingerprint l]}+ nonClusteredParams+ { fmtNode = \(_, l) -> [toLabel $ renderFingerprint l]+ } buildMaps :: [TKUnknown] -> (KeyMaps, Int) buildMaps =- foldr mapsInsertions (KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0)+ foldr+ mapsInsertions+ (KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0) -- FIXME: this presumes no keyID collisions in the input-data KeyMaps =- KeyMaps+data KeyMaps+ = KeyMaps { _k2f :: HashMap EightOctetKeyId Fingerprint , _f2i :: HashMap Fingerprint Int , _i2f :: HashMap Int Fingerprint@@ -459,132 +580,167 @@ mapsInsertions :: TKUnknown -> (KeyMaps, Int) -> (KeyMaps, Int) mapsInsertions tk (KeyMaps k2f f2i i2f, i) =- let fp = fingerprint (tk ^. tkuKey . _1)- keyids = rights . map eightOctetKeyID $ (tk ^.. biplate :: [SomePKPayload])- i' = i + 1- k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids- f2i' = HashMap.insert fp i' f2i- i2f' = HashMap.insert i' fp i2f- in (KeyMaps k2f' f2i' i2f', i')+ let fp = fingerprint (tk ^. tkuKey . _1)+ keyids =+ rights . map eightOctetKeyID $+ (tk ^.. biplate :: [SomePKPayload])+ i' = i + 1+ k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids+ f2i' = HashMap.insert fp i' f2i+ i2f' = HashMap.insert i' fp i2f+ in (KeyMaps k2f' f2i' i2f', i') -buildKeyGraph ::- ((KeyMaps, Int), [TKUnknown]) -> Either String (Gr Fingerprint HashAlgorithm)+buildKeyGraph+ :: ((KeyMaps, Int), [TKUnknown])+ -> Either String (Gr Fingerprint HashAlgorithm) buildKeyGraph ((KeyMaps k2f f2i _, _), ks) = do- edges <- fmap concat (mapM tkToEdges ks)- pure (mkGraph nodes (filter (not . samesies) . nub . sort $ edges))+ edges <- fmap concat (mapM tkToEdges ks)+ pure+ (mkGraph nodes (filter (not . samesies) . nub . sort $ edges)) where nodes = map swap . HashMap.toList $ f2i tkToEdges tk = do- target <- lookupNode (fingerprint (tk ^. tkuKey . _1))- mapM (edgeFor target) (mapMaybe (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk))+ target <- lookupNode (fingerprint (tk ^. tkuKey . _1))+ mapM+ (edgeFor target)+ (mapMaybe (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk)) edgeFor target (ha, i) = do- source <- lookupSource i- pure (source, target, ha)+ source <- lookupSource i+ pure (source, target, ha) lookupSource i =- case HashMap.lookup i k2f >>= flip HashMap.lookup f2i of- Just source -> Right source- Nothing ->- Left ("hkt: no source node for signature issuer key ID " ++ show i)+ case HashMap.lookup i k2f >>= flip HashMap.lookup f2i of+ Just source -> Right source+ Nothing ->+ Left+ ("hkt: no source node for signature issuer key ID " ++ show i) lookupNode fp =- case HashMap.lookup fp f2i of- Just node -> Right node- Nothing ->- Left ("hkt: no graph node for fingerprint " ++ renderFingerprint fp)+ case HashMap.lookup fp f2i of+ Just node -> Right node+ Nothing ->+ Left+ ("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))+ concat+ ( (tk ^.. tkuUIDs . traverse . _2)+ ++ (tk ^.. tkuUAts . traverse . _2)+ ) samesies (x, y, _) = x == y -data PaF =- PaF+data PaF+ = PaF { certPaths :: [Path] , keyFingerprints :: Map String Fingerprint }- deriving (Generic)+ deriving (Generic) instance A.ToJSON PaF doFindPaths :: Options -> IO () doFindPaths o = do- let ttarget1 = T.pack . target1- ttarget2 = T.pack . target2- ttarget3 = T.pack . target3- filt = targetIsFilter o- cpt <- getPOSIXTime- keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)- kr <- grabMatchingPublicKeyring keys+ let ttarget1 = T.pack . target1+ ttarget2 = T.pack . target2+ ttarget3 = T.pack . target3+ filt = targetIsFilter o+ cpt <- getPOSIXTime+ keys <-+ grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)+ kr <- grabMatchingPublicKeyring keys -- FIXME: seriously clean this up- filter2 <- parseFilterPredicateIO (ttarget2 o) >>= either dieHKT pure- filter3 <- parseFilterPredicateIO (ttarget3 o) >>= either dieHKT pure- keys1 <-- runConduitRes $ CL.sourceList keys .|- (if filt- then conduitTKFilter filter2- else CL.filter (matchAny (ttarget2 o))) .|- CL.consume- keys2 <-- runConduitRes $ CL.sourceList keys .|- (if filt- then conduitTKFilter filter3- else CL.filter (matchAny (ttarget3 o))) .|- CL.consume- let ((KeyMaps k2f f2i i2f, i), ks) =- (buildMaps &&& id)- (rights- (map- (verifyUnknownTKWith- (verifySigWith (verifyAgainstKeyring kr))- (Just (posixSecondsToUTCTime cpt)))- keys))- keygraph <- either dieHKT pure (buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks))- let keysToIs =- mapMaybe (\x -> HashMap.lookup (fingerprint (x ^. tkuKey . _1)) f2i)- froms = keysToIs keys1- tos = keysToIs keys2- combos = froms >>= \f -> tos >>= \t -> return (f, t)- paths =- map- (\(x, y) ->- fromMaybe [] (sp x y (emap (const (1.0 :: Double)) keygraph)))- combos- paf =- PaF- paths- (Map.fromList- (mapMaybe- (\x -> HashMap.lookup x i2f >>= \y -> return (show x, y))- (nub (sort (concat paths)))))- case pathsOutputFormat o of- Unstructured -- FIXME: do something about this- -> do- putStrLn . unlines $ map (show . ((,) =<< length)) paths- putStrLn . unlines $- map- (\x ->- maybe (show x) renderFingerprint (HashMap.lookup x i2f))- (nub (sort (concat paths)))- JSON -> BL.putStr . A.encode $ paf- YAML -> B.putStr . Y.encode $ paf- putStrLn ""+ filter2 <-+ parseFilterPredicateIO (ttarget2 o) >>= either dieHKT pure+ filter3 <-+ parseFilterPredicateIO (ttarget3 o) >>= either dieHKT pure+ keys1 <-+ runConduitRes $+ CL.sourceList keys+ .| ( if filt+ then conduitTKFilter filter2+ else CL.filter (matchAny (ttarget2 o))+ )+ .| CL.consume+ keys2 <-+ runConduitRes $+ CL.sourceList keys+ .| ( if filt+ then conduitTKFilter filter3+ else CL.filter (matchAny (ttarget3 o))+ )+ .| CL.consume+ let ((KeyMaps k2f f2i i2f, i), ks) =+ (buildMaps &&& id)+ ( rights+ ( map+ ( verifyUnknownTKWith+ (verifySigWith (verifyAgainstKeyring kr))+ (Just (posixSecondsToUTCTime cpt))+ )+ keys+ )+ )+ keygraph <-+ either dieHKT pure (buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks))+ let keysToIs =+ mapMaybe+ (\x -> HashMap.lookup (fingerprint (x ^. tkuKey . _1)) f2i)+ froms = keysToIs keys1+ tos = keysToIs keys2+ combos = froms >>= \f -> tos >>= \t -> return (f, t)+ paths =+ map+ ( \(x, y) ->+ fromMaybe [] (sp x y (emap (const (1.0 :: Double)) keygraph))+ )+ combos+ paf =+ PaF+ paths+ ( Map.fromList+ ( mapMaybe+ (\x -> HashMap.lookup x i2f >>= \y -> return (show x, y))+ (nub (sort (concat paths)))+ )+ )+ case pathsOutputFormat o of+ Unstructured ->+ -- FIXME: do something about this+ do+ putStrLn . unlines $ map (show . ((,) =<< length)) paths+ putStrLn . unlines $+ map+ ( \x ->+ maybe (show x) renderFingerprint (HashMap.lookup x i2f)+ )+ (nub (sort (concat paths)))+ JSON -> BL.putStr . A.encode $ paf+ YAML -> B.putStr . Y.encode $ paf+ putStrLn "" where matchAny srch tk =- either (const False) id $ runExcept $- fmap (keyMatchesFingerprint True tk) ((except . parseFingerprint) srch) <|>- fmap- (keyMatchesEightOctetKeyId True tk . Right)- ((except . parseEightOctetKeyId) srch) <|>- return (keyMatchesUIDSubString srch tk)+ either (const False) id $+ runExcept $+ fmap+ (keyMatchesFingerprint True tk)+ ((except . parseFingerprint) srch)+ <|> fmap+ (keyMatchesEightOctetKeyId True tk . Right)+ ((except . parseEightOctetKeyId) srch)+ <|> return (keyMatchesUIDSubString srch tk) -parseFilterPredicateIO :: Text -> IO (Either String (FilterPredicates Void TKUnknown))+parseFilterPredicateIO+ :: Text -> IO (Either String (FilterPredicates Void TKUnknown)) parseFilterPredicateIO e = do- parsed <-- try (evaluate (RTKFilterPredicate <$> parseTKExp (T.unpack e))) ::- IO (Either ErrorCall (Either String (FilterPredicates Void TKUnknown)))- pure $- case parsed of- Left err -> Left (show err)- Right result -> result+ parsed <-+ try (evaluate (RTKFilterPredicate <$> parseTKExp (T.unpack e)))+ :: IO+ ( Either+ ErrorCall+ (Either String (FilterPredicates Void TKUnknown))+ )+ pure $+ case parsed of+ Left err -> Left (show err)+ Right result -> result dieHKT :: String -> IO a dieHKT msg = hPutStrLn stderr msg >> exitFailure@@ -596,9 +752,9 @@ 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) -- FIXME: what should this be if there are multiple matches? sigissuer (SigV6 _ _ _ _ ys xs _ _) =- listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?+ listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches? sigissuer (SigVOther _ _) = Nothing getIssuer (Issuer i) = Just i
hop.hs view
@@ -15,4929 +15,6057 @@ -- -- 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 DeriveGeneric #-}-{-# LANGUAGE RecordWildCards #-}--import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA-import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..))-import Codec.Encryption.OpenPGP.Compression (decompressPkt, renderCompressionError)-import Codec.Encryption.OpenPGP.Expirations (effectiveKeyPreferencesAt, isTKTimeValid)-import Codec.Encryption.OpenPGP.Encrypt- ( EncryptCompatibilityProfile(..)- , PKESKEncryptError(..)- , PKESKSessionMaterial(..)- , RecipientEncryptRequest(..)- , RecipientEncryptRequestOverrides(..)- , RecipientEncryptResult(..)- , RecipientPKESKVersionStrategy(..)- , RecipientPayloadShape(..)- , defaultRecipientPayloadShape- , encryptForRecipients- , recipientEncryptionTarget- , recipientEncryptionTargetWithStrategy- )-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)-import Codec.Encryption.OpenPGP.Message- ( EncryptMessageOptions(..)- , encryptedPayloadBytes- , RecoveredSessionMaterial(..)- , SessionMaterialExposure(..)- , encryptMessage- , mkClearPayload- , mkPassphrase- )-import Codec.Encryption.OpenPGP.Ontology (isKUF, isPKBindingSig, isSKBindingSig)-import Codec.Encryption.OpenPGP.Policy- ( PKESKVersionPolicy(..)- , defaultDecryptPolicy- , defaultPolicy- , lenientDecryptPolicy- )-import Codec.Encryption.OpenPGP.S2K- ( decodeOpenPGPEncodedSessionKey- , skesk2Key- , skesk2SessionKey- )-import Codec.Encryption.OpenPGP.Serialize (parsePkts)-import Codec.Encryption.OpenPGP.SecretKey- ( decryptPrivateKey- , encryptPrivateKey- )-import qualified Codec.Encryption.OpenPGP.Subpackets as SP-import Codec.Encryption.OpenPGP.Signatures- ( SignError(..)- , renderSignError- , signCertRevocationWithRSA- , signDataWithEd25519- , signDataWithEd25519Legacy- , signDataWithEd25519V6- , signDataWithEd448- , signDataWithEd448V6- , signDataWithRSABuilder- , signKeyRevocationWithRSA- , signDataWithRSAV6- , signUserIDwithRSA- , verifyAgainstKeys- , verifyAgainstKeyring- , verifySigWith- , verifyUnknownTKWith- )-import Codec.Encryption.OpenPGP.Types-import Control.Applicative ((<|>), optional, some, many)-import Control.Error.Util (note)-import Control.Monad ((>=>), forM, forM_, unless, when)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)-import Control.Monad.Trans.Resource (MonadResource, MonadThrow)-import Control.Exception- ( IOException- , SomeException- , catch- , displayException- , evaluate- , throwIO- )-import qualified Crypto.PubKey.Ed25519 as Ed25519-import qualified Crypto.PubKey.Ed448 as Ed448-import qualified Crypto.PubKey.Curve25519 as Curve25519-import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.RSA.PKCS15 as P15-import Crypto.Number.Serialize (i2ospOf_, os2ip)-import Crypto.Random.Types (getRandomBytes)-import Crypto.Error (eitherCryptoError)-import qualified Data.Aeson as A-import qualified Data.Binary as Bin-import Data.Binary.Get (runGet)-import Data.Binary.Put (runPut, putByteString, putLazyByteString, putWord8, putWord16be, putWord32be)-import Data.Bits ((.&.), (.|.), shiftL, shiftR)-import qualified Data.ByteArray as BA-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC8-import Data.Conduit ((.|), fuseBoth, runConduitRes)-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.Combinators as CC-import qualified Data.Conduit.List as CL-import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt-import Data.Conduit.OpenPGP.Decrypt- ( DecryptKeyResolution(..)- , DecryptOutcome(..)- , PKESKRecipientKey(..)- )-import Data.Conduit.OpenPGP.Keyring- ( conduitToTKsDropping- , sinkPublicKeyringMap- )-import Data.Conduit.OpenPGP.Verify (conduitVerify, verifyPacketsBatch)-import Data.Conduit.Serialization.Binary (conduitGet)-import Data.Either (fromRight, isLeft, isRight, rights)-import Data.Bifunctor (first)-import Data.Char (digitToInt, isHexDigit, isSpace, toLower)-import Data.List (find, findIndex, foldl', intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, partition, stripPrefix)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)-import Data.Monoid ((<>))-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Data.Text.Encoding.Error (lenientDecode)-import Data.Time.Clock (UTCTime)-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds)-import Data.Time.Format (defaultTimeLocale, formatTime)-import Data.Time.Format.ISO8601 (iso8601ParseM)-import Data.IORef (IORef, newIORef, atomicModifyIORef')-import qualified Data.Vector as V-import Data.Version (showVersion)-import Data.Word (Word8)-import qualified Data.Yaml as Y-import GHC.Generics-import HOpenPGP.Tools.Common.Armor (doDeArmor)-import HOpenPGP.Tools.Common.Common- ( banner- , keyMatchesEightOctetKeyId- , keyMatchesFingerprint- , keyMatchesUIDSubString- , versioner- , warranty- )-import HOpenPGP.Tools.Common.Parser (parseTKExp)-import HOpenPGP.Tools.Common.TKUtils (processTK)-import Paths_hopenpgp_tools (version)-import System.Exit (exitFailure, exitSuccess, exitWith, ExitCode(..))--import Options.Applicative.Builder- ( argument- , auto- , command- , eitherReader- , footerDoc- , headerDoc- , help- , helpDoc- , info- , long- , metavar- , option- , prefs- , progDesc- , short- , showDefault- , showHelpOnError- , str- , strArgument- , strOption- , switch- , value- )-import Options.Applicative.Extra (customExecParser, helper, hsubparser)-import Options.Applicative.Types (Parser)-import Text.Read (readMaybe)--import Prettyprinter- ( (<+>)- , fillSep- , hardline- , list- , pretty- , softline- )-import Prettyprinter.Render.Text (hPutDoc)-import System.IO (BufferMode(..), Handle, hFlush, hPutStrLn, hSetBuffering, stderr, stdin)-import System.Directory (doesFileExist)-import System.Environment (getArgs, lookupEnv)--data Command- = VersionC VersionOptions- | ListProfilesC ListProfilesOptions- | GenerateKeyC KeyGenOptions- | ChangeKeyPasswordC ChangeKeyPasswordOptions- | MergeCertsC MergeCertsOptions- | ValidateUserIdC ValidateUserIdOptions- | CertifyUserIdC CertifyUserIdOptions- | RevokeKeyC RevokeKeyOptions- | RevokeUserIdC RevokeUserIdOptions- | UpdateKeyC UpdateKeyOptions- | VerifyC VerifyOptions- | InlineVerifyC InlineVerifyOptions- | EncryptC EncryptOptions- | DecryptC DecryptOptions- | InlineSignC InlineSignOptions- | InlineDetachC InlineDetachOptions- | ExtractCertC ExtractCertOptions- | SignC SignOptions- | UnsupportedC String- | DeArmorC- | ArmorC ArmoringOptions--data Options =- Options- { keyrings :: [String]- , outputFormat :: OutputFormat- , sigFilter :: String- , sigFile :: String- , blobFile :: String- }--data OutputFormat- = Unstructured- | JSON- | YAML- deriving (Eq, Read, Show)--data VerifyOptions =- VerifyOptions- { verifyNotBefore :: Maybe String- , verifyNotAfter :: Maybe String- , verifySigFile :: String- , verifyCertFiles :: [String]- }--data InlineVerifyOptions =- InlineVerifyOptions- { inlineNotBefore :: Maybe String- , inlineNotAfter :: Maybe String- , verificationsOut :: Maybe String- , inlineCertFiles :: [String]- }--data EncryptOptions =- EncryptOptions- { encNoArmor :: Bool- , encArmor :: Bool- , encProfile :: Maybe String- , encAs :: AsBinaryText- , encSignWithKeyFiles :: [String]- , encSignWithKeyPasswords :: [String]- , encSessionKeyOutFile :: Maybe String- , encFor :: EncryptFor- , encWithoutIntegrityCheck :: Bool- , encPasswords :: [String]- , encRecipientCerts :: [String]- }--data EncryptProfile- = EncryptProfileRFC9580- | EncryptProfileRFC4880- deriving (Eq)--data DecryptOptions =- DecryptOptions- { decNoArmor :: Bool- , decArmor :: Bool- , decWithoutIntegrityCheck :: Bool- , decVerifyNotBefore :: Maybe String- , decVerifyNotAfter :: Maybe String- , decSessionKeys :: [String]- , decSessionKeyOutFile :: Maybe String- , decPasswords :: [String]- , decKeyPasswords :: [String]- , decKeyFiles :: [String]- , decVerifyCerts :: [String]- , decVerificationsOutFile :: Maybe String- , decDeprecatedVerifyOutFile :: Maybe String- }--data InlineSignOptions =- InlineSignOptions- { inlineSignNoArmor :: Bool- , inlineSignArmor :: Bool- , inlineSignProfile :: Maybe String- , inlineSignAs :: Maybe InlineSignMode- , inlineSignKeyFiles :: [String]- , inlineSignKeyPasswords :: [String]- }--data InlineDetachOptions =- InlineDetachOptions- { inlineDetachNoArmor :: Bool- , inlineDetachOutputSigs :: String- }--data ChangeKeyPasswordOptions =- ChangeKeyPasswordOptions- { changeKeyPasswordNoArmor :: Bool- , changeKeyPasswordOldPasswords :: [String]- , changeKeyPasswordNewPasswords :: [String]- }--data MergeCertsOptions =- MergeCertsOptions- { mergeCertsNoArmor :: Bool- , mergeCertsFiles :: [String]- }--data ValidateUserIdOptions =- ValidateUserIdOptions- { validateUserIdAddrSpecOnly :: Bool- , validateUserIdAt :: Maybe String- , validateUserIdString :: String- , validateUserIdAuthorityFiles :: [String]- }--data CertifyUserIdOptions =- CertifyUserIdOptions- { certifyUserIds :: [String]- , certifyUserIdOutputFormat :: Maybe String- , certifyUserIdNoRequireSelfSig :: Bool- , certifyUserIdKeyPasswordFiles :: [String]- , certifyUserIdSignerFiles :: [String]- }--data RevokeKeyOptions =- RevokeKeyOptions- { revokeKeyNoArmor :: Bool- , revokeKeyPasswordFiles :: [String]- }--data RevokeUserIdOptions =- RevokeUserIdOptions- { revokeUserIdString :: String- , revokeUserIdNoArmor :: Bool- }--data UpdateKeyOptions =- UpdateKeyOptions- { updateKeyNoArmor :: Bool- , updateKeySigningOnly :: Bool- , updateKeyRevokeDeprecatedKeys :: Bool- , updateKeyNoAddedCapabilities :: Bool- , updateKeyPasswordFiles :: [String]- , updateKeyMergeCerts :: [String]- }--newtype ListProfilesOptions =- ListProfilesOptions- { profileSubcommand :: String- }--data VersionOptions =- VersionOptions- { vBackend :: Bool- , vExtended :: Bool- , vSopSpec :: Bool- , vSopv :: Bool- }--data CliOptions =- CliOptions- { cliDebug :: Bool- , cliCommand :: Command- }--data SopFailure- = MissingArg- | IncompleteVerification- | BadData- | PasswordNotHumanReadable- | ExpectedText- | CannotDecrypt- | UnsupportedAsymmetricAlgo- | CertCannotEncrypt- | UnsupportedOption- | OutputExists- | MissingInput- | NoSignature- | KeyIsProtected- | KeyCannotSign- | UnsupportedSpecialPrefix- | IncompatibleOptions- | UnsupportedProfile- | UnsupportedSubcommand- | CertUserIdNoMatch- | KeyCannotCertify--failureCode :: SopFailure -> Int-failureCode MissingArg = 19-failureCode IncompleteVerification = 23-failureCode BadData = 41-failureCode PasswordNotHumanReadable = 31-failureCode ExpectedText = 53-failureCode CannotDecrypt = 29-failureCode UnsupportedAsymmetricAlgo = 13-failureCode CertCannotEncrypt = 17-failureCode UnsupportedOption = 37-failureCode OutputExists = 59-failureCode MissingInput = 61-failureCode NoSignature = 3-failureCode KeyIsProtected = 67-failureCode KeyCannotSign = 79-failureCode UnsupportedSpecialPrefix = 71-failureCode IncompatibleOptions = 83-failureCode UnsupportedProfile = 89-failureCode UnsupportedSubcommand = 69-failureCode CertUserIdNoMatch = 107-failureCode KeyCannotCertify = 109--failWith :: SopFailure -> String -> IO a-failWith f msg = do- BLC8.hPutStrLn stderr (BLC8.pack msg)- exitWith (ExitFailure (failureCode f))--o :: Parser Options-o =- Options <$>- some- (strOption- (long "keyring" <>- short 'k' <> metavar "FILE" <> help "file containing keyring")) <*>- option- auto- (long "output-format" <>- metavar "FORMAT" <>- value Unstructured <> showDefault <> help "output format") <*>- option- auto- (long "signature-filter" <>- metavar "SIGFILTER" <>- value "sigcreationtime < now" <>- showDefault <> help "verify only signatures which match filter spec") <*>- argument str (metavar "SIGNATURE" <> sigHelp) <*>- argument str (metavar "BLOB" <> blobHelp)- where- sigHelp =- helpDoc . Just $- pretty "file containing OpenPGP binary signatures"- blobHelp =- helpDoc . Just $- pretty "file containing binary blob to be validated"--voP :: Parser VerifyOptions-voP =- VerifyOptions <$>- optional- (strOption- (long "not-before" <>- metavar "DATE" <> help "ignore signatures before DATE")) <*>- optional- (strOption- (long "not-after" <>- metavar "DATE" <> help "ignore signatures after DATE")) <*>- argument str (metavar "SIGNATURES" <> sigHelp) <*>- some (strArgument (metavar "CERTS..." <> certHelp))- where- sigHelp =- helpDoc . Just $- pretty "file containing OpenPGP signatures"- certHelp =- helpDoc . Just $- pretty "one or more certificate files"--ivoP :: Parser InlineVerifyOptions-ivoP =- InlineVerifyOptions <$>- optional- (strOption- (long "not-before" <>- metavar "DATE" <> help "ignore signatures before DATE")) <*>- optional- (strOption- (long "not-after" <>- metavar "DATE" <> help "ignore signatures after DATE")) <*>- optional- (strOption- (long "verifications-out" <>- metavar "VERIFICATIONS" <> help "write verification records to file")) <*>- some (strArgument (metavar "CERTS..." <> certHelp))- where- certHelp =- helpDoc . Just $- pretty "one or more certificate files"--lpoP :: Parser ListProfilesOptions-lpoP =- ListProfilesOptions <$>- strArgument (metavar "SUBCOMMAND" <> help "subcommand to list profiles for")--vopP :: Parser VersionOptions-vopP =- VersionOptions <$>- switch (long "backend" <> help "show backend implementation version") <*>- switch (long "extended" <> help "show extended version information") <*>- switch (long "sop-spec" <> help "show targeted sop draft") <*>- switch (long "sopv" <> help "show implemented sopv subset version")--encP :: Parser EncryptOptions-encP =- EncryptOptions <$>- switch (long "no-armor" <> help "output binary") <*>- switch (long "armor" <> help "output ASCII Armor") <*>- optional (strOption (long "profile" <> help "encryption profile")) <*>- option- (eitherReader asTypeReader)- (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary) <*>- many (strOption (long "sign-with" <> help "signing key material")) <*>- many- (strOption- (long "with-key-password" <>- help "password for unlocking signing key material")) <*>- optional- (strOption- (long "session-key-out" <>- metavar "SESSIONKEY" <> help "write generated session key to file")) <*>- option- (eitherReader encryptForReader)- (long "for" <>- metavar "ENCRYPTION_PURPOSE" <>- help "select recipient key purpose (any, storage, communications)" <>- value EncryptForAny) <*>- switch (long "without-integrity-check" <> help "disable integrity protection") <*>- many (strOption (long "with-password" <> help "symmetric encryption password")) <*>- many (strArgument (metavar "CERT" <> help "recipient certificate files"))- where- astypeHelp =- helpDoc . Just $- pretty "what to treat the input as" <>- softline <> list (map (pretty . fst) asTypes)--decP :: Parser DecryptOptions-decP =- DecryptOptions <$>- switch (long "no-armor" <> help "output binary") <*>- switch (long "armor" <> help "output ASCII Armor") <*>- switch (long "without-integrity-check" <> help "disable integrity verification") <*>- optional- (strOption- (long "verify-not-before" <>- metavar "DATE" <> help "ignore signatures before DATE when decrypting")) <*>- optional- (strOption- (long "verify-not-after" <>- metavar "DATE" <> help "ignore signatures after DATE when decrypting")) <*>- many (strOption (long "with-session-key" <> help "session key for decryption")) <*>- optional (strOption (long "session-key-out" <> help "write recovered session key")) <*>- many (strOption (long "with-password" <> help "password for SKESK decryption")) <*>- many- (strOption- (long "with-key-password" <>- help "password for unlocking decryption key material")) <*>- many (strArgument (metavar "KEY" <> help "secret key material")) <*>- many (strOption (long "verify-with" <> help "certificate(s) to verify signatures with")) <*>- optional- (strOption- (long "verifications-out" <>- help "write verification results to file")) <*>- optional- (strOption- (long "verify-out" <>- help "deprecated alias for --verifications-out"))--inlineSignP :: Parser InlineSignOptions-inlineSignP =- InlineSignOptions <$>- switch (long "no-armor" <> help "output binary") <*>- switch (long "armor" <> help "output ASCII Armor") <*>- optional (strOption (long "profile" <> help "signature profile")) <*>- optional- (option- (eitherReader inlineSignModeReader)- (long "as" <> metavar "DATATYPE" <> inlineSignAsHelp)) <*>- some (strArgument (metavar "KEY" <> help "signing key file(s)")) <*>- many (strOption (long "with-key-password" <> metavar "PASSWORD" <> help "password for encrypted signing key"))- where- inlineSignAsHelp =- helpDoc . Just $- pretty "what to treat the input as" <>- softline <> list [pretty "binary", pretty "text", pretty "clearsigned"]--inlineDetachP :: Parser InlineDetachOptions-inlineDetachP =- InlineDetachOptions <$>- switch (long "no-armor" <> help "output binary") <*>- strOption- (long "signatures-out" <> metavar "SIGNATURES" <> help "write detached signatures to file")--mergeCertsP :: Parser MergeCertsOptions-mergeCertsP =- MergeCertsOptions <$>- switch (long "no-armor" <> help "output binary") <*>- some (strArgument (metavar "CERTS..." <> help "one or more certificate files"))--validateUserIdP :: Parser ValidateUserIdOptions-validateUserIdP =- ValidateUserIdOptions <$>- switch- (long "addr-spec-only" <>- help "match only the addr-spec portion of conventional OpenPGP User IDs") <*>- optional- (strOption- (long "validate-at" <>- metavar "DATE" <> help "evaluate certifications at DATE")) <*>- argument str (metavar "USERID" <> help "user ID to validate") <*>- some (strArgument (metavar "CERTS..." <> help "one or more authority certificate files"))--certifyUserIdP :: Parser CertifyUserIdOptions-certifyUserIdP =- CertifyUserIdOptions <$>- some- (strOption- (long "userid" <>- metavar "USERID" <> help "user ID to certify (repeatable)")) <*>- optional- (strOption- (long "output-format" <>- metavar "FORMAT" <>- help "output format (text or binary)")) <*>- switch (long "no-require-self-sig" <> help "allow certifying user IDs that do not have self-signatures") <*>- many- (strOption- (long "with-key-password" <>- help "password for unlocking signer key material")) <*>- some (strArgument (metavar "KEYS..." <> help "one or more signer key files"))--revokeKeyP :: Parser RevokeKeyOptions-revokeKeyP =- RevokeKeyOptions <$>- switch (long "no-armor" <> help "output binary") <*>- many- (strOption- (long "with-key-password" <>- help "password for unlocking secret key material"))--revokeUserIdP :: Parser RevokeUserIdOptions-revokeUserIdP =- RevokeUserIdOptions <$>- argument str (metavar "USERID" <> help "user ID to revoke") <*>- switch (long "no-armor" <> help "output binary")--updateKeyP :: Parser UpdateKeyOptions-updateKeyP =- UpdateKeyOptions <$>- switch (long "no-armor" <> help "output binary") <*>- switch (long "signing-only" <> help "limit updated material to signing-capable key material") <*>- switch (long "revoke-deprecated-keys" <> help "emit revocations for deprecated key material when supported") <*>- switch (long "no-added-capabilities" <> help "do not add capabilities beyond existing target key material") <*>- many- (strOption- (long "with-key-password" <>- help "password for unlocking key material")) <*>- many- (strOption- (long "merge-certs" <>- metavar "CERTS" <> help "additional certificate files to merge into target keys"))--changeKeyPasswordP :: Parser ChangeKeyPasswordOptions-changeKeyPasswordP =- ChangeKeyPasswordOptions <$>- switch (long "no-armor" <> help "output binary") <*>- many- (strOption- (long "old-key-password" <>- help "password(s) used to unlock existing secret key material")) <*>- many- (strOption- (long "new-key-password" <>- help "password used to protect rewritten secret key material"))--dispatch :: POSIXTime -> Command -> IO ()-dispatch cpt o = banner' stderr >> hFlush stderr >> dispatch' cpt o- where- dispatch' _ (VersionC o') = doVersion o'- dispatch' _ (ListProfilesC o') = doListProfiles o'- dispatch' t (GenerateKeyC o) = doGenerateKey t o- dispatch' _ (ChangeKeyPasswordC o) = doChangeKeyPassword o- dispatch' _ (MergeCertsC o) = doMergeCerts o- dispatch' t (ValidateUserIdC o) = doValidateUserId t o- dispatch' t (CertifyUserIdC o) = doCertifyUserId t o- dispatch' t (RevokeKeyC o) = doRevokeKey t o- dispatch' t (RevokeUserIdC o) = doRevokeUserId t o- dispatch' t (UpdateKeyC o) = doUpdateKey t o- dispatch' t (VerifyC o') = doVerify t o'- dispatch' t (InlineVerifyC o') = doInlineVerify t o'- dispatch' t (EncryptC o') = doEncrypt t o'- dispatch' t (DecryptC o') = doDecrypt t o'- dispatch' t (InlineSignC o') = doInlineSign t o'- dispatch' t (InlineDetachC o') = doInlineDetach t o'- dispatch' _ (ExtractCertC o) = doExtractCert o- dispatch' t (SignC o) = doSign t o- dispatch' _ (UnsupportedC c) =- failWith UnsupportedSubcommand ("command not yet implemented: " ++ c)- dispatch' _ DeArmorC = doDeArmor- dispatch' _ (ArmorC o) = doArmor o--main :: IO ()-main = do- hSetBuffering stderr LineBuffering- args <- getArgs- ensureKnownSubcommand knownSopSubcommands args- cpt <- getPOSIXTime- CliOptions {..} <-- customExecParser- (prefs showHelpOnError)- (info- (helper <*> versioner "hop" <*> cliP)- (headerDoc (Just (banner "hop")) <>- progDesc "hOpenPGP Validator Tool" <>- footerDoc (Just (warranty "hop"))))- let _ = cliDebug- dispatch cpt cliCommand--knownSopSubcommands :: [String]-knownSopSubcommands =- [ "armor"- , "dearmor"- , "change-key-password"- , "decrypt"- , "encrypt"- , "certify-userid"- , "extract-cert"- , "generate-key"- , "inline-detach"- , "inline-sign"- , "inline-verify"- , "list-profiles"- , "merge-certs"- , "revoke-key"- , "revoke-userid"- , "sign"- , "update-key"- , "validate-userid"- , "verify"- , "version"- ]--ensureKnownSubcommand :: [String] -> [String] -> IO ()-ensureKnownSubcommand knownSubcommands args =- if any (`elem` ["-h", "--help", "--version"]) args- then pure ()- else- case find (not . isPrefixOf "-") args of- Just subcommand- | subcommand `notElem` knownSubcommands ->- failWith UnsupportedSubcommand ("unsupported subcommand: " ++ subcommand)- _ -> pure ()--cliP :: Parser CliOptions-cliP =- CliOptions <$>- switch (long "debug" <> help "emit more verbose output") <*>- cmd--banner' :: Handle -> IO ()-banner' h = hPutDoc h (banner "hop" <> hardline <> warranty "hop" <> hardline)--data Vrf =- Vrf- { _vrfmsg :: String- , _vrfmfpr :: Maybe Fingerprint- }- deriving (Eq, Generic, Show)--instance A.ToJSON Vrf--doV :: POSIXTime -> Options -> IO ()-doV cpt o = do- krs <- loadVerifyKeyringMap cpt (keyrings o)- sigs <-- runConduitRes $- CC.sourceFile (sigFile o) .| conduitGet Bin.get .| CC.filter v4b .|- CC.sinkVector- blob <- runConduitRes $ CC.sourceFile (blobFile o) .| CC.sinkLazy- verifications <-- runConduitRes $- CC.yieldMany (V.cons (LiteralDataPkt BinaryData mempty 0 blob) sigs) .|- conduitVerify krs Nothing .|- CC.sinkList- let verifications' = map v2v verifications- case outputFormat o of- Unstructured -> mapM_ print verifications'- JSON -> BL.putStr . A.encode $ verifications'- YAML -> B.putStr . Y.encode $ verifications'- putStrLn ""- case any isRight verifications of- True -> exitSuccess- _ -> exitFailure- where- v4b (SignaturePkt s@(SigV4 BinarySig _ _ _ _ _ _)) = sf s- v4b _ = False- v2v (Left l) = Vrf (show l) Nothing- v2v (Right v) =- Vrf "verified signature" (Just (fingerprint (_verificationSigner v)))- sf = const True--cmd :: Parser Command-cmd =- hsubparser- (command "armor" (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout")) <>- command "dearmor" (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout")) <>- command- "change-key-password"- (info (ChangeKeyPasswordC <$> changeKeyPasswordP) (progDesc "Update a key password")) <>- command "decrypt" (info (DecryptC <$> decP) (progDesc "Decrypt a message")) <>- command "encrypt" (info (EncryptC <$> encP) (progDesc "Encrypt a message")) <>- command- "certify-userid"- (info (CertifyUserIdC <$> certifyUserIdP) (progDesc "Certify user IDs in a certificate")) <>- command "extract-cert" (info (ExtractCertC <$> ecoP) (progDesc "Extract a certificate from a secret key and output it to stdout")) <>- command "generate-key" (info (GenerateKeyC <$> gkoP) (progDesc "Generate a secret key and output it to stdout")) <>- command "inline-detach" (info (InlineDetachC <$> inlineDetachP) (progDesc "Create inline detached signatures")) <>- command "inline-sign" (info (InlineSignC <$> inlineSignP) (progDesc "Create inline signatures")) <>- command "inline-verify" (info (InlineVerifyC <$> ivoP) (progDesc "Verify inline-signed data")) <>- command "list-profiles" (info (ListProfilesC <$> lpoP) (progDesc "List SOP profiles")) <>- command- "merge-certs"- (info (MergeCertsC <$> mergeCertsP) (progDesc "Merge OpenPGP certificates")) <>- command- "revoke-key"- (info (RevokeKeyC <$> revokeKeyP) (progDesc "Create a key revocation certificate")) <>- command- "revoke-userid"- (info (RevokeUserIdC <$> revokeUserIdP) (progDesc "Revoke a user ID")) <>- command "sign" (info (SignC <$> soP) (progDesc "Create detached signatures and output them to stdout")) <>- command- "update-key"- (info (UpdateKeyC <$> updateKeyP) (progDesc "Update key material")) <>- command- "validate-userid"- (info (ValidateUserIdC <$> validateUserIdP) (progDesc "Validate a certificate user ID")) <>- command "verify" (info (VerifyC <$> voP) (progDesc "Verify signatures")) <>- command "version" (info (VersionC <$> vopP) (progDesc "output hop version to stdout")))--armorTypes :: [(String, Maybe ArmorType)]-armorTypes =- [ ("auto", Nothing)- , ("sig", Just ArmorSignature)- , ("key", Just ArmorPrivateKeyBlock)- , ("cert", Just ArmorPublicKeyBlock)- , ("message", Just ArmorMessage)- ]--armorTypeReader :: String -> Either String (Maybe ArmorType)-armorTypeReader = note "unknown armor type" . flip lookup armorTypes--aoP :: Parser ArmoringOptions-aoP =- ArmoringOptions <$>- option- (eitherReader armorTypeReader)- (long "label" <> metavar "LABEL" <> armortypeHelp) <*>- switch- (long "allow-nested" <>- help "do the sane thing and unconditionally armor the output")- where- armortypeHelp =- helpDoc . Just $- pretty "ASCII armor type" <>- softline <> list (map (pretty . fst) armorTypes)--data ArmoringOptions =- ArmoringOptions- { label :: Maybe ArmorType- , allowNested :: Bool- }--doArmor :: ArmoringOptions -> IO ()-doArmor ArmoringOptions {..} = do- m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- let lbs = BL.fromChunks m- armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs- label' = guessLabel label (decodeFirstPacket lbs)- a = Armor label' [] lbs- BL.putStr $- if armoredAlready && not allowNested- then lbs- else AA.encodeLazy [a]- where- decodeFirstPacket = runGet Bin.get- -- UPSTREAM: openpgp-asciiarmor should export selectArmorType helper- -- to eliminate this pattern-matching boilerplate- guessLabel (Just l) _ = l- guessLabel Nothing (SignaturePkt _) = ArmorSignature- guessLabel Nothing (SecretKeyPkt _ _) = ArmorPrivateKeyBlock- guessLabel Nothing (PublicKeyPkt _) = ArmorPublicKeyBlock- guessLabel Nothing _ = ArmorMessage--doVersion :: VersionOptions -> IO ()-doVersion VersionOptions {..} = do- let selected = length (filter id [vBackend, vExtended, vSopSpec, vSopv])- when (selected > 1) $- failWith- IncompatibleOptions- "version: --backend, --extended, --sop-spec, and --sopv are mutually exclusive"- putStrLn $ "hop " ++ showVersion version- when vBackend $ putStrLn "backend: hOpenPGP"- when vExtended $ putStrLn "extended: yes"- when vSopSpec $ putStrLn "spec: draft-dkg-openpgp-stateless-cli-16"- when vSopv $ putStrLn "sopv: 1.0"--gkoP :: Parser KeyGenOptions-gkoP =- KeyGenOptions <$> switch (long "armor" <> help "armor the output") <*>- switch (long "no-armor" <> help "don't armor the output") <*>- many- (strOption- (long "with-key-password" <>- help "password used to protect generated secret key material")) <*>- optional- (strOption- (long "profile" <>- metavar "PROFILE" <> help "key generation profile (default, rfc4880, compatibility, security, performance)")) <*>- switch (long "signing-only" <> help "generate signing-only key material") <*>- many (strArgument (metavar "USERID" <> help "User ID associated with this key"))--data KeyGenOptions =- KeyGenOptions- { armor :: Bool- , noArmor :: Bool- , keyPasswords :: [String]- , keyProfile :: Maybe String- , keySigningOnly :: Bool- , userIds :: [String]- }--doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()-doGenerateKey pt KeyGenOptions {..} = do- when (armor && noArmor) $- failWith- IncompatibleOptions- "generate-key: --armor and --no-armor are mutually exclusive"- baseProfile <- parseKeyGenProfile keyProfile- let profile =- if keySigningOnly- then KeyGenSigningOnly- else baseProfile- password <- parseGenerateKeyPassword keyPasswords- let ts = ThirtyTwoBitTimeStamp (floor pt)- -- UPSTREAM: hOpenPGP should expose a supported legacy secret-key- -- re-encryption path so password-protected v4 key generation does not- -- need to switch to the v6 protection format here.- keyVersion =- if isJust password && keyVersionForProfile profile == V4- then V6- else keyVersionForProfile profile- primaryKeySpec = primaryKeySpecForProfile profile- sk <- generateSecretKey ts keyVersion primaryKeySpec- baseKey <-- buildKeyWith sk $ do- case userIds of- (primaryUid:restUids) -> do- addUserId ts True (T.pack primaryUid)- mapM_ (addUserId ts False . T.pack) restUids- [] -> pure ()- addSubkeysForProfile ts keyVersion profile- newkey <- get- return newkey- s <- maybe (pure baseKey) (`encryptTransferableSecretKey` baseKey) password- let lbs = runPut $ Bin.put s- BL.putStr $- if not armor && not noArmor- then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]- else lbs--type KeyBuilder = StateT TKUnknown IO--buildKeyWith :: SecretKey -> KeyBuilder a -> IO a-buildKeyWith sk a = evalStateT a (bareTK sk)- where- bareTK (SecretKey pkp ska) = TKUnknown (pkp, Just ska) [] [] [] []--data GeneratedKeySpec- = GeneratedRSAKey Int- | GeneratedEd25519Key- | GeneratedX25519Key- deriving (Eq)--generateSecretKey :: ThirtyTwoBitTimeStamp -> KeyVersion -> GeneratedKeySpec -> IO SecretKey-generateSecretKey ts keyVersion (GeneratedRSAKey bits) = do- (pub, priv) <- liftIO $ RSA.generate bits 0x10001- return $ SecretKey (pkp pub) (ska priv)- where- pkp pub = PKPayload keyVersion ts 0 RSA (RSAPubKey (RSA_PublicKey pub))- ska priv = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey priv)) 0 -- FIXME: calculate checksum-generateSecretKey ts keyVersion GeneratedEd25519Key = do- priv <- Ed25519.generateSecretKey- let pub = Ed25519.toPublic priv- pubBytes = BA.convert pub :: B.ByteString- privBytes = BA.convert priv :: B.ByteString- pure $- SecretKey- (PKPayload- keyVersion- ts- 0- (toFVal 27)- (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes)))))- (SUUnencrypted (EdDSAPrivateKey Ed25519 privBytes) 0)-generateSecretKey ts keyVersion GeneratedX25519Key = do- priv <- Curve25519.generateSecretKey- let pub = Curve25519.toPublic priv- pubBytes = BA.convert pub :: B.ByteString- privBytes = BA.convert priv :: B.ByteString- pure $- SecretKey- (PKPayload- keyVersion- ts- 0- X25519- (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes)))))- (SUUnencrypted (X25519PrivateKey privBytes) 0)--data KeyGenProfile- = KeyGenDefault- | KeyGenRFC4880- | KeyGenSecurity- | KeyGenPerformance- | KeyGenSigningOnly- deriving (Eq)--parseKeyGenProfile :: Maybe String -> IO KeyGenProfile-parseKeyGenProfile Nothing = pure KeyGenDefault-parseKeyGenProfile (Just "default") = pure KeyGenDefault-parseKeyGenProfile (Just "rfc4880") = pure KeyGenRFC4880-parseKeyGenProfile (Just "compatibility") = pure KeyGenRFC4880-parseKeyGenProfile (Just "security") = pure KeyGenSecurity-parseKeyGenProfile (Just "performance") = pure KeyGenPerformance-parseKeyGenProfile (Just profile) =- failWith- UnsupportedProfile- ("generate-key: unsupported profile " ++ profile)--keyVersionForProfile :: KeyGenProfile -> KeyVersion-keyVersionForProfile KeyGenDefault = V6-keyVersionForProfile KeyGenRFC4880 = V4-keyVersionForProfile KeyGenSecurity = V6-keyVersionForProfile KeyGenPerformance = V6-keyVersionForProfile KeyGenSigningOnly = V6--primaryKeySpecForProfile :: KeyGenProfile -> GeneratedKeySpec-primaryKeySpecForProfile KeyGenRFC4880 = GeneratedRSAKey 4096-primaryKeySpecForProfile _ = GeneratedEd25519Key--parseGenerateKeyPassword :: [String] -> IO (Maybe BL.ByteString)-parseGenerateKeyPassword [] = pure Nothing-parseGenerateKeyPassword [passwordFile] =- Just <$>- (loadPasswordFromFile "generate-key" "--with-key-password" passwordFile >>=- normalizeHumanReadablePassword "generate-key" "--with-key-password")-parseGenerateKeyPassword _ =- failWith- UnsupportedOption- "generate-key: multiple --with-key-password values are not supported"--loadPasswordFiles :: String -> String -> [String] -> IO [BL.ByteString]-loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName)--loadPasswordFromFile :: String -> String -> FilePath -> IO BL.ByteString-loadPasswordFromFile context optionName path = do- case stripPrefix "@ENV:" path of- Just varName- | null varName ->- failWith- BadData- (context ++ ": empty environment variable name in " ++ optionName)- | otherwise -> do- envValue <- lookupEnv varName- case envValue of- Nothing ->- failWith- MissingInput- (context ++ ": environment variable not found for " ++ optionName ++ ": " ++ varName)- Just value -> pure (BLC8.pack value)- Nothing ->- case stripPrefix "@FD:" path of- Just fdSpec -> loadPasswordFromFD context optionName fdSpec- Nothing ->- case path of- '@':_ ->- failWith- UnsupportedSpecialPrefix- (context ++ ": unsupported special prefix for " ++ optionName ++ ": " ++ path)- _ -> do- exists <- doesFileExist path- unless exists $- failWith- MissingInput- (context ++ ": password file does not exist for " ++ optionName ++ ": " ++ path)- BL.readFile path--loadPasswordFromFD :: String -> String -> String -> IO BL.ByteString-loadPasswordFromFD context optionName fdSpec =- case readMaybe fdSpec :: Maybe Int of- Just fdNum- | fdNum >= 0 ->- (do- let fdPath = "/dev/fd/" ++ show fdNum- exists <- doesFileExist fdPath- unless exists $- failWith- MissingInput- (context ++ ": file descriptor not available for " ++ optionName ++ ": " ++ fdSpec)- contents <- BL.readFile fdPath- _ <- evaluate (BL.length contents)- pure contents)- `catch`- (\err ->- failWith- MissingInput- (context ++ ": failed reading file descriptor for " ++ optionName ++- ": " ++ fdSpec ++ " (" ++ displayException (err :: IOException) ++ ")"))- | otherwise ->- failWith- BadData- (context ++ ": invalid file descriptor in " ++ optionName ++ ": " ++ fdSpec)- _ ->- failWith- BadData- (context ++ ": invalid file descriptor in " ++ optionName ++ ": " ++ fdSpec)--normalizeHumanReadablePassword :: String -> String -> BL.ByteString -> IO BL.ByteString-normalizeHumanReadablePassword context optionName passwordBytes =- case TE.decodeUtf8' (BL.toStrict passwordBytes) of- Left _ ->- failWith- PasswordNotHumanReadable- (context ++ ": password is not human-readable UTF-8 for " ++ optionName)- Right txt ->- pure- (BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt)))--passwordRetryCandidates :: BL.ByteString -> [BL.ByteString]-passwordRetryCandidates passwordBytes =- case TE.decodeUtf8' (BL.toStrict passwordBytes) of- Left _ -> [passwordBytes]- Right txt ->- let trimmed = BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt))- in if trimmed == passwordBytes- then [passwordBytes]- else [passwordBytes, trimmed]--addSubkeysForProfile :: ThirtyTwoBitTimeStamp -> KeyVersion -> KeyGenProfile -> KeyBuilder ()-addSubkeysForProfile ts keyVersion profile =- case profile of- KeyGenSigningOnly ->- addSubkey ts keyVersion profile [SignDataKey]- _ -> do- addSubkey ts keyVersion profile [EncryptStorageKey, EncryptCommunicationsKey]- addSubkey ts keyVersion profile [SignDataKey]- addSubkey ts keyVersion profile [AuthKey]--subkeySpecForProfile :: KeyGenProfile -> [KeyFlag] -> GeneratedKeySpec-subkeySpecForProfile KeyGenRFC4880 _ = GeneratedRSAKey 4096-subkeySpecForProfile _ keyflags- | any (`elem` keyflags) [EncryptStorageKey, EncryptCommunicationsKey] = GeneratedX25519Key- | 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'}- 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- encryptSecretAddendumForOutput pkp ska =- case ska of- SUUnencrypted {} -> doEncrypt- _ -> pure ska- where- doEncrypt = do- encryptedResult <- encryptPrivateKey defaultPolicy pkp ska password- case encryptedResult of- Left err ->- failWith BadData ("generate-key: failed to protect secret key material: " ++ err)- Right value -> pure value--rsaSigningKey :: SKAddendum -> IO RSA.PrivateKey-rsaSigningKey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) =- pure (k {RSA.private_p = 0, RSA.private_q = 0})-rsaSigningKey _ =- failWith- BadData- "generate-key: unsupported secret key format for RSA signing"--issuerSubpacketsFor :: String -> SomePKPayload -> IO [SigSubPacket]-issuerSubpacketsFor context pkp =- case _keyVersion pkp of- V6 -> pure []- _ ->- case eightOctetKeyID pkp of- Left err ->- failWith- BadData- (context ++ ": could not derive issuer key id: " ++ show err)- Right keyId -> pure [SigSubPacket False (Issuer keyId)]--issuerSubpacketFor :: String -> SomePKPayload -> IO SigSubPacket-issuerSubpacketFor context pkp = do- packets <- issuerSubpacketsFor context pkp- case packets of- [packet] -> pure packet- [] ->- failWith- BadData- (context ++ ": no legacy issuer key id is available for this key")- _ -> failWith BadData (context ++ ": unexpected issuer subpacket count")--addUserId :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()-addUserId ts primary userid = do- tk <- get- signed <- selfsign (_tkuKey tk) userid- modify (newUID signed)- where- newUID signed tk = tk {_tkuUIDs = _tkuUIDs tk ++ [signed]}- selfsign (pkp, Just ska) u = do- issuer <- liftIO (unhashed pkp)- sig <-- liftIO $- signWithKey- "generate-key"- pkp- PositiveCert- SHA512- (hashed pkp)- issuer- (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- False- (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))- , SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey))- , SigSubPacket False (PrimaryUserId primary)- , SigSubPacket- False- (PreferredHashAlgorithms [SHA512, SHA256, SHA384, SHA224])- , SigSubPacket- False- (PreferredSymmetricAlgorithms [AES256, AES192, AES128])- ]- unhashed = issuerSubpacketsFor "generate-key"--addSubkey :: ThirtyTwoBitTimeStamp -> KeyVersion -> KeyGenProfile -> [KeyFlag] -> KeyBuilder ()-addSubkey ts keyVersion profile keyflags = do- tk <- get- (SecretKey subpkp subska) <-- liftIO $- generateSecretKey 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"- issuerPrimary <- liftIO (unhashed pkp)- issuerSub <- liftIO (unhashed subpkp)- embeddedBacksig <-- if SignDataKey `elem` keyflags- then- Just <$>- liftIO- (signWithKey- "generate-key"- subpkp- PrimaryKeyBindingSig- SHA512- (hashed subpkp)- issuerSub- (subkeyPayloadForSigning pkp subpkp)- (Just subska))- else pure Nothing- bindingSig <-- liftIO $- signWithKey- "generate-key"- pkp- SubkeyBindingSig- SHA512- (hashedwithflags pkp)- (maybe issuerPrimary (\sig -> SigSubPacket False (EmbeddedSignature sig) : issuerPrimary) embeddedBacksig)- (subkeyPayloadForSigning pkp subpkp)- (Just ska)- modify (addIt subpkp subska bindingSig)- where- addIt sp ss binding tk =- tk {_tkuSubs = _tkuSubs tk ++ [(SecretSubkeyPkt sp ss, [binding])]}- hashed pkp =- [ SigSubPacket False (SigCreationTime ts)- , SigSubPacket- False- (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))- ]- hashedwithflags pkp =- hashed pkp ++ [SigSubPacket False (KeyFlags (S.fromList keyflags))]- unhashed = issuerSubpacketsFor "generate-key"--putKeyForSigning :: SomePKPayload -> Bin.Put-putKeyForSigning pkp@(PKPayload V6 _ _ _ _) = do- putWord8 0x9A- let bs = runPut (Bin.put pkp)- putWord32be (fromIntegral (BL.length bs))- putLazyByteString bs-putKeyForSigning pkp = do- putWord8 0x99- let bs = runPut (Bin.put pkp)- putWord16be (fromIntegral (BL.length bs))- putLazyByteString bs--putUserIdForSigning :: UserId -> Bin.Put-putUserIdForSigning (UserId u) = do- let bs = TE.encodeUtf8 u- putWord8 0xB4- putWord32be (fromIntegral (B.length bs))- putByteString bs--userIdPayloadForSigning :: SomePKPayload -> UserId -> BL.ByteString-userIdPayloadForSigning pkp uid =- runPut $ do- putKeyForSigning pkp- putUserIdForSigning uid--subkeyPayloadForSigning :: SomePKPayload -> SomePKPayload -> BL.ByteString-subkeyPayloadForSigning primary sub =- runPut $ do- putKeyForSigning primary- putKeyForSigning sub--issuerFingerprintVersionFor :: SomePKPayload -> IssuerFingerprintVersion-issuerFingerprintVersionFor pkp =- case _keyVersion pkp of- V6 -> IssuerFingerprintV6- _ -> IssuerFingerprintV4--ecoP :: Parser ExtractCertOptions-ecoP =- ExtractCertOptions <$> switch (long "armor" <> help "armor the output") <*>- switch (long "no-armor" <> help "don't armor the output")--data ExtractCertOptions =- ExtractCertOptions- { ecArmor :: Bool- , ecNoArmor :: Bool- }--doExtractCert :: ExtractCertOptions -> IO ()-doExtractCert ExtractCertOptions {..} = do- kbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- let lbs = BL.fromChunks kbs- pkts <- decodeOpenPGPInput "stdin" lbs- tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| 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- 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--doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()-doChangeKeyPassword ChangeKeyPasswordOptions {..} = do- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- packets <- decodeOpenPGPInput "stdin" input- tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| CC.sinkList- when (null tks) $- failWith- MissingInput- "change-key-password: no transferable secret key found on standard input"- when (any (not . hasSecretKeyMaterial) tks) $- failWith- MissingInput- "change-key-password: expected transferable secret key input on standard input"- oldPasswordsRaw <-- loadPasswordFiles "change-key-password" "--old-key-password" changeKeyPasswordOldPasswords- let oldPasswords = concatMap passwordRetryCandidates oldPasswordsRaw- newPassword <- parseChangeKeyPasswordNewPassword changeKeyPasswordNewPasswords- unlockedTks <-- mapM- (unlockTransferableSecretKeyMaterial- "change-key-password"- "standard input"- "--old-key-password"- oldPasswords)- tks- rewrittenTks <-- case newPassword of- Just password -> mapM (encryptTransferableSecretKey password) unlockedTks- Nothing -> pure unlockedTks- let output = runPut (mapM_ Bin.put rewrittenTks)- BL.putStr $- if changeKeyPasswordNoArmor || BL.null output- then output- else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]--parseChangeKeyPasswordNewPassword :: [String] -> IO (Maybe BL.ByteString)-parseChangeKeyPasswordNewPassword [] = pure Nothing-parseChangeKeyPasswordNewPassword [passwordFile] =- Just <$>- (loadPasswordFromFile "change-key-password" "--new-key-password" passwordFile >>=- normalizeHumanReadablePassword "change-key-password" "--new-key-password")-parseChangeKeyPasswordNewPassword _ =- failWith- UnsupportedOption- "change-key-password: multiple --new-key-password values are not supported"--hasSecretKeyMaterial :: TKUnknown -> Bool-hasSecretKeyMaterial tk =- case _tkuKey tk of- (_, Just _) -> True- _ -> any isSecretSubkeyPkt (_tkuSubs tk)- where- isSecretSubkeyPkt (SecretSubkeyPkt _ _, _) = True- isSecretSubkeyPkt _ = False--doValidateUserId :: POSIXTime -> ValidateUserIdOptions -> IO ()-doValidateUserId cpt ValidateUserIdOptions {..} = do- authorityTks <- concat <$> mapM (loadCertTKsFromFile "validate-userid") validateUserIdAuthorityFiles- validateAtTime <- verificationUpperBound cpt validateUserIdAt- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- certPkts <- decodeOpenPGPInput "standard input" input- certTks <- runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| CC.sinkList- when (null certTks) $- failWith MissingInput "validate-userid: no certificate found on standard input"- let targetUserId = T.pack validateUserIdString- forM_ certTks $ \certTk ->- when- (not- (certificateHasMatchingValidatedUserId- authorityTks- validateAtTime- validateUserIdAddrSpecOnly- targetUserId- certTk)) $- failWith- CertUserIdNoMatch- ("validate-userid: certificate has no correctly bound user ID matching " ++- validateUserIdString)--certificateHasMatchingValidatedUserId ::- [TKUnknown] -> Maybe UTCTime -> Bool -> Text -> TKUnknown -> Bool-certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =- case verifyUnknownTKWith verifier validateAtTime certTk of- Left _ -> False- Right verifiedTk -> any matchingBoundUid (_tkuUIDs verifiedTk)- where- verifier = verifySigWith (verifyAgainstKeys (certTk : authorityTks))- matchingBoundUid (uid, sigs) =- useridMatches addrSpecOnly targetUserId uid &&- any (signatureMatchesSigner certTk) sigs &&- any (\sig -> any (`signatureMatchesSigner` sig) authorityTks) sigs--useridMatches :: Bool -> Text -> Text -> Bool-useridMatches False targetUserId uid = uid == targetUserId-useridMatches True targetUserId uid =- case conventionalAddrSpec uid of- Just addrSpec -> addrSpec == targetUserId- Nothing -> False--conventionalAddrSpec :: Text -> Maybe Text-conventionalAddrSpec uid =- let (prefix, suffix) = T.breakOnEnd (T.pack "<") uid- in if T.null prefix- then Nothing- else case T.unsnoc suffix of- Just (addrSpec, '>')- | T.any (== '<') addrSpec -> Nothing- | otherwise -> guardNonEmpty (T.strip addrSpec)- _ -> Nothing- where- guardNonEmpty text- | T.null text = Nothing- | otherwise = Just text--signatureMatchesSigner :: TKUnknown -> SignaturePayload -> Bool-signatureMatchesSigner signer sig =- maybe False (keyMatchesFingerprint False signer) (signatureIssuerFingerprint sig) ||- maybe False (keyMatchesEightOctetKeyId False signer . Right) (signatureIssuerKeyId sig)--signatureIssuerFingerprint :: SignaturePayload -> Maybe Fingerprint-signatureIssuerFingerprint = listToMaybe . mapMaybe getIssuerFingerprint . signatureSubpackets- where- getIssuerFingerprint (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) =- Just issuerFingerprint- getIssuerFingerprint _ = Nothing--signatureIssuerKeyId :: SignaturePayload -> Maybe EightOctetKeyId-signatureIssuerKeyId = listToMaybe . mapMaybe getIssuerKeyId . signatureSubpackets- where- getIssuerKeyId (SigSubPacket _ (Issuer issuerKeyId)) = Just issuerKeyId- getIssuerKeyId _ = Nothing--signatureSubpackets :: SignaturePayload -> [SigSubPacket]-signatureSubpackets (SigV4 _ _ _ hashed unhashed _ _) = hashed ++ unhashed-signatureSubpackets (SigV6 _ _ _ _ hashed unhashed _ _) = hashed ++ unhashed-signatureSubpackets _ = []--doCertifyUserId :: POSIXTime -> CertifyUserIdOptions -> IO ()-doCertifyUserId cpt CertifyUserIdOptions {..} = do- signerPasswordsRaw <- loadPasswordFiles "certify-userid" "--with-key-password" certifyUserIdKeyPasswordFiles- let signerPasswords = concatMap passwordRetryCandidates signerPasswordsRaw- signerTks <- concat <$> mapM (loadCertifySignerTKsFromFile signerPasswords) certifyUserIdSignerFiles- when (null signerTks) $- failWith MissingInput "certify-userid: no signer certificate found"- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- certPkts <- decodeOpenPGPInput "standard input" input- targetTks <- runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| CC.sinkList- when (null targetTks) $- failWith MissingInput "certify-userid: no certificate found on standard input"- let targetUserIds = map T.pack certifyUserIds- requireSelfSig = not certifyUserIdNoRequireSelfSig- updatedTargets <-- mapM- (\targetTk -> addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks)- targetTks- let output = runPut (mapM_ Bin.put updatedTargets)- armorOutput =- case certifyUserIdOutputFormat of- Just "binary" -> output- _ -> AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]- BL.putStr armorOutput--loadCertifySignerTKsFromFile :: [BL.ByteString] -> String -> IO [TKUnknown]-loadCertifySignerTKsFromFile signerPasswords path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy- packets <- decodeOpenPGPInput path lbs- tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| CC.sinkList- let fallbackTks = signingFallbackTKs packets- when (null tks && null fallbackTks) $- failWith MissingInput ("certify-userid: no signer key material found in " ++ path)- mapM- (unlockTransferableSecretKeyMaterial- "certify-userid failed"- path- "--with-key-password"- signerPasswords)- (if null tks then fallbackTks else tks)--addUserIdCertifications :: TKUnknown -> [Text] -> Bool -> [TKUnknown] -> IO TKUnknown-addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do- forM_ targetUserIds $ \targetUserId ->- case find ((== targetUserId) . fst) (_tkuUIDs targetTk) of- Nothing ->- failWith- CertUserIdNoMatch- ("certify-userid: target certificate has no user ID matching " ++- T.unpack targetUserId)- Just (_, sigs) ->- when (requireSelfSig && not (any (signatureMatchesSigner targetTk) sigs)) $- failWith- CertUserIdNoMatch- ("certify-userid: target user ID has no self-signature: " ++- T.unpack targetUserId)- newSigs <-- concat <$>- forM- signerTks- (\signerTk ->- forM- targetUserIds- (\targetUserId -> do- sig <- createUIDCertification targetUserId signerTk- pure (targetUserId, sig)))- let updateUID (uid, sigs) =- if uid `elem` targetUserIds- then (uid, sigs ++ map snd (filter ((== uid) . fst) newSigs))- else (uid, sigs)- pure $ targetTk {_tkuUIDs = map updateUID (_tkuUIDs targetTk)}--createUIDCertification :: Text -> TKUnknown -> IO SignaturePayload-createUIDCertification targetUserId signerTk = do- let (signerPkp, mSignerSka) = _tkuKey signerTk- signerSka <-- case mSignerSka of- Just ska -> pure ska- Nothing -> failWith KeyCannotCertify "certify-userid: signer certificate has no secret key material"- signingKey <- rsaSigningKey signerSka- issuer <- issuerSubpacketsFor "certify-userid" signerPkp- let hashed = [SigSubPacket False (SigCreationTime (_timestamp signerPkp))]- certification = signUserIDwithRSA signerPkp (UserId targetUserId) hashed issuer signingKey- case certification of- Left err -> failWith BadData ("certify-userid: failed to create certification: " ++ show err)- Right sig -> pure sig--doRevokeKey :: POSIXTime -> RevokeKeyOptions -> IO ()-doRevokeKey cpt RevokeKeyOptions {..} = do- keyPasswordsRaw <- loadPasswordFiles "revoke-key" "--with-key-password" revokeKeyPasswordFiles- let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- keyPkts <- decodeOpenPGPInput "standard input" input- keyTks <- runConduitRes $ CL.sourceList keyPkts .| conduitToTKsDropping .| CC.sinkList- when (null keyTks) $- failWith MissingInput "revoke-key: no key found on standard input"- revocationSigPkts <- mapM (createKeyRevocation keyPasswords) keyTks- let output = runPut (mapM_ Bin.put revocationSigPkts)- BL.putStr $- if revokeKeyNoArmor- then output- else AA.encodeLazy [Armor ArmorSignature [] output]- where- createKeyRevocation keyPasswords' keyTk = do- unlockedTk <-- unlockTransferableSecretKeyMaterial- "revoke-key failed"- "standard input"- "--with-key-password"- keyPasswords'- keyTk- let (pkp, mSka) = _tkuKey unlockedTk- ska <-- case mSka of- Just s -> pure s- Nothing -> failWith KeyCannotCertify "revoke-key: key has no secret key material"- signingKey <- rsaSigningKey ska- issuer <- issuerSubpacketsFor "revoke-key" pkp- let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]- revocation = signKeyRevocationWithRSA pkp hashed issuer signingKey- case revocation of- Left err -> failWith BadData ("revoke-key: failed to create revocation: " ++ show err)- Right sig -> pure (SignaturePkt sig)--doRevokeUserId :: POSIXTime -> RevokeUserIdOptions -> IO ()-doRevokeUserId cpt RevokeUserIdOptions {..} = do- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- keyPkts <- decodeOpenPGPInput "standard input" input- keyTks <- runConduitRes $ CL.sourceList keyPkts .| conduitToTKsDropping .| CC.sinkList- when (null keyTks) $- failWith MissingInput "revoke-userid: no key found on standard input"- let keyTk = head keyTks- (pkp, mSka) = _tkuKey keyTk- targetUserId = T.pack revokeUserIdString- uidExists <-- if any ((== targetUserId) . fst) (_tkuUIDs keyTk)- then pure True- else failWith MissingInput ("revoke-userid: key has no user ID matching " ++ revokeUserIdString)- ska <-- case mSka of- Just s -> pure s- Nothing -> failWith KeyCannotCertify "revoke-userid: key has no secret key material"- signingKey <- rsaSigningKey ska- issuer <- issuerSubpacketsFor "revoke-userid" pkp- let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]- revocation = signCertRevocationWithRSA pkp (UserId targetUserId) hashed issuer signingKey- case revocation of- Left err -> failWith BadData ("revoke-userid: failed to create revocation: " ++ show err)- Right sig -> do- let revocationSigPkt = SignaturePkt sig- output = runPut (Bin.put revocationSigPkt)- BL.putStr $- if revokeUserIdNoArmor- then output- else AA.encodeLazy [Armor ArmorSignature [] output]--doUpdateKey :: POSIXTime -> UpdateKeyOptions -> IO ()-doUpdateKey cpt UpdateKeyOptions {..} = do- keyPasswordsRaw <- loadPasswordFiles "update-key" "--with-key-password" updateKeyPasswordFiles- let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw- when updateKeyRevokeDeprecatedKeys $- hPutStrLn stderr- "Warning: update-key: --revoke-deprecated-keys requested, but no deprecated-key detector is available; proceeding without synthetic revocations."- stdinInput <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- stdinPkts <- decodeOpenPGPInput "stdin" stdinInput- stdinTks <- runConduitRes $ CL.sourceList stdinPkts .| conduitToTKsDropping .| CC.sinkList- when (null stdinTks) $- failWith MissingInput "update-key: no key found on standard input"- updateSourceTks <- concat <$> mapM loadVerifyTKsFromFile updateKeyMergeCerts- when (null updateSourceTks) $- failWith MissingInput "update-key: no update keys found"- stdinUnlocked <- mapM (unlockUpdateKeyMaterial "standard input" keyPasswords) stdinTks- updateUnlocked <- mapM (unlockUpdateKeyMaterial "update input" keyPasswords) updateSourceTks- let updateTks =- if updateKeySigningOnly- then filter (updateKeyHasSigningCapability cpt) updateUnlocked- else updateUnlocked- when (updateKeySigningOnly && null updateTks) $- failWith MissingInput "update-key: no signing-capable update keys found"- let updatedTks =- map- (\targetTk ->- foldl'- (<>)- targetTk- (selectUpdateMergeInputs cpt updateKeyNoAddedCapabilities targetTk updateTks))- stdinUnlocked- -- Choose armor type based on whether updated key has secret material- armorType = if any hasSecretKeyMaterial updatedTks- then ArmorPrivateKeyBlock- else ArmorPublicKeyBlock- output = runPut (mapM_ Bin.put updatedTks)- BL.putStr $- if updateKeyNoArmor- then output- else AA.encodeLazy [Armor armorType [] output]--doMergeCerts :: MergeCertsOptions -> IO ()-doMergeCerts MergeCertsOptions {..} = do- stdinInput <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- stdinPkts <- decodeOpenPGPInput "stdin" stdinInput- stdinTks <- runConduitRes $ CL.sourceList stdinPkts .| conduitToTKsDropping .| CC.sinkList- mergeInTks <- concat <$> mapM loadVerifyTKsFromFile mergeCertsFiles- let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks- output = runPut (mapM_ Bin.put mergedTks)- BL.putStr $- if mergeCertsNoArmor || BL.null output- then output- else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]--mergeCertificatesForOutput :: [TKUnknown] -> [TKUnknown] -> [TKUnknown]-mergeCertificatesForOutput stdinTks mergeInTks =- map mergeGroup (groupByPrimaryKey stdinTks)- where- -- Upstream could expose this as a dedicated helper over TKWithWireRep- -- so downstreams can keep packet provenance while merging certs.- mergeGroup (base, rest) =- let primary = certificatePrimaryFingerprint base- mergedStdin = foldl' (<>) base rest- matchingMergeInputs =- filter ((== primary) . certificatePrimaryFingerprint) mergeInTks- in foldl' (<>) mergedStdin matchingMergeInputs--groupByPrimaryKey :: [TKUnknown] -> [(TKUnknown, [TKUnknown])]-groupByPrimaryKey [] = []-groupByPrimaryKey (tk:rest) =- let primary = certificatePrimaryFingerprint tk- (samePrimary, differentPrimary) =- partition ((== primary) . certificatePrimaryFingerprint) rest- in (tk, samePrimary) : groupByPrimaryKey differentPrimary--certificatePrimaryFingerprint :: TKUnknown -> B.ByteString-certificatePrimaryFingerprint =- BL.toStrict . unFingerprint . fingerprint . fst . _tkuKey--unlockUpdateKeyMaterial :: String -> [BL.ByteString] -> TKUnknown -> IO TKUnknown-unlockUpdateKeyMaterial _ [] tk = pure tk-unlockUpdateKeyMaterial source keyPasswords tk =- unlockTransferableSecretKeyMaterial- "update-key failed"- source- "--with-key-password"- keyPasswords- tk--updateKeyHasSigningCapability :: POSIXTime -> TKUnknown -> Bool-updateKeyHasSigningCapability cpt tk =- any- (\funKey ->- S.null (fkufs funKey) || S.member SignDataKey (fkufs funKey))- (tkToFunKeysAt cpt tk)--selectUpdateMergeInputs ::- POSIXTime- -> Bool- -> TKUnknown- -> [TKUnknown]- -> [TKUnknown]-selectUpdateMergeInputs cpt noAddedCaps targetTk updateTks =- filteredByCaps- where- targetPrimary = certificatePrimaryFingerprint targetTk- mergeCandidates =- filter ((== targetPrimary) . certificatePrimaryFingerprint) updateTks- targetCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt targetTk))- addsCapabilities updateTk =- let updateCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt updateTk))- in not (S.null (updateCapabilities S.\\ targetCapabilities))- filteredByCaps =- if noAddedCaps- then filter (not . addsCapabilities) mergeCandidates- else mergeCandidates--soP :: Parser SignOptions-soP =- SignOptions <$> switch (long "armor" <> help "armor the output") <*>- switch (long "no-armor" <> help "don't armor the output") <*>- optional- (strOption- (long "micalg-out" <>- metavar "MICALG" <> help "write MIME micalg parameter value to file")) <*>- many- (strOption- (long "with-key-password" <>- help "password for unlocking signing key material")) <*>- option- (eitherReader asTypeReader)- (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary) <*>- some- (strArgument- (metavar "KEYS..." <>- help "paths to at least one secret key, one key per filename"))- where- astypeHelp =- helpDoc . Just $- pretty "what to treat the input as" <>- softline <> list (map (pretty . fst) asTypes)--data SignOptions =- SignOptions- { sArmor :: Bool- , sNoArmor :: Bool- , sMicalgOut :: Maybe String- , sKeyPasswords :: [String]- , sAs :: AsBinaryText- , sKeyFiles :: [String]- }--asTypes :: [(String, AsBinaryText)]-asTypes = [("binary", AsBinary), ("text", AsText)]--data AsBinaryText- = AsBinary- | AsText- deriving (Eq)--data InlineSignMode- = InlineSignAsBinary- | InlineSignAsText- | InlineSignAsClearSigned- deriving (Eq)--data EncryptFor- = EncryptForAny- | EncryptForStorage- | EncryptForCommunications- deriving (Eq)--asTypeReader :: String -> Either String AsBinaryText-asTypeReader = note "unknown as type" . flip lookup asTypes--encryptForReader :: String -> Either String EncryptFor-encryptForReader "any" = Right EncryptForAny-encryptForReader "storage" = Right EncryptForStorage-encryptForReader "communications" = Right EncryptForCommunications-encryptForReader _ =- Left "encryption purpose must be one of: any, storage, communications"--doSign :: POSIXTime -> SignOptions -> IO ()-doSign pt SignOptions {..} = do- when (sNoArmor && sArmor) $- failWith IncompatibleOptions "sign: --armor and --no-armor are mutually exclusive"- forM_ sMicalgOut (ensureOutputPathAvailable "sign")- mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- when (sAs == AsText) $- ensureUTF8TextInput "sign" (BL.fromChunks mbs)- forM_ sMicalgOut (\_ -> ensureCanonicalMIMETextInput (BL.fromChunks mbs))- signingPasswordsRaw <- loadPasswordFiles "sign" "--with-key-password" sKeyPasswords- let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw- ks <- loadSigningKeys sKeyFiles signingPasswords- let ts = ThirtyTwoBitTimeStamp (floor pt)- payload' = BL.fromChunks mbs- payload = payload'- processedKeys <- mapM (normalizeSigningKey pt) ks- let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys- signingHash =- selectSigningHash- (concat perTransferKeySigners)- []- legacySigningHashFallbackOrder- when (any null perTransferKeySigners) $- failWith KeyCannotSign "sign: supplied key cannot produce detached signatures"- signatures <- mapM (signData sAs ts signingHash payload) (concat perTransferKeySigners)- let output = runPut (mapM_ (Bin.put . SignaturePkt) signatures)- case sMicalgOut of- Just outPath -> writeFileWithOutputExistsCheck "sign" outPath (renderMicalg signatures)- Nothing -> pure ()- BL.putStr $- if not sArmor && not sNoArmor- then AA.encodeLazy [Armor ArmorSignature [] output]- else output- where- signData ::- AsBinaryText- -> ThirtyTwoBitTimeStamp- -> HashAlgorithm- -> BL.ByteString- -> FunKey- -> IO SignaturePayload- signData mode t signHash d k = do- let st = case mode of { AsBinary -> BinarySig; AsText -> CanonicalTextSig }- payload = d- issuerPackets <- unhashed (fpkp k)- signWithKey "sign" (fpkp k) st signHash (hashed (fpkp k) t) issuerPackets payload (fmska k)- hashed pkp ct =- [ SigSubPacket False (SigCreationTime ct)- , SigSubPacket False (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))- ]- unhashed pkp = issuerSubpacketsFor "sign" pkp-loadSigningKeys :: [String] -> [BL.ByteString] -> IO [TKUnknown]-loadSigningKeys keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles- where- loadFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy- packets <- decodeOpenPGPInput path lbs- tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| CC.sinkList- let fallbackTks = signingFallbackTKs packets- when (null tks && null fallbackTks) $- failWith MissingInput ("sign: no secret key material found in " ++ path)- mapM (decryptSigningKeyMaterial path keyPasswords) (if null tks then fallbackTks else tks)--decryptSigningKeyMaterial :: FilePath -> [BL.ByteString] -> TKUnknown -> IO TKUnknown-decryptSigningKeyMaterial path keyPasswords =- unlockTransferableSecretKeyMaterial- "sign failed"- path- "--with-key-password"- keyPasswords--unlockTransferableSecretKeyMaterial ::- String -> FilePath -> String -> [BL.ByteString] -> TKUnknown -> IO TKUnknown--- 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'}- 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- ska' <- unlockSecretAddendum context path passwordOption keyPasswords pkp ska- pure (SecretSubkeyPkt pkp ska', sigs)- decryptSub sub = pure sub--unlockSecretAddendum ::- String -> FilePath -> String -> [BL.ByteString] -> SomePKPayload -> SKAddendum -> IO SKAddendum-unlockSecretAddendum _ _ _ _ _ sk@(SUUnencrypted _ _) = pure sk-unlockSecretAddendum context path passwordOption [] _ _ =- failWith- KeyIsProtected- (context ++ ": encrypted key material in " ++ path ++ " requires " ++ passwordOption)-unlockSecretAddendum context path passwordOption keyPasswords pkp sk =- case tryDecrypt keyPasswords of- Right decrypted -> pure decrypted- Left _ ->- failWith- KeyIsProtected- (context ++ ": could not unlock key material in " ++ path ++- " with provided " ++ passwordOption ++ " values")- where- tryDecrypt [] = Left ()- tryDecrypt (password:rest) =- case decryptPrivateKey (pkp, sk) password of- Left _ -> tryDecrypt rest- Right decrypted -> Right decrypted--normalizeSigningKey :: POSIXTime -> TKUnknown -> IO TKUnknown-normalizeSigningKey pt tk =- case processTK (Just pt) tk of- Left err -> failWith BadData ("sign: invalid signing key material: " ++ show err)- Right normalized -> pure normalized--signPayloadWithKeys ::- POSIXTime- -> AsBinaryText- -> BL.ByteString- -> [TKUnknown]- -> [HashAlgorithm]- -> [HashAlgorithm]- -> IO [SignaturePayload]-signPayloadWithKeys pt asMode payload keys recipientHashPrefs fallbackOrder = do- processedKeys <- mapM (normalizeSigningKey pt) keys- let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys- signingHash = selectSigningHash (concat perTransferKeySigners) recipientHashPrefs fallbackOrder- when (any null perTransferKeySigners) $- failWith KeyCannotSign "encrypt: supplied key cannot produce signatures"- mapM (signData asMode ts signingHash payload) (concat perTransferKeySigners)- where- ts = ThirtyTwoBitTimeStamp (floor pt)- signData ::- AsBinaryText- -> ThirtyTwoBitTimeStamp- -> HashAlgorithm- -> BL.ByteString- -> FunKey- -> IO SignaturePayload- signData mode t signHash d k = do- let st = case mode of { AsBinary -> BinarySig; AsText -> CanonicalTextSig }- payload = d- issuerPackets <- unhashed (fpkp k)- signWithKey "encrypt" (fpkp k) st signHash (hashed (fpkp k) t) issuerPackets payload (fmska k)- hashed pkp ct =- [ SigSubPacket False (SigCreationTime ct)- , SigSubPacket False (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))- ]- unhashed pkp = issuerSubpacketsFor "encrypt" pkp--signingCapableFunKeys :: POSIXTime -> TKUnknown -> [FunKey]-signingCapableFunKeys pt =- filter canSign . tkToFunKeysAt pt- where- canSign k =- canSignDataUsage (fkufs k) &&- case fmska k of- Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True- Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True- Just (SUUnencrypted (UnknownSKey _) _) ->- isEd25519PKA (_pkalgo (fpkp k)) || isEdDSAPKA (_pkalgo (fpkp k)) || isEd448PKA (_pkalgo (fpkp k))- _ -> False- 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 = signingCapableFunKeys---- | Algorithm-dispatching signature helper used by all sign paths.--- Supports RSA (v4), Ed25519 (v4), and Ed448 (v4).-signWithKey ::- String -- ^ context for error messages- -> SomePKPayload- -> SigType- -> HashAlgorithm- -> [SigSubPacket] -- ^ hashed subpackets- -> [SigSubPacket] -- ^ unhashed subpackets- -> BL.ByteString -- ^ payload to sign- -> Maybe SKAddendum- -> IO SignaturePayload-signWithKey ctx signerPKP st signHash hsd usd payload mska =- case mska of- Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) ->- validateRSASigningKeySize ctx signerPKP >>- if _keyVersion signerPKP == V6- then signRSAWithV6Salt (k {RSA.private_p = 0, RSA.private_q = 0})- else- signWithRSABuilder- signHash- (k {RSA.private_p = 0, RSA.private_q = 0})- Just (SUUnencrypted (EdDSAPrivateKey Ed25519 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- Just (SUUnencrypted (EdDSAPrivateKey Ed448 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- Just (SUUnencrypted (UnknownSKey rawBytes) _) ->- case () of- _ | isEd25519PKA (_pkalgo signerPKP) ->- do- normalized <- normalizeUnknownSecretForEdDSA ctx 32 rawBytes- case eitherCryptoError (Ed25519.secretKey normalized) 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- | isEd448PKA (_pkalgo signerPKP) ->- do- normalized <- normalizeUnknownSecretForEdDSA ctx 57 rawBytes- case eitherCryptoError (Ed448.secretKey normalized) 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- _ ->- failWith- UnsupportedAsymmetricAlgo- (ctx ++ " failed: unsupported unknown signing key for algorithm " ++- show (_pkalgo signerPKP))- _ -> failWith BadData (ctx ++ " failed: unsupported or encrypted signing key")- where- signEd25519 sk- = signWithV6Salt (\salt -> signDataWithEd25519V6 st salt sk hsd usd payload)- signEd448 sk- = signWithV6Salt (\salt -> signDataWithEd448V6 st salt sk hsd usd payload)- signRSAWithV6Salt privateKey =- signWithV6Salt (\salt -> signDataWithRSAV6 st salt privateKey hsd usd payload)- signWithV6Salt signer = go [32, 64, 16, 20, 28, 48] []- where- go [] _ =- failWith BadData (ctx ++ " failed: unable to construct a valid v6 signature salt")- go (n:rest) tried = do- bytes <- getRandomBytes n- case signer (SignatureSalt (BL.fromStrict bytes)) of- Right sig -> pure sig- Left (SignV6SaltSizeMismatch _ expected _) ->- let expectedLen = fromIntegral expected- in if expectedLen `elem` tried- then failWith BadData (ctx ++ " failed: unable to resolve v6 signature salt size")- else go (expectedLen : rest) (expectedLen : tried)- Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)- signWithRSABuilder hashToUse privateKey =- let builder =- SP.addUnhashedSubs- (SubpacketList usd)- (SP.addHashedSubs- (SubpacketList hsd)- (SP.sigBuilderInit st hashToUse))- in case signDataWithRSABuilder builder privateKey payload of- Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)- Right sig -> pure sig--normalizeUnknownSecretForEdDSA :: String -> Int -> BL.ByteString -> IO B.ByteString-normalizeUnknownSecretForEdDSA ctx expectedLen rawLbs- | B.length raw == expectedLen = pure raw- | B.length raw >= 2 =- let bits =- (fromIntegral (B.index raw 0) `shiftL` 8) .|. fromIntegral (B.index raw 1)- mpiBytes = (bits + 7) `div` 8- payload = B.drop 2 raw- in if B.length payload == mpiBytes && mpiBytes <= expectedLen- then pure (i2ospOf_ expectedLen (os2ip payload))- else bad- | otherwise = bad- where- raw = BL.toStrict rawLbs- bad =- failWith- BadData- (ctx ++ " failed: unsupported EdDSA secret key encoding (length=" ++- show (B.length raw) ++ ")")--validateRSASigningKeySize :: String -> SomePKPayload -> IO ()-validateRSASigningKeySize ctx signerPKP =- case pubkeySize (_pubkey signerPKP) of- Right bits- | bits < 2048 ->- failWith- KeyCannotSign- (ctx ++ " failed: RSA signing keys smaller than 2048 bits are not supported")- | otherwise -> pure ()- Left err ->- failWith- BadData- (ctx ++ " failed: unable to determine RSA key size: " ++ err)---- FIXME: clean this up-isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool-isEd25519PKA pka = fromFVal pka == 27-isEdDSAPKA pka = fromFVal pka == 22-isEd448PKA pka = fromFVal pka == 28--selectSigningHash :: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm-selectSigningHash signerKeys recipientHashPrefs fallbackOrder =- fromMaybe SHA512 (find (hashSupportedByAllSigners signerKeys) candidateOrder)- where- requestedPrefs =- if null recipientHashPrefs- then signerPrefs- else recipientHashPrefs- signerPrefs = concatMap fpreferredHashes signerKeys- filteredRequested = filter (hashSupportedByAllSigners signerKeys) requestedPrefs- filteredSignerPrefs = filter (hashSupportedByAllSigners signerKeys) signerPrefs- candidateOrder = filteredRequested ++ filteredSignerPrefs ++ fallbackOrder--legacySigningHashFallbackOrder :: [HashAlgorithm]-legacySigningHashFallbackOrder = [SHA512, SHA384, SHA256, SHA224]--rfc9580SigningHashFallbackOrder :: [HashAlgorithm]-rfc9580SigningHashFallbackOrder = [SHA3_512, SHA3_256, SHA512, SHA384, SHA256, SHA224]--hashSupportedByAllSigners :: [FunKey] -> HashAlgorithm -> Bool-hashSupportedByAllSigners signers ha =- not (isDeprecatedHashAlgorithm ha) &&- all (`signerSupportsHashAlgorithm` ha) signers--signerSupportsHashAlgorithm :: FunKey -> HashAlgorithm -> Bool-signerSupportsHashAlgorithm signer ha =- not (isDeprecatedHashAlgorithm ha) &&- case _pkalgo (fpkp signer) of- RSA -> rsaPKCS15SupportedHash ha- DeprecatedRSASignOnly -> rsaPKCS15SupportedHash ha- DeprecatedRSAEncryptOnly -> rsaPKCS15SupportedHash ha- _ -> not (isOtherHashAlgorithm ha)--rsaPKCS15SupportedHash :: HashAlgorithm -> Bool-rsaPKCS15SupportedHash SHA224 = True-rsaPKCS15SupportedHash SHA256 = True-rsaPKCS15SupportedHash SHA384 = True-rsaPKCS15SupportedHash SHA512 = True-rsaPKCS15SupportedHash _ = False--isDeprecatedHashAlgorithm :: HashAlgorithm -> Bool-isDeprecatedHashAlgorithm DeprecatedMD5 = True-isDeprecatedHashAlgorithm SHA1 = True-isDeprecatedHashAlgorithm RIPEMD160 = True-isDeprecatedHashAlgorithm _ = False--isOtherHashAlgorithm :: HashAlgorithm -> Bool-isOtherHashAlgorithm (OtherHA _) = True-isOtherHashAlgorithm _ = False--hashAlgorithmHeaderName :: HashAlgorithm -> String-hashAlgorithmHeaderName DeprecatedMD5 = "MD5"-hashAlgorithmHeaderName SHA1 = "SHA1"-hashAlgorithmHeaderName RIPEMD160 = "RIPEMD160"-hashAlgorithmHeaderName SHA224 = "SHA224"-hashAlgorithmHeaderName SHA256 = "SHA256"-hashAlgorithmHeaderName SHA384 = "SHA384"-hashAlgorithmHeaderName SHA512 = "SHA512"-hashAlgorithmHeaderName SHA3_256 = "SHA3-256"-hashAlgorithmHeaderName SHA3_512 = "SHA3-512"-hashAlgorithmHeaderName (OtherHA _) = "SHA512"--ensureCanonicalMIMETextInput :: BL.ByteString -> IO ()-ensureCanonicalMIMETextInput lbs = do- let bs = BL.toStrict lbs- when (B.any (> 0x7f) bs) $- failWith- ExpectedText- "sign: --micalg-out requires canonical 7-bit text data on standard input"- case TE.decodeUtf8' bs of- Left _ ->- failWith- ExpectedText- "sign: --micalg-out requires UTF-8 text data on standard input"- Right _ -> pure ()- when (not (canonicalCRLFLineEndings bs)) $- failWith- ExpectedText- "sign: --micalg-out requires CRLF line endings on standard input"- when (hasTrailingLineWhitespace bs) $- failWith- ExpectedText- "sign: --micalg-out requires no trailing line whitespace on standard input"- where- canonicalCRLFLineEndings bytes = go (B.unpack bytes)- where- go [] = True- go [13] = False- go (13:10:rest) = go rest- go (13:_) = False- go (10:_) = False- go (_:rest) = go rest- hasTrailingLineWhitespace bytes =- endsWithWhitespace bytes || trailingWhitespaceBeforeCRLF (B.unpack bytes)- endsWithWhitespace bytes =- case B.unsnoc bytes of- Just (_, c) -> c == 32 || c == 9- Nothing -> False- trailingWhitespaceBeforeCRLF (a:13:10:rest)- | a == 32 || a == 9 = True- | otherwise = trailingWhitespaceBeforeCRLF (13:10:rest)- trailingWhitespaceBeforeCRLF (_:rest) = trailingWhitespaceBeforeCRLF rest- trailingWhitespaceBeforeCRLF _ = False--ensureUTF8TextInput :: String -> BL.ByteString -> IO ()-ensureUTF8TextInput subcommand lbs =- case TE.decodeUtf8' (BL.toStrict lbs) of- Left _ ->- failWith- ExpectedText- (subcommand ++ ": --as=text requires UTF-8 text on standard input")- Right _ -> pure ()--canonicalizeUTF8Text :: BL.ByteString -> BL.ByteString-canonicalizeUTF8Text =- BL.fromStrict .- TE.encodeUtf8 . T.intercalate (T.pack "\r\n") . T.lines . TE.decodeUtf8 . BL.toStrict--renderMicalg :: [SignaturePayload] -> String-renderMicalg signatures =- case nub (mapMaybe signatureMicalg signatures) of- [micalg] -> micalg- _ -> ""- where- signatureMicalg (SigV4 _ _ ha _ _ _ _) = hashAlgorithmMicalg ha- signatureMicalg _ = Nothing- hashAlgorithmMicalg DeprecatedMD5 = Just "pgp-md5"- hashAlgorithmMicalg SHA1 = Just "pgp-sha1"- hashAlgorithmMicalg RIPEMD160 = Just "pgp-ripemd160"- hashAlgorithmMicalg SHA224 = Just "pgp-sha224"- hashAlgorithmMicalg SHA256 = Just "pgp-sha256"- hashAlgorithmMicalg SHA384 = Just "pgp-sha384"- hashAlgorithmMicalg SHA512 = Just "pgp-sha512"- hashAlgorithmMicalg SHA3_256 = Just "pgp-sha3-256"- hashAlgorithmMicalg SHA3_512 = Just "pgp-sha3-512"- hashAlgorithmMicalg (OtherHA _) = Nothing--grabKey :: String -> IO TKUnknown-grabKey fp = do- kbs <- runConduitRes $ CB.sourceFile fp .| CL.consume- let lbs = BL.fromChunks kbs- pkts <- decodeOpenPGPInput fp lbs- tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| CC.sinkList- case tks of- (k:_) -> pure k- [] ->- case signingFallbackTKs pkts of- (k:_) -> pure k- [] -> failWith MissingInput ("no secret key material found in " ++ fp)--signingFallbackTKs :: [Pkt] -> [TKUnknown]-signingFallbackTKs packets =- [TKUnknown (pkp, Just ska) [] [] [] [] | SecretKeyPkt pkp ska <- packets]--data FunKey =- FunKey- { fpkp :: SomePKPayload- , fmska :: Maybe SKAddendum- , fkufs :: S.Set KeyFlag- , fpreferredHashes :: [HashAlgorithm]- , fpreferredSymmetricAlgorithms :: [SymmetricAlgorithm]- , fsupportsSEIPDv2 :: Bool- }- deriving (Show)--tkToFunKeysAt :: POSIXTime -> TKUnknown -> [FunKey]-tkToFunKeysAt pt tk@(TKUnknown (pkp, mska) _ uids _ subs) =- catMaybes (mainKey : map extract subs)- where- mainPreferredHashes = effectiveHashPreferencesAt pt tk- mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt tk- mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt tk- mainKey =- Just- (FunKey- pkp- mska- (fromMaybe S.empty (grabASig uids >>= sig2KUFs))- mainPreferredHashes- mainPreferredSymmetricAlgorithms- mainSupportsSEIPDv2)- sig2KUFs = getHasheds >=> find isKUF >=> getKUFs- grabASig :: [(a, [b])] -> Maybe b- grabASig = (listToMaybe >=> listToMaybe) . map snd -- FIXME: this should grab the "best" sig- getHasheds :: SignaturePayload -> Maybe [SigSubPacket]- getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds- getHasheds (SigV6 _ _ _ _ hasheds _ _ _) = Just hasheds- getHasheds _ = Nothing- getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag)- getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs- getKUFs _ = Nothing- extract ((SecretSubkeyPkt spkp sska), sigs) =- return- (FunKey- spkp- (Just sska)- (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))- mainPreferredHashes- mainPreferredSymmetricAlgorithms- mainSupportsSEIPDv2)- extract ((PublicSubkeyPkt spkp), sigs) =- return- (FunKey- spkp- Nothing- (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))- mainPreferredHashes- mainPreferredSymmetricAlgorithms- mainSupportsSEIPDv2)- extract _ = Nothing--effectiveHashPreferencesAt :: POSIXTime -> TKUnknown -> [HashAlgorithm]-effectiveHashPreferencesAt pt tk =- concatMap toHashes $- fromMaybe [] (effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) tk)- where- toHashes (PreferredHashAlgorithms hashes) = hashes- toHashes _ = []--effectiveSymmetricPreferencesAt :: POSIXTime -> TKUnknown -> [SymmetricAlgorithm]-effectiveSymmetricPreferencesAt pt tk =- concatMap toSymmetricAlgorithms $- fromMaybe [] (effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) tk)- where- toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms- toSymmetricAlgorithms _ = []--effectiveSEIPDv2SupportAt :: POSIXTime -> TKUnknown -> Bool-effectiveSEIPDv2SupportAt pt tk =- any supportsSEIPDv2Flag $- concatMap toFeatureFlags $- fromMaybe [] (effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) tk)- where- toFeatureFlags (Features flags) = S.toList flags- toFeatureFlags _ = []- supportsSEIPDv2Flag FeatureSEIPDv2 = True- supportsSEIPDv2Flag _ = False---- SOP Handler Stubs--- These implement the stateless OpenPGP CLI commands per draft-16--doVerify :: POSIXTime -> VerifyOptions -> IO ()-doVerify cpt VerifyOptions {..} = do- (krs, verifyTks) <- loadVerifyContext cpt verifyCertFiles- signatureInput <- runConduitRes $ CC.sourceFile verifySigFile .| CC.sinkLazy- sigPkts <- decodeLikeSignaturePackets signatureInput- let sigs = V.fromList (filter isDetachedVerificationSignaturePkt sigPkts)- blob <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- upperBound <- verificationUpperBound cpt verifyNotAfter- lowerBound <- verificationLowerBound cpt verifyNotBefore- let sigsWithoutUnsupportedCritical =- V.filter (not . detachedSignatureHasUnsupportedCriticalSubpackets) sigs- binaryVerifications <- verifyWithLiteralData BinaryData blob sigsWithoutUnsupportedCritical krs upperBound- verifications <-- if any isRight binaryVerifications- then pure binaryVerifications- else- verifyWithLiteralData- TextData- blob- sigsWithoutUnsupportedCritical- krs- upperBound- let decodedVerifications = map (first show) verifications- signerPolicyAdjusted =- map (enforceVerificationSignerPolicy cpt verifyTks) decodedVerifications- let filtered =- filterByVerificationBounds lowerBound upperBound signerPolicyAdjusted- policyFiltered =- filter (not . verificationResultUsesDeprecatedHash) filtered- mapM_ (putStrLn . renderSOPVerificationLine verifyTks) (rights policyFiltered)- case any isRight policyFiltered of- True -> exitSuccess- _ -> failWith NoSignature "No acceptable signatures found"- where- decodeLikeSignaturePackets lbs = do- decodedArmors <- decodeAsciiArmorInput ("signature input in " ++ verifySigFile) lbs- case decodedArmors of- Just armors ->- case firstBy isDetachedSignatureArmor armors of- Just (Armor ArmorSignature _ bs) ->- parseOpenPGPPackets- ("signature input in " ++ verifySigFile)- (BL.fromStrict (BLC8.toStrict bs))- _ ->- case firstBy isDetachedSignatureUnsupportedArmor armors of- Just (ClearSigned _ _ _) ->- failWith- BadData- ("verify: expected detached signatures in " ++ verifySigFile)- Just (Armor _ _ _) ->- failWith- BadData- ("verify: expected signature armor in " ++ verifySigFile)- _ -> parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs- Nothing -> parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs- verifyWithLiteralData format payload sigs keyring upperBound =- runConduitRes $- CC.yieldMany (V.cons (LiteralDataPkt format mempty 0 payload) sigs) .|- conduitVerify keyring upperBound .|- CC.sinkList--detachedSignatureHasUnsupportedCriticalSubpackets :: Pkt -> Bool-detachedSignatureHasUnsupportedCriticalSubpackets (SignaturePkt sig) =- any criticalUnsupported (signatureHashedSubpackets sig)- where- criticalUnsupported (SigSubPacket True (OtherSigSub _ _)) = True- criticalUnsupported (SigSubPacket True (UserDefinedSigSub _ _)) = True- criticalUnsupported (SigSubPacket True (NotationData _ _ _)) = True- criticalUnsupported _ = False-detachedSignatureHasUnsupportedCriticalSubpackets _ = False--signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]-signatureHashedSubpackets (SigV4 _ _ _ hashed _ _ _) = hashed-signatureHashedSubpackets (SigV6 _ _ _ _ hashed _ _ _) = hashed-signatureHashedSubpackets _ = []--verificationResultUsesDeprecatedHash :: Either String Verification -> Bool-verificationResultUsesDeprecatedHash (Right verification) =- verificationUsesDeprecatedHash verification-verificationResultUsesDeprecatedHash _ = False--verificationUsesDeprecatedHash :: Verification -> Bool-verificationUsesDeprecatedHash (Verification _ sigPayload _) =- isDeprecatedHashAlgorithm (signatureHashAlgorithm sigPayload)--signatureHashAlgorithm :: SignaturePayload -> HashAlgorithm-signatureHashAlgorithm (SigV3 _ _ _ _ ha _ _) = ha-signatureHashAlgorithm (SigV4 _ _ ha _ _ _ _) = ha-signatureHashAlgorithm (SigV6 _ _ ha _ _ _ _ _) = ha-signatureHashAlgorithm (SigVOther _ _) = OtherHA 0--enforceVerificationSignerPolicy ::- POSIXTime- -> [TKUnknown]- -> Either String Verification- -> Either String Verification-enforceVerificationSignerPolicy _ _ result@(Left _) = result-enforceVerificationSignerPolicy cpt verifyTks result@(Right verification)- | signerAllowed = result- | otherwise = Left "verification failed: signer key is not valid for signing at signature creation time"- where- signerAllowed = any signerMatchesProcessed verifyTks- signerFp = fingerprint (_verificationSigner verification)- verificationTimePosix =- maybe cpt (realToFrac . utcTimeToPOSIXSeconds) (signatureCreationTime (_verificationSignature verification))- verificationTime = posixSecondsToUTCTime verificationTimePosix- signerMatchesProcessed tk- | not (keyMatchesFingerprint True tk signerFp) = False- | keyMatchesFingerprint False tk signerFp = True- | otherwise = any (subkeyAllowsSigning verificationTime signerFp) (_tkuSubs tk)--subkeyAllowsSigning :: UTCTime -> Fingerprint -> (Pkt, [SignaturePayload]) -> Bool-subkeyAllowsSigning t signerFp (pkt, sigs) =- case subkeyPayload pkt of- Just pkp- | fingerprint pkp == signerFp ->- any (bindingSignatureAllowsSigning t) (filter isSKBindingSig sigs)- _ -> False- where- subkeyPayload (PublicSubkeyPkt pkp) = Just pkp- subkeyPayload (SecretSubkeyPkt pkp _) = Just pkp- subkeyPayload _ = Nothing--bindingSignatureAllowsSigning :: UTCTime -> SignaturePayload -> Bool-bindingSignatureAllowsSigning t sig =- allowsSigning && hasValidBacksig- where- allowsSigning =- let flagSets = signatureKeyFlagSets sig- in null flagSets || any (S.member SignDataKey) flagSets- hasValidBacksig =- any- (\embedded ->- isPKBindingSig embedded &&- not (signatureExpiredAt t embedded))- (signatureEmbeddedSignatures sig)--signatureEmbeddedSignatures :: SignaturePayload -> [SignaturePayload]-signatureEmbeddedSignatures sig =- [ embedded- | SigSubPacket _ (EmbeddedSignature embedded) <- signatureSubpackets sig- ]--signatureKeyFlagSets :: SignaturePayload -> [S.Set KeyFlag]-signatureKeyFlagSets sig =- [ flags- | SigSubPacket _ (KeyFlags flags) <- signatureSubpackets sig- ]--signatureExpiredAt :: UTCTime -> SignaturePayload -> Bool-signatureExpiredAt t sig =- case (signatureCreationTime sig, signatureValiditySeconds sig) of- (Just created, Just validitySeconds) ->- utcTimeToPOSIXSeconds t >= utcTimeToPOSIXSeconds created + fromIntegral validitySeconds- _ -> False--signatureValiditySeconds :: SignaturePayload -> Maybe Integer-signatureValiditySeconds sig =- listToMaybe- [ fromIntegral secs- | SigSubPacket _ (SigExpirationTime (ThirtyTwoBitDuration secs)) <- signatureSubpackets sig- ]-verificationUpperBound ::- POSIXTime -> Maybe String -> IO (Maybe UTCTime)-verificationUpperBound cpt Nothing = return (Just (posixSecondsToUTCTime cpt))-verificationUpperBound _ (Just "-") = return Nothing-verificationUpperBound cpt (Just "now") =- return (Just (posixSecondsToUTCTime cpt))-verificationUpperBound _ (Just s) = do- let m = iso8601ParseM s :: Maybe UTCTime- case m of- Just t -> return (Just t)- Nothing -> failWith BadData ("Invalid DATE value: " ++ s)--verificationLowerBound ::- POSIXTime -> Maybe String -> IO (Maybe UTCTime)-verificationLowerBound _ Nothing = return Nothing-verificationLowerBound _ (Just "-") = return Nothing-verificationLowerBound cpt (Just "now") =- return (Just (posixSecondsToUTCTime cpt))-verificationLowerBound _ (Just s) = do- let m = iso8601ParseM s :: Maybe UTCTime- case m of- Just t -> return (Just t)- Nothing -> failWith BadData ("Invalid DATE value: " ++ s)--filterByVerificationBounds ::- Maybe UTCTime- -> Maybe UTCTime- -> [Either String Verification]- -> [Either String Verification]-filterByVerificationBounds lower upper = map (>>= ensureBounds)- where- ensureBounds v =- case signatureCreationTime (_verificationSignature v) of- Nothing -> Left "verification failed: signature is missing creation time"- Just sigTime- | Just upperBound <- upper- , sigTime > upperBound ->- Left "verification failed: signature created after --not-after bound"- | Just lowerBound <- lower- , sigTime < lowerBound ->- Left "verification failed: signature created before --not-before bound"- | otherwise -> Right v--signatureCreationTime :: SignaturePayload -> Maybe UTCTime-signatureCreationTime (SigV4 _ _ _ hashed _ _ _) =- firstCreationTime hashed-signatureCreationTime (SigV6 _ _ _ _ hashed _ _ _) =- firstCreationTime hashed-signatureCreationTime _ = Nothing--firstCreationTime :: [SigSubPacket] -> Maybe UTCTime-firstCreationTime = listToMaybe . mapMaybe getCreation- where- getCreation (SigSubPacket _ (SigCreationTime (ThirtyTwoBitTimeStamp ts))) =- Just (posixSecondsToUTCTime (fromIntegral ts))- getCreation _ = Nothing--isDetachedVerificationSignaturePkt :: Pkt -> Bool-isDetachedVerificationSignaturePkt (SignaturePkt (SigV4 sigType _ _ _ _ _ _)) =- sigType == BinarySig || sigType == CanonicalTextSig-isDetachedVerificationSignaturePkt (SignaturePkt (SigV6 sigType _ _ _ _ _ _ _)) =- sigType == BinarySig || sigType == CanonicalTextSig-isDetachedVerificationSignaturePkt _ = False--doInlineVerify :: POSIXTime -> InlineVerifyOptions -> IO ()-doInlineVerify cpt InlineVerifyOptions {..} = do- (krs, verifyTks) <- loadVerifyContext cpt inlineCertFiles- signedInput <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- upperBound <- verificationUpperBound cpt inlineNotAfter- lowerBound <- verificationLowerBound cpt inlineNotBefore- (allowTrailingSignatures, parsedPackets) <- inlineVerifyPackets signedInput- packets <- normalizeInlineVerifyPackets allowTrailingSignatures parsedPackets- let verifications =- map (first show) (verifyPacketsBatch krs upperBound packets)- filtered = filterByVerificationBounds lowerBound upperBound verifications- successLines = map (renderSOPVerificationLine verifyTks) (rights filtered)- renderedOut =- if null successLines- then ""- else unlines successLines- case verificationsOut of- Just outPath -> writeFileWithOutputExistsCheck "inline-verify" outPath renderedOut- Nothing -> pure ()- case any isRight filtered of- True -> extractSingleLiteralPayload packets >>= BL.putStr >> exitSuccess- _ -> failWith NoSignature "No acceptable signatures found"- where- inlineVerifyPackets :: BL.ByteString -> IO (Bool, [Pkt])- inlineVerifyPackets lbs = do- decodedArmors <- decodeAsciiArmorInput "inline-verify input" lbs- case decodedArmors of- Just armors ->- case listToMaybe (filter isInlineVerifyCandidateArmor armors) of- Just (Armor ArmorMessage _ bs) -> do- let packetBytes = BL.fromStrict (BLC8.toStrict bs)- packets <-- parseInlineVerifyMessagePackets- "inline-verify armored message"- packetBytes- pure (False, packets)- Just (ClearSigned headers cleartext signatureArmor) -> do- validateClearSignedEnvelopeBounds lbs- validateClearSignedHeaders headers- sigPkts <- clearSignedSignaturePackets signatureArmor- pure- ( True- , LiteralDataPkt TextData BL.empty 0 (BL.fromStrict (BLC8.toStrict cleartext)) :- sigPkts- )- Just (Armor _ _ _) ->- failWith- BadData- "inline-verify expects an armored OpenPGP message or cleartext signed message"- Nothing -> do- packets <- parseInlineVerifyMessagePackets "inline-verify input" lbs- pure (False, packets)- Nothing -> do- packets <- parseInlineVerifyMessagePackets "inline-verify input" lbs- pure (False, packets)-- parseInlineVerifyMessagePackets :: String -> BL.ByteString -> IO [Pkt]- parseInlineVerifyMessagePackets context packetBytes = do- rawPkts <- parseRawOpenPGPPackets context packetBytes- when (any compressedPacketParseFailed rawPkts) $- failWith BadData "inline-verify input has malformed compressed packet data"- when (any compressedPacketIsEmpty rawPkts) $- failWith BadData "inline-verify input has empty compressed packet data"- expanded <- expandPacketsStrict context rawPkts- when (any isMarkerPacket expanded && any isCompressedPacket rawPkts) $- failWith BadData "inline-verify input has malformed compressed packet sequence"- pure expanded-- expandPacketsStrict :: String -> [Pkt] -> IO [Pkt]- expandPacketsStrict context =- fmap concat . mapM expandPacket- where- expandPacket pkt =- case decompressPkt pkt of- Left err ->- failWith- BadData- (context ++ ": failed to parse compressed packet: " ++ renderCompressionError err)- Right packets -> pure packets--isInlineVerifyCandidateArmor :: Armor -> Bool-isInlineVerifyCandidateArmor (Armor ArmorMessage _ _) = True-isInlineVerifyCandidateArmor ClearSigned {} = True-isInlineVerifyCandidateArmor _ = False--clearSignedSignaturePackets :: Armor -> IO [Pkt]-clearSignedSignaturePackets (Armor ArmorSignature _ sigbs) =- let sigPktsSource = parseOpenPGPPackets "cleartext signature block" (BL.fromStrict (BLC8.toStrict sigbs))- in do- parsed <- sigPktsSource- let sigPkts = filter isSignaturePkt parsed- if null sigPkts- then failWith BadData "cleartext signature block has no signature packets"- else return sigPkts-clearSignedSignaturePackets (Armor _ _ _) =- failWith- BadData- "cleartext signed message does not contain an armored signature block"-clearSignedSignaturePackets (ClearSigned _ _ inner) =- clearSignedSignaturePackets inner--isSignaturePkt :: Pkt -> Bool-isSignaturePkt SignaturePkt {} = True-isSignaturePkt _ = False--normalizeInlineVerifyPackets :: Bool -> [Pkt] -> IO [Pkt]-normalizeInlineVerifyPackets allowTrailingSignatures pkts- | any isBrokenPacket relevantPkts =- failWith- BadData- "inline-verify input contains malformed packet encoding"- | any (not . isInlineVerificationPacket) filteredPkts =- failWith- BadData- "inline-verify input contains unsupported packet types"- | otherwise =- case ([pkt | pkt@LiteralDataPkt {} <- filteredPkts], [pkt | pkt@SignaturePkt {} <- filteredPkts]) of- ([], _) ->- failWith- BadData- "inline-verify input has no literal message payload"- ([_], []) ->- failWith- BadData- "inline-verify input has no signatures"- ([lit], sigs)- | not hasOnePass &&- (null signaturePositions || not (all (< literalIndex) signaturePositions)) &&- (not allowTrailingSignatures || not (all (> literalIndex) signaturePositions)) ->- failWith- BadData- "inline-verify input has malformed signed-message packet order"- | otherwise -> pure (lit : sigs)- (_, _) ->- failWith- BadData- "inline-verify input contains multiple literal payloads"- where- relevantPkts = filter (not . isMarkerPacket) pkts- filteredPkts = filter (not . isIgnorableInlineVerifyPacket) relevantPkts- packetPositions = zip [0 :: Int ..] filteredPkts- signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]- onePassPositions = [i | (i, OnePassSignaturePkt {}) <- packetPositions]- literalPositions = [i | (i, LiteralDataPkt {}) <- packetPositions]- hasOnePass = not (null onePassPositions)- literalIndex =- case literalPositions of- (i:_) -> i- [] -> -1- isBrokenPacket BrokenPacketPkt {} = True- isBrokenPacket _ = False--isIgnorableInlineVerifyPacket :: Pkt -> Bool-isIgnorableInlineVerifyPacket (OtherPacketPkt tag _) = tag >= 40-isIgnorableInlineVerifyPacket _ = False--isInlineVerificationPacket :: Pkt -> Bool-isInlineVerificationPacket LiteralDataPkt {} = True-isInlineVerificationPacket SignaturePkt {} = True-isInlineVerificationPacket OnePassSignaturePkt {} = True-isInlineVerificationPacket (OtherPacketPkt tag _) = tag >= 40-isInlineVerificationPacket BrokenPacketPkt {} = False-isInlineVerificationPacket _ = False--doEncrypt :: POSIXTime -> EncryptOptions -> IO ()-doEncrypt cpt EncryptOptions {..} = do- when (encNoArmor && encArmor) $- failWith IncompatibleOptions "encrypt: --armor and --no-armor are mutually exclusive"- payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- when (encAs == AsText) $- ensureUTF8TextInput "encrypt" payload- when encWithoutIntegrityCheck $- failWith- UnsupportedOption- "encrypt: --without-integrity-check is not supported by this backend"- symmetricPasswordsRaw <- loadPasswordFiles "encrypt" "--with-password" encPasswords- symmetricPasswords <-- mapM- (normalizeHumanReadablePassword "encrypt" "--with-password")- symmetricPasswordsRaw- signingKeyPasswordsRaw <- loadPasswordFiles "encrypt" "--with-key-password" encSignWithKeyPasswords- let signingKeyPasswords = concatMap passwordRetryCandidates signingKeyPasswordsRaw- encryptProfile <- parseEncryptProfile encProfile- when (not (null encRecipientCerts) && not (null symmetricPasswords)) $- failWith- UnsupportedOption- "encrypt: combining recipient certificates with --with-password is not yet supported"- recipientKeys <-- if null encRecipientCerts- then pure []- else loadEncryptRecipients cpt encFor encRecipientCerts- recipientHashPrefs <-- if null encRecipientCerts- then pure []- else loadRecipientPreferredHashes cpt encRecipientCerts- signatures <-- if null encSignWithKeyFiles- then pure []- else do- signingKeys <- loadSigningKeys encSignWithKeyFiles signingKeyPasswords- signPayloadWithKeys- cpt- encAs- payload- signingKeys- recipientHashPrefs- (case encryptProfile of- EncryptProfileRFC9580 -> rfc9580SigningHashFallbackOrder- EncryptProfileRFC4880 -> legacySigningHashFallbackOrder)- out <-- case encRecipientCerts of- [] -> doEncryptWithPassword encryptProfile payload symmetricPasswords encSessionKeyOutFile- _ ->- doEncryptForRecipients- encryptProfile- encAs- payload- signatures- recipientKeys- encSessionKeyOutFile- BL.putStr $- if encNoArmor- then out- else AA.encodeLazy [Armor ArmorMessage [] out]--doEncryptWithPassword ::- EncryptProfile- -> BL.ByteString- -> [BL.ByteString]- -> Maybe String- -> IO BL.ByteString-doEncryptWithPassword encryptProfile payload passwords sessionKeyOutFile = do- password <-- case passwords of- [] ->- failWith- MissingArg- "encrypt: supply at least one recipient certificate or --with-password"- [p] -> pure p- _ ->- failWith- UnsupportedOption- "encrypt: multiple --with-password values are not yet supported"- let exposure =- if isJust sessionKeyOutFile- then ExposeSessionMaterial- else DoNotExposeSessionMaterial- encrypted <-- case encryptProfile of- EncryptProfileRFC9580 -> do- s2kSalt <- Salt16 <$> getRandomBytes 16- iv <- IV <$> getRandomBytes 32- pure $- encryptMessage- RFC9580EncryptMessageOptions- { rfc9580EncryptMessageExposure = exposure- , rfc9580EncryptMessageSymmetricAlgorithm = AES256- , rfc9580EncryptMessageS2K = Argon2 s2kSalt 1 4 15- , rfc9580EncryptMessageIV = iv- }- (mkPassphrase password)- (mkClearPayload payload)- EncryptProfileRFC4880 -> do- salt <- Salt8 <$> getRandomBytes 8- iv <- IV <$> getRandomBytes 16- pure $- encryptMessage- RFC4880EncryptMessageOptions- { rfc4880EncryptMessageExposure = exposure- , rfc4880EncryptMessageSymmetricAlgorithm = AES256- , rfc4880EncryptMessageS2K = IteratedSalted SHA256 salt 65536- , rfc4880EncryptMessageIV = iv- }- (mkPassphrase password)- (mkClearPayload payload)- case encrypted of- Left err -> failWith BadData ("encrypt failed: " ++ show err)- Right (ciphertext, mRecoveredSession) -> do- forM_ sessionKeyOutFile $ \path ->- case mRecoveredSession of- Just recoveredSession ->- writeFileWithOutputExistsCheck- "encrypt"- path- ( renderSessionKeyOutLine- (fromFVal (recoveredSessionAlgorithm recoveredSession))- (unSessionKey (recoveredSessionKey recoveredSession)) ++ "\n"- )- Nothing ->- failWith- UnsupportedOption- "encrypt: --session-key-out unavailable for this password encryption mode"- pure (encryptedPayloadBytes ciphertext)--doEncryptForRecipients ::- EncryptProfile- -> AsBinaryText- -> BL.ByteString- -> [SignaturePayload]- -> [FunKey]- -> Maybe String- -> IO BL.ByteString-doEncryptForRecipients encryptProfile asMode payload signatures recipients sessionKeyOutFile = do- let targets = map recipientTargetFor recipients- payloadShape =- defaultRecipientPayloadShape- { recipientPayloadDataType = literalDataType- , recipientPayloadUseOnePassSignatures = not (null signatures)- , recipientPayloadSignatures = signatures- }- result <-- if useStrictEncryptProfile- then- encryptForRecipients- RecipientEncryptRequest- { recipientEncryptRequestTargets = targets- , recipientEncryptRequestPayloadShape = payloadShape- , recipientEncryptRequestPayload = BL.toStrict payload- , recipientEncryptRequestSymmetricOverride = symmetricOverride- , recipientEncryptRequestOverrides =- RecipientEncryptRequestSEIPDv2Overrides- { recipientEncryptRequestAEADOverride = Nothing- , recipientEncryptRequestChunkSizeOverride = Nothing- , recipientEncryptRequestSaltOverride = Nothing- }- }- else- encryptForRecipients- RecipientEncryptRequest- { recipientEncryptRequestTargets = targets- , recipientEncryptRequestPayloadShape = payloadShape- , recipientEncryptRequestPayload = BL.toStrict payload- , recipientEncryptRequestSymmetricOverride = symmetricOverride- , recipientEncryptRequestOverrides =- RecipientEncryptRequestSEIPDv1Overrides- { recipientEncryptRequestIVOverride = Nothing- }- }- RecipientEncryptResult {..} <-- case result of- Left err ->- failWith- (sopFailureForPKESKEncryptError err)- ("encrypt failed: " ++ renderPKESKEncryptError err)- Right value -> pure value- forM_ sessionKeyOutFile $ \path ->- writeFileWithOutputExistsCheck- "encrypt"- path- (renderSessionKeyOutLine- (fromFVal (pkeskSessionAlgorithm recipientEncryptSessionMaterial))- (unSessionKey (pkeskSessionKey recipientEncryptSessionMaterial)) ++ "\n")- pure (runPut (Bin.put (Block recipientEncryptPackets)))- where- literalDataType =- case asMode of- AsBinary -> BinaryData- AsText -> UTF8Data- anyRecipientSupportsSEIPDv2 = any fsupportsSEIPDv2 recipients- symmetricOverride- | useStrictEncryptProfile = preferredStrictSymmetric <|> Just AES256- | otherwise = preferredLegacySymmetric- isV6Recipient pkp = _keyVersion pkp == V6- useStrictEncryptProfile =- case encryptProfile of- EncryptProfileRFC9580 ->- anyRecipientSupportsSEIPDv2 || any (isV6Recipient . fpkp) recipients- EncryptProfileRFC4880 ->- anyRecipientSupportsSEIPDv2 || any (isV6Recipient . fpkp) recipients- preferredStrictSymmetric =- preferredRecipientSymmetric isSupportedStrictEncryptSymmetric- preferredLegacySymmetric =- preferredRecipientSymmetric isSupportedLegacyEncryptSymmetric- preferredRecipientSymmetric isSupported =- case filter (not . null) (map fpreferredSymmetricAlgorithms recipients) of- [] -> Nothing- prefLists ->- listToMaybe- [ candidate- | candidate <- filter isSupported (head prefLists)- , all (candidate `elem`) (tail prefLists)- ]- isSupportedStrictEncryptSymmetric algo =- algo `elem` [AES128, AES192, AES256]- -- Legacy profile fallback should not hard-fail on deprecated/unsupported- -- recipient preferences (e.g. IDEA in AEADED interop fixtures).- isSupportedLegacyEncryptSymmetric algo =- algo `elem` [AES128, AES192, AES256]- recipientTargetFor funkey =- let recipient = fpkp funkey- recipientNeedsV6PKESK =- useStrictEncryptProfile &&- (fsupportsSEIPDv2 funkey || _keyVersion recipient == V6)- in if _keyVersion recipient == V6- then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6- else- case _pkalgo recipient of- ECDH ->- -- Under strict (SEIPDv2) mode, keep Curve25519-compatible v4 ECDH keys on- -- the X25519/v6 path so ESK/payload versions stay aligned.- if recipientNeedsV6PKESK- then- case normalizeX25519CompatibleECDHRecipient recipient of- Just x25519Recipient ->- recipientEncryptionTargetWithStrategy x25519Recipient RecipientPreferV6- Nothing ->- recipientEncryptionTargetWithStrategy recipient RecipientPreferV6- else- recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop- DeprecatedRSAEncryptOnly ->- if recipientNeedsV6PKESK- then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6- else recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop- RSA ->- if recipientNeedsV6PKESK- then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6- else recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop- _ ->- if recipientNeedsV6PKESK- then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6- else recipientEncryptionTarget recipient--- normalizeX25519CompatibleECDHRecipient pkp =- case _pubkey pkp of- ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->- Just- (PKPayload- (_keyVersion pkp)- (_timestamp pkp)- (_v3exp pkp)- X25519- (_pubkey pkp))- _ -> Nothing--parseEncryptProfile :: Maybe String -> IO EncryptProfile-parseEncryptProfile Nothing = pure EncryptProfileRFC9580-parseEncryptProfile (Just profileName) =- case profileName of- "default" -> pure EncryptProfileRFC9580- "rfc9580" -> pure EncryptProfileRFC9580- "security" -> pure EncryptProfileRFC9580- "performance" -> pure EncryptProfileRFC9580- "rfc4880" -> pure EncryptProfileRFC4880- "compatibility" -> pure EncryptProfileRFC4880- _ -> failWith UnsupportedProfile ("encrypt: unsupported profile " ++ profileName)--doDecrypt :: POSIXTime -> DecryptOptions -> IO ()-doDecrypt cpt DecryptOptions {..} = do- when (decNoArmor && decArmor) $- failWith IncompatibleOptions "decrypt: --armor and --no-armor are mutually exclusive"- when decWithoutIntegrityCheck $- failWith- UnsupportedOption- "decrypt: --without-integrity-check is not supported by this backend"- sessionKeys <- parseDecryptSessionKeys decSessionKeys- (verificationOutputPath, usingDeprecatedVerifyOut) <-- resolveDecryptVerificationsOut decVerificationsOutFile decDeprecatedVerifyOutFile- let hasVerifyWith = not (null decVerifyCerts)- hasVerifyOut = isJust verificationOutputPath- hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter- doingVerification = hasVerifyWith && hasVerifyOut- when (hasVerifyWith /= hasVerifyOut) $- failWith- IncompleteVerification- "decrypt: verification requires both --verify-with and --verifications-out"- when (hasVerifyBounds && not doingVerification) $- failWith- IncompleteVerification- "decrypt: --verify-not-before/--verify-not-after require both --verify-with and --verifications-out"- passwords <- loadPasswordFiles "decrypt" "--with-password" decPasswords- keyPasswordsRaw <- loadPasswordFiles "decrypt" "--with-key-password" decKeyPasswords- let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw- when (null passwords && null sessionKeys && null decKeyFiles) $- failWith- MissingArg- "decrypt: supply KEYS, --with-password, or --with-session-key"- ciphertextInput <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- ciphertext <- decodeCiphertextInput ciphertextInput- validateDecryptPartialBodyEncoding ciphertext- ciphertextPktsRaw <- parseRawOpenPGPPackets "decrypt input" ciphertext- let ciphertextPkts =- filter- (\pkt ->- not (isForwardCompatUnknownESKPacket pkt || isUnsupportedSKESKPacket pkt))- ciphertextPktsRaw- -- Pre-flight: reject messages with no encrypted payload at all (upstream- -- won't produce a useful DecryptMalformedStructure for the empty case).- when (not (any isEncryptedPayloadPacket ciphertextPkts)) $- failWith BadData "decrypt input: no encrypted data packet found"- validateCiphertextPacketLayout ciphertextPkts- recipientKeys <- loadDecryptRecipientKeys cpt decKeyFiles keyPasswords- when (null recipientKeys && not (null decKeyFiles) && null passwords && null sessionKeys) $- failWith- CannotDecrypt- "decrypt failed: no usable secret key material found in provided KEYS"- let passwordAttempts =- case passwords of- [] -> [[]]- _ -> map (\password -> [password]) (concatMap passwordRetryCandidates passwords)- runDecryptAttemptWithPolicy decryptPolicy keyCandidates passwordBytes = do- passwordQueue <- newIORef passwordBytes- sessionKeyQueue <- newIORef (map decryptSessionKeyMaterial sessionKeys)- let decryptInputPkts = prioritizeDecryptablePKESKs keyCandidates ciphertextPkts- let keyResolutionResolver =- selectRecipientKeyInfosByRecipientIdentifier keyCandidates- let opts = Decrypt.DecryptOptions- { Decrypt.decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback keyResolutionResolver- , Decrypt.decryptOptionsPolicy = decryptPolicy- , Decrypt.decryptOptionsPassphraseCallback = decryptInputCallback passwordQueue sessionKeyQueue- }- (outcome, pkts) <- runConduitRes $- CL.sourceList decryptInputPkts .|- fuseBoth (Decrypt.conduitDecrypt opts) CL.consume- case outcome of- DecryptMalformedStructure reason ->- pure (Left reason)- DecryptTruncated ->- failWith BadData "decrypt failed: encrypted message is truncated"- _ -> pure (Right pkts)- tryDecryptWithPasswords [passwordBytes] =- runDecryptAttempt recipientKeys passwordBytes `catch` decryptIOFailureToSOP- tryDecryptWithPasswords (passwordBytes:rest) =- runDecryptAttempt recipientKeys passwordBytes `catch` retryNext- where- retryNext :: ExitCode -> IO [Pkt]- retryNext exitCode- | exitCode == ExitFailure (failureCode CannotDecrypt) =- tryDecryptWithPasswords rest- | otherwise = throwIO exitCode- tryDecryptWithPasswords [] =- failWith CannotDecrypt "decrypt failed: passphrase required but not provided"- decryptIOFailureToSOP :: IOException -> IO [Pkt]- decryptIOFailureToSOP err =- failWith CannotDecrypt ("decrypt failed: " ++ displayException err)- runDecryptAttempt keyCandidates passwordBytes = do- strictOutcome <- runDecryptAttemptWithPolicy defaultDecryptPolicy keyCandidates passwordBytes- case strictOutcome of- Right pkts -> pure pkts- Left reason- | shouldRetryLenientDecrypt reason keyCandidates passwordBytes -> do- lenientOutcome <- runDecryptAttemptWithPolicy lenientDecryptPolicy keyCandidates passwordBytes- case lenientOutcome of- Right pkts -> pure pkts- Left lenientReason ->- failWith BadData ("decrypt failed: malformed encrypted message structure (" ++ lenientReason ++ ")")- | otherwise ->- failWith BadData ("decrypt failed: malformed encrypted message structure (" ++ reason ++ ")")- shouldRetryLenientDecrypt reason keyCandidates passwordBytes- | "ESK packets must immediately precede encrypted data" `isInfixOf` reason = True- | "ESK packets present but none are version-aligned with SEIPDv2 payload" `isInfixOf` reason =- null passwordBytes &&- not (null keyCandidates) &&- any isLegacyRSAPKESK ciphertextPkts- | otherwise = False- isLegacyRSAPKESK (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) =- pka == RSA || pka == DeprecatedRSAEncryptOnly- isLegacyRSAPKESK _ = False- decryptedPktsRaw <- tryDecryptWithPasswords passwordAttempts- sessionKeyOutLine <-- resolveSessionKeyOut- decSessionKeyOutFile- sessionKeys- ciphertextPkts- recipientKeys- (concatMap passwordRetryCandidates passwords)- decryptedPkts <- do- decompressed <- mapM (either (\e -> failWith BadData (renderCompressionError e)) pure . recursivelyDecompressPacket) decryptedPktsRaw- pure (concat decompressed)- validateDecryptedMessageStructure decryptedPktsRaw decryptedPkts- payload <- extractSingleLiteralPayload decryptedPkts- BL.putStr payload- case (decSessionKeyOutFile, sessionKeyOutLine) of- (Just path, Just line) -> writeFileWithOutputExistsCheck "decrypt" path (line ++ "\n")- _ -> pure ()- when doingVerification $- doDecryptVerifyOutput- cpt- decVerifyCerts- verificationOutputPath- decVerifyNotBefore- decVerifyNotAfter- decryptedPkts- when usingDeprecatedVerifyOut $- hPutStrLn stderr- "Warning: --verify-out is deprecated; use --verifications-out instead."--data DecryptSessionKey =- DecryptSessionKey- { decryptSessionKeyMaterial :: BL.ByteString- , decryptSessionKeyOutLine :: Maybe String- }--decryptInputCallback ::- IORef [BL.ByteString] -> IORef [BL.ByteString] -> String -> IO BL.ByteString-decryptInputCallback passwordQueue sessionKeyQueue prompt- | "PKESK session key material" `isInfixOf` prompt = do- mSessionKeyMaterial <-- atomicModifyIORef' sessionKeyQueue $ \keys ->- case keys of- [] -> ([], Nothing)- (k:rest) -> (rest, Just k)- case mSessionKeyMaterial of- Just sessionKeyMaterial -> pure sessionKeyMaterial- Nothing ->- failWith- CannotDecrypt- "decrypt failed: PKESK session key material required but not provided"-decryptInputCallback passwordQueue _ _ = do- mPassword <-- atomicModifyIORef' passwordQueue $ \passwords ->- case passwords of- [] -> ([], Nothing)- (p:rest) -> (rest, Just p)- case mPassword of- Just password -> pure password- Nothing -> failWith CannotDecrypt "decrypt failed: passphrase required but not provided"--parseDecryptSessionKeys :: [String] -> IO [DecryptSessionKey]-parseDecryptSessionKeys = mapM parseSessionKeySpec--parseSessionKeySpec :: String -> IO DecryptSessionKey-parseSessionKeySpec spec =- case break (== ':') spec of- (_, "") -> do- material <- decodeHexBytes spec- pure- DecryptSessionKey- { decryptSessionKeyMaterial = BL.fromStrict material- , decryptSessionKeyOutLine = sessionKeyOutLineFromMaterial material- }- (algoSpec, ':' : keyHex) -> do- algo <- parseAlgorithmOctet algoSpec- keyBytes <- decodeHexBytes keyHex- when (B.null keyBytes) $- failWith BadData "decrypt: --with-session-key key material cannot be empty"- pure- DecryptSessionKey- { decryptSessionKeyMaterial = BL.fromStrict (encodeOpenPGPSessionKey algo keyBytes)- , decryptSessionKeyOutLine = Just (renderSessionKeyOutLine algo keyBytes)- }- _ -> failWith BadData "decrypt: invalid --with-session-key format"--resolveSessionKeyOut ::- Maybe String- -> [DecryptSessionKey]- -> [Pkt]- -> [PKESKRecipientKey]- -> [BL.ByteString]- -> IO (Maybe String)-resolveSessionKeyOut Nothing _ _ _ _ = pure Nothing-resolveSessionKeyOut (Just _) sessionKeys ciphertextPkts recipientKeys passwordCandidates =- case mapMaybe decryptSessionKeyOutLine sessionKeys of- (line:_) -> pure (Just line)- [] -> do- discoveredLine <-- recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates- case discoveredLine of- Just line -> pure (Just line)- Nothing -> pure Nothing--recoverSessionKeyOutFromCiphertext ::- [Pkt] -> [PKESKRecipientKey] -> [BL.ByteString] -> IO (Maybe String)-recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates =- case recoverFromSKESK of- Just line -> pure (Just line)- Nothing -> recoverFromLegacyRSAPKESK- where- recoverFromSKESK =- listToMaybe $- mapMaybe- (\(SKESKPayloadV4 sa s2k maybeEsk, passphrase) ->- case maybeEsk of- Nothing ->- case skesk2Key (SKESK4Packet sa s2k Nothing) passphrase of- Left _ -> Nothing- Right sessionKey ->- Just (renderSessionKeyOutLine (fromFVal sa) sessionKey)- Just esk ->- case skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase of- Left _ -> Nothing- Right (algo, sessionKey) ->- Just (renderSessionKeyOutLine (fromFVal algo) sessionKey))- [(payload, passphrase) | payload <- skeskPayloadsV4, passphrase <- passwordCandidates]- skeskPayloadsV4 =- mapMaybe- (\pkt ->- case pkt of- SKESKPkt (SKESKPayloadV4Packet payload) -> Just payload- _ -> Nothing)- ciphertextPkts- recoverFromLegacyRSAPKESK =- recoverRSACombos [(mpi, rsaKey) | mpi <- rsaPKESKMPIs, rsaKey <- rsaRecipientKeys]- recoverRSACombos [] = pure Nothing- recoverRSACombos ((mpi, rsaKey):rest) = do- encodedResult <- decryptLegacyRSAPKESK rsaKey mpi- case encodedResult of- Left _ -> recoverRSACombos rest- Right encoded ->- case decodeOpenPGPEncodedSessionKey encoded of- Right (algo, keyBytes) ->- pure (Just (renderSessionKeyOutLine (fromFVal algo) keyBytes))- Left _ -> recoverRSACombos rest- rsaPKESKMPIs =- mapMaybe- (\pkt ->- case pkt of- PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka (mpi :| [])))- | pka == RSA || pka == DeprecatedRSAEncryptOnly ->- Just mpi- _ -> Nothing)- ciphertextPkts- rsaRecipientKeys =- mapMaybe- (\keyInfo ->- case pkeskRecipientSKey keyInfo of- RSAPrivateKey (RSA_PrivateKey privateKey) -> Just privateKey- _ -> Nothing)- recipientKeys--decryptLegacyRSAPKESK :: RSA.PrivateKey -> MPI -> IO (Either String B.ByteString)-decryptLegacyRSAPKESK privateKey mpi = do- attempted <- P15.decryptSafer privateKey (mpiToCiphertext privateKey mpi)- pure (first show attempted)- where- mpiToCiphertext rsaKey (MPI encodedMPI) =- let modulusBytes = rsaModulusOctets rsaKey- in i2ospOf_ modulusBytes encodedMPI- rsaModulusOctets rsaKey =- let modulusBits = integerBitLength (RSA.public_n (RSA.private_pub rsaKey))- in max 1 ((modulusBits + 7) `div` 8)- integerBitLength n- | n <= 0 = 0- | otherwise = go n 0- where- go 0 bits = bits- go value bits = go (value `div` 2) (bits + 1)--parseAlgorithmOctet :: String -> IO Word8-parseAlgorithmOctet algoSpec =- case readMaybe algoSpec :: Maybe Int of- Just octet- | octet >= 0 && octet <= 255 ->- case toFVal (fromIntegral octet) :: SymmetricAlgorithm of- OtherSA _ ->- failWith- BadData- ("decrypt: unsupported --with-session-key algorithm: " ++ algoSpec)- _ -> pure (fromIntegral octet)- _ ->- failWith- BadData- ("decrypt: invalid --with-session-key algorithm: " ++ algoSpec)--decodeHexBytes :: String -> IO B.ByteString-decodeHexBytes hex =- if odd (length hex)- then failWith BadData "decrypt: hex key material must have an even number of digits"- else B.pack <$> go hex- where- go [] = pure []- go (a:b:rest) = do- hi <- nibble a- lo <- nibble b- (fromIntegral (hi * 16 + lo) :) <$> go rest- go _ = failWith BadData "decrypt: malformed hex key material"- nibble c =- if isHexDigit c- then pure (digitToInt c)- else failWith BadData "decrypt: key material must be hexadecimal"--isEncryptedPayloadPacket :: Pkt -> Bool-isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True-isEncryptedPayloadPacket SymEncDataPkt {} = True-isEncryptedPayloadPacket _ = False--isForwardCompatUnknownESKPacket :: Pkt -> Bool-isForwardCompatUnknownESKPacket (OtherPacketPkt tag _) = tag == 1 || tag == 3-isForwardCompatUnknownESKPacket (BrokenPacketPkt _ tag _) = tag == 1 || tag == 3-isForwardCompatUnknownESKPacket _ = False--isUnsupportedSKESKPacket :: Pkt -> Bool-isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ s2k _))) = isUnknownS2K s2k-isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ s2k _ _ _))) = isUnknownS2K s2k-isUnsupportedSKESKPacket _ = False--isUnknownS2K :: S2K -> Bool-isUnknownS2K OtherS2K {} = True-isUnknownS2K _ = False--validateCiphertextPacketLayout :: [Pkt] -> IO ()-validateCiphertextPacketLayout pkts =- case findIndex isEncryptedPayloadPacket pkts of- Nothing -> pure ()- Just payloadIndex ->- let trailing =- filter (not . isMarkerPacketPacket) (drop (payloadIndex + 1) pkts)- in when (not (null trailing)) $- failWith- BadData- "decrypt input: malformed encrypted message structure (unexpected packets after encrypted data)"--isMarkerPacketPacket :: Pkt -> Bool-isMarkerPacketPacket MarkerPkt {} = True-isMarkerPacketPacket _ = False--validateDecryptedMessageStructure :: [Pkt] -> [Pkt] -> IO ()-validateDecryptedMessageStructure rawPkts pkts = do- let literalCount = length [() | LiteralDataPkt {} <- pkts]- signatureCount = length [() | SignaturePkt {} <- pkts]- onePassCount = length [() | OnePassSignaturePkt {} <- pkts]- hasCompressedRaw = any isCompressedPacket rawPkts- hasUnknownPackets = any isUnknownPacket rawPkts || any isUnknownPacket pkts- maxCompressionDepth = maximum (0 : map compressionDepth rawPkts)- when (any compressedPacketParseFailed rawPkts) $- failWith BadData "decrypt failed: malformed compressed data stream"- when (maxCompressionDepth > 2) $- failWith BadData "decrypt failed: malformed encrypted message structure (excessive compression nesting)"- when (hasCompressedRaw && any isMarkerPacket pkts) $- failWith BadData "decrypt failed: malformed encrypted message structure (compressed marker packet)"- when (any isDisallowedDecryptedPacketType pkts) $- failWith BadData "decrypt failed: malformed encrypted message structure (unexpected packet type in plaintext)"- when (literalCount == 0) $- failWith BadData "decrypt failed: malformed encrypted message structure (no literal data payload found)"- when (literalCount > 1) $- failWith- BadData- "decrypt failed: malformed encrypted message structure (multiple literal payloads)"- when (not hasUnknownPackets && onePassCount > 0 && signatureCount == 0) $- failWith- BadData- "decrypt failed: malformed signed message structure (one-pass signature without trailing signature)"- when (not hasUnknownPackets && signatureCount > 0 && onePassCount == 0 && not isOldStyleSignedMessage) $- failWith- BadData- "decrypt failed: malformed signed message structure (trailing signature without one-pass signature)"- where- isOldStyleSignedMessage =- case [ i | (i, LiteralDataPkt {}) <- packetPositions ] of- [literalIndex] ->- not (null signaturePositions) &&- all (< literalIndex) signaturePositions- _ -> False- packetPositions = zip [0 :: Int ..] (filter (not . isMarkerPacket) pkts)- signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]--compressedPacketParseFailed :: Pkt -> Bool-compressedPacketParseFailed pkt@CompressedDataPkt {} = isLeft (decompressPkt pkt)-compressedPacketParseFailed _ = False--recursivelyDecompressPacket pkt@CompressedDataPkt {} = do- inner <- decompressPkt pkt- concat <$> mapM recursivelyDecompressPacket inner-recursivelyDecompressPacket pkt = Right [pkt]--compressedPacketIsEmpty :: Pkt -> Bool-compressedPacketIsEmpty pkt@CompressedDataPkt {} =- case decompressPkt pkt of- Right [] -> True- _ -> False-compressedPacketIsEmpty _ = False--isCompressedPacket :: Pkt -> Bool-isCompressedPacket CompressedDataPkt {} = True-isCompressedPacket _ = False--compressionDepth :: Pkt -> Int-compressionDepth pkt@CompressedDataPkt {} =- let inner = either (const []) id (decompressPkt pkt)- in if null inner- then 1- else 1 + maximum (0 : map compressionDepth inner)-compressionDepth _ = 0--isMarkerPacket :: Pkt -> Bool-isMarkerPacket MarkerPkt {} = True-isMarkerPacket _ = False--isUnknownPacket :: Pkt -> Bool-isUnknownPacket OtherPacketPkt {} = True-isUnknownPacket BrokenPacketPkt {} = True-isUnknownPacket _ = False--isDisallowedDecryptedPacketType :: Pkt -> Bool-isDisallowedDecryptedPacketType PKESKPkt {} = True-isDisallowedDecryptedPacketType SKESKPkt {} = True-isDisallowedDecryptedPacketType PublicKeyPkt {} = True-isDisallowedDecryptedPacketType PublicSubkeyPkt {} = True-isDisallowedDecryptedPacketType SecretKeyPkt {} = True-isDisallowedDecryptedPacketType SecretSubkeyPkt {} = True-isDisallowedDecryptedPacketType SymEncDataPkt {} = True-isDisallowedDecryptedPacketType SymEncIntegrityProtectedDataPkt {} = True-isDisallowedDecryptedPacketType _ = False--encodeOpenPGPSessionKey :: Word8 -> B.ByteString -> B.ByteString-encodeOpenPGPSessionKey algo keyBytes =- B.cons algo (keyBytes <> B.pack [fromIntegral (checksum `div` 256), fromIntegral checksum])- where- checksum :: Int- checksum = B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536--sessionKeyOutLineFromMaterial :: B.ByteString -> Maybe String-sessionKeyOutLineFromMaterial raw = do- (algo, keyBytes) <- decodeOpenPGPSessionKeyMaterial raw- pure (renderSessionKeyOutLine algo keyBytes)--decodeOpenPGPSessionKeyMaterial :: B.ByteString -> Maybe (Word8, B.ByteString)-decodeOpenPGPSessionKeyMaterial raw = do- (algo, body) <- B.uncons raw- case toFVal (fromIntegral algo) :: SymmetricAlgorithm of- OtherSA _ -> Nothing- _ -> do- let bodyLen = B.length body- if bodyLen < 3- then Nothing- else do- let keyBytes = B.take (bodyLen - 2) body- checksumHi = fromIntegral (B.index body (bodyLen - 2)) :: Int- checksumLo = fromIntegral (B.index body (bodyLen - 1)) :: Int- checksumExpected = checksumHi * 256 + checksumLo- checksumActual =- B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536- if B.null keyBytes || checksumActual /= checksumExpected- then Nothing- else Just (algo, keyBytes)--renderSessionKeyOutLine :: Word8 -> B.ByteString -> String-renderSessionKeyOutLine algo keyBytes =- show algo ++ ":" ++ hexEncodeBytes keyBytes--hexEncodeBytes :: B.ByteString -> String-hexEncodeBytes = concatMap encodeByte . B.unpack- where- encodeByte w =- [ nibble (w `shiftR` 4)- , nibble (w .&. 0x0f)- ]- nibble n = "0123456789abcdef" !! fromIntegral n--extractSingleLiteralPayload :: [Pkt] -> IO BL.ByteString-extractSingleLiteralPayload pkts =- case [p | LiteralDataPkt _ _ _ p <- pkts] of- [payload] -> pure payload- [] -> failWith BadData "decrypt failed: malformed encrypted message structure (no literal data payload found)"- _ -> failWith BadData "decrypt failed: malformed encrypted message structure (multiple literal data payloads found)"--doDecryptVerifyOutput ::- POSIXTime- -> [String]- -> Maybe String- -> Maybe String- -> Maybe String- -> [Pkt]- -> IO ()-doDecryptVerifyOutput cpt certFiles outFile notBeforeArg notAfterArg decryptedPkts = do- when (null certFiles) $- failWith- IncompleteVerification- "decrypt: verification requires at least one --verify-with cert"- (krs, verifyTks) <- loadVerifyContext cpt certFiles- upperBound <- verificationUpperBound cpt notAfterArg- lowerBound <- verificationLowerBound cpt notBeforeArg- verificationPkts <- normalizeDecryptVerificationPackets decryptedPkts- let verifications = map (first show) (verifyPacketsBatch krs upperBound verificationPkts)- filtered = filterByVerificationBounds lowerBound upperBound verifications- successLines =- map (renderSOPVerificationLine verifyTks) (rights filtered)- renderedOut =- if null successLines- then ""- else unlines successLines- case outFile of- Just path -> writeFileWithOutputExistsCheck "decrypt" path renderedOut- Nothing -> pure ()--normalizeDecryptVerificationPackets :: [Pkt] -> IO [Pkt]-normalizeDecryptVerificationPackets pkts =- case ([pkt | pkt@LiteralDataPkt {} <- pkts], [pkt | pkt@SignaturePkt {} <- pkts]) of- ([], _) ->- failWith- CannotDecrypt- "decrypt failed: no literal data payload found"- ([lit], []) -> pure [lit]- ([lit], sigs) -> pure (lit : sigs)- (_, _) ->- failWith- BadData- "decrypt failed: malformed signed message structure (multiple literal payloads)"--resolveDecryptVerificationsOut ::- Maybe String -> Maybe String -> IO (Maybe String, Bool)-resolveDecryptVerificationsOut newPath oldPath =- case (newPath, oldPath) of- (Just p, Nothing) -> pure (Just p, False)- (Nothing, Just p) -> pure (Just p, True)- (Just pNew, Just pOld)- | pNew == pOld -> pure (Just pNew, True)- | otherwise ->- failWith- IncompatibleOptions- "decrypt: --verifications-out and --verify-out cannot target different files"- (Nothing, Nothing) -> pure (Nothing, False)--renderSOPVerificationLine :: [TKUnknown] -> Verification -> String-renderSOPVerificationLine verifyTks v =- ts ++ " " ++ signerFp ++ " " ++ certFp ++ " " ++ modeLabel- where- sig = _verificationSignature v- ts = renderSOPVerificationTimestamp sig- signer = fingerprint (_verificationSigner v)- signerFp = hexEncodeBytes (BL.toStrict (unFingerprint signer))- modeLabel = signatureModeField sig- certFp =- case find (\tk -> keyMatchesFingerprint True tk signer) verifyTks of- Just tk ->- hexEncodeBytes- (BL.toStrict (unFingerprint (fingerprint (fst (_tkuKey tk)))))- Nothing -> signerFp--signatureModeField :: SignaturePayload -> String-signatureModeField sig =- case sig of- SigV4 CanonicalTextSig _ _ _ _ _ _ -> "mode:text"- SigV6 CanonicalTextSig _ _ _ _ _ _ _ -> "mode:text"- _ -> "mode:binary"--renderSOPVerificationTimestamp :: SignaturePayload -> String-renderSOPVerificationTimestamp sig =- formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $- case signatureCreationTime sig of- Just t -> t- Nothing -> posixSecondsToUTCTime 0--writeFileWithOutputExistsCheck :: String -> FilePath -> String -> IO ()-writeFileWithOutputExistsCheck subcommand path content = do- ensureOutputPathAvailable subcommand path- writeFile path content--parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]-parseOpenPGPPackets context bytes =- (do- let packets = concatMap (either (const []) id . decompressPkt) (parsePkts bytes)- _ <- evaluate (length packets)- pure packets)- `catch` parseFailure- where- parseFailure :: SomeException -> IO [Pkt]- parseFailure err =- failWith- BadData- (context ++ ": failed to parse OpenPGP packets: " ++ displayException err)--parseRawOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]-parseRawOpenPGPPackets context bytes =- (do- let packets = parsePkts bytes- _ <- evaluate (length packets)- pure packets)- `catch` parseFailure- where- parseFailure :: SomeException -> IO [Pkt]- parseFailure err =- failWith- BadData- (context ++ ": failed to parse OpenPGP packets: " ++ displayException err)--validateDecryptPartialBodyEncoding :: BL.ByteString -> IO ()-validateDecryptPartialBodyEncoding ciphertext =- case ensureNoShortFirstPartialBodyChunk (BL.toStrict ciphertext) of- Left err ->- failWith- BadData- ("decrypt input: invalid partial body encoding (" ++ err ++ ")")- Right () -> pure ()--ensureNoShortFirstPartialBodyChunk :: B.ByteString -> Either String ()-ensureNoShortFirstPartialBodyChunk = parsePackets- where- parsePackets bs- | B.null bs = Right ()- | otherwise = do- (header, rest) <- noteLeft "truncated packet header" (B.uncons bs)- if header .&. 0x80 /= 0x80- then Left "invalid packet header octet"- else do- remaining <-- if header .&. 0x40 == 0x40- then parseNewPacketBody rest- else parseOldPacketBody (header .&. 0x03) rest- parsePackets remaining-- parseOldPacketBody lengthType bs =- case lengthType of- 0 -> do- (lenOctet, rest) <- noteLeft "truncated old-format one-octet length" (B.uncons bs)- dropExact "truncated old-format packet body" (fromIntegral lenOctet) rest- 1 -> do- (hi, afterHi) <- noteLeft "truncated old-format two-octet length" (B.uncons bs)- (lo, rest) <- noteLeft "truncated old-format two-octet length" (B.uncons afterHi)- let len = fromIntegral hi * 256 + fromIntegral lo- dropExact "truncated old-format packet body" len rest- 2 -> do- (b1, afterB1) <- noteLeft "truncated old-format four-octet length" (B.uncons bs)- (b2, afterB2) <- noteLeft "truncated old-format four-octet length" (B.uncons afterB1)- (b3, afterB3) <- noteLeft "truncated old-format four-octet length" (B.uncons afterB2)- (b4, rest) <- noteLeft "truncated old-format four-octet length" (B.uncons afterB3)- let len =- (fromIntegral b1 `shiftL` 24) +- (fromIntegral b2 `shiftL` 16) +- (fromIntegral b3 `shiftL` 8) +- fromIntegral b4- dropExact "truncated old-format packet body" len rest- 3 -> Right B.empty- _ -> Left "invalid old-format length type"-- parseNewPacketBody = parseNewLengthChunks True-- parseNewLengthChunks isFirstChunk bs = do- (chunkLength, isPartial, afterLength) <- parseNewLength bs- when (isFirstChunk && isPartial && chunkLength < 512) $- Left- ("first partial chunk is too short (" ++- show chunkLength ++ " octets, minimum is 512)")- afterChunk <- dropExact "truncated new-format packet body chunk" chunkLength afterLength- if isPartial- then parseNewLengthChunks False afterChunk- else Right afterChunk-- parseNewLength bs = do- (lengthOctet, rest) <- noteLeft "truncated new-format length" (B.uncons bs)- case lengthOctet of- _ | lengthOctet < 192 ->- Right (fromIntegral lengthOctet, False, rest)- | lengthOctet < 224 -> do- (nextOctet, afterNext) <- noteLeft "truncated new-format two-octet length" (B.uncons rest)- let len =- ((fromIntegral lengthOctet - 192) `shiftL` 8) +- fromIntegral nextOctet +- 192- Right (len, False, afterNext)- | lengthOctet < 255 ->- Right- ( 1 `shiftL` fromIntegral (lengthOctet .&. 0x1f)- , True- , rest- )- | otherwise -> do- (b1, afterB1) <- noteLeft "truncated new-format five-octet length" (B.uncons rest)- (b2, afterB2) <- noteLeft "truncated new-format five-octet length" (B.uncons afterB1)- (b3, afterB3) <- noteLeft "truncated new-format five-octet length" (B.uncons afterB2)- (b4, afterB4) <- noteLeft "truncated new-format five-octet length" (B.uncons afterB3)- let len =- (fromIntegral b1 `shiftL` 24) +- (fromIntegral b2 `shiftL` 16) +- (fromIntegral b3 `shiftL` 8) +- fromIntegral b4- Right (len, False, afterB4)-- dropExact context n bs- | B.length bs < n = Left context- | otherwise = Right (B.drop n bs)-- noteLeft err = maybe (Left err) Right--ensureOutputPathAvailable :: String -> FilePath -> IO ()-ensureOutputPathAvailable subcommand path = do- exists <- doesFileExist path- when exists $- failWith OutputExists (subcommand ++ ": output path already exists: " ++ path)--loadVerifyKeyringMap :: POSIXTime -> [String] -> IO PublicKeyring-loadVerifyKeyringMap cpt certFiles = fst <$> loadVerifyContext cpt certFiles--loadVerifyContext :: POSIXTime -> [String] -> IO (PublicKeyring, [TKUnknown])-loadVerifyContext _ certFiles = do- allTks <-- mapMaybe enforceVerifyPrimaryKeyPolicy .- map sanitizeVerifyTK .- concat <$>- mapM (loadCertTKsFromFile "verify") certFiles- let publicTks =- mapMaybe- (\tk ->- case fromUnknownToTK tk of- Right (SomePublicTK publicTk) -> Just publicTk- _ -> Nothing)- allTks- keyring <- runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap- pure (keyring, allTks)--loadVerifyTKsFromFile :: String -> IO [TKUnknown]-loadVerifyTKsFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy- certPkts <- decodeOpenPGPInput path lbs- runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| CC.sinkList--loadCertTKsFromFile :: String -> String -> IO [TKUnknown]-loadCertTKsFromFile context path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy- certPkts <- decodeOpenPGPInput path lbs- rejectSecretKeyPackets context path certPkts- runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| CC.sinkList--rejectSecretKeyPackets :: String -> String -> [Pkt] -> IO ()-rejectSecretKeyPackets context path packets =- when (any isSecretKeyPacket packets) $- failWith- BadData- (context ++ ": certificate input contains secret key material in " ++ path)- where- isSecretKeyPacket SecretKeyPkt {} = True- 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)- }- where- isSubkeyPacket PublicSubkeyPkt {} = True- isSubkeyPacket SecretSubkeyPkt {} = True- isSubkeyPacket _ = False--enforceVerifyPrimaryKeyPolicy :: TKUnknown -> Maybe TKUnknown-enforceVerifyPrimaryKeyPolicy tk =- if primaryKeyTooSmallForVerification (_tkuKey tk)- then Nothing- else Just tk--primaryKeyTooSmallForVerification :: (SomePKPayload, Maybe SKAddendum) -> Bool-primaryKeyTooSmallForVerification (pkp, _) =- case _pkalgo pkp of- RSA -> rsaTooSmall- DeprecatedRSASignOnly -> rsaTooSmall- DeprecatedRSAEncryptOnly -> rsaTooSmall- _ -> False- where- rsaTooSmall =- case pubkeySize (_pubkey pkp) of- Right bits -> bits < 2048- Left _ -> False--primaryKeyIdentity :: (SomePKPayload, Maybe SKAddendum) -> Maybe (Fingerprint, EightOctetKeyId)-primaryKeyIdentity (pkp, _) = do- keyId <- either (const Nothing) Just (eightOctetKeyID pkp)- pure (fingerprint pkp, keyId)--sanitizeBindingSignature ::- Fingerprint- -> EightOctetKeyId- -> SignaturePayload- -> Maybe SignaturePayload-sanitizeBindingSignature _ _ sig- | hasUnsupportedCriticalSubpacket sig = Nothing- | hasUnsupportedCriticalEmbeddedBacksig sig = Nothing- | otherwise = Just sig- where- hasUnsupportedCriticalSubpacket sp =- any isUnsupportedCriticalSubpacket (signatureHashedSubpackets sp)- hasUnsupportedCriticalEmbeddedBacksig sp =- any- (\ssp ->- case _sspPayload ssp of- EmbeddedSignature embedded ->- any- isUnsupportedCriticalSubpacket- (signatureHashedSubpackets embedded)- _ -> False)- (signatureHashedSubpackets sp)- isUnsupportedCriticalSubpacket (SigSubPacket isCritical payload) =- isCritical &&- case payload of- UserDefinedSigSub {} -> True- OtherSigSub {} -> True- NotationData {} -> True- _ -> False- signatureHashedSubpackets (SigV4 _ _ _ hasheds _ _ _) = hasheds- signatureHashedSubpackets (SigV6 _ _ _ _ hasheds _ _ _) = hasheds- signatureHashedSubpackets _ = []--loadDecryptRecipientKeys ::- POSIXTime -> [String] -> [BL.ByteString] -> IO [PKESKRecipientKey]-loadDecryptRecipientKeys _ [] _ = pure []-loadDecryptRecipientKeys cpt keyFiles passwords = concat <$> mapM loadFromFile keyFiles- where- loadFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy- packets <- decodeOpenPGPInput path lbs- -- Build the set of fingerprints that are explicitly non-encryption-capable.- -- Keys not resolvable via TK (processTK failure, bare material) are allowed.- nonEncFps <- buildNonEncryptionFingerprintSet packets- keys <- mapM (packetRecipientKey path nonEncFps) packets >>= pure . catMaybes- let brokenSecretKeyErrors =- nub- [ err- | BrokenPacketPkt err tag _ <- packets- , tag == 5 || tag == 7- ]- when (null keys && not (null brokenSecretKeyErrors)) $- failWith- CannotDecrypt- ("decrypt failed: could not load usable secret key material from " ++ path ++- " (" ++ intercalate "; " brokenSecretKeyErrors ++ ")")- pure keys- -- Build a set of fingerprints that are EXPLICITLY non-encryption-capable.- -- Only keys whose binding signature carries a KeyFlags subpacket that does- -- NOT include any encryption bit are added. Keys with no binding-sig TK- -- (processTK failed, bare secret material, etc.) are NOT blocked — we fall- -- back to allowing them so that newly-generated or unusual keys still work.- buildNonEncryptionFingerprintSet packets = do- tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| CC.sinkList- let normTks = rights (map (processTK (Just cpt)) tks)- let tkDerived = S.fromList (concatMap nonEncryptionFingerprints normTks)- rawDerived = S.fromList (explicitNonEncryptionSubkeyFingerprints packets)- return (S.union tkDerived rawDerived)- 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- primaryFp = unFingerprint (fingerprint primaryPkp)- primarySigs =- concatMap snd (_tkuUIDs tk) ++- concatMap snd (_tkuUAts tk) ++- _tkuRevs tk- primaryEntry = [ primaryFp | not (sigsAllowEncryption primarySigs) ]- -- Subkeys: same rule as primary.- subEntries =- [ unFingerprint (fingerprint pkp)- | (pkt, sigs) <- _tkuSubs tk- , Just pkp <- [secretOrPublicSubkeyPayload pkt]- , not (sigsAllowEncryption sigs)- ]- blocked = primaryEntry ++ subEntries- in if tkHasAnyEncryptionCapableKey tk- then blocked- else []- explicitNonEncryptionSubkeyFingerprints packets =- let (mPending, blocked) = foldl' step (Nothing, []) packets- in maybe blocked- (\(fp, hasEnc, sawKeyFlags) -> finalize fp hasEnc sawKeyFlags blocked)- mPending- where- step (mPending, blocked) pkt =- case pkt of- PublicSubkeyPkt pkp ->- (Just (unFingerprint (fingerprint pkp), False, False), finalizePending mPending blocked)- SecretSubkeyPkt pkp _ ->- (Just (unFingerprint (fingerprint pkp), False, False), finalizePending mPending blocked)- SignaturePkt sig ->- case mPending of- Nothing -> (Nothing, blocked)- Just (fp, hasEnc, sawKeyFlags) ->- let usableSig =- if signatureHasUnsupportedCriticalSubpackets sig- then []- else keyFlagsFromSig sig- hasEnc' = hasEnc || any hasEncryptionFlag usableSig- sawKeyFlags' = sawKeyFlags || not (null usableSig)- in (Just (fp, hasEnc', sawKeyFlags'), blocked)- _ -> (Nothing, finalizePending mPending blocked)- finalizePending Nothing blocked = blocked- finalizePending (Just (fp, hasEnc, sawKeyFlags)) blocked =- finalize fp hasEnc sawKeyFlags blocked- finalize fp hasEnc sawKeyFlags blocked- | sawKeyFlags && not hasEnc = fp : blocked- | otherwise = blocked- tkHasAnyEncryptionCapableKey tk =- let (primaryPkp, _) = _tkuKey tk- primarySigs =- concatMap snd (_tkuUIDs tk) ++- concatMap snd (_tkuUAts tk) ++- _tkuRevs tk- primaryAllows = supportsRecipientPKESKAlgorithm primaryPkp && sigsAllowEncryption primarySigs- subAllows =- any- (\(pkt, sigs) ->- case secretOrPublicSubkeyPayload pkt of- Just pkp ->- supportsRecipientPKESKAlgorithm pkp && sigsAllowEncryption sigs- Nothing -> False)- (_tkuSubs tk)- in primaryAllows || subAllows- sigsAllowEncryption [] = True- sigsAllowEncryption sigs =- let usableSigs = filter (not . signatureHasUnsupportedCriticalSubpackets) sigs- flagSets = concatMap keyFlagsFromSig usableSigs- in if null usableSigs- then False- else null flagSets || any hasEncryptionFlag flagSets- hasEncryptionFlag flags =- S.member EncryptCommunicationsKey flags ||- S.member EncryptStorageKey flags- keyFlagsFromSig sig =- case sig of- SigV4 _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds- SigV6 _ _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds- _ -> []- signatureHasUnsupportedCriticalSubpackets sig =- let hasheds =- case sig of- SigV4 _ _ _ hs _ _ _ -> hs- SigV6 _ _ _ _ hs _ _ _ -> hs- _ -> []- in any isUnsupportedCritical hasheds- isUnsupportedCritical (SigSubPacket isCritical payload) =- isCritical &&- case payload of- OtherSigSub {} -> True- UserDefinedSigSub {} -> True- NotationData {} -> True- _ -> False- keyFlagsFromSubpackets subpackets =- [ 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- then pure Nothing- else decryptRecipientKey path pkp ska- packetRecipientKey path nonEncFps (SecretSubkeyPkt pkp ska) =- let fp = unFingerprint (fingerprint pkp)- in if S.member fp nonEncFps- then pure Nothing- else decryptRecipientKey path pkp ska- packetRecipientKey _ _ _ = pure Nothing- decryptRecipientKey path pkp ska =- case secretKeyProtectionPolicyViolation pkp ska of- Just violation ->- failWith- KeyIsProtected- ("decrypt failed: unsupported secret key protection in " ++ path ++- " (" ++ violation ++ ")")- Nothing ->- case ska of- SUUnencrypted skey _ ->- pure- (Just- (PKESKRecipientKey- { pkeskRecipientPKPayload = Just pkp- , pkeskRecipientSKey = skey- }))- _ ->- case passwords of- [] ->- failWith- KeyIsProtected- ("decrypt failed: encrypted key in " ++ path ++ " requires --with-key-password")- _ ->- case tryDecryptKey passwords of- Left _ ->- failWith- KeyIsProtected- ("decrypt failed: could not decrypt key in " ++ path ++ " with provided --with-key-password values")- Right (SUUnencrypted skey _) ->- pure- (Just- (PKESKRecipientKey- { pkeskRecipientPKPayload = Just pkp- , pkeskRecipientSKey = skey- }))- Right _ ->- failWith- KeyIsProtected- ("decrypt failed: unsupported secret key protection in " ++ path)- where- secretKeyProtectionPolicyViolation recipientPkp addendum =- let rejectArgon2WithoutAEAD s2k- | isArgon2S2K s2k =- Just "Argon2 S2K is only allowed with AEAD-protected secret keys"- | otherwise = Nothing- rejectSimpleForV6 s2k- | isSimpleS2K s2k =- Just "v6 secret key packets MUST NOT use simple S2K"- | otherwise = Nothing- in case addendum of- SUS16bit _ s2k _ _ ->- case _keyVersion recipientPkp of- V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k- _ -> rejectArgon2WithoutAEAD s2k- SUSSHA1 _ s2k _ _ ->- case _keyVersion recipientPkp of- V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k- _ -> rejectArgon2WithoutAEAD s2k- SUSym {} ->- if _keyVersion recipientPkp == V6- then- Just- "v6 secret key packets MUST NOT use legacy CFB secret-key protection"- else Nothing- _ -> Nothing- isArgon2S2K Argon2 {} = True- isArgon2S2K _ = False- isSimpleS2K (Simple _) = True- isSimpleS2K _ = False- tryDecryptKey [] = Left ()- tryDecryptKey (password:rest) =- case decryptPrivateKey (pkp, ska) password of- Left _ -> tryDecryptKey rest- Right decrypted -> Right decrypted--decodeOpenPGPInput :: String -> BL.ByteString -> IO [Pkt]-decodeOpenPGPInput path input = do- decodedArmors <- decodeAsciiArmorInput ("OpenPGP input in " ++ path) input- case decodedArmors of- Just armors ->- case firstBy isOpenPGPArmorBlock armors of- Just (Armor _ _ bs) ->- parseOpenPGPPackets- ("armored OpenPGP input in " ++ path)- (BL.fromStrict (BLC8.toStrict bs))- _ ->- case firstBy isClearSignedArmor armors of- Just _ ->- failWith BadData ("Expected key data in " ++ path ++ ", got cleartext signature")- _ -> parseOpenPGPPackets "OpenPGP input" input- Nothing -> parseOpenPGPPackets "OpenPGP input" input--loadRecipientPreferredHashes :: POSIXTime -> [String] -> IO [HashAlgorithm]-loadRecipientPreferredHashes cpt certFiles =- concat <$> mapM loadFromFile certFiles- where- loadFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy- pkts <- decodeOpenPGPInput path lbs- rejectSecretKeyPackets "encrypt" path pkts- tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| CC.sinkList- normalized <- mapM (normalizeRecipient path) tks- pure- (concatMap (effectiveHashPreferencesAt cpt) normalized)- normalizeRecipient path tk =- case processTK (Just cpt) tk of- Left err ->- failWith- BadData- ("encrypt: invalid recipient certificate in " ++ path ++ ": " ++ show err)- Right normalized -> pure normalized--loadEncryptRecipients :: POSIXTime -> EncryptFor -> [String] -> IO [FunKey]-loadEncryptRecipients cpt encPurpose certFiles = do- recipients <- concat <$> mapM loadRecipientsFromFile certFiles- if null recipients- then- failWith- CertCannotEncrypt- "encrypt: no supported recipient encryption keys found in provided certificates"- else pure recipients- where- loadRecipientsFromFile path = do- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy- pkts <- decodeOpenPGPInput path lbs- rejectSecretKeyPackets "encrypt" path pkts- rejectCriticalUnknownRecipientPackets path pkts- tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| CC.sinkList- normalized <- mapM (normalizeEncryptRecipientTK path) tks- let selected = selectEncryptRecipients encPurpose (concatMap (tkToFunKeysAt cpt) normalized)- packetFallback =- nub- (concatMap tkToEncryptPayloads normalized ++- mapMaybe extractEncryptRecipientPayload pkts)- pure $- case encPurpose of- EncryptForAny- | null selected -> map payloadToFunKey packetFallback- _ -> selected- normalizeEncryptRecipientTK path tk =- case processTK (Just cpt) tk of- Left err ->- failWith- BadData- ("encrypt: invalid recipient certificate in " ++ path ++ ": " ++ show err)- Right normalized ->- if not (isTKTimeValid (posixSecondsToUTCTime (realToFrac cpt)) normalized)- then- failWith- CertCannotEncrypt- ("encrypt: recipient certificate in " ++ path ++ " is expired")- else- if not (primaryUserIDExpirationAllowsAt cpt normalized)- then- failWith- CertCannotEncrypt- ("encrypt: recipient certificate in " ++ path ++ " is expired")- else pure normalized- rejectCriticalUnknownRecipientPackets path =- mapM_- (\pkt ->- case pkt of- OtherPacketPkt tag _- | tag < 40 ->- if isForwardCompatRecipientPacketTag tag- then pure ()- else- failWith- BadData- ("encrypt: invalid recipient certificate in " ++ path ++ ": critical unknown packet tag " ++ show tag)- BrokenPacketPkt _ tag _- | tag < 40 ->- if isForwardCompatRecipientPacketTag tag- then pure ()- else- failWith- BadData- ("encrypt: invalid recipient certificate in " ++ path ++ ": critical unknown packet tag " ++ show tag)- _ -> pure ())- isForwardCompatRecipientPacketTag tag = tag `elem` [5, 6, 7, 14]- payloadToFunKey pkp = FunKey pkp Nothing S.empty [] [] False--primaryUserIDExpirationAllowsAt :: POSIXTime -> TKUnknown -> Bool-primaryUserIDExpirationAllowsAt now tk =- case primaryUidSigs of- [] -> True- _ -> any (signatureKeyExpirationAllowsAt now primaryCreatedAt) primaryUidSigs- where- primaryCreatedAt = fromIntegral (_timestamp (fst (_tkuKey tk)))- primaryUidSigs =- [ sig- | (_, sigs) <- _tkuUIDs tk- , sig <- sigs- , signatureMarksPrimaryUserId sig- ]--signatureMarksPrimaryUserId :: SignaturePayload -> Bool-signatureMarksPrimaryUserId sig =- any isPrimaryUIDSubpacket (signatureSubpackets sig)- where- isPrimaryUIDSubpacket (SigSubPacket _ (PrimaryUserId True)) = True- isPrimaryUIDSubpacket _ = False--signatureKeyExpirationAllowsAt :: POSIXTime -> POSIXTime -> SignaturePayload -> Bool-signatureKeyExpirationAllowsAt now createdAt sig =- case signatureKeyValiditySeconds sig of- Nothing -> True- Just 0 -> True- Just validitySeconds -> now < createdAt + fromIntegral validitySeconds--signatureKeyValiditySeconds :: SignaturePayload -> Maybe Integer-signatureKeyValiditySeconds sig =- listToMaybe- [ fromIntegral secs- | SigSubPacket _ (KeyExpirationTime (ThirtyTwoBitDuration secs)) <- signatureSubpackets sig- ]--selectEncryptRecipients :: EncryptFor -> [FunKey] -> [FunKey]-selectEncryptRecipients encPurpose keys =- chosen- where- supported = filter (supportsRecipientPKESKAlgorithm . fpkp) keys- (matchingPurpose, unrestrictedPurpose) =- partition (keyMatchesEncryptPurpose encPurpose . fkufs) supported- chosen =- case encPurpose of- EncryptForAny- | null matchingPurpose -> unrestrictedPurpose- _ -> matchingPurpose---tkToEncryptPayloads :: TKUnknown -> [SomePKPayload]-tkToEncryptPayloads (TKUnknown (pkp, _) _ _ _ subs) =- filter supportsRecipientPKESKAlgorithm (pkp : mapMaybe extractSubkeyPayload subs)- where- extractSubkeyPayload (PublicSubkeyPkt subPkp, _) = Just subPkp- extractSubkeyPayload (SecretSubkeyPkt subPkp _, _) = Just subPkp- extractSubkeyPayload _ = Nothing--extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload-extractEncryptRecipientPayload pkt =- case pkt of- PublicKeyPkt pkp- | supportsRecipientPKESKAlgorithm pkp -> Just pkp- PublicSubkeyPkt pkp- | supportsRecipientPKESKAlgorithm pkp -> Just pkp- SecretKeyPkt pkp _- | supportsRecipientPKESKAlgorithm pkp -> Just pkp- SecretSubkeyPkt pkp _- | supportsRecipientPKESKAlgorithm pkp -> Just pkp- _ -> Nothing--keyMatchesEncryptPurpose :: EncryptFor -> S.Set KeyFlag -> Bool-keyMatchesEncryptPurpose encPurpose keyFlags =- not (S.null (keyFlags `S.intersection` encryptUsageFlags))- where- encryptUsageFlags =- case encPurpose of- EncryptForAny -> S.fromList [EncryptStorageKey, EncryptCommunicationsKey]- EncryptForStorage -> S.singleton EncryptStorageKey- EncryptForCommunications -> S.singleton EncryptCommunicationsKey--supportsRecipientPKESKAlgorithm :: SomePKPayload -> Bool-supportsRecipientPKESKAlgorithm pkp =- _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, ElgamalEncryptOnly, ECDH, X25519, X448] &&- hasSupportedRecipientIdentifierLength pkp--hasSupportedRecipientIdentifierLength :: SomePKPayload -> Bool-hasSupportedRecipientIdentifierLength pkp =- let keyIdentifierLen = BL.length (unFingerprint (fingerprint pkp))- in keyIdentifierLen == 16 || keyIdentifierLen == 20 || keyIdentifierLen == 32--renderPKESKEncryptError :: PKESKEncryptError -> String-renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm symAlgo err) =- "unsupported session-key algorithm " ++ show symAlgo ++ ": " ++ err-renderPKESKEncryptError (InvalidSessionKeyLength symAlgo expected got) =- "invalid session-key length for " ++ show symAlgo ++- " (expected " ++ show expected ++ ", got " ++ show got ++ ")"-renderPKESKEncryptError (UnsupportedRecipientAlgorithm pka) =- "unsupported recipient public-key algorithm: " ++ show pka-renderPKESKEncryptError (InvalidRecipientKeyMaterial pka err) =- "invalid recipient key material for " ++ show pka ++ ": " ++ err-renderPKESKEncryptError (RecipientKdfFailure pka err) =- "recipient KDF failure for " ++ show pka ++ ": " ++ err-renderPKESKEncryptError (RecipientKeyWrapFailure pka err) =- "recipient key-wrap failure for " ++ show pka ++ ": " ++ err-renderPKESKEncryptError (PayloadBuildFailure err) = "payload build failure: " ++ err-renderPKESKEncryptError NoRecipientsProvided = "no recipients were provided"-renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) =- "recipient capability selection failure: " ++ show err-renderPKESKEncryptError (InvalidRecipientIdentifier err) =- "invalid recipient identifier: " ++ err--sopFailureForPKESKEncryptError :: PKESKEncryptError -> SopFailure-sopFailureForPKESKEncryptError err =- case err of- UnsupportedRecipientAlgorithm _ -> UnsupportedAsymmetricAlgo- RecipientCapabilitySelectionFailure _ -> CertCannotEncrypt- NoRecipientsProvided -> CertCannotEncrypt- _ -> BadData---- | Resolve a PKESK recipient key using two strategies depending on whether--- the probe carries a wildcard recipient ID (eight zero bytes) or a real key--- ID / fingerprint.------ * Non-wildcard probes: the callback is invoked once for each PKESK attempt,--- so we do an idempotent lookup by recipient identifier from the full--- candidate list to avoid consuming keys needed by later PKESKs.------ * Wildcard probes (all-zero legacy recipient ID): hOpenPGP retries the--- callback after failed unwrap attempts. We therefore pop one candidate from--- a shared queue on each callback invocation.-selectRecipientKeyInfosByRecipientIdentifier ::- [PKESKRecipientKey]- -> KeyIdentifier- -> PubKeyAlgorithm- -> IO [PKESKRecipientKey]-selectRecipientKeyInfosByRecipientIdentifier keyInfos keyIdentifier pka =- pure $- case keyIdentifier of- KeyIdentifierWildcard -> compatible- KeyIdentifierEightOctet recipientKeyId ->- filter (matchesLegacyRecipientKeyId recipientKeyId) compatible- KeyIdentifierFingerprint recipientFingerprint ->- filter (matchesRecipientIdentifier (unFingerprint recipientFingerprint)) compatible- where- compatible =- [ keyInfo- | keyInfo <- keyInfos- , supportsPKESKAlgorithm pka keyInfo- ]--prioritizeDecryptablePKESKs :: [PKESKRecipientKey] -> [Pkt] -> [Pkt]-prioritizeDecryptablePKESKs keyInfos pkts =- nonMatchingPrefix ++ matchingPrefix ++ suffix- where- (prefix, suffix) = break isEncryptedPayloadPacket pkts- (matchingPrefix, nonMatchingPrefix) =- partition- (\pkt ->- case pkt of- PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)) ->- any (matchesRecipientIdentifier rid) keyInfos- PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ eoki _ _)) ->- any (matchesLegacyRecipientKeyId eoki) keyInfos- _ -> False)- prefix--supportsPKESKAlgorithm :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool-supportsPKESKAlgorithm pka keyInfo =- case pkeskRecipientSKey keyInfo of- RSAPrivateKey {} -> pka == RSA || pka == DeprecatedRSAEncryptOnly- ElGamalPrivateKey {} -> pka == ElgamalEncryptOnly- ECDHPrivateKey {} -> pka == ECDH || pka == X25519- X25519PrivateKey {} -> pka == X25519- X448PrivateKey {} -> pka == X448- UnknownSKey {} ->- (pka == X25519 || pka == X448) &&- case pkeskRecipientPKPayload keyInfo of- Just pkp -> _pkalgo pkp == pka- Nothing -> False- _ -> False--matchesRecipientIdentifier :: BL.ByteString -> PKESKRecipientKey -> Bool-matchesRecipientIdentifier rid keyInfo =- case pkeskRecipientPKPayload keyInfo of- Nothing -> False- Just pkp ->- let identifier = BL.toStrict rid- fps = recipientFingerprintsForMatch pkp- in any (identifier `elem`) (map recipientIdMatchVariants fps)--recipientFingerprintsForMatch :: SomePKPayload -> [B.ByteString]-recipientFingerprintsForMatch pkp =- baseFp : maybeToList normalizedX25519Fp- where- baseFp = BL.toStrict (unFingerprint (fingerprint pkp))- normalizedX25519Fp =- BL.toStrict . unFingerprint . fingerprint <$> normalizeX25519CompatiblePKP pkp--normalizeX25519CompatiblePKP :: SomePKPayload -> Maybe SomePKPayload-normalizeX25519CompatiblePKP pkp =- case _pubkey pkp of- ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->- Just- (PKPayload- (_keyVersion pkp)- (_timestamp pkp)- (_v3exp pkp)- X25519- (_pubkey pkp))- _ -> Nothing--recipientIdMatchVariants :: B.ByteString -> [B.ByteString]-recipientIdMatchVariants fp =- [ fp- , B.cons 0x04 fp- , B.cons 0x06 fp- , B.cons 0xFE fp- ]--matchesLegacyRecipientKeyId :: EightOctetKeyId -> PKESKRecipientKey -> Bool-matchesLegacyRecipientKeyId eoki keyInfo =- case pkeskRecipientPKPayload keyInfo of- Nothing -> False- Just pkp ->- case eightOctetKeyID pkp of- Right keyId -> keyId == eoki- Left _ -> False--decodeCiphertextInput :: BL.ByteString -> IO BL.ByteString-decodeCiphertextInput input = do- decodedArmors <- decodeAsciiArmorInput "decrypt input" input- case decodedArmors of- Just armors ->- case firstBy isArmorMessageBlock armors of- Just (Armor ArmorMessage _ bs) -> return (BL.fromStrict (BLC8.toStrict bs))- _ ->- case firstBy isOpenPGPArmorBlock armors of- Just _ ->- failWith- BadData- "decrypt expects an armored OpenPGP message"- _ -> return input- Nothing -> return input--doInlineSign :: POSIXTime -> InlineSignOptions -> IO ()-doInlineSign pt InlineSignOptions {..} = do- when (inlineSignNoArmor && inlineSignArmor) $- failWith IncompatibleOptions "inline-sign: --armor and --no-armor are mutually exclusive"- forM_- inlineSignProfile- (\profile ->- failWith UnsupportedOption- ("inline-sign: unsupported option --profile=" ++ profile))- let inlineMode = fromMaybe InlineSignAsBinary inlineSignAs- mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- when (inlineMode /= InlineSignAsBinary) $- ensureUTF8TextInput "inline-sign" (BL.fromChunks mbs)- signingPasswordsRaw <- loadPasswordFiles "inline-sign" "--with-key-password" inlineSignKeyPasswords- let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw- ks <- loadSigningKeys inlineSignKeyFiles signingPasswords- processedKeys <- mapM (normalizeSigningKey pt) ks- let ts = ThirtyTwoBitTimeStamp (floor pt)- payloadRaw = BL.fromChunks mbs- funkeys = concatMap (tkToFunKeysAt pt) processedKeys- signingKeys = filter isInlineRSASigner funkeys- inlineSignHash = selectSigningHash signingKeys [] legacySigningHashFallbackOrder- when (null signingKeys) $- failWith MissingInput "inline-sign: no signing-capable key found"- sigs <-- mapM- (signInlineData- ts- (inlineSignSignatureMode inlineMode)- inlineSignHash- payloadRaw)- signingKeys- case inlineMode of- InlineSignAsClearSigned -> doInlineSignCleartext inlineSignHash payloadRaw sigs- InlineSignAsText -> doInlineSignText payloadRaw sigs- InlineSignAsBinary -> doInlineSignBinary payloadRaw sigs- where- inlineSignSignatureMode mode =- case mode of- InlineSignAsBinary -> AsBinary- InlineSignAsText -> AsText- InlineSignAsClearSigned -> AsText- doInlineSignCleartext inlineSignHash payloadRaw sigs = do- when inlineSignNoArmor $- failWith- IncompatibleOptions- "inline-sign --as=clearsigned requires armored output"- let cleartextPayload =- if not (BL.null payloadRaw) && BL.last payloadRaw == 0x0a- then payloadRaw <> BL.singleton 0x0a- else payloadRaw- sigBytes = runPut $ mapM_ (Bin.put . SignaturePkt) sigs- hashHeader = ("Hash", hashAlgorithmHeaderName inlineSignHash)- clearSigned =- ClearSigned- [hashHeader]- (BLC8.fromStrict (BL.toStrict cleartextPayload))- (Armor ArmorSignature [] (BLC8.fromStrict (BL.toStrict sigBytes)))- BLC8.putStr (AA.encodeLazy [clearSigned])- doInlineSignText payloadRaw sigs =- doInlineSignMessage UTF8Data payloadRaw sigs- doInlineSignBinary payloadRaw sigs = do- doInlineSignMessage BinaryData payloadRaw sigs- doInlineSignMessage literalDataType payloadRaw sigs = do- let pktBytes =- runPut $- Bin.put- (Block- (map SignaturePkt sigs ++- [LiteralDataPkt literalDataType BL.empty 0 payloadRaw]))- BL.putStr $- if not inlineSignNoArmor && not inlineSignArmor- then AA.encodeLazy [Armor ArmorMessage [] pktBytes]- else if inlineSignArmor- then AA.encodeLazy [Armor ArmorMessage [] pktBytes]- else pktBytes--inlineSignModeReader :: String -> Either String InlineSignMode-inlineSignModeReader "binary" = Right InlineSignAsBinary-inlineSignModeReader "text" = Right InlineSignAsText-inlineSignModeReader "clearsigned" = Right InlineSignAsClearSigned-inlineSignModeReader _ =- Left "signature mode must be one of: binary, text, clearsigned"--isInlineSigningCapable :: FunKey -> Bool-isInlineSigningCapable k =- (S.null (fkufs k) || S.member SignDataKey (fkufs k)) &&- case fmska k of- Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True- Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True- Just (SUUnencrypted (UnknownSKey _) _) ->- isEd25519PKA (_pkalgo (fpkp k)) || isEdDSAPKA (_pkalgo (fpkp k)) || isEd448PKA (_pkalgo (fpkp k))- _ -> False---- Legacy alias.-isInlineRSASigner :: FunKey -> Bool-isInlineRSASigner = isInlineSigningCapable--signInlineData ::- ThirtyTwoBitTimeStamp- -> AsBinaryText- -> HashAlgorithm- -> BL.ByteString- -> FunKey- -> IO SignaturePayload-signInlineData ts mode signHash payload k =- do- issuerPackets <- inlineUnhashed (fpkp k)- signWithKey- "inline-sign"- (fpkp k)- sigType- signHash- (inlineHashed (fpkp k) ts)- issuerPackets- payload- (fmska k)- where- sigType =- case mode of- AsBinary -> BinarySig- AsText -> CanonicalTextSig--inlineHashed :: SomePKPayload -> ThirtyTwoBitTimeStamp -> [SigSubPacket]-inlineHashed pkp ts =- [ SigSubPacket False (SigCreationTime ts)- , SigSubPacket False (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))- ]--inlineUnhashed :: SomePKPayload -> IO [SigSubPacket]-inlineUnhashed pkp =- issuerSubpacketsFor "inline-sign" pkp--doInlineDetach :: POSIXTime -> InlineDetachOptions -> IO ()-doInlineDetach _ InlineDetachOptions {..} = do- ensureOutputPathAvailable "inline-detach" inlineDetachOutputSigs- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- (msgData, sigPkts) <- splitInlineSigned input- writeDetachedSignatures inlineDetachNoArmor inlineDetachOutputSigs sigPkts- BL.putStr msgData--splitInlineSigned :: BL.ByteString -> IO (BL.ByteString, [Pkt])-splitInlineSigned lbs = do- decodedArmors <- decodeAsciiArmorInput "inline-detach input" lbs- case decodedArmors of- Just armors ->- case firstBy isInlineSignedArmorCandidate armors of- Just (Armor ArmorMessage _ bs) ->- parseOpenPGPPackets- "inline-detach armored message"- (BL.fromStrict (BLC8.toStrict bs)) >>=- splitInlineSignedPackets- Just (ClearSigned headers cleartext signatureArmor) -> do- validateClearSignedHeaders headers- sigPkts <- clearSignedSignaturePackets signatureArmor- return (BL.fromStrict (BLC8.toStrict cleartext), sigPkts)- _ -> parseOpenPGPPackets "inline-detach input" lbs >>= splitInlineSignedPackets- Nothing -> parseOpenPGPPackets "inline-detach input" lbs >>= splitInlineSignedPackets--firstBy :: (a -> Bool) -> [a] -> Maybe a-firstBy predicate = find predicate--decodeAsciiArmorInput :: String -> BL.ByteString -> IO (Maybe [Armor])-decodeAsciiArmorInput context input =- case validateAsciiArmorEnvelope input of- Just err ->- failWith BadData (context ++ ": malformed ASCII armor: " ++ err)- Nothing -> do- let primaryDecode = AA.decodeLazy input :: Either String [Armor]- case primaryDecode of- Right (_:_) -> pure (Just (fromRight [] primaryDecode))- _ -> do- let normalizedInput = normalizeAsciiArmorForLenientDecode input- fallbackDecode =- if normalizedInput /= input- then AA.decodeLazy normalizedInput :: Either String [Armor]- else primaryDecode- case fallbackDecode of- Right [] | looksLikeAsciiArmor input ->- failWith BadData (context ++ ": malformed ASCII armor: no armor blocks found")- Right [] -> pure Nothing- Right armors -> pure (Just armors)- Left err- | looksLikeAsciiArmor input ->- failWith BadData (context ++ ": malformed ASCII armor: " ++ err)- | otherwise -> pure Nothing--normalizeAsciiArmorForLenientDecode :: BL.ByteString -> BL.ByteString-normalizeAsciiArmorForLenientDecode input- | not (looksLikeAsciiArmor input) = input- | otherwise =- BL.fromStrict .- TE.encodeUtf8 .- T.unlines .- normalizeAsciiArmorLines $- T.lines normalizedLineEndings- where- normalizedLineEndings =- T.replace- (T.pack "\r")- (T.pack "\n")- (T.replace (T.pack "\r\n") (T.pack "\n") (TE.decodeUtf8 (BL.toStrict input)))--data LenientArmorDecodeState- = LenientOutsideArmor- | LenientArmorHeaders Bool Bool- | LenientArmorBody Bool--normalizeAsciiArmorLines :: [Text] -> [Text]-normalizeAsciiArmorLines = go LenientOutsideArmor- where- go _ [] = []- go state (line:rest) =- let trimmedLine = T.dropWhileEnd isSpace line- whitespaceOnly = T.all isSpace line- beginLabel = beginArmorLabelText trimmedLine- isBegin = isJust beginLabel- isEnd = T.isPrefixOf (T.pack "-----END PGP ") trimmedLine- hasHeaderSeparator = T.any (== ':') trimmedLine- in case state of- LenientOutsideArmor- | isBegin ->- let isClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")- shouldStripHeaders = not isClearSigned- in trimmedLine : go (LenientArmorHeaders shouldStripHeaders isClearSigned) rest- | otherwise -> trimmedLine : go LenientOutsideArmor rest- LenientArmorHeaders stripHeaders isClearSigned- | whitespaceOnly -> T.empty : go (LenientArmorBody isClearSigned) rest- | isEnd -> T.empty : trimmedLine : go LenientOutsideArmor rest- | stripHeaders && hasHeaderSeparator ->- go (LenientArmorHeaders stripHeaders isClearSigned) rest- | otherwise -> trimmedLine : go (LenientArmorBody isClearSigned) rest- LenientArmorBody isClearSigned- | isEnd -> trimmedLine : go LenientOutsideArmor rest- | isBegin ->- let nestedClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")- shouldStripHeaders = not nestedClearSigned- in trimmedLine : go (LenientArmorHeaders shouldStripHeaders nestedClearSigned) rest- | otherwise ->- let bodyLine =- if isClearSigned- then line- else trimmedLine- in bodyLine : go (LenientArmorBody isClearSigned) rest--beginArmorLabelText :: Text -> Maybe Text-beginArmorLabelText line = do- rest <- T.stripPrefix (T.pack "-----BEGIN PGP ") line- T.stripSuffix (T.pack "-----") rest--validateClearSignedHeaders :: [(String, String)] -> IO ()-validateClearSignedHeaders headers =- unless (all (isAllowedHeaderKey . fst) headers) $- failWith BadData "cleartext signed message contains unsupported armor headers"- where- isAllowedHeaderKey key =- map toLower key `elem` ["hash"]--validateClearSignedEnvelopeBounds :: BL.ByteString -> IO ()-validateClearSignedEnvelopeBounds input = do- let text = TE.decodeUtf8With lenientDecode (BL.toStrict input)- normalized = T.replace (T.pack "\r") (T.pack "") text- ls = T.lines normalized- beginMarker = T.pack "-----BEGIN PGP SIGNED MESSAGE-----"- endMarker = T.pack "-----END PGP SIGNATURE-----"- firstBegin = findIndex ((== beginMarker) . T.strip) ls- hasVisibleText line = not (T.all isSpace line)- findIndexFrom start predicate =- fmap (+ start) (findIndex predicate (drop start ls))- case firstBegin of- Nothing -> pure ()- Just beginIx -> do- when (any hasVisibleText (take beginIx ls)) $- failWith BadData "cleartext signed message has non-whitespace text before armor header"- case findIndexFrom beginIx ((== endMarker) . T.strip) of- Nothing -> pure ()- Just endIx ->- when (any hasVisibleText (drop (endIx + 1) ls)) $- failWith BadData "cleartext signed message has non-whitespace text after signature block"--looksLikeAsciiArmor :: BL.ByteString -> Bool-looksLikeAsciiArmor input =- BLC8.pack "-----BEGIN PGP " `BL.isPrefixOf`- BLC8.dropWhile isAsciiArmorLeadingWhitespace input--isAsciiArmorLeadingWhitespace :: Char -> Bool-isAsciiArmorLeadingWhitespace c = c `elem` [' ', '\t', '\r', '\n']--validateAsciiArmorEnvelope :: BL.ByteString -> Maybe String-validateAsciiArmorEnvelope input- | not (looksLikeAsciiArmor input) = Nothing- | otherwise = validateArmorBlocks (BLC8.lines (BLC8.dropWhile isAsciiArmorLeadingWhitespace input))--validateArmorBlocks :: [BL.ByteString] -> Maybe String-validateArmorBlocks [] = Nothing-validateArmorBlocks (line:rest) =- case beginArmorLabel line of- -- UPSTREAM: openpgp-asciiarmor should export detectCleartextSignedBlock helper- -- to encapsulate this RFC 4880 cleartext signature framework detection- Just "SIGNED MESSAGE" -> validateClearSignedBlock rest- Just label -> validateBinaryArmorBlock label rest- Nothing -> Nothing--validateClearSignedBlock :: [BL.ByteString] -> Maybe String-validateClearSignedBlock ls =- case break hasBeginArmorLabel ls of- (_, []) ->- Just "cleartext signed message is missing an armored signature block"- (_, beginLine:rest) ->- case beginArmorLabel beginLine of- Just "SIGNATURE" -> validateBinaryArmorBlock "SIGNATURE" rest- Just label ->- Just- ("cleartext signed message must be followed by a PGP SIGNATURE block, found PGP " ++- label)- Nothing -> Just "cleartext signed message has an invalid armored signature header"--validateBinaryArmorBlock :: String -> [BL.ByteString] -> Maybe String-validateBinaryArmorBlock label ls =- case break hasEndArmorLabel ls of- (_, []) -> Just ("missing END PGP " ++ label ++ " footer")- (_, endLine:rest) ->- case endArmorLabel endLine of- Just endLabel- | endLabel == label -> validateArmorBlocks rest- | otherwise ->- Just- ("mismatched footer: expected END PGP " ++- label ++ ", found END PGP " ++ endLabel)- Nothing -> Just ("invalid END PGP " ++ label ++ " footer")--hasBeginArmorLabel :: BL.ByteString -> Bool-hasBeginArmorLabel = isJust . beginArmorLabel--hasEndArmorLabel :: BL.ByteString -> Bool-hasEndArmorLabel = isJust . endArmorLabel--beginArmorLabel :: BL.ByteString -> Maybe String-beginArmorLabel = armorBoundaryLabel "-----BEGIN PGP " "-----"--endArmorLabel :: BL.ByteString -> Maybe String-endArmorLabel = armorBoundaryLabel "-----END PGP " "-----"--armorBoundaryLabel :: String -> String -> BL.ByteString -> Maybe String-armorBoundaryLabel prefix suffix line = do- rest <- stripPrefix prefix (BLC8.unpack line)- if suffix `isSuffixOf` rest- then pure (take (length rest - length suffix) rest)- else Nothing--isOpenPGPArmorBlock :: Armor -> Bool-isOpenPGPArmorBlock (Armor _ _ _) = True-isOpenPGPArmorBlock _ = False--isArmorMessageBlock :: Armor -> Bool-isArmorMessageBlock (Armor ArmorMessage _ _) = True-isArmorMessageBlock _ = False--isDetachedSignatureArmor :: Armor -> Bool-isDetachedSignatureArmor (Armor ArmorSignature _ _) = True-isDetachedSignatureArmor _ = False--isDetachedSignatureUnsupportedArmor :: Armor -> Bool-isDetachedSignatureUnsupportedArmor (Armor _ _ _) = True-isDetachedSignatureUnsupportedArmor ClearSigned {} = True--isClearSignedArmor :: Armor -> Bool-isClearSignedArmor ClearSigned {} = True-isClearSignedArmor _ = False--isInlineSignedArmorCandidate :: Armor -> Bool-isInlineSignedArmorCandidate (Armor ArmorMessage _ _) = True-isInlineSignedArmorCandidate ClearSigned {} = True-isInlineSignedArmorCandidate _ = False--splitInlineSignedPackets :: [Pkt] -> IO (BL.ByteString, [Pkt])-splitInlineSignedPackets pkts = do- let msgPkts = [p | p@LiteralDataPkt {} <- pkts]- sigPkts = [p | p@SignaturePkt {} <- pkts]- case msgPkts of- [LiteralDataPkt _ _ _ payload]- | null sigPkts ->- failWith BadData "inline-detach input has no signatures"- | otherwise -> return (payload, sigPkts)- [] -> failWith BadData "inline-detach input has no literal message payload"- _ ->- failWith- BadData- "inline-detach input contains multiple literal payloads"--writeDetachedSignatures :: Bool -> String -> [Pkt] -> IO ()-writeDetachedSignatures noArmor outPath sigPkts = do- let sigBytes = runPut $ mapM_ Bin.put sigPkts- out =- if noArmor- then sigBytes- else BL.fromStrict (BLC8.toStrict (AA.encodeLazy [Armor ArmorSignature [] sigBytes]))- BL.writeFile outPath out--doListProfiles :: ListProfilesOptions -> IO ()-doListProfiles (ListProfilesOptions sc) =- case sc of- "generate-key" ->- putStr- "default: implementation defaults\nrfc4880: RSA-4096 interoperability-focused key generation\ncompatibility: broad interoperability defaults (alias of rfc4880)\nsecurity: security-oriented key generation\nperformance: performance-oriented key generation\n"- "encrypt" ->- putStr- "default: implementation defaults (alias of rfc9580, security, and performance)\nrfc9580: RFC 9580 packet format preferences\nrfc4880: RFC 4880 packet format preferences\ncompatibility: broad interoperability defaults (alias of rfc4880)\n"- _ -> failWith UnsupportedProfile "Subcommand does not support profiles"+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}++import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA+import Codec.Encryption.OpenPGP.ASCIIArmor.Types+ ( Armor (..)+ , ArmorType (..)+ )+import Codec.Encryption.OpenPGP.Compression+ ( CompressionError+ , decompressPkt+ , renderCompressionError+ )+import Codec.Encryption.OpenPGP.Encrypt+ ( PKESKEncryptError (..)+ , PKESKSessionMaterial (..)+ , RecipientEncryptRequest (..)+ , RecipientEncryptRequestOverrides (..)+ , RecipientEncryptResult (..)+ , RecipientPKESKVersionStrategy (..)+ , RecipientPayloadShape (..)+ , defaultRecipientPayloadShape+ , encryptForRecipients+ , recipientEncryptionTarget+ , recipientEncryptionTargetWithStrategy+ )+import Codec.Encryption.OpenPGP.Expirations+ ( effectiveKeyPreferencesAt+ , isTKTimeValid+ )+import Codec.Encryption.OpenPGP.Fingerprint+ ( eightOctetKeyID+ , fingerprint+ )+import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)+import Codec.Encryption.OpenPGP.Message+ ( EncryptMessageOptions (..)+ , RecoveredSessionMaterial (..)+ , SessionMaterialExposure (..)+ , encryptMessage+ , encryptedPayloadBytes+ , mkClearPayload+ , mkPassphrase+ )+import Codec.Encryption.OpenPGP.Ontology+ ( isKUF+ , isPKBindingSig+ , isSKBindingSig+ )+import Codec.Encryption.OpenPGP.Policy+ ( defaultDecryptPolicy+ , defaultPolicy+ , lenientDecryptPolicy+ )+import Codec.Encryption.OpenPGP.S2K+ ( decodeOpenPGPEncodedSessionKey+ , skesk2Key+ , skesk2SessionKey+ )+import Codec.Encryption.OpenPGP.SecretKey+ ( decryptPrivateKey+ , encryptPrivateKey+ )+import Codec.Encryption.OpenPGP.Serialize (parsePkts)+import Codec.Encryption.OpenPGP.Signatures+ ( SignError (..)+ , renderSignError+ , signCertRevocationWithRSA+ , signDataWithEd25519+ , signDataWithEd25519Legacy+ , signDataWithEd25519V6+ , signDataWithEd448+ , signDataWithEd448V6+ , signDataWithRSABuilder+ , 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.Exception+ ( IOException+ , SomeException+ , catch+ , displayException+ , evaluate+ , throwIO+ )+import Control.Monad (forM, forM_, join, unless, when, (>=>))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)+import Crypto.Error (eitherCryptoError)+import Crypto.Number.Serialize (i2ospOf_, os2ip)+import qualified Crypto.PubKey.Curve25519 as Curve25519+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as P15+import Crypto.Random.Types (getRandomBytes)+import qualified Data.Aeson as A+import Data.Bifunctor (first)+import qualified Data.Binary as Bin+import Data.Binary.Get (runGet)+import Data.Binary.Put+ ( putByteString+ , putLazyByteString+ , putWord16be+ , putWord32be+ , putWord8+ , runPut+ )+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC8+import Data.Char (digitToInt, isHexDigit, isSpace, toLower)+import Data.Conduit (fuseBoth, runConduitRes, (.|))+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.List as CL+import Data.Conduit.OpenPGP.Decrypt+ ( DecryptKeyResolution (..)+ , DecryptOutcome (..)+ , PKESKRecipientKey (..)+ )+import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt+import Data.Conduit.OpenPGP.Keyring+ ( conduitToTKsDroppingEither+ , sinkPublicKeyringMap+ )+import Data.Conduit.OpenPGP.Verify+ ( conduitVerify+ , verifyPacketsBatch+ )+import Data.Either (fromRight, isLeft, isRight, rights)+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.List+ ( find+ , findIndex+ , intercalate+ , isInfixOf+ , isPrefixOf+ , isSuffixOf+ , nub+ , partition+ , stripPrefix+ )+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe+ ( catMaybes+ , fromMaybe+ , isJust+ , listToMaybe+ , mapMaybe+ , maybeToList+ )+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Text.Encoding.Error (lenientDecode)+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX+ ( POSIXTime+ , getPOSIXTime+ , posixSecondsToUTCTime+ , utcTimeToPOSIXSeconds+ )+import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import qualified Data.Vector as V+import Data.Version (showVersion)+import Data.Word (Word8)+import GHC.Generics+import Options.Applicative.Builder+ ( argument+ , command+ , eitherReader+ , footerDoc+ , headerDoc+ , help+ , helpDoc+ , info+ , long+ , metavar+ , option+ , prefs+ , progDesc+ , showHelpOnError+ , str+ , strArgument+ , strOption+ , switch+ , value+ )+import Options.Applicative.Extra+ ( customExecParser+ , helper+ , hsubparser+ )+import Options.Applicative.Types (Parser)+import Prettyprinter+ ( hardline+ , list+ , pretty+ , softline+ )+import Prettyprinter.Render.Text (hPutDoc)+import System.Directory (doesFileExist)+import System.Environment (getArgs, lookupEnv)+import System.Exit+ ( ExitCode (..)+ , exitSuccess+ , exitWith+ )+import System.IO+ ( BufferMode (..)+ , Handle+ , hFlush+ , hPutStrLn+ , hSetBuffering+ , stderr+ , stdin+ )+import Text.Read (readMaybe)++import HOpenPGP.Tools.Common.Armor (doDeArmor)+import HOpenPGP.Tools.Common.Common+ ( banner+ , keyMatchesEightOctetKeyId+ , keyMatchesFingerprint+ , versioner+ , warranty+ )+import HOpenPGP.Tools.Common.TKUtils (processTK)+import Paths_hopenpgp_tools (version)++data Command+ = VersionC VersionOptions+ | ListProfilesC ListProfilesOptions+ | GenerateKeyC KeyGenOptions+ | ChangeKeyPasswordC ChangeKeyPasswordOptions+ | MergeCertsC MergeCertsOptions+ | ValidateUserIdC ValidateUserIdOptions+ | CertifyUserIdC CertifyUserIdOptions+ | RevokeKeyC RevokeKeyOptions+ | RevokeUserIdC RevokeUserIdOptions+ | UpdateKeyC UpdateKeyOptions+ | VerifyC VerifyOptions+ | InlineVerifyC InlineVerifyOptions+ | EncryptC EncryptOptions+ | DecryptC DecryptOptions+ | InlineSignC InlineSignOptions+ | InlineDetachC InlineDetachOptions+ | ExtractCertC ExtractCertOptions+ | SignC SignOptions+ | UnsupportedC String+ | DeArmorC+ | ArmorC ArmoringOptions++data OutputFormat+ = Unstructured+ | JSON+ | YAML+ deriving (Eq, Read, Show)++data VerifyOptions+ = VerifyOptions+ { verifyNotBefore :: Maybe String+ , verifyNotAfter :: Maybe String+ , verifySigFile :: String+ , verifyCertFiles :: [String]+ }++data InlineVerifyOptions+ = InlineVerifyOptions+ { inlineNotBefore :: Maybe String+ , inlineNotAfter :: Maybe String+ , verificationsOut :: Maybe String+ , inlineCertFiles :: [String]+ }++data EncryptOptions+ = EncryptOptions+ { encNoArmor :: Bool+ , encArmor :: Bool+ , encProfile :: Maybe String+ , encAs :: AsBinaryText+ , encSignWithKeyFiles :: [String]+ , encSignWithKeyPasswords :: [String]+ , encSessionKeyOutFile :: Maybe String+ , encFor :: EncryptFor+ , encWithoutIntegrityCheck :: Bool+ , encPasswords :: [String]+ , encRecipientCerts :: [String]+ }++data EncryptProfile+ = EncryptProfileRFC9580+ | EncryptProfileRFC4880+ deriving (Eq)++data DecryptOptions+ = DecryptOptions+ { decNoArmor :: Bool+ , decArmor :: Bool+ , decWithoutIntegrityCheck :: Bool+ , decVerifyNotBefore :: Maybe String+ , decVerifyNotAfter :: Maybe String+ , decSessionKeys :: [String]+ , decSessionKeyOutFile :: Maybe String+ , decPasswords :: [String]+ , decKeyPasswords :: [String]+ , decKeyFiles :: [String]+ , decVerifyCerts :: [String]+ , decVerificationsOutFile :: Maybe String+ , decDeprecatedVerifyOutFile :: Maybe String+ }++data InlineSignOptions+ = InlineSignOptions+ { inlineSignNoArmor :: Bool+ , inlineSignArmor :: Bool+ , inlineSignProfile :: Maybe String+ , inlineSignAs :: Maybe InlineSignMode+ , inlineSignKeyFiles :: [String]+ , inlineSignKeyPasswords :: [String]+ }++data InlineDetachOptions+ = InlineDetachOptions+ { inlineDetachNoArmor :: Bool+ , inlineDetachOutputSigs :: String+ }++data ChangeKeyPasswordOptions+ = ChangeKeyPasswordOptions+ { changeKeyPasswordNoArmor :: Bool+ , changeKeyPasswordOldPasswords :: [String]+ , changeKeyPasswordNewPasswords :: [String]+ }++data MergeCertsOptions+ = MergeCertsOptions+ { mergeCertsNoArmor :: Bool+ , mergeCertsFiles :: [String]+ }++data ValidateUserIdOptions+ = ValidateUserIdOptions+ { validateUserIdAddrSpecOnly :: Bool+ , validateUserIdAt :: Maybe String+ , validateUserIdString :: String+ , validateUserIdAuthorityFiles :: [String]+ }++data CertifyUserIdOptions+ = CertifyUserIdOptions+ { certifyUserIds :: [String]+ , certifyUserIdOutputFormat :: Maybe String+ , certifyUserIdNoRequireSelfSig :: Bool+ , certifyUserIdKeyPasswordFiles :: [String]+ , certifyUserIdSignerFiles :: [String]+ }++data RevokeKeyOptions+ = RevokeKeyOptions+ { revokeKeyNoArmor :: Bool+ , revokeKeyPasswordFiles :: [String]+ }++data RevokeUserIdOptions+ = RevokeUserIdOptions+ { revokeUserIdString :: String+ , revokeUserIdNoArmor :: Bool+ }++data UpdateKeyOptions+ = UpdateKeyOptions+ { updateKeyNoArmor :: Bool+ , updateKeySigningOnly :: Bool+ , updateKeyRevokeDeprecatedKeys :: Bool+ , updateKeyNoAddedCapabilities :: Bool+ , updateKeyPasswordFiles :: [String]+ , updateKeyMergeCerts :: [String]+ }++newtype ListProfilesOptions+ = ListProfilesOptions+ { profileSubcommand :: String+ }++data VersionOptions+ = VersionOptions+ { vBackend :: Bool+ , vExtended :: Bool+ , vSopSpec :: Bool+ , vSopv :: Bool+ }++data CliOptions+ = CliOptions+ { cliDebug :: Bool+ , cliCommand :: Command+ }++data SopFailure+ = MissingArg+ | IncompleteVerification+ | BadData+ | PasswordNotHumanReadable+ | ExpectedText+ | CannotDecrypt+ | UnsupportedAsymmetricAlgo+ | CertCannotEncrypt+ | UnsupportedOption+ | OutputExists+ | MissingInput+ | NoSignature+ | KeyIsProtected+ | KeyCannotSign+ | UnsupportedSpecialPrefix+ | IncompatibleOptions+ | UnsupportedProfile+ | UnsupportedSubcommand+ | CertUserIdNoMatch+ | KeyCannotCertify++failureCode :: SopFailure -> Int+failureCode MissingArg = 19+failureCode IncompleteVerification = 23+failureCode BadData = 41+failureCode PasswordNotHumanReadable = 31+failureCode ExpectedText = 53+failureCode CannotDecrypt = 29+failureCode UnsupportedAsymmetricAlgo = 13+failureCode CertCannotEncrypt = 17+failureCode UnsupportedOption = 37+failureCode OutputExists = 59+failureCode MissingInput = 61+failureCode NoSignature = 3+failureCode KeyIsProtected = 67+failureCode KeyCannotSign = 79+failureCode UnsupportedSpecialPrefix = 71+failureCode IncompatibleOptions = 83+failureCode UnsupportedProfile = 89+failureCode UnsupportedSubcommand = 69+failureCode CertUserIdNoMatch = 107+failureCode KeyCannotCertify = 109++failWith :: SopFailure -> String -> IO a+failWith f msg = do+ BLC8.hPutStrLn stderr (BLC8.pack msg)+ exitWith (ExitFailure (failureCode f))++voP :: Parser VerifyOptions+voP =+ VerifyOptions+ <$> optional+ ( strOption+ ( long "not-before"+ <> metavar "DATE"+ <> help "ignore signatures before DATE"+ )+ )+ <*> optional+ ( strOption+ ( long "not-after"+ <> metavar "DATE"+ <> help "ignore signatures after DATE"+ )+ )+ <*> argument str (metavar "SIGNATURES" <> sigHelp)+ <*> some (strArgument (metavar "CERTS..." <> certHelp))+ where+ sigHelp =+ helpDoc . Just $+ pretty "file containing OpenPGP signatures"+ certHelp =+ helpDoc . Just $+ pretty "one or more certificate files"++ivoP :: Parser InlineVerifyOptions+ivoP =+ InlineVerifyOptions+ <$> optional+ ( strOption+ ( long "not-before"+ <> metavar "DATE"+ <> help "ignore signatures before DATE"+ )+ )+ <*> optional+ ( strOption+ ( long "not-after"+ <> metavar "DATE"+ <> help "ignore signatures after DATE"+ )+ )+ <*> optional+ ( strOption+ ( long "verifications-out"+ <> metavar "VERIFICATIONS"+ <> help "write verification records to file"+ )+ )+ <*> some (strArgument (metavar "CERTS..." <> certHelp))+ where+ certHelp =+ helpDoc . Just $+ pretty "one or more certificate files"++lpoP :: Parser ListProfilesOptions+lpoP =+ ListProfilesOptions+ <$> strArgument+ (metavar "SUBCOMMAND" <> help "subcommand to list profiles for")++vopP :: Parser VersionOptions+vopP =+ VersionOptions+ <$> switch+ (long "backend" <> help "show backend implementation version")+ <*> switch+ (long "extended" <> help "show extended version information")+ <*> switch (long "sop-spec" <> help "show targeted sop draft")+ <*> switch+ (long "sopv" <> help "show implemented sopv subset version")++encP :: Parser EncryptOptions+encP =+ EncryptOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> switch (long "armor" <> help "output ASCII Armor")+ <*> optional+ (strOption (long "profile" <> help "encryption profile"))+ <*> option+ (eitherReader asTypeReader)+ (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)+ <*> many+ (strOption (long "sign-with" <> help "signing key material"))+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking signing key material"+ )+ )+ <*> optional+ ( strOption+ ( long "session-key-out"+ <> metavar "SESSIONKEY"+ <> help "write generated session key to file"+ )+ )+ <*> option+ (eitherReader encryptForReader)+ ( long "for"+ <> metavar "ENCRYPTION_PURPOSE"+ <> help+ "select recipient key purpose (any, storage, communications)"+ <> value EncryptForAny+ )+ <*> switch+ ( long "without-integrity-check"+ <> help "disable integrity protection"+ )+ <*> many+ ( strOption+ (long "with-password" <> help "symmetric encryption password")+ )+ <*> many+ ( strArgument+ (metavar "CERT" <> help "recipient certificate files")+ )+ where+ astypeHelp =+ helpDoc . Just $+ pretty "what to treat the input as"+ <> softline+ <> list (map (pretty . fst) asTypes)++decP :: Parser DecryptOptions+decP =+ DecryptOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> switch (long "armor" <> help "output ASCII Armor")+ <*> switch+ ( long "without-integrity-check"+ <> help "disable integrity verification"+ )+ <*> optional+ ( strOption+ ( long "verify-not-before"+ <> metavar "DATE"+ <> help "ignore signatures before DATE when decrypting"+ )+ )+ <*> optional+ ( strOption+ ( long "verify-not-after"+ <> metavar "DATE"+ <> help "ignore signatures after DATE when decrypting"+ )+ )+ <*> many+ ( strOption+ (long "with-session-key" <> help "session key for decryption")+ )+ <*> optional+ ( strOption+ (long "session-key-out" <> help "write recovered session key")+ )+ <*> many+ ( strOption+ (long "with-password" <> help "password for SKESK decryption")+ )+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking decryption key material"+ )+ )+ <*> many (strArgument (metavar "KEY" <> help "secret key material"))+ <*> many+ ( strOption+ ( long "verify-with"+ <> help "certificate(s) to verify signatures with"+ )+ )+ <*> optional+ ( strOption+ ( long "verifications-out"+ <> help "write verification results to file"+ )+ )+ <*> optional+ ( strOption+ ( long "verify-out"+ <> help "deprecated alias for --verifications-out"+ )+ )++inlineSignP :: Parser InlineSignOptions+inlineSignP =+ InlineSignOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> switch (long "armor" <> help "output ASCII Armor")+ <*> optional (strOption (long "profile" <> help "signature profile"))+ <*> optional+ ( option+ (eitherReader inlineSignModeReader)+ (long "as" <> metavar "DATATYPE" <> inlineSignAsHelp)+ )+ <*> some (strArgument (metavar "KEY" <> help "signing key file(s)"))+ <*> many+ ( strOption+ ( long "with-key-password"+ <> metavar "PASSWORD"+ <> help "password for encrypted signing key"+ )+ )+ where+ inlineSignAsHelp =+ helpDoc . Just $+ pretty "what to treat the input as"+ <> softline+ <> list [pretty "binary", pretty "text", pretty "clearsigned"]++inlineDetachP :: Parser InlineDetachOptions+inlineDetachP =+ InlineDetachOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> strOption+ ( long "signatures-out"+ <> metavar "SIGNATURES"+ <> help "write detached signatures to file"+ )++mergeCertsP :: Parser MergeCertsOptions+mergeCertsP =+ MergeCertsOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> some+ ( strArgument+ (metavar "CERTS..." <> help "one or more certificate files")+ )++validateUserIdP :: Parser ValidateUserIdOptions+validateUserIdP =+ ValidateUserIdOptions+ <$> switch+ ( long "addr-spec-only"+ <> help+ "match only the addr-spec portion of conventional OpenPGP User IDs"+ )+ <*> optional+ ( strOption+ ( long "validate-at"+ <> metavar "DATE"+ <> help "evaluate certifications at DATE"+ )+ )+ <*> argument str (metavar "USERID" <> help "user ID to validate")+ <*> some+ ( strArgument+ ( metavar "CERTS..."+ <> help "one or more authority certificate files"+ )+ )++certifyUserIdP :: Parser CertifyUserIdOptions+certifyUserIdP =+ CertifyUserIdOptions+ <$> some+ ( strOption+ ( long "userid"+ <> metavar "USERID"+ <> help "user ID to certify (repeatable)"+ )+ )+ <*> optional+ ( strOption+ ( long "output-format"+ <> metavar "FORMAT"+ <> help "output format (text or binary)"+ )+ )+ <*> switch+ ( long "no-require-self-sig"+ <> help "allow certifying user IDs that do not have self-signatures"+ )+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking signer key material"+ )+ )+ <*> some+ ( strArgument+ (metavar "KEYS..." <> help "one or more signer key files")+ )++revokeKeyP :: Parser RevokeKeyOptions+revokeKeyP =+ RevokeKeyOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking secret key material"+ )+ )++revokeUserIdP :: Parser RevokeUserIdOptions+revokeUserIdP =+ RevokeUserIdOptions+ <$> argument str (metavar "USERID" <> help "user ID to revoke")+ <*> switch (long "no-armor" <> help "output binary")++updateKeyP :: Parser UpdateKeyOptions+updateKeyP =+ UpdateKeyOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> switch+ ( long "signing-only"+ <> help "limit updated material to signing-capable key material"+ )+ <*> switch+ ( long "revoke-deprecated-keys"+ <> help+ "emit revocations for deprecated key material when supported"+ )+ <*> switch+ ( long "no-added-capabilities"+ <> help+ "do not add capabilities beyond existing target key material"+ )+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking key material"+ )+ )+ <*> many+ ( strOption+ ( long "merge-certs"+ <> metavar "CERTS"+ <> help "additional certificate files to merge into target keys"+ )+ )++changeKeyPasswordP :: Parser ChangeKeyPasswordOptions+changeKeyPasswordP =+ ChangeKeyPasswordOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> many+ ( strOption+ ( long "old-key-password"+ <> help "password(s) used to unlock existing secret key material"+ )+ )+ <*> many+ ( strOption+ ( long "new-key-password"+ <> help "password used to protect rewritten secret key material"+ )+ )++dispatch :: POSIXTime -> Command -> IO ()+dispatch cpt cmd' = banner' stderr >> hFlush stderr >> dispatch' cpt cmd'+ where+ dispatch' _ (VersionC o') = doVersion o'+ dispatch' _ (ListProfilesC o') = doListProfiles o'+ dispatch' t (GenerateKeyC o) = doGenerateKey t o+ dispatch' _ (ChangeKeyPasswordC o) = doChangeKeyPassword o+ dispatch' _ (MergeCertsC o) = doMergeCerts o+ dispatch' t (ValidateUserIdC o) = doValidateUserId t o+ dispatch' t (CertifyUserIdC o) = doCertifyUserId t o+ dispatch' t (RevokeKeyC o) = doRevokeKey t o+ dispatch' t (RevokeUserIdC o) = doRevokeUserId t o+ dispatch' t (UpdateKeyC o) = doUpdateKey t o+ dispatch' t (VerifyC o') = doVerify t o'+ dispatch' t (InlineVerifyC o') = doInlineVerify t o'+ dispatch' t (EncryptC o') = doEncrypt t o'+ dispatch' t (DecryptC o') = doDecrypt t o'+ dispatch' t (InlineSignC o') = doInlineSign t o'+ dispatch' t (InlineDetachC o') = doInlineDetach t o'+ dispatch' _ (ExtractCertC o) = doExtractCert o+ dispatch' t (SignC o) = doSign t o+ dispatch' _ (UnsupportedC c) =+ failWith+ UnsupportedSubcommand+ ("command not yet implemented: " ++ c)+ dispatch' _ DeArmorC = doDeArmor+ dispatch' _ (ArmorC o) = doArmor o++main :: IO ()+main = do+ hSetBuffering stderr LineBuffering+ args <- getArgs+ ensureKnownSubcommand knownSopSubcommands args+ cpt <- getPOSIXTime+ CliOptions {..} <-+ customExecParser+ (prefs showHelpOnError)+ ( info+ (helper <*> versioner "hop" <*> cliP)+ ( headerDoc (Just (banner "hop"))+ <> progDesc "hOpenPGP Validator Tool"+ <> footerDoc (Just (warranty "hop"))+ )+ )+ let _ = cliDebug+ dispatch cpt cliCommand++knownSopSubcommands :: [String]+knownSopSubcommands =+ [ "armor"+ , "dearmor"+ , "change-key-password"+ , "decrypt"+ , "encrypt"+ , "certify-userid"+ , "extract-cert"+ , "generate-key"+ , "inline-detach"+ , "inline-sign"+ , "inline-verify"+ , "list-profiles"+ , "merge-certs"+ , "revoke-key"+ , "revoke-userid"+ , "sign"+ , "update-key"+ , "validate-userid"+ , "verify"+ , "version"+ ]++ensureKnownSubcommand :: [String] -> [String] -> IO ()+ensureKnownSubcommand knownSubcommands args =+ if any (`elem` ["-h", "--help", "--version"]) args+ then pure ()+ else case find (not . isPrefixOf "-") args of+ Just subcommand+ | subcommand `notElem` knownSubcommands ->+ failWith+ UnsupportedSubcommand+ ("unsupported subcommand: " ++ subcommand)+ _ -> pure ()++cliP :: Parser CliOptions+cliP =+ CliOptions+ <$> switch (long "debug" <> help "emit more verbose output")+ <*> cmd++banner' :: Handle -> IO ()+banner' h =+ hPutDoc+ h+ (banner "hop" <> hardline <> warranty "hop" <> hardline)++data Vrf+ = Vrf+ { _vrfmsg :: String+ , _vrfmfpr :: Maybe Fingerprint+ }+ deriving (Eq, Generic, Show)++instance A.ToJSON Vrf++cmd :: Parser Command+cmd =+ hsubparser+ ( command+ "armor"+ (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout"))+ <> command+ "dearmor"+ (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))+ <> command+ "change-key-password"+ ( info+ (ChangeKeyPasswordC <$> changeKeyPasswordP)+ (progDesc "Update a key password")+ )+ <> command+ "decrypt"+ (info (DecryptC <$> decP) (progDesc "Decrypt a message"))+ <> command+ "encrypt"+ (info (EncryptC <$> encP) (progDesc "Encrypt a message"))+ <> command+ "certify-userid"+ ( info+ (CertifyUserIdC <$> certifyUserIdP)+ (progDesc "Certify user IDs in a certificate")+ )+ <> command+ "extract-cert"+ ( info+ (ExtractCertC <$> ecoP)+ ( progDesc+ "Extract a certificate from a secret key and output it to stdout"+ )+ )+ <> command+ "generate-key"+ ( info+ (GenerateKeyC <$> gkoP)+ (progDesc "Generate a secret key and output it to stdout")+ )+ <> command+ "inline-detach"+ ( info+ (InlineDetachC <$> inlineDetachP)+ (progDesc "Create inline detached signatures")+ )+ <> command+ "inline-sign"+ ( info+ (InlineSignC <$> inlineSignP)+ (progDesc "Create inline signatures")+ )+ <> command+ "inline-verify"+ ( info+ (InlineVerifyC <$> ivoP)+ (progDesc "Verify inline-signed data")+ )+ <> command+ "list-profiles"+ (info (ListProfilesC <$> lpoP) (progDesc "List SOP profiles"))+ <> command+ "merge-certs"+ ( info+ (MergeCertsC <$> mergeCertsP)+ (progDesc "Merge OpenPGP certificates")+ )+ <> command+ "revoke-key"+ ( info+ (RevokeKeyC <$> revokeKeyP)+ (progDesc "Create a key revocation certificate")+ )+ <> command+ "revoke-userid"+ ( info+ (RevokeUserIdC <$> revokeUserIdP)+ (progDesc "Revoke a user ID")+ )+ <> command+ "sign"+ ( info+ (SignC <$> soP)+ (progDesc "Create detached signatures and output them to stdout")+ )+ <> command+ "update-key"+ (info (UpdateKeyC <$> updateKeyP) (progDesc "Update key material"))+ <> command+ "validate-userid"+ ( info+ (ValidateUserIdC <$> validateUserIdP)+ (progDesc "Validate a certificate user ID")+ )+ <> command+ "verify"+ (info (VerifyC <$> voP) (progDesc "Verify signatures"))+ <> command+ "version"+ ( info+ (VersionC <$> vopP)+ (progDesc "output hop version to stdout")+ )+ )++armorTypes :: [(String, Maybe ArmorType)]+armorTypes =+ [ ("auto", Nothing)+ , ("sig", Just ArmorSignature)+ , ("key", Just ArmorPrivateKeyBlock)+ , ("cert", Just ArmorPublicKeyBlock)+ , ("message", Just ArmorMessage)+ ]++armorTypeReader :: String -> Either String (Maybe ArmorType)+armorTypeReader = note "unknown armor type" . flip lookup armorTypes++aoP :: Parser ArmoringOptions+aoP =+ ArmoringOptions+ <$> option+ (eitherReader armorTypeReader)+ (long "label" <> metavar "LABEL" <> armortypeHelp)+ <*> switch+ ( long "allow-nested"+ <> help "do the sane thing and unconditionally armor the output"+ )+ where+ armortypeHelp =+ helpDoc . Just $+ pretty "ASCII armor type"+ <> softline+ <> list (map (pretty . fst) armorTypes)++data ArmoringOptions+ = ArmoringOptions+ { label :: Maybe ArmorType+ , allowNested :: Bool+ }++doArmor :: ArmoringOptions -> IO ()+doArmor ArmoringOptions {..} = do+ m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ let lbs = BL.fromChunks m+ armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs+ label' = guessLabel label (decodeFirstPacket lbs)+ a = Armor label' [] lbs+ BL.putStr $+ if armoredAlready && not allowNested+ then lbs+ else AA.encodeLazy [a]+ where+ decodeFirstPacket = runGet Bin.get+ -- UPSTREAM: openpgp-asciiarmor should export selectArmorType helper+ -- to eliminate this pattern-matching boilerplate+ guessLabel (Just l) _ = l+ guessLabel Nothing (SignaturePkt _) = ArmorSignature+ guessLabel Nothing (SecretKeyPkt _ _) = ArmorPrivateKeyBlock+ guessLabel Nothing (PublicKeyPkt _) = ArmorPublicKeyBlock+ guessLabel Nothing _ = ArmorMessage++doVersion :: VersionOptions -> IO ()+doVersion VersionOptions {..} = do+ let selected = length (filter id [vBackend, vExtended, vSopSpec, vSopv])+ when (selected > 1) $+ failWith+ IncompatibleOptions+ "version: --backend, --extended, --sop-spec, and --sopv are mutually exclusive"+ putStrLn $ "hop " ++ showVersion version+ when vBackend $ putStrLn "backend: hOpenPGP"+ when vExtended $ putStrLn "extended: yes"+ when vSopSpec $+ putStrLn "spec: draft-dkg-openpgp-stateless-cli-16"+ when vSopv $ putStrLn "sopv: 1.0"++gkoP :: Parser KeyGenOptions+gkoP =+ KeyGenOptions+ <$> switch (long "armor" <> help "armor the output")+ <*> switch (long "no-armor" <> help "don't armor the output")+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password used to protect generated secret key material"+ )+ )+ <*> optional+ ( strOption+ ( long "profile"+ <> metavar "PROFILE"+ <> help+ "key generation profile (default, rfc4880, compatibility, security, performance)"+ )+ )+ <*> switch+ (long "signing-only" <> help "generate signing-only key material")+ <*> many+ ( strArgument+ (metavar "USERID" <> help "User ID associated with this key")+ )++data KeyGenOptions+ = KeyGenOptions+ { armor :: Bool+ , noArmor :: Bool+ , keyPasswords :: [String]+ , keyProfile :: Maybe String+ , keySigningOnly :: Bool+ , userIds :: [String]+ }++doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()+doGenerateKey pt KeyGenOptions {..} = do+ when (armor && noArmor) $+ failWith+ IncompatibleOptions+ "generate-key: --armor and --no-armor are mutually exclusive"+ baseProfile <- parseKeyGenProfile keyProfile+ let profile =+ if keySigningOnly+ then KeyGenSigningOnly+ else baseProfile+ password <- parseGenerateKeyPassword keyPasswords+ let ts = ThirtyTwoBitTimeStamp (floor pt)+ -- UPSTREAM: hOpenPGP should expose a supported legacy secret-key+ -- re-encryption path so password-protected v4 key generation does not+ -- need to switch to the v6 protection format here.+ keyVersion =+ if isJust password && keyVersionForProfile profile == V4+ then V6+ else keyVersionForProfile profile+ primaryKeySpec = primaryKeySpecForProfile profile+ sk <- generateSecretKey ts keyVersion primaryKeySpec+ baseKey <-+ buildKeyWith sk $ do+ case userIds of+ (primaryUid : restUids) -> do+ addUserId ts True (T.pack primaryUid)+ mapM_ (addUserId ts False . T.pack) restUids+ [] -> pure ()+ addSubkeysForProfile ts keyVersion profile+ newkey <- get+ return newkey+ s <-+ maybe+ (pure baseKey)+ (`encryptTransferableSecretKey` baseKey)+ password+ let lbs = runPut $ Bin.put s+ BL.putStr $+ if not armor && not noArmor+ then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]+ else lbs++type KeyBuilder = StateT TKUnknown IO++buildKeyWith :: SecretKey -> KeyBuilder a -> IO a+buildKeyWith sk a = evalStateT a (bareTK sk)+ where+ bareTK (SecretKey pkp ska) = TKUnknown (pkp, Just ska) [] [] [] []++data GeneratedKeySpec+ = GeneratedRSAKey Int+ | GeneratedEd25519Key+ | GeneratedX25519Key+ deriving (Eq)++generateSecretKey+ :: ThirtyTwoBitTimeStamp+ -> KeyVersion+ -> GeneratedKeySpec+ -> IO SecretKey+generateSecretKey ts keyVersion (GeneratedRSAKey bits) = do+ (pub, priv) <- liftIO $ RSA.generate bits 0x10001+ return $ SecretKey (pkp pub) (ska priv)+ where+ pkp pub = PKPayload keyVersion ts 0 RSA (RSAPubKey (RSA_PublicKey pub))+ ska priv = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey priv)) 0 -- FIXME: calculate checksum+generateSecretKey ts keyVersion GeneratedEd25519Key = do+ priv <- Ed25519.generateSecretKey+ let pub = Ed25519.toPublic priv+ pubBytes = BA.convert pub :: B.ByteString+ privBytes = BA.convert priv :: B.ByteString+ pure $+ SecretKey+ ( PKPayload+ keyVersion+ ts+ 0+ (toFVal 27)+ (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes))))+ )+ (SUUnencrypted (EdDSAPrivateKey Ed25519 privBytes) 0)+generateSecretKey ts keyVersion GeneratedX25519Key = do+ priv <- Curve25519.generateSecretKey+ let pub = Curve25519.toPublic priv+ pubBytes = BA.convert pub :: B.ByteString+ privBytes = BA.convert priv :: B.ByteString+ pure $+ SecretKey+ ( PKPayload+ keyVersion+ ts+ 0+ X25519+ (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes))))+ )+ (SUUnencrypted (X25519PrivateKey privBytes) 0)++data KeyGenProfile+ = KeyGenDefault+ | KeyGenRFC4880+ | KeyGenSecurity+ | KeyGenPerformance+ | KeyGenSigningOnly+ deriving (Eq)++parseKeyGenProfile :: Maybe String -> IO KeyGenProfile+parseKeyGenProfile Nothing = pure KeyGenDefault+parseKeyGenProfile (Just "default") = pure KeyGenDefault+parseKeyGenProfile (Just "rfc4880") = pure KeyGenRFC4880+parseKeyGenProfile (Just "compatibility") = pure KeyGenRFC4880+parseKeyGenProfile (Just "security") = pure KeyGenSecurity+parseKeyGenProfile (Just "performance") = pure KeyGenPerformance+parseKeyGenProfile (Just profile) =+ failWith+ UnsupportedProfile+ ("generate-key: unsupported profile " ++ profile)++keyVersionForProfile :: KeyGenProfile -> KeyVersion+keyVersionForProfile KeyGenDefault = V6+keyVersionForProfile KeyGenRFC4880 = V4+keyVersionForProfile KeyGenSecurity = V6+keyVersionForProfile KeyGenPerformance = V6+keyVersionForProfile KeyGenSigningOnly = V6++primaryKeySpecForProfile :: KeyGenProfile -> GeneratedKeySpec+primaryKeySpecForProfile KeyGenRFC4880 = GeneratedRSAKey 4096+primaryKeySpecForProfile _ = GeneratedEd25519Key++parseGenerateKeyPassword :: [String] -> IO (Maybe BL.ByteString)+parseGenerateKeyPassword [] = pure Nothing+parseGenerateKeyPassword [passwordFile] =+ Just+ <$> ( loadPasswordFromFile+ "generate-key"+ "--with-key-password"+ passwordFile+ >>= normalizeHumanReadablePassword+ "generate-key"+ "--with-key-password"+ )+parseGenerateKeyPassword _ =+ failWith+ UnsupportedOption+ "generate-key: multiple --with-key-password values are not supported"++loadPasswordFiles+ :: String -> String -> [String] -> IO [BL.ByteString]+loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName)++loadPasswordFromFile+ :: String -> String -> FilePath -> IO BL.ByteString+loadPasswordFromFile context optionName path = do+ case stripPrefix "@ENV:" path of+ Just varName+ | null varName ->+ failWith+ BadData+ (context ++ ": empty environment variable name in " ++ optionName)+ | otherwise -> do+ envValue <- lookupEnv varName+ case envValue of+ Nothing ->+ failWith+ MissingInput+ ( context+ ++ ": environment variable not found for "+ ++ optionName+ ++ ": "+ ++ varName+ )+ Just envVal -> pure (BLC8.pack envVal)+ Nothing ->+ case stripPrefix "@FD:" path of+ Just fdSpec -> loadPasswordFromFD context optionName fdSpec+ Nothing ->+ case path of+ '@' : _ ->+ failWith+ UnsupportedSpecialPrefix+ ( context+ ++ ": unsupported special prefix for "+ ++ optionName+ ++ ": "+ ++ path+ )+ _ -> do+ exists <- doesFileExist path+ unless exists $+ failWith+ MissingInput+ ( context+ ++ ": password file does not exist for "+ ++ optionName+ ++ ": "+ ++ path+ )+ BL.readFile path++loadPasswordFromFD+ :: String -> String -> String -> IO BL.ByteString+loadPasswordFromFD context optionName fdSpec =+ case readMaybe fdSpec :: Maybe Int of+ Just fdNum+ | fdNum >= 0 ->+ ( do+ let fdPath = "/dev/fd/" ++ show fdNum+ exists <- doesFileExist fdPath+ unless exists $+ failWith+ MissingInput+ ( context+ ++ ": file descriptor not available for "+ ++ optionName+ ++ ": "+ ++ fdSpec+ )+ contents <- BL.readFile fdPath+ _ <- evaluate (BL.length contents)+ pure contents+ )+ `catch` ( \err ->+ failWith+ MissingInput+ ( context+ ++ ": failed reading file descriptor for "+ ++ optionName+ ++ ": "+ ++ fdSpec+ ++ " ("+ ++ displayException (err :: IOException)+ ++ ")"+ )+ )+ | otherwise ->+ failWith+ BadData+ ( context+ ++ ": invalid file descriptor in "+ ++ optionName+ ++ ": "+ ++ fdSpec+ )+ _ ->+ failWith+ BadData+ ( context+ ++ ": invalid file descriptor in "+ ++ optionName+ ++ ": "+ ++ fdSpec+ )++normalizeHumanReadablePassword+ :: String -> String -> BL.ByteString -> IO BL.ByteString+normalizeHumanReadablePassword context optionName passwordBytes =+ case TE.decodeUtf8' (BL.toStrict passwordBytes) of+ Left _ ->+ failWith+ PasswordNotHumanReadable+ ( context+ ++ ": password is not human-readable UTF-8 for "+ ++ optionName+ )+ Right txt ->+ pure+ (BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt)))++passwordRetryCandidates :: BL.ByteString -> [BL.ByteString]+passwordRetryCandidates passwordBytes =+ case TE.decodeUtf8' (BL.toStrict passwordBytes) of+ Left _ -> [passwordBytes]+ Right txt ->+ let trimmed = BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt))+ in if trimmed == passwordBytes+ then [passwordBytes]+ else [passwordBytes, trimmed]++addSubkeysForProfile+ :: ThirtyTwoBitTimeStamp+ -> KeyVersion+ -> KeyGenProfile+ -> KeyBuilder ()+addSubkeysForProfile ts keyVersion profile =+ case profile of+ KeyGenSigningOnly ->+ addSubkey ts keyVersion profile [SignDataKey]+ _ -> do+ addSubkey+ ts+ keyVersion+ profile+ [EncryptStorageKey, EncryptCommunicationsKey]+ addSubkey ts keyVersion profile [SignDataKey]+ addSubkey ts keyVersion profile [AuthKey]++subkeySpecForProfile+ :: KeyGenProfile -> [KeyFlag] -> GeneratedKeySpec+subkeySpecForProfile KeyGenRFC4880 _ = GeneratedRSAKey 4096+subkeySpecForProfile _ keyflags+ | any+ (`elem` keyflags)+ [EncryptStorageKey, EncryptCommunicationsKey] =+ GeneratedX25519Key+ | 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'}+ 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+ encryptSecretAddendumForOutput pkp ska =+ case ska of+ SUUnencrypted {} -> doEncryptSecret+ _ -> pure ska+ where+ doEncryptSecret = do+ encryptedResult <-+ encryptPrivateKey defaultPolicy pkp ska password+ case encryptedResult of+ Left err ->+ failWith+ BadData+ ("generate-key: failed to protect secret key material: " ++ err)+ Right val -> pure val++rsaSigningKey :: SKAddendum -> IO RSA.PrivateKey+rsaSigningKey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) =+ pure (k {RSA.private_p = 0, RSA.private_q = 0})+rsaSigningKey _ =+ failWith+ BadData+ "generate-key: unsupported secret key format for RSA signing"++issuerSubpacketsFor+ :: String -> SomePKPayload -> IO [SigSubPacket]+issuerSubpacketsFor context pkp =+ case _keyVersion pkp of+ V6 -> pure []+ _ ->+ case eightOctetKeyID pkp of+ Left err ->+ failWith+ BadData+ (context ++ ": could not derive issuer key id: " ++ show err)+ Right keyId -> pure [SigSubPacket False (Issuer keyId)]++addUserId+ :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()+addUserId ts primary userid = do+ tk <- get+ signed <- selfsign (_tkuKey tk) userid+ modify (newUID signed)+ where+ newUID signed tk = tk {_tkuUIDs = _tkuUIDs tk ++ [signed]}+ selfsign (pkp, Just ska) u = do+ issuer <- liftIO (unhashed pkp)+ sig <-+ liftIO $+ signWithKey+ "generate-key"+ pkp+ PositiveCert+ SHA512+ (hashed pkp)+ issuer+ (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+ False+ ( IssuerFingerprint+ (issuerFingerprintVersionFor pkp)+ (fingerprint pkp)+ )+ , SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey))+ , SigSubPacket False (PrimaryUserId primary)+ , SigSubPacket+ False+ (PreferredHashAlgorithms [SHA512, SHA256, SHA384, SHA224])+ , SigSubPacket+ False+ (PreferredSymmetricAlgorithms [AES256, AES192, AES128])+ ]+ unhashed = issuerSubpacketsFor "generate-key"++addSubkey+ :: ThirtyTwoBitTimeStamp+ -> KeyVersion+ -> KeyGenProfile+ -> [KeyFlag]+ -> KeyBuilder ()+addSubkey ts keyVersion profile keyflags = do+ tk <- get+ (SecretKey subpkp subska) <-+ liftIO $+ generateSecretKey+ 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"+ issuerPrimary <- liftIO (unhashed pkp)+ issuerSub <- liftIO (unhashed subpkp)+ embeddedBacksig <-+ if SignDataKey `elem` keyflags+ then+ Just+ <$> liftIO+ ( signWithKey+ "generate-key"+ subpkp+ PrimaryKeyBindingSig+ SHA512+ (hashed subpkp)+ issuerSub+ (subkeyPayloadForSigning pkp subpkp)+ (Just subska)+ )+ else pure Nothing+ bindingSig <-+ liftIO $+ signWithKey+ "generate-key"+ pkp+ SubkeyBindingSig+ SHA512+ (hashedwithflags pkp)+ ( maybe+ issuerPrimary+ ( \sig -> SigSubPacket False (EmbeddedSignature sig) : issuerPrimary+ )+ embeddedBacksig+ )+ (subkeyPayloadForSigning pkp subpkp)+ (Just ska)+ modify (addIt subpkp subska bindingSig)+ where+ addIt sp ss binding tk =+ tk+ { _tkuSubs = _tkuSubs tk ++ [(SecretSubkeyPkt sp ss, [binding])]+ }+ hashed pkp =+ [ SigSubPacket False (SigCreationTime ts)+ , SigSubPacket+ False+ ( IssuerFingerprint+ (issuerFingerprintVersionFor pkp)+ (fingerprint pkp)+ )+ ]+ hashedwithflags pkp =+ hashed pkp+ ++ [SigSubPacket False (KeyFlags (S.fromList keyflags))]+ unhashed = issuerSubpacketsFor "generate-key"++putKeyForSigning :: SomePKPayload -> Bin.Put+putKeyForSigning pkp@(PKPayload V6 _ _ _ _) = do+ putWord8 0x9A+ let bs = runPut (Bin.put pkp)+ putWord32be (fromIntegral (BL.length bs))+ putLazyByteString bs+putKeyForSigning pkp = do+ putWord8 0x99+ let bs = runPut (Bin.put pkp)+ putWord16be (fromIntegral (BL.length bs))+ putLazyByteString bs++putUserIdForSigning :: UserId -> Bin.Put+putUserIdForSigning (UserId u) = do+ let bs = TE.encodeUtf8 u+ putWord8 0xB4+ putWord32be (fromIntegral (B.length bs))+ putByteString bs++userIdPayloadForSigning+ :: SomePKPayload -> UserId -> BL.ByteString+userIdPayloadForSigning pkp uid =+ runPut $ do+ putKeyForSigning pkp+ putUserIdForSigning uid++subkeyPayloadForSigning+ :: SomePKPayload -> SomePKPayload -> BL.ByteString+subkeyPayloadForSigning primary sub =+ runPut $ do+ putKeyForSigning primary+ putKeyForSigning sub++issuerFingerprintVersionFor+ :: SomePKPayload -> IssuerFingerprintVersion+issuerFingerprintVersionFor pkp =+ case _keyVersion pkp of+ V6 -> IssuerFingerprintV6+ _ -> IssuerFingerprintV4++ecoP :: Parser ExtractCertOptions+ecoP =+ ExtractCertOptions+ <$> switch (long "armor" <> help "armor the output")+ <*> switch (long "no-armor" <> help "don't armor the output")++data ExtractCertOptions+ = ExtractCertOptions+ { ecArmor :: Bool+ , ecNoArmor :: Bool+ }++doExtractCert :: ExtractCertOptions -> IO ()+doExtractCert ExtractCertOptions {..} = do+ kbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ let lbs = BL.fromChunks kbs+ pkts <- decodeOpenPGPInput "stdin" lbs+ tks <-+ runConduitRes $+ CL.sourceList pkts+ .| conduitToTKsDroppingEither+ .| CL.mapMaybe (either (const Nothing) id)+ .| 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+ 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++doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()+doChangeKeyPassword ChangeKeyPasswordOptions {..} = do+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ packets <- decodeOpenPGPInput "stdin" input+ tks <-+ runConduitRes $+ CL.sourceList packets+ .| conduitToTKsDroppingEither+ .| CL.mapMaybe (either (const Nothing) id)+ .| CC.sinkList+ when (null tks) $+ failWith+ MissingInput+ "change-key-password: no transferable secret key found on standard input"+ when (any (not . hasSecretKeyMaterial) tks) $+ failWith+ MissingInput+ "change-key-password: expected transferable secret key input on standard input"+ oldPasswordsRaw <-+ loadPasswordFiles+ "change-key-password"+ "--old-key-password"+ changeKeyPasswordOldPasswords+ let oldPasswords = concatMap passwordRetryCandidates oldPasswordsRaw+ newPassword <-+ parseChangeKeyPasswordNewPassword changeKeyPasswordNewPasswords+ unlockedTks <-+ mapM+ ( unlockTransferableSecretKeyMaterial+ "change-key-password"+ "standard input"+ "--old-key-password"+ oldPasswords+ )+ tks+ rewrittenTks <-+ case newPassword of+ Just password -> mapM (encryptTransferableSecretKey password) unlockedTks+ Nothing -> pure unlockedTks+ let output = runPut (mapM_ Bin.put rewrittenTks)+ BL.putStr $+ if changeKeyPasswordNoArmor || BL.null output+ then output+ else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]++parseChangeKeyPasswordNewPassword+ :: [String] -> IO (Maybe BL.ByteString)+parseChangeKeyPasswordNewPassword [] = pure Nothing+parseChangeKeyPasswordNewPassword [passwordFile] =+ Just+ <$> ( loadPasswordFromFile+ "change-key-password"+ "--new-key-password"+ passwordFile+ >>= normalizeHumanReadablePassword+ "change-key-password"+ "--new-key-password"+ )+parseChangeKeyPasswordNewPassword _ =+ failWith+ UnsupportedOption+ "change-key-password: multiple --new-key-password values are not supported"++hasSecretKeyMaterial :: TKUnknown -> Bool+hasSecretKeyMaterial tk =+ case _tkuKey tk of+ (_, Just _) -> True+ _ -> any isSecretSubkeyPkt (_tkuSubs tk)+ where+ isSecretSubkeyPkt (SecretSubkeyPkt _ _, _) = True+ isSecretSubkeyPkt _ = False++doValidateUserId :: POSIXTime -> ValidateUserIdOptions -> IO ()+doValidateUserId cpt ValidateUserIdOptions {..} = do+ authorityTks <-+ concat+ <$> mapM+ (loadCertTKsFromFile "validate-userid")+ validateUserIdAuthorityFiles+ validateAtTime <- verificationUpperBound cpt validateUserIdAt+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ certPkts <- decodeOpenPGPInput "standard input" input+ certTks <-+ runConduitRes $+ CL.sourceList certPkts+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ when (null certTks) $+ failWith+ MissingInput+ "validate-userid: no certificate found on standard input"+ let targetUserId = T.pack validateUserIdString+ forM_ certTks $ \certTk ->+ when+ ( not+ ( certificateHasMatchingValidatedUserId+ authorityTks+ validateAtTime+ validateUserIdAddrSpecOnly+ targetUserId+ certTk+ )+ )+ $ failWith+ CertUserIdNoMatch+ ( "validate-userid: certificate has no correctly bound user ID matching "+ ++ validateUserIdString+ )++certificateHasMatchingValidatedUserId+ :: [TKUnknown] -> Maybe UTCTime -> Bool -> Text -> TKUnknown -> Bool+certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =+ case verifyUnknownTKWith verifier validateAtTime certTk of+ Left _ -> False+ Right verifiedTk -> any matchingBoundUid (_tkuUIDs verifiedTk)+ where+ verifier = verifySigWith (verifyAgainstKeys (certTk : authorityTks))+ matchingBoundUid (uid, sigs) =+ useridMatches addrSpecOnly targetUserId uid+ && any (signatureMatchesSigner certTk) sigs+ && any+ (\sig -> any (`signatureMatchesSigner` sig) authorityTks)+ sigs++useridMatches :: Bool -> Text -> Text -> Bool+useridMatches False targetUserId uid = uid == targetUserId+useridMatches True targetUserId uid =+ case conventionalAddrSpec uid of+ Just addrSpec -> addrSpec == targetUserId+ Nothing -> False++conventionalAddrSpec :: Text -> Maybe Text+conventionalAddrSpec uid =+ let (prefix, suffix) = T.breakOnEnd (T.pack "<") uid+ in if T.null prefix+ then Nothing+ else case T.unsnoc suffix of+ Just (addrSpec, '>')+ | T.any (== '<') addrSpec -> Nothing+ | otherwise -> guardNonEmpty (T.strip addrSpec)+ _ -> Nothing+ where+ guardNonEmpty text+ | T.null text = Nothing+ | otherwise = Just text++signatureMatchesSigner :: TKUnknown -> SignaturePayload -> Bool+signatureMatchesSigner signer sig =+ maybe+ False+ (keyMatchesFingerprint False signer)+ (signatureIssuerFingerprint sig)+ || maybe+ False+ (keyMatchesEightOctetKeyId False signer . Right)+ (signatureIssuerKeyId sig)++signatureIssuerFingerprint+ :: SignaturePayload -> Maybe Fingerprint+signatureIssuerFingerprint =+ listToMaybe . mapMaybe getIssuerFingerprint . signatureSubpackets+ where+ getIssuerFingerprint (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) =+ Just issuerFingerprint+ getIssuerFingerprint _ = Nothing++signatureIssuerKeyId :: SignaturePayload -> Maybe EightOctetKeyId+signatureIssuerKeyId = listToMaybe . mapMaybe getIssuerKeyId . signatureSubpackets+ where+ getIssuerKeyId (SigSubPacket _ (Issuer issuerKeyId)) = Just issuerKeyId+ getIssuerKeyId _ = Nothing++signatureSubpackets :: SignaturePayload -> [SigSubPacket]+signatureSubpackets (SigV4 _ _ _ hashed unhashed _ _) = hashed ++ unhashed+signatureSubpackets (SigV6 _ _ _ _ hashed unhashed _ _) = hashed ++ unhashed+signatureSubpackets _ = []++doCertifyUserId :: POSIXTime -> CertifyUserIdOptions -> IO ()+doCertifyUserId _cpt CertifyUserIdOptions {..} = do+ signerPasswordsRaw <-+ loadPasswordFiles+ "certify-userid"+ "--with-key-password"+ certifyUserIdKeyPasswordFiles+ let signerPasswords = concatMap passwordRetryCandidates signerPasswordsRaw+ signerTks <-+ concat+ <$> mapM+ (loadCertifySignerTKsFromFile signerPasswords)+ certifyUserIdSignerFiles+ when (null signerTks) $+ failWith+ MissingInput+ "certify-userid: no signer certificate found"+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ certPkts <- decodeOpenPGPInput "standard input" input+ targetTks <-+ runConduitRes $+ CL.sourceList certPkts+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ when (null targetTks) $+ failWith+ MissingInput+ "certify-userid: no certificate found on standard input"+ let targetUserIds = map T.pack certifyUserIds+ requireSelfSig = not certifyUserIdNoRequireSelfSig+ updatedTargets <-+ mapM+ ( \targetTk ->+ addUserIdCertifications+ targetTk+ targetUserIds+ requireSelfSig+ signerTks+ )+ targetTks+ let output = runPut (mapM_ Bin.put updatedTargets)+ armorOutput =+ case certifyUserIdOutputFormat of+ Just "binary" -> output+ _ -> AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]+ BL.putStr armorOutput++loadCertifySignerTKsFromFile+ :: [BL.ByteString] -> String -> IO [TKUnknown]+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)+ .| CC.sinkList+ let fallbackTks = signingFallbackTKs packets+ when (null tks && null fallbackTks) $+ failWith+ MissingInput+ ("certify-userid: no signer key material found in " ++ path)+ mapM+ ( unlockTransferableSecretKeyMaterial+ "certify-userid failed"+ path+ "--with-key-password"+ signerPasswords+ )+ (if null tks then fallbackTks else tks)++addUserIdCertifications+ :: TKUnknown -> [Text] -> Bool -> [TKUnknown] -> IO TKUnknown+addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do+ forM_ targetUserIds $ \targetUserId ->+ case find ((== targetUserId) . fst) (_tkuUIDs targetTk) of+ Nothing ->+ failWith+ CertUserIdNoMatch+ ( "certify-userid: target certificate has no user ID matching "+ ++ T.unpack targetUserId+ )+ Just (_, sigs) ->+ when+ ( requireSelfSig+ && not (any (signatureMatchesSigner targetTk) sigs)+ )+ $ failWith+ CertUserIdNoMatch+ ( "certify-userid: target user ID has no self-signature: "+ ++ T.unpack targetUserId+ )+ newSigs <-+ concat+ <$> forM+ signerTks+ ( \signerTk ->+ forM+ targetUserIds+ ( \targetUserId -> do+ sig <- createUIDCertification targetUserId signerTk+ pure (targetUserId, sig)+ )+ )+ let updateUID (uid, sigs) =+ if uid `elem` targetUserIds+ then (uid, sigs ++ map snd (filter ((== uid) . fst) newSigs))+ else (uid, sigs)+ pure $ targetTk {_tkuUIDs = map updateUID (_tkuUIDs targetTk)}++createUIDCertification+ :: Text -> TKUnknown -> IO SignaturePayload+createUIDCertification targetUserId signerTk = do+ let (signerPkp, mSignerSka) = _tkuKey signerTk+ signerSka <-+ case mSignerSka of+ Just ska -> pure ska+ Nothing ->+ failWith+ KeyCannotCertify+ "certify-userid: signer certificate has no secret key material"+ signingKey <- rsaSigningKey signerSka+ issuer <- issuerSubpacketsFor "certify-userid" signerPkp+ let hashed = [SigSubPacket False (SigCreationTime (_timestamp signerPkp))]+ certification =+ signUserIDwithRSA+ signerPkp+ (UserId targetUserId)+ hashed+ issuer+ signingKey+ case certification of+ Left err ->+ failWith+ BadData+ ("certify-userid: failed to create certification: " ++ show err)+ Right sig -> pure sig++doRevokeKey :: POSIXTime -> RevokeKeyOptions -> IO ()+doRevokeKey _cpt RevokeKeyOptions {..} = do+ keyPasswordsRaw <-+ loadPasswordFiles+ "revoke-key"+ "--with-key-password"+ revokeKeyPasswordFiles+ let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ keyPkts <- decodeOpenPGPInput "standard input" input+ keyTks <-+ runConduitRes $+ CL.sourceList keyPkts+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ when (null keyTks) $+ failWith+ MissingInput+ "revoke-key: no key found on standard input"+ revocationSigPkts <-+ mapM (createKeyRevocation keyPasswords) keyTks+ let output = runPut (mapM_ Bin.put revocationSigPkts)+ BL.putStr $+ if revokeKeyNoArmor+ then output+ else AA.encodeLazy [Armor ArmorSignature [] output]+ where+ createKeyRevocation keyPasswords' keyTk = do+ unlockedTk <-+ unlockTransferableSecretKeyMaterial+ "revoke-key failed"+ "standard input"+ "--with-key-password"+ keyPasswords'+ keyTk+ let (pkp, mSka) = _tkuKey unlockedTk+ ska <-+ case mSka of+ Just s -> pure s+ Nothing ->+ failWith+ KeyCannotCertify+ "revoke-key: key has no secret key material"+ signingKey <- rsaSigningKey ska+ issuer <- issuerSubpacketsFor "revoke-key" pkp+ let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]+ revocation = signKeyRevocationWithRSA pkp hashed issuer signingKey+ case revocation of+ Left err ->+ failWith+ BadData+ ("revoke-key: failed to create revocation: " ++ show err)+ Right sig -> pure (SignaturePkt sig)++doRevokeUserId :: POSIXTime -> RevokeUserIdOptions -> IO ()+doRevokeUserId _cpt RevokeUserIdOptions {..} = do+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ keyPkts <- decodeOpenPGPInput "standard input" input+ keyTks <-+ runConduitRes $+ CL.sourceList keyPkts+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ when (null keyTks) $+ failWith+ MissingInput+ "revoke-userid: no key found on standard input"+ let keyTk = case keyTks of+ (kt : _) -> kt+ _ ->+ error+ "revoke-userid: no key found on standard input (should be caught above)"+ (pkp, mSka) = _tkuKey keyTk+ targetUserId = T.pack revokeUserIdString+ unless (any ((== targetUserId) . fst) (_tkuUIDs keyTk)) $+ failWith+ MissingInput+ ( "revoke-userid: key has no user ID matching "+ ++ revokeUserIdString+ )+ ska <-+ case mSka of+ Just s -> pure s+ Nothing ->+ failWith+ KeyCannotCertify+ "revoke-userid: key has no secret key material"+ signingKey <- rsaSigningKey ska+ issuer <- issuerSubpacketsFor "revoke-userid" pkp+ let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]+ revocation =+ signCertRevocationWithRSA+ pkp+ (UserId targetUserId)+ hashed+ issuer+ signingKey+ case revocation of+ Left err ->+ failWith+ BadData+ ("revoke-userid: failed to create revocation: " ++ show err)+ Right sig -> do+ let revocationSigPkt = SignaturePkt sig+ output = runPut (Bin.put revocationSigPkt)+ BL.putStr $+ if revokeUserIdNoArmor+ then output+ else AA.encodeLazy [Armor ArmorSignature [] output]++doUpdateKey :: POSIXTime -> UpdateKeyOptions -> IO ()+doUpdateKey cpt UpdateKeyOptions {..} = do+ keyPasswordsRaw <-+ loadPasswordFiles+ "update-key"+ "--with-key-password"+ updateKeyPasswordFiles+ let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw+ when updateKeyRevokeDeprecatedKeys $+ hPutStrLn+ stderr+ "Warning: update-key: --revoke-deprecated-keys requested, but no deprecated-key detector is available; proceeding without synthetic revocations."+ stdinInput <-+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ stdinPkts <- decodeOpenPGPInput "stdin" stdinInput+ stdinTks <-+ runConduitRes $+ CL.sourceList stdinPkts+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ when (null stdinTks) $+ failWith+ MissingInput+ "update-key: no key found on standard input"+ updateSourceTks <-+ concat <$> mapM loadVerifyTKsFromFile updateKeyMergeCerts+ when (null updateSourceTks) $+ failWith MissingInput "update-key: no update keys found"+ stdinUnlocked <-+ mapM+ (unlockUpdateKeyMaterial "standard input" keyPasswords)+ stdinTks+ updateUnlocked <-+ mapM+ (unlockUpdateKeyMaterial "update input" keyPasswords)+ updateSourceTks+ let updateTks =+ if updateKeySigningOnly+ then filter (updateKeyHasSigningCapability cpt) updateUnlocked+ else updateUnlocked+ when (updateKeySigningOnly && null updateTks) $+ failWith+ MissingInput+ "update-key: no signing-capable update keys found"+ let updatedTks =+ map+ ( \targetTk ->+ foldl'+ (<>)+ targetTk+ ( selectUpdateMergeInputs+ cpt+ updateKeyNoAddedCapabilities+ targetTk+ updateTks+ )+ )+ stdinUnlocked+ -- Choose armor type based on whether updated key has secret material+ armorType =+ if any hasSecretKeyMaterial updatedTks+ then ArmorPrivateKeyBlock+ else ArmorPublicKeyBlock+ output = runPut (mapM_ Bin.put updatedTks)+ BL.putStr $+ if updateKeyNoArmor+ then output+ else AA.encodeLazy [Armor armorType [] output]++doMergeCerts :: MergeCertsOptions -> IO ()+doMergeCerts MergeCertsOptions {..} = do+ stdinInput <-+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ stdinPkts <- decodeOpenPGPInput "stdin" stdinInput+ stdinTks <-+ runConduitRes $+ CL.sourceList stdinPkts+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ mergeInTks <-+ concat <$> mapM loadVerifyTKsFromFile mergeCertsFiles+ let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks+ output = runPut (mapM_ Bin.put mergedTks)+ BL.putStr $+ if mergeCertsNoArmor || BL.null output+ then output+ else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]++mergeCertificatesForOutput+ :: [TKUnknown] -> [TKUnknown] -> [TKUnknown]+mergeCertificatesForOutput stdinTks mergeInTks =+ map mergeGroup (groupByPrimaryKey stdinTks)+ where+ -- Upstream could expose this as a dedicated helper over TKWithWireRep+ -- so downstreams can keep packet provenance while merging certs.+ mergeGroup (base, rest) =+ let primary = certificatePrimaryFingerprint base+ mergedStdin = foldl' (<>) base rest+ matchingMergeInputs =+ filter ((== primary) . certificatePrimaryFingerprint) mergeInTks+ in foldl' (<>) mergedStdin matchingMergeInputs++groupByPrimaryKey :: [TKUnknown] -> [(TKUnknown, [TKUnknown])]+groupByPrimaryKey [] = []+groupByPrimaryKey (tk : rest) =+ let primary = certificatePrimaryFingerprint tk+ (samePrimary, differentPrimary) =+ partition ((== primary) . certificatePrimaryFingerprint) rest+ in (tk, samePrimary) : groupByPrimaryKey differentPrimary++certificatePrimaryFingerprint :: TKUnknown -> B.ByteString+certificatePrimaryFingerprint =+ BL.toStrict . unFingerprint . fingerprint . fst . _tkuKey++unlockUpdateKeyMaterial+ :: String -> [BL.ByteString] -> TKUnknown -> IO TKUnknown+unlockUpdateKeyMaterial _ [] tk = pure tk+unlockUpdateKeyMaterial source keyPasswords tk =+ unlockTransferableSecretKeyMaterial+ "update-key failed"+ source+ "--with-key-password"+ keyPasswords+ tk++updateKeyHasSigningCapability :: POSIXTime -> TKUnknown -> Bool+updateKeyHasSigningCapability cpt tk =+ any+ ( \funKey ->+ S.null (fkufs funKey) || S.member SignDataKey (fkufs funKey)+ )+ (tkToFunKeysAt cpt tk)++selectUpdateMergeInputs+ :: POSIXTime+ -> Bool+ -> TKUnknown+ -> [TKUnknown]+ -> [TKUnknown]+selectUpdateMergeInputs cpt noAddedCaps targetTk updateTks =+ filteredByCaps+ where+ targetPrimary = certificatePrimaryFingerprint targetTk+ mergeCandidates =+ filter+ ((== targetPrimary) . certificatePrimaryFingerprint)+ updateTks+ targetCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt targetTk))+ addsCapabilities updateTk =+ let updateCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt updateTk))+ in not (S.null (updateCapabilities S.\\ targetCapabilities))+ filteredByCaps =+ if noAddedCaps+ then filter (not . addsCapabilities) mergeCandidates+ else mergeCandidates++soP :: Parser SignOptions+soP =+ SignOptions+ <$> switch (long "armor" <> help "armor the output")+ <*> switch (long "no-armor" <> help "don't armor the output")+ <*> optional+ ( strOption+ ( long "micalg-out"+ <> metavar "MICALG"+ <> help "write MIME micalg parameter value to file"+ )+ )+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking signing key material"+ )+ )+ <*> option+ (eitherReader asTypeReader)+ (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)+ <*> some+ ( strArgument+ ( metavar "KEYS..."+ <> help "paths to at least one secret key, one key per filename"+ )+ )+ where+ astypeHelp =+ helpDoc . Just $+ pretty "what to treat the input as"+ <> softline+ <> list (map (pretty . fst) asTypes)++data SignOptions+ = SignOptions+ { sArmor :: Bool+ , sNoArmor :: Bool+ , sMicalgOut :: Maybe String+ , sKeyPasswords :: [String]+ , sAs :: AsBinaryText+ , sKeyFiles :: [String]+ }++asTypes :: [(String, AsBinaryText)]+asTypes = [("binary", AsBinary), ("text", AsText)]++data AsBinaryText+ = AsBinary+ | AsText+ deriving (Eq)++data InlineSignMode+ = InlineSignAsBinary+ | InlineSignAsText+ | InlineSignAsClearSigned+ deriving (Eq)++data EncryptFor+ = EncryptForAny+ | EncryptForStorage+ | EncryptForCommunications+ deriving (Eq)++asTypeReader :: String -> Either String AsBinaryText+asTypeReader = note "unknown as type" . flip lookup asTypes++encryptForReader :: String -> Either String EncryptFor+encryptForReader "any" = Right EncryptForAny+encryptForReader "storage" = Right EncryptForStorage+encryptForReader "communications" = Right EncryptForCommunications+encryptForReader _ =+ Left+ "encryption purpose must be one of: any, storage, communications"++doSign :: POSIXTime -> SignOptions -> IO ()+doSign pt SignOptions {..} = do+ when (sNoArmor && sArmor) $+ failWith+ IncompatibleOptions+ "sign: --armor and --no-armor are mutually exclusive"+ forM_ sMicalgOut (ensureOutputPathAvailable "sign")+ mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ when (sAs == AsText) $+ ensureUTF8TextInput "sign" (BL.fromChunks mbs)+ forM_+ sMicalgOut+ (\_ -> ensureCanonicalMIMETextInput (BL.fromChunks mbs))+ signingPasswordsRaw <-+ loadPasswordFiles "sign" "--with-key-password" sKeyPasswords+ let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw+ ks <- loadSigningKeys sKeyFiles signingPasswords+ let ts = ThirtyTwoBitTimeStamp (floor pt)+ payload' = BL.fromChunks mbs+ payload = payload'+ processedKeys <- mapM (normalizeSigningKey pt) ks+ let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys+ signingHash =+ selectSigningHash+ (concat perTransferKeySigners)+ []+ legacySigningHashFallbackOrder+ when (any null perTransferKeySigners) $+ failWith+ KeyCannotSign+ "sign: supplied key cannot produce detached signatures"+ signatures <-+ mapM+ (signData sAs ts signingHash payload)+ (concat perTransferKeySigners)+ let output = runPut (mapM_ (Bin.put . SignaturePkt) signatures)+ case sMicalgOut of+ Just outPath ->+ writeFileWithOutputExistsCheck+ "sign"+ outPath+ (renderMicalg signatures)+ Nothing -> pure ()+ BL.putStr $+ if not sArmor && not sNoArmor+ then AA.encodeLazy [Armor ArmorSignature [] output]+ else output+ where+ signData+ :: AsBinaryText+ -> ThirtyTwoBitTimeStamp+ -> HashAlgorithm+ -> BL.ByteString+ -> FunKey+ -> IO SignaturePayload+ signData mode t signHash d k = do+ let st = case mode of+ AsBinary -> BinarySig+ AsText -> CanonicalTextSig+ payload = d+ issuerPackets <- unhashed (fpkp k)+ signWithKey+ "sign"+ (fpkp k)+ st+ signHash+ (hashed (fpkp k) t)+ issuerPackets+ payload+ (fmska k)+ hashed pkp ct =+ [ SigSubPacket False (SigCreationTime ct)+ , SigSubPacket+ False+ ( IssuerFingerprint+ (issuerFingerprintVersionFor pkp)+ (fingerprint pkp)+ )+ ]+ unhashed pkp = issuerSubpacketsFor "sign" pkp+loadSigningKeys :: [String] -> [BL.ByteString] -> IO [TKUnknown]+loadSigningKeys keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles+ where+ loadFromFile path = do+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ packets <- decodeOpenPGPInput path lbs+ tks <-+ runConduitRes $+ CL.sourceList packets+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ let fallbackTks = signingFallbackTKs packets+ when (null tks && null fallbackTks) $+ failWith+ MissingInput+ ("sign: no secret key material found in " ++ path)+ mapM+ (decryptSigningKeyMaterial path keyPasswords)+ (if null tks then fallbackTks else tks)++decryptSigningKeyMaterial+ :: FilePath -> [BL.ByteString] -> TKUnknown -> IO TKUnknown+decryptSigningKeyMaterial path keyPasswords =+ unlockTransferableSecretKeyMaterial+ "sign failed"+ path+ "--with-key-password"+ keyPasswords++unlockTransferableSecretKeyMaterial+ :: String+ -> FilePath+ -> String+ -> [BL.ByteString]+ -> TKUnknown+ -> IO TKUnknown+-- 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'}+ 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+ ska' <-+ unlockSecretAddendum+ context+ path+ passwordOption+ keyPasswords+ pkp+ ska+ pure (SecretSubkeyPkt pkp ska', sigs)+ decryptSub sub = pure sub++unlockSecretAddendum+ :: String+ -> FilePath+ -> String+ -> [BL.ByteString]+ -> SomePKPayload+ -> SKAddendum+ -> IO SKAddendum+unlockSecretAddendum _ _ _ _ _ sk@(SUUnencrypted _ _) = pure sk+unlockSecretAddendum context path passwordOption [] _ _ =+ failWith+ KeyIsProtected+ ( context+ ++ ": encrypted key material in "+ ++ path+ ++ " requires "+ ++ passwordOption+ )+unlockSecretAddendum context path passwordOption keyPasswords pkp sk =+ case tryDecrypt keyPasswords of+ Right decrypted -> pure decrypted+ Left _ ->+ failWith+ KeyIsProtected+ ( context+ ++ ": could not unlock key material in "+ ++ path+ ++ " with provided "+ ++ passwordOption+ ++ " values"+ )+ where+ tryDecrypt [] = Left ()+ tryDecrypt (password : rest) =+ case decryptPrivateKey (pkp, sk) password of+ Left _ -> tryDecrypt rest+ Right decrypted -> Right decrypted++normalizeSigningKey :: POSIXTime -> TKUnknown -> IO TKUnknown+normalizeSigningKey pt tk =+ case processTK (Just pt) tk of+ Left err ->+ failWith+ BadData+ ("sign: invalid signing key material: " ++ show err)+ Right normalized -> pure normalized++signPayloadWithKeys+ :: POSIXTime+ -> AsBinaryText+ -> BL.ByteString+ -> [TKUnknown]+ -> [HashAlgorithm]+ -> [HashAlgorithm]+ -> IO [SignaturePayload]+signPayloadWithKeys pt asMode payload keys recipientHashPrefs fallbackOrder = do+ processedKeys <- mapM (normalizeSigningKey pt) keys+ let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys+ signingHash =+ selectSigningHash+ (concat perTransferKeySigners)+ recipientHashPrefs+ fallbackOrder+ when (any null perTransferKeySigners) $+ failWith+ KeyCannotSign+ "encrypt: supplied key cannot produce signatures"+ mapM+ (signData asMode ts signingHash payload)+ (concat perTransferKeySigners)+ where+ ts = ThirtyTwoBitTimeStamp (floor pt)+ signData+ :: AsBinaryText+ -> ThirtyTwoBitTimeStamp+ -> HashAlgorithm+ -> BL.ByteString+ -> FunKey+ -> IO SignaturePayload+ signData mode t signHash d' k = do+ let st = case mode of+ AsBinary -> BinarySig+ AsText -> CanonicalTextSig+ payload' = d'+ issuerPackets <- unhashed (fpkp k)+ signWithKey+ "encrypt"+ (fpkp k)+ st+ signHash+ (hashed (fpkp k) t)+ issuerPackets+ payload'+ (fmska k)+ hashed pkp ct =+ [ SigSubPacket False (SigCreationTime ct)+ , SigSubPacket+ False+ ( IssuerFingerprint+ (issuerFingerprintVersionFor pkp)+ (fingerprint pkp)+ )+ ]+ unhashed pkp = issuerSubpacketsFor "encrypt" pkp++signingCapableFunKeys :: POSIXTime -> TKUnknown -> [FunKey]+signingCapableFunKeys pt =+ filter canSign . tkToFunKeysAt pt+ where+ canSign k =+ canSignDataUsage (fkufs k)+ && case fmska k of+ Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True+ Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True+ Just (SUUnencrypted (UnknownSKey _) _) ->+ isEd25519PKA (_pkalgo (fpkp k))+ || isEdDSAPKA (_pkalgo (fpkp k))+ || isEd448PKA (_pkalgo (fpkp k))+ _ -> False+ 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 = signingCapableFunKeys++{- | Algorithm-dispatching signature helper used by all sign paths.+Supports RSA (v4), Ed25519 (v4), and Ed448 (v4).+-}+signWithKey+ :: String+ -- ^ context for error messages+ -> SomePKPayload+ -> SigType+ -> HashAlgorithm+ -> [SigSubPacket]+ -- ^ hashed subpackets+ -> [SigSubPacket]+ -- ^ unhashed subpackets+ -> BL.ByteString+ -- ^ payload to sign+ -> Maybe SKAddendum+ -> IO SignaturePayload+signWithKey ctx signerPKP st signHash hsd usd payload mska =+ case mska of+ Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) ->+ validateRSASigningKeySize ctx signerPKP+ >> if _keyVersion signerPKP == V6+ then signRSAWithV6Salt (k {RSA.private_p = 0, RSA.private_q = 0})+ else+ signWithRSABuilder+ signHash+ (k {RSA.private_p = 0, RSA.private_q = 0})+ Just (SUUnencrypted (EdDSAPrivateKey Ed25519 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+ Just (SUUnencrypted (EdDSAPrivateKey Ed448 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+ Just (SUUnencrypted (UnknownSKey rawBytes) _) ->+ case () of+ _+ | isEd25519PKA (_pkalgo signerPKP) ->+ do+ normalized <- normalizeUnknownSecretForEdDSA ctx 32 rawBytes+ case eitherCryptoError (Ed25519.secretKey normalized) 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+ | isEd448PKA (_pkalgo signerPKP) ->+ do+ normalized <- normalizeUnknownSecretForEdDSA ctx 57 rawBytes+ case eitherCryptoError (Ed448.secretKey normalized) 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+ _ ->+ failWith+ UnsupportedAsymmetricAlgo+ ( ctx+ ++ " failed: unsupported unknown signing key for algorithm "+ ++ show (_pkalgo signerPKP)+ )+ _ ->+ failWith+ BadData+ (ctx ++ " failed: unsupported or encrypted signing key")+ where+ signEd25519 sk =+ signWithV6Salt+ (\salt -> signDataWithEd25519V6 st salt sk hsd usd payload)+ signEd448 sk =+ signWithV6Salt+ (\salt -> signDataWithEd448V6 st salt sk hsd usd payload)+ signRSAWithV6Salt privateKey =+ signWithV6Salt+ (\salt -> signDataWithRSAV6 st salt privateKey hsd usd payload)+ signWithV6Salt signer = go [32, 64, 16, 20, 28, 48] []+ where+ go [] _ =+ failWith+ BadData+ (ctx ++ " failed: unable to construct a valid v6 signature salt")+ go (n : rest) tried = do+ bytes <- getRandomBytes n+ case signer (SignatureSalt (BL.fromStrict bytes)) of+ Right sig -> pure sig+ Left (SignV6SaltSizeMismatch _ expected _) ->+ let expectedLen = fromIntegral expected+ in if expectedLen `elem` tried+ then+ failWith+ BadData+ (ctx ++ " failed: unable to resolve v6 signature salt size")+ else go (expectedLen : rest) (expectedLen : tried)+ Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)+ signWithRSABuilder hashToUse privateKey =+ let builder =+ SP.addUnhashedSubs+ (SubpacketList usd)+ ( SP.addHashedSubs+ (SubpacketList hsd)+ (SP.sigBuilderInit st hashToUse)+ )+ in case signDataWithRSABuilder builder privateKey payload of+ Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)+ Right sig -> pure sig++normalizeUnknownSecretForEdDSA+ :: String -> Int -> BL.ByteString -> IO B.ByteString+normalizeUnknownSecretForEdDSA ctx expectedLen rawLbs+ | B.length raw == expectedLen = pure raw+ | B.length raw >= 2 =+ let bits =+ (fromIntegral (B.index raw 0) `shiftL` 8)+ .|. fromIntegral (B.index raw 1)+ mpiBytes = (bits + 7) `div` 8+ payload = B.drop 2 raw+ in if B.length payload == mpiBytes && mpiBytes <= expectedLen+ then pure (i2ospOf_ expectedLen (os2ip payload))+ else bad+ | otherwise = bad+ where+ raw = BL.toStrict rawLbs+ bad =+ failWith+ BadData+ ( ctx+ ++ " failed: unsupported EdDSA secret key encoding (length="+ ++ show (B.length raw)+ ++ ")"+ )++validateRSASigningKeySize :: String -> SomePKPayload -> IO ()+validateRSASigningKeySize ctx signerPKP =+ case pubkeySize (_pubkey signerPKP) of+ Right bits+ | bits < 2048 ->+ failWith+ KeyCannotSign+ ( ctx+ ++ " failed: RSA signing keys smaller than 2048 bits are not supported"+ )+ | otherwise -> pure ()+ Left err ->+ failWith+ BadData+ (ctx ++ " failed: unable to determine RSA key size: " ++ err)++-- FIXME: clean this up+isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool+isEd25519PKA pka = fromFVal pka == 27+isEdDSAPKA pka = fromFVal pka == 22+isEd448PKA pka = fromFVal pka == 28++selectSigningHash+ :: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm+selectSigningHash signerKeys recipientHashPrefs fallbackOrder =+ fromMaybe+ SHA512+ (find (hashSupportedByAllSigners signerKeys) candidateOrder)+ where+ requestedPrefs =+ if null recipientHashPrefs+ then signerPrefs+ else recipientHashPrefs+ signerPrefs = concatMap fpreferredHashes signerKeys+ filteredRequested = filter (hashSupportedByAllSigners signerKeys) requestedPrefs+ filteredSignerPrefs = filter (hashSupportedByAllSigners signerKeys) signerPrefs+ candidateOrder = filteredRequested ++ filteredSignerPrefs ++ fallbackOrder++legacySigningHashFallbackOrder :: [HashAlgorithm]+legacySigningHashFallbackOrder = [SHA512, SHA384, SHA256, SHA224]++rfc9580SigningHashFallbackOrder :: [HashAlgorithm]+rfc9580SigningHashFallbackOrder = [SHA3_512, SHA3_256, SHA512, SHA384, SHA256, SHA224]++hashSupportedByAllSigners :: [FunKey] -> HashAlgorithm -> Bool+hashSupportedByAllSigners signers ha =+ not (isDeprecatedHashAlgorithm ha)+ && all (`signerSupportsHashAlgorithm` ha) signers++signerSupportsHashAlgorithm :: FunKey -> HashAlgorithm -> Bool+signerSupportsHashAlgorithm signer ha =+ not (isDeprecatedHashAlgorithm ha)+ && case _pkalgo (fpkp signer) of+ RSA -> rsaPKCS15SupportedHash ha+ DeprecatedRSASignOnly -> rsaPKCS15SupportedHash ha+ DeprecatedRSAEncryptOnly -> rsaPKCS15SupportedHash ha+ _ -> not (isOtherHashAlgorithm ha)++rsaPKCS15SupportedHash :: HashAlgorithm -> Bool+rsaPKCS15SupportedHash SHA224 = True+rsaPKCS15SupportedHash SHA256 = True+rsaPKCS15SupportedHash SHA384 = True+rsaPKCS15SupportedHash SHA512 = True+rsaPKCS15SupportedHash _ = False++isDeprecatedHashAlgorithm :: HashAlgorithm -> Bool+isDeprecatedHashAlgorithm DeprecatedMD5 = True+isDeprecatedHashAlgorithm SHA1 = True+isDeprecatedHashAlgorithm RIPEMD160 = True+isDeprecatedHashAlgorithm _ = False++isOtherHashAlgorithm :: HashAlgorithm -> Bool+isOtherHashAlgorithm (OtherHA _) = True+isOtherHashAlgorithm _ = False++hashAlgorithmHeaderName :: HashAlgorithm -> String+hashAlgorithmHeaderName DeprecatedMD5 = "MD5"+hashAlgorithmHeaderName SHA1 = "SHA1"+hashAlgorithmHeaderName RIPEMD160 = "RIPEMD160"+hashAlgorithmHeaderName SHA224 = "SHA224"+hashAlgorithmHeaderName SHA256 = "SHA256"+hashAlgorithmHeaderName SHA384 = "SHA384"+hashAlgorithmHeaderName SHA512 = "SHA512"+hashAlgorithmHeaderName SHA3_256 = "SHA3-256"+hashAlgorithmHeaderName SHA3_512 = "SHA3-512"+hashAlgorithmHeaderName (OtherHA _) = "SHA512"++ensureCanonicalMIMETextInput :: BL.ByteString -> IO ()+ensureCanonicalMIMETextInput lbs = do+ let bs = BL.toStrict lbs+ when (B.any (> 0x7f) bs) $+ failWith+ ExpectedText+ "sign: --micalg-out requires canonical 7-bit text data on standard input"+ case TE.decodeUtf8' bs of+ Left _ ->+ failWith+ ExpectedText+ "sign: --micalg-out requires UTF-8 text data on standard input"+ Right _ -> pure ()+ when (not (canonicalCRLFLineEndings bs)) $+ failWith+ ExpectedText+ "sign: --micalg-out requires CRLF line endings on standard input"+ when (hasTrailingLineWhitespace bs) $+ failWith+ ExpectedText+ "sign: --micalg-out requires no trailing line whitespace on standard input"+ where+ canonicalCRLFLineEndings bytes = go (B.unpack bytes)+ where+ go [] = True+ go [13] = False+ go (13 : 10 : rest) = go rest+ go (13 : _) = False+ go (10 : _) = False+ go (_ : rest) = go rest+ hasTrailingLineWhitespace bytes =+ endsWithWhitespace bytes+ || trailingWhitespaceBeforeCRLF (B.unpack bytes)+ endsWithWhitespace bytes =+ case B.unsnoc bytes of+ Just (_, c) -> c == 32 || c == 9+ Nothing -> False+ trailingWhitespaceBeforeCRLF (a : 13 : 10 : rest)+ | a == 32 || a == 9 = True+ | otherwise = trailingWhitespaceBeforeCRLF (13 : 10 : rest)+ trailingWhitespaceBeforeCRLF (_ : rest) = trailingWhitespaceBeforeCRLF rest+ trailingWhitespaceBeforeCRLF _ = False++ensureUTF8TextInput :: String -> BL.ByteString -> IO ()+ensureUTF8TextInput subcommand lbs =+ case TE.decodeUtf8' (BL.toStrict lbs) of+ Left _ ->+ failWith+ ExpectedText+ (subcommand ++ ": --as=text requires UTF-8 text on standard input")+ Right _ -> pure ()++renderMicalg :: [SignaturePayload] -> String+renderMicalg signatures =+ case nub (mapMaybe signatureMicalg signatures) of+ [micalg] -> micalg+ _ -> ""+ where+ signatureMicalg (SigV4 _ _ ha _ _ _ _) = hashAlgorithmMicalg ha+ signatureMicalg _ = Nothing+ hashAlgorithmMicalg DeprecatedMD5 = Just "pgp-md5"+ hashAlgorithmMicalg SHA1 = Just "pgp-sha1"+ hashAlgorithmMicalg RIPEMD160 = Just "pgp-ripemd160"+ hashAlgorithmMicalg SHA224 = Just "pgp-sha224"+ hashAlgorithmMicalg SHA256 = Just "pgp-sha256"+ hashAlgorithmMicalg SHA384 = Just "pgp-sha384"+ hashAlgorithmMicalg SHA512 = Just "pgp-sha512"+ hashAlgorithmMicalg SHA3_256 = Just "pgp-sha3-256"+ hashAlgorithmMicalg SHA3_512 = Just "pgp-sha3-512"+ hashAlgorithmMicalg (OtherHA _) = Nothing++signingFallbackTKs :: [Pkt] -> [TKUnknown]+signingFallbackTKs packets =+ [ TKUnknown (pkp, Just ska) [] [] [] []+ | SecretKeyPkt pkp ska <- packets+ ]++data FunKey+ = FunKey+ { fpkp :: SomePKPayload+ , fmska :: Maybe SKAddendum+ , fkufs :: S.Set KeyFlag+ , fpreferredHashes :: [HashAlgorithm]+ , fpreferredSymmetricAlgorithms :: [SymmetricAlgorithm]+ , fsupportsSEIPDv2 :: Bool+ }+ deriving (Show)++tkToFunKeysAt :: POSIXTime -> TKUnknown -> [FunKey]+tkToFunKeysAt pt tk@(TKUnknown (pkp, mska) _ uids _ subs) =+ catMaybes (mainKey : map extract subs)+ where+ mainPreferredHashes = effectiveHashPreferencesAt pt tk+ mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt tk+ mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt tk+ mainKey =+ Just+ ( FunKey+ pkp+ mska+ (fromMaybe S.empty (grabASig uids >>= sig2KUFs))+ mainPreferredHashes+ mainPreferredSymmetricAlgorithms+ mainSupportsSEIPDv2+ )+ sig2KUFs = getHasheds >=> find isKUF >=> getKUFs+ grabASig :: [(a, [b])] -> Maybe b+ grabASig = (listToMaybe >=> listToMaybe) . map snd -- FIXME: this should grab the "best" sig+ getHasheds :: SignaturePayload -> Maybe [SigSubPacket]+ getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds+ getHasheds (SigV6 _ _ _ _ hasheds _ _ _) = Just hasheds+ getHasheds _ = Nothing+ getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag)+ getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs+ getKUFs _ = Nothing+ extract ((SecretSubkeyPkt spkp sska), sigs) =+ return+ ( FunKey+ spkp+ (Just sska)+ (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))+ mainPreferredHashes+ mainPreferredSymmetricAlgorithms+ mainSupportsSEIPDv2+ )+ extract ((PublicSubkeyPkt spkp), sigs) =+ return+ ( FunKey+ spkp+ Nothing+ (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))+ mainPreferredHashes+ mainPreferredSymmetricAlgorithms+ mainSupportsSEIPDv2+ )+ extract _ = Nothing++effectiveHashPreferencesAt+ :: POSIXTime -> TKUnknown -> [HashAlgorithm]+effectiveHashPreferencesAt pt tk =+ concatMap toHashes $+ fromMaybe+ []+ ( effectiveKeyPreferencesAt+ (posixSecondsToUTCTime (realToFrac pt))+ tk+ )+ where+ toHashes (PreferredHashAlgorithms hashes) = hashes+ toHashes _ = []++effectiveSymmetricPreferencesAt+ :: POSIXTime -> TKUnknown -> [SymmetricAlgorithm]+effectiveSymmetricPreferencesAt pt tk =+ concatMap toSymmetricAlgorithms $+ fromMaybe+ []+ ( effectiveKeyPreferencesAt+ (posixSecondsToUTCTime (realToFrac pt))+ tk+ )+ where+ toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms+ toSymmetricAlgorithms _ = []++effectiveSEIPDv2SupportAt :: POSIXTime -> TKUnknown -> Bool+effectiveSEIPDv2SupportAt pt tk =+ any supportsSEIPDv2Flag $+ concatMap toFeatureFlags $+ fromMaybe+ []+ ( effectiveKeyPreferencesAt+ (posixSecondsToUTCTime (realToFrac pt))+ tk+ )+ where+ toFeatureFlags (Features flags) = S.toList flags+ toFeatureFlags _ = []+ supportsSEIPDv2Flag FeatureSEIPDv2 = True+ supportsSEIPDv2Flag _ = False++-- SOP Handler Stubs+-- These implement the stateless OpenPGP CLI commands per draft-16++doVerify :: POSIXTime -> VerifyOptions -> IO ()+doVerify cpt VerifyOptions {..} = do+ (krs, verifyTks) <- loadVerifyContext cpt verifyCertFiles+ signatureInput <-+ runConduitRes $ CC.sourceFile verifySigFile .| CC.sinkLazy+ sigPkts <- decodeLikeSignaturePackets signatureInput+ let sigs = V.fromList (filter isDetachedVerificationSignaturePkt sigPkts)+ blob <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ upperBound <- verificationUpperBound cpt verifyNotAfter+ lowerBound <- verificationLowerBound cpt verifyNotBefore+ let sigsWithoutUnsupportedCritical =+ V.filter+ (not . detachedSignatureHasUnsupportedCriticalSubpackets)+ sigs+ binaryVerifications <-+ verifyWithLiteralData+ BinaryData+ blob+ sigsWithoutUnsupportedCritical+ krs+ upperBound+ verifications <-+ if any isRight binaryVerifications+ then pure binaryVerifications+ else+ verifyWithLiteralData+ TextData+ blob+ sigsWithoutUnsupportedCritical+ krs+ upperBound+ let decodedVerifications = map (first show) verifications+ signerPolicyAdjusted =+ map+ (enforceVerificationSignerPolicy cpt verifyTks)+ decodedVerifications+ let filtered =+ filterByVerificationBounds+ lowerBound+ upperBound+ signerPolicyAdjusted+ policyFiltered =+ filter (not . verificationResultUsesDeprecatedHash) filtered+ mapM_+ (putStrLn . renderSOPVerificationLine verifyTks)+ (rights policyFiltered)+ case any isRight policyFiltered of+ True -> exitSuccess+ _ -> failWith NoSignature "No acceptable signatures found"+ where+ decodeLikeSignaturePackets lbs = do+ decodedArmors <-+ decodeAsciiArmorInput+ ("signature input in " ++ verifySigFile)+ lbs+ case decodedArmors of+ Just armors ->+ case firstBy isDetachedSignatureArmor armors of+ Just (Armor ArmorSignature _ bs) ->+ parseOpenPGPPackets+ ("signature input in " ++ verifySigFile)+ (BL.fromStrict (BLC8.toStrict bs))+ _ ->+ case firstBy isDetachedSignatureUnsupportedArmor armors of+ Just (ClearSigned _ _ _) ->+ failWith+ BadData+ ("verify: expected detached signatures in " ++ verifySigFile)+ Just (Armor _ _ _) ->+ failWith+ BadData+ ("verify: expected signature armor in " ++ verifySigFile)+ _ ->+ parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs+ Nothing ->+ parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs+ verifyWithLiteralData format payload sigs keyring upperBound =+ runConduitRes $+ CC.yieldMany+ (V.cons (LiteralDataPkt format mempty 0 payload) sigs)+ .| conduitVerify keyring upperBound+ .| CC.sinkList++detachedSignatureHasUnsupportedCriticalSubpackets :: Pkt -> Bool+detachedSignatureHasUnsupportedCriticalSubpackets (SignaturePkt sig) =+ any criticalUnsupported (signatureHashedSubpackets sig)+ where+ criticalUnsupported (SigSubPacket True (OtherSigSub _ _)) = True+ criticalUnsupported (SigSubPacket True (UserDefinedSigSub _ _)) = True+ criticalUnsupported (SigSubPacket True (NotationData _ _ _)) = True+ criticalUnsupported _ = False+detachedSignatureHasUnsupportedCriticalSubpackets _ = False++signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]+signatureHashedSubpackets (SigV4 _ _ _ hashed _ _ _) = hashed+signatureHashedSubpackets (SigV6 _ _ _ _ hashed _ _ _) = hashed+signatureHashedSubpackets _ = []++verificationResultUsesDeprecatedHash+ :: Either String Verification -> Bool+verificationResultUsesDeprecatedHash (Right verification) =+ verificationUsesDeprecatedHash verification+verificationResultUsesDeprecatedHash _ = False++verificationUsesDeprecatedHash :: Verification -> Bool+verificationUsesDeprecatedHash (Verification _ sigPayload _) =+ isDeprecatedHashAlgorithm (signatureHashAlgorithm sigPayload)++signatureHashAlgorithm :: SignaturePayload -> HashAlgorithm+signatureHashAlgorithm (SigV3 _ _ _ _ ha _ _) = ha+signatureHashAlgorithm (SigV4 _ _ ha _ _ _ _) = ha+signatureHashAlgorithm (SigV6 _ _ ha _ _ _ _ _) = ha+signatureHashAlgorithm (SigVOther _ _) = OtherHA 0++enforceVerificationSignerPolicy+ :: POSIXTime+ -> [TKUnknown]+ -> Either String Verification+ -> Either String Verification+enforceVerificationSignerPolicy _ _ result@(Left _) = result+enforceVerificationSignerPolicy cpt verifyTks result@(Right verification)+ | signerAllowed = result+ | otherwise =+ Left+ "verification failed: signer key is not valid for signing at signature creation time"+ where+ signerAllowed = any signerMatchesProcessed verifyTks+ signerFp = fingerprint (_verificationSigner verification)+ verificationTimePosix =+ maybe+ cpt+ (realToFrac . utcTimeToPOSIXSeconds)+ (signatureCreationTime (_verificationSignature verification))+ verificationTime = posixSecondsToUTCTime verificationTimePosix+ signerMatchesProcessed tk+ | not (keyMatchesFingerprint True tk signerFp) = False+ | keyMatchesFingerprint False tk signerFp = True+ | otherwise =+ any (subkeyAllowsSigning verificationTime signerFp) (_tkuSubs tk)++subkeyAllowsSigning+ :: UTCTime -> Fingerprint -> (Pkt, [SignaturePayload]) -> Bool+subkeyAllowsSigning t signerFp (pkt, sigs) =+ case subkeyPayload pkt of+ Just pkp+ | fingerprint pkp == signerFp ->+ any+ (bindingSignatureAllowsSigning t)+ (filter isSKBindingSig sigs)+ _ -> False+ where+ subkeyPayload (PublicSubkeyPkt pkp) = Just pkp+ subkeyPayload (SecretSubkeyPkt pkp _) = Just pkp+ subkeyPayload _ = Nothing++bindingSignatureAllowsSigning+ :: UTCTime -> SignaturePayload -> Bool+bindingSignatureAllowsSigning t sig =+ allowsSigning && hasValidBacksig+ where+ allowsSigning =+ let flagSets = signatureKeyFlagSets sig+ in null flagSets || any (S.member SignDataKey) flagSets+ hasValidBacksig =+ any+ ( \embedded ->+ isPKBindingSig embedded+ && not (signatureExpiredAt t embedded)+ )+ (signatureEmbeddedSignatures sig)++signatureEmbeddedSignatures+ :: SignaturePayload -> [SignaturePayload]+signatureEmbeddedSignatures sig =+ [ embedded+ | SigSubPacket _ (EmbeddedSignature embedded) <-+ signatureSubpackets sig+ ]++signatureKeyFlagSets :: SignaturePayload -> [S.Set KeyFlag]+signatureKeyFlagSets sig =+ [ flags+ | SigSubPacket _ (KeyFlags flags) <- signatureSubpackets sig+ ]++signatureExpiredAt :: UTCTime -> SignaturePayload -> Bool+signatureExpiredAt t sig =+ case (signatureCreationTime sig, signatureValiditySeconds sig) of+ (Just created, Just validitySeconds) ->+ utcTimeToPOSIXSeconds t+ >= utcTimeToPOSIXSeconds created + fromIntegral validitySeconds+ _ -> False++signatureValiditySeconds :: SignaturePayload -> Maybe Integer+signatureValiditySeconds sig =+ listToMaybe+ [ fromIntegral secs+ | SigSubPacket _ (SigExpirationTime (ThirtyTwoBitDuration secs)) <-+ signatureSubpackets sig+ ]+verificationUpperBound+ :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)+verificationUpperBound cpt Nothing = return (Just (posixSecondsToUTCTime cpt))+verificationUpperBound _ (Just "-") = return Nothing+verificationUpperBound cpt (Just "now") =+ return (Just (posixSecondsToUTCTime cpt))+verificationUpperBound _ (Just s) = do+ let m = iso8601ParseM s :: Maybe UTCTime+ case m of+ Just t -> return (Just t)+ Nothing -> failWith BadData ("Invalid DATE value: " ++ s)++verificationLowerBound+ :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)+verificationLowerBound _ Nothing = return Nothing+verificationLowerBound _ (Just "-") = return Nothing+verificationLowerBound cpt (Just "now") =+ return (Just (posixSecondsToUTCTime cpt))+verificationLowerBound _ (Just s) = do+ let m = iso8601ParseM s :: Maybe UTCTime+ case m of+ Just t -> return (Just t)+ Nothing -> failWith BadData ("Invalid DATE value: " ++ s)++filterByVerificationBounds+ :: Maybe UTCTime+ -> Maybe UTCTime+ -> [Either String Verification]+ -> [Either String Verification]+filterByVerificationBounds lower upper = map (>>= ensureBounds)+ where+ ensureBounds v =+ case signatureCreationTime (_verificationSignature v) of+ Nothing ->+ Left "verification failed: signature is missing creation time"+ Just sigTime+ | Just upperBound <- upper+ , sigTime > upperBound ->+ Left+ "verification failed: signature created after --not-after bound"+ | Just lowerBound <- lower+ , sigTime < lowerBound ->+ Left+ "verification failed: signature created before --not-before bound"+ | otherwise -> Right v++signatureCreationTime :: SignaturePayload -> Maybe UTCTime+signatureCreationTime (SigV4 _ _ _ hashed _ _ _) =+ firstCreationTime hashed+signatureCreationTime (SigV6 _ _ _ _ hashed _ _ _) =+ firstCreationTime hashed+signatureCreationTime _ = Nothing++firstCreationTime :: [SigSubPacket] -> Maybe UTCTime+firstCreationTime = listToMaybe . mapMaybe getCreation+ where+ getCreation (SigSubPacket _ (SigCreationTime (ThirtyTwoBitTimeStamp ts))) =+ Just (posixSecondsToUTCTime (fromIntegral ts))+ getCreation _ = Nothing++isDetachedVerificationSignaturePkt :: Pkt -> Bool+isDetachedVerificationSignaturePkt (SignaturePkt (SigV4 sigType _ _ _ _ _ _)) =+ sigType == BinarySig || sigType == CanonicalTextSig+isDetachedVerificationSignaturePkt (SignaturePkt (SigV6 sigType _ _ _ _ _ _ _)) =+ sigType == BinarySig || sigType == CanonicalTextSig+isDetachedVerificationSignaturePkt _ = False++doInlineVerify :: POSIXTime -> InlineVerifyOptions -> IO ()+doInlineVerify cpt InlineVerifyOptions {..} = do+ (krs, verifyTks) <- loadVerifyContext cpt inlineCertFiles+ signedInput <-+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ upperBound <- verificationUpperBound cpt inlineNotAfter+ lowerBound <- verificationLowerBound cpt inlineNotBefore+ (allowTrailingSignatures, parsedPackets) <-+ inlineVerifyPackets signedInput+ packets <-+ normalizeInlineVerifyPackets+ allowTrailingSignatures+ parsedPackets+ let verifications =+ map (first show) (verifyPacketsBatch krs upperBound packets)+ filtered = filterByVerificationBounds lowerBound upperBound verifications+ successLines = map (renderSOPVerificationLine verifyTks) (rights filtered)+ renderedOut =+ if null successLines+ then ""+ else unlines successLines+ case verificationsOut of+ Just outPath ->+ writeFileWithOutputExistsCheck+ "inline-verify"+ outPath+ renderedOut+ Nothing -> pure ()+ case any isRight filtered of+ True ->+ extractSingleLiteralPayload packets >>= BL.putStr >> exitSuccess+ _ -> failWith NoSignature "No acceptable signatures found"+ where+ inlineVerifyPackets :: BL.ByteString -> IO (Bool, [Pkt])+ inlineVerifyPackets lbs = do+ decodedArmors <- decodeAsciiArmorInput "inline-verify input" lbs+ case decodedArmors of+ Just armors ->+ case listToMaybe (filter isInlineVerifyCandidateArmor armors) of+ Just (Armor ArmorMessage _ bs) -> do+ let packetBytes = BL.fromStrict (BLC8.toStrict bs)+ packets <-+ parseInlineVerifyMessagePackets+ "inline-verify armored message"+ packetBytes+ pure (False, packets)+ Just (ClearSigned headers cleartext signatureArmor) -> do+ validateClearSignedEnvelopeBounds lbs+ validateClearSignedHeaders headers+ sigPkts <- clearSignedSignaturePackets signatureArmor+ pure+ ( True+ , LiteralDataPkt+ TextData+ BL.empty+ 0+ (BL.fromStrict (BLC8.toStrict cleartext))+ : sigPkts+ )+ Just (Armor _ _ _) ->+ failWith+ BadData+ "inline-verify expects an armored OpenPGP message or cleartext signed message"+ Nothing -> do+ packets <-+ parseInlineVerifyMessagePackets "inline-verify input" lbs+ pure (False, packets)+ Nothing -> do+ packets <-+ parseInlineVerifyMessagePackets "inline-verify input" lbs+ pure (False, packets)++ parseInlineVerifyMessagePackets+ :: String -> BL.ByteString -> IO [Pkt]+ parseInlineVerifyMessagePackets context packetBytes = do+ rawPkts <- parseRawOpenPGPPackets context packetBytes+ when (any compressedPacketParseFailed rawPkts) $+ failWith+ BadData+ "inline-verify input has malformed compressed packet data"+ when (any compressedPacketIsEmpty rawPkts) $+ failWith+ BadData+ "inline-verify input has empty compressed packet data"+ expanded <- expandPacketsStrict context rawPkts+ when+ (any isMarkerPacket expanded && any isCompressedPacket rawPkts)+ $ failWith+ BadData+ "inline-verify input has malformed compressed packet sequence"+ pure expanded++ expandPacketsStrict :: String -> [Pkt] -> IO [Pkt]+ expandPacketsStrict context =+ fmap concat . mapM expandPacket+ where+ expandPacket pkt =+ case decompressPkt pkt of+ Left err ->+ failWith+ BadData+ ( context+ ++ ": failed to parse compressed packet: "+ ++ renderCompressionError err+ )+ Right packets -> pure packets++isInlineVerifyCandidateArmor :: Armor -> Bool+isInlineVerifyCandidateArmor (Armor ArmorMessage _ _) = True+isInlineVerifyCandidateArmor ClearSigned {} = True+isInlineVerifyCandidateArmor _ = False++clearSignedSignaturePackets :: Armor -> IO [Pkt]+clearSignedSignaturePackets (Armor ArmorSignature _ sigbs) =+ let sigPktsSource =+ parseOpenPGPPackets+ "cleartext signature block"+ (BL.fromStrict (BLC8.toStrict sigbs))+ in do+ parsed <- sigPktsSource+ let sigPkts = filter isSignaturePkt parsed+ if null sigPkts+ then+ failWith+ BadData+ "cleartext signature block has no signature packets"+ else return sigPkts+clearSignedSignaturePackets (Armor _ _ _) =+ failWith+ BadData+ "cleartext signed message does not contain an armored signature block"+clearSignedSignaturePackets (ClearSigned _ _ inner) =+ clearSignedSignaturePackets inner++isSignaturePkt :: Pkt -> Bool+isSignaturePkt SignaturePkt {} = True+isSignaturePkt _ = False++normalizeInlineVerifyPackets :: Bool -> [Pkt] -> IO [Pkt]+normalizeInlineVerifyPackets allowTrailingSignatures pkts+ | any isBrokenPacket relevantPkts =+ failWith+ BadData+ "inline-verify input contains malformed packet encoding"+ | any (not . isInlineVerificationPacket) filteredPkts =+ failWith+ BadData+ "inline-verify input contains unsupported packet types"+ | otherwise =+ case ( [pkt | pkt@LiteralDataPkt {} <- filteredPkts]+ , [pkt | pkt@SignaturePkt {} <- filteredPkts]+ ) of+ ([], _) ->+ failWith+ BadData+ "inline-verify input has no literal message payload"+ ([_], []) ->+ failWith+ BadData+ "inline-verify input has no signatures"+ ([lit], sigs)+ | not hasOnePass+ && ( null signaturePositions+ || not (all (< literalIndex) signaturePositions)+ )+ && ( not allowTrailingSignatures+ || not (all (> literalIndex) signaturePositions)+ ) ->+ failWith+ BadData+ "inline-verify input has malformed signed-message packet order"+ | otherwise -> pure (lit : sigs)+ (_, _) ->+ failWith+ BadData+ "inline-verify input contains multiple literal payloads"+ where+ relevantPkts = filter (not . isMarkerPacket) pkts+ filteredPkts = filter (not . isIgnorableInlineVerifyPacket) relevantPkts+ packetPositions = zip [0 :: Int ..] filteredPkts+ signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]+ onePassPositions = [i | (i, OnePassSignaturePkt {}) <- packetPositions]+ literalPositions = [i | (i, LiteralDataPkt {}) <- packetPositions]+ hasOnePass = not (null onePassPositions)+ literalIndex =+ case literalPositions of+ (i : _) -> i+ [] -> -1+ isBrokenPacket BrokenPacketPkt {} = True+ isBrokenPacket _ = False++isIgnorableInlineVerifyPacket :: Pkt -> Bool+isIgnorableInlineVerifyPacket (OtherPacketPkt tag _) = tag >= 40+isIgnorableInlineVerifyPacket _ = False++isInlineVerificationPacket :: Pkt -> Bool+isInlineVerificationPacket LiteralDataPkt {} = True+isInlineVerificationPacket SignaturePkt {} = True+isInlineVerificationPacket OnePassSignaturePkt {} = True+isInlineVerificationPacket (OtherPacketPkt tag _) = tag >= 40+isInlineVerificationPacket BrokenPacketPkt {} = False+isInlineVerificationPacket _ = False++doEncrypt :: POSIXTime -> EncryptOptions -> IO ()+doEncrypt cpt EncryptOptions {..} = do+ when (encNoArmor && encArmor) $+ failWith+ IncompatibleOptions+ "encrypt: --armor and --no-armor are mutually exclusive"+ payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ when (encAs == AsText) $+ ensureUTF8TextInput "encrypt" payload+ when encWithoutIntegrityCheck $+ failWith+ UnsupportedOption+ "encrypt: --without-integrity-check is not supported by this backend"+ symmetricPasswordsRaw <-+ loadPasswordFiles "encrypt" "--with-password" encPasswords+ symmetricPasswords <-+ mapM+ (normalizeHumanReadablePassword "encrypt" "--with-password")+ symmetricPasswordsRaw+ signingKeyPasswordsRaw <-+ loadPasswordFiles+ "encrypt"+ "--with-key-password"+ encSignWithKeyPasswords+ let signingKeyPasswords = concatMap passwordRetryCandidates signingKeyPasswordsRaw+ encryptProfile <- parseEncryptProfile encProfile+ when+ (not (null encRecipientCerts) && not (null symmetricPasswords))+ $ failWith+ UnsupportedOption+ "encrypt: combining recipient certificates with --with-password is not yet supported"+ recipientKeys <-+ if null encRecipientCerts+ then pure []+ else loadEncryptRecipients cpt encFor encRecipientCerts+ recipientHashPrefs <-+ if null encRecipientCerts+ then pure []+ else loadRecipientPreferredHashes cpt encRecipientCerts+ signatures <-+ if null encSignWithKeyFiles+ then pure []+ else do+ signingKeys <-+ loadSigningKeys encSignWithKeyFiles signingKeyPasswords+ signPayloadWithKeys+ cpt+ encAs+ payload+ signingKeys+ recipientHashPrefs+ ( case encryptProfile of+ EncryptProfileRFC9580 -> rfc9580SigningHashFallbackOrder+ EncryptProfileRFC4880 -> legacySigningHashFallbackOrder+ )+ out <-+ case encRecipientCerts of+ [] ->+ doEncryptWithPassword+ encryptProfile+ payload+ symmetricPasswords+ encSessionKeyOutFile+ _ ->+ doEncryptForRecipients+ encryptProfile+ encAs+ payload+ signatures+ recipientKeys+ encSessionKeyOutFile+ BL.putStr $+ if encNoArmor+ then out+ else AA.encodeLazy [Armor ArmorMessage [] out]++doEncryptWithPassword+ :: EncryptProfile+ -> BL.ByteString+ -> [BL.ByteString]+ -> Maybe String+ -> IO BL.ByteString+doEncryptWithPassword encryptProfile payload passwords sessionKeyOutFile = do+ password <-+ case passwords of+ [] ->+ failWith+ MissingArg+ "encrypt: supply at least one recipient certificate or --with-password"+ [p] -> pure p+ _ ->+ failWith+ UnsupportedOption+ "encrypt: multiple --with-password values are not yet supported"+ let exposure =+ if isJust sessionKeyOutFile+ then ExposeSessionMaterial+ else DoNotExposeSessionMaterial+ encrypted <-+ case encryptProfile of+ EncryptProfileRFC9580 -> do+ s2kSalt <- Salt16 <$> getRandomBytes 16+ iv <- IV <$> getRandomBytes 32+ pure $+ encryptMessage+ RFC9580EncryptMessageOptions+ { rfc9580EncryptMessageExposure = exposure+ , rfc9580EncryptMessageSymmetricAlgorithm = AES256+ , rfc9580EncryptMessageS2K = Argon2 s2kSalt 1 4 15+ , rfc9580EncryptMessageIV = iv+ }+ (mkPassphrase password)+ (mkClearPayload payload)+ EncryptProfileRFC4880 -> do+ salt <- Salt8 <$> getRandomBytes 8+ iv <- IV <$> getRandomBytes 16+ pure $+ encryptMessage+ RFC4880EncryptMessageOptions+ { rfc4880EncryptMessageExposure = exposure+ , rfc4880EncryptMessageSymmetricAlgorithm = AES256+ , rfc4880EncryptMessageS2K = IteratedSalted SHA256 salt 65536+ , rfc4880EncryptMessageIV = iv+ }+ (mkPassphrase password)+ (mkClearPayload payload)+ case encrypted of+ Left err -> failWith BadData ("encrypt failed: " ++ show err)+ Right (ciphertext, mRecoveredSession) -> do+ forM_ sessionKeyOutFile $ \path ->+ case mRecoveredSession of+ Just recoveredSession ->+ writeFileWithOutputExistsCheck+ "encrypt"+ path+ ( renderSessionKeyOutLine+ (fromFVal (recoveredSessionAlgorithm recoveredSession))+ (unSessionKey (recoveredSessionKey recoveredSession))+ ++ "\n"+ )+ Nothing ->+ failWith+ UnsupportedOption+ "encrypt: --session-key-out unavailable for this password encryption mode"+ pure (encryptedPayloadBytes ciphertext)++doEncryptForRecipients+ :: EncryptProfile+ -> AsBinaryText+ -> BL.ByteString+ -> [SignaturePayload]+ -> [FunKey]+ -> Maybe String+ -> IO BL.ByteString+doEncryptForRecipients encryptProfile asMode payload signatures recipients sessionKeyOutFile = do+ let targets = map recipientTargetFor recipients+ payloadShape =+ defaultRecipientPayloadShape+ { recipientPayloadDataType = literalDataType+ , recipientPayloadUseOnePassSignatures = not (null signatures)+ , recipientPayloadSignatures = signatures+ }+ result <-+ if useStrictEncryptProfile+ then+ encryptForRecipients+ RecipientEncryptRequest+ { recipientEncryptRequestTargets = targets+ , recipientEncryptRequestPayloadShape = payloadShape+ , recipientEncryptRequestPayload = BL.toStrict payload+ , recipientEncryptRequestSymmetricOverride = symmetricOverride+ , recipientEncryptRequestOverrides =+ RecipientEncryptRequestSEIPDv2Overrides+ { recipientEncryptRequestAEADOverride = Nothing+ , recipientEncryptRequestChunkSizeOverride = Nothing+ , recipientEncryptRequestSaltOverride = Nothing+ }+ }+ else+ encryptForRecipients+ RecipientEncryptRequest+ { recipientEncryptRequestTargets = targets+ , recipientEncryptRequestPayloadShape = payloadShape+ , recipientEncryptRequestPayload = BL.toStrict payload+ , recipientEncryptRequestSymmetricOverride = symmetricOverride+ , recipientEncryptRequestOverrides =+ RecipientEncryptRequestSEIPDv1Overrides+ { recipientEncryptRequestIVOverride = Nothing+ }+ }+ RecipientEncryptResult {..} <-+ case result of+ Left err ->+ failWith+ (sopFailureForPKESKEncryptError err)+ ("encrypt failed: " ++ renderPKESKEncryptError err)+ Right val -> pure val+ forM_ sessionKeyOutFile $ \path ->+ writeFileWithOutputExistsCheck+ "encrypt"+ path+ ( renderSessionKeyOutLine+ (fromFVal (pkeskSessionAlgorithm recipientEncryptSessionMaterial))+ (unSessionKey (pkeskSessionKey recipientEncryptSessionMaterial))+ ++ "\n"+ )+ pure (runPut (Bin.put (Block recipientEncryptPackets)))+ where+ literalDataType =+ case asMode of+ AsBinary -> BinaryData+ AsText -> UTF8Data+ anyRecipientSupportsSEIPDv2 = any fsupportsSEIPDv2 recipients+ symmetricOverride+ | useStrictEncryptProfile =+ preferredStrictSymmetric <|> Just AES256+ | otherwise = preferredLegacySymmetric+ isV6Recipient pkp = _keyVersion pkp == V6+ useStrictEncryptProfile =+ case encryptProfile of+ EncryptProfileRFC9580 ->+ anyRecipientSupportsSEIPDv2+ || any (isV6Recipient . fpkp) recipients+ EncryptProfileRFC4880 ->+ anyRecipientSupportsSEIPDv2+ || any (isV6Recipient . fpkp) recipients+ preferredStrictSymmetric =+ preferredRecipientSymmetric isSupportedStrictEncryptSymmetric+ preferredLegacySymmetric =+ preferredRecipientSymmetric isSupportedLegacyEncryptSymmetric+ preferredRecipientSymmetric isSupported =+ case filter+ (not . null)+ (map fpreferredSymmetricAlgorithms recipients) of+ [] -> Nothing+ (prefList : prefLists) ->+ listToMaybe+ [ candidate+ | candidate <- filter isSupported prefList+ , all (candidate `elem`) prefLists+ ]+ isSupportedStrictEncryptSymmetric algo =+ algo `elem` [AES128, AES192, AES256]+ -- Legacy profile fallback should not hard-fail on deprecated/unsupported+ -- recipient preferences (e.g. IDEA in AEADED interop fixtures).+ isSupportedLegacyEncryptSymmetric algo =+ algo `elem` [AES128, AES192, AES256]+ recipientTargetFor funkey =+ let recipient = fpkp funkey+ recipientNeedsV6PKESK =+ useStrictEncryptProfile+ && (fsupportsSEIPDv2 funkey || _keyVersion recipient == V6)+ in if _keyVersion recipient == V6+ then+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6+ else case _pkalgo recipient of+ ECDH ->+ -- Under strict (SEIPDv2) mode, keep Curve25519-compatible v4 ECDH keys on+ -- the X25519/v6 path so ESK/payload versions stay aligned.+ if recipientNeedsV6PKESK+ then case normalizeX25519CompatibleECDHRecipient recipient of+ Just x25519Recipient ->+ recipientEncryptionTargetWithStrategy+ x25519Recipient+ RecipientPreferV6+ Nothing ->+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6+ else+ recipientEncryptionTargetWithStrategy+ recipient+ RecipientForceV3Interop+ DeprecatedRSAEncryptOnly ->+ if recipientNeedsV6PKESK+ then+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6+ else+ recipientEncryptionTargetWithStrategy+ recipient+ RecipientForceV3Interop+ RSA ->+ if recipientNeedsV6PKESK+ then+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6+ else+ recipientEncryptionTargetWithStrategy+ recipient+ RecipientForceV3Interop+ _ ->+ if recipientNeedsV6PKESK+ then+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6+ else recipientEncryptionTarget recipient++ normalizeX25519CompatibleECDHRecipient pkp =+ case _pubkey pkp of+ ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->+ Just+ ( PKPayload+ (_keyVersion pkp)+ (_timestamp pkp)+ (_v3exp pkp)+ X25519+ (_pubkey pkp)+ )+ _ -> Nothing++parseEncryptProfile :: Maybe String -> IO EncryptProfile+parseEncryptProfile Nothing = pure EncryptProfileRFC9580+parseEncryptProfile (Just profileName) =+ case profileName of+ "default" -> pure EncryptProfileRFC9580+ "rfc9580" -> pure EncryptProfileRFC9580+ "security" -> pure EncryptProfileRFC9580+ "performance" -> pure EncryptProfileRFC9580+ "rfc4880" -> pure EncryptProfileRFC4880+ "compatibility" -> pure EncryptProfileRFC4880+ _ ->+ failWith+ UnsupportedProfile+ ("encrypt: unsupported profile " ++ profileName)++doDecrypt :: POSIXTime -> DecryptOptions -> IO ()+doDecrypt cpt DecryptOptions {..} = do+ when (decNoArmor && decArmor) $+ failWith+ IncompatibleOptions+ "decrypt: --armor and --no-armor are mutually exclusive"+ when decWithoutIntegrityCheck $+ failWith+ UnsupportedOption+ "decrypt: --without-integrity-check is not supported by this backend"+ sessionKeys <- parseDecryptSessionKeys decSessionKeys+ (verificationOutputPath, usingDeprecatedVerifyOut) <-+ resolveDecryptVerificationsOut+ decVerificationsOutFile+ decDeprecatedVerifyOutFile+ let hasVerifyWith = not (null decVerifyCerts)+ hasVerifyOut = isJust verificationOutputPath+ hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter+ doingVerification = hasVerifyWith && hasVerifyOut+ when (hasVerifyWith /= hasVerifyOut) $+ failWith+ IncompleteVerification+ "decrypt: verification requires both --verify-with and --verifications-out"+ when (hasVerifyBounds && not doingVerification) $+ failWith+ IncompleteVerification+ "decrypt: --verify-not-before/--verify-not-after require both --verify-with and --verifications-out"+ passwords <-+ loadPasswordFiles "decrypt" "--with-password" decPasswords+ keyPasswordsRaw <-+ loadPasswordFiles "decrypt" "--with-key-password" decKeyPasswords+ let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw+ when (null passwords && null sessionKeys && null decKeyFiles) $+ failWith+ MissingArg+ "decrypt: supply KEYS, --with-password, or --with-session-key"+ ciphertextInput <-+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ ciphertext <- decodeCiphertextInput ciphertextInput+ validateDecryptPartialBodyEncoding ciphertext+ ciphertextPktsRaw <-+ parseRawOpenPGPPackets "decrypt input" ciphertext+ let ciphertextPkts =+ filter+ ( \pkt ->+ not+ ( isForwardCompatUnknownESKPacket pkt+ || isUnsupportedSKESKPacket pkt+ )+ )+ ciphertextPktsRaw+ -- Pre-flight: reject messages with no encrypted payload at all (upstream+ -- won't produce a useful DecryptMalformedStructure for the empty case).+ when (not (any isEncryptedPayloadPacket ciphertextPkts)) $+ failWith BadData "decrypt input: no encrypted data packet found"+ validateCiphertextPacketLayout ciphertextPkts+ recipientKeys <-+ loadDecryptRecipientKeys cpt decKeyFiles keyPasswords+ when+ ( null recipientKeys+ && not (null decKeyFiles)+ && null passwords+ && null sessionKeys+ )+ $ failWith+ CannotDecrypt+ "decrypt failed: no usable secret key material found in provided KEYS"+ let passwordAttempts =+ case passwords of+ [] -> [[]]+ _ ->+ map+ (\password -> [password])+ (concatMap passwordRetryCandidates passwords)+ runDecryptAttemptWithPolicy decryptPolicy keyCandidates passwordBytes = do+ passwordQueue <- newIORef passwordBytes+ sessionKeyQueue <-+ newIORef (map decryptSessionKeyMaterial sessionKeys)+ let decryptInputPkts = prioritizeDecryptablePKESKs keyCandidates ciphertextPkts+ let keyResolutionResolver =+ selectRecipientKeyInfosByRecipientIdentifier keyCandidates+ let opts =+ Decrypt.DecryptOptions+ { Decrypt.decryptOptionsKeyResolution =+ DecryptWithUnwrapCandidatesCallback keyResolutionResolver+ , Decrypt.decryptOptionsPolicy = decryptPolicy+ , Decrypt.decryptOptionsPassphraseCallback =+ decryptInputCallback passwordQueue sessionKeyQueue+ }+ (outcome, pkts) <-+ runConduitRes $+ CL.sourceList decryptInputPkts+ .| fuseBoth (Decrypt.conduitDecrypt opts) CL.consume+ case outcome of+ DecryptMalformedStructure reason ->+ pure (Left reason)+ DecryptTruncated ->+ failWith BadData "decrypt failed: encrypted message is truncated"+ _ -> pure (Right pkts)+ tryDecryptWithPasswords [passwordBytes] =+ runDecryptAttempt recipientKeys passwordBytes+ `catch` decryptIOFailureToSOP+ tryDecryptWithPasswords (passwordBytes : rest) =+ runDecryptAttempt recipientKeys passwordBytes `catch` retryNext+ where+ retryNext :: ExitCode -> IO [Pkt]+ retryNext exitCode+ | exitCode == ExitFailure (failureCode CannotDecrypt) =+ tryDecryptWithPasswords rest+ | otherwise = throwIO exitCode+ tryDecryptWithPasswords [] =+ failWith+ CannotDecrypt+ "decrypt failed: passphrase required but not provided"+ decryptIOFailureToSOP :: IOException -> IO [Pkt]+ decryptIOFailureToSOP err =+ failWith+ CannotDecrypt+ ("decrypt failed: " ++ displayException err)+ runDecryptAttempt keyCandidates passwordBytes = do+ strictOutcome <-+ runDecryptAttemptWithPolicy+ defaultDecryptPolicy+ keyCandidates+ passwordBytes+ case strictOutcome of+ Right pkts -> pure pkts+ Left reason+ | shouldRetryLenientDecrypt reason keyCandidates passwordBytes -> do+ lenientOutcome <-+ runDecryptAttemptWithPolicy+ lenientDecryptPolicy+ keyCandidates+ passwordBytes+ case lenientOutcome of+ Right pkts -> pure pkts+ Left lenientReason ->+ failWith+ BadData+ ( "decrypt failed: malformed encrypted message structure ("+ ++ lenientReason+ ++ ")"+ )+ | otherwise ->+ failWith+ BadData+ ( "decrypt failed: malformed encrypted message structure ("+ ++ reason+ ++ ")"+ )+ shouldRetryLenientDecrypt reason keyCandidates passwordBytes+ | "ESK packets must immediately precede encrypted data"+ `isInfixOf` reason =+ True+ | "ESK packets present but none are version-aligned with SEIPDv2 payload"+ `isInfixOf` reason =+ null passwordBytes+ && not (null keyCandidates)+ && any isLegacyRSAPKESK ciphertextPkts+ | otherwise = False+ isLegacyRSAPKESK (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) =+ pka == RSA || pka == DeprecatedRSAEncryptOnly+ isLegacyRSAPKESK _ = False+ decryptedPktsRaw <- tryDecryptWithPasswords passwordAttempts+ sessionKeyOutLine <-+ resolveSessionKeyOut+ decSessionKeyOutFile+ sessionKeys+ ciphertextPkts+ recipientKeys+ (concatMap passwordRetryCandidates passwords)+ decryptedPkts <- do+ decompressed <-+ mapM+ ( either (\e -> failWith BadData (renderCompressionError e)) pure+ . recursivelyDecompressPacket+ )+ decryptedPktsRaw+ pure (concat decompressed)+ validateDecryptedMessageStructure decryptedPktsRaw decryptedPkts+ payload <- extractSingleLiteralPayload decryptedPkts+ BL.putStr payload+ case (decSessionKeyOutFile, sessionKeyOutLine) of+ (Just path, Just line) -> writeFileWithOutputExistsCheck "decrypt" path (line ++ "\n")+ _ -> pure ()+ when doingVerification $+ doDecryptVerifyOutput+ cpt+ decVerifyCerts+ verificationOutputPath+ decVerifyNotBefore+ decVerifyNotAfter+ decryptedPkts+ when usingDeprecatedVerifyOut $+ hPutStrLn+ stderr+ "Warning: --verify-out is deprecated; use --verifications-out instead."++data DecryptSessionKey+ = DecryptSessionKey+ { decryptSessionKeyMaterial :: BL.ByteString+ , decryptSessionKeyOutLine :: Maybe String+ }++decryptInputCallback+ :: IORef [BL.ByteString]+ -> IORef [BL.ByteString]+ -> String+ -> IO BL.ByteString+decryptInputCallback _passwordQueue sessionKeyQueue prompt+ | "PKESK session key material" `isInfixOf` prompt = do+ mSessionKeyMaterial <-+ atomicModifyIORef' sessionKeyQueue $ \keys ->+ case keys of+ [] -> ([], Nothing)+ (k : rest) -> (rest, Just k)+ case mSessionKeyMaterial of+ Just sessionKeyMaterial -> pure sessionKeyMaterial+ Nothing ->+ failWith+ CannotDecrypt+ "decrypt failed: PKESK session key material required but not provided"+decryptInputCallback passwordQueue _ _ = do+ mPassword <-+ atomicModifyIORef' passwordQueue $ \passwords ->+ case passwords of+ [] -> ([], Nothing)+ (p : rest) -> (rest, Just p)+ case mPassword of+ Just password -> pure password+ Nothing ->+ failWith+ CannotDecrypt+ "decrypt failed: passphrase required but not provided"++parseDecryptSessionKeys :: [String] -> IO [DecryptSessionKey]+parseDecryptSessionKeys = mapM parseSessionKeySpec++parseSessionKeySpec :: String -> IO DecryptSessionKey+parseSessionKeySpec spec =+ case break (== ':') spec of+ (_, "") -> do+ material <- decodeHexBytes spec+ pure+ DecryptSessionKey+ { decryptSessionKeyMaterial = BL.fromStrict material+ , decryptSessionKeyOutLine = sessionKeyOutLineFromMaterial material+ }+ (algoSpec, ':' : keyHex) -> do+ algo <- parseAlgorithmOctet algoSpec+ keyBytes <- decodeHexBytes keyHex+ when (B.null keyBytes) $+ failWith+ BadData+ "decrypt: --with-session-key key material cannot be empty"+ pure+ DecryptSessionKey+ { decryptSessionKeyMaterial =+ BL.fromStrict (encodeOpenPGPSessionKey algo keyBytes)+ , decryptSessionKeyOutLine =+ Just (renderSessionKeyOutLine algo keyBytes)+ }+ _ -> failWith BadData "decrypt: invalid --with-session-key format"++resolveSessionKeyOut+ :: Maybe String+ -> [DecryptSessionKey]+ -> [Pkt]+ -> [PKESKRecipientKey]+ -> [BL.ByteString]+ -> IO (Maybe String)+resolveSessionKeyOut Nothing _ _ _ _ = pure Nothing+resolveSessionKeyOut (Just _) sessionKeys ciphertextPkts recipientKeys passwordCandidates =+ case mapMaybe decryptSessionKeyOutLine sessionKeys of+ (line : _) -> pure (Just line)+ [] -> do+ discoveredLine <-+ recoverSessionKeyOutFromCiphertext+ ciphertextPkts+ recipientKeys+ passwordCandidates+ case discoveredLine of+ Just line -> pure (Just line)+ Nothing -> pure Nothing++recoverSessionKeyOutFromCiphertext+ :: [Pkt]+ -> [PKESKRecipientKey]+ -> [BL.ByteString]+ -> IO (Maybe String)+recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates =+ case recoverFromSKESK of+ Just line -> pure (Just line)+ Nothing -> recoverFromLegacyRSAPKESK+ where+ recoverFromSKESK =+ listToMaybe $+ mapMaybe+ ( \(SKESKPayloadV4 sa s2k maybeEsk, passphrase) ->+ case maybeEsk of+ Nothing ->+ case skesk2Key (SKESK4Packet sa s2k Nothing) passphrase of+ Left _ -> Nothing+ Right sessionKey ->+ Just (renderSessionKeyOutLine (fromFVal sa) sessionKey)+ Just esk ->+ case skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase of+ Left _ -> Nothing+ Right (algo, sessionKey) ->+ Just (renderSessionKeyOutLine (fromFVal algo) sessionKey)+ )+ [ (payload, passphrase)+ | payload <- skeskPayloadsV4+ , passphrase <- passwordCandidates+ ]+ skeskPayloadsV4 =+ mapMaybe+ ( \pkt ->+ case pkt of+ SKESKPkt (SKESKPayloadV4Packet payload) -> Just payload+ _ -> Nothing+ )+ ciphertextPkts+ recoverFromLegacyRSAPKESK =+ recoverRSACombos+ [(mpi, rsaKey) | mpi <- rsaPKESKMPIs, rsaKey <- rsaRecipientKeys]+ recoverRSACombos [] = pure Nothing+ recoverRSACombos ((mpi, rsaKey) : rest) = do+ encodedResult <- decryptLegacyRSAPKESK rsaKey mpi+ case encodedResult of+ Left _ -> recoverRSACombos rest+ Right encoded ->+ case decodeOpenPGPEncodedSessionKey encoded of+ Right (algo, keyBytes) ->+ pure (Just (renderSessionKeyOutLine (fromFVal algo) keyBytes))+ Left _ -> recoverRSACombos rest+ rsaPKESKMPIs =+ mapMaybe+ ( \pkt ->+ case pkt of+ PKESKPkt+ (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka (mpi :| [])))+ | pka == RSA || pka == DeprecatedRSAEncryptOnly ->+ Just mpi+ _ -> Nothing+ )+ ciphertextPkts+ rsaRecipientKeys =+ mapMaybe+ ( \keyInfo ->+ case pkeskRecipientSKey keyInfo of+ RSAPrivateKey (RSA_PrivateKey privateKey) -> Just privateKey+ _ -> Nothing+ )+ recipientKeys++decryptLegacyRSAPKESK+ :: RSA.PrivateKey -> MPI -> IO (Either String B.ByteString)+decryptLegacyRSAPKESK privateKey mpi = do+ attempted <-+ P15.decryptSafer privateKey (mpiToCiphertext privateKey mpi)+ pure (first show attempted)+ where+ mpiToCiphertext rsaKey (MPI encodedMPI) =+ let modulusBytes = rsaModulusOctets rsaKey+ in i2ospOf_ modulusBytes encodedMPI+ rsaModulusOctets rsaKey =+ let modulusBits = integerBitLength (RSA.public_n (RSA.private_pub rsaKey))+ in max 1 ((modulusBits + 7) `div` 8)+ integerBitLength n+ | n <= 0 = 0+ | otherwise = go n 0+ where+ go 0 bits = bits+ go val bits = go (val `div` 2) (bits + 1)++parseAlgorithmOctet :: String -> IO Word8+parseAlgorithmOctet algoSpec =+ case readMaybe algoSpec :: Maybe Int of+ Just octet+ | octet >= 0 && octet <= 255 ->+ case toFVal (fromIntegral octet) :: SymmetricAlgorithm of+ OtherSA _ ->+ failWith+ BadData+ ("decrypt: unsupported --with-session-key algorithm: " ++ algoSpec)+ _ -> pure (fromIntegral octet)+ _ ->+ failWith+ BadData+ ("decrypt: invalid --with-session-key algorithm: " ++ algoSpec)++decodeHexBytes :: String -> IO B.ByteString+decodeHexBytes hex =+ if odd (length hex)+ then+ failWith+ BadData+ "decrypt: hex key material must have an even number of digits"+ else B.pack <$> go hex+ where+ go [] = pure []+ go (a : b : rest) = do+ hi <- nibble a+ lo <- nibble b+ (fromIntegral (hi * 16 + lo) :) <$> go rest+ go _ = failWith BadData "decrypt: malformed hex key material"+ nibble c =+ if isHexDigit c+ then pure (digitToInt c)+ else failWith BadData "decrypt: key material must be hexadecimal"++isEncryptedPayloadPacket :: Pkt -> Bool+isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True+isEncryptedPayloadPacket SymEncDataPkt {} = True+isEncryptedPayloadPacket _ = False++isForwardCompatUnknownESKPacket :: Pkt -> Bool+isForwardCompatUnknownESKPacket (OtherPacketPkt tag _) = tag == 1 || tag == 3+isForwardCompatUnknownESKPacket (BrokenPacketPkt _ tag _) = tag == 1 || tag == 3+isForwardCompatUnknownESKPacket _ = False++isUnsupportedSKESKPacket :: Pkt -> Bool+isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ s2k _))) = isUnknownS2K s2k+isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ s2k _ _ _))) = isUnknownS2K s2k+isUnsupportedSKESKPacket _ = False++isUnknownS2K :: S2K -> Bool+isUnknownS2K OtherS2K {} = True+isUnknownS2K _ = False++validateCiphertextPacketLayout :: [Pkt] -> IO ()+validateCiphertextPacketLayout pkts =+ case findIndex isEncryptedPayloadPacket pkts of+ Nothing -> pure ()+ Just payloadIndex ->+ let trailing =+ filter+ (not . isMarkerPacketPacket)+ (drop (payloadIndex + 1) pkts)+ in when (not (null trailing)) $+ failWith+ BadData+ "decrypt input: malformed encrypted message structure (unexpected packets after encrypted data)"++isMarkerPacketPacket :: Pkt -> Bool+isMarkerPacketPacket MarkerPkt {} = True+isMarkerPacketPacket _ = False++validateDecryptedMessageStructure :: [Pkt] -> [Pkt] -> IO ()+validateDecryptedMessageStructure rawPkts pkts = do+ let literalCount = length [() | LiteralDataPkt {} <- pkts]+ signatureCount = length [() | SignaturePkt {} <- pkts]+ onePassCount = length [() | OnePassSignaturePkt {} <- pkts]+ hasCompressedRaw = any isCompressedPacket rawPkts+ hasUnknownPackets = any isUnknownPacket rawPkts || any isUnknownPacket pkts+ maxCompressionDepth = maximum (0 : map compressionDepth rawPkts)+ when (any compressedPacketParseFailed rawPkts) $+ failWith+ BadData+ "decrypt failed: malformed compressed data stream"+ when (maxCompressionDepth > 2) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (excessive compression nesting)"+ when (hasCompressedRaw && any isMarkerPacket pkts) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (compressed marker packet)"+ when (any isDisallowedDecryptedPacketType pkts) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (unexpected packet type in plaintext)"+ when (literalCount == 0) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (no literal data payload found)"+ when (literalCount > 1) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (multiple literal payloads)"+ when+ (not hasUnknownPackets && onePassCount > 0 && signatureCount == 0)+ $ failWith+ BadData+ "decrypt failed: malformed signed message structure (one-pass signature without trailing signature)"+ when+ ( not hasUnknownPackets+ && signatureCount > 0+ && onePassCount == 0+ && not isOldStyleSignedMessage+ )+ $ failWith+ BadData+ "decrypt failed: malformed signed message structure (trailing signature without one-pass signature)"+ where+ isOldStyleSignedMessage =+ case [i | (i, LiteralDataPkt {}) <- packetPositions] of+ [literalIndex] ->+ not (null signaturePositions)+ && all (< literalIndex) signaturePositions+ _ -> False+ packetPositions = zip [0 :: Int ..] (filter (not . isMarkerPacket) pkts)+ signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]++compressedPacketParseFailed :: Pkt -> Bool+compressedPacketParseFailed pkt@CompressedDataPkt {} = isLeft (decompressPkt pkt)+compressedPacketParseFailed _ = False++recursivelyDecompressPacket+ :: Pkt -> Either CompressionError [Pkt]+recursivelyDecompressPacket pkt@CompressedDataPkt {} = do+ inner <- decompressPkt pkt+ concat <$> mapM recursivelyDecompressPacket inner+recursivelyDecompressPacket pkt = Right [pkt]++compressedPacketIsEmpty :: Pkt -> Bool+compressedPacketIsEmpty pkt@CompressedDataPkt {} =+ case decompressPkt pkt of+ Right [] -> True+ _ -> False+compressedPacketIsEmpty _ = False++isCompressedPacket :: Pkt -> Bool+isCompressedPacket CompressedDataPkt {} = True+isCompressedPacket _ = False++compressionDepth :: Pkt -> Int+compressionDepth pkt@CompressedDataPkt {} =+ let inner = either (const []) id (decompressPkt pkt)+ in if null inner+ then 1+ else 1 + maximum (0 : map compressionDepth inner)+compressionDepth _ = 0++isMarkerPacket :: Pkt -> Bool+isMarkerPacket MarkerPkt {} = True+isMarkerPacket _ = False++isUnknownPacket :: Pkt -> Bool+isUnknownPacket OtherPacketPkt {} = True+isUnknownPacket BrokenPacketPkt {} = True+isUnknownPacket _ = False++isDisallowedDecryptedPacketType :: Pkt -> Bool+isDisallowedDecryptedPacketType PKESKPkt {} = True+isDisallowedDecryptedPacketType SKESKPkt {} = True+isDisallowedDecryptedPacketType PublicKeyPkt {} = True+isDisallowedDecryptedPacketType PublicSubkeyPkt {} = True+isDisallowedDecryptedPacketType SecretKeyPkt {} = True+isDisallowedDecryptedPacketType SecretSubkeyPkt {} = True+isDisallowedDecryptedPacketType SymEncDataPkt {} = True+isDisallowedDecryptedPacketType SymEncIntegrityProtectedDataPkt {} = True+isDisallowedDecryptedPacketType _ = False++encodeOpenPGPSessionKey :: Word8 -> B.ByteString -> B.ByteString+encodeOpenPGPSessionKey algo keyBytes =+ B.cons+ algo+ ( keyBytes+ <> B.pack [fromIntegral (checksum `div` 256), fromIntegral checksum]+ )+ where+ checksum :: Int+ checksum =+ B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536++sessionKeyOutLineFromMaterial :: B.ByteString -> Maybe String+sessionKeyOutLineFromMaterial raw = do+ (algo, keyBytes) <- decodeOpenPGPSessionKeyMaterial raw+ pure (renderSessionKeyOutLine algo keyBytes)++decodeOpenPGPSessionKeyMaterial+ :: B.ByteString -> Maybe (Word8, B.ByteString)+decodeOpenPGPSessionKeyMaterial raw = do+ (algo, body) <- B.uncons raw+ case toFVal (fromIntegral algo) :: SymmetricAlgorithm of+ OtherSA _ -> Nothing+ _ -> do+ let bodyLen = B.length body+ if bodyLen < 3+ then Nothing+ else do+ let keyBytes = B.take (bodyLen - 2) body+ checksumHi = fromIntegral (B.index body (bodyLen - 2)) :: Int+ checksumLo = fromIntegral (B.index body (bodyLen - 1)) :: Int+ checksumExpected = checksumHi * 256 + checksumLo+ checksumActual =+ B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536+ if B.null keyBytes || checksumActual /= checksumExpected+ then Nothing+ else Just (algo, keyBytes)++renderSessionKeyOutLine :: Word8 -> B.ByteString -> String+renderSessionKeyOutLine algo keyBytes =+ show algo ++ ":" ++ hexEncodeBytes keyBytes++hexEncodeBytes :: B.ByteString -> String+hexEncodeBytes = concatMap encodeByte . B.unpack+ where+ encodeByte w =+ [ nibble (w `shiftR` 4)+ , nibble (w .&. 0x0f)+ ]+ nibble n = "0123456789abcdef" !! fromIntegral n++extractSingleLiteralPayload :: [Pkt] -> IO BL.ByteString+extractSingleLiteralPayload pkts =+ case [p | LiteralDataPkt _ _ _ p <- pkts] of+ [payload] -> pure payload+ [] ->+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (no literal data payload found)"+ _ ->+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (multiple literal data payloads found)"++doDecryptVerifyOutput+ :: POSIXTime+ -> [String]+ -> Maybe String+ -> Maybe String+ -> Maybe String+ -> [Pkt]+ -> IO ()+doDecryptVerifyOutput cpt certFiles outFile notBeforeArg notAfterArg decryptedPkts = do+ when (null certFiles) $+ failWith+ IncompleteVerification+ "decrypt: verification requires at least one --verify-with cert"+ (krs, verifyTks) <- loadVerifyContext cpt certFiles+ upperBound <- verificationUpperBound cpt notAfterArg+ lowerBound <- verificationLowerBound cpt notBeforeArg+ verificationPkts <-+ normalizeDecryptVerificationPackets decryptedPkts+ let verifications =+ map+ (first show)+ (verifyPacketsBatch krs upperBound verificationPkts)+ filtered = filterByVerificationBounds lowerBound upperBound verifications+ successLines =+ map (renderSOPVerificationLine verifyTks) (rights filtered)+ renderedOut =+ if null successLines+ then ""+ else unlines successLines+ case outFile of+ Just path -> writeFileWithOutputExistsCheck "decrypt" path renderedOut+ Nothing -> pure ()++normalizeDecryptVerificationPackets :: [Pkt] -> IO [Pkt]+normalizeDecryptVerificationPackets pkts =+ case ( [pkt | pkt@LiteralDataPkt {} <- pkts]+ , [pkt | pkt@SignaturePkt {} <- pkts]+ ) of+ ([], _) ->+ failWith+ CannotDecrypt+ "decrypt failed: no literal data payload found"+ ([lit], []) -> pure [lit]+ ([lit], sigs) -> pure (lit : sigs)+ (_, _) ->+ failWith+ BadData+ "decrypt failed: malformed signed message structure (multiple literal payloads)"++resolveDecryptVerificationsOut+ :: Maybe String -> Maybe String -> IO (Maybe String, Bool)+resolveDecryptVerificationsOut newPath oldPath =+ case (newPath, oldPath) of+ (Just p, Nothing) -> pure (Just p, False)+ (Nothing, Just p) -> pure (Just p, True)+ (Just pNew, Just pOld)+ | pNew == pOld -> pure (Just pNew, True)+ | otherwise ->+ failWith+ IncompatibleOptions+ "decrypt: --verifications-out and --verify-out cannot target different files"+ (Nothing, Nothing) -> pure (Nothing, False)++renderSOPVerificationLine+ :: [TKUnknown] -> Verification -> String+renderSOPVerificationLine verifyTks v =+ ts ++ " " ++ signerFp ++ " " ++ certFp ++ " " ++ modeLabel+ where+ sig = _verificationSignature v+ ts = renderSOPVerificationTimestamp sig+ signer = fingerprint (_verificationSigner v)+ signerFp = hexEncodeBytes (BL.toStrict (unFingerprint signer))+ modeLabel = signatureModeField sig+ certFp =+ case find (\tk -> keyMatchesFingerprint True tk signer) verifyTks of+ Just tk ->+ hexEncodeBytes+ (BL.toStrict (unFingerprint (fingerprint (fst (_tkuKey tk)))))+ Nothing -> signerFp++signatureModeField :: SignaturePayload -> String+signatureModeField sig =+ case sig of+ SigV4 CanonicalTextSig _ _ _ _ _ _ -> "mode:text"+ SigV6 CanonicalTextSig _ _ _ _ _ _ _ -> "mode:text"+ _ -> "mode:binary"++renderSOPVerificationTimestamp :: SignaturePayload -> String+renderSOPVerificationTimestamp sig =+ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $+ case signatureCreationTime sig of+ Just t -> t+ Nothing -> posixSecondsToUTCTime 0++writeFileWithOutputExistsCheck+ :: String -> FilePath -> String -> IO ()+writeFileWithOutputExistsCheck subcommand path content = do+ ensureOutputPathAvailable subcommand path+ writeFile path content++parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]+parseOpenPGPPackets context bytes =+ ( do+ let packets =+ concatMap+ (either (const []) id . decompressPkt)+ (parsePkts bytes)+ _ <- evaluate (length packets)+ pure packets+ )+ `catch` parseFailure+ where+ parseFailure :: SomeException -> IO [Pkt]+ parseFailure err =+ failWith+ BadData+ ( context+ ++ ": failed to parse OpenPGP packets: "+ ++ displayException err+ )++parseRawOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]+parseRawOpenPGPPackets context bytes =+ ( do+ let packets = parsePkts bytes+ _ <- evaluate (length packets)+ pure packets+ )+ `catch` parseFailure+ where+ parseFailure :: SomeException -> IO [Pkt]+ parseFailure err =+ failWith+ BadData+ ( context+ ++ ": failed to parse OpenPGP packets: "+ ++ displayException err+ )++validateDecryptPartialBodyEncoding :: BL.ByteString -> IO ()+validateDecryptPartialBodyEncoding ciphertext =+ case ensureNoShortFirstPartialBodyChunk (BL.toStrict ciphertext) of+ Left err ->+ failWith+ BadData+ ("decrypt input: invalid partial body encoding (" ++ err ++ ")")+ Right () -> pure ()++ensureNoShortFirstPartialBodyChunk+ :: B.ByteString -> Either String ()+ensureNoShortFirstPartialBodyChunk = parsePackets+ where+ parsePackets bs+ | B.null bs = Right ()+ | otherwise = do+ (header, rest) <-+ noteLeft "truncated packet header" (B.uncons bs)+ if header .&. 0x80 /= 0x80+ then Left "invalid packet header octet"+ else do+ remaining <-+ if header .&. 0x40 == 0x40+ then parseNewPacketBody rest+ else parseOldPacketBody (header .&. 0x03) rest+ parsePackets remaining++ parseOldPacketBody lengthType bs =+ case lengthType of+ 0 -> do+ (lenOctet, rest) <-+ noteLeft "truncated old-format one-octet length" (B.uncons bs)+ dropExact+ "truncated old-format packet body"+ (fromIntegral lenOctet)+ rest+ 1 -> do+ (hi, afterHi) <-+ noteLeft "truncated old-format two-octet length" (B.uncons bs)+ (lo, rest) <-+ noteLeft+ "truncated old-format two-octet length"+ (B.uncons afterHi)+ let len = fromIntegral hi * 256 + fromIntegral lo+ dropExact "truncated old-format packet body" len rest+ 2 -> do+ (b1, afterB1) <-+ noteLeft "truncated old-format four-octet length" (B.uncons bs)+ (b2, afterB2) <-+ noteLeft+ "truncated old-format four-octet length"+ (B.uncons afterB1)+ (b3, afterB3) <-+ noteLeft+ "truncated old-format four-octet length"+ (B.uncons afterB2)+ (b4, rest) <-+ noteLeft+ "truncated old-format four-octet length"+ (B.uncons afterB3)+ let len =+ (fromIntegral b1 `shiftL` 24)+ + (fromIntegral b2 `shiftL` 16)+ + (fromIntegral b3 `shiftL` 8)+ + fromIntegral b4+ dropExact "truncated old-format packet body" len rest+ 3 -> Right B.empty+ _ -> Left "invalid old-format length type"++ parseNewPacketBody = parseNewLengthChunks True++ parseNewLengthChunks isFirstChunk bs = do+ (chunkLength, isPartial, afterLength) <- parseNewLength bs+ when (isFirstChunk && isPartial && chunkLength < 512) $+ Left+ ( "first partial chunk is too short ("+ ++ show chunkLength+ ++ " octets, minimum is 512)"+ )+ afterChunk <-+ dropExact+ "truncated new-format packet body chunk"+ chunkLength+ afterLength+ if isPartial+ then parseNewLengthChunks False afterChunk+ else Right afterChunk++ parseNewLength bs = do+ (lengthOctet, rest) <-+ noteLeft "truncated new-format length" (B.uncons bs)+ case lengthOctet of+ _+ | lengthOctet < 192 ->+ Right (fromIntegral lengthOctet, False, rest)+ | lengthOctet < 224 -> do+ (nextOctet, afterNext) <-+ noteLeft "truncated new-format two-octet length" (B.uncons rest)+ let len =+ ((fromIntegral lengthOctet - 192) `shiftL` 8)+ + fromIntegral nextOctet+ + 192+ Right (len, False, afterNext)+ | lengthOctet < 255 ->+ Right+ ( 1 `shiftL` fromIntegral (lengthOctet .&. 0x1f)+ , True+ , rest+ )+ | otherwise -> do+ (b1, afterB1) <-+ noteLeft "truncated new-format five-octet length" (B.uncons rest)+ (b2, afterB2) <-+ noteLeft+ "truncated new-format five-octet length"+ (B.uncons afterB1)+ (b3, afterB3) <-+ noteLeft+ "truncated new-format five-octet length"+ (B.uncons afterB2)+ (b4, afterB4) <-+ noteLeft+ "truncated new-format five-octet length"+ (B.uncons afterB3)+ let len =+ (fromIntegral b1 `shiftL` 24)+ + (fromIntegral b2 `shiftL` 16)+ + (fromIntegral b3 `shiftL` 8)+ + fromIntegral b4+ Right (len, False, afterB4)++ dropExact context n bs+ | B.length bs < n = Left context+ | otherwise = Right (B.drop n bs)++ noteLeft err = maybe (Left err) Right++ensureOutputPathAvailable :: String -> FilePath -> IO ()+ensureOutputPathAvailable subcommand path = do+ exists <- doesFileExist path+ when exists $+ failWith+ OutputExists+ (subcommand ++ ": output path already exists: " ++ path)++loadVerifyContext+ :: POSIXTime -> [String] -> IO (PublicKeyring, [TKUnknown])+loadVerifyContext _ certFiles = do+ allTks <-+ mapMaybe enforceVerifyPrimaryKeyPolicy+ . map sanitizeVerifyTK+ . concat+ <$> mapM (loadCertTKsFromFile "verify") certFiles+ let publicTks =+ mapMaybe+ ( \tk ->+ case fromUnknownToTK tk of+ Right (SomePublicTK publicTk) -> Just publicTk+ _ -> Nothing+ )+ allTks+ keyring <-+ runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap+ pure (keyring, allTks)++loadVerifyTKsFromFile :: String -> IO [TKUnknown]+loadVerifyTKsFromFile path = do+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ certPkts <- decodeOpenPGPInput path lbs+ runConduitRes $+ CL.sourceList certPkts+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList++loadCertTKsFromFile :: String -> String -> IO [TKUnknown]+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)+ .| CC.sinkList++rejectSecretKeyPackets :: String -> String -> [Pkt] -> IO ()+rejectSecretKeyPackets context path packets =+ when (any isSecretKeyPacket packets) $+ failWith+ BadData+ ( context+ ++ ": certificate input contains secret key material in "+ ++ path+ )+ where+ isSecretKeyPacket SecretKeyPkt {} = True+ 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)+ }+ where+ isSubkeyPacket PublicSubkeyPkt {} = True+ isSubkeyPacket SecretSubkeyPkt {} = True+ isSubkeyPacket _ = False++enforceVerifyPrimaryKeyPolicy :: TKUnknown -> Maybe TKUnknown+enforceVerifyPrimaryKeyPolicy tk =+ if primaryKeyTooSmallForVerification (_tkuKey tk)+ then Nothing+ else Just tk++primaryKeyTooSmallForVerification+ :: (SomePKPayload, Maybe SKAddendum) -> Bool+primaryKeyTooSmallForVerification (pkp, _) =+ case _pkalgo pkp of+ RSA -> rsaTooSmall+ DeprecatedRSASignOnly -> rsaTooSmall+ DeprecatedRSAEncryptOnly -> rsaTooSmall+ _ -> False+ where+ rsaTooSmall =+ case pubkeySize (_pubkey pkp) of+ Right bits -> bits < 2048+ Left _ -> False++primaryKeyIdentity+ :: (SomePKPayload, Maybe SKAddendum)+ -> Maybe (Fingerprint, EightOctetKeyId)+primaryKeyIdentity (pkp, _) = do+ keyId <- either (const Nothing) Just (eightOctetKeyID pkp)+ pure (fingerprint pkp, keyId)++sanitizeBindingSignature+ :: Fingerprint+ -> EightOctetKeyId+ -> SignaturePayload+ -> Maybe SignaturePayload+sanitizeBindingSignature _ _ sig+ | hasUnsupportedCriticalSubpacket sig = Nothing+ | hasUnsupportedCriticalEmbeddedBacksig sig = Nothing+ | otherwise = Just sig+ where+ hasUnsupportedCriticalSubpacket sp =+ any isUnsupportedCriticalSubpacket (signatureHashedSubpackets sp)+ hasUnsupportedCriticalEmbeddedBacksig sp =+ any+ ( \ssp ->+ case _sspPayload ssp of+ EmbeddedSignature embedded ->+ any+ isUnsupportedCriticalSubpacket+ (signatureHashedSubpackets embedded)+ _ -> False+ )+ (signatureHashedSubpackets sp)+ isUnsupportedCriticalSubpacket (SigSubPacket isCritical payload) =+ isCritical+ && case payload of+ UserDefinedSigSub {} -> True+ OtherSigSub {} -> True+ NotationData {} -> True+ _ -> False++loadDecryptRecipientKeys+ :: POSIXTime+ -> [String]+ -> [BL.ByteString]+ -> IO [PKESKRecipientKey]+loadDecryptRecipientKeys _ [] _ = pure []+loadDecryptRecipientKeys cpt keyFiles passwords = concat <$> mapM loadFromFile keyFiles+ where+ loadFromFile path = do+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ packets <- decodeOpenPGPInput path lbs+ -- Build the set of fingerprints that are explicitly non-encryption-capable.+ -- Keys not resolvable via TK (processTK failure, bare material) are allowed.+ nonEncFps <- buildNonEncryptionFingerprintSet packets+ keys <-+ mapM (packetRecipientKey path nonEncFps) packets+ >>= pure . catMaybes+ let brokenSecretKeyErrors =+ nub+ [ err+ | BrokenPacketPkt err tag _ <- packets+ , tag == 5 || tag == 7+ ]+ when (null keys && not (null brokenSecretKeyErrors)) $+ failWith+ CannotDecrypt+ ( "decrypt failed: could not load usable secret key material from "+ ++ path+ ++ " ("+ ++ intercalate "; " brokenSecretKeyErrors+ ++ ")"+ )+ pure keys+ -- Build a set of fingerprints that are EXPLICITLY non-encryption-capable.+ -- Only keys whose binding signature carries a KeyFlags subpacket that does+ -- NOT include any encryption bit are added. Keys with no binding-sig TK+ -- (processTK failed, bare secret material, etc.) are NOT blocked — we fall+ -- back to allowing them so that newly-generated or unusual keys still work.+ buildNonEncryptionFingerprintSet packets = do+ tks <-+ runConduitRes $+ CL.sourceList packets+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ let normTks = rights (map (processTK (Just cpt)) tks)+ let tkDerived = S.fromList (concatMap nonEncryptionFingerprints normTks)+ rawDerived = S.fromList (explicitNonEncryptionSubkeyFingerprints packets)+ return (S.union tkDerived rawDerived)+ 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+ primaryFp = unFingerprint (fingerprint primaryPkp)+ primarySigs =+ concatMap snd (_tkuUIDs tk)+ ++ concatMap snd (_tkuUAts tk)+ ++ _tkuRevs tk+ primaryEntry = [primaryFp | not (sigsAllowEncryption primarySigs)]+ -- Subkeys: same rule as primary.+ subEntries =+ [ unFingerprint (fingerprint pkp)+ | (pkt, sigs) <- _tkuSubs tk+ , Just pkp <- [secretOrPublicSubkeyPayload pkt]+ , not (sigsAllowEncryption sigs)+ ]+ blocked = primaryEntry ++ subEntries+ in if tkHasAnyEncryptionCapableKey tk+ then blocked+ else []+ explicitNonEncryptionSubkeyFingerprints packets =+ let (mPending, blocked) = foldl' step (Nothing, []) packets+ in maybe+ blocked+ ( \(fp, hasEnc, sawKeyFlags) -> finalize fp hasEnc sawKeyFlags blocked+ )+ mPending+ where+ step (mPending, blocked) pkt =+ case pkt of+ PublicSubkeyPkt pkp ->+ ( Just (unFingerprint (fingerprint pkp), False, False)+ , finalizePending mPending blocked+ )+ SecretSubkeyPkt pkp _ ->+ ( Just (unFingerprint (fingerprint pkp), False, False)+ , finalizePending mPending blocked+ )+ SignaturePkt sig ->+ case mPending of+ Nothing -> (Nothing, blocked)+ Just (fp, hasEnc, sawKeyFlags) ->+ let usableSig =+ if signatureHasUnsupportedCriticalSubpackets sig+ then []+ else keyFlagsFromSig sig+ hasEnc' = hasEnc || any hasEncryptionFlag usableSig+ sawKeyFlags' = sawKeyFlags || not (null usableSig)+ in (Just (fp, hasEnc', sawKeyFlags'), blocked)+ _ -> (Nothing, finalizePending mPending blocked)+ finalizePending Nothing blocked = blocked+ finalizePending (Just (fp, hasEnc, sawKeyFlags)) blocked =+ finalize fp hasEnc sawKeyFlags blocked+ finalize fp hasEnc sawKeyFlags blocked+ | sawKeyFlags && not hasEnc = fp : blocked+ | otherwise = blocked+ tkHasAnyEncryptionCapableKey tk =+ let (primaryPkp, _) = _tkuKey tk+ primarySigs =+ concatMap snd (_tkuUIDs tk)+ ++ concatMap snd (_tkuUAts tk)+ ++ _tkuRevs tk+ primaryAllows =+ supportsRecipientPKESKAlgorithm primaryPkp+ && sigsAllowEncryption primarySigs+ subAllows =+ any+ ( \(pkt, sigs) ->+ case secretOrPublicSubkeyPayload pkt of+ Just pkp ->+ supportsRecipientPKESKAlgorithm pkp && sigsAllowEncryption sigs+ Nothing -> False+ )+ (_tkuSubs tk)+ in primaryAllows || subAllows+ sigsAllowEncryption [] = True+ sigsAllowEncryption sigs =+ let usableSigs = filter (not . signatureHasUnsupportedCriticalSubpackets) sigs+ flagSets = concatMap keyFlagsFromSig usableSigs+ in if null usableSigs+ then False+ else null flagSets || any hasEncryptionFlag flagSets+ hasEncryptionFlag flags =+ S.member EncryptCommunicationsKey flags+ || S.member EncryptStorageKey flags+ keyFlagsFromSig sig =+ case sig of+ SigV4 _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds+ SigV6 _ _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds+ _ -> []+ signatureHasUnsupportedCriticalSubpackets sig =+ let hasheds =+ case sig of+ SigV4 _ _ _ hs _ _ _ -> hs+ SigV6 _ _ _ _ hs _ _ _ -> hs+ _ -> []+ in any isUnsupportedCritical hasheds+ isUnsupportedCritical (SigSubPacket isCritical payload) =+ isCritical+ && case payload of+ OtherSigSub {} -> True+ UserDefinedSigSub {} -> True+ NotationData {} -> True+ _ -> False+ keyFlagsFromSubpackets subpackets =+ [ 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+ then pure Nothing+ else decryptRecipientKey path pkp ska+ packetRecipientKey path nonEncFps (SecretSubkeyPkt pkp ska) =+ let fp = unFingerprint (fingerprint pkp)+ in if S.member fp nonEncFps+ then pure Nothing+ else decryptRecipientKey path pkp ska+ packetRecipientKey _ _ _ = pure Nothing+ decryptRecipientKey path pkp ska =+ case secretKeyProtectionPolicyViolation pkp ska of+ Just violation ->+ failWith+ KeyIsProtected+ ( "decrypt failed: unsupported secret key protection in "+ ++ path+ ++ " ("+ ++ violation+ ++ ")"+ )+ Nothing ->+ case ska of+ SUUnencrypted skey _ ->+ pure+ ( Just+ ( PKESKRecipientKey+ { pkeskRecipientPKPayload = Just pkp+ , pkeskRecipientSKey = skey+ }+ )+ )+ _ ->+ case passwords of+ [] ->+ failWith+ KeyIsProtected+ ( "decrypt failed: encrypted key in "+ ++ path+ ++ " requires --with-key-password"+ )+ _ ->+ case tryDecryptKey passwords of+ Left _ ->+ failWith+ KeyIsProtected+ ( "decrypt failed: could not decrypt key in "+ ++ path+ ++ " with provided --with-key-password values"+ )+ Right (SUUnencrypted skey _) ->+ pure+ ( Just+ ( PKESKRecipientKey+ { pkeskRecipientPKPayload = Just pkp+ , pkeskRecipientSKey = skey+ }+ )+ )+ Right _ ->+ failWith+ KeyIsProtected+ ("decrypt failed: unsupported secret key protection in " ++ path)+ where+ secretKeyProtectionPolicyViolation recipientPkp addendum =+ let rejectArgon2WithoutAEAD s2k+ | isArgon2S2K s2k =+ Just "Argon2 S2K is only allowed with AEAD-protected secret keys"+ | otherwise = Nothing+ rejectSimpleForV6 s2k+ | isSimpleS2K s2k =+ Just "v6 secret key packets MUST NOT use simple S2K"+ | otherwise = Nothing+ in case addendum of+ SUS16bit _ s2k _ _ ->+ case _keyVersion recipientPkp of+ V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k+ _ -> rejectArgon2WithoutAEAD s2k+ SUSSHA1 _ s2k _ _ ->+ case _keyVersion recipientPkp of+ V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k+ _ -> rejectArgon2WithoutAEAD s2k+ SUSym {} ->+ if _keyVersion recipientPkp == V6+ then+ Just+ "v6 secret key packets MUST NOT use legacy CFB secret-key protection"+ else Nothing+ _ -> Nothing+ isArgon2S2K Argon2 {} = True+ isArgon2S2K _ = False+ isSimpleS2K (Simple _) = True+ isSimpleS2K _ = False+ tryDecryptKey [] = Left ()+ tryDecryptKey (password : rest) =+ case decryptPrivateKey (pkp, ska) password of+ Left _ -> tryDecryptKey rest+ Right decrypted -> Right decrypted++decodeOpenPGPInput :: String -> BL.ByteString -> IO [Pkt]+decodeOpenPGPInput path input = do+ decodedArmors <-+ decodeAsciiArmorInput ("OpenPGP input in " ++ path) input+ case decodedArmors of+ Just armors ->+ case firstBy isOpenPGPArmorBlock armors of+ Just (Armor _ _ bs) ->+ parseOpenPGPPackets+ ("armored OpenPGP input in " ++ path)+ (BL.fromStrict (BLC8.toStrict bs))+ _ ->+ case firstBy isClearSignedArmor armors of+ Just _ ->+ failWith+ BadData+ ("Expected key data in " ++ path ++ ", got cleartext signature")+ _ -> parseOpenPGPPackets "OpenPGP input" input+ Nothing -> parseOpenPGPPackets "OpenPGP input" input++loadRecipientPreferredHashes+ :: POSIXTime -> [String] -> IO [HashAlgorithm]+loadRecipientPreferredHashes cpt certFiles =+ concat <$> mapM loadFromFile certFiles+ where+ loadFromFile path = do+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ pkts <- decodeOpenPGPInput path lbs+ rejectSecretKeyPackets "encrypt" path pkts+ tks <-+ runConduitRes $+ CL.sourceList pkts+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ normalized <- mapM (normalizeRecipient path) tks+ pure+ (concatMap (effectiveHashPreferencesAt cpt) normalized)+ normalizeRecipient path tk =+ case processTK (Just cpt) tk of+ Left err ->+ failWith+ BadData+ ( "encrypt: invalid recipient certificate in "+ ++ path+ ++ ": "+ ++ show err+ )+ Right normalized -> pure normalized++loadEncryptRecipients+ :: POSIXTime -> EncryptFor -> [String] -> IO [FunKey]+loadEncryptRecipients cpt encPurpose certFiles = do+ recipients <- concat <$> mapM loadRecipientsFromFile certFiles+ if null recipients+ then+ failWith+ CertCannotEncrypt+ "encrypt: no supported recipient encryption keys found in provided certificates"+ else pure recipients+ where+ loadRecipientsFromFile path = do+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy+ pkts <- decodeOpenPGPInput path lbs+ rejectSecretKeyPackets "encrypt" path pkts+ rejectCriticalUnknownRecipientPackets path pkts+ tks <-+ runConduitRes $+ CL.sourceList pkts+ .| conduitToTKsDroppingEither+ .| CL.mapFoldable (join . hush)+ .| CC.sinkList+ normalized <- mapM (normalizeEncryptRecipientTK path) tks+ let selected =+ selectEncryptRecipients+ encPurpose+ (concatMap (tkToFunKeysAt cpt) normalized)+ packetFallback =+ nub+ ( concatMap tkToEncryptPayloads normalized+ ++ mapMaybe extractEncryptRecipientPayload pkts+ )+ pure $+ case encPurpose of+ EncryptForAny+ | null selected -> map payloadToFunKey packetFallback+ _ -> selected+ normalizeEncryptRecipientTK path tk =+ case processTK (Just cpt) tk of+ Left err ->+ failWith+ BadData+ ( "encrypt: invalid recipient certificate in "+ ++ path+ ++ ": "+ ++ show err+ )+ Right normalized ->+ if not+ (isTKTimeValid (posixSecondsToUTCTime (realToFrac cpt)) normalized)+ then+ failWith+ CertCannotEncrypt+ ("encrypt: recipient certificate in " ++ path ++ " is expired")+ else+ if not (primaryUserIDExpirationAllowsAt cpt normalized)+ then+ failWith+ CertCannotEncrypt+ ("encrypt: recipient certificate in " ++ path ++ " is expired")+ else pure normalized+ rejectCriticalUnknownRecipientPackets path =+ mapM_+ ( \pkt ->+ case pkt of+ OtherPacketPkt tag _+ | tag < 40 ->+ if isForwardCompatRecipientPacketTag tag+ then pure ()+ else+ failWith+ BadData+ ( "encrypt: invalid recipient certificate in "+ ++ path+ ++ ": critical unknown packet tag "+ ++ show tag+ )+ BrokenPacketPkt _ tag _+ | tag < 40 ->+ if isForwardCompatRecipientPacketTag tag+ then pure ()+ else+ failWith+ BadData+ ( "encrypt: invalid recipient certificate in "+ ++ path+ ++ ": critical unknown packet tag "+ ++ show tag+ )+ _ -> pure ()+ )+ isForwardCompatRecipientPacketTag tag = tag `elem` [5, 6, 7, 14]+ payloadToFunKey pkp = FunKey pkp Nothing S.empty [] [] False++primaryUserIDExpirationAllowsAt :: POSIXTime -> TKUnknown -> Bool+primaryUserIDExpirationAllowsAt now tk =+ case primaryUidSigs of+ [] -> True+ _ ->+ any+ (signatureKeyExpirationAllowsAt now primaryCreatedAt)+ primaryUidSigs+ where+ primaryCreatedAt = fromIntegral (_timestamp (fst (_tkuKey tk)))+ primaryUidSigs =+ [ sig+ | (_, sigs) <- _tkuUIDs tk+ , sig <- sigs+ , signatureMarksPrimaryUserId sig+ ]++signatureMarksPrimaryUserId :: SignaturePayload -> Bool+signatureMarksPrimaryUserId sig =+ any isPrimaryUIDSubpacket (signatureSubpackets sig)+ where+ isPrimaryUIDSubpacket (SigSubPacket _ (PrimaryUserId True)) = True+ isPrimaryUIDSubpacket _ = False++signatureKeyExpirationAllowsAt+ :: POSIXTime -> POSIXTime -> SignaturePayload -> Bool+signatureKeyExpirationAllowsAt now createdAt sig =+ case signatureKeyValiditySeconds sig of+ Nothing -> True+ Just 0 -> True+ Just validitySeconds -> now < createdAt + fromIntegral validitySeconds++signatureKeyValiditySeconds :: SignaturePayload -> Maybe Integer+signatureKeyValiditySeconds sig =+ listToMaybe+ [ fromIntegral secs+ | SigSubPacket _ (KeyExpirationTime (ThirtyTwoBitDuration secs)) <-+ signatureSubpackets sig+ ]++selectEncryptRecipients :: EncryptFor -> [FunKey] -> [FunKey]+selectEncryptRecipients encPurpose keys =+ chosen+ where+ supported = filter (supportsRecipientPKESKAlgorithm . fpkp) keys+ (matchingPurpose, unrestrictedPurpose) =+ partition (keyMatchesEncryptPurpose encPurpose . fkufs) supported+ chosen =+ case encPurpose of+ EncryptForAny+ | null matchingPurpose -> unrestrictedPurpose+ _ -> matchingPurpose++tkToEncryptPayloads :: TKUnknown -> [SomePKPayload]+tkToEncryptPayloads (TKUnknown (pkp, _) _ _ _ subs) =+ filter+ supportsRecipientPKESKAlgorithm+ (pkp : mapMaybe extractSubkeyPayload subs)+ where+ extractSubkeyPayload (PublicSubkeyPkt subPkp, _) = Just subPkp+ extractSubkeyPayload (SecretSubkeyPkt subPkp _, _) = Just subPkp+ extractSubkeyPayload _ = Nothing++extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload+extractEncryptRecipientPayload pkt =+ case pkt of+ PublicKeyPkt pkp+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp+ PublicSubkeyPkt pkp+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp+ SecretKeyPkt pkp _+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp+ SecretSubkeyPkt pkp _+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp+ _ -> Nothing++keyMatchesEncryptPurpose :: EncryptFor -> S.Set KeyFlag -> Bool+keyMatchesEncryptPurpose encPurpose keyFlags =+ not (S.null (keyFlags `S.intersection` encryptUsageFlags))+ where+ encryptUsageFlags =+ case encPurpose of+ EncryptForAny -> S.fromList [EncryptStorageKey, EncryptCommunicationsKey]+ EncryptForStorage -> S.singleton EncryptStorageKey+ EncryptForCommunications -> S.singleton EncryptCommunicationsKey++supportsRecipientPKESKAlgorithm :: SomePKPayload -> Bool+supportsRecipientPKESKAlgorithm pkp =+ _pkalgo pkp+ `elem` [ RSA+ , DeprecatedRSAEncryptOnly+ , ElgamalEncryptOnly+ , ECDH+ , X25519+ , X448+ ]+ && hasSupportedRecipientIdentifierLength pkp++hasSupportedRecipientIdentifierLength :: SomePKPayload -> Bool+hasSupportedRecipientIdentifierLength pkp =+ let keyIdentifierLen = BL.length (unFingerprint (fingerprint pkp))+ in keyIdentifierLen == 16+ || keyIdentifierLen == 20+ || keyIdentifierLen == 32++renderPKESKEncryptError :: PKESKEncryptError -> String+renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm symAlgo err) =+ "unsupported session-key algorithm "+ ++ show symAlgo+ ++ ": "+ ++ err+renderPKESKEncryptError (InvalidSessionKeyLength symAlgo expected got) =+ "invalid session-key length for "+ ++ show symAlgo+ ++ " (expected "+ ++ show expected+ ++ ", got "+ ++ show got+ ++ ")"+renderPKESKEncryptError (UnsupportedRecipientAlgorithm pka) =+ "unsupported recipient public-key algorithm: " ++ show pka+renderPKESKEncryptError (InvalidRecipientKeyMaterial pka err) =+ "invalid recipient key material for " ++ show pka ++ ": " ++ err+renderPKESKEncryptError (RecipientKdfFailure pka err) =+ "recipient KDF failure for " ++ show pka ++ ": " ++ err+renderPKESKEncryptError (RecipientKeyWrapFailure pka err) =+ "recipient key-wrap failure for " ++ show pka ++ ": " ++ err+renderPKESKEncryptError (PayloadBuildFailure err) = "payload build failure: " ++ err+renderPKESKEncryptError NoRecipientsProvided = "no recipients were provided"+renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) =+ "recipient capability selection failure: " ++ show err+renderPKESKEncryptError (InvalidRecipientIdentifier err) =+ "invalid recipient identifier: " ++ err++sopFailureForPKESKEncryptError :: PKESKEncryptError -> SopFailure+sopFailureForPKESKEncryptError err =+ case err of+ UnsupportedRecipientAlgorithm _ -> UnsupportedAsymmetricAlgo+ RecipientCapabilitySelectionFailure _ -> CertCannotEncrypt+ NoRecipientsProvided -> CertCannotEncrypt+ _ -> BadData++{- | Resolve a PKESK recipient key using two strategies depending on whether+the probe carries a wildcard recipient ID (eight zero bytes) or a real key+ID / fingerprint.++* Non-wildcard probes: the callback is invoked once for each PKESK attempt,+ so we do an idempotent lookup by recipient identifier from the full+ candidate list to avoid consuming keys needed by later PKESKs.++* Wildcard probes (all-zero legacy recipient ID): hOpenPGP retries the+ callback after failed unwrap attempts. We therefore pop one candidate from+ a shared queue on each callback invocation.+-}+selectRecipientKeyInfosByRecipientIdentifier+ :: [PKESKRecipientKey]+ -> KeyIdentifier+ -> PubKeyAlgorithm+ -> IO [PKESKRecipientKey]+selectRecipientKeyInfosByRecipientIdentifier keyInfos keyIdentifier pka =+ pure $+ case keyIdentifier of+ KeyIdentifierWildcard -> compatible+ KeyIdentifierEightOctet recipientKeyId ->+ filter (matchesLegacyRecipientKeyId recipientKeyId) compatible+ KeyIdentifierFingerprint recipientFingerprint ->+ filter+ (matchesRecipientIdentifier (unFingerprint recipientFingerprint))+ compatible+ where+ compatible =+ [ keyInfo+ | keyInfo <- keyInfos+ , supportsPKESKAlgorithm pka keyInfo+ ]++prioritizeDecryptablePKESKs+ :: [PKESKRecipientKey] -> [Pkt] -> [Pkt]+prioritizeDecryptablePKESKs keyInfos pkts =+ nonMatchingPrefix ++ matchingPrefix ++ suffix+ where+ (prefix, suffix) = break isEncryptedPayloadPacket pkts+ (matchingPrefix, nonMatchingPrefix) =+ partition+ ( \pkt ->+ case pkt of+ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)) ->+ any (matchesRecipientIdentifier rid) keyInfos+ PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ eoki _ _)) ->+ any (matchesLegacyRecipientKeyId eoki) keyInfos+ _ -> False+ )+ prefix++supportsPKESKAlgorithm+ :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool+supportsPKESKAlgorithm pka keyInfo =+ case pkeskRecipientSKey keyInfo of+ RSAPrivateKey {} -> pka == RSA || pka == DeprecatedRSAEncryptOnly+ ElGamalPrivateKey {} -> pka == ElgamalEncryptOnly+ ECDHPrivateKey {} -> pka == ECDH || pka == X25519+ X25519PrivateKey {} -> pka == X25519+ X448PrivateKey {} -> pka == X448+ UnknownSKey {} ->+ (pka == X25519 || pka == X448)+ && case pkeskRecipientPKPayload keyInfo of+ Just pkp -> _pkalgo pkp == pka+ Nothing -> False+ _ -> False++matchesRecipientIdentifier+ :: BL.ByteString -> PKESKRecipientKey -> Bool+matchesRecipientIdentifier rid keyInfo =+ case pkeskRecipientPKPayload keyInfo of+ Nothing -> False+ Just pkp ->+ let identifier = BL.toStrict rid+ fps = recipientFingerprintsForMatch pkp+ in any (identifier `elem`) (map recipientIdMatchVariants fps)++recipientFingerprintsForMatch :: SomePKPayload -> [B.ByteString]+recipientFingerprintsForMatch pkp =+ baseFp : maybeToList normalizedX25519Fp+ where+ baseFp = BL.toStrict (unFingerprint (fingerprint pkp))+ normalizedX25519Fp =+ BL.toStrict . unFingerprint . fingerprint+ <$> normalizeX25519CompatiblePKP pkp++normalizeX25519CompatiblePKP+ :: SomePKPayload -> Maybe SomePKPayload+normalizeX25519CompatiblePKP pkp =+ case _pubkey pkp of+ ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->+ Just+ ( PKPayload+ (_keyVersion pkp)+ (_timestamp pkp)+ (_v3exp pkp)+ X25519+ (_pubkey pkp)+ )+ _ -> Nothing++recipientIdMatchVariants :: B.ByteString -> [B.ByteString]+recipientIdMatchVariants fp =+ [ fp+ , B.cons 0x04 fp+ , B.cons 0x06 fp+ , B.cons 0xFE fp+ ]++matchesLegacyRecipientKeyId+ :: EightOctetKeyId -> PKESKRecipientKey -> Bool+matchesLegacyRecipientKeyId eoki keyInfo =+ case pkeskRecipientPKPayload keyInfo of+ Nothing -> False+ Just pkp ->+ case eightOctetKeyID pkp of+ Right keyId -> keyId == eoki+ Left _ -> False++decodeCiphertextInput :: BL.ByteString -> IO BL.ByteString+decodeCiphertextInput input = do+ decodedArmors <- decodeAsciiArmorInput "decrypt input" input+ case decodedArmors of+ Just armors ->+ case firstBy isArmorMessageBlock armors of+ Just (Armor ArmorMessage _ bs) -> return (BL.fromStrict (BLC8.toStrict bs))+ _ ->+ case firstBy isOpenPGPArmorBlock armors of+ Just _ ->+ failWith+ BadData+ "decrypt expects an armored OpenPGP message"+ _ -> return input+ Nothing -> return input++doInlineSign :: POSIXTime -> InlineSignOptions -> IO ()+doInlineSign pt InlineSignOptions {..} = do+ when (inlineSignNoArmor && inlineSignArmor) $+ failWith+ IncompatibleOptions+ "inline-sign: --armor and --no-armor are mutually exclusive"+ forM_+ inlineSignProfile+ ( \profile ->+ failWith+ UnsupportedOption+ ("inline-sign: unsupported option --profile=" ++ profile)+ )+ let inlineMode = fromMaybe InlineSignAsBinary inlineSignAs+ mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ when (inlineMode /= InlineSignAsBinary) $+ ensureUTF8TextInput "inline-sign" (BL.fromChunks mbs)+ signingPasswordsRaw <-+ loadPasswordFiles+ "inline-sign"+ "--with-key-password"+ inlineSignKeyPasswords+ let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw+ ks <- loadSigningKeys inlineSignKeyFiles signingPasswords+ processedKeys <- mapM (normalizeSigningKey pt) ks+ let ts = ThirtyTwoBitTimeStamp (floor pt)+ payloadRaw = BL.fromChunks mbs+ funkeys = concatMap (tkToFunKeysAt pt) processedKeys+ signingKeys = filter isInlineRSASigner funkeys+ inlineSignHash =+ selectSigningHash signingKeys [] legacySigningHashFallbackOrder+ when (null signingKeys) $+ failWith MissingInput "inline-sign: no signing-capable key found"+ sigs <-+ mapM+ ( signInlineData+ ts+ (inlineSignSignatureMode inlineMode)+ inlineSignHash+ payloadRaw+ )+ signingKeys+ case inlineMode of+ InlineSignAsClearSigned -> doInlineSignCleartext inlineSignHash payloadRaw sigs+ InlineSignAsText -> doInlineSignText payloadRaw sigs+ InlineSignAsBinary -> doInlineSignBinary payloadRaw sigs+ where+ inlineSignSignatureMode mode =+ case mode of+ InlineSignAsBinary -> AsBinary+ InlineSignAsText -> AsText+ InlineSignAsClearSigned -> AsText+ doInlineSignCleartext inlineSignHash payloadRaw sigs = do+ when inlineSignNoArmor $+ failWith+ IncompatibleOptions+ "inline-sign --as=clearsigned requires armored output"+ let cleartextPayload =+ if not (BL.null payloadRaw) && BL.last payloadRaw == 0x0a+ then payloadRaw <> BL.singleton 0x0a+ else payloadRaw+ sigBytes = runPut $ mapM_ (Bin.put . SignaturePkt) sigs+ hashHeader = ("Hash", hashAlgorithmHeaderName inlineSignHash)+ clearSigned =+ ClearSigned+ [hashHeader]+ (BLC8.fromStrict (BL.toStrict cleartextPayload))+ (Armor ArmorSignature [] (BLC8.fromStrict (BL.toStrict sigBytes)))+ BLC8.putStr (AA.encodeLazy [clearSigned])+ doInlineSignText payloadRaw sigs =+ doInlineSignMessage UTF8Data payloadRaw sigs+ doInlineSignBinary payloadRaw sigs = do+ doInlineSignMessage BinaryData payloadRaw sigs+ doInlineSignMessage literalDataType payloadRaw sigs = do+ let pktBytes =+ runPut $+ Bin.put+ ( Block+ ( map SignaturePkt sigs+ ++ [LiteralDataPkt literalDataType BL.empty 0 payloadRaw]+ )+ )+ BL.putStr $+ if not inlineSignNoArmor && not inlineSignArmor+ then AA.encodeLazy [Armor ArmorMessage [] pktBytes]+ else+ if inlineSignArmor+ then AA.encodeLazy [Armor ArmorMessage [] pktBytes]+ else pktBytes++inlineSignModeReader :: String -> Either String InlineSignMode+inlineSignModeReader "binary" = Right InlineSignAsBinary+inlineSignModeReader "text" = Right InlineSignAsText+inlineSignModeReader "clearsigned" = Right InlineSignAsClearSigned+inlineSignModeReader _ =+ Left "signature mode must be one of: binary, text, clearsigned"++isInlineSigningCapable :: FunKey -> Bool+isInlineSigningCapable k =+ (S.null (fkufs k) || S.member SignDataKey (fkufs k))+ && case fmska k of+ Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True+ Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True+ Just (SUUnencrypted (UnknownSKey _) _) ->+ isEd25519PKA (_pkalgo (fpkp k))+ || isEdDSAPKA (_pkalgo (fpkp k))+ || isEd448PKA (_pkalgo (fpkp k))+ _ -> False++-- Legacy alias.+isInlineRSASigner :: FunKey -> Bool+isInlineRSASigner = isInlineSigningCapable++signInlineData+ :: ThirtyTwoBitTimeStamp+ -> AsBinaryText+ -> HashAlgorithm+ -> BL.ByteString+ -> FunKey+ -> IO SignaturePayload+signInlineData ts mode signHash payload k =+ do+ issuerPackets <- inlineUnhashed (fpkp k)+ signWithKey+ "inline-sign"+ (fpkp k)+ sigType+ signHash+ (inlineHashed (fpkp k) ts)+ issuerPackets+ payload+ (fmska k)+ where+ sigType =+ case mode of+ AsBinary -> BinarySig+ AsText -> CanonicalTextSig++inlineHashed+ :: SomePKPayload -> ThirtyTwoBitTimeStamp -> [SigSubPacket]+inlineHashed pkp ts =+ [ SigSubPacket False (SigCreationTime ts)+ , SigSubPacket+ False+ ( IssuerFingerprint+ (issuerFingerprintVersionFor pkp)+ (fingerprint pkp)+ )+ ]++inlineUnhashed :: SomePKPayload -> IO [SigSubPacket]+inlineUnhashed pkp =+ issuerSubpacketsFor "inline-sign" pkp++doInlineDetach :: POSIXTime -> InlineDetachOptions -> IO ()+doInlineDetach _ InlineDetachOptions {..} = do+ ensureOutputPathAvailable "inline-detach" inlineDetachOutputSigs+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ (msgData, sigPkts) <- splitInlineSigned input+ writeDetachedSignatures+ inlineDetachNoArmor+ inlineDetachOutputSigs+ sigPkts+ BL.putStr msgData++splitInlineSigned :: BL.ByteString -> IO (BL.ByteString, [Pkt])+splitInlineSigned lbs = do+ decodedArmors <- decodeAsciiArmorInput "inline-detach input" lbs+ case decodedArmors of+ Just armors ->+ case firstBy isInlineSignedArmorCandidate armors of+ Just (Armor ArmorMessage _ bs) ->+ parseOpenPGPPackets+ "inline-detach armored message"+ (BL.fromStrict (BLC8.toStrict bs))+ >>= splitInlineSignedPackets+ Just (ClearSigned headers cleartext signatureArmor) -> do+ validateClearSignedHeaders headers+ sigPkts <- clearSignedSignaturePackets signatureArmor+ return (BL.fromStrict (BLC8.toStrict cleartext), sigPkts)+ _ ->+ parseOpenPGPPackets "inline-detach input" lbs+ >>= splitInlineSignedPackets+ Nothing ->+ parseOpenPGPPackets "inline-detach input" lbs+ >>= splitInlineSignedPackets++firstBy :: (a -> Bool) -> [a] -> Maybe a+firstBy predicate = find predicate++decodeAsciiArmorInput+ :: String -> BL.ByteString -> IO (Maybe [Armor])+decodeAsciiArmorInput context input =+ case validateAsciiArmorEnvelope input of+ Just err ->+ failWith BadData (context ++ ": malformed ASCII armor: " ++ err)+ Nothing -> do+ let primaryDecode = AA.decodeLazy input :: Either String [Armor]+ case primaryDecode of+ Right (_ : _) -> pure (Just (fromRight [] primaryDecode))+ _ -> do+ let normalizedInput = normalizeAsciiArmorForLenientDecode input+ fallbackDecode =+ if normalizedInput /= input+ then AA.decodeLazy normalizedInput :: Either String [Armor]+ else primaryDecode+ case fallbackDecode of+ Right []+ | looksLikeAsciiArmor input ->+ failWith+ BadData+ (context ++ ": malformed ASCII armor: no armor blocks found")+ Right [] -> pure Nothing+ Right armors -> pure (Just armors)+ Left err+ | looksLikeAsciiArmor input ->+ failWith BadData (context ++ ": malformed ASCII armor: " ++ err)+ | otherwise -> pure Nothing++normalizeAsciiArmorForLenientDecode+ :: BL.ByteString -> BL.ByteString+normalizeAsciiArmorForLenientDecode input+ | not (looksLikeAsciiArmor input) = input+ | otherwise =+ BL.fromStrict+ . TE.encodeUtf8+ . T.unlines+ . normalizeAsciiArmorLines+ $ T.lines normalizedLineEndings+ where+ normalizedLineEndings =+ T.replace+ (T.pack "\r")+ (T.pack "\n")+ ( T.replace+ (T.pack "\r\n")+ (T.pack "\n")+ (TE.decodeUtf8 (BL.toStrict input))+ )++data LenientArmorDecodeState+ = LenientOutsideArmor+ | LenientArmorHeaders Bool Bool+ | LenientArmorBody Bool++normalizeAsciiArmorLines :: [Text] -> [Text]+normalizeAsciiArmorLines = go LenientOutsideArmor+ where+ go _ [] = []+ go state (line : rest) =+ let trimmedLine = T.dropWhileEnd isSpace line+ whitespaceOnly = T.all isSpace line+ beginLabel = beginArmorLabelText trimmedLine+ isBegin = isJust beginLabel+ isEnd = T.isPrefixOf (T.pack "-----END PGP ") trimmedLine+ hasHeaderSeparator = T.any (== ':') trimmedLine+ in case state of+ LenientOutsideArmor+ | isBegin ->+ let isClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")+ shouldStripHeaders = not isClearSigned+ in trimmedLine+ : go (LenientArmorHeaders shouldStripHeaders isClearSigned) rest+ | otherwise -> trimmedLine : go LenientOutsideArmor rest+ LenientArmorHeaders stripHeaders isClearSigned+ | whitespaceOnly ->+ T.empty : go (LenientArmorBody isClearSigned) rest+ | isEnd -> T.empty : trimmedLine : go LenientOutsideArmor rest+ | stripHeaders && hasHeaderSeparator ->+ go (LenientArmorHeaders stripHeaders isClearSigned) rest+ | otherwise ->+ trimmedLine : go (LenientArmorBody isClearSigned) rest+ LenientArmorBody isClearSigned+ | isEnd -> trimmedLine : go LenientOutsideArmor rest+ | isBegin ->+ let nestedClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")+ shouldStripHeaders = not nestedClearSigned+ in trimmedLine+ : go+ (LenientArmorHeaders shouldStripHeaders nestedClearSigned)+ rest+ | otherwise ->+ let bodyLine =+ if isClearSigned+ then line+ else trimmedLine+ in bodyLine : go (LenientArmorBody isClearSigned) rest++beginArmorLabelText :: Text -> Maybe Text+beginArmorLabelText line = do+ rest <- T.stripPrefix (T.pack "-----BEGIN PGP ") line+ T.stripSuffix (T.pack "-----") rest++validateClearSignedHeaders :: [(String, String)] -> IO ()+validateClearSignedHeaders headers =+ unless (all (isAllowedHeaderKey . fst) headers) $+ failWith+ BadData+ "cleartext signed message contains unsupported armor headers"+ where+ isAllowedHeaderKey hkey =+ map toLower hkey `elem` ["hash"]++validateClearSignedEnvelopeBounds :: BL.ByteString -> IO ()+validateClearSignedEnvelopeBounds input = do+ let text = TE.decodeUtf8With lenientDecode (BL.toStrict input)+ normalized = T.replace (T.pack "\r") (T.pack "") text+ ls = T.lines normalized+ beginMarker = T.pack "-----BEGIN PGP SIGNED MESSAGE-----"+ endMarker = T.pack "-----END PGP SIGNATURE-----"+ firstBegin = findIndex ((== beginMarker) . T.strip) ls+ hasVisibleText line = not (T.all isSpace line)+ findIndexFrom start predicate =+ fmap (+ start) (findIndex predicate (drop start ls))+ case firstBegin of+ Nothing -> pure ()+ Just beginIx -> do+ when (any hasVisibleText (take beginIx ls)) $+ failWith+ BadData+ "cleartext signed message has non-whitespace text before armor header"+ case findIndexFrom beginIx ((== endMarker) . T.strip) of+ Nothing -> pure ()+ Just endIx ->+ when (any hasVisibleText (drop (endIx + 1) ls)) $+ failWith+ BadData+ "cleartext signed message has non-whitespace text after signature block"++looksLikeAsciiArmor :: BL.ByteString -> Bool+looksLikeAsciiArmor input =+ BLC8.pack "-----BEGIN PGP "+ `BL.isPrefixOf` BLC8.dropWhile isAsciiArmorLeadingWhitespace input++isAsciiArmorLeadingWhitespace :: Char -> Bool+isAsciiArmorLeadingWhitespace c = c `elem` [' ', '\t', '\r', '\n']++validateAsciiArmorEnvelope :: BL.ByteString -> Maybe String+validateAsciiArmorEnvelope input+ | not (looksLikeAsciiArmor input) = Nothing+ | otherwise =+ validateArmorBlocks+ (BLC8.lines (BLC8.dropWhile isAsciiArmorLeadingWhitespace input))++validateArmorBlocks :: [BL.ByteString] -> Maybe String+validateArmorBlocks [] = Nothing+validateArmorBlocks (line : rest) =+ case beginArmorLabel line of+ -- UPSTREAM: openpgp-asciiarmor should export detectCleartextSignedBlock helper+ -- to encapsulate this RFC 4880 cleartext signature framework detection+ Just "SIGNED MESSAGE" -> validateClearSignedBlock rest+ Just label -> validateBinaryArmorBlock label rest+ Nothing -> Nothing++validateClearSignedBlock :: [BL.ByteString] -> Maybe String+validateClearSignedBlock ls =+ case break hasBeginArmorLabel ls of+ (_, []) ->+ Just+ "cleartext signed message is missing an armored signature block"+ (_, beginLine : rest) ->+ case beginArmorLabel beginLine of+ Just "SIGNATURE" -> validateBinaryArmorBlock "SIGNATURE" rest+ Just label ->+ Just+ ( "cleartext signed message must be followed by a PGP SIGNATURE block, found PGP "+ ++ label+ )+ Nothing ->+ Just+ "cleartext signed message has an invalid armored signature header"++validateBinaryArmorBlock+ :: String -> [BL.ByteString] -> Maybe String+validateBinaryArmorBlock label ls =+ case break hasEndArmorLabel ls of+ (_, []) -> Just ("missing END PGP " ++ label ++ " footer")+ (_, endLine : rest) ->+ case endArmorLabel endLine of+ Just endLabel+ | endLabel == label -> validateArmorBlocks rest+ | otherwise ->+ Just+ ( "mismatched footer: expected END PGP "+ ++ label+ ++ ", found END PGP "+ ++ endLabel+ )+ Nothing -> Just ("invalid END PGP " ++ label ++ " footer")++hasBeginArmorLabel :: BL.ByteString -> Bool+hasBeginArmorLabel = isJust . beginArmorLabel++hasEndArmorLabel :: BL.ByteString -> Bool+hasEndArmorLabel = isJust . endArmorLabel++beginArmorLabel :: BL.ByteString -> Maybe String+beginArmorLabel = armorBoundaryLabel "-----BEGIN PGP " "-----"++endArmorLabel :: BL.ByteString -> Maybe String+endArmorLabel = armorBoundaryLabel "-----END PGP " "-----"++armorBoundaryLabel+ :: String -> String -> BL.ByteString -> Maybe String+armorBoundaryLabel prefix suffix line = do+ rest <- stripPrefix prefix (BLC8.unpack line)+ if suffix `isSuffixOf` rest+ then pure (take (length rest - length suffix) rest)+ else Nothing++isOpenPGPArmorBlock :: Armor -> Bool+isOpenPGPArmorBlock (Armor _ _ _) = True+isOpenPGPArmorBlock _ = False++isArmorMessageBlock :: Armor -> Bool+isArmorMessageBlock (Armor ArmorMessage _ _) = True+isArmorMessageBlock _ = False++isDetachedSignatureArmor :: Armor -> Bool+isDetachedSignatureArmor (Armor ArmorSignature _ _) = True+isDetachedSignatureArmor _ = False++isDetachedSignatureUnsupportedArmor :: Armor -> Bool+isDetachedSignatureUnsupportedArmor (Armor _ _ _) = True+isDetachedSignatureUnsupportedArmor ClearSigned {} = True++isClearSignedArmor :: Armor -> Bool+isClearSignedArmor ClearSigned {} = True+isClearSignedArmor _ = False++isInlineSignedArmorCandidate :: Armor -> Bool+isInlineSignedArmorCandidate (Armor ArmorMessage _ _) = True+isInlineSignedArmorCandidate ClearSigned {} = True+isInlineSignedArmorCandidate _ = False++splitInlineSignedPackets :: [Pkt] -> IO (BL.ByteString, [Pkt])+splitInlineSignedPackets pkts = do+ let msgPkts = [p | p@LiteralDataPkt {} <- pkts]+ sigPkts = [p | p@SignaturePkt {} <- pkts]+ case msgPkts of+ [LiteralDataPkt _ _ _ payload]+ | null sigPkts ->+ failWith BadData "inline-detach input has no signatures"+ | otherwise -> return (payload, sigPkts)+ [] ->+ failWith+ BadData+ "inline-detach input has no literal message payload"+ _ ->+ failWith+ BadData+ "inline-detach input contains multiple literal payloads"++writeDetachedSignatures :: Bool -> String -> [Pkt] -> IO ()+writeDetachedSignatures noArmor outPath sigPkts = do+ let sigBytes = runPut $ mapM_ Bin.put sigPkts+ out =+ if noArmor+ then sigBytes+ else+ BL.fromStrict+ (BLC8.toStrict (AA.encodeLazy [Armor ArmorSignature [] sigBytes]))+ BL.writeFile outPath out++doListProfiles :: ListProfilesOptions -> IO ()+doListProfiles lpos =+ case profileSubcommand lpos of+ "generate-key" ->+ putStr+ "default: implementation defaults\nrfc4880: RSA-4096 interoperability-focused key generation\ncompatibility: broad interoperability defaults (alias of rfc4880)\nsecurity: security-oriented key generation\nperformance: performance-oriented key generation\n"+ "encrypt" ->+ putStr+ "default: implementation defaults (alias of rfc9580, security, and performance)\nrfc9580: RFC 9580 packet format preferences\nrfc4880: RFC 4880 packet format preferences\ncompatibility: broad interoperability defaults (alias of rfc4880)\n"+ _ ->+ failWith+ UnsupportedProfile+ "Subcommand does not support profiles"
hopenpgp-tools.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hopenpgp-tools-version: 0.25.1+version: 0.25.2 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: https://salsa.debian.org/clint/hOpenPGP-tools@@ -129,4 +129,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hopenpgp-tools.git- tag: hopenpgp-tools/0.25.1+ tag: hopenpgp-tools/0.25.2
hot.hs view
@@ -15,11 +15,13 @@ -- -- 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 RecordWildCards #-} import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA-import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..))+import Codec.Encryption.OpenPGP.ASCIIArmor.Types+ ( Armor (..)+ , ArmorType (..)+ ) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types import Control.Applicative (optional)@@ -32,148 +34,165 @@ import Data.Binary.Get (Get) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.Conduit (ConduitM, (.|), runConduitRes)+import Data.Conduit (ConduitM, runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Filter- ( FilterPredicates(RPFilterPredicate)- , conduitPktFilter- )+ ( FilterPredicates (RPFilterPredicate)+ , conduitPktFilter+ ) import Data.Conduit.Serialization.Binary (conduitGet, conduitPut) import Data.Void (Void) import qualified Data.Yaml as Y-import HOpenPGP.Tools.Common.Armor (doDeArmor)-import HOpenPGP.Tools.Common.Common (banner, prependAuto, versioner, warranty)-import HOpenPGP.Tools.Common.Parser (parsePExp)--import System.IO- ( BufferMode(..)- , Handle- , hFlush- , hPutStrLn- , hSetBuffering- , stderr- , stdin- , stdout- )-import System.Exit (exitFailure)--import Prettyprinter- ( Pretty- , (<+>)- , group- , hardline- , list- , pretty- , softline- )-import Prettyprinter.Render.Text (hPutDoc) import Options.Applicative.Builder- ( argument- , command- , eitherReader- , footerDoc- , headerDoc- , help- , helpDoc- , info- , long- , metavar- , option- , prefs- , progDesc- , showDefaultWith- , showHelpOnError- , str- , strOption- , value- )-import Options.Applicative.Extra (customExecParser, helper, hsubparser)+ ( argument+ , command+ , eitherReader+ , footerDoc+ , headerDoc+ , help+ , helpDoc+ , info+ , long+ , metavar+ , option+ , prefs+ , progDesc+ , showDefaultWith+ , showHelpOnError+ , str+ , strOption+ , value+ )+import Options.Applicative.Extra+ ( customExecParser+ , helper+ , hsubparser+ ) import Options.Applicative.Types (Parser)+import Prettyprinter+ ( Pretty+ , group+ , hardline+ , list+ , pretty+ , softline+ , (<+>)+ )+import Prettyprinter.Render.Text (hPutDoc)+import System.Exit (exitFailure)+import System.IO+ ( BufferMode (..)+ , Handle+ , hFlush+ , hPutStrLn+ , hSetBuffering+ , stderr+ , stdin+ , stdout+ ) +import HOpenPGP.Tools.Common.Armor (doDeArmor)+import HOpenPGP.Tools.Common.Common+ ( banner+ , prependAuto+ , versioner+ , warranty+ )+import HOpenPGP.Tools.Common.Parser (parsePExp)+ data Command- = DumpC DumpOptions- | DeArmorC- | ArmorC ArmoringOptions- | FilterC FilteringOptions+ = DumpC DumpOptions+ | DeArmorC+ | ArmorC ArmoringOptions+ | FilterC FilteringOptions -data DumpOptions =- DumpOptions+data DumpOptions+ = DumpOptions { outputformat :: DumpOutputFormat } -data FilteringOptions =- FilteringOptions+data FilteringOptions+ = FilteringOptions { fExpression :: String } data DumpOutputFormat- = DumpPretty- | DumpJSON- | DumpYAML- | DumpShow- deriving (Bounded, Enum, Read, Show)+ = DumpPretty+ | DumpJSON+ | DumpYAML+ | DumpShow+ deriving (Bounded, Enum, Read, Show) doDump :: DumpOptions -> IO () doDump DumpOptions {..} =- runConduitRes $- CB.sourceHandle stdin .| conduitGet (get :: Get Pkt) .|- case outputformat of- DumpPretty -> prettyPrinter- DumpJSON -> jsonSink- DumpYAML -> yamlSink- DumpShow -> printer+ runConduitRes $+ CB.sourceHandle stdin+ .| conduitGet (get :: Get Pkt)+ .| case outputformat of+ DumpPretty -> prettyPrinter+ DumpJSON -> jsonSink+ DumpYAML -> yamlSink+ DumpShow -> printer -- Print every input value to standard output.-printer :: (Show a, MonadIO m) => ConduitM a Void m ()+printer :: (MonadIO m, Show a) => ConduitM a Void m () printer = CL.mapM_ (liftIO . print) -prettyPrinter :: (Pretty a, MonadIO m) => ConduitM a Void m ()+prettyPrinter :: (MonadIO m, Pretty a) => ConduitM a Void m () prettyPrinter =- CL.mapM_ (liftIO . hPutDoc stdout . (<> hardline) . group . pretty)+ CL.mapM_+ (liftIO . hPutDoc stdout . (<> hardline) . group . pretty) jsonSink :: (A.ToJSON a, MonadIO m) => ConduitM a Void m () jsonSink = CL.mapM_ (liftIO . BL.putStr . flip BL.snoc 0x0a . A.encode) -yamlSink :: (Y.ToJSON a, MonadIO m) => ConduitM a Void m ()+yamlSink :: (MonadIO m, Y.ToJSON a) => ConduitM a Void m () yamlSink = CL.mapM_ (liftIO . B.putStr . flip B.snoc 0x0a . Y.encode) doFilter :: FilteringOptions -> IO () doFilter fo =- parseExpressions fo >>= \parsed ->- case parsed of- Left err -> dieHot err- Right predicates ->- runConduitRes $- CB.sourceHandle stdin .| conduitGet (get :: Get Pkt) .|- conduitPktFilter predicates .|- CL.map put .|- conduitPut .|- CB.sinkHandle stdout+ parseExpressions fo >>= \parsed ->+ case parsed of+ Left err -> dieHot err+ Right predicates ->+ runConduitRes $+ CB.sourceHandle stdin+ .| conduitGet (get :: Get Pkt)+ .| conduitPktFilter predicates+ .| CL.map put+ .| conduitPut+ .| CB.sinkHandle stdout doP :: Parser DumpOptions doP =- DumpOptions <$>- option- (prependAuto "Dump")- (long "output-format" <>- metavar "FORMAT" <>- value DumpPretty <> showDefaultWith (drop 4 . show) <> ofHelp)+ DumpOptions+ <$> option+ (prependAuto "Dump")+ ( long "output-format"+ <> metavar "FORMAT"+ <> value DumpPretty+ <> showDefaultWith (drop 4 . show)+ <> ofHelp+ ) where ofHelp =- helpDoc . Just $- pretty "output format" <>- hardline <> list (map (pretty . drop 4 . show) ofchoices)+ helpDoc . Just $+ pretty "output format"+ <> hardline+ <> list (map (pretty . drop 4 . show) ofchoices) ofchoices = [minBound .. maxBound] :: [DumpOutputFormat] foP :: Parser FilteringOptions foP =- FilteringOptions <$> argument str (metavar "EXPRESSION" <> filterTargetHelp)+ FilteringOptions+ <$> argument str (metavar "EXPRESSION" <> filterTargetHelp) where filterTargetHelp =- helpDoc . Just $- pretty "packet filter expression" <+>- softline <> pretty "see source for current syntax"+ helpDoc . Just $+ pretty "packet filter expression"+ <+> softline+ <> pretty "see source for current syntax" dispatch :: Command -> IO () dispatch c = (banner' stderr >> hFlush stderr) >> dispatch' c@@ -185,88 +204,105 @@ main :: IO () main = do- hSetBuffering stderr LineBuffering- customExecParser- (prefs showHelpOnError)- (info- (helper <*> versioner "hot" <*> cmd)- (headerDoc (Just (banner "hot")) <>- progDesc "hOpenPGP OpenPGP-message Tool" <>- footerDoc (Just (warranty "hot")))) >>=- dispatch+ hSetBuffering stderr LineBuffering+ customExecParser+ (prefs showHelpOnError)+ ( info+ (helper <*> versioner "hot" <*> cmd)+ ( headerDoc (Just (banner "hot"))+ <> progDesc "hOpenPGP OpenPGP-message Tool"+ <> footerDoc (Just (warranty "hot"))+ )+ )+ >>= dispatch cmd :: Parser Command cmd =- hsubparser- (command "armor" (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout")) <>- command- "dearmor"- (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout")) <>- command- "dump"- (info (DumpC <$> doP) (progDesc "Dump OpenPGP packets from stdin")) <>- command- "filter"- (info- (FilterC <$> foP)- (progDesc "Filter some packets from stdin to stdout")))+ hsubparser+ ( command+ "armor"+ (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout"))+ <> command+ "dearmor"+ (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))+ <> command+ "dump"+ (info (DumpC <$> doP) (progDesc "Dump OpenPGP packets from stdin"))+ <> command+ "filter"+ ( info+ (FilterC <$> foP)+ (progDesc "Filter some packets from stdin to stdout")+ )+ ) banner' :: Handle -> IO ()-banner' h = hPutDoc h (banner "hot" <> hardline <> warranty "hot" <> hardline)+banner' h =+ hPutDoc+ h+ (banner "hot" <> hardline <> warranty "hot" <> hardline) -parseExpressions :: FilteringOptions -> IO (Either String (FilterPredicates r a))+parseExpressions+ :: FilteringOptions -> IO (Either String (FilterPredicates r a)) parseExpressions FilteringOptions {..} = do- parsed <- parseE fExpression- pure (RPFilterPredicate <$> parsed)+ parsed <- parseE fExpression+ pure (RPFilterPredicate <$> parsed) where parseE e = do- parsed <- try (evaluate (parsePExp e :: Either String (Reader Pkt Bool))) :: IO (Either ErrorCall (Either String (Reader Pkt Bool)))- pure $- case parsed of- Left err -> Left (show (err :: ErrorCall))- Right value -> value+ parsed <-+ try (evaluate (parsePExp e :: Either String (Reader Pkt Bool)))+ :: IO (Either ErrorCall (Either String (Reader Pkt Bool)))+ pure $+ case parsed of+ Left err -> Left (show (err :: ErrorCall))+ Right v -> v armorTypes :: [(String, ArmorType)] armorTypes =- [ ("message", ArmorMessage)- , ("pubkeyblock", ArmorPublicKeyBlock)- , ("privkeyblock", ArmorPrivateKeyBlock)- , ("signature", ArmorSignature)- ]+ [ ("message", ArmorMessage)+ , ("pubkeyblock", ArmorPublicKeyBlock)+ , ("privkeyblock", ArmorPrivateKeyBlock)+ , ("signature", ArmorSignature)+ ] armorTypeReader :: String -> Either String ArmorType armorTypeReader = note "unknown armor type" . flip lookup armorTypes aoP :: Parser ArmoringOptions aoP =- ArmoringOptions <$>- optional- (strOption- (long "comment" <> metavar "COMMENT" <> help "ASCII armor Comment field")) <*>- option- (eitherReader armorTypeReader)- (long "armor-type" <> metavar "ARMORTYPE" <> armortypeHelp)+ ArmoringOptions+ <$> optional+ ( strOption+ ( long "comment"+ <> metavar "COMMENT"+ <> help "ASCII armor Comment field"+ )+ )+ <*> option+ (eitherReader armorTypeReader)+ (long "armor-type" <> metavar "ARMORTYPE" <> armortypeHelp) where armortypeHelp =- helpDoc . Just $- pretty "ASCII armor type" <>- softline <> list (map (pretty . fst) armorTypes)+ helpDoc . Just $+ pretty "ASCII armor type"+ <> softline+ <> list (map (pretty . fst) armorTypes) -data ArmoringOptions =- ArmoringOptions+data ArmoringOptions+ = ArmoringOptions { comment :: Maybe String , armortype :: ArmorType } doArmor :: ArmoringOptions -> IO () doArmor ArmoringOptions {..} = do- m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- let a =- Armor- armortype- (maybe [] (\x -> [("Comment", x)]) comment)- (BL.fromChunks m)- BL.putStr $ AA.encodeLazy [a]+ m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ let a =+ Armor+ armortype+ (maybe [] (\x -> [("Comment", x)]) comment)+ (BL.fromChunks m)+ BL.putStr $ AA.encodeLazy [a] dieHot :: String -> IO a dieHot msg = hPutStrLn stderr msg >> exitFailure