diff --git a/HOpenPGP/Tools/Common.hs b/HOpenPGP/Tools/Common.hs
--- a/HOpenPGP/Tools/Common.hs
+++ b/HOpenPGP/Tools/Common.hs
@@ -15,6 +15,7 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
+
module HOpenPGP.Tools.Common
( banner
, versioner
diff --git a/HOpenPGP/Tools/TKUtils.hs b/HOpenPGP/Tools/TKUtils.hs
--- a/HOpenPGP/Tools/TKUtils.hs
+++ b/HOpenPGP/Tools/TKUtils.hs
@@ -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
diff --git a/hkt.hs b/hkt.hs
--- a/hkt.hs
+++ b/hkt.hs
@@ -16,9 +16,7 @@
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE 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
diff --git a/hokey.hs b/hokey.hs
--- a/hokey.hs
+++ b/hokey.hs
@@ -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 "") 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 =
diff --git a/hop.hs b/hop.hs
--- a/hop.hs
+++ b/hop.hs
@@ -16,596 +16,4913 @@
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE 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"
diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal
--- a/hopenpgp-tools.cabal
+++ b/hopenpgp-tools.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: hopenpgp-tools
-version: 0.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
diff --git a/hot.hs b/hot.hs
--- a/hot.hs
+++ b/hot.hs
@@ -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