hopenpgp-tools 0.24 → 0.25
raw patch · 7 files changed
+5515/−707 lines, 7 filesdep +networkdep ~basedep ~openpgp-asciiarmor
Dependencies added: network
Dependency ranges changed: base, openpgp-asciiarmor
Files
- HOpenPGP/Tools/Common.hs +1/−0
- HOpenPGP/Tools/TKUtils.hs +5/−3
- hkt.hs +120/−88
- hokey.hs +440/−8
- hop.hs +4910/−593
- hopenpgp-tools.cabal +12/−6
- hot.hs +27/−9
HOpenPGP/Tools/Common.hs view
@@ -15,6 +15,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>.+ module HOpenPGP.Tools.Common ( banner , versioner
HOpenPGP/Tools/TKUtils.hs view
@@ -22,20 +22,22 @@ import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Signatures- ( verifyAgainstKeys+ ( VerificationError+ , verifyAgainstKeys , verifySigWith , verifyUnknownTKWith ) import Codec.Encryption.OpenPGP.Types import Control.Arrow (second) import Control.Error.Util (hush)+import Control.Lens ((^.), _1) import Data.Bifunctor (first) import Data.List (sortOn) import Data.Maybe (listToMaybe, mapMaybe) import Data.Ord (Down(..)) import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) --- should this fail or should verifyTKWith fail if there are no self-sigs?+-- 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@@ -59,7 +61,7 @@ sigcts (SigV4 _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs sigcts (SigV6 _ _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs sigcts _ = []- pkp = fst (_tkuKey key)+ pkp = key ^. tkuKey . _1 alleged = filter (\x -> assI x || assIFP x) sigCreationTimeFromSubpacket (SigSubPacket _ (SigCreationTime x)) = Just x sigCreationTimeFromSubpacket _ = Nothing
hkt.hs view
@@ -16,9 +16,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-} import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)@@ -30,12 +28,13 @@ import Codec.Encryption.OpenPGP.Signatures ( verifyAgainstKeyring , verifySigWith- , verifyTKWith+ , verifyUnknownTKWith ) import Codec.Encryption.OpenPGP.Types import Control.Applicative ((<|>), optional) import Control.Arrow ((&&&))-import Control.Lens ((^.), (^..), _1, _2, (&))+import Control.Exception (ErrorCall, evaluate, try)+import Control.Lens ((^.), (^..), _1, _2) import Control.Monad.Trans.Except (except, runExcept) import Control.Monad.Trans.Resource (MonadResource, MonadThrow) import qualified Data.Aeson as A@@ -43,14 +42,17 @@ import Data.Binary.Put (runPut) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.Conduit (ConduitM, ConduitT, (.|), 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 )-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping, sinkPublicKeyringMap)+import Data.Conduit.OpenPGP.Keyring+ ( conduitToTKsDropping+ , sinkPublicKeyringMap+ ) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Data.Lens (biplate) import Data.Either (rights)@@ -62,7 +64,6 @@ import Data.GraphViz.Types (printDotGraph) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap-import qualified Data.IxSet.Typed as IxSet import Data.List (nub, sort) import Data.Map (Map) import qualified Data.Map as Map@@ -70,6 +71,7 @@ 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.Tuple (swap) import qualified Data.Yaml as Y@@ -84,7 +86,7 @@ ) import HOpenPGP.Tools.Parser (parseTKExp) import System.Directory (getHomeDirectory)-+import System.Exit (exitFailure) import Options.Applicative.Builder ( argument , auto@@ -111,15 +113,18 @@ import Prettyprinter.Render.Text (hPutDoc, putDoc) import Prettyprinter ((<+>), fillSep, hardline, list, pretty)-import System.IO (BufferMode(..), Handle, hFlush, hSetBuffering, stderr)+import qualified Prettyprinter.Render.Text as PPA+import Prettyprinter (layoutPretty, defaultLayoutOptions)+import System.IO (BufferMode(..), Handle, hFlush, hPutStrLn, hSetBuffering, stderr) grabMatchingKeysConduit :: (MonadResource m, MonadThrow m) => FilePath -> Bool+ -> FilterPredicates Void TKUnknown -> Text -> ConduitM () TKUnknown m ()-grabMatchingKeysConduit fp filt srch =+grabMatchingKeysConduit fp filt ufp srch = CB.sourceFile fp .| conduitGet get .| conduitToTKsDropping .| (if filt then conduitTKFilter ufp@@ -131,17 +136,25 @@ return (keyMatchesUIDSubString srch tk) efp = (except . parseFingerprint) srch eeok = (except . parseEightOctetKeyId) srch- ufp = RTKFilterPredicate (parseE srch)- parseE =- either (error . ("filter parse error: " ++)) id . parseTKExp . T.unpack -- this should be more specialized -grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TK 'PublicTK]+grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TKUnknown] grabMatchingKeys fp filt srch =- runConduitRes $ grabMatchingKeysConduit fp filt srch .| CL.map fromUnknownToPublicTK .| CL.consume+ parseFilterPredicateIO srch >>= \parsed ->+ case parsed of+ Left err -> dieHKT err+ Right ufp ->+ runConduitRes $ grabMatchingKeysConduit fp filt ufp srch .| CL.consume -grabMatchingKeysKeyring :: FilePath -> Bool -> Text -> IO PublicKeyring-grabMatchingKeysKeyring fp filt srch =- runConduitRes $ grabMatchingKeysConduit fp filt srch .| CL.map fromUnknownToPublicTK .| sinkPublicKeyringMap+grabMatchingPublicKeyring :: [TKUnknown] -> IO PublicKeyring+grabMatchingPublicKeyring keys =+ 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 data Key = Key@@ -164,12 +177,12 @@ instance A.ToJSON TKey -tkToTKey :: TK 'PublicTK -> TKey+tkToTKey :: TKUnknown -> TKey tkToTKey tk = TKey- { publickey = mkey (tk ^. tkPrimaryKey & keyPktPKPayload)- , uids = tk ^. tkUIDs ^.. traverse . _1- , subkeys = map (mkey . \(x, _) -> keyPktPKPayload x) (tk ^. tkSubs)+ { publickey = mkey (tk ^. tkuKey . _1)+ , uids = tk ^. tkuUIDs ^.. traverse . _1+ , subkeys = map (mkey . \(PublicSubkeyPkt x, _) -> x) (tk ^. tkuSubs) } where mkey =@@ -177,8 +190,7 @@ _pkalgo <*> pkalgoAbbrev . _pkalgo <*>- show .- pretty .+ renderFingerprint . fingerprint showTKey :: TKey -> IO ()@@ -200,6 +212,10 @@ pretty "/" <> pretty (fpr k) +renderFingerprint :: Fingerprint -> String+renderFingerprint =+ T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty+ data Options = Options { keyring :: String@@ -372,9 +388,9 @@ let ttarget1 = T.pack . target1 keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o) case pathsOutputFormat o of- Unstructured -> mapM_ (BL.putStr . putTK' . someTKToUnknown . SomePublicTK) keys- JSON -> BL.putStr . A.encode $ map (someTKToUnknown . SomePublicTK) keys- YAML -> B.putStr . Y.encode $ map (someTKToUnknown . SomePublicTK) keys+ Unstructured -> mapM_ (BL.putStr . putTK') keys+ JSON -> BL.putStr . A.encode $ keys+ YAML -> B.putStr . Y.encode $ keys where putTK' key = runPut $ do@@ -391,26 +407,30 @@ doGraph o = do let ttarget1 = T.pack . target1 cpt <- getPOSIXTime- kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (ttarget1 o)+ keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)+ kr <- grabMatchingPublicKeyring keys let g = buildKeyGraph ((buildMaps &&& id) (rights (map- (verifyTKWith+ (verifyUnknownTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt)))- (IxSet.toList kr))))- case graphOutputFormat o of- LossyPretty -> prettyPrint g- GraphViz ->- TLIO.putStrLn . printDotGraph . graphToDot nonClusteredLabeledNodesParams $- g+ 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 $ show (pretty l)]}+ nonClusteredParams {fmtNode = \(_, l) -> [toLabel $ renderFingerprint l]} -buildMaps :: [TK 'PublicTK] -> (KeyMaps, Int)+buildMaps :: [TKUnknown] -> (KeyMaps, Int) buildMaps = foldr mapsInsertions (KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0) @@ -422,9 +442,9 @@ , _i2f :: HashMap Int Fingerprint } -mapsInsertions :: TK 'PublicTK -> (KeyMaps, Int) -> (KeyMaps, Int)+mapsInsertions :: TKUnknown -> (KeyMaps, Int) -> (KeyMaps, Int) mapsInsertions tk (KeyMaps k2f f2i i2f, i) =- let fp = fingerprint (tk ^. tkPrimaryKey & keyPktPKPayload)+ 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@@ -433,24 +453,32 @@ in (KeyMaps k2f' f2i' i2f', i') buildKeyGraph ::- ((KeyMaps, Int), [TK 'PublicTK]) -> Gr Fingerprint HashAlgorithm-buildKeyGraph ((KeyMaps k2f f2i _, _), ks) = mkGraph nodes edges+ ((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)) where nodes = map swap . HashMap.toList $ f2i- edges = filter (not . samesies) . nub . sort . concatMap tkToEdges $ ks- tkToEdges tk =- map- (\(ha, i) -> (source i, target tk, ha))- (mapMaybe (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk))- target tk =- fromMaybe- (error "Epic fail")- (HashMap.lookup (fingerprint (tk ^. tkPrimaryKey & keyPktPKPayload)) f2i)- source i = fromMaybe (-1) (HashMap.lookup i k2f >>= flip HashMap.lookup f2i)+ tkToEdges tk = do+ 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)+ 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)+ lookupNode 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 ^.. tkUIDs . traverse . _2) ++ (tk ^.. tkUAts . traverse . _2))+ ((tk ^.. tkuUIDs . traverse . _2) ++ (tk ^.. tkuUAts . traverse . _2)) samesies (x, y, _) = x == y data PaF =@@ -467,32 +495,36 @@ let ttarget1 = T.pack . target1 ttarget2 = T.pack . target2 ttarget3 = T.pack . target3+ filt = targetIsFilter o cpt <- getPOSIXTime- kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (ttarget1 o)+ 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 (IxSet.toList kr) .|+ runConduitRes $ CL.sourceList keys .| (if filt- then pup (conduitTKFilter (ufpt (ttarget2 o)))- else pup (CL.filter (matchAny (ttarget2 o)))) .|+ then conduitTKFilter filter2+ else CL.filter (matchAny (ttarget2 o))) .| CL.consume keys2 <-- runConduitRes $ CL.sourceList (IxSet.toList kr) .|+ runConduitRes $ CL.sourceList keys .| (if filt- then pup (conduitTKFilter (ufpt (ttarget3 o)))- else pup (CL.filter (matchAny (ttarget3 o)))) .|+ then conduitTKFilter filter3+ else CL.filter (matchAny (ttarget3 o))) .| CL.consume let ((KeyMaps k2f f2i i2f, i), ks) = (buildMaps &&& id) (rights (map- (verifyTKWith- (verifySigWith (verifyAgainstKeyring kr))- (Just (posixSecondsToUTCTime cpt)))- (IxSet.toList kr)))- keygraph = buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks)- keysToIs =- mapMaybe (\x -> HashMap.lookup (fingerprint (x ^. tkPrimaryKey & keyPktPKPayload)) f2i)+ (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)@@ -506,8 +538,8 @@ paths (Map.fromList (mapMaybe- (\x -> HashMap.lookup x i2f >>= \y -> return (show x, y))- (nub (sort (concat paths)))))+ (\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@@ -515,14 +547,12 @@ putStrLn . unlines $ map (\x ->- maybe (show x) show $ HashMap.lookup x i2f >>= \y ->- return (x, pretty y))+ 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- filt = targetIsFilter o matchAny srch tk = either (const False) id $ runExcept $ fmap (keyMatchesFingerprint True tk) ((except . parseFingerprint) srch) <|>@@ -530,10 +560,20 @@ (keyMatchesEightOctetKeyId True tk . Right) ((except . parseEightOctetKeyId) srch) <|> return (keyMatchesUIDSubString srch tk)- ufpt srch = RTKFilterPredicate (parseE srch)- parseE e =- either (error . ("filter parse error: " ++)) id (parseTKExp (T.unpack e)) -- this should be more specialized +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++dieHKT :: String -> IO a+dieHKT msg = hPutStrLn stderr msg >> exitFailure+ -- FIXME: deduplicate the following code sigissuer :: SignaturePayload -> Maybe EightOctetKeyId getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId@@ -542,22 +582,14 @@ sigissuer SigV3 {} = Nothing sigissuer (SigV4 _ _ _ ys xs _ _) = listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?-sigissuer (SigVOther _ _) = error "We're in the future." -- FIXME+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 _ = error "V3 sig not supported here"--fromUnknownToPublicTK :: TKUnknown -> TK 'PublicTK-fromUnknownToPublicTK = either error fromSome . fromUnknownToTK- where- fromSome (SomePublicTK tk) = tk- fromSome (SomeSecretTK _) = error "impossible"--pup :: Monad m- => ConduitT TKUnknown TKUnknown m ()- -> ConduitT (TK PublicTK) (TK PublicTK) m ()-pup c = CL.map (someTKToUnknown . SomePublicTK) .| c .| CL.map fromUnknownToPublicTK--- upu c = CL.map fromUnknownToPublicTK .| c .| CL.map (someTKToUnknown . SomePublicTK)+hashAlgo (SigV6 _ _ x _ _ _ _ _) = x+hashAlgo (SigVOther _ _) = OtherHA 0
hokey.hs view
@@ -19,6 +19,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} import Codec.Encryption.OpenPGP.Expirations (getKeyExpirationTimesFromSignature)@@ -35,15 +36,21 @@ ) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types+import Control.Applicative (optional) import Control.Arrow ((***)) import Control.Error.Util (hush)+import Control.Exception (bracket) import Control.Lens ((&), (^.), _1, _2, mapped, over) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHA+import qualified Crypto.PubKey.RSA as RSA import qualified Data.Aeson as A import Data.Binary (get, put)+import Data.Binary.Get (getWord32be, runGet)+import Data.Binary.Put (Put, putByteString, putLazyByteString, putWord32be, putWord8, runPut)+import Data.Bits ((.&.), shiftR, testBit) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as Base16@@ -52,7 +59,7 @@ 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 (AuthSecretSubkeyAtTime, authSecretSubkeyPrimaryUID, authSecretSubkeyValue, conduitToAuthSecretSubkeysAt, conduitToSecretTKs, conduitToTKsDropping) import Data.Conduit.Serialization.Binary (conduitGet, conduitPut) import Data.Foldable (find) import Data.List (elemIndex, findIndex, intercalate, nub, sort, sortOn)@@ -65,12 +72,17 @@ import qualified Data.Text as T import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime) import Data.Time.Format (formatTime)+import qualified Data.Word as Word import qualified Data.Yaml as Y import GHC.Generics import HOpenPGP.Tools.Common (banner, versioner, warranty) import HOpenPGP.Tools.HKP (FetchValidationMethod(..), rearmorKeys) import qualified HOpenPGP.Tools.HKP as HKP import HOpenPGP.Tools.TKUtils (processTK)+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 qualified HOpenPGP.Tools.WKD as WKD import Options.Applicative.Builder@@ -112,9 +124,11 @@ , (<+>) , annotate , colon+ , defaultLayoutOptions , flatAlt , hardline , indent+ , layoutPretty , line , list , pretty@@ -187,11 +201,21 @@ , 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@@ -219,6 +243,8 @@ instance A.ToJSON SubkeyReport +instance A.ToJSON SubkeyRevocationDigestWarning+ instance A.ToJSON CrossCertReport instance A.ToJSON b => A.ToJSON (FakeMap Text b) where@@ -298,12 +324,16 @@ colorizePHAs x = uncurry Colored- (if fSHA2Family x < ei DeprecatedMD5 x && fSHA2Family x < ei SHA1 x- then (Just Green, Nothing)- else (Just Red, Just "weak hash with higher preference"))+ (if preferredWeakHash x+ then (Just Red, Just "weak hash with higher preference")+ else (Just Green, Nothing)) x fSHA2Family = fi (`elem` [SHA512, SHA384, SHA256, SHA224])- ei x y = fromMaybe maxBound (elemIndex x y)+ 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@@ -327,7 +357,7 @@ colorizeHA ha = uncurry Colored- (if ha `elem` [DeprecatedMD5, SHA1]+ (if isKnownWeakHashAlgorithm ha then (Just Red, Just "weak hash algorithm") else (Nothing, Nothing)) ha@@ -446,6 +476,8 @@ , 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) [] }@@ -500,6 +532,22 @@ 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@@ -620,6 +668,21 @@ 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 <>@@ -659,6 +722,13 @@ , fetchQuery :: String } +data InjectSSHAgentOptions =+ InjectSSHAgentOptions+ { injectSSHAgentFromFD :: Maybe Int+ , injectSSHAgentSocket :: Maybe String+ , injectSSHAgentComment :: Maybe String+ }+ data FetchMethod = HKP | WKD@@ -668,7 +738,15 @@ = CmdLint LintOptions | CmdCanonicalize | CmdFetch FetchOptions+ | CmdInjectSSHAgent InjectSSHAgentOptions +data InjectableAuthSubkey =+ InjectableAuthSubkey+ { injectableAuthSubkeyPKP :: SomePKPayload+ , injectableAuthSubkeySKA :: SKAddendum+ , injectableAuthSubkeyPrimaryUID :: Maybe Text+ }+ lintO :: Parser LintOptions lintO = LintOptions <$>@@ -711,10 +789,32 @@ 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"))+ dispatch :: Command -> IO () dispatch (CmdFetch o) = banner' stderr >> hFlush stderr >> doFetch o dispatch (CmdLint o) = banner' stderr >> hFlush stderr >> doLint o dispatch CmdCanonicalize = banner' stderr >> hFlush stderr >> doCanonicalize+dispatch (CmdInjectSSHAgent o) =+ banner' stderr >> hFlush stderr >> doInjectSSHAgent o main :: IO () main = do@@ -742,6 +842,11 @@ (CmdFetch <$> fetchO) (progDesc "fetch key(s) via HKP or WKD")) <> command+ "inject-ssh-agent"+ (info+ (CmdInjectSSHAgent <$> injectSSHAgentO)+ (progDesc "Read exported secret key bytes, pick an auth-capable subkey, and add it to ssh-agent")) <>+ command "lint" (info (CmdLint <$> lintO) (progDesc "check key(s) for 'best practices'"))) @@ -768,8 +873,13 @@ conduitPut .| CB.sinkHandle stdout where- canonicalize (TKUnknown k r ui ua s) =- TKUnknown k (sort r) (indepthsort ui) (indepthsort ua) (indepthsort s)+ canonicalize 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 @@ -785,6 +895,328 @@ case ekeys of Left e -> hPutStrLn stderr $ "error fetching keys: " ++ e Right ks -> B.putStr $ rearmorKeys ks++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++candidateFromAuthSecretSubkey :: AuthSecretSubkeyAtTime -> InjectableAuthSubkey+candidateFromAuthSecretSubkey authSubkey =+ InjectableAuthSubkey+ { injectableAuthSubkeyPKP = authSecretSubkeyPKP authSubkey+ , injectableAuthSubkeySKA = authSecretSubkeySKA authSubkey+ , injectableAuthSubkeyPrimaryUID = authSecretSubkeyPrimaryUID authSubkey+ }++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)+ where+ inferFromTK tk =+ 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+ }+ inferFromSubkey _ _ = Nothing+ hasAuthCapability 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+ 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++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"++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++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)+ 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)+ defaultSSHComment 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 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")++authSecretSubkeyPKP :: AuthSecretSubkeyAtTime -> SomePKPayload+authSecretSubkeyPKP = keyPktPKPayload . authSecretSubkeyValue++authSecretSubkeySKA :: AuthSecretSubkeyAtTime -> SKAddendum+authSecretSubkeySKA = secretKeyPktSKAddendum . authSecretSubkeyValue++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++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++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")++renderFingerprint :: Fingerprint -> String+renderFingerprint =+ T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty++renderKeyID :: EightOctetKeyId -> String+renderKeyID =+ T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty++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++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++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")++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+ where+ raw = integerToUnsignedBytes n+ encoded =+ 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)+ where+ raw =+ 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++isEd25519PKA :: PubKeyAlgorithm -> Bool+isEd25519PKA pka = fromFVal pka == 27++frameSSHAgentRequest :: BL.ByteString -> BL.ByteString+frameSSHAgentRequest 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")++readSSHAgentPacket :: Socket -> IO B.ByteString+readSSHAgentPacket sock = do+ 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+recvExact sock remaining = go B.empty remaining+ 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)++whenEmpty :: [a] -> String -> IO ()+whenEmpty [] msg = failInject msg+whenEmpty _ _ = pure ()++failInject :: String -> IO a+failInject msg = hPutStrLn stderr msg >> exitFailure banner' :: Handle -> IO () banner' h =
hop.hs view
@@ -16,596 +16,4913 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RecordWildCards #-}--import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA-import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..))-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.Ontology (isKUF)-import Codec.Encryption.OpenPGP.Serialize ()-import Codec.Encryption.OpenPGP.Signatures- ( crossSignSubkeyWithRSA- , signDataWithRSA- , signUserIDwithRSA- , verifyAgainstKeyring- , verifySigWith- , verifyTKWith- )-import Codec.Encryption.OpenPGP.Types-import Control.Applicative ((<|>), optional, some)-import Control.Error.Util (note)-import Control.Monad ((>=>), forM_)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)-import Control.Monad.Trans.Resource (MonadResource, MonadThrow)-import qualified Crypto.PubKey.RSA as RSA-import qualified Data.Aeson as A-import qualified Data.Binary as Bin-import Data.Binary.Get (runGet)-import Data.Binary.Put (runPut)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC8-import Data.Conduit ((.|), 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.Keyring- ( conduitToTKs- , conduitToPublicViewTKs- , conduitToSecretTKs- , conduitToTKsDropping- , sinkPublicKeyringMap- )-import Data.Conduit.OpenPGP.Verify (conduitVerify)-import Data.Conduit.Serialization.Binary (conduitGet)-import Data.Either (fromRight, isRight, rights)-import Data.Bifunctor (first)-import Data.List (find)-import Data.Maybe (catMaybes, fromJust, listToMaybe)-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.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)-import qualified Data.Vector as V-import Data.Version (showVersion)-import qualified Data.Yaml as Y-import GHC.Generics-import HOpenPGP.Tools.Armor (doDeArmor)-import HOpenPGP.Tools.Common- ( banner- , keyMatchesEightOctetKeyId- , keyMatchesFingerprint- , keyMatchesUIDSubString- , versioner- , warranty- )-import HOpenPGP.Tools.Parser (parseTKExp)-import HOpenPGP.Tools.TKUtils (processTK)-import Paths_hopenpgp_tools (version)-import System.Exit (exitFailure, exitSuccess)--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 Prettyprinter- ( (<+>)- , fillSep- , hardline- , list- , pretty- , softline- )-import Prettyprinter.Render.Text (hPutDoc)-import System.IO (BufferMode(..), Handle, hFlush, hSetBuffering, stderr, stdin)--data Command- = VersionC- | GenerateKeyC KeyGenOptions- | ExtractCertC ExtractCertOptions- | SignC SignOptions- | 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)--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"--dispatch :: POSIXTime -> Command -> IO ()-dispatch cpt o = banner' stderr >> hFlush stderr >> dispatch' cpt o- where- dispatch' _ VersionC = doVersion- dispatch' t (GenerateKeyC o) = doGenerateKey t o- dispatch' _ (ExtractCertC o) = doExtractCert o- dispatch' t (SignC o) = doSign t o- dispatch' _ DeArmorC = doDeArmor- dispatch' _ (ArmorC o) = doArmor o--main :: IO ()-main = do- hSetBuffering stderr LineBuffering- cpt <- getPOSIXTime- customExecParser- (prefs showHelpOnError)- (info- (helper <*> versioner "hop" <*> cmd)- (headerDoc (Just (banner "hop")) <>- progDesc "hOpenPGP Validator Tool" <>- footerDoc (Just (warranty "hop")))) >>=- dispatch cpt--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- let allkfiles = sequence_ (map CC.sourceFile (keyrings o))- krs <-- runConduitRes $- allkfiles .| conduitGet Bin.get .| conduitToTKs .| CL.map (fromSomePub) .| sinkPublicKeyringMap-- 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- "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- "sign"- (info- (SignC <$> soP)- (progDesc "Create detached signatures and output them to stdout")) <>- command- "version"- (info (pure VersionC) (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- guessLabel (Just l) _ = l- guessLabel Nothing (SignaturePkt _) = ArmorSignature- guessLabel Nothing (SecretKeyPkt _ _) = ArmorPrivateKeyBlock- guessLabel Nothing (PublicKeyPkt _) = ArmorPublicKeyBlock- guessLabel Nothing _ = ArmorMessage--doVersion :: IO ()-doVersion = putStrLn $ "hop " ++ showVersion version--gkoP :: Parser KeyGenOptions-gkoP =- KeyGenOptions <$> switch (long "armor" <> help "armor the output") <*>- switch (long "no-armor" <> help "don't armor the output") <*>- strArgument (metavar "USERID" <> help "User ID associated with this key")--data KeyGenOptions =- KeyGenOptions- { armor :: Bool- , noArmor :: Bool- , userId :: String- }--doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()-doGenerateKey pt KeyGenOptions {..} = do- let ts = ThirtyTwoBitTimeStamp (floor pt)- sk <- generateSecretKey ts RSA- s <-- buildKeyWith sk $ do- addUserId ts True (T.pack userId)- addSubkey ts [EncryptStorageKey, EncryptCommunicationsKey]- addSubkey ts [SignDataKey]- addSubkey ts [AuthKey]- newkey <- get- return newkey- 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) [] [] [] []--generateSecretKey :: ThirtyTwoBitTimeStamp -> PubKeyAlgorithm -> IO SecretKey-generateSecretKey ts RSA = do- (pub, priv) <- liftIO $ RSA.generate 512 0x10001- return $ SecretKey (pkp pub) (ska priv)- where- pkp pub = PKPayload V4 ts 0 RSA (RSAPubKey (RSA_PublicKey pub))- ska priv = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey priv)) 0 -- FIXME: calculate checksum--addUserId :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()-addUserId ts primary userid = modify (newUID userid)- where- newUID u tku = tku {_tkuUIDs = _tkuUIDs tku ++ [selfsign (_tkuKey tku) u]}- selfsign (pkp, Just ska) u =- ( u- , [ fromRight- undefined- (signUserIDwithRSA- pkp- (UserId u)- (hashed pkp)- (unhashed pkp)- (skey ska))- ])- hashed pkp =- [ SigSubPacket False (SigCreationTime ts)- , SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (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 pkp =- [SigSubPacket False (Issuer (fromRight undefined (eightOctetKeyID pkp)))]- skey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) = k--addSubkey :: ThirtyTwoBitTimeStamp -> [KeyFlag] -> KeyBuilder ()-addSubkey ts keyflags = do- tku <- get- (SecretKey subpkp subska) <- liftIO $ generateSecretKey ts RSA- let (pkp, Just ska) = _tkuKey tku- Right crossig =- crossSignSubkeyWithRSA- pkp- subpkp- (hashedwithflags pkp)- (unhashed pkp)- (hashed subpkp)- (unhashed subpkp)- (skey ska)- (skey subska)- modify (addIt subpkp subska crossig)- where- skey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) = k- addIt sp ss cross tku =- tku {_tkuSubs = _tkuSubs tku ++ [(SecretSubkeyPkt sp ss, [cross])]}- hashed pkp =- [ SigSubPacket False (SigCreationTime ts)- , SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint pkp))- ]- hashedwithflags pkp =- hashed pkp ++ [SigSubPacket False (KeyFlags (S.fromList keyflags))]- unhashed pkp =- [SigSubPacket False (Issuer (fromRight undefined (eightOctetKeyID pkp)))]--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- isArmored =- BLC8.pack "-----BEGIN PGP PRIVATE KEY BLOCK-----" == BL.take 37 lbs- Right [Armor ArmorPrivateKeyBlock _ decoded] =- AA.decodeLazy lbs :: Either String [Armor]- lbs' =- if isArmored- then decoded- else lbs- k <-- runConduitRes $- CL.sourceList (BL.toChunks lbs') .| conduitGet Bin.get .| conduitToPublicViewTKs .|- CL.take 1- let output = runPut $ Bin.put (someTKToUnknown . SomePublicTK $ head k)- BL.putStr $- if not ecArmor && not ecNoArmor- then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]- else output--soP :: Parser SignOptions-soP =- SignOptions <$> switch (long "armor" <> help "armor the output") <*>- switch (long "no-armor" <> help "don't armor the output") <*>- 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- , sAs :: AsBinaryText- , sKeyFiles :: [String]- }--asTypes :: [(String, AsBinaryText)]-asTypes = [("binary", AsBinary), ("text", AsText)]--data AsBinaryText- = AsBinary- | AsText- deriving (Eq)--asTypeReader :: String -> Either String AsBinaryText-asTypeReader = note "unknown as type" . flip lookup asTypes--doSign :: POSIXTime -> SignOptions -> IO ()-doSign pt SignOptions {..} = do- mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- ks <- mapM grabKey sKeyFiles- let ts = ThirtyTwoBitTimeStamp (floor pt)- payload' = BL.fromChunks mbs- payload =- if sAs == AsText- then canonicalize payload'- else payload'- funkeys = concatMap tkToFunKeys . rights . map (processTK (Just pt) . someTKToUnknown . SomeSecretTK) $ ks- allSigningCapableKeys = filter (isSigner . fkufs) funkeys- forM_ allSigningCapableKeys $ \k -> do- let Right sig = signData sAs ts k payload- sigpkt = SignaturePkt sig- output = runPut (Bin.put sigpkt)- BL.putStr $- if not sArmor && not sNoArmor- then AA.encodeLazy [Armor ArmorSignature [] output]- else output- where- signData ::- AsBinaryText- -> ThirtyTwoBitTimeStamp- -> FunKey- -> BL.ByteString- -> Either String SignaturePayload- signData AsBinary t k d =- first show $ signDataWithRSA- BinarySig- (skey (fromJust (fmska k)))- (hashed (fpkp k) t)- (unhashed (fpkp k))- d- signData AsText t k d =- first show $ signDataWithRSA- CanonicalTextSig- (skey (fromJust (fmska k)))- (hashed (fpkp k) t)- (unhashed (fpkp k))- (canonicalize d)- skey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) =- k {RSA.private_p = 0, RSA.private_q = 0} -- FIXME: why is this necessary?- hashed pkp ct =- [ SigSubPacket False (SigCreationTime ct)- , SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint pkp))- ]- unhashed pkp =- [SigSubPacket False (Issuer (fromRight undefined (eightOctetKeyID pkp)))]- isSigner = S.member SignDataKey- canonicalize :: BL.ByteString -> BL.ByteString- canonicalize =- BL.fromStrict .- TE.encodeUtf8 .- T.intercalate (T.pack "\r\n") . T.lines . TE.decodeUtf8 . BL.toStrict--grabKey :: String -> IO (TK 'SecretTK)-grabKey fp = do- kbs <- runConduitRes $ CB.sourceFile fp .| CL.consume- let lbs = BL.fromChunks kbs- isArmored =- BLC8.pack "-----BEGIN PGP PRIVATE KEY BLOCK-----" == BL.take 37 lbs- Right [Armor ArmorPrivateKeyBlock _ decoded] =- AA.decodeLazy lbs :: Either String [Armor]- lbs' =- if isArmored- then decoded- else lbs- Just k <-- runConduitRes $- CL.sourceList (BL.toChunks lbs') .| conduitGet Bin.get .| conduitToSecretTKs .|- CL.head- return k--data FunKey =- FunKey- { fpkp :: SomePKPayload- , fmska :: Maybe SKAddendum- , fkufs :: S.Set KeyFlag- }- deriving (Show)--tkToFunKeys :: TKUnknown -> [FunKey]-tkToFunKeys (TKUnknown (pkp, mska) revs uids uats subs) =- catMaybes (mainKey : map extract subs)- where- mainKey = grabASig uids >>= sig2KUFs >>= \kf -> return (FunKey pkp mska kf)- 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 _ = Nothing- getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag)- getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs- getKUFs _ = Nothing- extract ((SecretSubkeyPkt spkp sska), sigs) =- listToMaybe sigs >>= sig2KUFs >>= \kf ->- return (FunKey spkp (Just sska) kf)- extract ((PublicSubkeyPkt spkp), sigs) =- listToMaybe sigs >>= sig2KUFs >>= \kf -> return (FunKey spkp Nothing kf)- extract _ = Nothing--fromSomePub :: SomeTK -> TK 'PublicTK-fromSomePub (SomePublicTK tk) = tk+{-# 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+ , 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.Armor (doDeArmor)+import HOpenPGP.Tools.Common+ ( banner+ , keyMatchesEightOctetKeyId+ , keyMatchesFingerprint+ , keyMatchesUIDSubString+ , versioner+ , warranty+ )+import HOpenPGP.Tools.Parser (parseTKExp)+import HOpenPGP.Tools.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]+ }++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)"))+ 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)++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)) || 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+ | 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+ | 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)++isEd25519PKA :: PubKeyAlgorithm -> Bool+isEd25519PKA pka = fromFVal pka == 27++isEd448PKA :: PubKeyAlgorithm -> Bool+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)+ ks <- mapM grabKey inlineSignKeyFiles+ 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)) || 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"
hopenpgp-tools.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hopenpgp-tools-version: 0.24+version: 0.25 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: https://salsa.debian.org/clint/hOpenPGP-tools@@ -18,7 +18,7 @@ common deps autogen-modules: Paths_hopenpgp_tools- build-depends: base > 4.15 && < 5+ build-depends: base >= 4.15 && < 5 , aeson , binary >= 0.6.4.0 , binary-conduit@@ -46,7 +46,7 @@ build-depends: array , conduit-extra >= 1.1 , monad-loops- , openpgp-asciiarmor >= 0.1+ , openpgp-asciiarmor >= 1 build-tool-depends: alex:alex, happy:happy default-language: Haskell2010 @@ -62,7 +62,8 @@ , http-client >= 0.4.30 , http-client-tls , http-types- , openpgp-asciiarmor >= 1.0+ , network+ , openpgp-asciiarmor >= 1 , prettyprinter-ansi-terminal >= 1.1.2 , time , time-locale-compat@@ -102,12 +103,17 @@ , conduit-extra >= 1.1 , containers , crypton+ , directory , monad-loops , mtl- , openpgp-asciiarmor >= 0.1+ , openpgp-asciiarmor >= 1 , resourcet , time , vector+ if flag(use-memory)+ build-depends: memory+ else+ build-depends: ram build-tool-depends: alex:alex, happy:happy default-language: Haskell2010 @@ -118,4 +124,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hopenpgp-tools.git- tag: hopenpgp-tools/0.24+ tag: hopenpgp-tools/0.25
hot.hs view
@@ -24,7 +24,9 @@ import Codec.Encryption.OpenPGP.Types import Control.Applicative (optional) import Control.Error.Util (note)+import Control.Exception (ErrorCall, evaluate, try) import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Reader (Reader) import qualified Data.Aeson as A import Data.Binary (get, put) import Data.Binary.Get (Get)@@ -48,11 +50,13 @@ ( BufferMode(..) , Handle , hFlush+ , hPutStrLn , hSetBuffering , stderr , stdin , stdout )+import System.Exit (exitFailure) import Prettyprinter ( Pretty@@ -136,12 +140,16 @@ doFilter :: FilteringOptions -> IO () doFilter fo =- runConduitRes $- CB.sourceHandle stdin .| conduitGet (get :: Get Pkt) .|- conduitPktFilter (parseExpressions fo) .|- 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 =@@ -206,10 +214,17 @@ banner' :: Handle -> IO () banner' h = hPutDoc h (banner "hot" <> hardline <> warranty "hot" <> hardline) -parseExpressions :: FilteringOptions -> FilterPredicates r a-parseExpressions FilteringOptions {..} = RPFilterPredicate (parseE fExpression)+parseExpressions :: FilteringOptions -> IO (Either String (FilterPredicates r a))+parseExpressions FilteringOptions {..} = do+ parsed <- parseE fExpression+ pure (RPFilterPredicate <$> parsed) where- parseE e = either (error . ("filter parse error: " ++)) id (parsePExp e)+ 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 armorTypes :: [(String, ArmorType)] armorTypes =@@ -252,3 +267,6 @@ (maybe [] (\x -> [("Comment", x)]) comment) (BL.fromChunks m) BL.putStr $ AA.encodeLazy [a]++dieHot :: String -> IO a+dieHot msg = hPutStrLn stderr msg >> exitFailure