diff --git a/HOpenPGP/Tools/Common/HKP.hs b/HOpenPGP/Tools/Common/HKP.hs
--- a/HOpenPGP/Tools/Common/HKP.hs
+++ b/HOpenPGP/Tools/Common/HKP.hs
@@ -15,112 +15,121 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-
{-# LANGUAGE OverloadedStrings #-}
module HOpenPGP.Tools.Common.HKP
- ( fetchKeys
- , FetchValidationMethod(..)
- , rearmorKeys
- ) where
+ ( fetchKeys
+ , FetchValidationMethod (..)
+ , rearmorKeys
+ ) where
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
- ( Armor(Armor)
- , ArmorType(ArmorPublicKeyBlock)
- )
+ ( Armor (Armor)
+ , ArmorType (ArmorPublicKeyBlock)
+ )
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.Types
- ( Block(..)
- , TKUnknown(..)
- , Fingerprint
- )
-import Control.Applicative (liftA2)
+ ( Block (..)
+ , Fingerprint
+ , TKUnknown (..)
+ )
import Control.Arrow ((&&&))
import Control.Lens ((^..))
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (ExceptT(..), throwE)
+import Control.Monad.Trans.Except (ExceptT (..), throwE)
import Data.Binary (get, put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
-import Data.Conduit ((.|), runConduitRes)
+import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Data.Lens (biplate)
import Data.Either (rights)
-import Data.Monoid ((<>), mempty)
import Data.Time.Clock.POSIX (getPOSIXTime)
-import HOpenPGP.Tools.Common.TKUtils (processTK)
import Network.HTTP.Client
- ( Response(..)
- , httpLbs
- , newManager
- , parseUrlThrow
- , setQueryString
- )
+ ( Response (..)
+ , httpLbs
+ , newManager
+ , parseUrlThrow
+ , setQueryString
+ )
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (ok200)
import Prettyprinter (pretty)
+import HOpenPGP.Tools.Common.TKUtils (processTK)
+
data FetchValidationMethod
- = MatchPrimaryKeyFingerprint
- | MatchPrimaryOrAnySubkeyFingerprint
- | AnySelfSigned
- deriving (Bounded, Enum, Eq, Read, Show)
+ = MatchPrimaryKeyFingerprint
+ | MatchPrimaryOrAnySubkeyFingerprint
+ | AnySelfSigned
+ deriving (Bounded, Enum, Eq, Read, Show)
-fetchKeys ::
- String
- -> FetchValidationMethod
- -> Fingerprint
- -> ExceptT String IO [TKUnknown]
+fetchKeys
+ :: String
+ -> FetchValidationMethod
+ -> Fingerprint
+ -> ExceptT String IO [TKUnknown]
fetchKeys ks fvm q = do
- manager <- liftIO $ newManager tlsManagerSettings
- request <- liftIO $ parseUrlThrow (ks <> basereq)
- let newreq = setQueryString (newqs q) request
- response <- liftIO $ httpLbs newreq manager
- processedKeys <-
- if responseStatus response == ok200
- then validateKeys (responseBody response)
- else throwE ("HTTP status: " ++ show (responseStatus response))
- return $ map fst $ filter (fvp fvm . fst . _tkuKey . snd) processedKeys
+ manager <- liftIO $ newManager tlsManagerSettings
+ request <- liftIO $ parseUrlThrow (ks <> basereq)
+ let newreq = setQueryString (newqs q) request
+ response <- liftIO $ httpLbs newreq manager
+ processedKeys <-
+ if responseStatus response == ok200
+ then validateKeys (responseBody response)
+ else throwE ("HTTP status: " ++ show (responseStatus response))
+ return $
+ map fst $
+ filter (fvp fvm . fst . _tkuKey . snd) processedKeys
where
fvp MatchPrimaryKeyFingerprint k = fingerprint k == q
- fvp MatchPrimaryOrAnySubkeyFingerprint k =
- any (\k -> fingerprint k == q) (k ^.. biplate)
- fvp AnySelfSigned k = True
+ fvp MatchPrimaryOrAnySubkeyFingerprint k' =
+ any (\k'' -> fingerprint k'' == q) (k' ^.. biplate)
+ fvp AnySelfSigned _ = True
basereq = "/pks/lookup"
- newqs q =
- [ ("op", Just "get")
- , ("options", Just "mr")
- , ("exact", Just "on")
- , ("search", Just (BC8.pack ("0x" <> show (pretty q)))) -- FIXME: butter
- ]
+ newqs q' =
+ [ ("op", Just "get")
+ , ("options", Just "mr")
+ , ("exact", Just "on")
+ , ("search", Just (BC8.pack ("0x" <> show (pretty q')))) -- FIXME: butter
+ ]
-validateKeys :: BL.ByteString -> ExceptT String IO [(TKUnknown, TKUnknown)] -- FIXME: conduit fail
+validateKeys
+ :: BL.ByteString -> ExceptT String IO [(TKUnknown, TKUnknown)] -- FIXME: conduit fail
validateKeys larmors = do
- bytestrings <-
- ExceptT $ return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
- keys <-
- liftIO . runConduitRes $
- CB.sourceLbs bytestrings .| conduitGet get .| conduitToTKsDropping .|
- CL.consume
- cpt <- liftIO getPOSIXTime
- return . rights $
- map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
+ bytestrings <-
+ ExceptT $
+ return $
+ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
+ keys <-
+ liftIO . runConduitRes $
+ CB.sourceLbs bytestrings
+ .| conduitGet get
+ .| conduitToTKsDroppingEither
+ .| CL.mapMaybe (either (const Nothing) id)
+ .| CL.consume
+ cpt <- liftIO getPOSIXTime
+ return . rights $
+ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
where
armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs
armorToBS _ = mempty
rearmorKeys :: [TKUnknown] -> B.ByteString
rearmorKeys keys =
- if null keys
- then mempty
- else AA.encode .
- return .
- Armor ArmorPublicKeyBlock [("Comment", "filtered by hokey")] .
- runPut . put . Block $
- keys
+ if null keys
+ then mempty
+ else
+ AA.encode
+ . return
+ . Armor ArmorPublicKeyBlock [("Comment", "filtered by hokey")]
+ . runPut
+ . put
+ . Block
+ $ keys
diff --git a/HOpenPGP/Tools/Common/TKUtils.hs b/HOpenPGP/Tools/Common/TKUtils.hs
--- a/HOpenPGP/Tools/Common/TKUtils.hs
+++ b/HOpenPGP/Tools/Common/TKUtils.hs
@@ -17,16 +17,18 @@
-- along with this program. If not, see .
module HOpenPGP.Tools.Common.TKUtils
- ( processTK
- ) where
+ ( processTK
+ ) where
-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
+import Codec.Encryption.OpenPGP.Fingerprint
+ ( eightOctetKeyID
+ , fingerprint
+ )
import Codec.Encryption.OpenPGP.Signatures
- ( VerificationError
- , verifyAgainstKeys
- , verifySigWith
- , verifyUnknownTKWith
- )
+ ( verifyAgainstKeys
+ , verifySigWith
+ , verifyUnknownTKWith
+ )
import Codec.Encryption.OpenPGP.Types
import Control.Arrow (second)
import Control.Error.Util (hush)
@@ -34,58 +36,60 @@
import Data.Bifunctor (first)
import Data.List (sortOn)
import Data.Maybe (listToMaybe, mapMaybe)
-import Data.Ord (Down(..))
+import Data.Ord (Down (..))
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
-- should this fail or should verifyUnknownTKWith fail if there are no self-sigs?
-processTK :: Maybe POSIXTime -> TKUnknown -> Either String TKUnknown
-processTK mpt key =
- first show $ verifyUnknownTKWith
- (verifySigWith (verifyAgainstKeys [key]))
- (fmap posixSecondsToUTCTime mpt) .
- stripOlderSigs .
- stripOtherSigs $
- key
+processTK
+ :: Maybe POSIXTime -> TKUnknown -> Either String TKUnknown
+processTK mpt tk =
+ first show
+ $ verifyUnknownTKWith
+ (verifySigWith (verifyAgainstKeys [tk]))
+ (fmap posixSecondsToUTCTime mpt)
+ . stripOlderSigs
+ . stripOtherSigs
+ $ tk
where
- stripOtherSigs tk =
- tk
- { _tkuUIDs = map (second alleged) (_tkuUIDs tk)
- , _tkuUAts = map (second alleged) (_tkuUAts tk)
- }
- stripOlderSigs tk =
- tk
- { _tkuUIDs = map (second newest) (_tkuUIDs tk)
- , _tkuUAts = map (second newest) (_tkuUAts tk)
- }
+ stripOtherSigs tk' =
+ tk'
+ { _tkuUIDs = map (second alleged) (_tkuUIDs tk')
+ , _tkuUAts = map (second alleged) (_tkuUAts tk')
+ }
+ stripOlderSigs tk' =
+ tk'
+ { _tkuUIDs = map (second newest) (_tkuUIDs tk')
+ , _tkuUAts = map (second newest) (_tkuUAts tk')
+ }
newest = take 1 . sortOn (Down . take 1 . sigcts) -- FIXME: this is terrible
sigcts (SigV4 _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs
sigcts (SigV6 _ _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs
sigcts _ = []
- pkp = key ^. tkuKey . _1
+ pkp = tk ^. tkuKey . _1
alleged = filter (\x -> assI x || assIFP x)
sigCreationTimeFromSubpacket (SigSubPacket _ (SigCreationTime x)) = Just x
sigCreationTimeFromSubpacket _ = Nothing
sigissuer (SigVOther 2 _) = Nothing
sigissuer SigV3 {} = Nothing
sigissuer (SigV4 _ _ _ ys xs _ _) =
- listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
+ listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
sigissuer (SigV6 _ _ _ _ ys xs _ _) =
- listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
+ listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
sigissuer (SigVOther _ _) = Nothing
sigissuerfp (SigV4 _ _ _ ys xs _ _) =
- listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
+ listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
sigissuerfp (SigV6 _ _ _ _ ys xs _ _) =
- listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
+ listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
sigissuerfp _ = Nothing
eoki
- | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
- | _keyVersion pkp == DeprecatedV3 &&
- elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
- hush . eightOctetKeyID $ pkp
- | otherwise = Nothing
+ | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
+ | _keyVersion pkp == DeprecatedV3
+ && elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
+ hush . eightOctetKeyID $ pkp
+ | otherwise = Nothing
fp
- | _keyVersion pkp == V4 = Just . fingerprint $ pkp
- | otherwise = Nothing
+ | _keyVersion pkp == V4 = Just . fingerprint $ pkp
+ | otherwise = Nothing
getIssuer (Issuer i) = Just i
getIssuer _ = Nothing
getIssuerFP (IssuerFingerprint IssuerFingerprintV4 i) = Just i
diff --git a/HOpenPGP/Tools/Common/WKD.hs b/HOpenPGP/Tools/Common/WKD.hs
--- a/HOpenPGP/Tools/Common/WKD.hs
+++ b/HOpenPGP/Tools/Common/WKD.hs
@@ -15,35 +15,34 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-
{-# LANGUAGE OverloadedStrings #-}
module HOpenPGP.Tools.Common.WKD
- ( fetchKeys
- , parseMailbox
- ) where
+ ( fetchKeys
+ , parseMailbox
+ ) where
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
- ( Armor(Armor)
- , ArmorType(ArmorPublicKeyBlock)
- )
-import Codec.Encryption.OpenPGP.Types (TKUnknown(..))
+ ( Armor (Armor)
+ , ArmorType (ArmorPublicKeyBlock)
+ )
+import Codec.Encryption.OpenPGP.Types (TKUnknown (..))
import Control.Arrow ((&&&))
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (ExceptT(..), throwE)
+import Control.Monad.Trans.Except (ExceptT (..), throwE)
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
import Data.Binary (get)
+import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
-import Data.Bits ((.&.), (.|.), shiftL, shiftR)
-import Data.Conduit ((.|), runConduitRes)
+import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Either (rights)
import Data.Text (Text)
@@ -51,116 +50,144 @@
import qualified Data.Text.Encoding as TE
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Word (Word8)
-import HOpenPGP.Tools.Common.HKP (FetchValidationMethod(..))
-import HOpenPGP.Tools.Common.TKUtils (processTK)
import Network.HTTP.Client
- ( Manager
- , Response(..)
- , httpLbs
- , newManager
- , parseUrlThrow
- , setQueryString
- )
+ ( Manager
+ , Response (..)
+ , httpLbs
+ , newManager
+ , parseUrlThrow
+ , setQueryString
+ )
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (ok200)
-fetchKeys ::
- FetchValidationMethod
- -> Text
- -> ExceptT String IO [TKUnknown]
+import HOpenPGP.Tools.Common.HKP (FetchValidationMethod (..))
+import HOpenPGP.Tools.Common.TKUtils (processTK)
+
+fetchKeys
+ :: FetchValidationMethod
+ -> Text
+ -> ExceptT String IO [TKUnknown]
fetchKeys fvm mailbox = do
- parsedMailbox <- ExceptT . return $ parseMailbox mailbox
- manager <- liftIO $ newManager tlsManagerSettings
- response <- fetchWKD manager parsedMailbox
- body <-
- if responseStatus response == ok200
- then return (responseBody response)
- else throwE ("HTTP status: " ++ show (responseStatus response))
- validateAndFilterKeys fvm parsedMailbox body
+ parsedMailbox <- ExceptT . return $ parseMailbox mailbox
+ manager <- liftIO $ newManager tlsManagerSettings
+ response <- fetchWKD manager parsedMailbox
+ body <-
+ if responseStatus response == ok200
+ then return (responseBody response)
+ else throwE ("HTTP status: " ++ show (responseStatus response))
+ validateAndFilterKeys fvm parsedMailbox body
parseMailbox :: Text -> Either String (Text, Text)
parseMailbox rawMailbox =
- let mailbox = T.strip rawMailbox
- parts = T.splitOn "@" mailbox
- in case parts of
- [localPart, domain]
- | T.null localPart -> Left "mailbox local part cannot be empty"
- | T.null domain -> Left "mailbox domain cannot be empty"
- | T.any (== ' ') mailbox -> Left "mailbox cannot contain spaces"
- | otherwise -> Right (localPart, T.toLower domain)
- _ -> Left "mailbox must contain exactly one @"
+ let mailbox = T.strip rawMailbox
+ parts = T.splitOn "@" mailbox
+ in case parts of
+ [localPart, domain]
+ | T.null localPart -> Left "mailbox local part cannot be empty"
+ | T.null domain -> Left "mailbox domain cannot be empty"
+ | T.any (== ' ') mailbox -> Left "mailbox cannot contain spaces"
+ | otherwise -> Right (localPart, T.toLower domain)
+ _ -> Left "mailbox must contain exactly one @"
-fetchWKD ::
- Manager
- -> (Text, Text)
- -> ExceptT String IO (Response BL.ByteString)
+fetchWKD
+ :: Manager
+ -> (Text, Text)
+ -> ExceptT String IO (Response BL.ByteString)
fetchWKD manager (localPart, domain) = do
- let localPartLower = T.toLower localPart
- hu = BC8.unpack . zbase32 . sha1 . TE.encodeUtf8 $ localPartLower
- advancedUrl =
- "https://openpgpkey." <>
- T.unpack domain <>
- "/.well-known/openpgpkey/" <> T.unpack domain <> "/hu/" <> hu
- directUrl =
- "https://" <> T.unpack domain <> "/.well-known/openpgpkey/hu/" <> hu
- mailboxParam = TE.encodeUtf8 localPartLower
- withMailbox req = setQueryString [("l", Just mailboxParam)] req
- advancedRequest <- liftIO $ parseUrlThrow advancedUrl
- advancedResponse <- liftIO $ httpLbs (withMailbox advancedRequest) manager
- if responseStatus advancedResponse == ok200
- then return advancedResponse
- else do
- directRequest <- liftIO $ parseUrlThrow directUrl
- liftIO $ httpLbs (withMailbox directRequest) manager
+ let localPartLower = T.toLower localPart
+ hu = BC8.unpack . zbase32 . sha1 . TE.encodeUtf8 $ localPartLower
+ advancedUrl =
+ "https://openpgpkey."
+ <> T.unpack domain
+ <> "/.well-known/openpgpkey/"
+ <> T.unpack domain
+ <> "/hu/"
+ <> hu
+ directUrl =
+ "https://"
+ <> T.unpack domain
+ <> "/.well-known/openpgpkey/hu/"
+ <> hu
+ mailboxParam = TE.encodeUtf8 localPartLower
+ withMailbox req = setQueryString [("l", Just mailboxParam)] req
+ advancedRequest <- liftIO $ parseUrlThrow advancedUrl
+ advancedResponse <-
+ liftIO $ httpLbs (withMailbox advancedRequest) manager
+ if responseStatus advancedResponse == ok200
+ then return advancedResponse
+ else do
+ directRequest <- liftIO $ parseUrlThrow directUrl
+ liftIO $ httpLbs (withMailbox directRequest) manager
-validateAndFilterKeys ::
- FetchValidationMethod
- -> (Text, Text)
- -> BL.ByteString
- -> ExceptT String IO [TKUnknown]
+validateAndFilterKeys
+ :: FetchValidationMethod
+ -> (Text, Text)
+ -> BL.ByteString
+ -> ExceptT String IO [TKUnknown]
validateAndFilterKeys fvm mailbox body = do
- keys <- decodeWkdResponse body
- cpt <- liftIO getPOSIXTime
- let processedKeys = rights $ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
- mailboxFiltered = filter (mailboxMatchesKey mailbox . snd) processedKeys
- return $
- map fst $
- case fvm of
- AnySelfSigned -> processedKeys
- MatchPrimaryKeyFingerprint -> mailboxFiltered
- MatchPrimaryOrAnySubkeyFingerprint -> mailboxFiltered
+ keys <- decodeWkdResponse body
+ cpt <- liftIO getPOSIXTime
+ let processedKeys =
+ rights $
+ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
+ mailboxFiltered = filter (mailboxMatchesKey mailbox . snd) processedKeys
+ return $
+ map fst $
+ case fvm of
+ AnySelfSigned -> processedKeys
+ MatchPrimaryKeyFingerprint -> mailboxFiltered
+ MatchPrimaryOrAnySubkeyFingerprint -> mailboxFiltered
-decodeWkdResponse :: BL.ByteString -> ExceptT String IO [TKUnknown]
+decodeWkdResponse
+ :: BL.ByteString -> ExceptT String IO [TKUnknown]
decodeWkdResponse body =
- if isArmored body
- then decodeArmored body
- else decodeBinary body
+ if isArmored body
+ then decodeArmored body
+ else decodeBinary body
decodeBinary :: BL.ByteString -> ExceptT String IO [TKUnknown]
decodeBinary bytes =
- liftIO . runConduitRes $
- CB.sourceLbs bytes .| conduitGet get .| conduitToTKsDropping .| CL.consume
+ liftIO . runConduitRes $
+ CB.sourceLbs bytes
+ .| conduitGet get
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable id
+ .| CL.mapMaybe id
+ .| CL.consume
decodeArmored :: BL.ByteString -> ExceptT String IO [TKUnknown]
decodeArmored larmors = do
- bytestrings <- ExceptT . return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
- liftIO . runConduitRes $
- CB.sourceLbs bytestrings .| conduitGet get .| conduitToTKsDropping .| CL.consume
+ bytestrings <-
+ ExceptT . return $
+ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
+ liftIO . runConduitRes $
+ CB.sourceLbs bytestrings
+ .| conduitGet get
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable id
+ .| CL.mapMaybe id
+ .| CL.consume
where
armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs
armorToBS _ = mempty
isArmored :: BL.ByteString -> Bool
isArmored =
- BC8.isPrefixOf "-----BEGIN PGP PUBLIC KEY BLOCK-----" . BL.toStrict . BL.take 40
+ BC8.isPrefixOf "-----BEGIN PGP PUBLIC KEY BLOCK-----"
+ . BL.toStrict
+ . BL.take 40
mailboxMatchesKey :: (Text, Text) -> TKUnknown -> Bool
mailboxMatchesKey (localPart, domain) tk =
- let mailbox = T.toLower (localPart <> "@" <> domain)
- bracketedMailbox = "<" <> mailbox <> ">"
- in any
- (\uid -> let lowered = T.toLower uid in lowered == mailbox || bracketedMailbox `T.isInfixOf` lowered)
- (map fst (_tkuUIDs tk))
+ let mailbox = T.toLower (localPart <> "@" <> domain)
+ bracketedMailbox = "<" <> mailbox <> ">"
+ in any
+ ( \uid ->
+ let lowered = T.toLower uid
+ in lowered == mailbox || bracketedMailbox `T.isInfixOf` lowered
+ )
+ (map fst (_tkuUIDs tk))
sha1 :: B.ByteString -> B.ByteString
sha1 bs = BA.convert (CH.hashWith CHA.SHA1 bs :: CH.Digest CHA.SHA1)
@@ -175,9 +202,10 @@
pick i = alphabet !! i
go _ 0 [] = []
go acc bits [] =
- [pick (fromIntegral (((acc `shiftL` (5 - bits)) .&. 31) :: Int))]
- go acc bits (x:xs)
- | bits >= 5 =
- pick (fromIntegral (((acc `shiftR` (bits - 5)) .&. 31) :: Int)) :
- go acc (bits - 5) (x : xs)
- | otherwise = go ((acc `shiftL` 8) .|. fromIntegral x) (bits + 8) xs
+ [pick (fromIntegral (((acc `shiftL` (5 - bits)) .&. 31) :: Int))]
+ go acc bits (x : xs)
+ | bits >= 5 =
+ pick (fromIntegral (((acc `shiftR` (bits - 5)) .&. 31) :: Int))
+ : go acc (bits - 5) (x : xs)
+ | otherwise =
+ go ((acc `shiftL` 8) .|. fromIntegral x) (bits + 8) xs
diff --git a/HOpenPGP/Tools/Hokey/Canonicalize.hs b/HOpenPGP/Tools/Hokey/Canonicalize.hs
--- a/HOpenPGP/Tools/Hokey/Canonicalize.hs
+++ b/HOpenPGP/Tools/Hokey/Canonicalize.hs
@@ -17,41 +17,44 @@
-- along with this program. If not, see .
module HOpenPGP.Tools.Hokey.Canonicalize
- (
- doCanonicalize
- ) where
+ ( doCanonicalize
+ ) where
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
-import Control.Lens (_2, mapped, over)
+import Control.Error.Util (hush)
+import Control.Lens (mapped, over, _2)
+import Control.Monad (join)
import Data.Binary (get, put)
-import Data.Conduit ((.|), runConduitRes)
+import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither)
import Data.Conduit.Serialization.Binary (conduitGet, conduitPut)
import Data.List (nub, sort)
-
import System.IO
- ( stdin
- , stdout
- )
+ ( stdin
+ , stdout
+ )
doCanonicalize :: IO ()
doCanonicalize =
- runConduitRes $ CB.sourceHandle stdin .| conduitGet get .|
- conduitToTKsDropping .|
- CL.map canonicalize .|
- CL.map put .|
- conduitPut .|
- CB.sinkHandle stdout
+ runConduitRes $
+ CB.sourceHandle stdin
+ .| conduitGet get
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CL.map canonicalize
+ .| CL.map put
+ .| conduitPut
+ .| CB.sinkHandle stdout
where
canonicalize tk =
- tk
- { _tkuRevs = sort (_tkuRevs tk)
- , _tkuUIDs = indepthsort (_tkuUIDs tk)
- , _tkuUAts = indepthsort (_tkuUAts tk)
- , _tkuSubs = indepthsort (_tkuSubs tk)
- }
+ tk
+ { _tkuRevs = sort (_tkuRevs tk)
+ , _tkuUIDs = indepthsort (_tkuUIDs tk)
+ , _tkuUAts = indepthsort (_tkuUAts tk)
+ , _tkuSubs = indepthsort (_tkuSubs tk)
+ }
indepthsort :: (Ord a, Ord b) => [(a, [b])] -> [(a, [b])]
indepthsort = nub . sort . over (mapped . _2) sort
diff --git a/HOpenPGP/Tools/Hokey/Fetch.hs b/HOpenPGP/Tools/Hokey/Fetch.hs
--- a/HOpenPGP/Tools/Hokey/Fetch.hs
+++ b/HOpenPGP/Tools/Hokey/Fetch.hs
@@ -17,34 +17,36 @@
-- along with this program. If not, see .
module HOpenPGP.Tools.Hokey.Fetch
- (
- doFetch
- ) where
+ ( doFetch
+ ) where
import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)
import Codec.Encryption.OpenPGP.Serialize ()
-import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import qualified Data.ByteString as B
import qualified Data.Text as T
+import System.IO
+ ( hPutStrLn
+ , stderr
+ )
+
import HOpenPGP.Tools.Common.HKP (rearmorKeys)
import qualified HOpenPGP.Tools.Common.HKP as HKP
import qualified HOpenPGP.Tools.Common.WKD as WKD
-import HOpenPGP.Tools.Hokey.Options (FetchOptions(..), FetchMethod(..))
-
-import System.IO
- ( hPutStrLn
- , stderr
- )
+import HOpenPGP.Tools.Hokey.Options
+ ( FetchMethod (..)
+ , FetchOptions (..)
+ )
doFetch :: FetchOptions -> IO ()
doFetch o = do
- ekeys <-
- runExceptT $
- case fetchMethod o of
- HKP -> do
- fp <- ExceptT . return . parseFingerprint . T.pack $ fetchQuery o
- HKP.fetchKeys (keyServer o) (fetchValidation o) fp
- WKD -> WKD.fetchKeys (fetchValidation o) (T.pack (fetchQuery o))
- case ekeys of
- Left e -> hPutStrLn stderr $ "error fetching keys: " ++ e
- Right ks -> B.putStr $ rearmorKeys ks
+ ekeys <-
+ runExceptT $
+ case fetchMethod o of
+ HKP -> do
+ fp <- ExceptT . return . parseFingerprint . T.pack $ fetchQuery o
+ HKP.fetchKeys (keyServer o) (fetchValidation o) fp
+ WKD -> WKD.fetchKeys (fetchValidation o) (T.pack (fetchQuery o))
+ case ekeys of
+ Left e -> hPutStrLn stderr $ "error fetching keys: " ++ e
+ Right ks -> B.putStr $ rearmorKeys ks
diff --git a/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs b/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs
--- a/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs
+++ b/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs
@@ -15,209 +15,280 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-
{-# LANGUAGE GADTs #-}
module HOpenPGP.Tools.Hokey.InjectSSHAgent
- (
- doInjectSSHAgent
- ) where
+ ( doInjectSSHAgent
+ ) where
+
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.Ontology
- ( isKUF
- , isSKBindingSig
- )
+ ( isKUF
+ , isSKBindingSig
+ )
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Control.Exception (bracket)
import qualified Crypto.PubKey.RSA as RSA
import Data.Binary (get)
import Data.Binary.Get (getWord32be, runGet)
-import Data.Binary.Put (Put, putByteString, putLazyByteString, putWord32be, putWord8, runPut)
-import Data.Bits ((.&.), shiftR, testBit)
+import Data.Binary.Put
+ ( Put
+ , putByteString
+ , putLazyByteString
+ , putWord32be
+ , putWord8
+ , runPut
+ )
+import Data.Bits (shiftR, testBit, (.&.))
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
-import Data.Conduit ((.|), runConduitRes)
+import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
-import Data.Conduit.OpenPGP.Keyring (AuthSecretSubkeyAtTime, authSecretSubkeyPrimaryUID, authSecretSubkeyValue, conduitToAuthSecretSubkeysAt, conduitToSecretTKs)
+import Data.Conduit.OpenPGP.Keyring
+ ( AuthSecretSubkeyAtTime
+ , authSecretSubkeyPrimaryUID
+ , authSecretSubkeyValue
+ , conduitToAuthSecretSubkeysAt
+ , conduitToSomeTKsDroppingEither
+ )
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Foldable (find)
import Data.List (intercalate, sortOn)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
-import Data.Ord (Down(..))
+import Data.Ord (Down (..))
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
-import HOpenPGP.Tools.Common.Common (renderFingerprint)
-import Network.Socket (Family(AF_UNIX), SockAddr(..), Socket, SocketType(Stream), close, connect, defaultProtocol, socket)
+import Data.Time.Clock.POSIX
+ ( POSIXTime
+ , getPOSIXTime
+ , posixSecondsToUTCTime
+ )
+import Network.Socket
+ ( Family (AF_UNIX)
+ , SockAddr (..)
+ , Socket
+ , SocketType (Stream)
+ , close
+ , connect
+ , defaultProtocol
+ , socket
+ )
import qualified Network.Socket.ByteString as NSB
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
-import HOpenPGP.Tools.Hokey.Options (InjectSSHAgentOptions(..))
import System.IO
- ( hPutStrLn
- , stderr
- , stdin
- )
+ ( hPutStrLn
+ , stderr
+ , stdin
+ )
+import HOpenPGP.Tools.Common.Common (renderFingerprint)
+import HOpenPGP.Tools.Hokey.Options (InjectSSHAgentOptions (..))
+
doInjectSSHAgent :: InjectSSHAgentOptions -> IO ()
doInjectSSHAgent opts = do
- socketPath <- resolveSSHAgentSocketPath (injectSSHAgentSocket opts)
- input <- readInjectedSecretKeyMaterial opts
- cpt <- getPOSIXTime
- authCandidates <-
- runConduitRes $
- CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|
- conduitToAuthSecretSubkeysAt (posixSecondsToUTCTime cpt) .|
- CL.consume
- injectableCandidates <-
- if null authCandidates
- then inferInjectableAuthSubkeys cpt input
- else pure (map candidateFromAuthSecretSubkey authCandidates)
- whenEmpty injectableCandidates "inject-ssh-agent: no authentication-capable secret subkey found"
- selectedRequests <-
- selectInjectableAuthSubkeys
- (injectSSHAgentComment opts)
- injectableCandidates
- mapM_
- (\(selected, request) -> do
- sendAddIdentityToSSHAgent socketPath request
- hPutStrLn stderr $
- "inject-ssh-agent: added authentication subkey " ++
- renderFingerprint (fingerprint (injectableAuthSubkeyPKP selected)) ++
- " to ssh-agent")
- selectedRequests
+ socketPath <-
+ resolveSSHAgentSocketPath (injectSSHAgentSocket opts)
+ input <- readInjectedSecretKeyMaterial opts
+ cpt <- getPOSIXTime
+ authCandidates <-
+ runConduitRes $
+ CL.sourceList (BL.toChunks input)
+ .| conduitGet get
+ .| conduitToSomeTKsDroppingEither
+ .| CL.mapMaybe (either (const Nothing) (>>= someTKToSecretTK))
+ .| conduitToAuthSecretSubkeysAt (posixSecondsToUTCTime cpt)
+ .| CL.consume
+ injectableCandidates <-
+ if null authCandidates
+ then inferInjectableAuthSubkeys cpt input
+ else pure (map candidateFromAuthSecretSubkey authCandidates)
+ whenEmpty
+ injectableCandidates
+ "inject-ssh-agent: no authentication-capable secret subkey found"
+ selectedRequests <-
+ selectInjectableAuthSubkeys
+ (injectSSHAgentComment opts)
+ injectableCandidates
+ mapM_
+ ( \(selected, request) -> do
+ sendAddIdentityToSSHAgent socketPath request
+ hPutStrLn stderr $
+ "inject-ssh-agent: added authentication subkey "
+ ++ renderFingerprint
+ (fingerprint (injectableAuthSubkeyPKP selected))
+ ++ " to ssh-agent"
+ )
+ selectedRequests
-candidateFromAuthSecretSubkey :: AuthSecretSubkeyAtTime -> InjectableAuthSubkey
+candidateFromAuthSecretSubkey
+ :: AuthSecretSubkeyAtTime -> InjectableAuthSubkey
candidateFromAuthSecretSubkey authSubkey =
- InjectableAuthSubkey
- { injectableAuthSubkeyPKP = authSecretSubkeyPKP authSubkey
- , injectableAuthSubkeySKA = authSecretSubkeySKA authSubkey
- , injectableAuthSubkeyPrimaryUID = authSecretSubkeyPrimaryUID authSubkey
- }
+ InjectableAuthSubkey
+ { injectableAuthSubkeyPKP = authSecretSubkeyPKP authSubkey
+ , injectableAuthSubkeySKA = authSecretSubkeySKA authSubkey
+ , injectableAuthSubkeyPrimaryUID =
+ authSecretSubkeyPrimaryUID authSubkey
+ }
-inferInjectableAuthSubkeys ::
- POSIXTime -> BL.ByteString -> IO [InjectableAuthSubkey]
+inferInjectableAuthSubkeys
+ :: POSIXTime -> BL.ByteString -> IO [InjectableAuthSubkey]
inferInjectableAuthSubkeys _cpt input = do
- tks <-
- runConduitRes $
- CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|
- CL.consume
- pure (concatMap inferFromTK tks)
+ tks <-
+ runConduitRes $
+ CL.sourceList (BL.toChunks input)
+ .| conduitGet get
+ .| conduitToSomeTKsDroppingEither
+ .| CL.mapMaybe (either (const Nothing) (>>= someTKToSecretTK))
+ .| CL.consume
+ pure (concatMap inferFromTK tks)
where
inferFromTK tk =
- let mPrimaryUID = fst <$> listToMaybe (_tkUIDs tk)
- in mapMaybe (inferFromSubkey mPrimaryUID) (_tkSubs tk)
- inferFromSubkey :: Maybe Text -> (KeyPkt k, [SignaturePayload]) -> Maybe InjectableAuthSubkey
+ let mPrimaryUID = fst <$> listToMaybe (_tkUIDs tk)
+ in mapMaybe (inferFromSubkey mPrimaryUID) (_tkSubs tk)
+ inferFromSubkey
+ :: Maybe Text
+ -> (KeyPkt k, [SignaturePayload])
+ -> Maybe InjectableAuthSubkey
inferFromSubkey mPrimaryUID (KeyPktSecretSubkey pkp ska, sigs)
- | hasAuthCapability sigs =
- Just
- InjectableAuthSubkey
- { injectableAuthSubkeyPKP = pkp
- , injectableAuthSubkeySKA = ska
- , injectableAuthSubkeyPrimaryUID = mPrimaryUID
- }
+ | hasAuthCapability sigs =
+ Just
+ InjectableAuthSubkey
+ { injectableAuthSubkeyPKP = pkp
+ , injectableAuthSubkeySKA = ska
+ , injectableAuthSubkeyPrimaryUID = mPrimaryUID
+ }
inferFromSubkey _ _ = Nothing
hasAuthCapability sigs =
- any
- (Set.member AuthKey)
- (mapMaybe signatureKeyFlags (newestWithUsageFlags (filter isSKBindingSig sigs)))
+ any
+ (Set.member AuthKey)
+ ( mapMaybe
+ signatureKeyFlags
+ (newestWithUsageFlags (filter isSKBindingSig sigs))
+ )
newestWithUsageFlags =
- take 1 . sortOn (Down . take 1 . sigCreationTimes) . filter (any isKUF . signatureHashedSubpackets)
- sigCreationTimes = mapMaybe sigCreationTimeFromSubpacket . signatureHashedSubpackets
+ take 1
+ . sortOn (Down . take 1 . sigCreationTimes)
+ . filter (any isKUF . signatureHashedSubpackets)
+ sigCreationTimes =
+ mapMaybe sigCreationTimeFromSubpacket . signatureHashedSubpackets
sigCreationTimeFromSubpacket (SigSubPacket _ (SigCreationTime ct)) = Just ct
sigCreationTimeFromSubpacket _ = Nothing
signatureHashedSubpackets (SigV4 _ _ _ hasheds _ _ _) = hasheds
signatureHashedSubpackets (SigV6 _ _ _ _ hasheds _ _ _) = hasheds
signatureHashedSubpackets _ = []
signatureKeyFlags sig = do
- sp <- find isKUF (signatureHashedSubpackets sig)
- case sp of
- SigSubPacket _ (KeyFlags flags) -> Just flags
- _ -> Nothing
+ sp <- find isKUF (signatureHashedSubpackets sig)
+ case sp of
+ SigSubPacket _ (KeyFlags flags) -> Just flags
+ _ -> Nothing
resolveSSHAgentSocketPath :: Maybe String -> IO String
resolveSSHAgentSocketPath (Just path) = pure path
resolveSSHAgentSocketPath Nothing = do
- envPath <- lookupEnv "SSH_AUTH_SOCK"
- case envPath of
- Just path -> pure path
- Nothing ->
- failInject
- "inject-ssh-agent: SSH_AUTH_SOCK is not set; use --ssh-agent-socket"
+ envPath <- lookupEnv "SSH_AUTH_SOCK"
+ case envPath of
+ Just path -> pure path
+ Nothing ->
+ failInject
+ "inject-ssh-agent: SSH_AUTH_SOCK is not set; use --ssh-agent-socket"
-readInjectedSecretKeyMaterial :: InjectSSHAgentOptions -> IO BL.ByteString
+readInjectedSecretKeyMaterial
+ :: InjectSSHAgentOptions -> IO BL.ByteString
readInjectedSecretKeyMaterial opts = do
- chunks <-
- case injectSSHAgentFromFD opts of
- Nothing -> runConduitRes $ CB.sourceHandle stdin .| CL.consume
- Just fd
- | fd < 0 ->
- failInject "inject-ssh-agent: --from-fd must be a non-negative integer"
- | otherwise ->
- runConduitRes $ CB.sourceFile ("/dev/fd/" ++ show fd) .| CL.consume
- let input = BL.fromChunks chunks
- if BL.null input
- then
- failInject
- "inject-ssh-agent: no secret key bytes were provided on the selected input stream"
- else pure input
+ chunks <-
+ case injectSSHAgentFromFD opts of
+ Nothing -> runConduitRes $ CB.sourceHandle stdin .| CL.consume
+ Just fd
+ | fd < 0 ->
+ failInject
+ "inject-ssh-agent: --from-fd must be a non-negative integer"
+ | otherwise ->
+ runConduitRes $
+ CB.sourceFile ("/dev/fd/" ++ show fd) .| CL.consume
+ let input = BL.fromChunks chunks
+ if BL.null input
+ then
+ failInject
+ "inject-ssh-agent: no secret key bytes were provided on the selected input stream"
+ else pure input
-selectInjectableAuthSubkeys ::
- Maybe String -> [InjectableAuthSubkey] -> IO [(InjectableAuthSubkey, BL.ByteString)]
+selectInjectableAuthSubkeys
+ :: Maybe String
+ -> [InjectableAuthSubkey]
+ -> IO [(InjectableAuthSubkey, BL.ByteString)]
selectInjectableAuthSubkeys mComment candidates
- | null selectedRequests =
- failInject
- ("inject-ssh-agent: auth-capable subkeys were found, but none are supported for ssh-agent injection: " ++
- intercalate "; " (reverse errs))
- | otherwise = pure (reverse selectedRequests)
+ | null selectedRequests =
+ failInject
+ ( "inject-ssh-agent: auth-capable subkeys were found, but none are supported for ssh-agent injection: "
+ ++ intercalate "; " (reverse errs)
+ )
+ | otherwise = pure (reverse selectedRequests)
where
(errs, selectedRequests) = foldl' pick ([], []) candidates
pick (accErrs, accSelected) candidate =
- case
- sshAddIdentityRequest
- (fromMaybe (defaultSSHComment candidate) mComment)
- (injectableAuthSubkeyPKP candidate)
- (injectableAuthSubkeySKA candidate) of
- Left err -> (err : accErrs, accSelected)
- Right request -> (accErrs, (candidate, request) : accSelected)
+ case sshAddIdentityRequest
+ (fromMaybe (defaultSSHComment candidate) mComment)
+ (injectableAuthSubkeyPKP candidate)
+ (injectableAuthSubkeySKA candidate) of
+ Left err -> (err : accErrs, accSelected)
+ Right request -> (accErrs, (candidate, request) : accSelected)
defaultSSHComment candidate =
- case injectableAuthSubkeyPrimaryUID candidate of
- Just uid -> T.unpack uid
- Nothing -> "openpgp:" ++ BC8.unpack (Base16.encode (BL.toStrict (unFingerprint (fingerprint (injectableAuthSubkeyPKP candidate)))))
+ case injectableAuthSubkeyPrimaryUID candidate of
+ Just uid -> T.unpack uid
+ Nothing ->
+ "openpgp:"
+ ++ BC8.unpack
+ ( Base16.encode
+ ( BL.toStrict
+ (unFingerprint (fingerprint (injectableAuthSubkeyPKP candidate)))
+ )
+ )
-sshAddIdentityRequest ::
- String -> SomePKPayload -> SKAddendum -> Either String BL.ByteString
+sshAddIdentityRequest
+ :: String
+ -> SomePKPayload
+ -> SKAddendum
+ -> Either String BL.ByteString
sshAddIdentityRequest comment subkeyPKP subkeySKA =
- case subkeySKA of
- SUUnencrypted (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) _ ->
- Right $ frameSSHAgentRequest (rsaAddIdentityPayload (BC8.pack comment) rsaPrivateKey)
- SUUnencrypted (EdDSAPrivateKey Ed25519 secretSeed) _ ->
- frameSSHAgentRequest <$>
- ed25519AddIdentityPayload (BC8.pack comment) subkeyPKP secretSeed
- SUUnencrypted (UnknownSKey rawSecret) _
- | isEd25519PKA (_pkalgo subkeyPKP) ->
- frameSSHAgentRequest <$>
- ed25519AddIdentityPayload
- (BC8.pack comment)
- subkeyPKP
- (BL.toStrict rawSecret)
- SUUnencrypted (EdDSAPrivateKey Ed448 _) _ ->
- Left
- ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
- " uses Ed448, which is not supported by ssh-agent add-identity")
- SUUnencrypted _ _ ->
- Left
- ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
- " uses an unsupported key algorithm for ssh-agent injection")
- _ ->
- Left
- ("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
- " is encrypted; decrypt it before injection")
+ case subkeySKA of
+ SUUnencrypted (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) _ ->
+ Right $
+ frameSSHAgentRequest
+ (rsaAddIdentityPayload (BC8.pack comment) rsaPrivateKey)
+ SUUnencrypted (EdDSAPrivateKey Ed25519 secretSeed) _ ->
+ frameSSHAgentRequest
+ <$> ed25519AddIdentityPayload (BC8.pack comment) subkeyPKP secretSeed
+ SUUnencrypted (UnknownSKey rawSecret) _
+ | isEd25519PKA (_pkalgo subkeyPKP) ->
+ frameSSHAgentRequest
+ <$> ed25519AddIdentityPayload
+ (BC8.pack comment)
+ subkeyPKP
+ (BL.toStrict rawSecret)
+ SUUnencrypted (EdDSAPrivateKey Ed448 _) _ ->
+ Left
+ ( "subkey "
+ ++ renderFingerprint (fingerprint subkeyPKP)
+ ++ " uses Ed448, which is not supported by ssh-agent add-identity"
+ )
+ SUUnencrypted _ _ ->
+ Left
+ ( "subkey "
+ ++ renderFingerprint (fingerprint subkeyPKP)
+ ++ " uses an unsupported key algorithm for ssh-agent injection"
+ )
+ _ ->
+ Left
+ ( "subkey "
+ ++ renderFingerprint (fingerprint subkeyPKP)
+ ++ " is encrypted; decrypt it before injection"
+ )
authSecretSubkeyPKP :: AuthSecretSubkeyAtTime -> SomePKPayload
authSecretSubkeyPKP = keyPktPKPayload . authSecretSubkeyValue
@@ -225,126 +296,150 @@
authSecretSubkeySKA :: AuthSecretSubkeyAtTime -> SKAddendum
authSecretSubkeySKA = secretKeyPktSKAddendum . authSecretSubkeyValue
-rsaAddIdentityPayload :: B.ByteString -> RSA.PrivateKey -> BL.ByteString
+rsaAddIdentityPayload
+ :: B.ByteString -> RSA.PrivateKey -> BL.ByteString
rsaAddIdentityPayload comment privateKey =
- runPut $ do
- putWord8 17
- putSSHString (BC8.pack "ssh-rsa")
- putSSHMpint (RSA.public_n (RSA.private_pub privateKey))
- putSSHMpint (RSA.public_e (RSA.private_pub privateKey))
- putSSHMpint (RSA.private_d privateKey)
- putSSHMpint (RSA.private_qinv privateKey)
- putSSHMpint (RSA.private_p privateKey)
- putSSHMpint (RSA.private_q privateKey)
- putSSHString comment
+ runPut $ do
+ putWord8 17
+ putSSHString (BC8.pack "ssh-rsa")
+ putSSHMpint (RSA.public_n (RSA.private_pub privateKey))
+ putSSHMpint (RSA.public_e (RSA.private_pub privateKey))
+ putSSHMpint (RSA.private_d privateKey)
+ putSSHMpint (RSA.private_qinv privateKey)
+ putSSHMpint (RSA.private_p privateKey)
+ putSSHMpint (RSA.private_q privateKey)
+ putSSHString comment
-ed25519AddIdentityPayload ::
- B.ByteString -> SomePKPayload -> B.ByteString -> Either String BL.ByteString
+ed25519AddIdentityPayload
+ :: B.ByteString
+ -> SomePKPayload
+ -> B.ByteString
+ -> Either String BL.ByteString
ed25519AddIdentityPayload comment pkp rawSecret = do
- publicKey <- ed25519PublicPoint pkp
- secretSeed <- normalizeEd25519Secret rawSecret
- pure $
- runPut $ do
- putWord8 17
- putSSHString (BC8.pack "ssh-ed25519")
- putSSHString publicKey
- putSSHString (secretSeed <> publicKey)
- putSSHString comment
+ publicKey <- ed25519PublicPoint pkp
+ secretSeed <- normalizeEd25519Secret rawSecret
+ pure $
+ runPut $ do
+ putWord8 17
+ putSSHString (BC8.pack "ssh-ed25519")
+ putSSHString publicKey
+ putSSHString (secretSeed <> publicKey)
+ putSSHString comment
ed25519PublicPoint :: SomePKPayload -> Either String B.ByteString
ed25519PublicPoint pkp =
- case _pubkey pkp of
- EdDSAPubKey Ed25519 point ->
- maybe
- (Left ("invalid Ed25519 public point for subkey " ++ renderFingerprint (fingerprint pkp)))
- Right
- (edPointToRawBytes point)
- _ -> Left ("subkey " ++ renderFingerprint (fingerprint pkp) ++ " does not have an Ed25519 public key")
+ case _pubkey pkp of
+ EdDSAPubKey Ed25519 point ->
+ maybe
+ ( Left
+ ( "invalid Ed25519 public point for subkey "
+ ++ renderFingerprint (fingerprint pkp)
+ )
+ )
+ Right
+ (edPointToRawBytes point)
+ _ ->
+ Left
+ ( "subkey "
+ ++ renderFingerprint (fingerprint pkp)
+ ++ " does not have an Ed25519 public key"
+ )
edPointToRawBytes :: EdPoint -> Maybe B.ByteString
edPointToRawBytes (NativeEPoint (EPoint i)) = integerToFixedBytes 32 i
edPointToRawBytes (PrefixedNativeEPoint (EPoint i)) = do
- prefixed <- integerToFixedBytes 33 i
- case B.uncons prefixed of
- Just (0x40, raw) -> Just raw
- _ -> Nothing
+ prefixed <- integerToFixedBytes 33 i
+ case B.uncons prefixed of
+ Just (0x40, raw) -> Just raw
+ _ -> Nothing
-normalizeEd25519Secret :: B.ByteString -> Either String B.ByteString
+normalizeEd25519Secret
+ :: B.ByteString -> Either String B.ByteString
normalizeEd25519Secret rawSecret
- | B.length rawSecret == 32 = Right rawSecret
- | otherwise =
- Left
- ("expected 32-byte Ed25519 secret seed, got " ++ show (B.length rawSecret) ++ " bytes")
+ | B.length rawSecret == 32 = Right rawSecret
+ | otherwise =
+ Left
+ ( "expected 32-byte Ed25519 secret seed, got "
+ ++ show (B.length rawSecret)
+ ++ " bytes"
+ )
putSSHString :: B.ByteString -> Put
putSSHString bs = putWord32be (fromIntegral (B.length bs)) >> putByteString bs
putSSHMpint :: Integer -> Put
putSSHMpint n
- | n <= 0 = putWord32be 0
- | otherwise = putSSHString encoded
+ | n <= 0 = putWord32be 0
+ | otherwise = putSSHString encoded
where
raw = integerToUnsignedBytes n
encoded =
- case B.uncons raw of
- Just (firstByte, _)
- | testBit firstByte 7 -> B.cons 0x00 raw
- _ -> raw
+ case B.uncons raw of
+ Just (firstByte, _)
+ | testBit firstByte 7 -> B.cons 0x00 raw
+ _ -> raw
integerToFixedBytes :: Int -> Integer -> Maybe B.ByteString
integerToFixedBytes width n
- | n < 0 = Nothing
- | B.length raw > width = Nothing
- | otherwise = Just (B.replicate (width - B.length raw) 0x00 <> raw)
+ | n < 0 = Nothing
+ | B.length raw > width = Nothing
+ | otherwise =
+ Just (B.replicate (width - B.length raw) 0x00 <> raw)
where
raw =
- if n == 0
- then B.singleton 0x00
- else integerToUnsignedBytes n
+ if n == 0
+ then B.singleton 0x00
+ else integerToUnsignedBytes n
integerToUnsignedBytes :: Integer -> B.ByteString
integerToUnsignedBytes n =
- B.reverse $
- B.unfoldr
- (\value ->
- if value == 0
- then Nothing
- else Just (fromIntegral (value .&. 0xff), value `shiftR` 8))
- n
+ B.reverse $
+ B.unfoldr
+ ( \value ->
+ if value == 0
+ then Nothing
+ else Just (fromIntegral (value .&. 0xff), value `shiftR` 8)
+ )
+ n
isEd25519PKA :: PubKeyAlgorithm -> Bool
isEd25519PKA pka = fromFVal pka == 27
frameSSHAgentRequest :: BL.ByteString -> BL.ByteString
frameSSHAgentRequest body =
- runPut $ putWord32be (fromIntegral (BL.length body)) >> putLazyByteString body
+ runPut $
+ putWord32be (fromIntegral (BL.length body))
+ >> putLazyByteString body
sendAddIdentityToSSHAgent :: FilePath -> BL.ByteString -> IO ()
sendAddIdentityToSSHAgent socketPath request =
- bracket
- (socket AF_UNIX Stream defaultProtocol)
- close
- (\sock -> do
- connect sock (SockAddrUnix socketPath)
- NSB.sendAll sock (BL.toStrict request)
- response <- readSSHAgentPacket sock
- case B.uncons response of
- Just (6, _) -> pure ()
- Just (5, _) ->
- failInject "inject-ssh-agent: ssh-agent rejected the supplied key"
- Just (code, _) ->
- failInject
- ("inject-ssh-agent: ssh-agent returned unexpected response type " ++
- show code)
- Nothing ->
- failInject
- "inject-ssh-agent: ssh-agent returned an empty response packet")
+ bracket
+ (socket AF_UNIX Stream defaultProtocol)
+ close
+ ( \sock -> do
+ connect sock (SockAddrUnix socketPath)
+ NSB.sendAll sock (BL.toStrict request)
+ response <- readSSHAgentPacket sock
+ case B.uncons response of
+ Just (6, _) -> pure ()
+ Just (5, _) ->
+ failInject
+ "inject-ssh-agent: ssh-agent rejected the supplied key"
+ Just (code, _) ->
+ failInject
+ ( "inject-ssh-agent: ssh-agent returned unexpected response type "
+ ++ show code
+ )
+ Nothing ->
+ failInject
+ "inject-ssh-agent: ssh-agent returned an empty response packet"
+ )
readSSHAgentPacket :: Socket -> IO B.ByteString
readSSHAgentPacket sock = do
- lenPrefix <- recvExact sock 4
- let packetLen = fromIntegral (runGet getWord32be (BL.fromStrict lenPrefix))
- recvExact sock packetLen
+ lenPrefix <- recvExact sock 4
+ let packetLen = fromIntegral (runGet getWord32be (BL.fromStrict lenPrefix))
+ recvExact sock packetLen
recvExact :: Socket -> Int -> IO B.ByteString
recvExact _ 0 = pure B.empty
@@ -352,12 +447,12 @@
where
go acc 0 = pure acc
go acc bytesRemaining = do
- chunk <- NSB.recv sock bytesRemaining
- if B.null chunk
- then
- failInject
- "inject-ssh-agent: ssh-agent socket closed while reading response"
- else go (acc <> chunk) (bytesRemaining - B.length chunk)
+ chunk <- NSB.recv sock bytesRemaining
+ if B.null chunk
+ then
+ failInject
+ "inject-ssh-agent: ssh-agent socket closed while reading response"
+ else go (acc <> chunk) (bytesRemaining - B.length chunk)
whenEmpty :: [a] -> String -> IO ()
whenEmpty [] msg = failInject msg
@@ -366,8 +461,8 @@
failInject :: String -> IO a
failInject msg = hPutStrLn stderr msg >> exitFailure
-data InjectableAuthSubkey =
- InjectableAuthSubkey
+data InjectableAuthSubkey
+ = InjectableAuthSubkey
{ injectableAuthSubkeyPKP :: SomePKPayload
, injectableAuthSubkeySKA :: SKAddendum
, injectableAuthSubkeyPrimaryUID :: Maybe Text
diff --git a/HOpenPGP/Tools/Hokey/Lint.hs b/HOpenPGP/Tools/Hokey/Lint.hs
--- a/HOpenPGP/Tools/Hokey/Lint.hs
+++ b/HOpenPGP/Tools/Hokey/Lint.hs
@@ -15,696 +15,942 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeApplications #-}
-
-module HOpenPGP.Tools.Hokey.Lint
- (
- doLint
- ) where
-
-import Codec.Encryption.OpenPGP.Expirations (getKeyExpirationTimesFromSignature)
-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
-import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)
-import Codec.Encryption.OpenPGP.Ontology
- ( isCT
- , isCertRevocationSig
- , isKUF
- , isPHA
- , isPKBindingSig
- , isSKBindingSig
- )
-import Codec.Encryption.OpenPGP.Serialize ()
-import Codec.Encryption.OpenPGP.Types
-import Control.Arrow ((***))
-import Control.Error.Util (hush)
-import Control.Lens ((&), (^.), _1)
-import Control.Monad.Trans.Writer.Lazy (execWriter, tell)
-import qualified Crypto.Hash as CH
-import qualified Crypto.Hash.Algorithms as CHA
-import qualified Data.Aeson as A
-import Data.Binary (get)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Base16 as Base16
-import qualified Data.ByteString.Char8 as BC8
-import qualified Data.ByteString.Lazy as BL
-import Data.Conduit ((.|), runConduitRes)
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.List as CL
-import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
-import Data.Conduit.Serialization.Binary (conduitGet)
-import Data.Foldable (find)
-import Data.List (elemIndex, findIndex, intercalate, sortOn)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
-import Data.Ord (Down(..))
-import qualified Data.Set as Set
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
-import Data.Time.Format (formatTime)
-import qualified Data.Yaml as Y
-import GHC.Generics
-import HOpenPGP.Tools.Common.Common (renderKeyID, renderFingerprint)
-import HOpenPGP.Tools.Common.TKUtils (processTK)
-import HOpenPGP.Tools.Hokey.Options (LintOptions(..), LintOutputFormat(..))
-
-import Data.Time.Locale.Compat (defaultTimeLocale)
-import System.IO
- ( stdin
- )
-
-import Prettyprinter
- ( Doc
- , (<+>)
- , annotate
- , colon
- , flatAlt
- , indent
- , line
- , list
- , pretty
- )
-import qualified Prettyprinter.Render.Terminal as PPA
-
-linebreak :: Doc ann
-linebreak = flatAlt line mempty
-
-green, yellow, red :: Doc PPA.AnsiStyle -> Doc PPA.AnsiStyle
-green = annotate (PPA.color PPA.Green)
-yellow = annotate (PPA.color PPA.Yellow)
-red = annotate (PPA.color PPA.Red)
-
-data KAS =
- KAS
- { pubkeyalgo :: Colored PubKeyAlgorithm
- , pubkeysize :: Colored (Maybe Int)
- , stringrep :: String
- }
- deriving (Generic)
-
-data Color
- = Green
- | Yellow
- | Red
- deriving (Eq, Generic, Ord)
-
-data Colored a =
- Colored
- { color :: Maybe Color
- , explanation :: Maybe String
- , val :: a
- }
- deriving (Functor, Generic)
-
-newtype FakeMap a b =
- FakeMap
- { unFakeMap :: [(a, b)]
- }
-
-data KeyReport =
- KeyReport
- { keyStatus :: String
- , keyFingerprint :: Fingerprint
- , keyVer :: Colored KeyVersion
- , keyCreationTime :: ThirtyTwoBitTimeStamp
- , keyAlgorithmAndSize :: KAS
- , keyUIDsAndUAts :: FakeMap Text (Colored UIDReport)
- , keyBestOf :: Maybe UIDReport
- , keySubkeys :: [SubkeyReport]
- , keyHasEncryptionCapableSubkey :: Colored Bool
- }
- deriving (Generic)
-
-data UIDReport =
- UIDReport
- { uidSelfSigHashAlgorithms :: [Colored HashAlgorithm]
- , uidPreferredHashAlgorithms :: [Colored [HashAlgorithm]]
- , uidKeyExpirationTimes :: [Colored [ThirtyTwoBitDuration]]
- , uidKeyUsageFlags :: [Colored (Set.Set KeyFlag)]
- , uidRevocationStatus :: [RevocationStatus]
- }
- deriving (Generic)
-
-data SubkeyReport =
- SubkeyReport
- { skFingerprint :: Colored Fingerprint
- , skVer :: Colored KeyVersion
- , skCreationTime :: ThirtyTwoBitTimeStamp
- , skAlgorithmAndSize :: KAS
- , skBindingSigHashAlgorithms :: [Colored HashAlgorithm]
- , skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning]
- , skUsageFlags :: [Colored (Set.Set KeyFlag)]
- , skCrossCerts :: CrossCertReport
- }
- deriving (Generic)
-
-data SubkeyRevocationDigestWarning =
- SubkeyRevocationDigestWarning
- { srwHashAlgorithm :: HashAlgorithm
- , srwSubkeyFingerprint :: String
- , srwSubkeyKeyID :: Maybe String
- , srwMessage :: String
- }
- deriving (Generic)
-
-data CrossCertReport =
- CrossCertReport
- { ccPresent :: Colored Bool
- , ccHashAlgorithms :: [Colored HashAlgorithm]
- }
- deriving (Generic)
-
-data RevocationStatus =
- RevocationStatus
- { isRevoked :: Bool
- , revocationCode :: String
- , revocationReason :: Text
- }
- deriving (Generic)
-
-instance A.ToJSON KAS
-
-instance A.ToJSON Color
-
-instance (A.ToJSON a) => A.ToJSON (Colored a)
-
-instance A.ToJSON KeyReport
-
-instance A.ToJSON UIDReport
-
-instance A.ToJSON SubkeyReport
-
-instance A.ToJSON SubkeyRevocationDigestWarning
-
-instance A.ToJSON CrossCertReport
-
-instance A.ToJSON b => A.ToJSON (FakeMap Text b) where
- toJSON = A.toJSON . Map.fromList . unFakeMap
-
-instance A.ToJSON RevocationStatus
-
-instance Semigroup UIDReport where
- (<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') =
- UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e')
-
-instance Monoid UIDReport where
- mempty = UIDReport [] [] [] [] []
- mappend = (<>)
-
-checkKey :: Maybe POSIXTime -> TKUnknown -> KeyReport
-checkKey mpt key =
- (\x ->
- x
- { keyBestOf = populateBestOf x
- , keyHasEncryptionCapableSubkey =
- hasEncryptionCapableSubkey (concatMap skUsageFlags (keySubkeys x))
- })
- KeyReport
- { keyStatus = either id (const "good") processedTK
- , keyFingerprint = key ^. tkuKey . _1 & fingerprint
- , keyVer = key ^. tkuKey . _1 & _keyVersion & colorizeKV
- , keyCreationTime = key ^. tkuKey . _1 & _timestamp
- , keyAlgorithmAndSize = kasIt (key ^. tkuKey . _1)
- , keyUIDsAndUAts =
- FakeMap
- (map (\(x, y) -> (x, uidr (Just x) y)) (processedOrOrig ^. tkuUIDs) ++
- map (uatspsToText *** uidr Nothing) (processedOrOrig ^. tkuUAts))
- , keyBestOf = Nothing
- , keySubkeys =
- map (checkSK (key ^. tkuKey . _1 & fingerprint)) (key ^. tkuSubs)
- , keyHasEncryptionCapableSubkey = Colored Nothing Nothing False
- }
- where
- processedOrOrig = either (const key) id processedTK
- processedTK = processTK mpt key
- kasIt :: SomePKPayload -> KAS
- kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize)
- kasIt' :: PubKeyAlgorithm -> Either String Int -> KAS
- kasIt' pka epks =
- KAS
- { pubkeyalgo = colorizePKA pka
- , pubkeysize = colorizePKS pka epks
- , stringrep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka)
- }
- colorizeKV kv =
- uncurry
- Colored
- (if kv == V4
- then (Just Green, Nothing)
- else (Just Red, Just "not a V4 key"))
- kv
- colorizePKA pka
- | pka `elem` [RSA, EdDSA, ECDH] = Colored (Just Green) Nothing pka
- | otherwise =
- Colored
- (Just Yellow)
- (Just "public key algorithm neither RSA nor EdDSA")
- pka
- colorizePKS pka epks = uncurry Colored (colorizePKS' pka epks) (hush epks)
- colorizePKS' pka (Right pks)
- | pka `elem` [EdDSA, ECDH] && pks >= 256 = (Just Green, Nothing)
- | pka `elem` [EdDSA, ECDH] =
- (Just Yellow, Just "Public key size under 256 bits")
- | pka == RSA && pks >= 3072 = (Just Green, Nothing)
- | pka == RSA && pks >= 2048 =
- (Just Yellow, Just "Public key size between 2048 and 3072 bits")
- | pka == RSA = (Just Red, Just "Public key size under 2048 bits")
- | otherwise = (Nothing, Nothing)
- colorizePKS' _ (Left _) =
- (Just Red, Just "public key algorithm not understood")
- colorizePHAs x =
- uncurry
- Colored
- (if preferredWeakHash x
- then (Just Red, Just "weak hash with higher preference")
- else (Just Green, Nothing))
- x
- fSHA2Family = fi (`elem` [SHA512, SHA384, SHA256, SHA224])
- firstStrongSHA2 xs = fSHA2Family xs
- preferredWeakHash xs =
- any
- (\ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2 xs)
- knownWeakHashAlgorithms
- fi x y = fromMaybe maxBound (findIndex x y)
- colorizeKETs ct ts kes
- | null kes = Colored (Just Red) (Just "no expiration set") kes
- | any (\ke -> realToFrac ts + realToFrac ke < ct) kes =
- Colored (Just Red) (Just "expiration passed") kes
- | any (\ke -> realToFrac ts + realToFrac ke > ct + (5 * 31557600)) kes =
- Colored (Just Yellow) (Just "expiration too far in future") kes
- | otherwise = Colored (Just Green) Nothing kes
- eoki pkp
- | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
- | _keyVersion pkp == DeprecatedV3 &&
- elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
- hush . eightOctetKeyID $ pkp
- | otherwise = Nothing
- phas (SigV4 _ _ _ xs _ _ _) =
- colorizePHAs .
- concatMap (\(SigSubPacket _ (PreferredHashAlgorithms x)) -> x) $
- filter isPHA xs
- phas _ = Colored Nothing Nothing []
- has = map (colorizeHA . hashAlgo) . alleged
- colorizeHA ha =
- uncurry
- Colored
- (if isKnownWeakHashAlgorithm ha
- then (Just Red, Just "weak hash algorithm")
- else (Nothing, Nothing))
- ha
- sigcts (SigV4 _ _ _ xs _ _ _) =
- map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs
- sigcts (SigV6 _ _ _ _ xs _ _ _) =
- map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs
- alleged =
- filter
- (\x -> ((==) <$> sigissuer x <*> eoki (key ^. tkuKey . _1)) == Just True)
- uatspsToText = T.pack . uatspsToString
- uatspsToString us =
- ""
- uaspToString (ImageAttribute hdr d) =
- hdrToString hdr ++ ':' : show (BL.length d) ++ ':' :
- BC8.unpack (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
- uaspToString (OtherUASub t d) =
- "other-" ++ show t ++ ':' : show (BL.length d) ++ ':' :
- BC8.unpack (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
- hdrToString (ImageHV1 JPEG) = "jpeg"
- hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)
- uidr Nothing sps =
- Colored
- Nothing
- Nothing
- (UIDReport
- (has sps)
- (map phas sps)
- (map
- (colorizeKETs
- (fromMaybe 0 mpt)
- (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) .
- getKeyExpirationTimesFromSignature)
- sps -- should that be 0?
- )
- (kufs False sps)
- (findRevocationReason sps))
- uidr (Just u) sps =
- colorizeUID
- u
- (UIDReport
- (has sps)
- (map phas sps)
- (map
- (colorizeKETs
- (fromMaybe 0 mpt)
- (unThirtyTwoBitTimeStamp (_timestamp (key ^. tkuKey . _1))) .
- getKeyExpirationTimesFromSignature)
- sps -- should that be 0?
- )
- (kufs False sps)
- (findRevocationReason sps))
- populateBestOf krep =
- Just
- (UIDReport <$> best . uidSelfSigHashAlgorithms <*> best .
- uidPreferredHashAlgorithms <*>
- best .
- uidKeyExpirationTimes <*>
- best .
- uidKeyUsageFlags <*>
- pure [] $
- mconcat (justTheUIDRs krep))
- justTheUIDRs = map (decolorize . snd) . unFakeMap . keyUIDsAndUAts
- best = take 1 . sortOn color
- decolorize (Colored _ _ x) = x
- colorizeUID u
- | '(' `elem` T.unpack u =
- Colored (Just Yellow) (Just "parenthesis in uid") -- FIXME: be more discerning
- | '<' `notElem` T.unpack u =
- Colored (Just Yellow) (Just "no left angle bracket in uid") -- FIXME: be more discerning
- | otherwise = Colored Nothing Nothing
- findRevocationReason = concatMap grabReasons . filter isCertRevocationSig
- grabReasons (SigV4 CertRevocationSig _ _ has _ _ _) =
- mapMaybe (grabReasons' . _sspPayload) has
- grabReasons _ = []
- grabReasons' (ReasonForRevocation a b) =
- Just (RevocationStatus True (show a) b)
- grabReasons' _ = Nothing
- kufs s =
- map
- (colorizeKUFs s . (\(SigSubPacket _ (KeyFlags x)) -> x) .
- fromMaybe undefined .
- find isKUF .
- hasheds) .
- newestWith (any isKUF . hasheds)
- colorizeKUFs False x =
- uncurry
- Colored
- (if (Set.member EncryptStorageKey x ||
- Set.member EncryptCommunicationsKey x) &&
- (Set.member SignDataKey x || Set.member CertifyKeysKey x)
- then (Just Yellow, Just "both signing & encryption")
- else (Just Green, Nothing))
- x
- colorizeKUFs True x =
- uncurry
- Colored
- (if Set.member CertifyKeysKey x
- then (Just Red, Just "certification-capable subkey")
- else (if (Set.member EncryptStorageKey x ||
- Set.member EncryptCommunicationsKey x) &&
- Set.member SignDataKey x
- then (Just Yellow, Just "both signing & encryption")
- else (Just Green, Nothing)))
- x
- newestWith p = take 1 . sortOn (Down . take 1 . sigcts) . filter p -- FIXME: this is terrible
- hasheds (SigV4 _ _ _ xs _ _ _) = xs
- hasheds (SigV6 _ _ _ _ xs _ _ _) = xs
- hasheds _ = []
- checkSK ::
- Fingerprint -> (Pkt, [SignaturePayload]) -> SubkeyReport
- checkSK pf (PublicSubkeyPkt pkp, sigs) = checkSK' pf pkp sigs
- checkSK pf (SecretSubkeyPkt pkp _, sigs) = checkSK' pf pkp sigs
- checkSK' pf pkp sigs =
- (\x -> x {skCrossCerts = ccr (map decolorize (skUsageFlags x)) sigs})
- SubkeyReport
- { skFingerprint = colorizeF pf (fingerprint pkp)
- , skVer = colorizeKV (_keyVersion pkp)
- , skCreationTime = _timestamp pkp
- , skAlgorithmAndSize = kasIt pkp
- , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)
- , skRevocationSigWeakDigests =
- subkeyRevocationSigWeakDigests pkp sigs
- , skUsageFlags = kufs True (filter isSKBindingSig sigs)
- , skCrossCerts = CrossCertReport (Colored Nothing Nothing False) []
- }
- hasEncryptionCapableSubkey skrs =
- if any
- ((\x ->
- Set.member EncryptStorageKey x ||
- Set.member EncryptCommunicationsKey x) .
- decolorize)
- skrs
- then Colored (Just Green) Nothing True
- else Colored
- (Just Red)
- (Just "no encryption-capable subkey present")
- False
- embeddedSigs =
- filter isPKBindingSig . concatMap getEmbeds . filter isSKBindingSig
- getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
- getEmbeds _ = []
- getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]
- getEmbed _ = []
- ccr kufs sigs =
- CrossCertReport (colorES kufs sigs) (map (colorizeHA . hashAlgo) sigs)
- colorES kufs sigs =
- case ( null (embeddedSigs sigs)
- , any (Set.member SignDataKey) kufs
- , any (Set.member AuthKey) kufs) of
- (True, True, True) ->
- Colored
- (Just Red)
- (Just "signing- and auth-capable subkey without cross-cert")
- False
- (True, True, False) ->
- Colored
- (Just Red)
- (Just "signing-capable subkey without cross-cert")
- False
- (True, False, True) ->
- Colored
- (Just Yellow)
- (Just "auth-capable subkey without cross-cert")
- False
- (False, True, True) -> Colored (Just Green) Nothing True
- (False, True, False) -> Colored (Just Green) Nothing True
- (False, False, True) -> Colored (Just Green) Nothing True
- (False, False, False) -> Colored Nothing Nothing True
- (True, _, _) -> Colored Nothing Nothing False
- colorizeF pf fp =
- uncurry
- Colored
- (if pf == fp
- then (Just Red, Just "subkey has same fingerprint as primary key")
- else (Just Green, Nothing))
- fp
- subkeyRevocationSigWeakDigests pkp =
- mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp) .
- filter isSubkeyRevocationSignature
- mkSubkeyRevocationSigWeakDigestWarning pkp sig =
- let ha = hashAlgo sig
- in if isKnownWeakHashAlgorithm ha
- then
- Just
- SubkeyRevocationDigestWarning
- { srwHashAlgorithm = ha
- , srwSubkeyFingerprint = renderFingerprint (fingerprint pkp)
- , srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp))
- , srwMessage =
- "subkey revocation signature uses known-weak digest algorithm"
- }
- else Nothing
-
-prettyKeyReport :: POSIXTime -> TKUnknown -> Doc PPA.AnsiStyle
-prettyKeyReport cpt key = do
- let keyReport = checkKey (Just cpt) key
- execWriter $
- tell
- (linebreak <> pretty "Key has potential validity" <> colon <+>
- pretty (keyStatus keyReport) <>
- linebreak <>
- pretty "Key has fingerprint" <>
- colon <+>
- pretty (SpacedFingerprint (keyFingerprint keyReport)) <>
- linebreak <>
- pretty "Checking to see if key is OpenPGPv4" <>
- colon <+>
- coloredToColor (pretty . show) (keyVer keyReport) <>
- linebreak <>
- (\kas ->
- pretty "Checking the strength of your primary asymmetric key" <> colon <+>
- coloredToColor pretty (pubkeyalgo kas) <+>
- coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas))
- (keyAlgorithmAndSize keyReport) <>
- linebreak <>
- pretty "Checking user-ID- and user-attribute-related items" <>
- colon <>
- mconcat
- (map
- (uidtrip (keyCreationTime keyReport) . gottabeabetterway)
- (unFakeMap (keyUIDsAndUAts keyReport))) <>
- linebreak <>
- pretty "Checking subkeys" <>
- colon <>
- linebreak <>
- indent
- 2
- (pretty "one of the subkeys is encryption-capable" <> colon <+>
- coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)) <>
- mconcat (map subkeyrep (keySubkeys keyReport)) <>
- linebreak)
- where
- coloredToColor f (Colored (Just Green) _ x) = green (f x)
- coloredToColor f (Colored (Just Yellow) _ x) = yellow (f x)
- coloredToColor f (Colored (Just Red) _ x) = red (f x)
- coloredToColor f (Colored Nothing _ x) = f x
- uidtrip ts (u, ur)
- | null (uidRevocationStatus ur) =
- linebreak <> indent 2 (coloredToColor pretty (fmap T.unpack u)) <> colon <>
- linebreak <>
- indent
- 4
- (pretty "Self-sig hash algorithms" <> colon <+>
- (list . map (coloredToColor pretty) . uidSelfSigHashAlgorithms) ur) <>
- linebreak <>
- indent
- 4
- (pretty "Preferred hash algorithms" <> colon <+>
- mconcat (map (coloredToColor pretty) (uidPreferredHashAlgorithms ur))) <>
- linebreak <>
- indent
- 4
- (pretty "Key expiration times" <> colon <+>
- mconcat
- (map
- (coloredToColor list . fmap (map (pretty . keyExp ts)))
- (uidKeyExpirationTimes ur))) <>
- linebreak <>
- indent
- 4
- (pretty "Key usage flags" <> colon <+>
- (list . map (coloredToColor (pretty . Set.toList)))
- (uidKeyUsageFlags ur))
- | otherwise =
- linebreak <> indent 2 (coloredToColor pretty (fmap T.unpack u)) <> colon <+>
- pretty "[revoked]" <>
- linebreak <>
- indent
- 4
- (pretty "Revocation code" <> colon <+>
- list (map (pretty . revocationCode) (uidRevocationStatus ur))) <>
- linebreak <>
- indent
- 4
- (pretty "Revocation reason" <> colon <+>
- list
- (map
- (pretty . T.unpack . revocationReason)
- (uidRevocationStatus ur)))
- keyExp ts ke =
- (show . pretty) ke ++ " = " ++
- formatTime
- defaultTimeLocale
- "%c"
- (posixSecondsToUTCTime (realToFrac ts + realToFrac ke))
- gottabeabetterway (a, Colored x y z) = (Colored x y a, z)
- subkeyrep skr =
- linebreak <>
- indent
- 2
- (pretty "fpr" <> colon <+>
- coloredToColor pretty (fmap SpacedFingerprint (skFingerprint skr))) <>
- linebreak <>
- indent 4 (pretty "version" <> colon <+> coloredToColor pretty (skVer skr)) <>
- linebreak <>
- indent 4 (pretty "timestamp" <> colon <+> pretty (skCreationTime skr)) <>
- linebreak <>
- indent
- 4
- ((\kas ->
- pretty "algo/size" <> colon <+>
- coloredToColor pretty (pubkeyalgo kas) <+>
- coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas))
- (skAlgorithmAndSize skr)) <>
- linebreak <>
- indent
- 4
- (pretty "binding sig hash algorithms" <> colon <+>
- (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms) skr) <>
- linebreak <>
- indent
- 4
- (pretty "weak subkey revocation digests" <> colon <+>
- if null (skRevocationSigWeakDigests skr)
- then pretty "[]"
- else
- list
- (map
- (\w ->
- red
- (pretty (srwHashAlgorithm w) <> colon <+>
- pretty (srwSubkeyFingerprint w) <> colon <+>
- maybe (pretty "") pretty (srwSubkeyKeyID w)))
- (skRevocationSigWeakDigests skr))) <>
- linebreak <>
- indent
- 4
- (pretty "usage flags" <> colon <+>
- (list . map (coloredToColor (pretty . Set.toList))) (skUsageFlags skr)) <>
- linebreak <>
- indent
- 4
- (pretty "embedded cross-cert" <> colon <+>
- (coloredToColor pretty . ccPresent . skCrossCerts) skr) <>
- linebreak <>
- indent
- 4
- (pretty "cross-cert hash algorithms" <> colon <+>
- (list . map (coloredToColor pretty) . ccHashAlgorithms . skCrossCerts)
- skr)
-
-jsonReport :: POSIXTime -> TKUnknown -> BL.ByteString
-jsonReport ps = A.encode . checkKey (Just ps)
-
-yamlReport :: POSIXTime -> TKUnknown -> B.ByteString
-yamlReport ps = Y.encode . (: []) . checkKey (Just ps)
-
-doLint :: LintOptions -> IO ()
-doLint o = do
- cpt <- getPOSIXTime
- keys <-
- runConduitRes $ CB.sourceHandle stdin .| conduitGet get .|
- conduitToTKsDropping .|
- CL.consume
- output (lintOutputFormat o) cpt keys
- where
- output Pretty cpt = mapM_ (PPA.putDoc . prettyKeyReport cpt)
- output JSON cpt =
- mapM_ (BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt)
- output YAML cpt = mapM_ (B.putStr . yamlReport cpt)
-
-sigissuer :: SignaturePayload -> Maybe EightOctetKeyId
-getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId
-hashAlgo :: SignaturePayload -> HashAlgorithm
-sigissuer (SigVOther 2 _) = Nothing
-sigissuer SigV3 {} = Nothing
-sigissuer (SigV4 _ _ _ ys xs _ _) =
- listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
-sigissuer (SigV6 _ _ _ _ ys xs _ _) =
- listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
-sigissuer (SigVOther _ _) = Nothing
-
-getIssuer (Issuer i) = Just i
-getIssuer _ = Nothing
-
-hashAlgo (SigV3 _ _ _ _ x _ _) = x
-hashAlgo (SigV4 _ _ x _ _ _ _) = x
-hashAlgo (SigV6 _ _ x _ _ _ _ _) = x
-hashAlgo (SigVOther _ _) = OtherHA 0
-
-knownWeakHashAlgorithms :: [HashAlgorithm]
-knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]
-
-isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool
-isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms
-
-isSubkeyRevocationSignature :: SignaturePayload -> Bool
-isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig
-isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig
-isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig
-isSubkeyRevocationSignature _ = False
-
-
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+
+module HOpenPGP.Tools.Hokey.Lint
+ ( doLint
+ ) where
+
+import Codec.Encryption.OpenPGP.Expirations
+ ( getKeyExpirationTimesFromSignature
+ )
+import Codec.Encryption.OpenPGP.Fingerprint
+ ( eightOctetKeyID
+ , fingerprint
+ )
+import Codec.Encryption.OpenPGP.KeyInfo
+ ( pkalgoAbbrev
+ , pubkeySize
+ )
+import Codec.Encryption.OpenPGP.Ontology
+ ( isCT
+ , isCertRevocationSig
+ , isKUF
+ , isPHA
+ , isPKBindingSig
+ , isSKBindingSig
+ )
+import Codec.Encryption.OpenPGP.Serialize ()
+import Codec.Encryption.OpenPGP.Types
+import Control.Arrow ((***))
+import Control.Error.Util (hush)
+import Control.Lens ((&), (^.), _1)
+import Control.Monad (join, void)
+import Control.Monad.Trans.Writer.Lazy (execWriter, tell)
+import qualified Crypto.Hash as CH
+import qualified Crypto.Hash.Algorithms as CHA
+import qualified Data.Aeson as A
+import Data.Binary (get)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8 as BC8
+import qualified Data.ByteString.Lazy as BL
+import Data.Conduit (runConduitRes, (.|))
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.List as CL
+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither)
+import Data.Conduit.Serialization.Binary (conduitGet)
+import Data.Foldable (find, maximumBy, sequenceA_, traverse_)
+import Data.List (elemIndex, findIndex, intercalate, nub, sortOn)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Ord (comparing)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX
+ ( POSIXTime
+ , getPOSIXTime
+ , posixSecondsToUTCTime
+ )
+import Data.Time.Format (formatTime)
+import Data.Time.Locale.Compat (defaultTimeLocale)
+import qualified Data.Yaml as Y
+import GHC.Generics
+import Prettyprinter
+ ( Doc
+ , annotate
+ , colon
+ , flatAlt
+ , indent
+ , line
+ , list
+ , pretty
+ , vsep
+ , (<+>)
+ )
+import qualified Prettyprinter.Render.Terminal as PPA
+import System.IO
+ ( stdin
+ )
+
+import HOpenPGP.Tools.Common.Common
+ ( renderFingerprint
+ , renderKeyID
+ )
+import HOpenPGP.Tools.Common.TKUtils (processTK)
+import HOpenPGP.Tools.Hokey.Options
+ ( LintOptions (..)
+ , LintOutputFormat (..)
+ )
+
+linebreak :: Doc ann
+linebreak = flatAlt line mempty
+
+green, yellow, red :: Doc PPA.AnsiStyle -> Doc PPA.AnsiStyle
+green = annotate (PPA.color PPA.Green)
+yellow = annotate (PPA.color PPA.Yellow)
+red = annotate (PPA.color PPA.Red)
+
+data KAS
+ = KAS
+ { pubkeyalgo :: Result PubKeyAlgorithm
+ , pubkeysize :: Result (Maybe Int)
+ , stringrep :: String
+ }
+ deriving (Generic)
+
+data Color
+ = Green
+ | Yellow
+ | Red
+ deriving (Eq, Generic, Ord)
+
+data Result a = Result
+ { resultColor :: Maybe Color
+ , resultFindings :: Maybe [String]
+ , resultValue :: a
+ }
+ deriving (Functor, Generic)
+
+instance Applicative Result where
+ pure x = Result Nothing Nothing x
+ (Result c1 e1 f) <*> (Result c2 e2 x) =
+ Result (max c1 c2) (e1 <> e2) (f x)
+
+instance Monad Result where
+ (Result c1 e1 x) >>= f =
+ let Result c2 e2 y = f x
+ in Result (max c1 c2) (e1 <> e2) y
+
+colored :: Maybe Color -> Maybe [String] -> a -> Result a
+colored c e x = Result c e x
+
+withColor :: Maybe Color -> a -> Result a
+withColor c x = Result c Nothing x
+
+getResult :: Result a -> a
+getResult (Result _ _ x) = x
+
+newtype LintPolicy src a
+ = LintPolicy
+ { unPolicy :: src -> Maybe POSIXTime -> Result a
+ }
+ deriving (Functor, Generic)
+
+instance Applicative (LintPolicy src) where
+ pure x = LintPolicy (\_ _ -> pure x)
+ (LintPolicy f) <*> (LintPolicy x) = LintPolicy (\src mpt -> f src mpt <*> x src mpt)
+
+data KeyReport
+ = KeyReport
+ { keyStatus :: Result String
+ , keyFingerprint :: Result Fingerprint
+ , keyVer :: Result KeyVersion
+ , keyCreationTime :: Result ThirtyTwoBitTimeStamp
+ , keyAlgorithmAndSize :: Result KAS
+ , keyUIDsAndUAts :: Map.Map Text (Result UIDReport)
+ , keyBestOf :: Maybe UIDReport
+ , keySubkeys :: [Result SubkeyReport]
+ , keyHasEncryptionCapableSubkey :: Result Bool
+ }
+ deriving (Generic)
+
+data UIDReport
+ = UIDReport
+ { uidSelfSigHashAlgorithms :: [Result HashAlgorithm]
+ , uidPreferredHashAlgorithms :: [Result [HashAlgorithm]]
+ , uidKeyExpirationTimes :: [Result [ThirtyTwoBitDuration]]
+ , uidKeyUsageFlags :: [Result (Set.Set KeyFlag)]
+ , uidRevocationStatus :: [RevocationStatus]
+ }
+ deriving (Generic)
+
+data SubkeyReport
+ = SubkeyReport
+ { skFingerprint :: Result Fingerprint
+ , skVer :: Result KeyVersion
+ , skCreationTime :: ThirtyTwoBitTimeStamp
+ , skAlgorithmAndSize :: Result KAS
+ , skBindingSigHashAlgorithms :: [Result HashAlgorithm]
+ , skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning]
+ , skUsageFlags :: [Result (Set.Set KeyFlag)]
+ , skCrossCerts :: CrossCertReport
+ }
+ deriving (Generic)
+
+data SubkeyRevocationDigestWarning
+ = SubkeyRevocationDigestWarning
+ { srwHashAlgorithm :: HashAlgorithm
+ , srwSubkeyFingerprint :: String
+ , srwSubkeyKeyID :: Maybe String
+ , srwMessage :: String
+ }
+ deriving (Generic)
+
+data CrossCertReport
+ = CrossCertReport
+ { ccPresent :: Result Bool
+ , ccHashAlgorithms :: [Result HashAlgorithm]
+ }
+ deriving (Generic)
+
+data RevocationStatus
+ = RevocationStatus
+ { isRevoked :: Bool
+ , revocationCode :: String
+ , revocationReason :: Text
+ }
+ deriving (Generic)
+
+instance A.ToJSON KAS
+
+instance A.ToJSON Color
+
+instance (A.ToJSON a) => A.ToJSON (Result a)
+
+instance A.ToJSON KeyReport
+
+instance A.ToJSON UIDReport
+
+instance A.ToJSON SubkeyReport
+
+instance A.ToJSON SubkeyRevocationDigestWarning
+
+instance A.ToJSON CrossCertReport
+
+instance A.ToJSON RevocationStatus
+
+instance Semigroup UIDReport where
+ (<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') =
+ UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e')
+
+instance Monoid UIDReport where
+ mempty = UIDReport [] [] [] [] []
+ mappend = (<>)
+
+checkKey :: LintPolicy TKUnknown KeyReport
+checkKey = LintPolicy $ \tk mpt -> checkKey' mpt tk
+
+checkKey' :: Maybe POSIXTime -> TKUnknown -> Result KeyReport
+checkKey' mpt tk =
+ kr
+ <$ sequenceA_
+ [ void (keyStatus kr)
+ , void (keyFingerprint kr)
+ , void (keyVer kr)
+ , void (keyAlgorithmAndSize kr)
+ , void (keyHasEncryptionCapableSubkey kr)
+ , traverse_ void (keySubkeys kr)
+ , traverse_ void (keyUIDsAndUAts kr)
+ ]
+ where
+ kr =
+ KeyReport
+ { keyStatus = pure (either id (const "good") procResult)
+ , keyFingerprint = pure (fingerprint primaryKey)
+ , keyVer = colorizeKV (_keyVersion primaryKey)
+ , keyCreationTime = pure (_timestamp primaryKey)
+ , keyAlgorithmAndSize = kasIt primaryKey
+ , keyUIDsAndUAts = uidMap
+ , keyBestOf = populateBestOf uidMap
+ , keySubkeys = subkeys
+ , keyHasEncryptionCapableSubkey =
+ hasEncryptionCapableSubkey
+ (concatMap (skUsageFlags . getResult) subkeys)
+ }
+ uidMap =
+ Map.fromListWith (liftA2 (<>)) $
+ map
+ (\(x, y) -> (x, uidr (Just x) y))
+ (processedTK ^. tkuUIDs)
+ ++ map
+ (uatspsToText *** uidr Nothing)
+ (processedTK ^. tkuUAts)
+ subkeys =
+ map (checkSK (fingerprint primaryKey)) (processedTK ^. tkuSubs)
+ procResult = processTK mpt tk
+ processedTK = either (const tk) id procResult
+ primaryKey = processedTK ^. tkuKey . _1
+ uidr :: Maybe Text -> [SignaturePayload] -> Result UIDReport
+ uidr Nothing sps =
+ UIDReport
+ <$> pure (has sps)
+ <*> pure (map phas sps)
+ <*> pure
+ ( map
+ ( colorizeKETs
+ (fromMaybe 0 mpt)
+ (unThirtyTwoBitTimeStamp (_timestamp primaryKey))
+ . getKeyExpirationTimesFromSignature
+ )
+ sps -- should that be 0?
+ )
+ <*> pure (kufs False sps)
+ <*> pure (findRevocationReason sps)
+ uidr (Just u) sps =
+ colorizeUID
+ u
+ ( UIDReport
+ (has sps)
+ (map phas sps)
+ ( map
+ ( colorizeKETs
+ (fromMaybe 0 mpt)
+ (unThirtyTwoBitTimeStamp (_timestamp primaryKey))
+ . getKeyExpirationTimesFromSignature
+ )
+ sps -- should that be 0?
+ )
+ (kufs False sps)
+ (findRevocationReason sps)
+ )
+ kasIt :: SomePKPayload -> Result KAS
+ kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize)
+ kasIt' :: PubKeyAlgorithm -> Either String Int -> Result KAS
+ kasIt' pka epks =
+ let pr = colorizePKA pka
+ prs = colorizePKS pka epks
+ strRep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka)
+ in colored
+ (max (resultColor pr) (resultColor prs))
+ (resultFindings pr <> resultFindings prs)
+ (KAS pr prs strRep)
+ colorizeKV :: KeyVersion -> Result KeyVersion
+ colorizeKV kv
+ | kv `elem` [V4, V6] = withColor (Just Green) kv
+ | otherwise =
+ colored (Just Red) (Just ["not a V4 or V6 key"]) kv
+ colorizePKA :: PubKeyAlgorithm -> Result PubKeyAlgorithm
+ colorizePKA pka
+ | pka `elem` [RSA, EdDSA, ECDH, X25519, X448] -- FIXME: incomplete
+ =
+ colored (Just Green) Nothing pka
+ | otherwise =
+ colored
+ (Just Yellow)
+ (Just ["public key algorithm neither RSA nor EdDSA"])
+ pka
+ colorizePKS
+ :: PubKeyAlgorithm -> Either String Int -> Result (Maybe Int)
+ colorizePKS pka (Right pks)
+ -- Group 256-bit ECC curves
+ | pka `elem` [X25519, ECDH, EdDSA] && pks >= 256 -- FIXME: incomplete
+ =
+ withColor (Just Green) (Just pks)
+ -- Group 448-bit ECC curves
+ | pka `elem` [X448] && pks >= 448 -- FIXME: incomplete
+ =
+ withColor (Just Green) (Just pks)
+ -- Catch-all for undersized ECC curves
+ | pka `elem` [X25519, X448, ECDH, EdDSA] -- FIXME: incomplete
+ =
+ colored
+ (Just Yellow)
+ (Just ["Public key size insufficient for ECC algorithm"])
+ (Just pks)
+ -- RSA size checks
+ | pka == RSA && pks >= 3072 =
+ withColor (Just Green) (Just pks)
+ | pka == RSA && pks >= 2048 =
+ colored
+ (Just Yellow)
+ (Just ["Public key size between 2048 and 3072 bits"])
+ (Just pks)
+ | pka == RSA =
+ colored
+ (Just Red)
+ (Just ["Public key size under 2048 bits"])
+ (Just pks)
+ -- Fallback for unknown algorithms but known sizes
+ | otherwise =
+ pure (Just pks)
+ colorizePKS _ (Left _) =
+ colored
+ (Just Red)
+ (Just ["public key algorithm not understood"])
+ Nothing
+ colorizePHAs :: [HashAlgorithm] -> Result [HashAlgorithm]
+ colorizePHAs x
+ | preferredWeakHash x =
+ colored (Just Red) (Just ["weak hash with higher preference"]) x
+ | otherwise = withColor (Just Green) x
+ fSHA2or3Family =
+ fi (`elem` [SHA512, SHA384, SHA256, SHA224, SHA3_512, SHA3_256])
+ firstStrongSHA2or3 xs = fSHA2or3Family xs
+ preferredWeakHash xs =
+ any
+ ( \ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2or3 xs
+ )
+ knownWeakHashAlgorithms
+ fi x y = fromMaybe maxBound (findIndex x y)
+ colorizeKETs ct ts kes
+ | null kes = colored (Just Red) (Just ["no expiration set"]) kes
+ | any (\ke -> realToFrac ts + realToFrac ke < ct) kes =
+ colored (Just Red) (Just ["expiration passed"]) kes
+ | any
+ (\ke -> realToFrac ts + realToFrac ke > ct + (5 * 31557600))
+ kes =
+ colored (Just Yellow) (Just ["expiration too far in future"]) kes
+ | otherwise = colored (Just Green) Nothing kes
+ eoki pkp
+ | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
+ | _keyVersion pkp == DeprecatedV3
+ && elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
+ hush . eightOctetKeyID $ pkp
+ | otherwise = Nothing
+ phas sig =
+ colorizePHAs
+ ( concatMap
+ ( \case
+ SigSubPacket _ (PreferredHashAlgorithms x) -> x
+ _ -> []
+ )
+ (filter isPHA (hasheds sig))
+ )
+ has = map (colorizeHA . hashAlgo) . alleged
+ colorizeHA :: HashAlgorithm -> Result HashAlgorithm
+ colorizeHA ha
+ | isKnownWeakHashAlgorithm ha =
+ colored (Just Red) (Just ["weak hash algorithm"]) ha
+ | otherwise = pure ha
+ sigcts sig =
+ map
+ ( \case
+ SigSubPacket _ (SigCreationTime x) -> x
+ _ -> error "unexpected subpacket type"
+ )
+ (filter isCT (hasheds sig))
+ alleged =
+ filter
+ ( \sig ->
+ primaryFingerprint `elem` sigissuerFPs sig
+ || ((==) <$> sigissuer sig <*> eoki primaryKey)
+ == Just True
+ )
+ where
+ primaryFingerprint = fingerprint primaryKey
+ uatspsToText = T.pack . uatspsToString
+ uatspsToString us =
+ ""
+ uaspToString (ImageAttribute hdr d) =
+ hdrToString hdr
+ ++ ':'
+ : show (BL.length d)
+ ++ ':'
+ : BC8.unpack
+ (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
+ uaspToString (OtherUASub t d) =
+ "other-"
+ ++ show t
+ ++ ':'
+ : show (BL.length d)
+ ++ ':'
+ : BC8.unpack
+ (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
+ hdrToString (ImageHV1 JPEG) = "jpeg"
+ hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)
+ populateBestOf
+ :: Map.Map Text (Result UIDReport) -> Maybe UIDReport
+ populateBestOf um
+ | Map.null um = Nothing
+ | otherwise =
+ Just
+ ( UIDReport
+ <$> best . uidSelfSigHashAlgorithms
+ <*> best
+ . uidPreferredHashAlgorithms
+ <*> best
+ . uidKeyExpirationTimes
+ <*> best
+ . uidKeyUsageFlags
+ <*> pure []
+ $ mconcat (justTheUIDRs um)
+ )
+ justTheUIDRs = map getResult . Map.elems
+ -- Pick the single most favorable Result from a list, for display as
+ -- a representative "best of" example.
+ --
+ -- This doesn't use Ord because there could be a Nothing in the list
+ -- and that would be "best".
+ --
+ -- That also implies that this should get an overhaul.
+ best :: [Result a] -> [Result a]
+ best = take 1 . sortOn (bestOfRank . resultColor)
+ bestOfRank :: Maybe Color -> Int
+ bestOfRank (Just Green) = 0
+ bestOfRank (Just Yellow) = 1
+ bestOfRank (Just Red) = 2
+ bestOfRank Nothing = 3
+ colorizeUID :: Text -> UIDReport -> Result UIDReport
+ colorizeUID u ur =
+ let strU = T.unpack u
+ check cond msg =
+ if cond
+ then colored (Just Yellow) (Just [msg]) ()
+ else pure ()
+ in check ('(' `elem` strU) "parenthesis in uid"
+ *> check ('<' `notElem` strU) "no left angle bracket in uid"
+ *> pure ur
+ findRevocationReason = concatMap grabReasons . filter isCertRevocationSig
+ grabReasons (SigV4 CertRevocationSig _ _ hashedSubs _ _ _) =
+ mapMaybe (grabReasons' . _sspPayload) hashedSubs
+ grabReasons (SigV6 CertRevocationSig _ _ _ hashedSubs _ _ _) =
+ mapMaybe (grabReasons' . _sspPayload) hashedSubs
+ grabReasons _ = []
+ grabReasons' (ReasonForRevocation a b) =
+ Just (RevocationStatus True (show a) b)
+ grabReasons' _ = Nothing
+ kufs s =
+ mapMaybe
+ ( \sig ->
+ case find isKUF (hasheds sig) of
+ Just (SigSubPacket _ (KeyFlags x)) -> Just (colorizeKUFs s x)
+ _ -> Nothing
+ )
+ . newestWith (any isKUF . hasheds)
+ colorizeKUFs
+ :: Bool -> Set.Set KeyFlag -> Result (Set.Set KeyFlag)
+ colorizeKUFs False x
+ | encrypts && signsOrCertifies =
+ colored (Just Yellow) (Just ["both signing & encryption"]) x
+ | otherwise = withColor (Just Green) x
+ where
+ encrypts =
+ Set.member EncryptStorageKey x
+ || Set.member EncryptCommunicationsKey x
+ signsOrCertifies = Set.member SignDataKey x || Set.member CertifyKeysKey x
+ colorizeKUFs True x
+ | certifies =
+ colored (Just Red) (Just ["certification-capable subkey"]) x
+ | encryptsAndSigns =
+ colored (Just Yellow) (Just ["both signing & encryption"]) x
+ | otherwise = withColor (Just Green) x
+ where
+ certifies = Set.member CertifyKeysKey x
+ encryptsAndSigns =
+ ( Set.member EncryptStorageKey x
+ || Set.member EncryptCommunicationsKey x
+ )
+ && Set.member SignDataKey x
+ sigTime :: SignaturePayload -> ThirtyTwoBitTimeStamp
+ sigTime sig = case sigcts sig of
+ (t : _) -> t
+ [] -> 0
+ newestWith p sigs =
+ let filtered = filter p sigs
+ in if null filtered
+ then []
+ else [maximumBy (comparing sigTime) filtered]
+ checkSK
+ :: Fingerprint -> (Pkt, [SignaturePayload]) -> Result SubkeyReport
+ checkSK pf (PublicSubkeyPkt pkp, sigs) = checkSK' pf pkp sigs
+ checkSK pf (SecretSubkeyPkt pkp _, sigs) = checkSK' pf pkp sigs
+ checkSK _ _ = error "checkSK: unexpected packet type"
+ checkSK' pf pkp sigs =
+ skr
+ <$ sequenceA_
+ [ void (skFingerprint skr)
+ , void (skVer skr)
+ , void (skAlgorithmAndSize skr)
+ , traverse_ void (skBindingSigHashAlgorithms skr)
+ , traverse_ void (skUsageFlags skr)
+ , void (ccPresent (skCrossCerts skr))
+ , traverse_ void (ccHashAlgorithms (skCrossCerts skr))
+ ]
+ where
+ skr =
+ ( \x -> x {skCrossCerts = ccr (map getResult (skUsageFlags x)) sigs}
+ )
+ SubkeyReport
+ { skFingerprint = colorizeF pf (fingerprint pkp)
+ , skVer = colorizeKV (_keyVersion pkp)
+ , skCreationTime = _timestamp pkp
+ , skAlgorithmAndSize = kasIt pkp
+ , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)
+ , skRevocationSigWeakDigests =
+ subkeyRevocationSigWeakDigests pkp sigs
+ , skUsageFlags = kufs True (filter isSKBindingSig sigs)
+ , skCrossCerts = CrossCertReport (pure False) []
+ }
+ hasEncryptionCapableSubkey
+ :: [Result (Set.Set KeyFlag)] -> Result Bool
+ hasEncryptionCapableSubkey skrs =
+ let hasEncryption =
+ any
+ ( ( \x ->
+ Set.member EncryptStorageKey x
+ || Set.member EncryptCommunicationsKey x
+ )
+ . getResult
+ )
+ skrs
+ in if hasEncryption
+ then withColor (Just Green) True
+ else
+ colored
+ (Just Red)
+ (Just ["no encryption-capable subkey present"])
+ False
+ embeddedSigs =
+ filter isPKBindingSig
+ . concatMap getEmbeds
+ . filter isSKBindingSig
+ getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
+ getEmbeds (SigV6 _ _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
+ getEmbeds _ = []
+ getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]
+ getEmbed _ = []
+ ccr kufs' sigs =
+ CrossCertReport
+ (colorES kufs' sigs)
+ (map (colorizeHA . hashAlgo) sigs)
+ colorES :: [Set.Set KeyFlag] -> [SignaturePayload] -> Result Bool
+ colorES kufs' sigs =
+ let noEmbedded = null (embeddedSigs sigs)
+ signCapable = any (Set.member SignDataKey) kufs'
+ authCapable = any (Set.member AuthKey) kufs'
+ in case (noEmbedded, signCapable, authCapable) of
+ (True, True, True) ->
+ colored
+ (Just Red)
+ (Just ["signing- and auth-capable subkey without cross-cert"])
+ False
+ (True, True, False) ->
+ colored
+ (Just Red)
+ (Just ["signing-capable subkey without cross-cert"])
+ False
+ (True, False, True) ->
+ colored
+ (Just Yellow)
+ (Just ["auth-capable subkey without cross-cert"])
+ False
+ _ ->
+ withColor (Just Green) True
+ colorizeF :: Fingerprint -> Fingerprint -> Result Fingerprint
+ colorizeF pf fp
+ | pf == fp =
+ colored
+ (Just Red)
+ (Just ["subkey has same fingerprint as primary key"])
+ fp
+ | otherwise = withColor (Just Green) fp
+ subkeyRevocationSigWeakDigests pkp =
+ mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp)
+ . filter isSubkeyRevocationSignature
+ mkSubkeyRevocationSigWeakDigestWarning pkp sig =
+ let ha = hashAlgo sig
+ in if isKnownWeakHashAlgorithm ha
+ then
+ Just
+ SubkeyRevocationDigestWarning
+ { srwHashAlgorithm = ha
+ , srwSubkeyFingerprint = renderFingerprint (fingerprint pkp)
+ , srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp))
+ , srwMessage =
+ "subkey revocation signature uses known-weak digest algorithm"
+ }
+ else Nothing
+
+prettyKeyReport :: POSIXTime -> TKUnknown -> Doc PPA.AnsiStyle
+prettyKeyReport cpt tk = do
+ let keyReportResult = unPolicy checkKey tk (Just cpt)
+ keyReport = getResult keyReportResult
+ execWriter $
+ tell $
+ vsep
+ [ pretty "Key has potential validity"
+ <> colon
+ <+> pretty (getResult (keyStatus keyReport))
+ , pretty "Key has fingerprint"
+ <> colon
+ <+> pretty (SpacedFingerprint (getResult (keyFingerprint keyReport)))
+ , pretty "Checking to see if key is OpenPGPv4 or v6"
+ <> colon
+ <+> coloredToColor (pretty . show) (keyVer keyReport)
+ , ( \kas ->
+ pretty "Checking the strength of your primary asymmetric key"
+ <> colon
+ <+> coloredToColor pretty (pubkeyalgo kas)
+ <+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)
+ )
+ (getResult (keyAlgorithmAndSize keyReport))
+ , pretty "Checking user-ID- and user-attribute-related items"
+ <> colon
+ <> mconcat
+ ( map
+ (uidtrip (getResult (keyCreationTime keyReport)))
+ (Map.toList (keyUIDsAndUAts keyReport))
+ )
+ , pretty "Checking subkeys" <> colon
+ , indent
+ 2
+ ( pretty "one of the subkeys is encryption-capable"
+ <> colon
+ <+> coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)
+ )
+ <> mconcat (map subkeyrep (keySubkeys keyReport))
+ ]
+ <> linebreak
+ where
+ coloredToColor f (Result (Just Green) _ x) = green (f x)
+ coloredToColor f (Result (Just Yellow) _ x) = yellow (f x)
+ coloredToColor f (Result (Just Red) _ x) = red (f x)
+ coloredToColor f (Result Nothing _ x) = f x
+ uidtrip ts (uText, r@(Result _ _ ur))
+ | null (uidRevocationStatus ur) =
+ linebreak
+ <> indent 2 (coloredToColor pretty (T.unpack uText <$ r))
+ <> colon
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "Self-sig hash algorithms"
+ <> colon
+ <+> (list . map (coloredToColor pretty) . uidSelfSigHashAlgorithms)
+ ur
+ )
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "Preferred hash algorithms"
+ <> colon
+ <+> mconcat
+ (map (coloredToColor pretty) (uidPreferredHashAlgorithms ur))
+ )
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "Key expiration times"
+ <> colon
+ <+> mconcat
+ ( map
+ (coloredToColor list . fmap (map (pretty . keyExp ts)))
+ (uidKeyExpirationTimes ur)
+ )
+ )
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "Key usage flags"
+ <> colon
+ <+> (list . map (coloredToColor (pretty . Set.toList)))
+ (uidKeyUsageFlags ur)
+ )
+ | otherwise =
+ linebreak
+ <> indent 2 (coloredToColor pretty (T.unpack uText <$ r))
+ <> colon
+ <+> pretty "[revoked]"
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "Revocation code"
+ <> colon
+ <+> list (map (pretty . revocationCode) (uidRevocationStatus ur))
+ )
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "Revocation reason"
+ <> colon
+ <+> list
+ ( map
+ (pretty . T.unpack . revocationReason)
+ (uidRevocationStatus ur)
+ )
+ )
+ keyExp ts ke =
+ (show . pretty) ke
+ ++ " = "
+ ++ formatTime
+ defaultTimeLocale
+ "%c"
+ (posixSecondsToUTCTime (realToFrac ts + realToFrac ke))
+ subkeyrep skrResult =
+ let skr = getResult skrResult
+ in subkeydetail skr
+ subkeydetail skr =
+ linebreak
+ <> indent
+ 2
+ ( pretty "fpr"
+ <> colon
+ <+> coloredToColor
+ pretty
+ (fmap SpacedFingerprint (skFingerprint skr))
+ )
+ <> linebreak
+ <> indent
+ 4
+ (pretty "version" <> colon <+> coloredToColor pretty (skVer skr))
+ <> linebreak
+ <> indent
+ 4
+ (pretty "timestamp" <> colon <+> pretty (skCreationTime skr))
+ <> linebreak
+ <> indent
+ 4
+ ( ( \kas ->
+ pretty "algo/size"
+ <> colon
+ <+> coloredToColor pretty (pubkeyalgo kas)
+ <+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)
+ )
+ (getResult (skAlgorithmAndSize skr))
+ )
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "binding sig hash algorithms"
+ <> colon
+ <+> (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms)
+ skr
+ )
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "weak subkey revocation digests"
+ <> colon
+ <+> if null (skRevocationSigWeakDigests skr)
+ then pretty "[]"
+ else
+ list
+ ( map
+ ( \w ->
+ red
+ ( pretty (srwHashAlgorithm w)
+ <> colon
+ <+> pretty (srwSubkeyFingerprint w)
+ <> colon
+ <+> maybe (pretty "") pretty (srwSubkeyKeyID w)
+ )
+ )
+ (skRevocationSigWeakDigests skr)
+ )
+ )
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "usage flags"
+ <> colon
+ <+> (list . map (coloredToColor (pretty . Set.toList)))
+ (skUsageFlags skr)
+ )
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "embedded cross-cert"
+ <> colon
+ <+> (coloredToColor pretty . ccPresent . skCrossCerts) skr
+ )
+ <> linebreak
+ <> indent
+ 4
+ ( pretty "cross-cert hash algorithms"
+ <> colon
+ <+> ( list
+ . map (coloredToColor pretty)
+ . ccHashAlgorithms
+ . skCrossCerts
+ )
+ skr
+ )
+
+jsonReport :: POSIXTime -> TKUnknown -> BL.ByteString
+jsonReport ps tk = A.encode (getResult (unPolicy checkKey tk (Just ps)))
+
+yamlReport :: POSIXTime -> TKUnknown -> B.ByteString
+yamlReport ps tk = Y.encode . (: []) $ getResult (unPolicy checkKey tk (Just ps))
+
+doLint :: LintOptions -> IO ()
+doLint o = do
+ cpt <- getPOSIXTime
+ keys <-
+ runConduitRes $
+ CB.sourceHandle stdin
+ .| conduitGet get
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CL.consume
+ output (lintOutputFormat o) cpt keys
+ where
+ output Pretty cpt = mapM_ (PPA.putDoc . prettyKeyReport cpt)
+ output JSON cpt =
+ mapM_
+ (BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt)
+ output YAML cpt = mapM_ (B.putStr . yamlReport cpt)
+
+sigissuer :: SignaturePayload -> Maybe EightOctetKeyId
+getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId
+hashAlgo :: SignaturePayload -> HashAlgorithm
+sigissuer (SigVOther 2 _) = Nothing
+sigissuer SigV3 {} = Nothing
+sigissuer (SigV4 _ _ _ ys xs _ _) =
+ let issuers = mapMaybe (getIssuer . _sspPayload) (ys ++ xs)
+ in case nub issuers of
+ [issuer] -> Just issuer
+ _ -> Nothing
+sigissuer (SigV6 {}) = Nothing -- v6 signatures are forbidden from carrying Issuer subpackets; see sigissuerFPs
+sigissuer (SigVOther _ _) = Nothing
+
+getIssuer (Issuer i) = Just i
+getIssuer _ = Nothing
+
+sigissuerFPs :: SignaturePayload -> [Fingerprint]
+sigissuerFPs (SigV4 _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)
+sigissuerFPs (SigV6 _ _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)
+sigissuerFPs _ = []
+
+getIssuerFP :: SigSubPacketPayload -> Maybe Fingerprint
+getIssuerFP (IssuerFingerprint _ fp) = Just fp
+getIssuerFP _ = Nothing
+
+hashAlgo (SigV3 _ _ _ _ x _ _) = x
+hashAlgo (SigV4 _ _ x _ _ _ _) = x
+hashAlgo (SigV6 _ _ x _ _ _ _ _) = x
+hashAlgo (SigVOther _ _) = OtherHA 0
+
+knownWeakHashAlgorithms :: [HashAlgorithm]
+knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]
+
+isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool
+isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms
+
+isSubkeyRevocationSignature :: SignaturePayload -> Bool
+isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig
+isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig
+isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig
+isSubkeyRevocationSignature _ = False
+
+hasheds :: SignaturePayload -> [SigSubPacket]
+hasheds (SigV4 _ _ _ xs _ _ _) = xs
+hasheds (SigV6 _ _ _ _ xs _ _ _) = xs
+hasheds _ = []
diff --git a/HOpenPGP/Tools/Hokey/Options.hs b/HOpenPGP/Tools/Hokey/Options.hs
--- a/HOpenPGP/Tools/Hokey/Options.hs
+++ b/HOpenPGP/Tools/Hokey/Options.hs
@@ -17,130 +17,157 @@
-- along with this program. If not, see .
module HOpenPGP.Tools.Hokey.Options
- (
- -- CanonicalizeOptions
- FetchOptions(..)
- , InjectSSHAgentOptions(..)
- , LintOptions(..)
- , fetchO
- , injectSSHAgentO
- , lintO
- , FetchMethod(..)
- , LintOutputFormat(..)
- ) where
+ ( -- CanonicalizeOptions
+ FetchOptions (..)
+ , InjectSSHAgentOptions (..)
+ , LintOptions (..)
+ , fetchO
+ , injectSSHAgentO
+ , lintO
+ , FetchMethod (..)
+ , LintOutputFormat (..)
+ ) where
import Codec.Encryption.OpenPGP.Serialize ()
import Control.Applicative (optional)
-import HOpenPGP.Tools.Common.HKP (FetchValidationMethod(..))
-
import Options.Applicative.Builder
- ( argument
- , auto
- , help
- , helpDoc
- , long
- , metavar
- , option
- , showDefault
- , str
- , value
- )
+ ( argument
+ , auto
+ , help
+ , helpDoc
+ , long
+ , metavar
+ , option
+ , showDefault
+ , str
+ , value
+ )
import Options.Applicative.Types (Parser)
import Prettyprinter
- ( hardline
- , list
- , pretty
- )
+ ( hardline
+ , list
+ , pretty
+ )
+import HOpenPGP.Tools.Common.HKP (FetchValidationMethod (..))
+
data LintOutputFormat
- = Pretty
- | JSON
- | YAML
- deriving (Bounded, Enum, Eq, Read, Show)
+ = Pretty
+ | JSON
+ | YAML
+ deriving (Bounded, Enum, Eq, Read, Show)
-data LintOptions =
- LintOptions
+data LintOptions
+ = LintOptions
{ lintOutputFormat :: LintOutputFormat
}
-data FetchOptions =
- FetchOptions
+data FetchOptions
+ = FetchOptions
{ keyServer :: String
, fetchMethod :: FetchMethod
, fetchValidation :: FetchValidationMethod
, fetchQuery :: String
}
-data InjectSSHAgentOptions =
- InjectSSHAgentOptions
+data InjectSSHAgentOptions
+ = InjectSSHAgentOptions
{ injectSSHAgentFromFD :: Maybe Int
, injectSSHAgentSocket :: Maybe String
, injectSSHAgentComment :: Maybe String
}
data FetchMethod
- = HKP
- | WKD
- deriving (Bounded, Enum, Eq, Read, Show)
+ = HKP
+ | WKD
+ deriving (Bounded, Enum, Eq, Read, Show)
lintO :: Parser LintOptions
lintO =
- LintOptions <$>
- option
- auto
- (long "output-format" <> metavar "FORMAT" <> value Pretty <> showDefault <>
- ofHelp)
+ LintOptions
+ <$> option
+ auto
+ ( long "output-format"
+ <> metavar "FORMAT"
+ <> value Pretty
+ <> showDefault
+ <> ofHelp
+ )
where
ofHelp =
- helpDoc . Just $ pretty "output format" <> hardline <>
- list (map (pretty . show) ofchoices)
+ helpDoc . Just $
+ pretty "output format"
+ <> hardline
+ <> list (map (pretty . show) ofchoices)
ofchoices = [minBound .. maxBound] :: [LintOutputFormat]
fetchO :: Parser FetchOptions
fetchO =
- FetchOptions <$>
- option
- str
- (long "keyserver" <> metavar "URL" <>
- value "http://pool.sks-keyservers.net:11371" <>
- showDefault <>
- help "HKP server (used only when --method=HKP)") <*>
- option
- auto
- (long "method" <> metavar "METHOD" <> value HKP <> showDefault <> fmHelp) <*>
- option
- auto
- (long "validation-method" <> metavar "METHOD" <>
- value MatchPrimaryKeyFingerprint <>
- showDefault <>
- vmHelp) <*>
- argument str (metavar "QUERY")
+ FetchOptions
+ <$> option
+ str
+ ( long "keyserver"
+ <> metavar "URL"
+ <> value "http://pool.sks-keyservers.net:11371"
+ <> showDefault
+ <> help "HKP server (used only when --method=HKP)"
+ )
+ <*> option
+ auto
+ ( long "method"
+ <> metavar "METHOD"
+ <> value HKP
+ <> showDefault
+ <> fmHelp
+ )
+ <*> option
+ auto
+ ( long "validation-method"
+ <> metavar "METHOD"
+ <> value MatchPrimaryKeyFingerprint
+ <> showDefault
+ <> vmHelp
+ )
+ <*> argument str (metavar "QUERY")
where
fmHelp =
- helpDoc . Just $ pretty "fetch method" <> hardline <>
- list (map (pretty . show) fmchoices)
+ helpDoc . Just $
+ pretty "fetch method"
+ <> hardline
+ <> list (map (pretty . show) fmchoices)
fmchoices = [minBound .. maxBound] :: [FetchMethod]
vmHelp =
- helpDoc . Just $ pretty "validation method" <> hardline <>
- list (map (pretty . show) vmchoices)
+ helpDoc . Just $
+ pretty "validation method"
+ <> hardline
+ <> list (map (pretty . show) vmchoices)
vmchoices = [minBound .. maxBound] :: [FetchValidationMethod]
injectSSHAgentO :: Parser InjectSSHAgentOptions
injectSSHAgentO =
- InjectSSHAgentOptions <$>
- optional
- (option
- auto
- (long "from-fd" <>
- metavar "FD" <>
- help "read binary gpg --export-secret-keys bytes from this already-open file descriptor")) <*>
- optional
- (option
- str
- (long "ssh-agent-socket" <>
- metavar "PATH" <> help "path to ssh-agent socket (defaults to SSH_AUTH_SOCK)")) <*>
- optional
- (option
- str
- (long "comment" <>
- metavar "TEXT" <> help "comment string stored with the injected SSH identity"))
+ InjectSSHAgentOptions
+ <$> optional
+ ( option
+ auto
+ ( long "from-fd"
+ <> metavar "FD"
+ <> help
+ "read binary gpg --export-secret-keys bytes from this already-open file descriptor"
+ )
+ )
+ <*> optional
+ ( option
+ str
+ ( long "ssh-agent-socket"
+ <> metavar "PATH"
+ <> help "path to ssh-agent socket (defaults to SSH_AUTH_SOCK)"
+ )
+ )
+ <*> optional
+ ( option
+ str
+ ( long "comment"
+ <> metavar "TEXT"
+ <> help "comment string stored with the injected SSH identity"
+ )
+ )
diff --git a/hkt.hs b/hkt.hs
--- a/hkt.hs
+++ b/hkt.hs
@@ -15,26 +15,33 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-
{-# LANGUAGE DeriveGeneric #-}
-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
-import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)
+import Codec.Encryption.OpenPGP.Fingerprint
+ ( eightOctetKeyID
+ , fingerprint
+ )
+import Codec.Encryption.OpenPGP.KeyInfo
+ ( pkalgoAbbrev
+ , pubkeySize
+ )
import Codec.Encryption.OpenPGP.KeySelection
- ( parseEightOctetKeyId
- , parseFingerprint
- )
+ ( parseEightOctetKeyId
+ , parseFingerprint
+ )
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Signatures
- ( verifyAgainstKeyring
- , verifySigWith
- , verifyUnknownTKWith
- )
+ ( verifyAgainstKeyring
+ , verifySigWith
+ , verifyUnknownTKWith
+ )
import Codec.Encryption.OpenPGP.Types
-import Control.Applicative ((<|>), optional)
+import Control.Applicative (optional, (<|>))
import Control.Arrow ((&&&))
+import Control.Error.Util (hush)
import Control.Exception (ErrorCall, evaluate, try)
import Control.Lens ((^.), (^..), _1, _2)
+import Control.Monad (join)
import Control.Monad.Trans.Except (except, runExcept)
import Control.Monad.Trans.Resource (MonadResource, MonadThrow)
import qualified Data.Aeson as A
@@ -42,24 +49,33 @@
import Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
-import Data.Conduit (ConduitM, (.|), runConduitRes)
+import Data.Conduit (ConduitM, runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Filter
- ( FilterPredicates(RTKFilterPredicate)
- , conduitTKFilter
- )
+ ( FilterPredicates (RTKFilterPredicate)
+ , conduitTKFilter
+ )
import Data.Conduit.OpenPGP.Keyring
- ( conduitToTKsDropping
- , sinkPublicKeyringMap
- )
+ ( conduitToTKsDroppingEither
+ , sinkPublicKeyringMap
+ )
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Data.Lens (biplate)
import Data.Either (rights)
-import Data.Graph.Inductive.Graph (Graph(mkGraph), Path, emap, prettyPrint)
+import Data.Graph.Inductive.Graph
+ ( Graph (mkGraph)
+ , Path
+ , emap
+ , prettyPrint
+ )
import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.SP (sp)
-import Data.GraphViz (GraphvizParams(..), graphToDot, nonClusteredParams)
+import Data.GraphViz
+ ( GraphvizParams (..)
+ , graphToDot
+ , nonClusteredParams
+ )
import Data.GraphViz.Attributes (toLabel)
import Data.GraphViz.Types (printDotGraph)
import Data.HashMap.Lazy (HashMap)
@@ -71,119 +87,156 @@
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TLIO
-import Data.Void (Void)
-import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)
+import Data.Time.Clock.POSIX
+ ( getPOSIXTime
+ , posixSecondsToUTCTime
+ )
import Data.Tuple (swap)
+import Data.Void (Void)
import qualified Data.Yaml as Y
import GHC.Generics
-import HOpenPGP.Tools.Common.Common
- ( banner
- , keyMatchesEightOctetKeyId
- , keyMatchesFingerprint
- , keyMatchesUIDSubString
- , versioner
- , warranty
- )
-import HOpenPGP.Tools.Common.Parser (parseTKExp)
-import System.Directory (getHomeDirectory)
-import System.Exit (exitFailure)
import Options.Applicative.Builder
- ( argument
- , auto
- , command
- , footerDoc
- , headerDoc
- , help
- , helpDoc
- , info
- , long
- , metavar
- , option
- , prefs
- , progDesc
- , showDefault
- , showHelpOnError
- , str
- , strOption
- , switch
- , value
- )
-import Options.Applicative.Extra (customExecParser, helper, hsubparser)
+ ( argument
+ , auto
+ , command
+ , footerDoc
+ , headerDoc
+ , help
+ , helpDoc
+ , info
+ , long
+ , metavar
+ , option
+ , prefs
+ , progDesc
+ , showDefault
+ , showHelpOnError
+ , str
+ , strOption
+ , switch
+ , value
+ )
+import Options.Applicative.Extra
+ ( customExecParser
+ , helper
+ , hsubparser
+ )
import Options.Applicative.Types (Parser)
-
+import Prettyprinter
+ ( defaultLayoutOptions
+ , fillSep
+ , hardline
+ , layoutPretty
+ , list
+ , pretty
+ , (<+>)
+ )
import Prettyprinter.Render.Text (hPutDoc, putDoc)
-import Prettyprinter ((<+>), fillSep, hardline, list, pretty)
import qualified Prettyprinter.Render.Text as PPA
-import Prettyprinter (layoutPretty, defaultLayoutOptions)
-import System.IO (BufferMode(..), Handle, hFlush, hPutStrLn, hSetBuffering, stderr)
+import System.Directory (getHomeDirectory)
+import System.Exit (exitFailure)
+import System.IO
+ ( BufferMode (..)
+ , Handle
+ , hFlush
+ , hPutStrLn
+ , hSetBuffering
+ , stderr
+ )
-grabMatchingKeysConduit ::
- (MonadResource m, MonadThrow m)
- => FilePath
- -> Bool
- -> FilterPredicates Void TKUnknown
- -> Text
- -> ConduitM () TKUnknown m ()
+import HOpenPGP.Tools.Common.Common
+ ( banner
+ , keyMatchesEightOctetKeyId
+ , keyMatchesFingerprint
+ , keyMatchesUIDSubString
+ , versioner
+ , warranty
+ )
+import HOpenPGP.Tools.Common.Parser (parseTKExp)
+
+grabMatchingKeysConduit
+ :: (MonadResource m, MonadThrow m)
+ => FilePath
+ -> Bool
+ -> FilterPredicates Void TKUnknown
+ -> Text
+ -> ConduitM () TKUnknown m ()
grabMatchingKeysConduit fp filt ufp srch =
- CB.sourceFile fp .| conduitGet get .| conduitToTKsDropping .|
- (if filt
- then conduitTKFilter ufp
- else CL.filter matchAny)
+ CB.sourceFile fp
+ .| conduitGet get
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| ( if filt
+ then conduitTKFilter ufp
+ else CL.filter matchAny
+ )
where
matchAny tk =
- either (const False) id $ runExcept $ fmap (keyMatchesFingerprint True tk) efp <|>
- fmap (keyMatchesEightOctetKeyId True tk . Right) eeok <|>
- return (keyMatchesUIDSubString srch tk)
+ either (const False) id $
+ runExcept $
+ fmap (keyMatchesFingerprint True tk) efp
+ <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok
+ <|> return (keyMatchesUIDSubString srch tk)
efp = (except . parseFingerprint) srch
eeok = (except . parseEightOctetKeyId) srch
grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TKUnknown]
grabMatchingKeys fp filt srch =
- if filt
- then do
- parsed <- parseFilterPredicateIO srch
- case parsed of
- Left err -> dieHKT err
- Right ufp -> runConduitRes $ grabMatchingKeysConduit fp filt ufp srch .| CL.consume
- else
- -- When not using filter syntax, treat TARGET as a fingerprint, key ID or UID substring
- runConduitRes $
- CB.sourceFile fp .| conduitGet get .| conduitToTKsDropping .| CL.filter matchAny .| CL.consume
+ if filt
+ then do
+ parsed <- parseFilterPredicateIO srch
+ case parsed of
+ Left err -> dieHKT err
+ Right ufp ->
+ runConduitRes $
+ grabMatchingKeysConduit fp filt ufp srch .| CL.consume
+ else
+ -- When not using filter syntax, treat TARGET as a fingerprint, key ID or UID substring
+ runConduitRes $
+ CB.sourceFile fp
+ .| conduitGet get
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CL.filter matchAny
+ .| CL.consume
where
matchAny tk =
- either (const False) id $ runExcept $ fmap (keyMatchesFingerprint True tk) efp <|>
- fmap (keyMatchesEightOctetKeyId True tk . Right) eeok <|>
- return (keyMatchesUIDSubString srch tk)
+ either (const False) id $
+ runExcept $
+ fmap (keyMatchesFingerprint True tk) efp
+ <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok
+ <|> return (keyMatchesUIDSubString srch tk)
efp = (except . parseFingerprint) srch
eeok = (except . parseEightOctetKeyId) srch
grabMatchingPublicKeyring :: [TKUnknown] -> IO PublicKeyring
grabMatchingPublicKeyring keys =
- runConduitRes $
- CL.sourceList (mapMaybe unknownToPublicTK keys) .| sinkPublicKeyringMap
+ runConduitRes $
+ CL.sourceList (mapMaybe unknownToPublicTK keys)
+ .| sinkPublicKeyringMap
where
unknownToPublicTK tk =
- case fromUnknownToTK tk of
- Right (SomePublicTK publicTk) -> Just publicTk
- Right (SomeSecretTK secretTk) -> Just (publicViewTK secretTk)
- Left _ -> Nothing
+ case fromUnknownToTK tk of
+ Right (SomePublicTK publicTk) -> Just publicTk
+ Right (SomeSecretTK secretTk) -> Just (publicViewTK secretTk)
+ Left _ -> Nothing
-data Key =
- Key
+data Key
+ = Key
{ keysize :: Maybe Int
, keyalgo :: String
, keyalgoabbreviation :: String
, fpr :: String
}
- deriving (Generic)
+ deriving (Generic)
-data TKey =
- TKey
+data TKey
+ = TKey
{ publickey :: Key
, uids :: [Text]
, subkeys :: [Key]
}
- deriving (Generic)
+ deriving (Generic)
instance A.ToJSON Key
@@ -191,48 +244,66 @@
tkToTKey :: TKUnknown -> TKey
tkToTKey tk =
- TKey
- { publickey = mkey (tk ^. tkuKey . _1)
- , uids = tk ^. tkuUIDs ^.. traverse . _1
- , subkeys = mapMaybe (\t -> case t of
- (PublicSubkeyPkt x, _) -> Just (mkey x)
- (SecretSubkeyPkt x _, _) -> Just (mkey x)
- _ -> Nothing) (tk ^. tkuSubs)
- }
+ TKey
+ { publickey = mkey (tk ^. tkuKey . _1)
+ , uids = tk ^. tkuUIDs ^.. traverse . _1
+ , subkeys =
+ mapMaybe
+ ( \t -> case t of
+ (PublicSubkeyPkt x, _) -> Just (mkey x)
+ (SecretSubkeyPkt x _, _) -> Just (mkey x)
+ _ -> Nothing
+ )
+ (tk ^. tkuSubs)
+ }
where
mkey =
- Key <$> either (const Nothing) Just . pubkeySize . _pubkey <*> show .
- _pkalgo <*>
- pkalgoAbbrev .
- _pkalgo <*>
- renderFingerprint .
- fingerprint
+ Key
+ <$> either (const Nothing) Just . pubkeySize . _pubkey
+ <*> show
+ . _pkalgo
+ <*> pkalgoAbbrev
+ . _pkalgo
+ <*> renderFingerprint
+ . fingerprint
showTKey :: TKey -> IO ()
-showTKey key =
- putDoc $ pretty "pub " <+> sizeabbrevkeyid (publickey key) <> hardline <>
- mconcat
- (map
- (\x ->
- pretty "uid " <+> pretty (T.unpack x) <>
- hardline)
- (uids key)) <>
- mconcat
- (map (\x -> pretty "sub " <+> sizeabbrevkeyid x <> hardline) (subkeys key)) <>
- hardline
+showTKey tkey =
+ putDoc $
+ pretty "pub "
+ <+> sizeabbrevkeyid (publickey tkey)
+ <> hardline
+ <> mconcat
+ ( map
+ ( \x ->
+ pretty "uid "
+ <+> pretty (T.unpack x)
+ <> hardline
+ )
+ (uids tkey)
+ )
+ <> mconcat
+ ( map
+ (\x -> pretty "sub " <+> sizeabbrevkeyid x <> hardline)
+ (subkeys tkey)
+ )
+ <> hardline
where
sizeabbrevkeyid k =
- pretty (maybe "unknown" show (keysize k)) <>
- pretty (keyalgoabbreviation k) <>
- pretty "/" <>
- pretty (fpr k)
+ pretty (maybe "unknown" show (keysize k))
+ <> pretty (keyalgoabbreviation k)
+ <> pretty "/"
+ <> pretty (fpr k)
renderFingerprint :: Fingerprint -> String
renderFingerprint =
- T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty
+ T.unpack
+ . PPA.renderStrict
+ . layoutPretty defaultLayoutOptions
+ . pretty
-data Options =
- Options
+data Options
+ = Options
{ keyring :: String
, graphOutputFormat :: GraphOutputFormat
, pathsOutputFormat :: PathsOutputFormat
@@ -243,215 +314,265 @@
}
data Command
- = CmdList Options
- | CmdExportPubkeys Options
- | CmdGraph Options
- | CmdFindPaths Options
+ = CmdList Options
+ | CmdExportPubkeys Options
+ | CmdGraph Options
+ | CmdFindPaths Options
data GraphOutputFormat
- = GraphViz
- | LossyPretty
- deriving (Bounded, Enum, Eq, Read, Show)
+ = GraphViz
+ | LossyPretty
+ deriving (Bounded, Enum, Eq, Read, Show)
data PathsOutputFormat
- = Unstructured
- | JSON
- | YAML
- deriving (Eq, Read, Show)
+ = Unstructured
+ | JSON
+ | YAML
+ deriving (Eq, Read, Show)
listO :: String -> Parser Options
-listO homedir =
- Options <$>
- strOption (long "keyring" <> metavar "FILE" <> help "file containing keyring") <*>
- pure GraphViz -- unused
- <*>
- option
- auto
- (long "output-format" <> metavar "FORMAT" <> value Unstructured <>
- showDefault <>
- help "output format") <*>
- switch (long "filter" <> help "treat target as filter") <*>
- (fromMaybe "" <$> optional (argument str (metavar "TARGET" <> targetHelp))) <*>
- pure "" <*>
- pure ""
+listO _ =
+ Options
+ <$> strOption
+ ( long "keyring"
+ <> metavar "FILE"
+ <> help "file containing keyring"
+ )
+ <*> pure GraphViz -- unused
+ <*> option
+ auto
+ ( long "output-format"
+ <> metavar "FORMAT"
+ <> value Unstructured
+ <> showDefault
+ <> help "output format"
+ )
+ <*> switch (long "filter" <> help "treat target as filter")
+ <*> ( fromMaybe ""
+ <$> optional (argument str (metavar "TARGET" <> targetHelp))
+ )
+ <*> pure ""
+ <*> pure ""
where
targetHelp =
- helpDoc . Just $ pretty "target (which keys to output)*"
+ helpDoc . Just $ pretty "target (which keys to output)*"
graphO :: String -> Parser Options
-graphO homedir =
- Options <$>
- strOption (long "keyring" <> metavar "FILE" <> help "file containing keyring") <*>
- option
- auto
- (long "output-format" <> metavar "FORMAT" <> value GraphViz <> showDefault <>
- ofhelp) <*>
- pure Unstructured -- unused
- <*>
- switch (long "filter" <> help "treat target as filter") <*>
- (fromMaybe "" <$> optional (argument str (metavar "TARGET" <> targetHelp))) <*>
- pure "" <*>
- pure ""
+graphO _homedir =
+ Options
+ <$> strOption
+ ( long "keyring"
+ <> metavar "FILE"
+ <> help "file containing keyring"
+ )
+ <*> option
+ auto
+ ( long "output-format"
+ <> metavar "FORMAT"
+ <> value GraphViz
+ <> showDefault
+ <> ofhelp
+ )
+ <*> pure Unstructured -- unused
+ <*> switch (long "filter" <> help "treat target as filter")
+ <*> ( fromMaybe ""
+ <$> optional (argument str (metavar "TARGET" <> targetHelp))
+ )
+ <*> pure ""
+ <*> pure ""
where
ofhelp =
- helpDoc . Just $ pretty "output format" <> hardline <>
- list (map (pretty . show) ofchoices)
+ helpDoc . Just $
+ pretty "output format"
+ <> hardline
+ <> list (map (pretty . show) ofchoices)
ofchoices = [minBound .. maxBound] :: [GraphOutputFormat]
targetHelp =
- helpDoc . Just $ pretty "target (which keys to graph)*"
+ helpDoc . Just $ pretty "target (which keys to graph)*"
findPathsO :: String -> Parser Options
-findPathsO homedir =
- Options <$>
- strOption (long "keyring" <> metavar "FILE" <> help "file containing keyring") <*>
- pure GraphViz -- unused
- <*>
- option
- auto
- (long "output-format" <> metavar "FORMAT" <> value Unstructured <>
- showDefault <>
- help "output format") <*>
- switch (long "filter" <> help "treat targets as filter") <*>
- argument str (metavar "TARGET-SET" <> targetHelp) <*>
- argument str (metavar "FROM-KEYS" <> fromHelp) <*>
- argument str (metavar "TO-KEYS" <> toHelp)
+findPathsO _homedir =
+ Options
+ <$> strOption
+ ( long "keyring"
+ <> metavar "FILE"
+ <> help "file containing keyring"
+ )
+ <*> pure GraphViz -- unused
+ <*> option
+ auto
+ ( long "output-format"
+ <> metavar "FORMAT"
+ <> value Unstructured
+ <> showDefault
+ <> help "output format"
+ )
+ <*> switch (long "filter" <> help "treat targets as filter")
+ <*> argument str (metavar "TARGET-SET" <> targetHelp)
+ <*> argument str (metavar "FROM-KEYS" <> fromHelp)
+ <*> argument str (metavar "TO-KEYS" <> toHelp)
where
targetHelp =
- helpDoc . Just $
- pretty "target (which keys to use in pathfinding)*"
+ helpDoc . Just $
+ pretty "target (which keys to use in pathfinding)*"
fromHelp =
- helpDoc . Just $
- pretty "from (which keys to use for the source of paths)*"
+ helpDoc . Just $
+ pretty "from (which keys to use for the source of paths)*"
toHelp =
- helpDoc . Just $
- pretty "to (which keys to use for the destinations of paths)*"
+ helpDoc . Just $
+ pretty "to (which keys to use for the destinations of paths)*"
dispatch :: Command -> IO ()
dispatch (CmdList o) = banner' stderr >> hFlush stderr >> doList o
dispatch (CmdExportPubkeys o) =
- banner' stderr >> hFlush stderr >> doExportPubkeys o
+ banner' stderr >> hFlush stderr >> doExportPubkeys o
dispatch (CmdGraph o) = banner' stderr >> hFlush stderr >> doGraph o
dispatch (CmdFindPaths o) = banner' stderr >> hFlush stderr >> doFindPaths o
main :: IO ()
main = do
- hSetBuffering stderr LineBuffering
- homedir <- getHomeDirectory
- customExecParser
- (prefs showHelpOnError)
- (info
- (helper <*> versioner "hkt" <*> cmd homedir)
- (headerDoc (Just (banner "hkt")) <>
- progDesc "hOpenPGP Keyring Tool" <>
- footerDoc (Just (warranty "hkt")))) >>=
- dispatch
+ hSetBuffering stderr LineBuffering
+ homedir <- getHomeDirectory
+ customExecParser
+ (prefs showHelpOnError)
+ ( info
+ (helper <*> versioner "hkt" <*> cmd homedir)
+ ( headerDoc (Just (banner "hkt"))
+ <> progDesc "hOpenPGP Keyring Tool"
+ <> footerDoc (Just (warranty "hkt"))
+ )
+ )
+ >>= dispatch
cmd :: String -> Parser Command
cmd homedir =
- hsubparser
- (command
- "export-pubkeys"
- (info
- (CmdExportPubkeys <$> listO homedir)
- (progDesc "export matching keys to stdout" <> footerDoc (Just foot))) <>
- command
- "findpaths"
- (info
- (CmdFindPaths <$> findPathsO homedir)
- (progDesc "find short paths between keys" <> footerDoc (Just foot))) <>
- command
- "graph"
- (info
- (CmdGraph <$> graphO homedir)
- (progDesc "graph certifications" <> footerDoc (Just foot))) <>
- command
- "list"
- (info
- (CmdList <$> listO homedir)
- (progDesc "list matching keys" <> footerDoc (Just foot))))
+ hsubparser
+ ( command
+ "export-pubkeys"
+ ( info
+ (CmdExportPubkeys <$> listO homedir)
+ ( progDesc "export matching keys to stdout"
+ <> footerDoc (Just foot)
+ )
+ )
+ <> command
+ "findpaths"
+ ( info
+ (CmdFindPaths <$> findPathsO homedir)
+ (progDesc "find short paths between keys" <> footerDoc (Just foot))
+ )
+ <> command
+ "graph"
+ ( info
+ (CmdGraph <$> graphO homedir)
+ (progDesc "graph certifications" <> footerDoc (Just foot))
+ )
+ <> command
+ "list"
+ ( info
+ (CmdList <$> listO homedir)
+ (progDesc "list matching keys" <> footerDoc (Just foot))
+ )
+ )
where
foot =
- hardline <>
- fillSep
- [ pretty "*if --filter is not specified, this must be"
- , pretty "a fingerprint,"
- , pretty "an eight-octet key ID,"
- , pretty "or a substring of a UID (including an empty string)"
- ] <>
- hardline <>
- fillSep
- [ pretty "if --filter is specified, it must be"
- , pretty "something in filter syntax (see source)."
- ]
+ hardline
+ <> fillSep
+ [ pretty "*if --filter is not specified, this must be"
+ , pretty "a fingerprint,"
+ , pretty "an eight-octet key ID,"
+ , pretty "or a substring of a UID (including an empty string)"
+ ]
+ <> hardline
+ <> fillSep
+ [ pretty "if --filter is specified, it must be"
+ , pretty "something in filter syntax (see source)."
+ ]
banner' :: Handle -> IO ()
-banner' h = hPutDoc h (banner "hkt" <> hardline <> warranty "hkt" <> hardline)
+banner' h =
+ hPutDoc
+ h
+ (banner "hkt" <> hardline <> warranty "hkt" <> hardline)
doList :: Options -> IO ()
doList o = do
- let ttarget1 = T.pack . target1
- keys' <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
- let keys = map tkToTKey keys'
- case pathsOutputFormat o of
- Unstructured -> mapM_ showTKey keys
- JSON -> BL.putStr . A.encode $ keys
- YAML -> B.putStr . Y.encode $ keys
- putStrLn ""
+ let ttarget1 = T.pack . target1
+ keys' <-
+ grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
+ let keys = map tkToTKey keys'
+ case pathsOutputFormat o of
+ Unstructured -> mapM_ showTKey keys
+ JSON -> BL.putStr . A.encode $ keys
+ YAML -> B.putStr . Y.encode $ keys
+ putStrLn ""
doExportPubkeys :: Options -> IO ()
doExportPubkeys o = do
- let ttarget1 = T.pack . target1
- keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
- case pathsOutputFormat o of
- Unstructured -> mapM_ (BL.putStr . putTK') keys
- JSON -> BL.putStr . A.encode $ keys
- YAML -> B.putStr . Y.encode $ keys
+ let ttarget1 = T.pack . target1
+ keys <-
+ grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
+ case pathsOutputFormat o of
+ Unstructured -> mapM_ (BL.putStr . putTK') keys
+ JSON -> BL.putStr . A.encode $ keys
+ YAML -> B.putStr . Y.encode $ keys
where
- putTK' key =
- runPut $ do
- put (PublicKey (key ^. tkuKey . _1))
- mapM_ (put . Signature) (_tkuRevs key)
- mapM_ putUid' (_tkuUIDs key)
- mapM_ putUat' (_tkuUAts key)
- mapM_ putSub' (_tkuSubs key)
+ putTK' tk =
+ runPut $ do
+ put (PublicKey (tk ^. tkuKey . _1))
+ mapM_ (put . Signature) (_tkuRevs tk)
+ mapM_ putUid' (_tkuUIDs tk)
+ mapM_ putUat' (_tkuUAts tk)
+ mapM_ putSub' (_tkuSubs tk)
putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps
putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps
putSub' (p, sps) = put p >> mapM_ (put . Signature) sps
doGraph :: Options -> IO ()
doGraph o = do
- let ttarget1 = T.pack . target1
- cpt <- getPOSIXTime
- keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
- kr <- grabMatchingPublicKeyring keys
- let g =
- buildKeyGraph
- ((buildMaps &&& id)
- (rights
- (map
- (verifyUnknownTKWith
- (verifySigWith (verifyAgainstKeyring kr))
- (Just (posixSecondsToUTCTime cpt)))
- keys)))
- case g of
- Left err -> dieHKT err
- Right graph ->
- case graphOutputFormat o of
- LossyPretty -> prettyPrint graph
- GraphViz ->
- TLIO.putStrLn . printDotGraph . graphToDot nonClusteredLabeledNodesParams $
- graph
+ let ttarget1 = T.pack . target1
+ cpt <- getPOSIXTime
+ keys <-
+ grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
+ kr <- grabMatchingPublicKeyring keys
+ let g =
+ buildKeyGraph
+ ( (buildMaps &&& id)
+ ( rights
+ ( map
+ ( verifyUnknownTKWith
+ (verifySigWith (verifyAgainstKeyring kr))
+ (Just (posixSecondsToUTCTime cpt))
+ )
+ keys
+ )
+ )
+ )
+ case g of
+ Left err -> dieHKT err
+ Right graph ->
+ case graphOutputFormat o of
+ LossyPretty -> prettyPrint graph
+ GraphViz ->
+ TLIO.putStrLn
+ . printDotGraph
+ . graphToDot nonClusteredLabeledNodesParams
+ $ graph
where
nonClusteredLabeledNodesParams =
- nonClusteredParams {fmtNode = \(_, l) -> [toLabel $ renderFingerprint l]}
+ nonClusteredParams
+ { fmtNode = \(_, l) -> [toLabel $ renderFingerprint l]
+ }
buildMaps :: [TKUnknown] -> (KeyMaps, Int)
buildMaps =
- foldr mapsInsertions (KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0)
+ foldr
+ mapsInsertions
+ (KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0)
-- FIXME: this presumes no keyID collisions in the input
-data KeyMaps =
- KeyMaps
+data KeyMaps
+ = KeyMaps
{ _k2f :: HashMap EightOctetKeyId Fingerprint
, _f2i :: HashMap Fingerprint Int
, _i2f :: HashMap Int Fingerprint
@@ -459,132 +580,167 @@
mapsInsertions :: TKUnknown -> (KeyMaps, Int) -> (KeyMaps, Int)
mapsInsertions tk (KeyMaps k2f f2i i2f, i) =
- let fp = fingerprint (tk ^. tkuKey . _1)
- keyids = rights . map eightOctetKeyID $ (tk ^.. biplate :: [SomePKPayload])
- i' = i + 1
- k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids
- f2i' = HashMap.insert fp i' f2i
- i2f' = HashMap.insert i' fp i2f
- in (KeyMaps k2f' f2i' i2f', i')
+ let fp = fingerprint (tk ^. tkuKey . _1)
+ keyids =
+ rights . map eightOctetKeyID $
+ (tk ^.. biplate :: [SomePKPayload])
+ i' = i + 1
+ k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids
+ f2i' = HashMap.insert fp i' f2i
+ i2f' = HashMap.insert i' fp i2f
+ in (KeyMaps k2f' f2i' i2f', i')
-buildKeyGraph ::
- ((KeyMaps, Int), [TKUnknown]) -> Either String (Gr Fingerprint HashAlgorithm)
+buildKeyGraph
+ :: ((KeyMaps, Int), [TKUnknown])
+ -> Either String (Gr Fingerprint HashAlgorithm)
buildKeyGraph ((KeyMaps k2f f2i _, _), ks) = do
- edges <- fmap concat (mapM tkToEdges ks)
- pure (mkGraph nodes (filter (not . samesies) . nub . sort $ edges))
+ edges <- fmap concat (mapM tkToEdges ks)
+ pure
+ (mkGraph nodes (filter (not . samesies) . nub . sort $ edges))
where
nodes = map swap . HashMap.toList $ f2i
tkToEdges tk = do
- target <- lookupNode (fingerprint (tk ^. tkuKey . _1))
- mapM (edgeFor target) (mapMaybe (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk))
+ target <- lookupNode (fingerprint (tk ^. tkuKey . _1))
+ mapM
+ (edgeFor target)
+ (mapMaybe (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk))
edgeFor target (ha, i) = do
- source <- lookupSource i
- pure (source, target, ha)
+ source <- lookupSource i
+ pure (source, target, ha)
lookupSource i =
- case HashMap.lookup i k2f >>= flip HashMap.lookup f2i of
- Just source -> Right source
- Nothing ->
- Left ("hkt: no source node for signature issuer key ID " ++ show i)
+ case HashMap.lookup i k2f >>= flip HashMap.lookup f2i of
+ Just source -> Right source
+ Nothing ->
+ Left
+ ("hkt: no source node for signature issuer key ID " ++ show i)
lookupNode fp =
- case HashMap.lookup fp f2i of
- Just node -> Right node
- Nothing ->
- Left ("hkt: no graph node for fingerprint " ++ renderFingerprint fp)
+ case HashMap.lookup fp f2i of
+ Just node -> Right node
+ Nothing ->
+ Left
+ ("hkt: no graph node for fingerprint " ++ renderFingerprint fp)
fakejoin (x, y) = fmap ((,) x) y
sigs tk =
- concat
- ((tk ^.. tkuUIDs . traverse . _2) ++ (tk ^.. tkuUAts . traverse . _2))
+ concat
+ ( (tk ^.. tkuUIDs . traverse . _2)
+ ++ (tk ^.. tkuUAts . traverse . _2)
+ )
samesies (x, y, _) = x == y
-data PaF =
- PaF
+data PaF
+ = PaF
{ certPaths :: [Path]
, keyFingerprints :: Map String Fingerprint
}
- deriving (Generic)
+ deriving (Generic)
instance A.ToJSON PaF
doFindPaths :: Options -> IO ()
doFindPaths o = do
- let ttarget1 = T.pack . target1
- ttarget2 = T.pack . target2
- ttarget3 = T.pack . target3
- filt = targetIsFilter o
- cpt <- getPOSIXTime
- keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
- kr <- grabMatchingPublicKeyring keys
+ let ttarget1 = T.pack . target1
+ ttarget2 = T.pack . target2
+ ttarget3 = T.pack . target3
+ filt = targetIsFilter o
+ cpt <- getPOSIXTime
+ keys <-
+ grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
+ kr <- grabMatchingPublicKeyring keys
-- FIXME: seriously clean this up
- filter2 <- parseFilterPredicateIO (ttarget2 o) >>= either dieHKT pure
- filter3 <- parseFilterPredicateIO (ttarget3 o) >>= either dieHKT pure
- keys1 <-
- runConduitRes $ CL.sourceList keys .|
- (if filt
- then conduitTKFilter filter2
- else CL.filter (matchAny (ttarget2 o))) .|
- CL.consume
- keys2 <-
- runConduitRes $ CL.sourceList keys .|
- (if filt
- then conduitTKFilter filter3
- else CL.filter (matchAny (ttarget3 o))) .|
- CL.consume
- let ((KeyMaps k2f f2i i2f, i), ks) =
- (buildMaps &&& id)
- (rights
- (map
- (verifyUnknownTKWith
- (verifySigWith (verifyAgainstKeyring kr))
- (Just (posixSecondsToUTCTime cpt)))
- keys))
- keygraph <- either dieHKT pure (buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks))
- let keysToIs =
- mapMaybe (\x -> HashMap.lookup (fingerprint (x ^. tkuKey . _1)) f2i)
- froms = keysToIs keys1
- tos = keysToIs keys2
- combos = froms >>= \f -> tos >>= \t -> return (f, t)
- paths =
- map
- (\(x, y) ->
- fromMaybe [] (sp x y (emap (const (1.0 :: Double)) keygraph)))
- combos
- paf =
- PaF
- paths
- (Map.fromList
- (mapMaybe
- (\x -> HashMap.lookup x i2f >>= \y -> return (show x, y))
- (nub (sort (concat paths)))))
- case pathsOutputFormat o of
- Unstructured -- FIXME: do something about this
- -> do
- putStrLn . unlines $ map (show . ((,) =<< length)) paths
- putStrLn . unlines $
- map
- (\x ->
- maybe (show x) renderFingerprint (HashMap.lookup x i2f))
- (nub (sort (concat paths)))
- JSON -> BL.putStr . A.encode $ paf
- YAML -> B.putStr . Y.encode $ paf
- putStrLn ""
+ filter2 <-
+ parseFilterPredicateIO (ttarget2 o) >>= either dieHKT pure
+ filter3 <-
+ parseFilterPredicateIO (ttarget3 o) >>= either dieHKT pure
+ keys1 <-
+ runConduitRes $
+ CL.sourceList keys
+ .| ( if filt
+ then conduitTKFilter filter2
+ else CL.filter (matchAny (ttarget2 o))
+ )
+ .| CL.consume
+ keys2 <-
+ runConduitRes $
+ CL.sourceList keys
+ .| ( if filt
+ then conduitTKFilter filter3
+ else CL.filter (matchAny (ttarget3 o))
+ )
+ .| CL.consume
+ let ((KeyMaps k2f f2i i2f, i), ks) =
+ (buildMaps &&& id)
+ ( rights
+ ( map
+ ( verifyUnknownTKWith
+ (verifySigWith (verifyAgainstKeyring kr))
+ (Just (posixSecondsToUTCTime cpt))
+ )
+ keys
+ )
+ )
+ keygraph <-
+ either dieHKT pure (buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks))
+ let keysToIs =
+ mapMaybe
+ (\x -> HashMap.lookup (fingerprint (x ^. tkuKey . _1)) f2i)
+ froms = keysToIs keys1
+ tos = keysToIs keys2
+ combos = froms >>= \f -> tos >>= \t -> return (f, t)
+ paths =
+ map
+ ( \(x, y) ->
+ fromMaybe [] (sp x y (emap (const (1.0 :: Double)) keygraph))
+ )
+ combos
+ paf =
+ PaF
+ paths
+ ( Map.fromList
+ ( mapMaybe
+ (\x -> HashMap.lookup x i2f >>= \y -> return (show x, y))
+ (nub (sort (concat paths)))
+ )
+ )
+ case pathsOutputFormat o of
+ Unstructured ->
+ -- FIXME: do something about this
+ do
+ putStrLn . unlines $ map (show . ((,) =<< length)) paths
+ putStrLn . unlines $
+ map
+ ( \x ->
+ maybe (show x) renderFingerprint (HashMap.lookup x i2f)
+ )
+ (nub (sort (concat paths)))
+ JSON -> BL.putStr . A.encode $ paf
+ YAML -> B.putStr . Y.encode $ paf
+ putStrLn ""
where
matchAny srch tk =
- either (const False) id $ runExcept $
- fmap (keyMatchesFingerprint True tk) ((except . parseFingerprint) srch) <|>
- fmap
- (keyMatchesEightOctetKeyId True tk . Right)
- ((except . parseEightOctetKeyId) srch) <|>
- return (keyMatchesUIDSubString srch tk)
+ either (const False) id $
+ runExcept $
+ fmap
+ (keyMatchesFingerprint True tk)
+ ((except . parseFingerprint) srch)
+ <|> fmap
+ (keyMatchesEightOctetKeyId True tk . Right)
+ ((except . parseEightOctetKeyId) srch)
+ <|> return (keyMatchesUIDSubString srch tk)
-parseFilterPredicateIO :: Text -> IO (Either String (FilterPredicates Void TKUnknown))
+parseFilterPredicateIO
+ :: Text -> IO (Either String (FilterPredicates Void TKUnknown))
parseFilterPredicateIO e = do
- parsed <-
- try (evaluate (RTKFilterPredicate <$> parseTKExp (T.unpack e))) ::
- IO (Either ErrorCall (Either String (FilterPredicates Void TKUnknown)))
- pure $
- case parsed of
- Left err -> Left (show err)
- Right result -> result
+ parsed <-
+ try (evaluate (RTKFilterPredicate <$> parseTKExp (T.unpack e)))
+ :: IO
+ ( Either
+ ErrorCall
+ (Either String (FilterPredicates Void TKUnknown))
+ )
+ pure $
+ case parsed of
+ Left err -> Left (show err)
+ Right result -> result
dieHKT :: String -> IO a
dieHKT msg = hPutStrLn stderr msg >> exitFailure
@@ -596,9 +752,9 @@
sigissuer (SigVOther 2 _) = Nothing
sigissuer SigV3 {} = Nothing
sigissuer (SigV4 _ _ _ ys xs _ _) =
- listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
+ listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
sigissuer (SigV6 _ _ _ _ ys xs _ _) =
- listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
+ listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs) -- FIXME: what should this be if there are multiple matches?
sigissuer (SigVOther _ _) = Nothing
getIssuer (Issuer i) = Just i
diff --git a/hop.hs b/hop.hs
--- a/hop.hs
+++ b/hop.hs
@@ -15,4929 +15,6057 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE RecordWildCards #-}
-
-import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
-import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..))
-import Codec.Encryption.OpenPGP.Compression (decompressPkt, renderCompressionError)
-import Codec.Encryption.OpenPGP.Expirations (effectiveKeyPreferencesAt, isTKTimeValid)
-import Codec.Encryption.OpenPGP.Encrypt
- ( EncryptCompatibilityProfile(..)
- , PKESKEncryptError(..)
- , PKESKSessionMaterial(..)
- , RecipientEncryptRequest(..)
- , RecipientEncryptRequestOverrides(..)
- , RecipientEncryptResult(..)
- , RecipientPKESKVersionStrategy(..)
- , RecipientPayloadShape(..)
- , defaultRecipientPayloadShape
- , encryptForRecipients
- , recipientEncryptionTarget
- , recipientEncryptionTargetWithStrategy
- )
-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
-import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
-import Codec.Encryption.OpenPGP.Message
- ( EncryptMessageOptions(..)
- , encryptedPayloadBytes
- , RecoveredSessionMaterial(..)
- , SessionMaterialExposure(..)
- , encryptMessage
- , mkClearPayload
- , mkPassphrase
- )
-import Codec.Encryption.OpenPGP.Ontology (isKUF, isPKBindingSig, isSKBindingSig)
-import Codec.Encryption.OpenPGP.Policy
- ( PKESKVersionPolicy(..)
- , defaultDecryptPolicy
- , defaultPolicy
- , lenientDecryptPolicy
- )
-import Codec.Encryption.OpenPGP.S2K
- ( decodeOpenPGPEncodedSessionKey
- , skesk2Key
- , skesk2SessionKey
- )
-import Codec.Encryption.OpenPGP.Serialize (parsePkts)
-import Codec.Encryption.OpenPGP.SecretKey
- ( decryptPrivateKey
- , encryptPrivateKey
- )
-import qualified Codec.Encryption.OpenPGP.Subpackets as SP
-import Codec.Encryption.OpenPGP.Signatures
- ( SignError(..)
- , renderSignError
- , signCertRevocationWithRSA
- , signDataWithEd25519
- , signDataWithEd25519Legacy
- , signDataWithEd25519V6
- , signDataWithEd448
- , signDataWithEd448V6
- , signDataWithRSABuilder
- , signKeyRevocationWithRSA
- , signDataWithRSAV6
- , signUserIDwithRSA
- , verifyAgainstKeys
- , verifyAgainstKeyring
- , verifySigWith
- , verifyUnknownTKWith
- )
-import Codec.Encryption.OpenPGP.Types
-import Control.Applicative ((<|>), optional, some, many)
-import Control.Error.Util (note)
-import Control.Monad ((>=>), forM, forM_, unless, when)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)
-import Control.Monad.Trans.Resource (MonadResource, MonadThrow)
-import Control.Exception
- ( IOException
- , SomeException
- , catch
- , displayException
- , evaluate
- , throwIO
- )
-import qualified Crypto.PubKey.Ed25519 as Ed25519
-import qualified Crypto.PubKey.Ed448 as Ed448
-import qualified Crypto.PubKey.Curve25519 as Curve25519
-import qualified Crypto.PubKey.RSA as RSA
-import qualified Crypto.PubKey.RSA.PKCS15 as P15
-import Crypto.Number.Serialize (i2ospOf_, os2ip)
-import Crypto.Random.Types (getRandomBytes)
-import Crypto.Error (eitherCryptoError)
-import qualified Data.Aeson as A
-import qualified Data.Binary as Bin
-import Data.Binary.Get (runGet)
-import Data.Binary.Put (runPut, putByteString, putLazyByteString, putWord8, putWord16be, putWord32be)
-import Data.Bits ((.&.), (.|.), shiftL, shiftR)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Lazy.Char8 as BLC8
-import Data.Conduit ((.|), fuseBoth, runConduitRes)
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.Combinators as CC
-import qualified Data.Conduit.List as CL
-import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt
-import Data.Conduit.OpenPGP.Decrypt
- ( DecryptKeyResolution(..)
- , DecryptOutcome(..)
- , PKESKRecipientKey(..)
- )
-import Data.Conduit.OpenPGP.Keyring
- ( conduitToTKsDropping
- , sinkPublicKeyringMap
- )
-import Data.Conduit.OpenPGP.Verify (conduitVerify, verifyPacketsBatch)
-import Data.Conduit.Serialization.Binary (conduitGet)
-import Data.Either (fromRight, isLeft, isRight, rights)
-import Data.Bifunctor (first)
-import Data.Char (digitToInt, isHexDigit, isSpace, toLower)
-import Data.List (find, findIndex, foldl', intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, partition, stripPrefix)
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)
-import Data.Monoid ((<>))
-import qualified Data.Set as S
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import Data.Text.Encoding.Error (lenientDecode)
-import Data.Time.Clock (UTCTime)
-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
-import Data.Time.Format (defaultTimeLocale, formatTime)
-import Data.Time.Format.ISO8601 (iso8601ParseM)
-import Data.IORef (IORef, newIORef, atomicModifyIORef')
-import qualified Data.Vector as V
-import Data.Version (showVersion)
-import Data.Word (Word8)
-import qualified Data.Yaml as Y
-import GHC.Generics
-import HOpenPGP.Tools.Common.Armor (doDeArmor)
-import HOpenPGP.Tools.Common.Common
- ( banner
- , keyMatchesEightOctetKeyId
- , keyMatchesFingerprint
- , keyMatchesUIDSubString
- , versioner
- , warranty
- )
-import HOpenPGP.Tools.Common.Parser (parseTKExp)
-import HOpenPGP.Tools.Common.TKUtils (processTK)
-import Paths_hopenpgp_tools (version)
-import System.Exit (exitFailure, exitSuccess, exitWith, ExitCode(..))
-
-import Options.Applicative.Builder
- ( argument
- , auto
- , command
- , eitherReader
- , footerDoc
- , headerDoc
- , help
- , helpDoc
- , info
- , long
- , metavar
- , option
- , prefs
- , progDesc
- , short
- , showDefault
- , showHelpOnError
- , str
- , strArgument
- , strOption
- , switch
- , value
- )
-import Options.Applicative.Extra (customExecParser, helper, hsubparser)
-import Options.Applicative.Types (Parser)
-import Text.Read (readMaybe)
-
-import Prettyprinter
- ( (<+>)
- , fillSep
- , hardline
- , list
- , pretty
- , softline
- )
-import Prettyprinter.Render.Text (hPutDoc)
-import System.IO (BufferMode(..), Handle, hFlush, hPutStrLn, hSetBuffering, stderr, stdin)
-import System.Directory (doesFileExist)
-import System.Environment (getArgs, lookupEnv)
-
-data Command
- = VersionC VersionOptions
- | ListProfilesC ListProfilesOptions
- | GenerateKeyC KeyGenOptions
- | ChangeKeyPasswordC ChangeKeyPasswordOptions
- | MergeCertsC MergeCertsOptions
- | ValidateUserIdC ValidateUserIdOptions
- | CertifyUserIdC CertifyUserIdOptions
- | RevokeKeyC RevokeKeyOptions
- | RevokeUserIdC RevokeUserIdOptions
- | UpdateKeyC UpdateKeyOptions
- | VerifyC VerifyOptions
- | InlineVerifyC InlineVerifyOptions
- | EncryptC EncryptOptions
- | DecryptC DecryptOptions
- | InlineSignC InlineSignOptions
- | InlineDetachC InlineDetachOptions
- | ExtractCertC ExtractCertOptions
- | SignC SignOptions
- | UnsupportedC String
- | DeArmorC
- | ArmorC ArmoringOptions
-
-data Options =
- Options
- { keyrings :: [String]
- , outputFormat :: OutputFormat
- , sigFilter :: String
- , sigFile :: String
- , blobFile :: String
- }
-
-data OutputFormat
- = Unstructured
- | JSON
- | YAML
- deriving (Eq, Read, Show)
-
-data VerifyOptions =
- VerifyOptions
- { verifyNotBefore :: Maybe String
- , verifyNotAfter :: Maybe String
- , verifySigFile :: String
- , verifyCertFiles :: [String]
- }
-
-data InlineVerifyOptions =
- InlineVerifyOptions
- { inlineNotBefore :: Maybe String
- , inlineNotAfter :: Maybe String
- , verificationsOut :: Maybe String
- , inlineCertFiles :: [String]
- }
-
-data EncryptOptions =
- EncryptOptions
- { encNoArmor :: Bool
- , encArmor :: Bool
- , encProfile :: Maybe String
- , encAs :: AsBinaryText
- , encSignWithKeyFiles :: [String]
- , encSignWithKeyPasswords :: [String]
- , encSessionKeyOutFile :: Maybe String
- , encFor :: EncryptFor
- , encWithoutIntegrityCheck :: Bool
- , encPasswords :: [String]
- , encRecipientCerts :: [String]
- }
-
-data EncryptProfile
- = EncryptProfileRFC9580
- | EncryptProfileRFC4880
- deriving (Eq)
-
-data DecryptOptions =
- DecryptOptions
- { decNoArmor :: Bool
- , decArmor :: Bool
- , decWithoutIntegrityCheck :: Bool
- , decVerifyNotBefore :: Maybe String
- , decVerifyNotAfter :: Maybe String
- , decSessionKeys :: [String]
- , decSessionKeyOutFile :: Maybe String
- , decPasswords :: [String]
- , decKeyPasswords :: [String]
- , decKeyFiles :: [String]
- , decVerifyCerts :: [String]
- , decVerificationsOutFile :: Maybe String
- , decDeprecatedVerifyOutFile :: Maybe String
- }
-
-data InlineSignOptions =
- InlineSignOptions
- { inlineSignNoArmor :: Bool
- , inlineSignArmor :: Bool
- , inlineSignProfile :: Maybe String
- , inlineSignAs :: Maybe InlineSignMode
- , inlineSignKeyFiles :: [String]
- , inlineSignKeyPasswords :: [String]
- }
-
-data InlineDetachOptions =
- InlineDetachOptions
- { inlineDetachNoArmor :: Bool
- , inlineDetachOutputSigs :: String
- }
-
-data ChangeKeyPasswordOptions =
- ChangeKeyPasswordOptions
- { changeKeyPasswordNoArmor :: Bool
- , changeKeyPasswordOldPasswords :: [String]
- , changeKeyPasswordNewPasswords :: [String]
- }
-
-data MergeCertsOptions =
- MergeCertsOptions
- { mergeCertsNoArmor :: Bool
- , mergeCertsFiles :: [String]
- }
-
-data ValidateUserIdOptions =
- ValidateUserIdOptions
- { validateUserIdAddrSpecOnly :: Bool
- , validateUserIdAt :: Maybe String
- , validateUserIdString :: String
- , validateUserIdAuthorityFiles :: [String]
- }
-
-data CertifyUserIdOptions =
- CertifyUserIdOptions
- { certifyUserIds :: [String]
- , certifyUserIdOutputFormat :: Maybe String
- , certifyUserIdNoRequireSelfSig :: Bool
- , certifyUserIdKeyPasswordFiles :: [String]
- , certifyUserIdSignerFiles :: [String]
- }
-
-data RevokeKeyOptions =
- RevokeKeyOptions
- { revokeKeyNoArmor :: Bool
- , revokeKeyPasswordFiles :: [String]
- }
-
-data RevokeUserIdOptions =
- RevokeUserIdOptions
- { revokeUserIdString :: String
- , revokeUserIdNoArmor :: Bool
- }
-
-data UpdateKeyOptions =
- UpdateKeyOptions
- { updateKeyNoArmor :: Bool
- , updateKeySigningOnly :: Bool
- , updateKeyRevokeDeprecatedKeys :: Bool
- , updateKeyNoAddedCapabilities :: Bool
- , updateKeyPasswordFiles :: [String]
- , updateKeyMergeCerts :: [String]
- }
-
-newtype ListProfilesOptions =
- ListProfilesOptions
- { profileSubcommand :: String
- }
-
-data VersionOptions =
- VersionOptions
- { vBackend :: Bool
- , vExtended :: Bool
- , vSopSpec :: Bool
- , vSopv :: Bool
- }
-
-data CliOptions =
- CliOptions
- { cliDebug :: Bool
- , cliCommand :: Command
- }
-
-data SopFailure
- = MissingArg
- | IncompleteVerification
- | BadData
- | PasswordNotHumanReadable
- | ExpectedText
- | CannotDecrypt
- | UnsupportedAsymmetricAlgo
- | CertCannotEncrypt
- | UnsupportedOption
- | OutputExists
- | MissingInput
- | NoSignature
- | KeyIsProtected
- | KeyCannotSign
- | UnsupportedSpecialPrefix
- | IncompatibleOptions
- | UnsupportedProfile
- | UnsupportedSubcommand
- | CertUserIdNoMatch
- | KeyCannotCertify
-
-failureCode :: SopFailure -> Int
-failureCode MissingArg = 19
-failureCode IncompleteVerification = 23
-failureCode BadData = 41
-failureCode PasswordNotHumanReadable = 31
-failureCode ExpectedText = 53
-failureCode CannotDecrypt = 29
-failureCode UnsupportedAsymmetricAlgo = 13
-failureCode CertCannotEncrypt = 17
-failureCode UnsupportedOption = 37
-failureCode OutputExists = 59
-failureCode MissingInput = 61
-failureCode NoSignature = 3
-failureCode KeyIsProtected = 67
-failureCode KeyCannotSign = 79
-failureCode UnsupportedSpecialPrefix = 71
-failureCode IncompatibleOptions = 83
-failureCode UnsupportedProfile = 89
-failureCode UnsupportedSubcommand = 69
-failureCode CertUserIdNoMatch = 107
-failureCode KeyCannotCertify = 109
-
-failWith :: SopFailure -> String -> IO a
-failWith f msg = do
- BLC8.hPutStrLn stderr (BLC8.pack msg)
- exitWith (ExitFailure (failureCode f))
-
-o :: Parser Options
-o =
- Options <$>
- some
- (strOption
- (long "keyring" <>
- short 'k' <> metavar "FILE" <> help "file containing keyring")) <*>
- option
- auto
- (long "output-format" <>
- metavar "FORMAT" <>
- value Unstructured <> showDefault <> help "output format") <*>
- option
- auto
- (long "signature-filter" <>
- metavar "SIGFILTER" <>
- value "sigcreationtime < now" <>
- showDefault <> help "verify only signatures which match filter spec") <*>
- argument str (metavar "SIGNATURE" <> sigHelp) <*>
- argument str (metavar "BLOB" <> blobHelp)
- where
- sigHelp =
- helpDoc . Just $
- pretty "file containing OpenPGP binary signatures"
- blobHelp =
- helpDoc . Just $
- pretty "file containing binary blob to be validated"
-
-voP :: Parser VerifyOptions
-voP =
- VerifyOptions <$>
- optional
- (strOption
- (long "not-before" <>
- metavar "DATE" <> help "ignore signatures before DATE")) <*>
- optional
- (strOption
- (long "not-after" <>
- metavar "DATE" <> help "ignore signatures after DATE")) <*>
- argument str (metavar "SIGNATURES" <> sigHelp) <*>
- some (strArgument (metavar "CERTS..." <> certHelp))
- where
- sigHelp =
- helpDoc . Just $
- pretty "file containing OpenPGP signatures"
- certHelp =
- helpDoc . Just $
- pretty "one or more certificate files"
-
-ivoP :: Parser InlineVerifyOptions
-ivoP =
- InlineVerifyOptions <$>
- optional
- (strOption
- (long "not-before" <>
- metavar "DATE" <> help "ignore signatures before DATE")) <*>
- optional
- (strOption
- (long "not-after" <>
- metavar "DATE" <> help "ignore signatures after DATE")) <*>
- optional
- (strOption
- (long "verifications-out" <>
- metavar "VERIFICATIONS" <> help "write verification records to file")) <*>
- some (strArgument (metavar "CERTS..." <> certHelp))
- where
- certHelp =
- helpDoc . Just $
- pretty "one or more certificate files"
-
-lpoP :: Parser ListProfilesOptions
-lpoP =
- ListProfilesOptions <$>
- strArgument (metavar "SUBCOMMAND" <> help "subcommand to list profiles for")
-
-vopP :: Parser VersionOptions
-vopP =
- VersionOptions <$>
- switch (long "backend" <> help "show backend implementation version") <*>
- switch (long "extended" <> help "show extended version information") <*>
- switch (long "sop-spec" <> help "show targeted sop draft") <*>
- switch (long "sopv" <> help "show implemented sopv subset version")
-
-encP :: Parser EncryptOptions
-encP =
- EncryptOptions <$>
- switch (long "no-armor" <> help "output binary") <*>
- switch (long "armor" <> help "output ASCII Armor") <*>
- optional (strOption (long "profile" <> help "encryption profile")) <*>
- option
- (eitherReader asTypeReader)
- (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary) <*>
- many (strOption (long "sign-with" <> help "signing key material")) <*>
- many
- (strOption
- (long "with-key-password" <>
- help "password for unlocking signing key material")) <*>
- optional
- (strOption
- (long "session-key-out" <>
- metavar "SESSIONKEY" <> help "write generated session key to file")) <*>
- option
- (eitherReader encryptForReader)
- (long "for" <>
- metavar "ENCRYPTION_PURPOSE" <>
- help "select recipient key purpose (any, storage, communications)" <>
- value EncryptForAny) <*>
- switch (long "without-integrity-check" <> help "disable integrity protection") <*>
- many (strOption (long "with-password" <> help "symmetric encryption password")) <*>
- many (strArgument (metavar "CERT" <> help "recipient certificate files"))
- where
- astypeHelp =
- helpDoc . Just $
- pretty "what to treat the input as" <>
- softline <> list (map (pretty . fst) asTypes)
-
-decP :: Parser DecryptOptions
-decP =
- DecryptOptions <$>
- switch (long "no-armor" <> help "output binary") <*>
- switch (long "armor" <> help "output ASCII Armor") <*>
- switch (long "without-integrity-check" <> help "disable integrity verification") <*>
- optional
- (strOption
- (long "verify-not-before" <>
- metavar "DATE" <> help "ignore signatures before DATE when decrypting")) <*>
- optional
- (strOption
- (long "verify-not-after" <>
- metavar "DATE" <> help "ignore signatures after DATE when decrypting")) <*>
- many (strOption (long "with-session-key" <> help "session key for decryption")) <*>
- optional (strOption (long "session-key-out" <> help "write recovered session key")) <*>
- many (strOption (long "with-password" <> help "password for SKESK decryption")) <*>
- many
- (strOption
- (long "with-key-password" <>
- help "password for unlocking decryption key material")) <*>
- many (strArgument (metavar "KEY" <> help "secret key material")) <*>
- many (strOption (long "verify-with" <> help "certificate(s) to verify signatures with")) <*>
- optional
- (strOption
- (long "verifications-out" <>
- help "write verification results to file")) <*>
- optional
- (strOption
- (long "verify-out" <>
- help "deprecated alias for --verifications-out"))
-
-inlineSignP :: Parser InlineSignOptions
-inlineSignP =
- InlineSignOptions <$>
- switch (long "no-armor" <> help "output binary") <*>
- switch (long "armor" <> help "output ASCII Armor") <*>
- optional (strOption (long "profile" <> help "signature profile")) <*>
- optional
- (option
- (eitherReader inlineSignModeReader)
- (long "as" <> metavar "DATATYPE" <> inlineSignAsHelp)) <*>
- some (strArgument (metavar "KEY" <> help "signing key file(s)")) <*>
- many (strOption (long "with-key-password" <> metavar "PASSWORD" <> help "password for encrypted signing key"))
- where
- inlineSignAsHelp =
- helpDoc . Just $
- pretty "what to treat the input as" <>
- softline <> list [pretty "binary", pretty "text", pretty "clearsigned"]
-
-inlineDetachP :: Parser InlineDetachOptions
-inlineDetachP =
- InlineDetachOptions <$>
- switch (long "no-armor" <> help "output binary") <*>
- strOption
- (long "signatures-out" <> metavar "SIGNATURES" <> help "write detached signatures to file")
-
-mergeCertsP :: Parser MergeCertsOptions
-mergeCertsP =
- MergeCertsOptions <$>
- switch (long "no-armor" <> help "output binary") <*>
- some (strArgument (metavar "CERTS..." <> help "one or more certificate files"))
-
-validateUserIdP :: Parser ValidateUserIdOptions
-validateUserIdP =
- ValidateUserIdOptions <$>
- switch
- (long "addr-spec-only" <>
- help "match only the addr-spec portion of conventional OpenPGP User IDs") <*>
- optional
- (strOption
- (long "validate-at" <>
- metavar "DATE" <> help "evaluate certifications at DATE")) <*>
- argument str (metavar "USERID" <> help "user ID to validate") <*>
- some (strArgument (metavar "CERTS..." <> help "one or more authority certificate files"))
-
-certifyUserIdP :: Parser CertifyUserIdOptions
-certifyUserIdP =
- CertifyUserIdOptions <$>
- some
- (strOption
- (long "userid" <>
- metavar "USERID" <> help "user ID to certify (repeatable)")) <*>
- optional
- (strOption
- (long "output-format" <>
- metavar "FORMAT" <>
- help "output format (text or binary)")) <*>
- switch (long "no-require-self-sig" <> help "allow certifying user IDs that do not have self-signatures") <*>
- many
- (strOption
- (long "with-key-password" <>
- help "password for unlocking signer key material")) <*>
- some (strArgument (metavar "KEYS..." <> help "one or more signer key files"))
-
-revokeKeyP :: Parser RevokeKeyOptions
-revokeKeyP =
- RevokeKeyOptions <$>
- switch (long "no-armor" <> help "output binary") <*>
- many
- (strOption
- (long "with-key-password" <>
- help "password for unlocking secret key material"))
-
-revokeUserIdP :: Parser RevokeUserIdOptions
-revokeUserIdP =
- RevokeUserIdOptions <$>
- argument str (metavar "USERID" <> help "user ID to revoke") <*>
- switch (long "no-armor" <> help "output binary")
-
-updateKeyP :: Parser UpdateKeyOptions
-updateKeyP =
- UpdateKeyOptions <$>
- switch (long "no-armor" <> help "output binary") <*>
- switch (long "signing-only" <> help "limit updated material to signing-capable key material") <*>
- switch (long "revoke-deprecated-keys" <> help "emit revocations for deprecated key material when supported") <*>
- switch (long "no-added-capabilities" <> help "do not add capabilities beyond existing target key material") <*>
- many
- (strOption
- (long "with-key-password" <>
- help "password for unlocking key material")) <*>
- many
- (strOption
- (long "merge-certs" <>
- metavar "CERTS" <> help "additional certificate files to merge into target keys"))
-
-changeKeyPasswordP :: Parser ChangeKeyPasswordOptions
-changeKeyPasswordP =
- ChangeKeyPasswordOptions <$>
- switch (long "no-armor" <> help "output binary") <*>
- many
- (strOption
- (long "old-key-password" <>
- help "password(s) used to unlock existing secret key material")) <*>
- many
- (strOption
- (long "new-key-password" <>
- help "password used to protect rewritten secret key material"))
-
-dispatch :: POSIXTime -> Command -> IO ()
-dispatch cpt o = banner' stderr >> hFlush stderr >> dispatch' cpt o
- where
- dispatch' _ (VersionC o') = doVersion o'
- dispatch' _ (ListProfilesC o') = doListProfiles o'
- dispatch' t (GenerateKeyC o) = doGenerateKey t o
- dispatch' _ (ChangeKeyPasswordC o) = doChangeKeyPassword o
- dispatch' _ (MergeCertsC o) = doMergeCerts o
- dispatch' t (ValidateUserIdC o) = doValidateUserId t o
- dispatch' t (CertifyUserIdC o) = doCertifyUserId t o
- dispatch' t (RevokeKeyC o) = doRevokeKey t o
- dispatch' t (RevokeUserIdC o) = doRevokeUserId t o
- dispatch' t (UpdateKeyC o) = doUpdateKey t o
- dispatch' t (VerifyC o') = doVerify t o'
- dispatch' t (InlineVerifyC o') = doInlineVerify t o'
- dispatch' t (EncryptC o') = doEncrypt t o'
- dispatch' t (DecryptC o') = doDecrypt t o'
- dispatch' t (InlineSignC o') = doInlineSign t o'
- dispatch' t (InlineDetachC o') = doInlineDetach t o'
- dispatch' _ (ExtractCertC o) = doExtractCert o
- dispatch' t (SignC o) = doSign t o
- dispatch' _ (UnsupportedC c) =
- failWith UnsupportedSubcommand ("command not yet implemented: " ++ c)
- dispatch' _ DeArmorC = doDeArmor
- dispatch' _ (ArmorC o) = doArmor o
-
-main :: IO ()
-main = do
- hSetBuffering stderr LineBuffering
- args <- getArgs
- ensureKnownSubcommand knownSopSubcommands args
- cpt <- getPOSIXTime
- CliOptions {..} <-
- customExecParser
- (prefs showHelpOnError)
- (info
- (helper <*> versioner "hop" <*> cliP)
- (headerDoc (Just (banner "hop")) <>
- progDesc "hOpenPGP Validator Tool" <>
- footerDoc (Just (warranty "hop"))))
- let _ = cliDebug
- dispatch cpt cliCommand
-
-knownSopSubcommands :: [String]
-knownSopSubcommands =
- [ "armor"
- , "dearmor"
- , "change-key-password"
- , "decrypt"
- , "encrypt"
- , "certify-userid"
- , "extract-cert"
- , "generate-key"
- , "inline-detach"
- , "inline-sign"
- , "inline-verify"
- , "list-profiles"
- , "merge-certs"
- , "revoke-key"
- , "revoke-userid"
- , "sign"
- , "update-key"
- , "validate-userid"
- , "verify"
- , "version"
- ]
-
-ensureKnownSubcommand :: [String] -> [String] -> IO ()
-ensureKnownSubcommand knownSubcommands args =
- if any (`elem` ["-h", "--help", "--version"]) args
- then pure ()
- else
- case find (not . isPrefixOf "-") args of
- Just subcommand
- | subcommand `notElem` knownSubcommands ->
- failWith UnsupportedSubcommand ("unsupported subcommand: " ++ subcommand)
- _ -> pure ()
-
-cliP :: Parser CliOptions
-cliP =
- CliOptions <$>
- switch (long "debug" <> help "emit more verbose output") <*>
- cmd
-
-banner' :: Handle -> IO ()
-banner' h = hPutDoc h (banner "hop" <> hardline <> warranty "hop" <> hardline)
-
-data Vrf =
- Vrf
- { _vrfmsg :: String
- , _vrfmfpr :: Maybe Fingerprint
- }
- deriving (Eq, Generic, Show)
-
-instance A.ToJSON Vrf
-
-doV :: POSIXTime -> Options -> IO ()
-doV cpt o = do
- krs <- loadVerifyKeyringMap cpt (keyrings o)
- sigs <-
- runConduitRes $
- CC.sourceFile (sigFile o) .| conduitGet Bin.get .| CC.filter v4b .|
- CC.sinkVector
- blob <- runConduitRes $ CC.sourceFile (blobFile o) .| CC.sinkLazy
- verifications <-
- runConduitRes $
- CC.yieldMany (V.cons (LiteralDataPkt BinaryData mempty 0 blob) sigs) .|
- conduitVerify krs Nothing .|
- CC.sinkList
- let verifications' = map v2v verifications
- case outputFormat o of
- Unstructured -> mapM_ print verifications'
- JSON -> BL.putStr . A.encode $ verifications'
- YAML -> B.putStr . Y.encode $ verifications'
- putStrLn ""
- case any isRight verifications of
- True -> exitSuccess
- _ -> exitFailure
- where
- v4b (SignaturePkt s@(SigV4 BinarySig _ _ _ _ _ _)) = sf s
- v4b _ = False
- v2v (Left l) = Vrf (show l) Nothing
- v2v (Right v) =
- Vrf "verified signature" (Just (fingerprint (_verificationSigner v)))
- sf = const True
-
-cmd :: Parser Command
-cmd =
- hsubparser
- (command "armor" (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout")) <>
- command "dearmor" (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout")) <>
- command
- "change-key-password"
- (info (ChangeKeyPasswordC <$> changeKeyPasswordP) (progDesc "Update a key password")) <>
- command "decrypt" (info (DecryptC <$> decP) (progDesc "Decrypt a message")) <>
- command "encrypt" (info (EncryptC <$> encP) (progDesc "Encrypt a message")) <>
- command
- "certify-userid"
- (info (CertifyUserIdC <$> certifyUserIdP) (progDesc "Certify user IDs in a certificate")) <>
- command "extract-cert" (info (ExtractCertC <$> ecoP) (progDesc "Extract a certificate from a secret key and output it to stdout")) <>
- command "generate-key" (info (GenerateKeyC <$> gkoP) (progDesc "Generate a secret key and output it to stdout")) <>
- command "inline-detach" (info (InlineDetachC <$> inlineDetachP) (progDesc "Create inline detached signatures")) <>
- command "inline-sign" (info (InlineSignC <$> inlineSignP) (progDesc "Create inline signatures")) <>
- command "inline-verify" (info (InlineVerifyC <$> ivoP) (progDesc "Verify inline-signed data")) <>
- command "list-profiles" (info (ListProfilesC <$> lpoP) (progDesc "List SOP profiles")) <>
- command
- "merge-certs"
- (info (MergeCertsC <$> mergeCertsP) (progDesc "Merge OpenPGP certificates")) <>
- command
- "revoke-key"
- (info (RevokeKeyC <$> revokeKeyP) (progDesc "Create a key revocation certificate")) <>
- command
- "revoke-userid"
- (info (RevokeUserIdC <$> revokeUserIdP) (progDesc "Revoke a user ID")) <>
- command "sign" (info (SignC <$> soP) (progDesc "Create detached signatures and output them to stdout")) <>
- command
- "update-key"
- (info (UpdateKeyC <$> updateKeyP) (progDesc "Update key material")) <>
- command
- "validate-userid"
- (info (ValidateUserIdC <$> validateUserIdP) (progDesc "Validate a certificate user ID")) <>
- command "verify" (info (VerifyC <$> voP) (progDesc "Verify signatures")) <>
- command "version" (info (VersionC <$> vopP) (progDesc "output hop version to stdout")))
-
-armorTypes :: [(String, Maybe ArmorType)]
-armorTypes =
- [ ("auto", Nothing)
- , ("sig", Just ArmorSignature)
- , ("key", Just ArmorPrivateKeyBlock)
- , ("cert", Just ArmorPublicKeyBlock)
- , ("message", Just ArmorMessage)
- ]
-
-armorTypeReader :: String -> Either String (Maybe ArmorType)
-armorTypeReader = note "unknown armor type" . flip lookup armorTypes
-
-aoP :: Parser ArmoringOptions
-aoP =
- ArmoringOptions <$>
- option
- (eitherReader armorTypeReader)
- (long "label" <> metavar "LABEL" <> armortypeHelp) <*>
- switch
- (long "allow-nested" <>
- help "do the sane thing and unconditionally armor the output")
- where
- armortypeHelp =
- helpDoc . Just $
- pretty "ASCII armor type" <>
- softline <> list (map (pretty . fst) armorTypes)
-
-data ArmoringOptions =
- ArmoringOptions
- { label :: Maybe ArmorType
- , allowNested :: Bool
- }
-
-doArmor :: ArmoringOptions -> IO ()
-doArmor ArmoringOptions {..} = do
- m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
- let lbs = BL.fromChunks m
- armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs
- label' = guessLabel label (decodeFirstPacket lbs)
- a = Armor label' [] lbs
- BL.putStr $
- if armoredAlready && not allowNested
- then lbs
- else AA.encodeLazy [a]
- where
- decodeFirstPacket = runGet Bin.get
- -- UPSTREAM: openpgp-asciiarmor should export selectArmorType helper
- -- to eliminate this pattern-matching boilerplate
- guessLabel (Just l) _ = l
- guessLabel Nothing (SignaturePkt _) = ArmorSignature
- guessLabel Nothing (SecretKeyPkt _ _) = ArmorPrivateKeyBlock
- guessLabel Nothing (PublicKeyPkt _) = ArmorPublicKeyBlock
- guessLabel Nothing _ = ArmorMessage
-
-doVersion :: VersionOptions -> IO ()
-doVersion VersionOptions {..} = do
- let selected = length (filter id [vBackend, vExtended, vSopSpec, vSopv])
- when (selected > 1) $
- failWith
- IncompatibleOptions
- "version: --backend, --extended, --sop-spec, and --sopv are mutually exclusive"
- putStrLn $ "hop " ++ showVersion version
- when vBackend $ putStrLn "backend: hOpenPGP"
- when vExtended $ putStrLn "extended: yes"
- when vSopSpec $ putStrLn "spec: draft-dkg-openpgp-stateless-cli-16"
- when vSopv $ putStrLn "sopv: 1.0"
-
-gkoP :: Parser KeyGenOptions
-gkoP =
- KeyGenOptions <$> switch (long "armor" <> help "armor the output") <*>
- switch (long "no-armor" <> help "don't armor the output") <*>
- many
- (strOption
- (long "with-key-password" <>
- help "password used to protect generated secret key material")) <*>
- optional
- (strOption
- (long "profile" <>
- metavar "PROFILE" <> help "key generation profile (default, rfc4880, compatibility, security, performance)")) <*>
- switch (long "signing-only" <> help "generate signing-only key material") <*>
- many (strArgument (metavar "USERID" <> help "User ID associated with this key"))
-
-data KeyGenOptions =
- KeyGenOptions
- { armor :: Bool
- , noArmor :: Bool
- , keyPasswords :: [String]
- , keyProfile :: Maybe String
- , keySigningOnly :: Bool
- , userIds :: [String]
- }
-
-doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()
-doGenerateKey pt KeyGenOptions {..} = do
- when (armor && noArmor) $
- failWith
- IncompatibleOptions
- "generate-key: --armor and --no-armor are mutually exclusive"
- baseProfile <- parseKeyGenProfile keyProfile
- let profile =
- if keySigningOnly
- then KeyGenSigningOnly
- else baseProfile
- password <- parseGenerateKeyPassword keyPasswords
- let ts = ThirtyTwoBitTimeStamp (floor pt)
- -- UPSTREAM: hOpenPGP should expose a supported legacy secret-key
- -- re-encryption path so password-protected v4 key generation does not
- -- need to switch to the v6 protection format here.
- keyVersion =
- if isJust password && keyVersionForProfile profile == V4
- then V6
- else keyVersionForProfile profile
- primaryKeySpec = primaryKeySpecForProfile profile
- sk <- generateSecretKey ts keyVersion primaryKeySpec
- baseKey <-
- buildKeyWith sk $ do
- case userIds of
- (primaryUid:restUids) -> do
- addUserId ts True (T.pack primaryUid)
- mapM_ (addUserId ts False . T.pack) restUids
- [] -> pure ()
- addSubkeysForProfile ts keyVersion profile
- newkey <- get
- return newkey
- s <- maybe (pure baseKey) (`encryptTransferableSecretKey` baseKey) password
- let lbs = runPut $ Bin.put s
- BL.putStr $
- if not armor && not noArmor
- then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]
- else lbs
-
-type KeyBuilder = StateT TKUnknown IO
-
-buildKeyWith :: SecretKey -> KeyBuilder a -> IO a
-buildKeyWith sk a = evalStateT a (bareTK sk)
- where
- bareTK (SecretKey pkp ska) = TKUnknown (pkp, Just ska) [] [] [] []
-
-data GeneratedKeySpec
- = GeneratedRSAKey Int
- | GeneratedEd25519Key
- | GeneratedX25519Key
- deriving (Eq)
-
-generateSecretKey :: ThirtyTwoBitTimeStamp -> KeyVersion -> GeneratedKeySpec -> IO SecretKey
-generateSecretKey ts keyVersion (GeneratedRSAKey bits) = do
- (pub, priv) <- liftIO $ RSA.generate bits 0x10001
- return $ SecretKey (pkp pub) (ska priv)
- where
- pkp pub = PKPayload keyVersion ts 0 RSA (RSAPubKey (RSA_PublicKey pub))
- ska priv = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey priv)) 0 -- FIXME: calculate checksum
-generateSecretKey ts keyVersion GeneratedEd25519Key = do
- priv <- Ed25519.generateSecretKey
- let pub = Ed25519.toPublic priv
- pubBytes = BA.convert pub :: B.ByteString
- privBytes = BA.convert priv :: B.ByteString
- pure $
- SecretKey
- (PKPayload
- keyVersion
- ts
- 0
- (toFVal 27)
- (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes)))))
- (SUUnencrypted (EdDSAPrivateKey Ed25519 privBytes) 0)
-generateSecretKey ts keyVersion GeneratedX25519Key = do
- priv <- Curve25519.generateSecretKey
- let pub = Curve25519.toPublic priv
- pubBytes = BA.convert pub :: B.ByteString
- privBytes = BA.convert priv :: B.ByteString
- pure $
- SecretKey
- (PKPayload
- keyVersion
- ts
- 0
- X25519
- (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes)))))
- (SUUnencrypted (X25519PrivateKey privBytes) 0)
-
-data KeyGenProfile
- = KeyGenDefault
- | KeyGenRFC4880
- | KeyGenSecurity
- | KeyGenPerformance
- | KeyGenSigningOnly
- deriving (Eq)
-
-parseKeyGenProfile :: Maybe String -> IO KeyGenProfile
-parseKeyGenProfile Nothing = pure KeyGenDefault
-parseKeyGenProfile (Just "default") = pure KeyGenDefault
-parseKeyGenProfile (Just "rfc4880") = pure KeyGenRFC4880
-parseKeyGenProfile (Just "compatibility") = pure KeyGenRFC4880
-parseKeyGenProfile (Just "security") = pure KeyGenSecurity
-parseKeyGenProfile (Just "performance") = pure KeyGenPerformance
-parseKeyGenProfile (Just profile) =
- failWith
- UnsupportedProfile
- ("generate-key: unsupported profile " ++ profile)
-
-keyVersionForProfile :: KeyGenProfile -> KeyVersion
-keyVersionForProfile KeyGenDefault = V6
-keyVersionForProfile KeyGenRFC4880 = V4
-keyVersionForProfile KeyGenSecurity = V6
-keyVersionForProfile KeyGenPerformance = V6
-keyVersionForProfile KeyGenSigningOnly = V6
-
-primaryKeySpecForProfile :: KeyGenProfile -> GeneratedKeySpec
-primaryKeySpecForProfile KeyGenRFC4880 = GeneratedRSAKey 4096
-primaryKeySpecForProfile _ = GeneratedEd25519Key
-
-parseGenerateKeyPassword :: [String] -> IO (Maybe BL.ByteString)
-parseGenerateKeyPassword [] = pure Nothing
-parseGenerateKeyPassword [passwordFile] =
- Just <$>
- (loadPasswordFromFile "generate-key" "--with-key-password" passwordFile >>=
- normalizeHumanReadablePassword "generate-key" "--with-key-password")
-parseGenerateKeyPassword _ =
- failWith
- UnsupportedOption
- "generate-key: multiple --with-key-password values are not supported"
-
-loadPasswordFiles :: String -> String -> [String] -> IO [BL.ByteString]
-loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName)
-
-loadPasswordFromFile :: String -> String -> FilePath -> IO BL.ByteString
-loadPasswordFromFile context optionName path = do
- case stripPrefix "@ENV:" path of
- Just varName
- | null varName ->
- failWith
- BadData
- (context ++ ": empty environment variable name in " ++ optionName)
- | otherwise -> do
- envValue <- lookupEnv varName
- case envValue of
- Nothing ->
- failWith
- MissingInput
- (context ++ ": environment variable not found for " ++ optionName ++ ": " ++ varName)
- Just value -> pure (BLC8.pack value)
- Nothing ->
- case stripPrefix "@FD:" path of
- Just fdSpec -> loadPasswordFromFD context optionName fdSpec
- Nothing ->
- case path of
- '@':_ ->
- failWith
- UnsupportedSpecialPrefix
- (context ++ ": unsupported special prefix for " ++ optionName ++ ": " ++ path)
- _ -> do
- exists <- doesFileExist path
- unless exists $
- failWith
- MissingInput
- (context ++ ": password file does not exist for " ++ optionName ++ ": " ++ path)
- BL.readFile path
-
-loadPasswordFromFD :: String -> String -> String -> IO BL.ByteString
-loadPasswordFromFD context optionName fdSpec =
- case readMaybe fdSpec :: Maybe Int of
- Just fdNum
- | fdNum >= 0 ->
- (do
- let fdPath = "/dev/fd/" ++ show fdNum
- exists <- doesFileExist fdPath
- unless exists $
- failWith
- MissingInput
- (context ++ ": file descriptor not available for " ++ optionName ++ ": " ++ fdSpec)
- contents <- BL.readFile fdPath
- _ <- evaluate (BL.length contents)
- pure contents)
- `catch`
- (\err ->
- failWith
- MissingInput
- (context ++ ": failed reading file descriptor for " ++ optionName ++
- ": " ++ fdSpec ++ " (" ++ displayException (err :: IOException) ++ ")"))
- | otherwise ->
- failWith
- BadData
- (context ++ ": invalid file descriptor in " ++ optionName ++ ": " ++ fdSpec)
- _ ->
- failWith
- BadData
- (context ++ ": invalid file descriptor in " ++ optionName ++ ": " ++ fdSpec)
-
-normalizeHumanReadablePassword :: String -> String -> BL.ByteString -> IO BL.ByteString
-normalizeHumanReadablePassword context optionName passwordBytes =
- case TE.decodeUtf8' (BL.toStrict passwordBytes) of
- Left _ ->
- failWith
- PasswordNotHumanReadable
- (context ++ ": password is not human-readable UTF-8 for " ++ optionName)
- Right txt ->
- pure
- (BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt)))
-
-passwordRetryCandidates :: BL.ByteString -> [BL.ByteString]
-passwordRetryCandidates passwordBytes =
- case TE.decodeUtf8' (BL.toStrict passwordBytes) of
- Left _ -> [passwordBytes]
- Right txt ->
- let trimmed = BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt))
- in if trimmed == passwordBytes
- then [passwordBytes]
- else [passwordBytes, trimmed]
-
-addSubkeysForProfile :: ThirtyTwoBitTimeStamp -> KeyVersion -> KeyGenProfile -> KeyBuilder ()
-addSubkeysForProfile ts keyVersion profile =
- case profile of
- KeyGenSigningOnly ->
- addSubkey ts keyVersion profile [SignDataKey]
- _ -> do
- addSubkey ts keyVersion profile [EncryptStorageKey, EncryptCommunicationsKey]
- addSubkey ts keyVersion profile [SignDataKey]
- addSubkey ts keyVersion profile [AuthKey]
-
-subkeySpecForProfile :: KeyGenProfile -> [KeyFlag] -> GeneratedKeySpec
-subkeySpecForProfile KeyGenRFC4880 _ = GeneratedRSAKey 4096
-subkeySpecForProfile _ keyflags
- | any (`elem` keyflags) [EncryptStorageKey, EncryptCommunicationsKey] = GeneratedX25519Key
- | otherwise = GeneratedEd25519Key
-
-encryptTransferableSecretKey :: BL.ByteString -> TKUnknown -> IO TKUnknown
-encryptTransferableSecretKey password tk = do
- keyPair' <- encryptKeyPair (_tkuKey tk)
- subs' <- mapM encryptSub (_tkuSubs tk)
- pure tk {_tkuKey = keyPair', _tkuSubs = subs'}
- where
- encryptKeyPair (pkp, Just ska) = do
- encrypted <- encryptSecretAddendumForOutput pkp ska
- pure (pkp, Just encrypted)
- encryptKeyPair keyPair = pure keyPair
- encryptSub (SecretSubkeyPkt pkp ska, sigs) = do
- encrypted <- encryptSecretAddendumForOutput pkp ska
- pure (SecretSubkeyPkt pkp encrypted, sigs)
- encryptSub sub = pure sub
- encryptSecretAddendumForOutput pkp ska =
- case ska of
- SUUnencrypted {} -> doEncrypt
- _ -> pure ska
- where
- doEncrypt = do
- encryptedResult <- encryptPrivateKey defaultPolicy pkp ska password
- case encryptedResult of
- Left err ->
- failWith BadData ("generate-key: failed to protect secret key material: " ++ err)
- Right value -> pure value
-
-rsaSigningKey :: SKAddendum -> IO RSA.PrivateKey
-rsaSigningKey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) =
- pure (k {RSA.private_p = 0, RSA.private_q = 0})
-rsaSigningKey _ =
- failWith
- BadData
- "generate-key: unsupported secret key format for RSA signing"
-
-issuerSubpacketsFor :: String -> SomePKPayload -> IO [SigSubPacket]
-issuerSubpacketsFor context pkp =
- case _keyVersion pkp of
- V6 -> pure []
- _ ->
- case eightOctetKeyID pkp of
- Left err ->
- failWith
- BadData
- (context ++ ": could not derive issuer key id: " ++ show err)
- Right keyId -> pure [SigSubPacket False (Issuer keyId)]
-
-issuerSubpacketFor :: String -> SomePKPayload -> IO SigSubPacket
-issuerSubpacketFor context pkp = do
- packets <- issuerSubpacketsFor context pkp
- case packets of
- [packet] -> pure packet
- [] ->
- failWith
- BadData
- (context ++ ": no legacy issuer key id is available for this key")
- _ -> failWith BadData (context ++ ": unexpected issuer subpacket count")
-
-addUserId :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()
-addUserId ts primary userid = do
- tk <- get
- signed <- selfsign (_tkuKey tk) userid
- modify (newUID signed)
- where
- newUID signed tk = tk {_tkuUIDs = _tkuUIDs tk ++ [signed]}
- selfsign (pkp, Just ska) u = do
- issuer <- liftIO (unhashed pkp)
- sig <-
- liftIO $
- signWithKey
- "generate-key"
- pkp
- PositiveCert
- SHA512
- (hashed pkp)
- issuer
- (userIdPayloadForSigning pkp (UserId u))
- (Just ska)
- pure (u, [sig])
- selfsign _ _ =
- liftIO $
- failWith BadData "generate-key: primary key is missing secret key material"
- hashed pkp =
- [ SigSubPacket False (SigCreationTime ts)
- , SigSubPacket
- False
- (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))
- , SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey))
- , SigSubPacket False (PrimaryUserId primary)
- , SigSubPacket
- False
- (PreferredHashAlgorithms [SHA512, SHA256, SHA384, SHA224])
- , SigSubPacket
- False
- (PreferredSymmetricAlgorithms [AES256, AES192, AES128])
- ]
- unhashed = issuerSubpacketsFor "generate-key"
-
-addSubkey :: ThirtyTwoBitTimeStamp -> KeyVersion -> KeyGenProfile -> [KeyFlag] -> KeyBuilder ()
-addSubkey ts keyVersion profile keyflags = do
- tk <- get
- (SecretKey subpkp subska) <-
- liftIO $
- generateSecretKey ts keyVersion (subkeySpecForProfile profile keyflags)
- (pkp, ska) <-
- case _tkuKey tk of
- (primaryPkp, Just primarySka) -> pure (primaryPkp, primarySka)
- _ ->
- liftIO $
- failWith
- BadData
- "generate-key: primary key is missing secret key material"
- issuerPrimary <- liftIO (unhashed pkp)
- issuerSub <- liftIO (unhashed subpkp)
- embeddedBacksig <-
- if SignDataKey `elem` keyflags
- then
- Just <$>
- liftIO
- (signWithKey
- "generate-key"
- subpkp
- PrimaryKeyBindingSig
- SHA512
- (hashed subpkp)
- issuerSub
- (subkeyPayloadForSigning pkp subpkp)
- (Just subska))
- else pure Nothing
- bindingSig <-
- liftIO $
- signWithKey
- "generate-key"
- pkp
- SubkeyBindingSig
- SHA512
- (hashedwithflags pkp)
- (maybe issuerPrimary (\sig -> SigSubPacket False (EmbeddedSignature sig) : issuerPrimary) embeddedBacksig)
- (subkeyPayloadForSigning pkp subpkp)
- (Just ska)
- modify (addIt subpkp subska bindingSig)
- where
- addIt sp ss binding tk =
- tk {_tkuSubs = _tkuSubs tk ++ [(SecretSubkeyPkt sp ss, [binding])]}
- hashed pkp =
- [ SigSubPacket False (SigCreationTime ts)
- , SigSubPacket
- False
- (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))
- ]
- hashedwithflags pkp =
- hashed pkp ++ [SigSubPacket False (KeyFlags (S.fromList keyflags))]
- unhashed = issuerSubpacketsFor "generate-key"
-
-putKeyForSigning :: SomePKPayload -> Bin.Put
-putKeyForSigning pkp@(PKPayload V6 _ _ _ _) = do
- putWord8 0x9A
- let bs = runPut (Bin.put pkp)
- putWord32be (fromIntegral (BL.length bs))
- putLazyByteString bs
-putKeyForSigning pkp = do
- putWord8 0x99
- let bs = runPut (Bin.put pkp)
- putWord16be (fromIntegral (BL.length bs))
- putLazyByteString bs
-
-putUserIdForSigning :: UserId -> Bin.Put
-putUserIdForSigning (UserId u) = do
- let bs = TE.encodeUtf8 u
- putWord8 0xB4
- putWord32be (fromIntegral (B.length bs))
- putByteString bs
-
-userIdPayloadForSigning :: SomePKPayload -> UserId -> BL.ByteString
-userIdPayloadForSigning pkp uid =
- runPut $ do
- putKeyForSigning pkp
- putUserIdForSigning uid
-
-subkeyPayloadForSigning :: SomePKPayload -> SomePKPayload -> BL.ByteString
-subkeyPayloadForSigning primary sub =
- runPut $ do
- putKeyForSigning primary
- putKeyForSigning sub
-
-issuerFingerprintVersionFor :: SomePKPayload -> IssuerFingerprintVersion
-issuerFingerprintVersionFor pkp =
- case _keyVersion pkp of
- V6 -> IssuerFingerprintV6
- _ -> IssuerFingerprintV4
-
-ecoP :: Parser ExtractCertOptions
-ecoP =
- ExtractCertOptions <$> switch (long "armor" <> help "armor the output") <*>
- switch (long "no-armor" <> help "don't armor the output")
-
-data ExtractCertOptions =
- ExtractCertOptions
- { ecArmor :: Bool
- , ecNoArmor :: Bool
- }
-
-doExtractCert :: ExtractCertOptions -> IO ()
-doExtractCert ExtractCertOptions {..} = do
- kbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
- let lbs = BL.fromChunks kbs
- pkts <- decodeOpenPGPInput "stdin" lbs
- tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| CC.sinkList
- when (null tks) $
- failWith
- MissingInput
- "extract-cert: no transferable secret key found on standard input"
- let output = runPut $ mapM_ (Bin.put . pubToSecret) tks
- BL.putStr $
- if not ecArmor && not ecNoArmor
- then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
- else output
- where
- pubToSecret tk =
- tk {_tkuKey = pToS (_tkuKey tk), _tkuSubs = map subPToS (_tkuSubs tk)}
- pToS (pkp, _) = (pkp, Nothing)
- subPToS (SecretSubkeyPkt pkp _, sigs) = (PublicSubkeyPkt pkp, sigs)
- subPToS (PublicSubkeyPkt pkp, sigs) = (PublicSubkeyPkt pkp, sigs)
- subPToS x = x
-
-doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()
-doChangeKeyPassword ChangeKeyPasswordOptions {..} = do
- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- packets <- decodeOpenPGPInput "stdin" input
- tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| CC.sinkList
- when (null tks) $
- failWith
- MissingInput
- "change-key-password: no transferable secret key found on standard input"
- when (any (not . hasSecretKeyMaterial) tks) $
- failWith
- MissingInput
- "change-key-password: expected transferable secret key input on standard input"
- oldPasswordsRaw <-
- loadPasswordFiles "change-key-password" "--old-key-password" changeKeyPasswordOldPasswords
- let oldPasswords = concatMap passwordRetryCandidates oldPasswordsRaw
- newPassword <- parseChangeKeyPasswordNewPassword changeKeyPasswordNewPasswords
- unlockedTks <-
- mapM
- (unlockTransferableSecretKeyMaterial
- "change-key-password"
- "standard input"
- "--old-key-password"
- oldPasswords)
- tks
- rewrittenTks <-
- case newPassword of
- Just password -> mapM (encryptTransferableSecretKey password) unlockedTks
- Nothing -> pure unlockedTks
- let output = runPut (mapM_ Bin.put rewrittenTks)
- BL.putStr $
- if changeKeyPasswordNoArmor || BL.null output
- then output
- else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]
-
-parseChangeKeyPasswordNewPassword :: [String] -> IO (Maybe BL.ByteString)
-parseChangeKeyPasswordNewPassword [] = pure Nothing
-parseChangeKeyPasswordNewPassword [passwordFile] =
- Just <$>
- (loadPasswordFromFile "change-key-password" "--new-key-password" passwordFile >>=
- normalizeHumanReadablePassword "change-key-password" "--new-key-password")
-parseChangeKeyPasswordNewPassword _ =
- failWith
- UnsupportedOption
- "change-key-password: multiple --new-key-password values are not supported"
-
-hasSecretKeyMaterial :: TKUnknown -> Bool
-hasSecretKeyMaterial tk =
- case _tkuKey tk of
- (_, Just _) -> True
- _ -> any isSecretSubkeyPkt (_tkuSubs tk)
- where
- isSecretSubkeyPkt (SecretSubkeyPkt _ _, _) = True
- isSecretSubkeyPkt _ = False
-
-doValidateUserId :: POSIXTime -> ValidateUserIdOptions -> IO ()
-doValidateUserId cpt ValidateUserIdOptions {..} = do
- authorityTks <- concat <$> mapM (loadCertTKsFromFile "validate-userid") validateUserIdAuthorityFiles
- validateAtTime <- verificationUpperBound cpt validateUserIdAt
- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- certPkts <- decodeOpenPGPInput "standard input" input
- certTks <- runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| CC.sinkList
- when (null certTks) $
- failWith MissingInput "validate-userid: no certificate found on standard input"
- let targetUserId = T.pack validateUserIdString
- forM_ certTks $ \certTk ->
- when
- (not
- (certificateHasMatchingValidatedUserId
- authorityTks
- validateAtTime
- validateUserIdAddrSpecOnly
- targetUserId
- certTk)) $
- failWith
- CertUserIdNoMatch
- ("validate-userid: certificate has no correctly bound user ID matching " ++
- validateUserIdString)
-
-certificateHasMatchingValidatedUserId ::
- [TKUnknown] -> Maybe UTCTime -> Bool -> Text -> TKUnknown -> Bool
-certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =
- case verifyUnknownTKWith verifier validateAtTime certTk of
- Left _ -> False
- Right verifiedTk -> any matchingBoundUid (_tkuUIDs verifiedTk)
- where
- verifier = verifySigWith (verifyAgainstKeys (certTk : authorityTks))
- matchingBoundUid (uid, sigs) =
- useridMatches addrSpecOnly targetUserId uid &&
- any (signatureMatchesSigner certTk) sigs &&
- any (\sig -> any (`signatureMatchesSigner` sig) authorityTks) sigs
-
-useridMatches :: Bool -> Text -> Text -> Bool
-useridMatches False targetUserId uid = uid == targetUserId
-useridMatches True targetUserId uid =
- case conventionalAddrSpec uid of
- Just addrSpec -> addrSpec == targetUserId
- Nothing -> False
-
-conventionalAddrSpec :: Text -> Maybe Text
-conventionalAddrSpec uid =
- let (prefix, suffix) = T.breakOnEnd (T.pack "<") uid
- in if T.null prefix
- then Nothing
- else case T.unsnoc suffix of
- Just (addrSpec, '>')
- | T.any (== '<') addrSpec -> Nothing
- | otherwise -> guardNonEmpty (T.strip addrSpec)
- _ -> Nothing
- where
- guardNonEmpty text
- | T.null text = Nothing
- | otherwise = Just text
-
-signatureMatchesSigner :: TKUnknown -> SignaturePayload -> Bool
-signatureMatchesSigner signer sig =
- maybe False (keyMatchesFingerprint False signer) (signatureIssuerFingerprint sig) ||
- maybe False (keyMatchesEightOctetKeyId False signer . Right) (signatureIssuerKeyId sig)
-
-signatureIssuerFingerprint :: SignaturePayload -> Maybe Fingerprint
-signatureIssuerFingerprint = listToMaybe . mapMaybe getIssuerFingerprint . signatureSubpackets
- where
- getIssuerFingerprint (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) =
- Just issuerFingerprint
- getIssuerFingerprint _ = Nothing
-
-signatureIssuerKeyId :: SignaturePayload -> Maybe EightOctetKeyId
-signatureIssuerKeyId = listToMaybe . mapMaybe getIssuerKeyId . signatureSubpackets
- where
- getIssuerKeyId (SigSubPacket _ (Issuer issuerKeyId)) = Just issuerKeyId
- getIssuerKeyId _ = Nothing
-
-signatureSubpackets :: SignaturePayload -> [SigSubPacket]
-signatureSubpackets (SigV4 _ _ _ hashed unhashed _ _) = hashed ++ unhashed
-signatureSubpackets (SigV6 _ _ _ _ hashed unhashed _ _) = hashed ++ unhashed
-signatureSubpackets _ = []
-
-doCertifyUserId :: POSIXTime -> CertifyUserIdOptions -> IO ()
-doCertifyUserId cpt CertifyUserIdOptions {..} = do
- signerPasswordsRaw <- loadPasswordFiles "certify-userid" "--with-key-password" certifyUserIdKeyPasswordFiles
- let signerPasswords = concatMap passwordRetryCandidates signerPasswordsRaw
- signerTks <- concat <$> mapM (loadCertifySignerTKsFromFile signerPasswords) certifyUserIdSignerFiles
- when (null signerTks) $
- failWith MissingInput "certify-userid: no signer certificate found"
- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- certPkts <- decodeOpenPGPInput "standard input" input
- targetTks <- runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| CC.sinkList
- when (null targetTks) $
- failWith MissingInput "certify-userid: no certificate found on standard input"
- let targetUserIds = map T.pack certifyUserIds
- requireSelfSig = not certifyUserIdNoRequireSelfSig
- updatedTargets <-
- mapM
- (\targetTk -> addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks)
- targetTks
- let output = runPut (mapM_ Bin.put updatedTargets)
- armorOutput =
- case certifyUserIdOutputFormat of
- Just "binary" -> output
- _ -> AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
- BL.putStr armorOutput
-
-loadCertifySignerTKsFromFile :: [BL.ByteString] -> String -> IO [TKUnknown]
-loadCertifySignerTKsFromFile signerPasswords path = do
- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
- packets <- decodeOpenPGPInput path lbs
- tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| CC.sinkList
- let fallbackTks = signingFallbackTKs packets
- when (null tks && null fallbackTks) $
- failWith MissingInput ("certify-userid: no signer key material found in " ++ path)
- mapM
- (unlockTransferableSecretKeyMaterial
- "certify-userid failed"
- path
- "--with-key-password"
- signerPasswords)
- (if null tks then fallbackTks else tks)
-
-addUserIdCertifications :: TKUnknown -> [Text] -> Bool -> [TKUnknown] -> IO TKUnknown
-addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do
- forM_ targetUserIds $ \targetUserId ->
- case find ((== targetUserId) . fst) (_tkuUIDs targetTk) of
- Nothing ->
- failWith
- CertUserIdNoMatch
- ("certify-userid: target certificate has no user ID matching " ++
- T.unpack targetUserId)
- Just (_, sigs) ->
- when (requireSelfSig && not (any (signatureMatchesSigner targetTk) sigs)) $
- failWith
- CertUserIdNoMatch
- ("certify-userid: target user ID has no self-signature: " ++
- T.unpack targetUserId)
- newSigs <-
- concat <$>
- forM
- signerTks
- (\signerTk ->
- forM
- targetUserIds
- (\targetUserId -> do
- sig <- createUIDCertification targetUserId signerTk
- pure (targetUserId, sig)))
- let updateUID (uid, sigs) =
- if uid `elem` targetUserIds
- then (uid, sigs ++ map snd (filter ((== uid) . fst) newSigs))
- else (uid, sigs)
- pure $ targetTk {_tkuUIDs = map updateUID (_tkuUIDs targetTk)}
-
-createUIDCertification :: Text -> TKUnknown -> IO SignaturePayload
-createUIDCertification targetUserId signerTk = do
- let (signerPkp, mSignerSka) = _tkuKey signerTk
- signerSka <-
- case mSignerSka of
- Just ska -> pure ska
- Nothing -> failWith KeyCannotCertify "certify-userid: signer certificate has no secret key material"
- signingKey <- rsaSigningKey signerSka
- issuer <- issuerSubpacketsFor "certify-userid" signerPkp
- let hashed = [SigSubPacket False (SigCreationTime (_timestamp signerPkp))]
- certification = signUserIDwithRSA signerPkp (UserId targetUserId) hashed issuer signingKey
- case certification of
- Left err -> failWith BadData ("certify-userid: failed to create certification: " ++ show err)
- Right sig -> pure sig
-
-doRevokeKey :: POSIXTime -> RevokeKeyOptions -> IO ()
-doRevokeKey cpt RevokeKeyOptions {..} = do
- keyPasswordsRaw <- loadPasswordFiles "revoke-key" "--with-key-password" revokeKeyPasswordFiles
- let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- keyPkts <- decodeOpenPGPInput "standard input" input
- keyTks <- runConduitRes $ CL.sourceList keyPkts .| conduitToTKsDropping .| CC.sinkList
- when (null keyTks) $
- failWith MissingInput "revoke-key: no key found on standard input"
- revocationSigPkts <- mapM (createKeyRevocation keyPasswords) keyTks
- let output = runPut (mapM_ Bin.put revocationSigPkts)
- BL.putStr $
- if revokeKeyNoArmor
- then output
- else AA.encodeLazy [Armor ArmorSignature [] output]
- where
- createKeyRevocation keyPasswords' keyTk = do
- unlockedTk <-
- unlockTransferableSecretKeyMaterial
- "revoke-key failed"
- "standard input"
- "--with-key-password"
- keyPasswords'
- keyTk
- let (pkp, mSka) = _tkuKey unlockedTk
- ska <-
- case mSka of
- Just s -> pure s
- Nothing -> failWith KeyCannotCertify "revoke-key: key has no secret key material"
- signingKey <- rsaSigningKey ska
- issuer <- issuerSubpacketsFor "revoke-key" pkp
- let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]
- revocation = signKeyRevocationWithRSA pkp hashed issuer signingKey
- case revocation of
- Left err -> failWith BadData ("revoke-key: failed to create revocation: " ++ show err)
- Right sig -> pure (SignaturePkt sig)
-
-doRevokeUserId :: POSIXTime -> RevokeUserIdOptions -> IO ()
-doRevokeUserId cpt RevokeUserIdOptions {..} = do
- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- keyPkts <- decodeOpenPGPInput "standard input" input
- keyTks <- runConduitRes $ CL.sourceList keyPkts .| conduitToTKsDropping .| CC.sinkList
- when (null keyTks) $
- failWith MissingInput "revoke-userid: no key found on standard input"
- let keyTk = head keyTks
- (pkp, mSka) = _tkuKey keyTk
- targetUserId = T.pack revokeUserIdString
- uidExists <-
- if any ((== targetUserId) . fst) (_tkuUIDs keyTk)
- then pure True
- else failWith MissingInput ("revoke-userid: key has no user ID matching " ++ revokeUserIdString)
- ska <-
- case mSka of
- Just s -> pure s
- Nothing -> failWith KeyCannotCertify "revoke-userid: key has no secret key material"
- signingKey <- rsaSigningKey ska
- issuer <- issuerSubpacketsFor "revoke-userid" pkp
- let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]
- revocation = signCertRevocationWithRSA pkp (UserId targetUserId) hashed issuer signingKey
- case revocation of
- Left err -> failWith BadData ("revoke-userid: failed to create revocation: " ++ show err)
- Right sig -> do
- let revocationSigPkt = SignaturePkt sig
- output = runPut (Bin.put revocationSigPkt)
- BL.putStr $
- if revokeUserIdNoArmor
- then output
- else AA.encodeLazy [Armor ArmorSignature [] output]
-
-doUpdateKey :: POSIXTime -> UpdateKeyOptions -> IO ()
-doUpdateKey cpt UpdateKeyOptions {..} = do
- keyPasswordsRaw <- loadPasswordFiles "update-key" "--with-key-password" updateKeyPasswordFiles
- let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
- when updateKeyRevokeDeprecatedKeys $
- hPutStrLn stderr
- "Warning: update-key: --revoke-deprecated-keys requested, but no deprecated-key detector is available; proceeding without synthetic revocations."
- stdinInput <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- stdinPkts <- decodeOpenPGPInput "stdin" stdinInput
- stdinTks <- runConduitRes $ CL.sourceList stdinPkts .| conduitToTKsDropping .| CC.sinkList
- when (null stdinTks) $
- failWith MissingInput "update-key: no key found on standard input"
- updateSourceTks <- concat <$> mapM loadVerifyTKsFromFile updateKeyMergeCerts
- when (null updateSourceTks) $
- failWith MissingInput "update-key: no update keys found"
- stdinUnlocked <- mapM (unlockUpdateKeyMaterial "standard input" keyPasswords) stdinTks
- updateUnlocked <- mapM (unlockUpdateKeyMaterial "update input" keyPasswords) updateSourceTks
- let updateTks =
- if updateKeySigningOnly
- then filter (updateKeyHasSigningCapability cpt) updateUnlocked
- else updateUnlocked
- when (updateKeySigningOnly && null updateTks) $
- failWith MissingInput "update-key: no signing-capable update keys found"
- let updatedTks =
- map
- (\targetTk ->
- foldl'
- (<>)
- targetTk
- (selectUpdateMergeInputs cpt updateKeyNoAddedCapabilities targetTk updateTks))
- stdinUnlocked
- -- Choose armor type based on whether updated key has secret material
- armorType = if any hasSecretKeyMaterial updatedTks
- then ArmorPrivateKeyBlock
- else ArmorPublicKeyBlock
- output = runPut (mapM_ Bin.put updatedTks)
- BL.putStr $
- if updateKeyNoArmor
- then output
- else AA.encodeLazy [Armor armorType [] output]
-
-doMergeCerts :: MergeCertsOptions -> IO ()
-doMergeCerts MergeCertsOptions {..} = do
- stdinInput <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- stdinPkts <- decodeOpenPGPInput "stdin" stdinInput
- stdinTks <- runConduitRes $ CL.sourceList stdinPkts .| conduitToTKsDropping .| CC.sinkList
- mergeInTks <- concat <$> mapM loadVerifyTKsFromFile mergeCertsFiles
- let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks
- output = runPut (mapM_ Bin.put mergedTks)
- BL.putStr $
- if mergeCertsNoArmor || BL.null output
- then output
- else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
-
-mergeCertificatesForOutput :: [TKUnknown] -> [TKUnknown] -> [TKUnknown]
-mergeCertificatesForOutput stdinTks mergeInTks =
- map mergeGroup (groupByPrimaryKey stdinTks)
- where
- -- Upstream could expose this as a dedicated helper over TKWithWireRep
- -- so downstreams can keep packet provenance while merging certs.
- mergeGroup (base, rest) =
- let primary = certificatePrimaryFingerprint base
- mergedStdin = foldl' (<>) base rest
- matchingMergeInputs =
- filter ((== primary) . certificatePrimaryFingerprint) mergeInTks
- in foldl' (<>) mergedStdin matchingMergeInputs
-
-groupByPrimaryKey :: [TKUnknown] -> [(TKUnknown, [TKUnknown])]
-groupByPrimaryKey [] = []
-groupByPrimaryKey (tk:rest) =
- let primary = certificatePrimaryFingerprint tk
- (samePrimary, differentPrimary) =
- partition ((== primary) . certificatePrimaryFingerprint) rest
- in (tk, samePrimary) : groupByPrimaryKey differentPrimary
-
-certificatePrimaryFingerprint :: TKUnknown -> B.ByteString
-certificatePrimaryFingerprint =
- BL.toStrict . unFingerprint . fingerprint . fst . _tkuKey
-
-unlockUpdateKeyMaterial :: String -> [BL.ByteString] -> TKUnknown -> IO TKUnknown
-unlockUpdateKeyMaterial _ [] tk = pure tk
-unlockUpdateKeyMaterial source keyPasswords tk =
- unlockTransferableSecretKeyMaterial
- "update-key failed"
- source
- "--with-key-password"
- keyPasswords
- tk
-
-updateKeyHasSigningCapability :: POSIXTime -> TKUnknown -> Bool
-updateKeyHasSigningCapability cpt tk =
- any
- (\funKey ->
- S.null (fkufs funKey) || S.member SignDataKey (fkufs funKey))
- (tkToFunKeysAt cpt tk)
-
-selectUpdateMergeInputs ::
- POSIXTime
- -> Bool
- -> TKUnknown
- -> [TKUnknown]
- -> [TKUnknown]
-selectUpdateMergeInputs cpt noAddedCaps targetTk updateTks =
- filteredByCaps
- where
- targetPrimary = certificatePrimaryFingerprint targetTk
- mergeCandidates =
- filter ((== targetPrimary) . certificatePrimaryFingerprint) updateTks
- targetCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt targetTk))
- addsCapabilities updateTk =
- let updateCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt updateTk))
- in not (S.null (updateCapabilities S.\\ targetCapabilities))
- filteredByCaps =
- if noAddedCaps
- then filter (not . addsCapabilities) mergeCandidates
- else mergeCandidates
-
-soP :: Parser SignOptions
-soP =
- SignOptions <$> switch (long "armor" <> help "armor the output") <*>
- switch (long "no-armor" <> help "don't armor the output") <*>
- optional
- (strOption
- (long "micalg-out" <>
- metavar "MICALG" <> help "write MIME micalg parameter value to file")) <*>
- many
- (strOption
- (long "with-key-password" <>
- help "password for unlocking signing key material")) <*>
- option
- (eitherReader asTypeReader)
- (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary) <*>
- some
- (strArgument
- (metavar "KEYS..." <>
- help "paths to at least one secret key, one key per filename"))
- where
- astypeHelp =
- helpDoc . Just $
- pretty "what to treat the input as" <>
- softline <> list (map (pretty . fst) asTypes)
-
-data SignOptions =
- SignOptions
- { sArmor :: Bool
- , sNoArmor :: Bool
- , sMicalgOut :: Maybe String
- , sKeyPasswords :: [String]
- , sAs :: AsBinaryText
- , sKeyFiles :: [String]
- }
-
-asTypes :: [(String, AsBinaryText)]
-asTypes = [("binary", AsBinary), ("text", AsText)]
-
-data AsBinaryText
- = AsBinary
- | AsText
- deriving (Eq)
-
-data InlineSignMode
- = InlineSignAsBinary
- | InlineSignAsText
- | InlineSignAsClearSigned
- deriving (Eq)
-
-data EncryptFor
- = EncryptForAny
- | EncryptForStorage
- | EncryptForCommunications
- deriving (Eq)
-
-asTypeReader :: String -> Either String AsBinaryText
-asTypeReader = note "unknown as type" . flip lookup asTypes
-
-encryptForReader :: String -> Either String EncryptFor
-encryptForReader "any" = Right EncryptForAny
-encryptForReader "storage" = Right EncryptForStorage
-encryptForReader "communications" = Right EncryptForCommunications
-encryptForReader _ =
- Left "encryption purpose must be one of: any, storage, communications"
-
-doSign :: POSIXTime -> SignOptions -> IO ()
-doSign pt SignOptions {..} = do
- when (sNoArmor && sArmor) $
- failWith IncompatibleOptions "sign: --armor and --no-armor are mutually exclusive"
- forM_ sMicalgOut (ensureOutputPathAvailable "sign")
- mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
- when (sAs == AsText) $
- ensureUTF8TextInput "sign" (BL.fromChunks mbs)
- forM_ sMicalgOut (\_ -> ensureCanonicalMIMETextInput (BL.fromChunks mbs))
- signingPasswordsRaw <- loadPasswordFiles "sign" "--with-key-password" sKeyPasswords
- let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw
- ks <- loadSigningKeys sKeyFiles signingPasswords
- let ts = ThirtyTwoBitTimeStamp (floor pt)
- payload' = BL.fromChunks mbs
- payload = payload'
- processedKeys <- mapM (normalizeSigningKey pt) ks
- let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys
- signingHash =
- selectSigningHash
- (concat perTransferKeySigners)
- []
- legacySigningHashFallbackOrder
- when (any null perTransferKeySigners) $
- failWith KeyCannotSign "sign: supplied key cannot produce detached signatures"
- signatures <- mapM (signData sAs ts signingHash payload) (concat perTransferKeySigners)
- let output = runPut (mapM_ (Bin.put . SignaturePkt) signatures)
- case sMicalgOut of
- Just outPath -> writeFileWithOutputExistsCheck "sign" outPath (renderMicalg signatures)
- Nothing -> pure ()
- BL.putStr $
- if not sArmor && not sNoArmor
- then AA.encodeLazy [Armor ArmorSignature [] output]
- else output
- where
- signData ::
- AsBinaryText
- -> ThirtyTwoBitTimeStamp
- -> HashAlgorithm
- -> BL.ByteString
- -> FunKey
- -> IO SignaturePayload
- signData mode t signHash d k = do
- let st = case mode of { AsBinary -> BinarySig; AsText -> CanonicalTextSig }
- payload = d
- issuerPackets <- unhashed (fpkp k)
- signWithKey "sign" (fpkp k) st signHash (hashed (fpkp k) t) issuerPackets payload (fmska k)
- hashed pkp ct =
- [ SigSubPacket False (SigCreationTime ct)
- , SigSubPacket False (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))
- ]
- unhashed pkp = issuerSubpacketsFor "sign" pkp
-loadSigningKeys :: [String] -> [BL.ByteString] -> IO [TKUnknown]
-loadSigningKeys keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles
- where
- loadFromFile path = do
- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
- packets <- decodeOpenPGPInput path lbs
- tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| CC.sinkList
- let fallbackTks = signingFallbackTKs packets
- when (null tks && null fallbackTks) $
- failWith MissingInput ("sign: no secret key material found in " ++ path)
- mapM (decryptSigningKeyMaterial path keyPasswords) (if null tks then fallbackTks else tks)
-
-decryptSigningKeyMaterial :: FilePath -> [BL.ByteString] -> TKUnknown -> IO TKUnknown
-decryptSigningKeyMaterial path keyPasswords =
- unlockTransferableSecretKeyMaterial
- "sign failed"
- path
- "--with-key-password"
- keyPasswords
-
-unlockTransferableSecretKeyMaterial ::
- String -> FilePath -> String -> [BL.ByteString] -> TKUnknown -> IO TKUnknown
--- Upstream could expose a TK-wide secret-key rewrite helper so SOP
--- subcommands do not need to walk primary and subkey packets separately.
-unlockTransferableSecretKeyMaterial context path passwordOption keyPasswords tk = do
- keyPair' <- decryptSecretPart (_tkuKey tk)
- subs' <- mapM decryptSub (_tkuSubs tk)
- pure tk {_tkuKey = keyPair', _tkuSubs = subs'}
- where
- decryptSecretPart (pkp, Just ska) = do
- ska' <- unlockSecretAddendum context path passwordOption keyPasswords pkp ska
- pure (pkp, Just ska')
- decryptSecretPart keyPair = pure keyPair
- decryptSub (SecretSubkeyPkt pkp ska, sigs) = do
- ska' <- unlockSecretAddendum context path passwordOption keyPasswords pkp ska
- pure (SecretSubkeyPkt pkp ska', sigs)
- decryptSub sub = pure sub
-
-unlockSecretAddendum ::
- String -> FilePath -> String -> [BL.ByteString] -> SomePKPayload -> SKAddendum -> IO SKAddendum
-unlockSecretAddendum _ _ _ _ _ sk@(SUUnencrypted _ _) = pure sk
-unlockSecretAddendum context path passwordOption [] _ _ =
- failWith
- KeyIsProtected
- (context ++ ": encrypted key material in " ++ path ++ " requires " ++ passwordOption)
-unlockSecretAddendum context path passwordOption keyPasswords pkp sk =
- case tryDecrypt keyPasswords of
- Right decrypted -> pure decrypted
- Left _ ->
- failWith
- KeyIsProtected
- (context ++ ": could not unlock key material in " ++ path ++
- " with provided " ++ passwordOption ++ " values")
- where
- tryDecrypt [] = Left ()
- tryDecrypt (password:rest) =
- case decryptPrivateKey (pkp, sk) password of
- Left _ -> tryDecrypt rest
- Right decrypted -> Right decrypted
-
-normalizeSigningKey :: POSIXTime -> TKUnknown -> IO TKUnknown
-normalizeSigningKey pt tk =
- case processTK (Just pt) tk of
- Left err -> failWith BadData ("sign: invalid signing key material: " ++ show err)
- Right normalized -> pure normalized
-
-signPayloadWithKeys ::
- POSIXTime
- -> AsBinaryText
- -> BL.ByteString
- -> [TKUnknown]
- -> [HashAlgorithm]
- -> [HashAlgorithm]
- -> IO [SignaturePayload]
-signPayloadWithKeys pt asMode payload keys recipientHashPrefs fallbackOrder = do
- processedKeys <- mapM (normalizeSigningKey pt) keys
- let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys
- signingHash = selectSigningHash (concat perTransferKeySigners) recipientHashPrefs fallbackOrder
- when (any null perTransferKeySigners) $
- failWith KeyCannotSign "encrypt: supplied key cannot produce signatures"
- mapM (signData asMode ts signingHash payload) (concat perTransferKeySigners)
- where
- ts = ThirtyTwoBitTimeStamp (floor pt)
- signData ::
- AsBinaryText
- -> ThirtyTwoBitTimeStamp
- -> HashAlgorithm
- -> BL.ByteString
- -> FunKey
- -> IO SignaturePayload
- signData mode t signHash d k = do
- let st = case mode of { AsBinary -> BinarySig; AsText -> CanonicalTextSig }
- payload = d
- issuerPackets <- unhashed (fpkp k)
- signWithKey "encrypt" (fpkp k) st signHash (hashed (fpkp k) t) issuerPackets payload (fmska k)
- hashed pkp ct =
- [ SigSubPacket False (SigCreationTime ct)
- , SigSubPacket False (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))
- ]
- unhashed pkp = issuerSubpacketsFor "encrypt" pkp
-
-signingCapableFunKeys :: POSIXTime -> TKUnknown -> [FunKey]
-signingCapableFunKeys pt =
- filter canSign . tkToFunKeysAt pt
- where
- canSign k =
- canSignDataUsage (fkufs k) &&
- case fmska k of
- Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
- Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
- Just (SUUnencrypted (UnknownSKey _) _) ->
- isEd25519PKA (_pkalgo (fpkp k)) || isEdDSAPKA (_pkalgo (fpkp k)) || isEd448PKA (_pkalgo (fpkp k))
- _ -> False
- canSignDataUsage keyFlags = S.null keyFlags || S.member SignDataKey keyFlags
-
--- Legacy alias kept for internal call sites that have not been updated.
-signingCapableRSAFunKeys :: POSIXTime -> TKUnknown -> [FunKey]
-signingCapableRSAFunKeys = signingCapableFunKeys
-
--- | Algorithm-dispatching signature helper used by all sign paths.
--- Supports RSA (v4), Ed25519 (v4), and Ed448 (v4).
-signWithKey ::
- String -- ^ context for error messages
- -> SomePKPayload
- -> SigType
- -> HashAlgorithm
- -> [SigSubPacket] -- ^ hashed subpackets
- -> [SigSubPacket] -- ^ unhashed subpackets
- -> BL.ByteString -- ^ payload to sign
- -> Maybe SKAddendum
- -> IO SignaturePayload
-signWithKey ctx signerPKP st signHash hsd usd payload mska =
- case mska of
- Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) ->
- validateRSASigningKeySize ctx signerPKP >>
- if _keyVersion signerPKP == V6
- then signRSAWithV6Salt (k {RSA.private_p = 0, RSA.private_q = 0})
- else
- signWithRSABuilder
- signHash
- (k {RSA.private_p = 0, RSA.private_q = 0})
- Just (SUUnencrypted (EdDSAPrivateKey Ed25519 rawBytes) _) ->
- case eitherCryptoError (Ed25519.secretKey rawBytes) of
- Left err -> failWith BadData (ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
- Right sk
- | _keyVersion signerPKP == V6 -> signEd25519 sk
- | isEdDSAPKA (_pkalgo signerPKP) ->
- case signDataWithEd25519Legacy st sk hsd usd payload of
- Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
- Right sig -> pure sig
- | otherwise ->
- case signDataWithEd25519 st sk hsd usd payload of
- Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
- Right sig -> pure sig
- Just (SUUnencrypted (EdDSAPrivateKey Ed448 rawBytes) _) ->
- case eitherCryptoError (Ed448.secretKey rawBytes) of
- Left err -> failWith BadData (ctx ++ " failed: bad Ed448 secret key: " ++ show err)
- Right sk
- | _keyVersion signerPKP == V6 -> signEd448 sk
- | otherwise ->
- case signDataWithEd448 st sk hsd usd payload of
- Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
- Right sig -> pure sig
- Just (SUUnencrypted (UnknownSKey rawBytes) _) ->
- case () of
- _ | isEd25519PKA (_pkalgo signerPKP) ->
- do
- normalized <- normalizeUnknownSecretForEdDSA ctx 32 rawBytes
- case eitherCryptoError (Ed25519.secretKey normalized) of
- Left err -> failWith BadData (ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
- Right sk
- | _keyVersion signerPKP == V6 -> signEd25519 sk
- | isEdDSAPKA (_pkalgo signerPKP) ->
- case signDataWithEd25519Legacy st sk hsd usd payload of
- Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
- Right sig -> pure sig
- | otherwise ->
- case signDataWithEd25519 st sk hsd usd payload of
- Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
- Right sig -> pure sig
- | isEd448PKA (_pkalgo signerPKP) ->
- do
- normalized <- normalizeUnknownSecretForEdDSA ctx 57 rawBytes
- case eitherCryptoError (Ed448.secretKey normalized) of
- Left err -> failWith BadData (ctx ++ " failed: bad Ed448 secret key: " ++ show err)
- Right sk
- | _keyVersion signerPKP == V6 -> signEd448 sk
- | otherwise ->
- case signDataWithEd448 st sk hsd usd payload of
- Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
- Right sig -> pure sig
- _ ->
- failWith
- UnsupportedAsymmetricAlgo
- (ctx ++ " failed: unsupported unknown signing key for algorithm " ++
- show (_pkalgo signerPKP))
- _ -> failWith BadData (ctx ++ " failed: unsupported or encrypted signing key")
- where
- signEd25519 sk
- = signWithV6Salt (\salt -> signDataWithEd25519V6 st salt sk hsd usd payload)
- signEd448 sk
- = signWithV6Salt (\salt -> signDataWithEd448V6 st salt sk hsd usd payload)
- signRSAWithV6Salt privateKey =
- signWithV6Salt (\salt -> signDataWithRSAV6 st salt privateKey hsd usd payload)
- signWithV6Salt signer = go [32, 64, 16, 20, 28, 48] []
- where
- go [] _ =
- failWith BadData (ctx ++ " failed: unable to construct a valid v6 signature salt")
- go (n:rest) tried = do
- bytes <- getRandomBytes n
- case signer (SignatureSalt (BL.fromStrict bytes)) of
- Right sig -> pure sig
- Left (SignV6SaltSizeMismatch _ expected _) ->
- let expectedLen = fromIntegral expected
- in if expectedLen `elem` tried
- then failWith BadData (ctx ++ " failed: unable to resolve v6 signature salt size")
- else go (expectedLen : rest) (expectedLen : tried)
- Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
- signWithRSABuilder hashToUse privateKey =
- let builder =
- SP.addUnhashedSubs
- (SubpacketList usd)
- (SP.addHashedSubs
- (SubpacketList hsd)
- (SP.sigBuilderInit st hashToUse))
- in case signDataWithRSABuilder builder privateKey payload of
- Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
- Right sig -> pure sig
-
-normalizeUnknownSecretForEdDSA :: String -> Int -> BL.ByteString -> IO B.ByteString
-normalizeUnknownSecretForEdDSA ctx expectedLen rawLbs
- | B.length raw == expectedLen = pure raw
- | B.length raw >= 2 =
- let bits =
- (fromIntegral (B.index raw 0) `shiftL` 8) .|. fromIntegral (B.index raw 1)
- mpiBytes = (bits + 7) `div` 8
- payload = B.drop 2 raw
- in if B.length payload == mpiBytes && mpiBytes <= expectedLen
- then pure (i2ospOf_ expectedLen (os2ip payload))
- else bad
- | otherwise = bad
- where
- raw = BL.toStrict rawLbs
- bad =
- failWith
- BadData
- (ctx ++ " failed: unsupported EdDSA secret key encoding (length=" ++
- show (B.length raw) ++ ")")
-
-validateRSASigningKeySize :: String -> SomePKPayload -> IO ()
-validateRSASigningKeySize ctx signerPKP =
- case pubkeySize (_pubkey signerPKP) of
- Right bits
- | bits < 2048 ->
- failWith
- KeyCannotSign
- (ctx ++ " failed: RSA signing keys smaller than 2048 bits are not supported")
- | otherwise -> pure ()
- Left err ->
- failWith
- BadData
- (ctx ++ " failed: unable to determine RSA key size: " ++ err)
-
--- FIXME: clean this up
-isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool
-isEd25519PKA pka = fromFVal pka == 27
-isEdDSAPKA pka = fromFVal pka == 22
-isEd448PKA pka = fromFVal pka == 28
-
-selectSigningHash :: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm
-selectSigningHash signerKeys recipientHashPrefs fallbackOrder =
- fromMaybe SHA512 (find (hashSupportedByAllSigners signerKeys) candidateOrder)
- where
- requestedPrefs =
- if null recipientHashPrefs
- then signerPrefs
- else recipientHashPrefs
- signerPrefs = concatMap fpreferredHashes signerKeys
- filteredRequested = filter (hashSupportedByAllSigners signerKeys) requestedPrefs
- filteredSignerPrefs = filter (hashSupportedByAllSigners signerKeys) signerPrefs
- candidateOrder = filteredRequested ++ filteredSignerPrefs ++ fallbackOrder
-
-legacySigningHashFallbackOrder :: [HashAlgorithm]
-legacySigningHashFallbackOrder = [SHA512, SHA384, SHA256, SHA224]
-
-rfc9580SigningHashFallbackOrder :: [HashAlgorithm]
-rfc9580SigningHashFallbackOrder = [SHA3_512, SHA3_256, SHA512, SHA384, SHA256, SHA224]
-
-hashSupportedByAllSigners :: [FunKey] -> HashAlgorithm -> Bool
-hashSupportedByAllSigners signers ha =
- not (isDeprecatedHashAlgorithm ha) &&
- all (`signerSupportsHashAlgorithm` ha) signers
-
-signerSupportsHashAlgorithm :: FunKey -> HashAlgorithm -> Bool
-signerSupportsHashAlgorithm signer ha =
- not (isDeprecatedHashAlgorithm ha) &&
- case _pkalgo (fpkp signer) of
- RSA -> rsaPKCS15SupportedHash ha
- DeprecatedRSASignOnly -> rsaPKCS15SupportedHash ha
- DeprecatedRSAEncryptOnly -> rsaPKCS15SupportedHash ha
- _ -> not (isOtherHashAlgorithm ha)
-
-rsaPKCS15SupportedHash :: HashAlgorithm -> Bool
-rsaPKCS15SupportedHash SHA224 = True
-rsaPKCS15SupportedHash SHA256 = True
-rsaPKCS15SupportedHash SHA384 = True
-rsaPKCS15SupportedHash SHA512 = True
-rsaPKCS15SupportedHash _ = False
-
-isDeprecatedHashAlgorithm :: HashAlgorithm -> Bool
-isDeprecatedHashAlgorithm DeprecatedMD5 = True
-isDeprecatedHashAlgorithm SHA1 = True
-isDeprecatedHashAlgorithm RIPEMD160 = True
-isDeprecatedHashAlgorithm _ = False
-
-isOtherHashAlgorithm :: HashAlgorithm -> Bool
-isOtherHashAlgorithm (OtherHA _) = True
-isOtherHashAlgorithm _ = False
-
-hashAlgorithmHeaderName :: HashAlgorithm -> String
-hashAlgorithmHeaderName DeprecatedMD5 = "MD5"
-hashAlgorithmHeaderName SHA1 = "SHA1"
-hashAlgorithmHeaderName RIPEMD160 = "RIPEMD160"
-hashAlgorithmHeaderName SHA224 = "SHA224"
-hashAlgorithmHeaderName SHA256 = "SHA256"
-hashAlgorithmHeaderName SHA384 = "SHA384"
-hashAlgorithmHeaderName SHA512 = "SHA512"
-hashAlgorithmHeaderName SHA3_256 = "SHA3-256"
-hashAlgorithmHeaderName SHA3_512 = "SHA3-512"
-hashAlgorithmHeaderName (OtherHA _) = "SHA512"
-
-ensureCanonicalMIMETextInput :: BL.ByteString -> IO ()
-ensureCanonicalMIMETextInput lbs = do
- let bs = BL.toStrict lbs
- when (B.any (> 0x7f) bs) $
- failWith
- ExpectedText
- "sign: --micalg-out requires canonical 7-bit text data on standard input"
- case TE.decodeUtf8' bs of
- Left _ ->
- failWith
- ExpectedText
- "sign: --micalg-out requires UTF-8 text data on standard input"
- Right _ -> pure ()
- when (not (canonicalCRLFLineEndings bs)) $
- failWith
- ExpectedText
- "sign: --micalg-out requires CRLF line endings on standard input"
- when (hasTrailingLineWhitespace bs) $
- failWith
- ExpectedText
- "sign: --micalg-out requires no trailing line whitespace on standard input"
- where
- canonicalCRLFLineEndings bytes = go (B.unpack bytes)
- where
- go [] = True
- go [13] = False
- go (13:10:rest) = go rest
- go (13:_) = False
- go (10:_) = False
- go (_:rest) = go rest
- hasTrailingLineWhitespace bytes =
- endsWithWhitespace bytes || trailingWhitespaceBeforeCRLF (B.unpack bytes)
- endsWithWhitespace bytes =
- case B.unsnoc bytes of
- Just (_, c) -> c == 32 || c == 9
- Nothing -> False
- trailingWhitespaceBeforeCRLF (a:13:10:rest)
- | a == 32 || a == 9 = True
- | otherwise = trailingWhitespaceBeforeCRLF (13:10:rest)
- trailingWhitespaceBeforeCRLF (_:rest) = trailingWhitespaceBeforeCRLF rest
- trailingWhitespaceBeforeCRLF _ = False
-
-ensureUTF8TextInput :: String -> BL.ByteString -> IO ()
-ensureUTF8TextInput subcommand lbs =
- case TE.decodeUtf8' (BL.toStrict lbs) of
- Left _ ->
- failWith
- ExpectedText
- (subcommand ++ ": --as=text requires UTF-8 text on standard input")
- Right _ -> pure ()
-
-canonicalizeUTF8Text :: BL.ByteString -> BL.ByteString
-canonicalizeUTF8Text =
- BL.fromStrict .
- TE.encodeUtf8 . T.intercalate (T.pack "\r\n") . T.lines . TE.decodeUtf8 . BL.toStrict
-
-renderMicalg :: [SignaturePayload] -> String
-renderMicalg signatures =
- case nub (mapMaybe signatureMicalg signatures) of
- [micalg] -> micalg
- _ -> ""
- where
- signatureMicalg (SigV4 _ _ ha _ _ _ _) = hashAlgorithmMicalg ha
- signatureMicalg _ = Nothing
- hashAlgorithmMicalg DeprecatedMD5 = Just "pgp-md5"
- hashAlgorithmMicalg SHA1 = Just "pgp-sha1"
- hashAlgorithmMicalg RIPEMD160 = Just "pgp-ripemd160"
- hashAlgorithmMicalg SHA224 = Just "pgp-sha224"
- hashAlgorithmMicalg SHA256 = Just "pgp-sha256"
- hashAlgorithmMicalg SHA384 = Just "pgp-sha384"
- hashAlgorithmMicalg SHA512 = Just "pgp-sha512"
- hashAlgorithmMicalg SHA3_256 = Just "pgp-sha3-256"
- hashAlgorithmMicalg SHA3_512 = Just "pgp-sha3-512"
- hashAlgorithmMicalg (OtherHA _) = Nothing
-
-grabKey :: String -> IO TKUnknown
-grabKey fp = do
- kbs <- runConduitRes $ CB.sourceFile fp .| CL.consume
- let lbs = BL.fromChunks kbs
- pkts <- decodeOpenPGPInput fp lbs
- tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| CC.sinkList
- case tks of
- (k:_) -> pure k
- [] ->
- case signingFallbackTKs pkts of
- (k:_) -> pure k
- [] -> failWith MissingInput ("no secret key material found in " ++ fp)
-
-signingFallbackTKs :: [Pkt] -> [TKUnknown]
-signingFallbackTKs packets =
- [TKUnknown (pkp, Just ska) [] [] [] [] | SecretKeyPkt pkp ska <- packets]
-
-data FunKey =
- FunKey
- { fpkp :: SomePKPayload
- , fmska :: Maybe SKAddendum
- , fkufs :: S.Set KeyFlag
- , fpreferredHashes :: [HashAlgorithm]
- , fpreferredSymmetricAlgorithms :: [SymmetricAlgorithm]
- , fsupportsSEIPDv2 :: Bool
- }
- deriving (Show)
-
-tkToFunKeysAt :: POSIXTime -> TKUnknown -> [FunKey]
-tkToFunKeysAt pt tk@(TKUnknown (pkp, mska) _ uids _ subs) =
- catMaybes (mainKey : map extract subs)
- where
- mainPreferredHashes = effectiveHashPreferencesAt pt tk
- mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt tk
- mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt tk
- mainKey =
- Just
- (FunKey
- pkp
- mska
- (fromMaybe S.empty (grabASig uids >>= sig2KUFs))
- mainPreferredHashes
- mainPreferredSymmetricAlgorithms
- mainSupportsSEIPDv2)
- sig2KUFs = getHasheds >=> find isKUF >=> getKUFs
- grabASig :: [(a, [b])] -> Maybe b
- grabASig = (listToMaybe >=> listToMaybe) . map snd -- FIXME: this should grab the "best" sig
- getHasheds :: SignaturePayload -> Maybe [SigSubPacket]
- getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds
- getHasheds (SigV6 _ _ _ _ hasheds _ _ _) = Just hasheds
- getHasheds _ = Nothing
- getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag)
- getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs
- getKUFs _ = Nothing
- extract ((SecretSubkeyPkt spkp sska), sigs) =
- return
- (FunKey
- spkp
- (Just sska)
- (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
- mainPreferredHashes
- mainPreferredSymmetricAlgorithms
- mainSupportsSEIPDv2)
- extract ((PublicSubkeyPkt spkp), sigs) =
- return
- (FunKey
- spkp
- Nothing
- (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
- mainPreferredHashes
- mainPreferredSymmetricAlgorithms
- mainSupportsSEIPDv2)
- extract _ = Nothing
-
-effectiveHashPreferencesAt :: POSIXTime -> TKUnknown -> [HashAlgorithm]
-effectiveHashPreferencesAt pt tk =
- concatMap toHashes $
- fromMaybe [] (effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) tk)
- where
- toHashes (PreferredHashAlgorithms hashes) = hashes
- toHashes _ = []
-
-effectiveSymmetricPreferencesAt :: POSIXTime -> TKUnknown -> [SymmetricAlgorithm]
-effectiveSymmetricPreferencesAt pt tk =
- concatMap toSymmetricAlgorithms $
- fromMaybe [] (effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) tk)
- where
- toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms
- toSymmetricAlgorithms _ = []
-
-effectiveSEIPDv2SupportAt :: POSIXTime -> TKUnknown -> Bool
-effectiveSEIPDv2SupportAt pt tk =
- any supportsSEIPDv2Flag $
- concatMap toFeatureFlags $
- fromMaybe [] (effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) tk)
- where
- toFeatureFlags (Features flags) = S.toList flags
- toFeatureFlags _ = []
- supportsSEIPDv2Flag FeatureSEIPDv2 = True
- supportsSEIPDv2Flag _ = False
-
--- SOP Handler Stubs
--- These implement the stateless OpenPGP CLI commands per draft-16
-
-doVerify :: POSIXTime -> VerifyOptions -> IO ()
-doVerify cpt VerifyOptions {..} = do
- (krs, verifyTks) <- loadVerifyContext cpt verifyCertFiles
- signatureInput <- runConduitRes $ CC.sourceFile verifySigFile .| CC.sinkLazy
- sigPkts <- decodeLikeSignaturePackets signatureInput
- let sigs = V.fromList (filter isDetachedVerificationSignaturePkt sigPkts)
- blob <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- upperBound <- verificationUpperBound cpt verifyNotAfter
- lowerBound <- verificationLowerBound cpt verifyNotBefore
- let sigsWithoutUnsupportedCritical =
- V.filter (not . detachedSignatureHasUnsupportedCriticalSubpackets) sigs
- binaryVerifications <- verifyWithLiteralData BinaryData blob sigsWithoutUnsupportedCritical krs upperBound
- verifications <-
- if any isRight binaryVerifications
- then pure binaryVerifications
- else
- verifyWithLiteralData
- TextData
- blob
- sigsWithoutUnsupportedCritical
- krs
- upperBound
- let decodedVerifications = map (first show) verifications
- signerPolicyAdjusted =
- map (enforceVerificationSignerPolicy cpt verifyTks) decodedVerifications
- let filtered =
- filterByVerificationBounds lowerBound upperBound signerPolicyAdjusted
- policyFiltered =
- filter (not . verificationResultUsesDeprecatedHash) filtered
- mapM_ (putStrLn . renderSOPVerificationLine verifyTks) (rights policyFiltered)
- case any isRight policyFiltered of
- True -> exitSuccess
- _ -> failWith NoSignature "No acceptable signatures found"
- where
- decodeLikeSignaturePackets lbs = do
- decodedArmors <- decodeAsciiArmorInput ("signature input in " ++ verifySigFile) lbs
- case decodedArmors of
- Just armors ->
- case firstBy isDetachedSignatureArmor armors of
- Just (Armor ArmorSignature _ bs) ->
- parseOpenPGPPackets
- ("signature input in " ++ verifySigFile)
- (BL.fromStrict (BLC8.toStrict bs))
- _ ->
- case firstBy isDetachedSignatureUnsupportedArmor armors of
- Just (ClearSigned _ _ _) ->
- failWith
- BadData
- ("verify: expected detached signatures in " ++ verifySigFile)
- Just (Armor _ _ _) ->
- failWith
- BadData
- ("verify: expected signature armor in " ++ verifySigFile)
- _ -> parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs
- Nothing -> parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs
- verifyWithLiteralData format payload sigs keyring upperBound =
- runConduitRes $
- CC.yieldMany (V.cons (LiteralDataPkt format mempty 0 payload) sigs) .|
- conduitVerify keyring upperBound .|
- CC.sinkList
-
-detachedSignatureHasUnsupportedCriticalSubpackets :: Pkt -> Bool
-detachedSignatureHasUnsupportedCriticalSubpackets (SignaturePkt sig) =
- any criticalUnsupported (signatureHashedSubpackets sig)
- where
- criticalUnsupported (SigSubPacket True (OtherSigSub _ _)) = True
- criticalUnsupported (SigSubPacket True (UserDefinedSigSub _ _)) = True
- criticalUnsupported (SigSubPacket True (NotationData _ _ _)) = True
- criticalUnsupported _ = False
-detachedSignatureHasUnsupportedCriticalSubpackets _ = False
-
-signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]
-signatureHashedSubpackets (SigV4 _ _ _ hashed _ _ _) = hashed
-signatureHashedSubpackets (SigV6 _ _ _ _ hashed _ _ _) = hashed
-signatureHashedSubpackets _ = []
-
-verificationResultUsesDeprecatedHash :: Either String Verification -> Bool
-verificationResultUsesDeprecatedHash (Right verification) =
- verificationUsesDeprecatedHash verification
-verificationResultUsesDeprecatedHash _ = False
-
-verificationUsesDeprecatedHash :: Verification -> Bool
-verificationUsesDeprecatedHash (Verification _ sigPayload _) =
- isDeprecatedHashAlgorithm (signatureHashAlgorithm sigPayload)
-
-signatureHashAlgorithm :: SignaturePayload -> HashAlgorithm
-signatureHashAlgorithm (SigV3 _ _ _ _ ha _ _) = ha
-signatureHashAlgorithm (SigV4 _ _ ha _ _ _ _) = ha
-signatureHashAlgorithm (SigV6 _ _ ha _ _ _ _ _) = ha
-signatureHashAlgorithm (SigVOther _ _) = OtherHA 0
-
-enforceVerificationSignerPolicy ::
- POSIXTime
- -> [TKUnknown]
- -> Either String Verification
- -> Either String Verification
-enforceVerificationSignerPolicy _ _ result@(Left _) = result
-enforceVerificationSignerPolicy cpt verifyTks result@(Right verification)
- | signerAllowed = result
- | otherwise = Left "verification failed: signer key is not valid for signing at signature creation time"
- where
- signerAllowed = any signerMatchesProcessed verifyTks
- signerFp = fingerprint (_verificationSigner verification)
- verificationTimePosix =
- maybe cpt (realToFrac . utcTimeToPOSIXSeconds) (signatureCreationTime (_verificationSignature verification))
- verificationTime = posixSecondsToUTCTime verificationTimePosix
- signerMatchesProcessed tk
- | not (keyMatchesFingerprint True tk signerFp) = False
- | keyMatchesFingerprint False tk signerFp = True
- | otherwise = any (subkeyAllowsSigning verificationTime signerFp) (_tkuSubs tk)
-
-subkeyAllowsSigning :: UTCTime -> Fingerprint -> (Pkt, [SignaturePayload]) -> Bool
-subkeyAllowsSigning t signerFp (pkt, sigs) =
- case subkeyPayload pkt of
- Just pkp
- | fingerprint pkp == signerFp ->
- any (bindingSignatureAllowsSigning t) (filter isSKBindingSig sigs)
- _ -> False
- where
- subkeyPayload (PublicSubkeyPkt pkp) = Just pkp
- subkeyPayload (SecretSubkeyPkt pkp _) = Just pkp
- subkeyPayload _ = Nothing
-
-bindingSignatureAllowsSigning :: UTCTime -> SignaturePayload -> Bool
-bindingSignatureAllowsSigning t sig =
- allowsSigning && hasValidBacksig
- where
- allowsSigning =
- let flagSets = signatureKeyFlagSets sig
- in null flagSets || any (S.member SignDataKey) flagSets
- hasValidBacksig =
- any
- (\embedded ->
- isPKBindingSig embedded &&
- not (signatureExpiredAt t embedded))
- (signatureEmbeddedSignatures sig)
-
-signatureEmbeddedSignatures :: SignaturePayload -> [SignaturePayload]
-signatureEmbeddedSignatures sig =
- [ embedded
- | SigSubPacket _ (EmbeddedSignature embedded) <- signatureSubpackets sig
- ]
-
-signatureKeyFlagSets :: SignaturePayload -> [S.Set KeyFlag]
-signatureKeyFlagSets sig =
- [ flags
- | SigSubPacket _ (KeyFlags flags) <- signatureSubpackets sig
- ]
-
-signatureExpiredAt :: UTCTime -> SignaturePayload -> Bool
-signatureExpiredAt t sig =
- case (signatureCreationTime sig, signatureValiditySeconds sig) of
- (Just created, Just validitySeconds) ->
- utcTimeToPOSIXSeconds t >= utcTimeToPOSIXSeconds created + fromIntegral validitySeconds
- _ -> False
-
-signatureValiditySeconds :: SignaturePayload -> Maybe Integer
-signatureValiditySeconds sig =
- listToMaybe
- [ fromIntegral secs
- | SigSubPacket _ (SigExpirationTime (ThirtyTwoBitDuration secs)) <- signatureSubpackets sig
- ]
-verificationUpperBound ::
- POSIXTime -> Maybe String -> IO (Maybe UTCTime)
-verificationUpperBound cpt Nothing = return (Just (posixSecondsToUTCTime cpt))
-verificationUpperBound _ (Just "-") = return Nothing
-verificationUpperBound cpt (Just "now") =
- return (Just (posixSecondsToUTCTime cpt))
-verificationUpperBound _ (Just s) = do
- let m = iso8601ParseM s :: Maybe UTCTime
- case m of
- Just t -> return (Just t)
- Nothing -> failWith BadData ("Invalid DATE value: " ++ s)
-
-verificationLowerBound ::
- POSIXTime -> Maybe String -> IO (Maybe UTCTime)
-verificationLowerBound _ Nothing = return Nothing
-verificationLowerBound _ (Just "-") = return Nothing
-verificationLowerBound cpt (Just "now") =
- return (Just (posixSecondsToUTCTime cpt))
-verificationLowerBound _ (Just s) = do
- let m = iso8601ParseM s :: Maybe UTCTime
- case m of
- Just t -> return (Just t)
- Nothing -> failWith BadData ("Invalid DATE value: " ++ s)
-
-filterByVerificationBounds ::
- Maybe UTCTime
- -> Maybe UTCTime
- -> [Either String Verification]
- -> [Either String Verification]
-filterByVerificationBounds lower upper = map (>>= ensureBounds)
- where
- ensureBounds v =
- case signatureCreationTime (_verificationSignature v) of
- Nothing -> Left "verification failed: signature is missing creation time"
- Just sigTime
- | Just upperBound <- upper
- , sigTime > upperBound ->
- Left "verification failed: signature created after --not-after bound"
- | Just lowerBound <- lower
- , sigTime < lowerBound ->
- Left "verification failed: signature created before --not-before bound"
- | otherwise -> Right v
-
-signatureCreationTime :: SignaturePayload -> Maybe UTCTime
-signatureCreationTime (SigV4 _ _ _ hashed _ _ _) =
- firstCreationTime hashed
-signatureCreationTime (SigV6 _ _ _ _ hashed _ _ _) =
- firstCreationTime hashed
-signatureCreationTime _ = Nothing
-
-firstCreationTime :: [SigSubPacket] -> Maybe UTCTime
-firstCreationTime = listToMaybe . mapMaybe getCreation
- where
- getCreation (SigSubPacket _ (SigCreationTime (ThirtyTwoBitTimeStamp ts))) =
- Just (posixSecondsToUTCTime (fromIntegral ts))
- getCreation _ = Nothing
-
-isDetachedVerificationSignaturePkt :: Pkt -> Bool
-isDetachedVerificationSignaturePkt (SignaturePkt (SigV4 sigType _ _ _ _ _ _)) =
- sigType == BinarySig || sigType == CanonicalTextSig
-isDetachedVerificationSignaturePkt (SignaturePkt (SigV6 sigType _ _ _ _ _ _ _)) =
- sigType == BinarySig || sigType == CanonicalTextSig
-isDetachedVerificationSignaturePkt _ = False
-
-doInlineVerify :: POSIXTime -> InlineVerifyOptions -> IO ()
-doInlineVerify cpt InlineVerifyOptions {..} = do
- (krs, verifyTks) <- loadVerifyContext cpt inlineCertFiles
- signedInput <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- upperBound <- verificationUpperBound cpt inlineNotAfter
- lowerBound <- verificationLowerBound cpt inlineNotBefore
- (allowTrailingSignatures, parsedPackets) <- inlineVerifyPackets signedInput
- packets <- normalizeInlineVerifyPackets allowTrailingSignatures parsedPackets
- let verifications =
- map (first show) (verifyPacketsBatch krs upperBound packets)
- filtered = filterByVerificationBounds lowerBound upperBound verifications
- successLines = map (renderSOPVerificationLine verifyTks) (rights filtered)
- renderedOut =
- if null successLines
- then ""
- else unlines successLines
- case verificationsOut of
- Just outPath -> writeFileWithOutputExistsCheck "inline-verify" outPath renderedOut
- Nothing -> pure ()
- case any isRight filtered of
- True -> extractSingleLiteralPayload packets >>= BL.putStr >> exitSuccess
- _ -> failWith NoSignature "No acceptable signatures found"
- where
- inlineVerifyPackets :: BL.ByteString -> IO (Bool, [Pkt])
- inlineVerifyPackets lbs = do
- decodedArmors <- decodeAsciiArmorInput "inline-verify input" lbs
- case decodedArmors of
- Just armors ->
- case listToMaybe (filter isInlineVerifyCandidateArmor armors) of
- Just (Armor ArmorMessage _ bs) -> do
- let packetBytes = BL.fromStrict (BLC8.toStrict bs)
- packets <-
- parseInlineVerifyMessagePackets
- "inline-verify armored message"
- packetBytes
- pure (False, packets)
- Just (ClearSigned headers cleartext signatureArmor) -> do
- validateClearSignedEnvelopeBounds lbs
- validateClearSignedHeaders headers
- sigPkts <- clearSignedSignaturePackets signatureArmor
- pure
- ( True
- , LiteralDataPkt TextData BL.empty 0 (BL.fromStrict (BLC8.toStrict cleartext)) :
- sigPkts
- )
- Just (Armor _ _ _) ->
- failWith
- BadData
- "inline-verify expects an armored OpenPGP message or cleartext signed message"
- Nothing -> do
- packets <- parseInlineVerifyMessagePackets "inline-verify input" lbs
- pure (False, packets)
- Nothing -> do
- packets <- parseInlineVerifyMessagePackets "inline-verify input" lbs
- pure (False, packets)
-
- parseInlineVerifyMessagePackets :: String -> BL.ByteString -> IO [Pkt]
- parseInlineVerifyMessagePackets context packetBytes = do
- rawPkts <- parseRawOpenPGPPackets context packetBytes
- when (any compressedPacketParseFailed rawPkts) $
- failWith BadData "inline-verify input has malformed compressed packet data"
- when (any compressedPacketIsEmpty rawPkts) $
- failWith BadData "inline-verify input has empty compressed packet data"
- expanded <- expandPacketsStrict context rawPkts
- when (any isMarkerPacket expanded && any isCompressedPacket rawPkts) $
- failWith BadData "inline-verify input has malformed compressed packet sequence"
- pure expanded
-
- expandPacketsStrict :: String -> [Pkt] -> IO [Pkt]
- expandPacketsStrict context =
- fmap concat . mapM expandPacket
- where
- expandPacket pkt =
- case decompressPkt pkt of
- Left err ->
- failWith
- BadData
- (context ++ ": failed to parse compressed packet: " ++ renderCompressionError err)
- Right packets -> pure packets
-
-isInlineVerifyCandidateArmor :: Armor -> Bool
-isInlineVerifyCandidateArmor (Armor ArmorMessage _ _) = True
-isInlineVerifyCandidateArmor ClearSigned {} = True
-isInlineVerifyCandidateArmor _ = False
-
-clearSignedSignaturePackets :: Armor -> IO [Pkt]
-clearSignedSignaturePackets (Armor ArmorSignature _ sigbs) =
- let sigPktsSource = parseOpenPGPPackets "cleartext signature block" (BL.fromStrict (BLC8.toStrict sigbs))
- in do
- parsed <- sigPktsSource
- let sigPkts = filter isSignaturePkt parsed
- if null sigPkts
- then failWith BadData "cleartext signature block has no signature packets"
- else return sigPkts
-clearSignedSignaturePackets (Armor _ _ _) =
- failWith
- BadData
- "cleartext signed message does not contain an armored signature block"
-clearSignedSignaturePackets (ClearSigned _ _ inner) =
- clearSignedSignaturePackets inner
-
-isSignaturePkt :: Pkt -> Bool
-isSignaturePkt SignaturePkt {} = True
-isSignaturePkt _ = False
-
-normalizeInlineVerifyPackets :: Bool -> [Pkt] -> IO [Pkt]
-normalizeInlineVerifyPackets allowTrailingSignatures pkts
- | any isBrokenPacket relevantPkts =
- failWith
- BadData
- "inline-verify input contains malformed packet encoding"
- | any (not . isInlineVerificationPacket) filteredPkts =
- failWith
- BadData
- "inline-verify input contains unsupported packet types"
- | otherwise =
- case ([pkt | pkt@LiteralDataPkt {} <- filteredPkts], [pkt | pkt@SignaturePkt {} <- filteredPkts]) of
- ([], _) ->
- failWith
- BadData
- "inline-verify input has no literal message payload"
- ([_], []) ->
- failWith
- BadData
- "inline-verify input has no signatures"
- ([lit], sigs)
- | not hasOnePass &&
- (null signaturePositions || not (all (< literalIndex) signaturePositions)) &&
- (not allowTrailingSignatures || not (all (> literalIndex) signaturePositions)) ->
- failWith
- BadData
- "inline-verify input has malformed signed-message packet order"
- | otherwise -> pure (lit : sigs)
- (_, _) ->
- failWith
- BadData
- "inline-verify input contains multiple literal payloads"
- where
- relevantPkts = filter (not . isMarkerPacket) pkts
- filteredPkts = filter (not . isIgnorableInlineVerifyPacket) relevantPkts
- packetPositions = zip [0 :: Int ..] filteredPkts
- signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]
- onePassPositions = [i | (i, OnePassSignaturePkt {}) <- packetPositions]
- literalPositions = [i | (i, LiteralDataPkt {}) <- packetPositions]
- hasOnePass = not (null onePassPositions)
- literalIndex =
- case literalPositions of
- (i:_) -> i
- [] -> -1
- isBrokenPacket BrokenPacketPkt {} = True
- isBrokenPacket _ = False
-
-isIgnorableInlineVerifyPacket :: Pkt -> Bool
-isIgnorableInlineVerifyPacket (OtherPacketPkt tag _) = tag >= 40
-isIgnorableInlineVerifyPacket _ = False
-
-isInlineVerificationPacket :: Pkt -> Bool
-isInlineVerificationPacket LiteralDataPkt {} = True
-isInlineVerificationPacket SignaturePkt {} = True
-isInlineVerificationPacket OnePassSignaturePkt {} = True
-isInlineVerificationPacket (OtherPacketPkt tag _) = tag >= 40
-isInlineVerificationPacket BrokenPacketPkt {} = False
-isInlineVerificationPacket _ = False
-
-doEncrypt :: POSIXTime -> EncryptOptions -> IO ()
-doEncrypt cpt EncryptOptions {..} = do
- when (encNoArmor && encArmor) $
- failWith IncompatibleOptions "encrypt: --armor and --no-armor are mutually exclusive"
- payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- when (encAs == AsText) $
- ensureUTF8TextInput "encrypt" payload
- when encWithoutIntegrityCheck $
- failWith
- UnsupportedOption
- "encrypt: --without-integrity-check is not supported by this backend"
- symmetricPasswordsRaw <- loadPasswordFiles "encrypt" "--with-password" encPasswords
- symmetricPasswords <-
- mapM
- (normalizeHumanReadablePassword "encrypt" "--with-password")
- symmetricPasswordsRaw
- signingKeyPasswordsRaw <- loadPasswordFiles "encrypt" "--with-key-password" encSignWithKeyPasswords
- let signingKeyPasswords = concatMap passwordRetryCandidates signingKeyPasswordsRaw
- encryptProfile <- parseEncryptProfile encProfile
- when (not (null encRecipientCerts) && not (null symmetricPasswords)) $
- failWith
- UnsupportedOption
- "encrypt: combining recipient certificates with --with-password is not yet supported"
- recipientKeys <-
- if null encRecipientCerts
- then pure []
- else loadEncryptRecipients cpt encFor encRecipientCerts
- recipientHashPrefs <-
- if null encRecipientCerts
- then pure []
- else loadRecipientPreferredHashes cpt encRecipientCerts
- signatures <-
- if null encSignWithKeyFiles
- then pure []
- else do
- signingKeys <- loadSigningKeys encSignWithKeyFiles signingKeyPasswords
- signPayloadWithKeys
- cpt
- encAs
- payload
- signingKeys
- recipientHashPrefs
- (case encryptProfile of
- EncryptProfileRFC9580 -> rfc9580SigningHashFallbackOrder
- EncryptProfileRFC4880 -> legacySigningHashFallbackOrder)
- out <-
- case encRecipientCerts of
- [] -> doEncryptWithPassword encryptProfile payload symmetricPasswords encSessionKeyOutFile
- _ ->
- doEncryptForRecipients
- encryptProfile
- encAs
- payload
- signatures
- recipientKeys
- encSessionKeyOutFile
- BL.putStr $
- if encNoArmor
- then out
- else AA.encodeLazy [Armor ArmorMessage [] out]
-
-doEncryptWithPassword ::
- EncryptProfile
- -> BL.ByteString
- -> [BL.ByteString]
- -> Maybe String
- -> IO BL.ByteString
-doEncryptWithPassword encryptProfile payload passwords sessionKeyOutFile = do
- password <-
- case passwords of
- [] ->
- failWith
- MissingArg
- "encrypt: supply at least one recipient certificate or --with-password"
- [p] -> pure p
- _ ->
- failWith
- UnsupportedOption
- "encrypt: multiple --with-password values are not yet supported"
- let exposure =
- if isJust sessionKeyOutFile
- then ExposeSessionMaterial
- else DoNotExposeSessionMaterial
- encrypted <-
- case encryptProfile of
- EncryptProfileRFC9580 -> do
- s2kSalt <- Salt16 <$> getRandomBytes 16
- iv <- IV <$> getRandomBytes 32
- pure $
- encryptMessage
- RFC9580EncryptMessageOptions
- { rfc9580EncryptMessageExposure = exposure
- , rfc9580EncryptMessageSymmetricAlgorithm = AES256
- , rfc9580EncryptMessageS2K = Argon2 s2kSalt 1 4 15
- , rfc9580EncryptMessageIV = iv
- }
- (mkPassphrase password)
- (mkClearPayload payload)
- EncryptProfileRFC4880 -> do
- salt <- Salt8 <$> getRandomBytes 8
- iv <- IV <$> getRandomBytes 16
- pure $
- encryptMessage
- RFC4880EncryptMessageOptions
- { rfc4880EncryptMessageExposure = exposure
- , rfc4880EncryptMessageSymmetricAlgorithm = AES256
- , rfc4880EncryptMessageS2K = IteratedSalted SHA256 salt 65536
- , rfc4880EncryptMessageIV = iv
- }
- (mkPassphrase password)
- (mkClearPayload payload)
- case encrypted of
- Left err -> failWith BadData ("encrypt failed: " ++ show err)
- Right (ciphertext, mRecoveredSession) -> do
- forM_ sessionKeyOutFile $ \path ->
- case mRecoveredSession of
- Just recoveredSession ->
- writeFileWithOutputExistsCheck
- "encrypt"
- path
- ( renderSessionKeyOutLine
- (fromFVal (recoveredSessionAlgorithm recoveredSession))
- (unSessionKey (recoveredSessionKey recoveredSession)) ++ "\n"
- )
- Nothing ->
- failWith
- UnsupportedOption
- "encrypt: --session-key-out unavailable for this password encryption mode"
- pure (encryptedPayloadBytes ciphertext)
-
-doEncryptForRecipients ::
- EncryptProfile
- -> AsBinaryText
- -> BL.ByteString
- -> [SignaturePayload]
- -> [FunKey]
- -> Maybe String
- -> IO BL.ByteString
-doEncryptForRecipients encryptProfile asMode payload signatures recipients sessionKeyOutFile = do
- let targets = map recipientTargetFor recipients
- payloadShape =
- defaultRecipientPayloadShape
- { recipientPayloadDataType = literalDataType
- , recipientPayloadUseOnePassSignatures = not (null signatures)
- , recipientPayloadSignatures = signatures
- }
- result <-
- if useStrictEncryptProfile
- then
- encryptForRecipients
- RecipientEncryptRequest
- { recipientEncryptRequestTargets = targets
- , recipientEncryptRequestPayloadShape = payloadShape
- , recipientEncryptRequestPayload = BL.toStrict payload
- , recipientEncryptRequestSymmetricOverride = symmetricOverride
- , recipientEncryptRequestOverrides =
- RecipientEncryptRequestSEIPDv2Overrides
- { recipientEncryptRequestAEADOverride = Nothing
- , recipientEncryptRequestChunkSizeOverride = Nothing
- , recipientEncryptRequestSaltOverride = Nothing
- }
- }
- else
- encryptForRecipients
- RecipientEncryptRequest
- { recipientEncryptRequestTargets = targets
- , recipientEncryptRequestPayloadShape = payloadShape
- , recipientEncryptRequestPayload = BL.toStrict payload
- , recipientEncryptRequestSymmetricOverride = symmetricOverride
- , recipientEncryptRequestOverrides =
- RecipientEncryptRequestSEIPDv1Overrides
- { recipientEncryptRequestIVOverride = Nothing
- }
- }
- RecipientEncryptResult {..} <-
- case result of
- Left err ->
- failWith
- (sopFailureForPKESKEncryptError err)
- ("encrypt failed: " ++ renderPKESKEncryptError err)
- Right value -> pure value
- forM_ sessionKeyOutFile $ \path ->
- writeFileWithOutputExistsCheck
- "encrypt"
- path
- (renderSessionKeyOutLine
- (fromFVal (pkeskSessionAlgorithm recipientEncryptSessionMaterial))
- (unSessionKey (pkeskSessionKey recipientEncryptSessionMaterial)) ++ "\n")
- pure (runPut (Bin.put (Block recipientEncryptPackets)))
- where
- literalDataType =
- case asMode of
- AsBinary -> BinaryData
- AsText -> UTF8Data
- anyRecipientSupportsSEIPDv2 = any fsupportsSEIPDv2 recipients
- symmetricOverride
- | useStrictEncryptProfile = preferredStrictSymmetric <|> Just AES256
- | otherwise = preferredLegacySymmetric
- isV6Recipient pkp = _keyVersion pkp == V6
- useStrictEncryptProfile =
- case encryptProfile of
- EncryptProfileRFC9580 ->
- anyRecipientSupportsSEIPDv2 || any (isV6Recipient . fpkp) recipients
- EncryptProfileRFC4880 ->
- anyRecipientSupportsSEIPDv2 || any (isV6Recipient . fpkp) recipients
- preferredStrictSymmetric =
- preferredRecipientSymmetric isSupportedStrictEncryptSymmetric
- preferredLegacySymmetric =
- preferredRecipientSymmetric isSupportedLegacyEncryptSymmetric
- preferredRecipientSymmetric isSupported =
- case filter (not . null) (map fpreferredSymmetricAlgorithms recipients) of
- [] -> Nothing
- prefLists ->
- listToMaybe
- [ candidate
- | candidate <- filter isSupported (head prefLists)
- , all (candidate `elem`) (tail prefLists)
- ]
- isSupportedStrictEncryptSymmetric algo =
- algo `elem` [AES128, AES192, AES256]
- -- Legacy profile fallback should not hard-fail on deprecated/unsupported
- -- recipient preferences (e.g. IDEA in AEADED interop fixtures).
- isSupportedLegacyEncryptSymmetric algo =
- algo `elem` [AES128, AES192, AES256]
- recipientTargetFor funkey =
- let recipient = fpkp funkey
- recipientNeedsV6PKESK =
- useStrictEncryptProfile &&
- (fsupportsSEIPDv2 funkey || _keyVersion recipient == V6)
- in if _keyVersion recipient == V6
- then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
- else
- case _pkalgo recipient of
- ECDH ->
- -- Under strict (SEIPDv2) mode, keep Curve25519-compatible v4 ECDH keys on
- -- the X25519/v6 path so ESK/payload versions stay aligned.
- if recipientNeedsV6PKESK
- then
- case normalizeX25519CompatibleECDHRecipient recipient of
- Just x25519Recipient ->
- recipientEncryptionTargetWithStrategy x25519Recipient RecipientPreferV6
- Nothing ->
- recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
- else
- recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop
- DeprecatedRSAEncryptOnly ->
- if recipientNeedsV6PKESK
- then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
- else recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop
- RSA ->
- if recipientNeedsV6PKESK
- then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
- else recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop
- _ ->
- if recipientNeedsV6PKESK
- then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
- else recipientEncryptionTarget recipient
-
-
- normalizeX25519CompatibleECDHRecipient pkp =
- case _pubkey pkp of
- ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->
- Just
- (PKPayload
- (_keyVersion pkp)
- (_timestamp pkp)
- (_v3exp pkp)
- X25519
- (_pubkey pkp))
- _ -> Nothing
-
-parseEncryptProfile :: Maybe String -> IO EncryptProfile
-parseEncryptProfile Nothing = pure EncryptProfileRFC9580
-parseEncryptProfile (Just profileName) =
- case profileName of
- "default" -> pure EncryptProfileRFC9580
- "rfc9580" -> pure EncryptProfileRFC9580
- "security" -> pure EncryptProfileRFC9580
- "performance" -> pure EncryptProfileRFC9580
- "rfc4880" -> pure EncryptProfileRFC4880
- "compatibility" -> pure EncryptProfileRFC4880
- _ -> failWith UnsupportedProfile ("encrypt: unsupported profile " ++ profileName)
-
-doDecrypt :: POSIXTime -> DecryptOptions -> IO ()
-doDecrypt cpt DecryptOptions {..} = do
- when (decNoArmor && decArmor) $
- failWith IncompatibleOptions "decrypt: --armor and --no-armor are mutually exclusive"
- when decWithoutIntegrityCheck $
- failWith
- UnsupportedOption
- "decrypt: --without-integrity-check is not supported by this backend"
- sessionKeys <- parseDecryptSessionKeys decSessionKeys
- (verificationOutputPath, usingDeprecatedVerifyOut) <-
- resolveDecryptVerificationsOut decVerificationsOutFile decDeprecatedVerifyOutFile
- let hasVerifyWith = not (null decVerifyCerts)
- hasVerifyOut = isJust verificationOutputPath
- hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter
- doingVerification = hasVerifyWith && hasVerifyOut
- when (hasVerifyWith /= hasVerifyOut) $
- failWith
- IncompleteVerification
- "decrypt: verification requires both --verify-with and --verifications-out"
- when (hasVerifyBounds && not doingVerification) $
- failWith
- IncompleteVerification
- "decrypt: --verify-not-before/--verify-not-after require both --verify-with and --verifications-out"
- passwords <- loadPasswordFiles "decrypt" "--with-password" decPasswords
- keyPasswordsRaw <- loadPasswordFiles "decrypt" "--with-key-password" decKeyPasswords
- let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
- when (null passwords && null sessionKeys && null decKeyFiles) $
- failWith
- MissingArg
- "decrypt: supply KEYS, --with-password, or --with-session-key"
- ciphertextInput <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- ciphertext <- decodeCiphertextInput ciphertextInput
- validateDecryptPartialBodyEncoding ciphertext
- ciphertextPktsRaw <- parseRawOpenPGPPackets "decrypt input" ciphertext
- let ciphertextPkts =
- filter
- (\pkt ->
- not (isForwardCompatUnknownESKPacket pkt || isUnsupportedSKESKPacket pkt))
- ciphertextPktsRaw
- -- Pre-flight: reject messages with no encrypted payload at all (upstream
- -- won't produce a useful DecryptMalformedStructure for the empty case).
- when (not (any isEncryptedPayloadPacket ciphertextPkts)) $
- failWith BadData "decrypt input: no encrypted data packet found"
- validateCiphertextPacketLayout ciphertextPkts
- recipientKeys <- loadDecryptRecipientKeys cpt decKeyFiles keyPasswords
- when (null recipientKeys && not (null decKeyFiles) && null passwords && null sessionKeys) $
- failWith
- CannotDecrypt
- "decrypt failed: no usable secret key material found in provided KEYS"
- let passwordAttempts =
- case passwords of
- [] -> [[]]
- _ -> map (\password -> [password]) (concatMap passwordRetryCandidates passwords)
- runDecryptAttemptWithPolicy decryptPolicy keyCandidates passwordBytes = do
- passwordQueue <- newIORef passwordBytes
- sessionKeyQueue <- newIORef (map decryptSessionKeyMaterial sessionKeys)
- let decryptInputPkts = prioritizeDecryptablePKESKs keyCandidates ciphertextPkts
- let keyResolutionResolver =
- selectRecipientKeyInfosByRecipientIdentifier keyCandidates
- let opts = Decrypt.DecryptOptions
- { Decrypt.decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback keyResolutionResolver
- , Decrypt.decryptOptionsPolicy = decryptPolicy
- , Decrypt.decryptOptionsPassphraseCallback = decryptInputCallback passwordQueue sessionKeyQueue
- }
- (outcome, pkts) <- runConduitRes $
- CL.sourceList decryptInputPkts .|
- fuseBoth (Decrypt.conduitDecrypt opts) CL.consume
- case outcome of
- DecryptMalformedStructure reason ->
- pure (Left reason)
- DecryptTruncated ->
- failWith BadData "decrypt failed: encrypted message is truncated"
- _ -> pure (Right pkts)
- tryDecryptWithPasswords [passwordBytes] =
- runDecryptAttempt recipientKeys passwordBytes `catch` decryptIOFailureToSOP
- tryDecryptWithPasswords (passwordBytes:rest) =
- runDecryptAttempt recipientKeys passwordBytes `catch` retryNext
- where
- retryNext :: ExitCode -> IO [Pkt]
- retryNext exitCode
- | exitCode == ExitFailure (failureCode CannotDecrypt) =
- tryDecryptWithPasswords rest
- | otherwise = throwIO exitCode
- tryDecryptWithPasswords [] =
- failWith CannotDecrypt "decrypt failed: passphrase required but not provided"
- decryptIOFailureToSOP :: IOException -> IO [Pkt]
- decryptIOFailureToSOP err =
- failWith CannotDecrypt ("decrypt failed: " ++ displayException err)
- runDecryptAttempt keyCandidates passwordBytes = do
- strictOutcome <- runDecryptAttemptWithPolicy defaultDecryptPolicy keyCandidates passwordBytes
- case strictOutcome of
- Right pkts -> pure pkts
- Left reason
- | shouldRetryLenientDecrypt reason keyCandidates passwordBytes -> do
- lenientOutcome <- runDecryptAttemptWithPolicy lenientDecryptPolicy keyCandidates passwordBytes
- case lenientOutcome of
- Right pkts -> pure pkts
- Left lenientReason ->
- failWith BadData ("decrypt failed: malformed encrypted message structure (" ++ lenientReason ++ ")")
- | otherwise ->
- failWith BadData ("decrypt failed: malformed encrypted message structure (" ++ reason ++ ")")
- shouldRetryLenientDecrypt reason keyCandidates passwordBytes
- | "ESK packets must immediately precede encrypted data" `isInfixOf` reason = True
- | "ESK packets present but none are version-aligned with SEIPDv2 payload" `isInfixOf` reason =
- null passwordBytes &&
- not (null keyCandidates) &&
- any isLegacyRSAPKESK ciphertextPkts
- | otherwise = False
- isLegacyRSAPKESK (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) =
- pka == RSA || pka == DeprecatedRSAEncryptOnly
- isLegacyRSAPKESK _ = False
- decryptedPktsRaw <- tryDecryptWithPasswords passwordAttempts
- sessionKeyOutLine <-
- resolveSessionKeyOut
- decSessionKeyOutFile
- sessionKeys
- ciphertextPkts
- recipientKeys
- (concatMap passwordRetryCandidates passwords)
- decryptedPkts <- do
- decompressed <- mapM (either (\e -> failWith BadData (renderCompressionError e)) pure . recursivelyDecompressPacket) decryptedPktsRaw
- pure (concat decompressed)
- validateDecryptedMessageStructure decryptedPktsRaw decryptedPkts
- payload <- extractSingleLiteralPayload decryptedPkts
- BL.putStr payload
- case (decSessionKeyOutFile, sessionKeyOutLine) of
- (Just path, Just line) -> writeFileWithOutputExistsCheck "decrypt" path (line ++ "\n")
- _ -> pure ()
- when doingVerification $
- doDecryptVerifyOutput
- cpt
- decVerifyCerts
- verificationOutputPath
- decVerifyNotBefore
- decVerifyNotAfter
- decryptedPkts
- when usingDeprecatedVerifyOut $
- hPutStrLn stderr
- "Warning: --verify-out is deprecated; use --verifications-out instead."
-
-data DecryptSessionKey =
- DecryptSessionKey
- { decryptSessionKeyMaterial :: BL.ByteString
- , decryptSessionKeyOutLine :: Maybe String
- }
-
-decryptInputCallback ::
- IORef [BL.ByteString] -> IORef [BL.ByteString] -> String -> IO BL.ByteString
-decryptInputCallback passwordQueue sessionKeyQueue prompt
- | "PKESK session key material" `isInfixOf` prompt = do
- mSessionKeyMaterial <-
- atomicModifyIORef' sessionKeyQueue $ \keys ->
- case keys of
- [] -> ([], Nothing)
- (k:rest) -> (rest, Just k)
- case mSessionKeyMaterial of
- Just sessionKeyMaterial -> pure sessionKeyMaterial
- Nothing ->
- failWith
- CannotDecrypt
- "decrypt failed: PKESK session key material required but not provided"
-decryptInputCallback passwordQueue _ _ = do
- mPassword <-
- atomicModifyIORef' passwordQueue $ \passwords ->
- case passwords of
- [] -> ([], Nothing)
- (p:rest) -> (rest, Just p)
- case mPassword of
- Just password -> pure password
- Nothing -> failWith CannotDecrypt "decrypt failed: passphrase required but not provided"
-
-parseDecryptSessionKeys :: [String] -> IO [DecryptSessionKey]
-parseDecryptSessionKeys = mapM parseSessionKeySpec
-
-parseSessionKeySpec :: String -> IO DecryptSessionKey
-parseSessionKeySpec spec =
- case break (== ':') spec of
- (_, "") -> do
- material <- decodeHexBytes spec
- pure
- DecryptSessionKey
- { decryptSessionKeyMaterial = BL.fromStrict material
- , decryptSessionKeyOutLine = sessionKeyOutLineFromMaterial material
- }
- (algoSpec, ':' : keyHex) -> do
- algo <- parseAlgorithmOctet algoSpec
- keyBytes <- decodeHexBytes keyHex
- when (B.null keyBytes) $
- failWith BadData "decrypt: --with-session-key key material cannot be empty"
- pure
- DecryptSessionKey
- { decryptSessionKeyMaterial = BL.fromStrict (encodeOpenPGPSessionKey algo keyBytes)
- , decryptSessionKeyOutLine = Just (renderSessionKeyOutLine algo keyBytes)
- }
- _ -> failWith BadData "decrypt: invalid --with-session-key format"
-
-resolveSessionKeyOut ::
- Maybe String
- -> [DecryptSessionKey]
- -> [Pkt]
- -> [PKESKRecipientKey]
- -> [BL.ByteString]
- -> IO (Maybe String)
-resolveSessionKeyOut Nothing _ _ _ _ = pure Nothing
-resolveSessionKeyOut (Just _) sessionKeys ciphertextPkts recipientKeys passwordCandidates =
- case mapMaybe decryptSessionKeyOutLine sessionKeys of
- (line:_) -> pure (Just line)
- [] -> do
- discoveredLine <-
- recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates
- case discoveredLine of
- Just line -> pure (Just line)
- Nothing -> pure Nothing
-
-recoverSessionKeyOutFromCiphertext ::
- [Pkt] -> [PKESKRecipientKey] -> [BL.ByteString] -> IO (Maybe String)
-recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates =
- case recoverFromSKESK of
- Just line -> pure (Just line)
- Nothing -> recoverFromLegacyRSAPKESK
- where
- recoverFromSKESK =
- listToMaybe $
- mapMaybe
- (\(SKESKPayloadV4 sa s2k maybeEsk, passphrase) ->
- case maybeEsk of
- Nothing ->
- case skesk2Key (SKESK4Packet sa s2k Nothing) passphrase of
- Left _ -> Nothing
- Right sessionKey ->
- Just (renderSessionKeyOutLine (fromFVal sa) sessionKey)
- Just esk ->
- case skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase of
- Left _ -> Nothing
- Right (algo, sessionKey) ->
- Just (renderSessionKeyOutLine (fromFVal algo) sessionKey))
- [(payload, passphrase) | payload <- skeskPayloadsV4, passphrase <- passwordCandidates]
- skeskPayloadsV4 =
- mapMaybe
- (\pkt ->
- case pkt of
- SKESKPkt (SKESKPayloadV4Packet payload) -> Just payload
- _ -> Nothing)
- ciphertextPkts
- recoverFromLegacyRSAPKESK =
- recoverRSACombos [(mpi, rsaKey) | mpi <- rsaPKESKMPIs, rsaKey <- rsaRecipientKeys]
- recoverRSACombos [] = pure Nothing
- recoverRSACombos ((mpi, rsaKey):rest) = do
- encodedResult <- decryptLegacyRSAPKESK rsaKey mpi
- case encodedResult of
- Left _ -> recoverRSACombos rest
- Right encoded ->
- case decodeOpenPGPEncodedSessionKey encoded of
- Right (algo, keyBytes) ->
- pure (Just (renderSessionKeyOutLine (fromFVal algo) keyBytes))
- Left _ -> recoverRSACombos rest
- rsaPKESKMPIs =
- mapMaybe
- (\pkt ->
- case pkt of
- PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka (mpi :| [])))
- | pka == RSA || pka == DeprecatedRSAEncryptOnly ->
- Just mpi
- _ -> Nothing)
- ciphertextPkts
- rsaRecipientKeys =
- mapMaybe
- (\keyInfo ->
- case pkeskRecipientSKey keyInfo of
- RSAPrivateKey (RSA_PrivateKey privateKey) -> Just privateKey
- _ -> Nothing)
- recipientKeys
-
-decryptLegacyRSAPKESK :: RSA.PrivateKey -> MPI -> IO (Either String B.ByteString)
-decryptLegacyRSAPKESK privateKey mpi = do
- attempted <- P15.decryptSafer privateKey (mpiToCiphertext privateKey mpi)
- pure (first show attempted)
- where
- mpiToCiphertext rsaKey (MPI encodedMPI) =
- let modulusBytes = rsaModulusOctets rsaKey
- in i2ospOf_ modulusBytes encodedMPI
- rsaModulusOctets rsaKey =
- let modulusBits = integerBitLength (RSA.public_n (RSA.private_pub rsaKey))
- in max 1 ((modulusBits + 7) `div` 8)
- integerBitLength n
- | n <= 0 = 0
- | otherwise = go n 0
- where
- go 0 bits = bits
- go value bits = go (value `div` 2) (bits + 1)
-
-parseAlgorithmOctet :: String -> IO Word8
-parseAlgorithmOctet algoSpec =
- case readMaybe algoSpec :: Maybe Int of
- Just octet
- | octet >= 0 && octet <= 255 ->
- case toFVal (fromIntegral octet) :: SymmetricAlgorithm of
- OtherSA _ ->
- failWith
- BadData
- ("decrypt: unsupported --with-session-key algorithm: " ++ algoSpec)
- _ -> pure (fromIntegral octet)
- _ ->
- failWith
- BadData
- ("decrypt: invalid --with-session-key algorithm: " ++ algoSpec)
-
-decodeHexBytes :: String -> IO B.ByteString
-decodeHexBytes hex =
- if odd (length hex)
- then failWith BadData "decrypt: hex key material must have an even number of digits"
- else B.pack <$> go hex
- where
- go [] = pure []
- go (a:b:rest) = do
- hi <- nibble a
- lo <- nibble b
- (fromIntegral (hi * 16 + lo) :) <$> go rest
- go _ = failWith BadData "decrypt: malformed hex key material"
- nibble c =
- if isHexDigit c
- then pure (digitToInt c)
- else failWith BadData "decrypt: key material must be hexadecimal"
-
-isEncryptedPayloadPacket :: Pkt -> Bool
-isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True
-isEncryptedPayloadPacket SymEncDataPkt {} = True
-isEncryptedPayloadPacket _ = False
-
-isForwardCompatUnknownESKPacket :: Pkt -> Bool
-isForwardCompatUnknownESKPacket (OtherPacketPkt tag _) = tag == 1 || tag == 3
-isForwardCompatUnknownESKPacket (BrokenPacketPkt _ tag _) = tag == 1 || tag == 3
-isForwardCompatUnknownESKPacket _ = False
-
-isUnsupportedSKESKPacket :: Pkt -> Bool
-isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ s2k _))) = isUnknownS2K s2k
-isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ s2k _ _ _))) = isUnknownS2K s2k
-isUnsupportedSKESKPacket _ = False
-
-isUnknownS2K :: S2K -> Bool
-isUnknownS2K OtherS2K {} = True
-isUnknownS2K _ = False
-
-validateCiphertextPacketLayout :: [Pkt] -> IO ()
-validateCiphertextPacketLayout pkts =
- case findIndex isEncryptedPayloadPacket pkts of
- Nothing -> pure ()
- Just payloadIndex ->
- let trailing =
- filter (not . isMarkerPacketPacket) (drop (payloadIndex + 1) pkts)
- in when (not (null trailing)) $
- failWith
- BadData
- "decrypt input: malformed encrypted message structure (unexpected packets after encrypted data)"
-
-isMarkerPacketPacket :: Pkt -> Bool
-isMarkerPacketPacket MarkerPkt {} = True
-isMarkerPacketPacket _ = False
-
-validateDecryptedMessageStructure :: [Pkt] -> [Pkt] -> IO ()
-validateDecryptedMessageStructure rawPkts pkts = do
- let literalCount = length [() | LiteralDataPkt {} <- pkts]
- signatureCount = length [() | SignaturePkt {} <- pkts]
- onePassCount = length [() | OnePassSignaturePkt {} <- pkts]
- hasCompressedRaw = any isCompressedPacket rawPkts
- hasUnknownPackets = any isUnknownPacket rawPkts || any isUnknownPacket pkts
- maxCompressionDepth = maximum (0 : map compressionDepth rawPkts)
- when (any compressedPacketParseFailed rawPkts) $
- failWith BadData "decrypt failed: malformed compressed data stream"
- when (maxCompressionDepth > 2) $
- failWith BadData "decrypt failed: malformed encrypted message structure (excessive compression nesting)"
- when (hasCompressedRaw && any isMarkerPacket pkts) $
- failWith BadData "decrypt failed: malformed encrypted message structure (compressed marker packet)"
- when (any isDisallowedDecryptedPacketType pkts) $
- failWith BadData "decrypt failed: malformed encrypted message structure (unexpected packet type in plaintext)"
- when (literalCount == 0) $
- failWith BadData "decrypt failed: malformed encrypted message structure (no literal data payload found)"
- when (literalCount > 1) $
- failWith
- BadData
- "decrypt failed: malformed encrypted message structure (multiple literal payloads)"
- when (not hasUnknownPackets && onePassCount > 0 && signatureCount == 0) $
- failWith
- BadData
- "decrypt failed: malformed signed message structure (one-pass signature without trailing signature)"
- when (not hasUnknownPackets && signatureCount > 0 && onePassCount == 0 && not isOldStyleSignedMessage) $
- failWith
- BadData
- "decrypt failed: malformed signed message structure (trailing signature without one-pass signature)"
- where
- isOldStyleSignedMessage =
- case [ i | (i, LiteralDataPkt {}) <- packetPositions ] of
- [literalIndex] ->
- not (null signaturePositions) &&
- all (< literalIndex) signaturePositions
- _ -> False
- packetPositions = zip [0 :: Int ..] (filter (not . isMarkerPacket) pkts)
- signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]
-
-compressedPacketParseFailed :: Pkt -> Bool
-compressedPacketParseFailed pkt@CompressedDataPkt {} = isLeft (decompressPkt pkt)
-compressedPacketParseFailed _ = False
-
-recursivelyDecompressPacket pkt@CompressedDataPkt {} = do
- inner <- decompressPkt pkt
- concat <$> mapM recursivelyDecompressPacket inner
-recursivelyDecompressPacket pkt = Right [pkt]
-
-compressedPacketIsEmpty :: Pkt -> Bool
-compressedPacketIsEmpty pkt@CompressedDataPkt {} =
- case decompressPkt pkt of
- Right [] -> True
- _ -> False
-compressedPacketIsEmpty _ = False
-
-isCompressedPacket :: Pkt -> Bool
-isCompressedPacket CompressedDataPkt {} = True
-isCompressedPacket _ = False
-
-compressionDepth :: Pkt -> Int
-compressionDepth pkt@CompressedDataPkt {} =
- let inner = either (const []) id (decompressPkt pkt)
- in if null inner
- then 1
- else 1 + maximum (0 : map compressionDepth inner)
-compressionDepth _ = 0
-
-isMarkerPacket :: Pkt -> Bool
-isMarkerPacket MarkerPkt {} = True
-isMarkerPacket _ = False
-
-isUnknownPacket :: Pkt -> Bool
-isUnknownPacket OtherPacketPkt {} = True
-isUnknownPacket BrokenPacketPkt {} = True
-isUnknownPacket _ = False
-
-isDisallowedDecryptedPacketType :: Pkt -> Bool
-isDisallowedDecryptedPacketType PKESKPkt {} = True
-isDisallowedDecryptedPacketType SKESKPkt {} = True
-isDisallowedDecryptedPacketType PublicKeyPkt {} = True
-isDisallowedDecryptedPacketType PublicSubkeyPkt {} = True
-isDisallowedDecryptedPacketType SecretKeyPkt {} = True
-isDisallowedDecryptedPacketType SecretSubkeyPkt {} = True
-isDisallowedDecryptedPacketType SymEncDataPkt {} = True
-isDisallowedDecryptedPacketType SymEncIntegrityProtectedDataPkt {} = True
-isDisallowedDecryptedPacketType _ = False
-
-encodeOpenPGPSessionKey :: Word8 -> B.ByteString -> B.ByteString
-encodeOpenPGPSessionKey algo keyBytes =
- B.cons algo (keyBytes <> B.pack [fromIntegral (checksum `div` 256), fromIntegral checksum])
- where
- checksum :: Int
- checksum = B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536
-
-sessionKeyOutLineFromMaterial :: B.ByteString -> Maybe String
-sessionKeyOutLineFromMaterial raw = do
- (algo, keyBytes) <- decodeOpenPGPSessionKeyMaterial raw
- pure (renderSessionKeyOutLine algo keyBytes)
-
-decodeOpenPGPSessionKeyMaterial :: B.ByteString -> Maybe (Word8, B.ByteString)
-decodeOpenPGPSessionKeyMaterial raw = do
- (algo, body) <- B.uncons raw
- case toFVal (fromIntegral algo) :: SymmetricAlgorithm of
- OtherSA _ -> Nothing
- _ -> do
- let bodyLen = B.length body
- if bodyLen < 3
- then Nothing
- else do
- let keyBytes = B.take (bodyLen - 2) body
- checksumHi = fromIntegral (B.index body (bodyLen - 2)) :: Int
- checksumLo = fromIntegral (B.index body (bodyLen - 1)) :: Int
- checksumExpected = checksumHi * 256 + checksumLo
- checksumActual =
- B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536
- if B.null keyBytes || checksumActual /= checksumExpected
- then Nothing
- else Just (algo, keyBytes)
-
-renderSessionKeyOutLine :: Word8 -> B.ByteString -> String
-renderSessionKeyOutLine algo keyBytes =
- show algo ++ ":" ++ hexEncodeBytes keyBytes
-
-hexEncodeBytes :: B.ByteString -> String
-hexEncodeBytes = concatMap encodeByte . B.unpack
- where
- encodeByte w =
- [ nibble (w `shiftR` 4)
- , nibble (w .&. 0x0f)
- ]
- nibble n = "0123456789abcdef" !! fromIntegral n
-
-extractSingleLiteralPayload :: [Pkt] -> IO BL.ByteString
-extractSingleLiteralPayload pkts =
- case [p | LiteralDataPkt _ _ _ p <- pkts] of
- [payload] -> pure payload
- [] -> failWith BadData "decrypt failed: malformed encrypted message structure (no literal data payload found)"
- _ -> failWith BadData "decrypt failed: malformed encrypted message structure (multiple literal data payloads found)"
-
-doDecryptVerifyOutput ::
- POSIXTime
- -> [String]
- -> Maybe String
- -> Maybe String
- -> Maybe String
- -> [Pkt]
- -> IO ()
-doDecryptVerifyOutput cpt certFiles outFile notBeforeArg notAfterArg decryptedPkts = do
- when (null certFiles) $
- failWith
- IncompleteVerification
- "decrypt: verification requires at least one --verify-with cert"
- (krs, verifyTks) <- loadVerifyContext cpt certFiles
- upperBound <- verificationUpperBound cpt notAfterArg
- lowerBound <- verificationLowerBound cpt notBeforeArg
- verificationPkts <- normalizeDecryptVerificationPackets decryptedPkts
- let verifications = map (first show) (verifyPacketsBatch krs upperBound verificationPkts)
- filtered = filterByVerificationBounds lowerBound upperBound verifications
- successLines =
- map (renderSOPVerificationLine verifyTks) (rights filtered)
- renderedOut =
- if null successLines
- then ""
- else unlines successLines
- case outFile of
- Just path -> writeFileWithOutputExistsCheck "decrypt" path renderedOut
- Nothing -> pure ()
-
-normalizeDecryptVerificationPackets :: [Pkt] -> IO [Pkt]
-normalizeDecryptVerificationPackets pkts =
- case ([pkt | pkt@LiteralDataPkt {} <- pkts], [pkt | pkt@SignaturePkt {} <- pkts]) of
- ([], _) ->
- failWith
- CannotDecrypt
- "decrypt failed: no literal data payload found"
- ([lit], []) -> pure [lit]
- ([lit], sigs) -> pure (lit : sigs)
- (_, _) ->
- failWith
- BadData
- "decrypt failed: malformed signed message structure (multiple literal payloads)"
-
-resolveDecryptVerificationsOut ::
- Maybe String -> Maybe String -> IO (Maybe String, Bool)
-resolveDecryptVerificationsOut newPath oldPath =
- case (newPath, oldPath) of
- (Just p, Nothing) -> pure (Just p, False)
- (Nothing, Just p) -> pure (Just p, True)
- (Just pNew, Just pOld)
- | pNew == pOld -> pure (Just pNew, True)
- | otherwise ->
- failWith
- IncompatibleOptions
- "decrypt: --verifications-out and --verify-out cannot target different files"
- (Nothing, Nothing) -> pure (Nothing, False)
-
-renderSOPVerificationLine :: [TKUnknown] -> Verification -> String
-renderSOPVerificationLine verifyTks v =
- ts ++ " " ++ signerFp ++ " " ++ certFp ++ " " ++ modeLabel
- where
- sig = _verificationSignature v
- ts = renderSOPVerificationTimestamp sig
- signer = fingerprint (_verificationSigner v)
- signerFp = hexEncodeBytes (BL.toStrict (unFingerprint signer))
- modeLabel = signatureModeField sig
- certFp =
- case find (\tk -> keyMatchesFingerprint True tk signer) verifyTks of
- Just tk ->
- hexEncodeBytes
- (BL.toStrict (unFingerprint (fingerprint (fst (_tkuKey tk)))))
- Nothing -> signerFp
-
-signatureModeField :: SignaturePayload -> String
-signatureModeField sig =
- case sig of
- SigV4 CanonicalTextSig _ _ _ _ _ _ -> "mode:text"
- SigV6 CanonicalTextSig _ _ _ _ _ _ _ -> "mode:text"
- _ -> "mode:binary"
-
-renderSOPVerificationTimestamp :: SignaturePayload -> String
-renderSOPVerificationTimestamp sig =
- formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $
- case signatureCreationTime sig of
- Just t -> t
- Nothing -> posixSecondsToUTCTime 0
-
-writeFileWithOutputExistsCheck :: String -> FilePath -> String -> IO ()
-writeFileWithOutputExistsCheck subcommand path content = do
- ensureOutputPathAvailable subcommand path
- writeFile path content
-
-parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
-parseOpenPGPPackets context bytes =
- (do
- let packets = concatMap (either (const []) id . decompressPkt) (parsePkts bytes)
- _ <- evaluate (length packets)
- pure packets)
- `catch` parseFailure
- where
- parseFailure :: SomeException -> IO [Pkt]
- parseFailure err =
- failWith
- BadData
- (context ++ ": failed to parse OpenPGP packets: " ++ displayException err)
-
-parseRawOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
-parseRawOpenPGPPackets context bytes =
- (do
- let packets = parsePkts bytes
- _ <- evaluate (length packets)
- pure packets)
- `catch` parseFailure
- where
- parseFailure :: SomeException -> IO [Pkt]
- parseFailure err =
- failWith
- BadData
- (context ++ ": failed to parse OpenPGP packets: " ++ displayException err)
-
-validateDecryptPartialBodyEncoding :: BL.ByteString -> IO ()
-validateDecryptPartialBodyEncoding ciphertext =
- case ensureNoShortFirstPartialBodyChunk (BL.toStrict ciphertext) of
- Left err ->
- failWith
- BadData
- ("decrypt input: invalid partial body encoding (" ++ err ++ ")")
- Right () -> pure ()
-
-ensureNoShortFirstPartialBodyChunk :: B.ByteString -> Either String ()
-ensureNoShortFirstPartialBodyChunk = parsePackets
- where
- parsePackets bs
- | B.null bs = Right ()
- | otherwise = do
- (header, rest) <- noteLeft "truncated packet header" (B.uncons bs)
- if header .&. 0x80 /= 0x80
- then Left "invalid packet header octet"
- else do
- remaining <-
- if header .&. 0x40 == 0x40
- then parseNewPacketBody rest
- else parseOldPacketBody (header .&. 0x03) rest
- parsePackets remaining
-
- parseOldPacketBody lengthType bs =
- case lengthType of
- 0 -> do
- (lenOctet, rest) <- noteLeft "truncated old-format one-octet length" (B.uncons bs)
- dropExact "truncated old-format packet body" (fromIntegral lenOctet) rest
- 1 -> do
- (hi, afterHi) <- noteLeft "truncated old-format two-octet length" (B.uncons bs)
- (lo, rest) <- noteLeft "truncated old-format two-octet length" (B.uncons afterHi)
- let len = fromIntegral hi * 256 + fromIntegral lo
- dropExact "truncated old-format packet body" len rest
- 2 -> do
- (b1, afterB1) <- noteLeft "truncated old-format four-octet length" (B.uncons bs)
- (b2, afterB2) <- noteLeft "truncated old-format four-octet length" (B.uncons afterB1)
- (b3, afterB3) <- noteLeft "truncated old-format four-octet length" (B.uncons afterB2)
- (b4, rest) <- noteLeft "truncated old-format four-octet length" (B.uncons afterB3)
- let len =
- (fromIntegral b1 `shiftL` 24) +
- (fromIntegral b2 `shiftL` 16) +
- (fromIntegral b3 `shiftL` 8) +
- fromIntegral b4
- dropExact "truncated old-format packet body" len rest
- 3 -> Right B.empty
- _ -> Left "invalid old-format length type"
-
- parseNewPacketBody = parseNewLengthChunks True
-
- parseNewLengthChunks isFirstChunk bs = do
- (chunkLength, isPartial, afterLength) <- parseNewLength bs
- when (isFirstChunk && isPartial && chunkLength < 512) $
- Left
- ("first partial chunk is too short (" ++
- show chunkLength ++ " octets, minimum is 512)")
- afterChunk <- dropExact "truncated new-format packet body chunk" chunkLength afterLength
- if isPartial
- then parseNewLengthChunks False afterChunk
- else Right afterChunk
-
- parseNewLength bs = do
- (lengthOctet, rest) <- noteLeft "truncated new-format length" (B.uncons bs)
- case lengthOctet of
- _ | lengthOctet < 192 ->
- Right (fromIntegral lengthOctet, False, rest)
- | lengthOctet < 224 -> do
- (nextOctet, afterNext) <- noteLeft "truncated new-format two-octet length" (B.uncons rest)
- let len =
- ((fromIntegral lengthOctet - 192) `shiftL` 8) +
- fromIntegral nextOctet +
- 192
- Right (len, False, afterNext)
- | lengthOctet < 255 ->
- Right
- ( 1 `shiftL` fromIntegral (lengthOctet .&. 0x1f)
- , True
- , rest
- )
- | otherwise -> do
- (b1, afterB1) <- noteLeft "truncated new-format five-octet length" (B.uncons rest)
- (b2, afterB2) <- noteLeft "truncated new-format five-octet length" (B.uncons afterB1)
- (b3, afterB3) <- noteLeft "truncated new-format five-octet length" (B.uncons afterB2)
- (b4, afterB4) <- noteLeft "truncated new-format five-octet length" (B.uncons afterB3)
- let len =
- (fromIntegral b1 `shiftL` 24) +
- (fromIntegral b2 `shiftL` 16) +
- (fromIntegral b3 `shiftL` 8) +
- fromIntegral b4
- Right (len, False, afterB4)
-
- dropExact context n bs
- | B.length bs < n = Left context
- | otherwise = Right (B.drop n bs)
-
- noteLeft err = maybe (Left err) Right
-
-ensureOutputPathAvailable :: String -> FilePath -> IO ()
-ensureOutputPathAvailable subcommand path = do
- exists <- doesFileExist path
- when exists $
- failWith OutputExists (subcommand ++ ": output path already exists: " ++ path)
-
-loadVerifyKeyringMap :: POSIXTime -> [String] -> IO PublicKeyring
-loadVerifyKeyringMap cpt certFiles = fst <$> loadVerifyContext cpt certFiles
-
-loadVerifyContext :: POSIXTime -> [String] -> IO (PublicKeyring, [TKUnknown])
-loadVerifyContext _ certFiles = do
- allTks <-
- mapMaybe enforceVerifyPrimaryKeyPolicy .
- map sanitizeVerifyTK .
- concat <$>
- mapM (loadCertTKsFromFile "verify") certFiles
- let publicTks =
- mapMaybe
- (\tk ->
- case fromUnknownToTK tk of
- Right (SomePublicTK publicTk) -> Just publicTk
- _ -> Nothing)
- allTks
- keyring <- runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap
- pure (keyring, allTks)
-
-loadVerifyTKsFromFile :: String -> IO [TKUnknown]
-loadVerifyTKsFromFile path = do
- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
- certPkts <- decodeOpenPGPInput path lbs
- runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| CC.sinkList
-
-loadCertTKsFromFile :: String -> String -> IO [TKUnknown]
-loadCertTKsFromFile context path = do
- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
- certPkts <- decodeOpenPGPInput path lbs
- rejectSecretKeyPackets context path certPkts
- runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| CC.sinkList
-
-rejectSecretKeyPackets :: String -> String -> [Pkt] -> IO ()
-rejectSecretKeyPackets context path packets =
- when (any isSecretKeyPacket packets) $
- failWith
- BadData
- (context ++ ": certificate input contains secret key material in " ++ path)
- where
- isSecretKeyPacket SecretKeyPkt {} = True
- isSecretKeyPacket SecretSubkeyPkt {} = True
- isSecretKeyPacket _ = False
-
-sanitizeVerifyTK :: TKUnknown -> TKUnknown
-sanitizeVerifyTK tk =
- case primaryKeyIdentity (_tkuKey tk) of
- Nothing -> tk
- Just (primaryFp, primaryKeyId) ->
- tk
- { _tkuSubs =
- map
- (\(pkt, sigs) ->
- let sanitized = mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs
- in if isSubkeyPacket pkt
- then (pkt, sanitized)
- else (pkt, sigs))
- (_tkuSubs tk)
- }
- where
- isSubkeyPacket PublicSubkeyPkt {} = True
- isSubkeyPacket SecretSubkeyPkt {} = True
- isSubkeyPacket _ = False
-
-enforceVerifyPrimaryKeyPolicy :: TKUnknown -> Maybe TKUnknown
-enforceVerifyPrimaryKeyPolicy tk =
- if primaryKeyTooSmallForVerification (_tkuKey tk)
- then Nothing
- else Just tk
-
-primaryKeyTooSmallForVerification :: (SomePKPayload, Maybe SKAddendum) -> Bool
-primaryKeyTooSmallForVerification (pkp, _) =
- case _pkalgo pkp of
- RSA -> rsaTooSmall
- DeprecatedRSASignOnly -> rsaTooSmall
- DeprecatedRSAEncryptOnly -> rsaTooSmall
- _ -> False
- where
- rsaTooSmall =
- case pubkeySize (_pubkey pkp) of
- Right bits -> bits < 2048
- Left _ -> False
-
-primaryKeyIdentity :: (SomePKPayload, Maybe SKAddendum) -> Maybe (Fingerprint, EightOctetKeyId)
-primaryKeyIdentity (pkp, _) = do
- keyId <- either (const Nothing) Just (eightOctetKeyID pkp)
- pure (fingerprint pkp, keyId)
-
-sanitizeBindingSignature ::
- Fingerprint
- -> EightOctetKeyId
- -> SignaturePayload
- -> Maybe SignaturePayload
-sanitizeBindingSignature _ _ sig
- | hasUnsupportedCriticalSubpacket sig = Nothing
- | hasUnsupportedCriticalEmbeddedBacksig sig = Nothing
- | otherwise = Just sig
- where
- hasUnsupportedCriticalSubpacket sp =
- any isUnsupportedCriticalSubpacket (signatureHashedSubpackets sp)
- hasUnsupportedCriticalEmbeddedBacksig sp =
- any
- (\ssp ->
- case _sspPayload ssp of
- EmbeddedSignature embedded ->
- any
- isUnsupportedCriticalSubpacket
- (signatureHashedSubpackets embedded)
- _ -> False)
- (signatureHashedSubpackets sp)
- isUnsupportedCriticalSubpacket (SigSubPacket isCritical payload) =
- isCritical &&
- case payload of
- UserDefinedSigSub {} -> True
- OtherSigSub {} -> True
- NotationData {} -> True
- _ -> False
- signatureHashedSubpackets (SigV4 _ _ _ hasheds _ _ _) = hasheds
- signatureHashedSubpackets (SigV6 _ _ _ _ hasheds _ _ _) = hasheds
- signatureHashedSubpackets _ = []
-
-loadDecryptRecipientKeys ::
- POSIXTime -> [String] -> [BL.ByteString] -> IO [PKESKRecipientKey]
-loadDecryptRecipientKeys _ [] _ = pure []
-loadDecryptRecipientKeys cpt keyFiles passwords = concat <$> mapM loadFromFile keyFiles
- where
- loadFromFile path = do
- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
- packets <- decodeOpenPGPInput path lbs
- -- Build the set of fingerprints that are explicitly non-encryption-capable.
- -- Keys not resolvable via TK (processTK failure, bare material) are allowed.
- nonEncFps <- buildNonEncryptionFingerprintSet packets
- keys <- mapM (packetRecipientKey path nonEncFps) packets >>= pure . catMaybes
- let brokenSecretKeyErrors =
- nub
- [ err
- | BrokenPacketPkt err tag _ <- packets
- , tag == 5 || tag == 7
- ]
- when (null keys && not (null brokenSecretKeyErrors)) $
- failWith
- CannotDecrypt
- ("decrypt failed: could not load usable secret key material from " ++ path ++
- " (" ++ intercalate "; " brokenSecretKeyErrors ++ ")")
- pure keys
- -- Build a set of fingerprints that are EXPLICITLY non-encryption-capable.
- -- Only keys whose binding signature carries a KeyFlags subpacket that does
- -- NOT include any encryption bit are added. Keys with no binding-sig TK
- -- (processTK failed, bare secret material, etc.) are NOT blocked — we fall
- -- back to allowing them so that newly-generated or unusual keys still work.
- buildNonEncryptionFingerprintSet packets = do
- tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| CC.sinkList
- let normTks = rights (map (processTK (Just cpt)) tks)
- let tkDerived = S.fromList (concatMap nonEncryptionFingerprints normTks)
- rawDerived = S.fromList (explicitNonEncryptionSubkeyFingerprints packets)
- return (S.union tkDerived rawDerived)
- nonEncryptionFingerprints tk =
- -- Primary key: add to blocklist only if explicit key-flags are present
- -- and all of them exclude encryption usage.
- let (primaryPkp, _) = _tkuKey tk
- primaryFp = unFingerprint (fingerprint primaryPkp)
- primarySigs =
- concatMap snd (_tkuUIDs tk) ++
- concatMap snd (_tkuUAts tk) ++
- _tkuRevs tk
- primaryEntry = [ primaryFp | not (sigsAllowEncryption primarySigs) ]
- -- Subkeys: same rule as primary.
- subEntries =
- [ unFingerprint (fingerprint pkp)
- | (pkt, sigs) <- _tkuSubs tk
- , Just pkp <- [secretOrPublicSubkeyPayload pkt]
- , not (sigsAllowEncryption sigs)
- ]
- blocked = primaryEntry ++ subEntries
- in if tkHasAnyEncryptionCapableKey tk
- then blocked
- else []
- explicitNonEncryptionSubkeyFingerprints packets =
- let (mPending, blocked) = foldl' step (Nothing, []) packets
- in maybe blocked
- (\(fp, hasEnc, sawKeyFlags) -> finalize fp hasEnc sawKeyFlags blocked)
- mPending
- where
- step (mPending, blocked) pkt =
- case pkt of
- PublicSubkeyPkt pkp ->
- (Just (unFingerprint (fingerprint pkp), False, False), finalizePending mPending blocked)
- SecretSubkeyPkt pkp _ ->
- (Just (unFingerprint (fingerprint pkp), False, False), finalizePending mPending blocked)
- SignaturePkt sig ->
- case mPending of
- Nothing -> (Nothing, blocked)
- Just (fp, hasEnc, sawKeyFlags) ->
- let usableSig =
- if signatureHasUnsupportedCriticalSubpackets sig
- then []
- else keyFlagsFromSig sig
- hasEnc' = hasEnc || any hasEncryptionFlag usableSig
- sawKeyFlags' = sawKeyFlags || not (null usableSig)
- in (Just (fp, hasEnc', sawKeyFlags'), blocked)
- _ -> (Nothing, finalizePending mPending blocked)
- finalizePending Nothing blocked = blocked
- finalizePending (Just (fp, hasEnc, sawKeyFlags)) blocked =
- finalize fp hasEnc sawKeyFlags blocked
- finalize fp hasEnc sawKeyFlags blocked
- | sawKeyFlags && not hasEnc = fp : blocked
- | otherwise = blocked
- tkHasAnyEncryptionCapableKey tk =
- let (primaryPkp, _) = _tkuKey tk
- primarySigs =
- concatMap snd (_tkuUIDs tk) ++
- concatMap snd (_tkuUAts tk) ++
- _tkuRevs tk
- primaryAllows = supportsRecipientPKESKAlgorithm primaryPkp && sigsAllowEncryption primarySigs
- subAllows =
- any
- (\(pkt, sigs) ->
- case secretOrPublicSubkeyPayload pkt of
- Just pkp ->
- supportsRecipientPKESKAlgorithm pkp && sigsAllowEncryption sigs
- Nothing -> False)
- (_tkuSubs tk)
- in primaryAllows || subAllows
- sigsAllowEncryption [] = True
- sigsAllowEncryption sigs =
- let usableSigs = filter (not . signatureHasUnsupportedCriticalSubpackets) sigs
- flagSets = concatMap keyFlagsFromSig usableSigs
- in if null usableSigs
- then False
- else null flagSets || any hasEncryptionFlag flagSets
- hasEncryptionFlag flags =
- S.member EncryptCommunicationsKey flags ||
- S.member EncryptStorageKey flags
- keyFlagsFromSig sig =
- case sig of
- SigV4 _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds
- SigV6 _ _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds
- _ -> []
- signatureHasUnsupportedCriticalSubpackets sig =
- let hasheds =
- case sig of
- SigV4 _ _ _ hs _ _ _ -> hs
- SigV6 _ _ _ _ hs _ _ _ -> hs
- _ -> []
- in any isUnsupportedCritical hasheds
- isUnsupportedCritical (SigSubPacket isCritical payload) =
- isCritical &&
- case payload of
- OtherSigSub {} -> True
- UserDefinedSigSub {} -> True
- NotationData {} -> True
- _ -> False
- keyFlagsFromSubpackets subpackets =
- [ flags
- | SigSubPacket _ (KeyFlags flags) <- subpackets
- ]
- secretOrPublicSubkeyPayload (SecretSubkeyPkt pkp _) = Just pkp
- secretOrPublicSubkeyPayload (PublicSubkeyPkt pkp) = Just pkp
- secretOrPublicSubkeyPayload _ = Nothing
- packetRecipientKey path nonEncFps (SecretKeyPkt pkp ska) =
- let fp = unFingerprint (fingerprint pkp)
- in if S.member fp nonEncFps
- then pure Nothing
- else decryptRecipientKey path pkp ska
- packetRecipientKey path nonEncFps (SecretSubkeyPkt pkp ska) =
- let fp = unFingerprint (fingerprint pkp)
- in if S.member fp nonEncFps
- then pure Nothing
- else decryptRecipientKey path pkp ska
- packetRecipientKey _ _ _ = pure Nothing
- decryptRecipientKey path pkp ska =
- case secretKeyProtectionPolicyViolation pkp ska of
- Just violation ->
- failWith
- KeyIsProtected
- ("decrypt failed: unsupported secret key protection in " ++ path ++
- " (" ++ violation ++ ")")
- Nothing ->
- case ska of
- SUUnencrypted skey _ ->
- pure
- (Just
- (PKESKRecipientKey
- { pkeskRecipientPKPayload = Just pkp
- , pkeskRecipientSKey = skey
- }))
- _ ->
- case passwords of
- [] ->
- failWith
- KeyIsProtected
- ("decrypt failed: encrypted key in " ++ path ++ " requires --with-key-password")
- _ ->
- case tryDecryptKey passwords of
- Left _ ->
- failWith
- KeyIsProtected
- ("decrypt failed: could not decrypt key in " ++ path ++ " with provided --with-key-password values")
- Right (SUUnencrypted skey _) ->
- pure
- (Just
- (PKESKRecipientKey
- { pkeskRecipientPKPayload = Just pkp
- , pkeskRecipientSKey = skey
- }))
- Right _ ->
- failWith
- KeyIsProtected
- ("decrypt failed: unsupported secret key protection in " ++ path)
- where
- secretKeyProtectionPolicyViolation recipientPkp addendum =
- let rejectArgon2WithoutAEAD s2k
- | isArgon2S2K s2k =
- Just "Argon2 S2K is only allowed with AEAD-protected secret keys"
- | otherwise = Nothing
- rejectSimpleForV6 s2k
- | isSimpleS2K s2k =
- Just "v6 secret key packets MUST NOT use simple S2K"
- | otherwise = Nothing
- in case addendum of
- SUS16bit _ s2k _ _ ->
- case _keyVersion recipientPkp of
- V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k
- _ -> rejectArgon2WithoutAEAD s2k
- SUSSHA1 _ s2k _ _ ->
- case _keyVersion recipientPkp of
- V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k
- _ -> rejectArgon2WithoutAEAD s2k
- SUSym {} ->
- if _keyVersion recipientPkp == V6
- then
- Just
- "v6 secret key packets MUST NOT use legacy CFB secret-key protection"
- else Nothing
- _ -> Nothing
- isArgon2S2K Argon2 {} = True
- isArgon2S2K _ = False
- isSimpleS2K (Simple _) = True
- isSimpleS2K _ = False
- tryDecryptKey [] = Left ()
- tryDecryptKey (password:rest) =
- case decryptPrivateKey (pkp, ska) password of
- Left _ -> tryDecryptKey rest
- Right decrypted -> Right decrypted
-
-decodeOpenPGPInput :: String -> BL.ByteString -> IO [Pkt]
-decodeOpenPGPInput path input = do
- decodedArmors <- decodeAsciiArmorInput ("OpenPGP input in " ++ path) input
- case decodedArmors of
- Just armors ->
- case firstBy isOpenPGPArmorBlock armors of
- Just (Armor _ _ bs) ->
- parseOpenPGPPackets
- ("armored OpenPGP input in " ++ path)
- (BL.fromStrict (BLC8.toStrict bs))
- _ ->
- case firstBy isClearSignedArmor armors of
- Just _ ->
- failWith BadData ("Expected key data in " ++ path ++ ", got cleartext signature")
- _ -> parseOpenPGPPackets "OpenPGP input" input
- Nothing -> parseOpenPGPPackets "OpenPGP input" input
-
-loadRecipientPreferredHashes :: POSIXTime -> [String] -> IO [HashAlgorithm]
-loadRecipientPreferredHashes cpt certFiles =
- concat <$> mapM loadFromFile certFiles
- where
- loadFromFile path = do
- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
- pkts <- decodeOpenPGPInput path lbs
- rejectSecretKeyPackets "encrypt" path pkts
- tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| CC.sinkList
- normalized <- mapM (normalizeRecipient path) tks
- pure
- (concatMap (effectiveHashPreferencesAt cpt) normalized)
- normalizeRecipient path tk =
- case processTK (Just cpt) tk of
- Left err ->
- failWith
- BadData
- ("encrypt: invalid recipient certificate in " ++ path ++ ": " ++ show err)
- Right normalized -> pure normalized
-
-loadEncryptRecipients :: POSIXTime -> EncryptFor -> [String] -> IO [FunKey]
-loadEncryptRecipients cpt encPurpose certFiles = do
- recipients <- concat <$> mapM loadRecipientsFromFile certFiles
- if null recipients
- then
- failWith
- CertCannotEncrypt
- "encrypt: no supported recipient encryption keys found in provided certificates"
- else pure recipients
- where
- loadRecipientsFromFile path = do
- lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
- pkts <- decodeOpenPGPInput path lbs
- rejectSecretKeyPackets "encrypt" path pkts
- rejectCriticalUnknownRecipientPackets path pkts
- tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| CC.sinkList
- normalized <- mapM (normalizeEncryptRecipientTK path) tks
- let selected = selectEncryptRecipients encPurpose (concatMap (tkToFunKeysAt cpt) normalized)
- packetFallback =
- nub
- (concatMap tkToEncryptPayloads normalized ++
- mapMaybe extractEncryptRecipientPayload pkts)
- pure $
- case encPurpose of
- EncryptForAny
- | null selected -> map payloadToFunKey packetFallback
- _ -> selected
- normalizeEncryptRecipientTK path tk =
- case processTK (Just cpt) tk of
- Left err ->
- failWith
- BadData
- ("encrypt: invalid recipient certificate in " ++ path ++ ": " ++ show err)
- Right normalized ->
- if not (isTKTimeValid (posixSecondsToUTCTime (realToFrac cpt)) normalized)
- then
- failWith
- CertCannotEncrypt
- ("encrypt: recipient certificate in " ++ path ++ " is expired")
- else
- if not (primaryUserIDExpirationAllowsAt cpt normalized)
- then
- failWith
- CertCannotEncrypt
- ("encrypt: recipient certificate in " ++ path ++ " is expired")
- else pure normalized
- rejectCriticalUnknownRecipientPackets path =
- mapM_
- (\pkt ->
- case pkt of
- OtherPacketPkt tag _
- | tag < 40 ->
- if isForwardCompatRecipientPacketTag tag
- then pure ()
- else
- failWith
- BadData
- ("encrypt: invalid recipient certificate in " ++ path ++ ": critical unknown packet tag " ++ show tag)
- BrokenPacketPkt _ tag _
- | tag < 40 ->
- if isForwardCompatRecipientPacketTag tag
- then pure ()
- else
- failWith
- BadData
- ("encrypt: invalid recipient certificate in " ++ path ++ ": critical unknown packet tag " ++ show tag)
- _ -> pure ())
- isForwardCompatRecipientPacketTag tag = tag `elem` [5, 6, 7, 14]
- payloadToFunKey pkp = FunKey pkp Nothing S.empty [] [] False
-
-primaryUserIDExpirationAllowsAt :: POSIXTime -> TKUnknown -> Bool
-primaryUserIDExpirationAllowsAt now tk =
- case primaryUidSigs of
- [] -> True
- _ -> any (signatureKeyExpirationAllowsAt now primaryCreatedAt) primaryUidSigs
- where
- primaryCreatedAt = fromIntegral (_timestamp (fst (_tkuKey tk)))
- primaryUidSigs =
- [ sig
- | (_, sigs) <- _tkuUIDs tk
- , sig <- sigs
- , signatureMarksPrimaryUserId sig
- ]
-
-signatureMarksPrimaryUserId :: SignaturePayload -> Bool
-signatureMarksPrimaryUserId sig =
- any isPrimaryUIDSubpacket (signatureSubpackets sig)
- where
- isPrimaryUIDSubpacket (SigSubPacket _ (PrimaryUserId True)) = True
- isPrimaryUIDSubpacket _ = False
-
-signatureKeyExpirationAllowsAt :: POSIXTime -> POSIXTime -> SignaturePayload -> Bool
-signatureKeyExpirationAllowsAt now createdAt sig =
- case signatureKeyValiditySeconds sig of
- Nothing -> True
- Just 0 -> True
- Just validitySeconds -> now < createdAt + fromIntegral validitySeconds
-
-signatureKeyValiditySeconds :: SignaturePayload -> Maybe Integer
-signatureKeyValiditySeconds sig =
- listToMaybe
- [ fromIntegral secs
- | SigSubPacket _ (KeyExpirationTime (ThirtyTwoBitDuration secs)) <- signatureSubpackets sig
- ]
-
-selectEncryptRecipients :: EncryptFor -> [FunKey] -> [FunKey]
-selectEncryptRecipients encPurpose keys =
- chosen
- where
- supported = filter (supportsRecipientPKESKAlgorithm . fpkp) keys
- (matchingPurpose, unrestrictedPurpose) =
- partition (keyMatchesEncryptPurpose encPurpose . fkufs) supported
- chosen =
- case encPurpose of
- EncryptForAny
- | null matchingPurpose -> unrestrictedPurpose
- _ -> matchingPurpose
-
-
-tkToEncryptPayloads :: TKUnknown -> [SomePKPayload]
-tkToEncryptPayloads (TKUnknown (pkp, _) _ _ _ subs) =
- filter supportsRecipientPKESKAlgorithm (pkp : mapMaybe extractSubkeyPayload subs)
- where
- extractSubkeyPayload (PublicSubkeyPkt subPkp, _) = Just subPkp
- extractSubkeyPayload (SecretSubkeyPkt subPkp _, _) = Just subPkp
- extractSubkeyPayload _ = Nothing
-
-extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload
-extractEncryptRecipientPayload pkt =
- case pkt of
- PublicKeyPkt pkp
- | supportsRecipientPKESKAlgorithm pkp -> Just pkp
- PublicSubkeyPkt pkp
- | supportsRecipientPKESKAlgorithm pkp -> Just pkp
- SecretKeyPkt pkp _
- | supportsRecipientPKESKAlgorithm pkp -> Just pkp
- SecretSubkeyPkt pkp _
- | supportsRecipientPKESKAlgorithm pkp -> Just pkp
- _ -> Nothing
-
-keyMatchesEncryptPurpose :: EncryptFor -> S.Set KeyFlag -> Bool
-keyMatchesEncryptPurpose encPurpose keyFlags =
- not (S.null (keyFlags `S.intersection` encryptUsageFlags))
- where
- encryptUsageFlags =
- case encPurpose of
- EncryptForAny -> S.fromList [EncryptStorageKey, EncryptCommunicationsKey]
- EncryptForStorage -> S.singleton EncryptStorageKey
- EncryptForCommunications -> S.singleton EncryptCommunicationsKey
-
-supportsRecipientPKESKAlgorithm :: SomePKPayload -> Bool
-supportsRecipientPKESKAlgorithm pkp =
- _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, ElgamalEncryptOnly, ECDH, X25519, X448] &&
- hasSupportedRecipientIdentifierLength pkp
-
-hasSupportedRecipientIdentifierLength :: SomePKPayload -> Bool
-hasSupportedRecipientIdentifierLength pkp =
- let keyIdentifierLen = BL.length (unFingerprint (fingerprint pkp))
- in keyIdentifierLen == 16 || keyIdentifierLen == 20 || keyIdentifierLen == 32
-
-renderPKESKEncryptError :: PKESKEncryptError -> String
-renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm symAlgo err) =
- "unsupported session-key algorithm " ++ show symAlgo ++ ": " ++ err
-renderPKESKEncryptError (InvalidSessionKeyLength symAlgo expected got) =
- "invalid session-key length for " ++ show symAlgo ++
- " (expected " ++ show expected ++ ", got " ++ show got ++ ")"
-renderPKESKEncryptError (UnsupportedRecipientAlgorithm pka) =
- "unsupported recipient public-key algorithm: " ++ show pka
-renderPKESKEncryptError (InvalidRecipientKeyMaterial pka err) =
- "invalid recipient key material for " ++ show pka ++ ": " ++ err
-renderPKESKEncryptError (RecipientKdfFailure pka err) =
- "recipient KDF failure for " ++ show pka ++ ": " ++ err
-renderPKESKEncryptError (RecipientKeyWrapFailure pka err) =
- "recipient key-wrap failure for " ++ show pka ++ ": " ++ err
-renderPKESKEncryptError (PayloadBuildFailure err) = "payload build failure: " ++ err
-renderPKESKEncryptError NoRecipientsProvided = "no recipients were provided"
-renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) =
- "recipient capability selection failure: " ++ show err
-renderPKESKEncryptError (InvalidRecipientIdentifier err) =
- "invalid recipient identifier: " ++ err
-
-sopFailureForPKESKEncryptError :: PKESKEncryptError -> SopFailure
-sopFailureForPKESKEncryptError err =
- case err of
- UnsupportedRecipientAlgorithm _ -> UnsupportedAsymmetricAlgo
- RecipientCapabilitySelectionFailure _ -> CertCannotEncrypt
- NoRecipientsProvided -> CertCannotEncrypt
- _ -> BadData
-
--- | Resolve a PKESK recipient key using two strategies depending on whether
--- the probe carries a wildcard recipient ID (eight zero bytes) or a real key
--- ID / fingerprint.
---
--- * Non-wildcard probes: the callback is invoked once for each PKESK attempt,
--- so we do an idempotent lookup by recipient identifier from the full
--- candidate list to avoid consuming keys needed by later PKESKs.
---
--- * Wildcard probes (all-zero legacy recipient ID): hOpenPGP retries the
--- callback after failed unwrap attempts. We therefore pop one candidate from
--- a shared queue on each callback invocation.
-selectRecipientKeyInfosByRecipientIdentifier ::
- [PKESKRecipientKey]
- -> KeyIdentifier
- -> PubKeyAlgorithm
- -> IO [PKESKRecipientKey]
-selectRecipientKeyInfosByRecipientIdentifier keyInfos keyIdentifier pka =
- pure $
- case keyIdentifier of
- KeyIdentifierWildcard -> compatible
- KeyIdentifierEightOctet recipientKeyId ->
- filter (matchesLegacyRecipientKeyId recipientKeyId) compatible
- KeyIdentifierFingerprint recipientFingerprint ->
- filter (matchesRecipientIdentifier (unFingerprint recipientFingerprint)) compatible
- where
- compatible =
- [ keyInfo
- | keyInfo <- keyInfos
- , supportsPKESKAlgorithm pka keyInfo
- ]
-
-prioritizeDecryptablePKESKs :: [PKESKRecipientKey] -> [Pkt] -> [Pkt]
-prioritizeDecryptablePKESKs keyInfos pkts =
- nonMatchingPrefix ++ matchingPrefix ++ suffix
- where
- (prefix, suffix) = break isEncryptedPayloadPacket pkts
- (matchingPrefix, nonMatchingPrefix) =
- partition
- (\pkt ->
- case pkt of
- PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)) ->
- any (matchesRecipientIdentifier rid) keyInfos
- PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ eoki _ _)) ->
- any (matchesLegacyRecipientKeyId eoki) keyInfos
- _ -> False)
- prefix
-
-supportsPKESKAlgorithm :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool
-supportsPKESKAlgorithm pka keyInfo =
- case pkeskRecipientSKey keyInfo of
- RSAPrivateKey {} -> pka == RSA || pka == DeprecatedRSAEncryptOnly
- ElGamalPrivateKey {} -> pka == ElgamalEncryptOnly
- ECDHPrivateKey {} -> pka == ECDH || pka == X25519
- X25519PrivateKey {} -> pka == X25519
- X448PrivateKey {} -> pka == X448
- UnknownSKey {} ->
- (pka == X25519 || pka == X448) &&
- case pkeskRecipientPKPayload keyInfo of
- Just pkp -> _pkalgo pkp == pka
- Nothing -> False
- _ -> False
-
-matchesRecipientIdentifier :: BL.ByteString -> PKESKRecipientKey -> Bool
-matchesRecipientIdentifier rid keyInfo =
- case pkeskRecipientPKPayload keyInfo of
- Nothing -> False
- Just pkp ->
- let identifier = BL.toStrict rid
- fps = recipientFingerprintsForMatch pkp
- in any (identifier `elem`) (map recipientIdMatchVariants fps)
-
-recipientFingerprintsForMatch :: SomePKPayload -> [B.ByteString]
-recipientFingerprintsForMatch pkp =
- baseFp : maybeToList normalizedX25519Fp
- where
- baseFp = BL.toStrict (unFingerprint (fingerprint pkp))
- normalizedX25519Fp =
- BL.toStrict . unFingerprint . fingerprint <$> normalizeX25519CompatiblePKP pkp
-
-normalizeX25519CompatiblePKP :: SomePKPayload -> Maybe SomePKPayload
-normalizeX25519CompatiblePKP pkp =
- case _pubkey pkp of
- ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->
- Just
- (PKPayload
- (_keyVersion pkp)
- (_timestamp pkp)
- (_v3exp pkp)
- X25519
- (_pubkey pkp))
- _ -> Nothing
-
-recipientIdMatchVariants :: B.ByteString -> [B.ByteString]
-recipientIdMatchVariants fp =
- [ fp
- , B.cons 0x04 fp
- , B.cons 0x06 fp
- , B.cons 0xFE fp
- ]
-
-matchesLegacyRecipientKeyId :: EightOctetKeyId -> PKESKRecipientKey -> Bool
-matchesLegacyRecipientKeyId eoki keyInfo =
- case pkeskRecipientPKPayload keyInfo of
- Nothing -> False
- Just pkp ->
- case eightOctetKeyID pkp of
- Right keyId -> keyId == eoki
- Left _ -> False
-
-decodeCiphertextInput :: BL.ByteString -> IO BL.ByteString
-decodeCiphertextInput input = do
- decodedArmors <- decodeAsciiArmorInput "decrypt input" input
- case decodedArmors of
- Just armors ->
- case firstBy isArmorMessageBlock armors of
- Just (Armor ArmorMessage _ bs) -> return (BL.fromStrict (BLC8.toStrict bs))
- _ ->
- case firstBy isOpenPGPArmorBlock armors of
- Just _ ->
- failWith
- BadData
- "decrypt expects an armored OpenPGP message"
- _ -> return input
- Nothing -> return input
-
-doInlineSign :: POSIXTime -> InlineSignOptions -> IO ()
-doInlineSign pt InlineSignOptions {..} = do
- when (inlineSignNoArmor && inlineSignArmor) $
- failWith IncompatibleOptions "inline-sign: --armor and --no-armor are mutually exclusive"
- forM_
- inlineSignProfile
- (\profile ->
- failWith UnsupportedOption
- ("inline-sign: unsupported option --profile=" ++ profile))
- let inlineMode = fromMaybe InlineSignAsBinary inlineSignAs
- mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
- when (inlineMode /= InlineSignAsBinary) $
- ensureUTF8TextInput "inline-sign" (BL.fromChunks mbs)
- signingPasswordsRaw <- loadPasswordFiles "inline-sign" "--with-key-password" inlineSignKeyPasswords
- let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw
- ks <- loadSigningKeys inlineSignKeyFiles signingPasswords
- processedKeys <- mapM (normalizeSigningKey pt) ks
- let ts = ThirtyTwoBitTimeStamp (floor pt)
- payloadRaw = BL.fromChunks mbs
- funkeys = concatMap (tkToFunKeysAt pt) processedKeys
- signingKeys = filter isInlineRSASigner funkeys
- inlineSignHash = selectSigningHash signingKeys [] legacySigningHashFallbackOrder
- when (null signingKeys) $
- failWith MissingInput "inline-sign: no signing-capable key found"
- sigs <-
- mapM
- (signInlineData
- ts
- (inlineSignSignatureMode inlineMode)
- inlineSignHash
- payloadRaw)
- signingKeys
- case inlineMode of
- InlineSignAsClearSigned -> doInlineSignCleartext inlineSignHash payloadRaw sigs
- InlineSignAsText -> doInlineSignText payloadRaw sigs
- InlineSignAsBinary -> doInlineSignBinary payloadRaw sigs
- where
- inlineSignSignatureMode mode =
- case mode of
- InlineSignAsBinary -> AsBinary
- InlineSignAsText -> AsText
- InlineSignAsClearSigned -> AsText
- doInlineSignCleartext inlineSignHash payloadRaw sigs = do
- when inlineSignNoArmor $
- failWith
- IncompatibleOptions
- "inline-sign --as=clearsigned requires armored output"
- let cleartextPayload =
- if not (BL.null payloadRaw) && BL.last payloadRaw == 0x0a
- then payloadRaw <> BL.singleton 0x0a
- else payloadRaw
- sigBytes = runPut $ mapM_ (Bin.put . SignaturePkt) sigs
- hashHeader = ("Hash", hashAlgorithmHeaderName inlineSignHash)
- clearSigned =
- ClearSigned
- [hashHeader]
- (BLC8.fromStrict (BL.toStrict cleartextPayload))
- (Armor ArmorSignature [] (BLC8.fromStrict (BL.toStrict sigBytes)))
- BLC8.putStr (AA.encodeLazy [clearSigned])
- doInlineSignText payloadRaw sigs =
- doInlineSignMessage UTF8Data payloadRaw sigs
- doInlineSignBinary payloadRaw sigs = do
- doInlineSignMessage BinaryData payloadRaw sigs
- doInlineSignMessage literalDataType payloadRaw sigs = do
- let pktBytes =
- runPut $
- Bin.put
- (Block
- (map SignaturePkt sigs ++
- [LiteralDataPkt literalDataType BL.empty 0 payloadRaw]))
- BL.putStr $
- if not inlineSignNoArmor && not inlineSignArmor
- then AA.encodeLazy [Armor ArmorMessage [] pktBytes]
- else if inlineSignArmor
- then AA.encodeLazy [Armor ArmorMessage [] pktBytes]
- else pktBytes
-
-inlineSignModeReader :: String -> Either String InlineSignMode
-inlineSignModeReader "binary" = Right InlineSignAsBinary
-inlineSignModeReader "text" = Right InlineSignAsText
-inlineSignModeReader "clearsigned" = Right InlineSignAsClearSigned
-inlineSignModeReader _ =
- Left "signature mode must be one of: binary, text, clearsigned"
-
-isInlineSigningCapable :: FunKey -> Bool
-isInlineSigningCapable k =
- (S.null (fkufs k) || S.member SignDataKey (fkufs k)) &&
- case fmska k of
- Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
- Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
- Just (SUUnencrypted (UnknownSKey _) _) ->
- isEd25519PKA (_pkalgo (fpkp k)) || isEdDSAPKA (_pkalgo (fpkp k)) || isEd448PKA (_pkalgo (fpkp k))
- _ -> False
-
--- Legacy alias.
-isInlineRSASigner :: FunKey -> Bool
-isInlineRSASigner = isInlineSigningCapable
-
-signInlineData ::
- ThirtyTwoBitTimeStamp
- -> AsBinaryText
- -> HashAlgorithm
- -> BL.ByteString
- -> FunKey
- -> IO SignaturePayload
-signInlineData ts mode signHash payload k =
- do
- issuerPackets <- inlineUnhashed (fpkp k)
- signWithKey
- "inline-sign"
- (fpkp k)
- sigType
- signHash
- (inlineHashed (fpkp k) ts)
- issuerPackets
- payload
- (fmska k)
- where
- sigType =
- case mode of
- AsBinary -> BinarySig
- AsText -> CanonicalTextSig
-
-inlineHashed :: SomePKPayload -> ThirtyTwoBitTimeStamp -> [SigSubPacket]
-inlineHashed pkp ts =
- [ SigSubPacket False (SigCreationTime ts)
- , SigSubPacket False (IssuerFingerprint (issuerFingerprintVersionFor pkp) (fingerprint pkp))
- ]
-
-inlineUnhashed :: SomePKPayload -> IO [SigSubPacket]
-inlineUnhashed pkp =
- issuerSubpacketsFor "inline-sign" pkp
-
-doInlineDetach :: POSIXTime -> InlineDetachOptions -> IO ()
-doInlineDetach _ InlineDetachOptions {..} = do
- ensureOutputPathAvailable "inline-detach" inlineDetachOutputSigs
- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
- (msgData, sigPkts) <- splitInlineSigned input
- writeDetachedSignatures inlineDetachNoArmor inlineDetachOutputSigs sigPkts
- BL.putStr msgData
-
-splitInlineSigned :: BL.ByteString -> IO (BL.ByteString, [Pkt])
-splitInlineSigned lbs = do
- decodedArmors <- decodeAsciiArmorInput "inline-detach input" lbs
- case decodedArmors of
- Just armors ->
- case firstBy isInlineSignedArmorCandidate armors of
- Just (Armor ArmorMessage _ bs) ->
- parseOpenPGPPackets
- "inline-detach armored message"
- (BL.fromStrict (BLC8.toStrict bs)) >>=
- splitInlineSignedPackets
- Just (ClearSigned headers cleartext signatureArmor) -> do
- validateClearSignedHeaders headers
- sigPkts <- clearSignedSignaturePackets signatureArmor
- return (BL.fromStrict (BLC8.toStrict cleartext), sigPkts)
- _ -> parseOpenPGPPackets "inline-detach input" lbs >>= splitInlineSignedPackets
- Nothing -> parseOpenPGPPackets "inline-detach input" lbs >>= splitInlineSignedPackets
-
-firstBy :: (a -> Bool) -> [a] -> Maybe a
-firstBy predicate = find predicate
-
-decodeAsciiArmorInput :: String -> BL.ByteString -> IO (Maybe [Armor])
-decodeAsciiArmorInput context input =
- case validateAsciiArmorEnvelope input of
- Just err ->
- failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
- Nothing -> do
- let primaryDecode = AA.decodeLazy input :: Either String [Armor]
- case primaryDecode of
- Right (_:_) -> pure (Just (fromRight [] primaryDecode))
- _ -> do
- let normalizedInput = normalizeAsciiArmorForLenientDecode input
- fallbackDecode =
- if normalizedInput /= input
- then AA.decodeLazy normalizedInput :: Either String [Armor]
- else primaryDecode
- case fallbackDecode of
- Right [] | looksLikeAsciiArmor input ->
- failWith BadData (context ++ ": malformed ASCII armor: no armor blocks found")
- Right [] -> pure Nothing
- Right armors -> pure (Just armors)
- Left err
- | looksLikeAsciiArmor input ->
- failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
- | otherwise -> pure Nothing
-
-normalizeAsciiArmorForLenientDecode :: BL.ByteString -> BL.ByteString
-normalizeAsciiArmorForLenientDecode input
- | not (looksLikeAsciiArmor input) = input
- | otherwise =
- BL.fromStrict .
- TE.encodeUtf8 .
- T.unlines .
- normalizeAsciiArmorLines $
- T.lines normalizedLineEndings
- where
- normalizedLineEndings =
- T.replace
- (T.pack "\r")
- (T.pack "\n")
- (T.replace (T.pack "\r\n") (T.pack "\n") (TE.decodeUtf8 (BL.toStrict input)))
-
-data LenientArmorDecodeState
- = LenientOutsideArmor
- | LenientArmorHeaders Bool Bool
- | LenientArmorBody Bool
-
-normalizeAsciiArmorLines :: [Text] -> [Text]
-normalizeAsciiArmorLines = go LenientOutsideArmor
- where
- go _ [] = []
- go state (line:rest) =
- let trimmedLine = T.dropWhileEnd isSpace line
- whitespaceOnly = T.all isSpace line
- beginLabel = beginArmorLabelText trimmedLine
- isBegin = isJust beginLabel
- isEnd = T.isPrefixOf (T.pack "-----END PGP ") trimmedLine
- hasHeaderSeparator = T.any (== ':') trimmedLine
- in case state of
- LenientOutsideArmor
- | isBegin ->
- let isClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
- shouldStripHeaders = not isClearSigned
- in trimmedLine : go (LenientArmorHeaders shouldStripHeaders isClearSigned) rest
- | otherwise -> trimmedLine : go LenientOutsideArmor rest
- LenientArmorHeaders stripHeaders isClearSigned
- | whitespaceOnly -> T.empty : go (LenientArmorBody isClearSigned) rest
- | isEnd -> T.empty : trimmedLine : go LenientOutsideArmor rest
- | stripHeaders && hasHeaderSeparator ->
- go (LenientArmorHeaders stripHeaders isClearSigned) rest
- | otherwise -> trimmedLine : go (LenientArmorBody isClearSigned) rest
- LenientArmorBody isClearSigned
- | isEnd -> trimmedLine : go LenientOutsideArmor rest
- | isBegin ->
- let nestedClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
- shouldStripHeaders = not nestedClearSigned
- in trimmedLine : go (LenientArmorHeaders shouldStripHeaders nestedClearSigned) rest
- | otherwise ->
- let bodyLine =
- if isClearSigned
- then line
- else trimmedLine
- in bodyLine : go (LenientArmorBody isClearSigned) rest
-
-beginArmorLabelText :: Text -> Maybe Text
-beginArmorLabelText line = do
- rest <- T.stripPrefix (T.pack "-----BEGIN PGP ") line
- T.stripSuffix (T.pack "-----") rest
-
-validateClearSignedHeaders :: [(String, String)] -> IO ()
-validateClearSignedHeaders headers =
- unless (all (isAllowedHeaderKey . fst) headers) $
- failWith BadData "cleartext signed message contains unsupported armor headers"
- where
- isAllowedHeaderKey key =
- map toLower key `elem` ["hash"]
-
-validateClearSignedEnvelopeBounds :: BL.ByteString -> IO ()
-validateClearSignedEnvelopeBounds input = do
- let text = TE.decodeUtf8With lenientDecode (BL.toStrict input)
- normalized = T.replace (T.pack "\r") (T.pack "") text
- ls = T.lines normalized
- beginMarker = T.pack "-----BEGIN PGP SIGNED MESSAGE-----"
- endMarker = T.pack "-----END PGP SIGNATURE-----"
- firstBegin = findIndex ((== beginMarker) . T.strip) ls
- hasVisibleText line = not (T.all isSpace line)
- findIndexFrom start predicate =
- fmap (+ start) (findIndex predicate (drop start ls))
- case firstBegin of
- Nothing -> pure ()
- Just beginIx -> do
- when (any hasVisibleText (take beginIx ls)) $
- failWith BadData "cleartext signed message has non-whitespace text before armor header"
- case findIndexFrom beginIx ((== endMarker) . T.strip) of
- Nothing -> pure ()
- Just endIx ->
- when (any hasVisibleText (drop (endIx + 1) ls)) $
- failWith BadData "cleartext signed message has non-whitespace text after signature block"
-
-looksLikeAsciiArmor :: BL.ByteString -> Bool
-looksLikeAsciiArmor input =
- BLC8.pack "-----BEGIN PGP " `BL.isPrefixOf`
- BLC8.dropWhile isAsciiArmorLeadingWhitespace input
-
-isAsciiArmorLeadingWhitespace :: Char -> Bool
-isAsciiArmorLeadingWhitespace c = c `elem` [' ', '\t', '\r', '\n']
-
-validateAsciiArmorEnvelope :: BL.ByteString -> Maybe String
-validateAsciiArmorEnvelope input
- | not (looksLikeAsciiArmor input) = Nothing
- | otherwise = validateArmorBlocks (BLC8.lines (BLC8.dropWhile isAsciiArmorLeadingWhitespace input))
-
-validateArmorBlocks :: [BL.ByteString] -> Maybe String
-validateArmorBlocks [] = Nothing
-validateArmorBlocks (line:rest) =
- case beginArmorLabel line of
- -- UPSTREAM: openpgp-asciiarmor should export detectCleartextSignedBlock helper
- -- to encapsulate this RFC 4880 cleartext signature framework detection
- Just "SIGNED MESSAGE" -> validateClearSignedBlock rest
- Just label -> validateBinaryArmorBlock label rest
- Nothing -> Nothing
-
-validateClearSignedBlock :: [BL.ByteString] -> Maybe String
-validateClearSignedBlock ls =
- case break hasBeginArmorLabel ls of
- (_, []) ->
- Just "cleartext signed message is missing an armored signature block"
- (_, beginLine:rest) ->
- case beginArmorLabel beginLine of
- Just "SIGNATURE" -> validateBinaryArmorBlock "SIGNATURE" rest
- Just label ->
- Just
- ("cleartext signed message must be followed by a PGP SIGNATURE block, found PGP " ++
- label)
- Nothing -> Just "cleartext signed message has an invalid armored signature header"
-
-validateBinaryArmorBlock :: String -> [BL.ByteString] -> Maybe String
-validateBinaryArmorBlock label ls =
- case break hasEndArmorLabel ls of
- (_, []) -> Just ("missing END PGP " ++ label ++ " footer")
- (_, endLine:rest) ->
- case endArmorLabel endLine of
- Just endLabel
- | endLabel == label -> validateArmorBlocks rest
- | otherwise ->
- Just
- ("mismatched footer: expected END PGP " ++
- label ++ ", found END PGP " ++ endLabel)
- Nothing -> Just ("invalid END PGP " ++ label ++ " footer")
-
-hasBeginArmorLabel :: BL.ByteString -> Bool
-hasBeginArmorLabel = isJust . beginArmorLabel
-
-hasEndArmorLabel :: BL.ByteString -> Bool
-hasEndArmorLabel = isJust . endArmorLabel
-
-beginArmorLabel :: BL.ByteString -> Maybe String
-beginArmorLabel = armorBoundaryLabel "-----BEGIN PGP " "-----"
-
-endArmorLabel :: BL.ByteString -> Maybe String
-endArmorLabel = armorBoundaryLabel "-----END PGP " "-----"
-
-armorBoundaryLabel :: String -> String -> BL.ByteString -> Maybe String
-armorBoundaryLabel prefix suffix line = do
- rest <- stripPrefix prefix (BLC8.unpack line)
- if suffix `isSuffixOf` rest
- then pure (take (length rest - length suffix) rest)
- else Nothing
-
-isOpenPGPArmorBlock :: Armor -> Bool
-isOpenPGPArmorBlock (Armor _ _ _) = True
-isOpenPGPArmorBlock _ = False
-
-isArmorMessageBlock :: Armor -> Bool
-isArmorMessageBlock (Armor ArmorMessage _ _) = True
-isArmorMessageBlock _ = False
-
-isDetachedSignatureArmor :: Armor -> Bool
-isDetachedSignatureArmor (Armor ArmorSignature _ _) = True
-isDetachedSignatureArmor _ = False
-
-isDetachedSignatureUnsupportedArmor :: Armor -> Bool
-isDetachedSignatureUnsupportedArmor (Armor _ _ _) = True
-isDetachedSignatureUnsupportedArmor ClearSigned {} = True
-
-isClearSignedArmor :: Armor -> Bool
-isClearSignedArmor ClearSigned {} = True
-isClearSignedArmor _ = False
-
-isInlineSignedArmorCandidate :: Armor -> Bool
-isInlineSignedArmorCandidate (Armor ArmorMessage _ _) = True
-isInlineSignedArmorCandidate ClearSigned {} = True
-isInlineSignedArmorCandidate _ = False
-
-splitInlineSignedPackets :: [Pkt] -> IO (BL.ByteString, [Pkt])
-splitInlineSignedPackets pkts = do
- let msgPkts = [p | p@LiteralDataPkt {} <- pkts]
- sigPkts = [p | p@SignaturePkt {} <- pkts]
- case msgPkts of
- [LiteralDataPkt _ _ _ payload]
- | null sigPkts ->
- failWith BadData "inline-detach input has no signatures"
- | otherwise -> return (payload, sigPkts)
- [] -> failWith BadData "inline-detach input has no literal message payload"
- _ ->
- failWith
- BadData
- "inline-detach input contains multiple literal payloads"
-
-writeDetachedSignatures :: Bool -> String -> [Pkt] -> IO ()
-writeDetachedSignatures noArmor outPath sigPkts = do
- let sigBytes = runPut $ mapM_ Bin.put sigPkts
- out =
- if noArmor
- then sigBytes
- else BL.fromStrict (BLC8.toStrict (AA.encodeLazy [Armor ArmorSignature [] sigBytes]))
- BL.writeFile outPath out
-
-doListProfiles :: ListProfilesOptions -> IO ()
-doListProfiles (ListProfilesOptions sc) =
- case sc of
- "generate-key" ->
- putStr
- "default: implementation defaults\nrfc4880: RSA-4096 interoperability-focused key generation\ncompatibility: broad interoperability defaults (alias of rfc4880)\nsecurity: security-oriented key generation\nperformance: performance-oriented key generation\n"
- "encrypt" ->
- putStr
- "default: implementation defaults (alias of rfc9580, security, and performance)\nrfc9580: RFC 9580 packet format preferences\nrfc4880: RFC 4880 packet format preferences\ncompatibility: broad interoperability defaults (alias of rfc4880)\n"
- _ -> failWith UnsupportedProfile "Subcommand does not support profiles"
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RecordWildCards #-}
+
+import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
+import Codec.Encryption.OpenPGP.ASCIIArmor.Types
+ ( Armor (..)
+ , ArmorType (..)
+ )
+import Codec.Encryption.OpenPGP.Compression
+ ( CompressionError
+ , decompressPkt
+ , renderCompressionError
+ )
+import Codec.Encryption.OpenPGP.Encrypt
+ ( PKESKEncryptError (..)
+ , PKESKSessionMaterial (..)
+ , RecipientEncryptRequest (..)
+ , RecipientEncryptRequestOverrides (..)
+ , RecipientEncryptResult (..)
+ , RecipientPKESKVersionStrategy (..)
+ , RecipientPayloadShape (..)
+ , defaultRecipientPayloadShape
+ , encryptForRecipients
+ , recipientEncryptionTarget
+ , recipientEncryptionTargetWithStrategy
+ )
+import Codec.Encryption.OpenPGP.Expirations
+ ( effectiveKeyPreferencesAt
+ , isTKTimeValid
+ )
+import Codec.Encryption.OpenPGP.Fingerprint
+ ( eightOctetKeyID
+ , fingerprint
+ )
+import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
+import Codec.Encryption.OpenPGP.Message
+ ( EncryptMessageOptions (..)
+ , RecoveredSessionMaterial (..)
+ , SessionMaterialExposure (..)
+ , encryptMessage
+ , encryptedPayloadBytes
+ , mkClearPayload
+ , mkPassphrase
+ )
+import Codec.Encryption.OpenPGP.Ontology
+ ( isKUF
+ , isPKBindingSig
+ , isSKBindingSig
+ )
+import Codec.Encryption.OpenPGP.Policy
+ ( defaultDecryptPolicy
+ , defaultPolicy
+ , lenientDecryptPolicy
+ )
+import Codec.Encryption.OpenPGP.S2K
+ ( decodeOpenPGPEncodedSessionKey
+ , skesk2Key
+ , skesk2SessionKey
+ )
+import Codec.Encryption.OpenPGP.SecretKey
+ ( decryptPrivateKey
+ , encryptPrivateKey
+ )
+import Codec.Encryption.OpenPGP.Serialize (parsePkts)
+import Codec.Encryption.OpenPGP.Signatures
+ ( SignError (..)
+ , renderSignError
+ , signCertRevocationWithRSA
+ , signDataWithEd25519
+ , signDataWithEd25519Legacy
+ , signDataWithEd25519V6
+ , signDataWithEd448
+ , signDataWithEd448V6
+ , signDataWithRSABuilder
+ , signDataWithRSAV6
+ , signKeyRevocationWithRSA
+ , signUserIDwithRSA
+ , verifyAgainstKeys
+ , verifySigWith
+ , verifyUnknownTKWith
+ )
+import qualified Codec.Encryption.OpenPGP.Subpackets as SP
+import Codec.Encryption.OpenPGP.Types
+import Control.Applicative (many, optional, some, (<|>))
+import Control.Error.Util (hush, note)
+import Control.Exception
+ ( IOException
+ , SomeException
+ , catch
+ , displayException
+ , evaluate
+ , throwIO
+ )
+import Control.Monad (forM, forM_, join, unless, when, (>=>))
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)
+import Crypto.Error (eitherCryptoError)
+import Crypto.Number.Serialize (i2ospOf_, os2ip)
+import qualified Crypto.PubKey.Curve25519 as Curve25519
+import qualified Crypto.PubKey.Ed25519 as Ed25519
+import qualified Crypto.PubKey.Ed448 as Ed448
+import qualified Crypto.PubKey.RSA as RSA
+import qualified Crypto.PubKey.RSA.PKCS15 as P15
+import Crypto.Random.Types (getRandomBytes)
+import qualified Data.Aeson as A
+import Data.Bifunctor (first)
+import qualified Data.Binary as Bin
+import Data.Binary.Get (runGet)
+import Data.Binary.Put
+ ( putByteString
+ , putLazyByteString
+ , putWord16be
+ , putWord32be
+ , putWord8
+ , runPut
+ )
+import Data.Bits (shiftL, shiftR, (.&.), (.|.))
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Char8 as BLC8
+import Data.Char (digitToInt, isHexDigit, isSpace, toLower)
+import Data.Conduit (fuseBoth, runConduitRes, (.|))
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.Combinators as CC
+import qualified Data.Conduit.List as CL
+import Data.Conduit.OpenPGP.Decrypt
+ ( DecryptKeyResolution (..)
+ , DecryptOutcome (..)
+ , PKESKRecipientKey (..)
+ )
+import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt
+import Data.Conduit.OpenPGP.Keyring
+ ( conduitToTKsDroppingEither
+ , sinkPublicKeyringMap
+ )
+import Data.Conduit.OpenPGP.Verify
+ ( conduitVerify
+ , verifyPacketsBatch
+ )
+import Data.Either (fromRight, isLeft, isRight, rights)
+import Data.IORef (IORef, atomicModifyIORef', newIORef)
+import Data.List
+ ( find
+ , findIndex
+ , intercalate
+ , isInfixOf
+ , isPrefixOf
+ , isSuffixOf
+ , nub
+ , partition
+ , stripPrefix
+ )
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe
+ ( catMaybes
+ , fromMaybe
+ , isJust
+ , listToMaybe
+ , mapMaybe
+ , maybeToList
+ )
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Text.Encoding.Error (lenientDecode)
+import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX
+ ( POSIXTime
+ , getPOSIXTime
+ , posixSecondsToUTCTime
+ , utcTimeToPOSIXSeconds
+ )
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Data.Time.Format.ISO8601 (iso8601ParseM)
+import qualified Data.Vector as V
+import Data.Version (showVersion)
+import Data.Word (Word8)
+import GHC.Generics
+import Options.Applicative.Builder
+ ( argument
+ , command
+ , eitherReader
+ , footerDoc
+ , headerDoc
+ , help
+ , helpDoc
+ , info
+ , long
+ , metavar
+ , option
+ , prefs
+ , progDesc
+ , showHelpOnError
+ , str
+ , strArgument
+ , strOption
+ , switch
+ , value
+ )
+import Options.Applicative.Extra
+ ( customExecParser
+ , helper
+ , hsubparser
+ )
+import Options.Applicative.Types (Parser)
+import Prettyprinter
+ ( hardline
+ , list
+ , pretty
+ , softline
+ )
+import Prettyprinter.Render.Text (hPutDoc)
+import System.Directory (doesFileExist)
+import System.Environment (getArgs, lookupEnv)
+import System.Exit
+ ( ExitCode (..)
+ , exitSuccess
+ , exitWith
+ )
+import System.IO
+ ( BufferMode (..)
+ , Handle
+ , hFlush
+ , hPutStrLn
+ , hSetBuffering
+ , stderr
+ , stdin
+ )
+import Text.Read (readMaybe)
+
+import HOpenPGP.Tools.Common.Armor (doDeArmor)
+import HOpenPGP.Tools.Common.Common
+ ( banner
+ , keyMatchesEightOctetKeyId
+ , keyMatchesFingerprint
+ , versioner
+ , warranty
+ )
+import HOpenPGP.Tools.Common.TKUtils (processTK)
+import Paths_hopenpgp_tools (version)
+
+data Command
+ = VersionC VersionOptions
+ | ListProfilesC ListProfilesOptions
+ | GenerateKeyC KeyGenOptions
+ | ChangeKeyPasswordC ChangeKeyPasswordOptions
+ | MergeCertsC MergeCertsOptions
+ | ValidateUserIdC ValidateUserIdOptions
+ | CertifyUserIdC CertifyUserIdOptions
+ | RevokeKeyC RevokeKeyOptions
+ | RevokeUserIdC RevokeUserIdOptions
+ | UpdateKeyC UpdateKeyOptions
+ | VerifyC VerifyOptions
+ | InlineVerifyC InlineVerifyOptions
+ | EncryptC EncryptOptions
+ | DecryptC DecryptOptions
+ | InlineSignC InlineSignOptions
+ | InlineDetachC InlineDetachOptions
+ | ExtractCertC ExtractCertOptions
+ | SignC SignOptions
+ | UnsupportedC String
+ | DeArmorC
+ | ArmorC ArmoringOptions
+
+data OutputFormat
+ = Unstructured
+ | JSON
+ | YAML
+ deriving (Eq, Read, Show)
+
+data VerifyOptions
+ = VerifyOptions
+ { verifyNotBefore :: Maybe String
+ , verifyNotAfter :: Maybe String
+ , verifySigFile :: String
+ , verifyCertFiles :: [String]
+ }
+
+data InlineVerifyOptions
+ = InlineVerifyOptions
+ { inlineNotBefore :: Maybe String
+ , inlineNotAfter :: Maybe String
+ , verificationsOut :: Maybe String
+ , inlineCertFiles :: [String]
+ }
+
+data EncryptOptions
+ = EncryptOptions
+ { encNoArmor :: Bool
+ , encArmor :: Bool
+ , encProfile :: Maybe String
+ , encAs :: AsBinaryText
+ , encSignWithKeyFiles :: [String]
+ , encSignWithKeyPasswords :: [String]
+ , encSessionKeyOutFile :: Maybe String
+ , encFor :: EncryptFor
+ , encWithoutIntegrityCheck :: Bool
+ , encPasswords :: [String]
+ , encRecipientCerts :: [String]
+ }
+
+data EncryptProfile
+ = EncryptProfileRFC9580
+ | EncryptProfileRFC4880
+ deriving (Eq)
+
+data DecryptOptions
+ = DecryptOptions
+ { decNoArmor :: Bool
+ , decArmor :: Bool
+ , decWithoutIntegrityCheck :: Bool
+ , decVerifyNotBefore :: Maybe String
+ , decVerifyNotAfter :: Maybe String
+ , decSessionKeys :: [String]
+ , decSessionKeyOutFile :: Maybe String
+ , decPasswords :: [String]
+ , decKeyPasswords :: [String]
+ , decKeyFiles :: [String]
+ , decVerifyCerts :: [String]
+ , decVerificationsOutFile :: Maybe String
+ , decDeprecatedVerifyOutFile :: Maybe String
+ }
+
+data InlineSignOptions
+ = InlineSignOptions
+ { inlineSignNoArmor :: Bool
+ , inlineSignArmor :: Bool
+ , inlineSignProfile :: Maybe String
+ , inlineSignAs :: Maybe InlineSignMode
+ , inlineSignKeyFiles :: [String]
+ , inlineSignKeyPasswords :: [String]
+ }
+
+data InlineDetachOptions
+ = InlineDetachOptions
+ { inlineDetachNoArmor :: Bool
+ , inlineDetachOutputSigs :: String
+ }
+
+data ChangeKeyPasswordOptions
+ = ChangeKeyPasswordOptions
+ { changeKeyPasswordNoArmor :: Bool
+ , changeKeyPasswordOldPasswords :: [String]
+ , changeKeyPasswordNewPasswords :: [String]
+ }
+
+data MergeCertsOptions
+ = MergeCertsOptions
+ { mergeCertsNoArmor :: Bool
+ , mergeCertsFiles :: [String]
+ }
+
+data ValidateUserIdOptions
+ = ValidateUserIdOptions
+ { validateUserIdAddrSpecOnly :: Bool
+ , validateUserIdAt :: Maybe String
+ , validateUserIdString :: String
+ , validateUserIdAuthorityFiles :: [String]
+ }
+
+data CertifyUserIdOptions
+ = CertifyUserIdOptions
+ { certifyUserIds :: [String]
+ , certifyUserIdOutputFormat :: Maybe String
+ , certifyUserIdNoRequireSelfSig :: Bool
+ , certifyUserIdKeyPasswordFiles :: [String]
+ , certifyUserIdSignerFiles :: [String]
+ }
+
+data RevokeKeyOptions
+ = RevokeKeyOptions
+ { revokeKeyNoArmor :: Bool
+ , revokeKeyPasswordFiles :: [String]
+ }
+
+data RevokeUserIdOptions
+ = RevokeUserIdOptions
+ { revokeUserIdString :: String
+ , revokeUserIdNoArmor :: Bool
+ }
+
+data UpdateKeyOptions
+ = UpdateKeyOptions
+ { updateKeyNoArmor :: Bool
+ , updateKeySigningOnly :: Bool
+ , updateKeyRevokeDeprecatedKeys :: Bool
+ , updateKeyNoAddedCapabilities :: Bool
+ , updateKeyPasswordFiles :: [String]
+ , updateKeyMergeCerts :: [String]
+ }
+
+newtype ListProfilesOptions
+ = ListProfilesOptions
+ { profileSubcommand :: String
+ }
+
+data VersionOptions
+ = VersionOptions
+ { vBackend :: Bool
+ , vExtended :: Bool
+ , vSopSpec :: Bool
+ , vSopv :: Bool
+ }
+
+data CliOptions
+ = CliOptions
+ { cliDebug :: Bool
+ , cliCommand :: Command
+ }
+
+data SopFailure
+ = MissingArg
+ | IncompleteVerification
+ | BadData
+ | PasswordNotHumanReadable
+ | ExpectedText
+ | CannotDecrypt
+ | UnsupportedAsymmetricAlgo
+ | CertCannotEncrypt
+ | UnsupportedOption
+ | OutputExists
+ | MissingInput
+ | NoSignature
+ | KeyIsProtected
+ | KeyCannotSign
+ | UnsupportedSpecialPrefix
+ | IncompatibleOptions
+ | UnsupportedProfile
+ | UnsupportedSubcommand
+ | CertUserIdNoMatch
+ | KeyCannotCertify
+
+failureCode :: SopFailure -> Int
+failureCode MissingArg = 19
+failureCode IncompleteVerification = 23
+failureCode BadData = 41
+failureCode PasswordNotHumanReadable = 31
+failureCode ExpectedText = 53
+failureCode CannotDecrypt = 29
+failureCode UnsupportedAsymmetricAlgo = 13
+failureCode CertCannotEncrypt = 17
+failureCode UnsupportedOption = 37
+failureCode OutputExists = 59
+failureCode MissingInput = 61
+failureCode NoSignature = 3
+failureCode KeyIsProtected = 67
+failureCode KeyCannotSign = 79
+failureCode UnsupportedSpecialPrefix = 71
+failureCode IncompatibleOptions = 83
+failureCode UnsupportedProfile = 89
+failureCode UnsupportedSubcommand = 69
+failureCode CertUserIdNoMatch = 107
+failureCode KeyCannotCertify = 109
+
+failWith :: SopFailure -> String -> IO a
+failWith f msg = do
+ BLC8.hPutStrLn stderr (BLC8.pack msg)
+ exitWith (ExitFailure (failureCode f))
+
+voP :: Parser VerifyOptions
+voP =
+ VerifyOptions
+ <$> optional
+ ( strOption
+ ( long "not-before"
+ <> metavar "DATE"
+ <> help "ignore signatures before DATE"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "not-after"
+ <> metavar "DATE"
+ <> help "ignore signatures after DATE"
+ )
+ )
+ <*> argument str (metavar "SIGNATURES" <> sigHelp)
+ <*> some (strArgument (metavar "CERTS..." <> certHelp))
+ where
+ sigHelp =
+ helpDoc . Just $
+ pretty "file containing OpenPGP signatures"
+ certHelp =
+ helpDoc . Just $
+ pretty "one or more certificate files"
+
+ivoP :: Parser InlineVerifyOptions
+ivoP =
+ InlineVerifyOptions
+ <$> optional
+ ( strOption
+ ( long "not-before"
+ <> metavar "DATE"
+ <> help "ignore signatures before DATE"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "not-after"
+ <> metavar "DATE"
+ <> help "ignore signatures after DATE"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "verifications-out"
+ <> metavar "VERIFICATIONS"
+ <> help "write verification records to file"
+ )
+ )
+ <*> some (strArgument (metavar "CERTS..." <> certHelp))
+ where
+ certHelp =
+ helpDoc . Just $
+ pretty "one or more certificate files"
+
+lpoP :: Parser ListProfilesOptions
+lpoP =
+ ListProfilesOptions
+ <$> strArgument
+ (metavar "SUBCOMMAND" <> help "subcommand to list profiles for")
+
+vopP :: Parser VersionOptions
+vopP =
+ VersionOptions
+ <$> switch
+ (long "backend" <> help "show backend implementation version")
+ <*> switch
+ (long "extended" <> help "show extended version information")
+ <*> switch (long "sop-spec" <> help "show targeted sop draft")
+ <*> switch
+ (long "sopv" <> help "show implemented sopv subset version")
+
+encP :: Parser EncryptOptions
+encP =
+ EncryptOptions
+ <$> switch (long "no-armor" <> help "output binary")
+ <*> switch (long "armor" <> help "output ASCII Armor")
+ <*> optional
+ (strOption (long "profile" <> help "encryption profile"))
+ <*> option
+ (eitherReader asTypeReader)
+ (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)
+ <*> many
+ (strOption (long "sign-with" <> help "signing key material"))
+ <*> many
+ ( strOption
+ ( long "with-key-password"
+ <> help "password for unlocking signing key material"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "session-key-out"
+ <> metavar "SESSIONKEY"
+ <> help "write generated session key to file"
+ )
+ )
+ <*> option
+ (eitherReader encryptForReader)
+ ( long "for"
+ <> metavar "ENCRYPTION_PURPOSE"
+ <> help
+ "select recipient key purpose (any, storage, communications)"
+ <> value EncryptForAny
+ )
+ <*> switch
+ ( long "without-integrity-check"
+ <> help "disable integrity protection"
+ )
+ <*> many
+ ( strOption
+ (long "with-password" <> help "symmetric encryption password")
+ )
+ <*> many
+ ( strArgument
+ (metavar "CERT" <> help "recipient certificate files")
+ )
+ where
+ astypeHelp =
+ helpDoc . Just $
+ pretty "what to treat the input as"
+ <> softline
+ <> list (map (pretty . fst) asTypes)
+
+decP :: Parser DecryptOptions
+decP =
+ DecryptOptions
+ <$> switch (long "no-armor" <> help "output binary")
+ <*> switch (long "armor" <> help "output ASCII Armor")
+ <*> switch
+ ( long "without-integrity-check"
+ <> help "disable integrity verification"
+ )
+ <*> optional
+ ( strOption
+ ( long "verify-not-before"
+ <> metavar "DATE"
+ <> help "ignore signatures before DATE when decrypting"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "verify-not-after"
+ <> metavar "DATE"
+ <> help "ignore signatures after DATE when decrypting"
+ )
+ )
+ <*> many
+ ( strOption
+ (long "with-session-key" <> help "session key for decryption")
+ )
+ <*> optional
+ ( strOption
+ (long "session-key-out" <> help "write recovered session key")
+ )
+ <*> many
+ ( strOption
+ (long "with-password" <> help "password for SKESK decryption")
+ )
+ <*> many
+ ( strOption
+ ( long "with-key-password"
+ <> help "password for unlocking decryption key material"
+ )
+ )
+ <*> many (strArgument (metavar "KEY" <> help "secret key material"))
+ <*> many
+ ( strOption
+ ( long "verify-with"
+ <> help "certificate(s) to verify signatures with"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "verifications-out"
+ <> help "write verification results to file"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "verify-out"
+ <> help "deprecated alias for --verifications-out"
+ )
+ )
+
+inlineSignP :: Parser InlineSignOptions
+inlineSignP =
+ InlineSignOptions
+ <$> switch (long "no-armor" <> help "output binary")
+ <*> switch (long "armor" <> help "output ASCII Armor")
+ <*> optional (strOption (long "profile" <> help "signature profile"))
+ <*> optional
+ ( option
+ (eitherReader inlineSignModeReader)
+ (long "as" <> metavar "DATATYPE" <> inlineSignAsHelp)
+ )
+ <*> some (strArgument (metavar "KEY" <> help "signing key file(s)"))
+ <*> many
+ ( strOption
+ ( long "with-key-password"
+ <> metavar "PASSWORD"
+ <> help "password for encrypted signing key"
+ )
+ )
+ where
+ inlineSignAsHelp =
+ helpDoc . Just $
+ pretty "what to treat the input as"
+ <> softline
+ <> list [pretty "binary", pretty "text", pretty "clearsigned"]
+
+inlineDetachP :: Parser InlineDetachOptions
+inlineDetachP =
+ InlineDetachOptions
+ <$> switch (long "no-armor" <> help "output binary")
+ <*> strOption
+ ( long "signatures-out"
+ <> metavar "SIGNATURES"
+ <> help "write detached signatures to file"
+ )
+
+mergeCertsP :: Parser MergeCertsOptions
+mergeCertsP =
+ MergeCertsOptions
+ <$> switch (long "no-armor" <> help "output binary")
+ <*> some
+ ( strArgument
+ (metavar "CERTS..." <> help "one or more certificate files")
+ )
+
+validateUserIdP :: Parser ValidateUserIdOptions
+validateUserIdP =
+ ValidateUserIdOptions
+ <$> switch
+ ( long "addr-spec-only"
+ <> help
+ "match only the addr-spec portion of conventional OpenPGP User IDs"
+ )
+ <*> optional
+ ( strOption
+ ( long "validate-at"
+ <> metavar "DATE"
+ <> help "evaluate certifications at DATE"
+ )
+ )
+ <*> argument str (metavar "USERID" <> help "user ID to validate")
+ <*> some
+ ( strArgument
+ ( metavar "CERTS..."
+ <> help "one or more authority certificate files"
+ )
+ )
+
+certifyUserIdP :: Parser CertifyUserIdOptions
+certifyUserIdP =
+ CertifyUserIdOptions
+ <$> some
+ ( strOption
+ ( long "userid"
+ <> metavar "USERID"
+ <> help "user ID to certify (repeatable)"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "output-format"
+ <> metavar "FORMAT"
+ <> help "output format (text or binary)"
+ )
+ )
+ <*> switch
+ ( long "no-require-self-sig"
+ <> help "allow certifying user IDs that do not have self-signatures"
+ )
+ <*> many
+ ( strOption
+ ( long "with-key-password"
+ <> help "password for unlocking signer key material"
+ )
+ )
+ <*> some
+ ( strArgument
+ (metavar "KEYS..." <> help "one or more signer key files")
+ )
+
+revokeKeyP :: Parser RevokeKeyOptions
+revokeKeyP =
+ RevokeKeyOptions
+ <$> switch (long "no-armor" <> help "output binary")
+ <*> many
+ ( strOption
+ ( long "with-key-password"
+ <> help "password for unlocking secret key material"
+ )
+ )
+
+revokeUserIdP :: Parser RevokeUserIdOptions
+revokeUserIdP =
+ RevokeUserIdOptions
+ <$> argument str (metavar "USERID" <> help "user ID to revoke")
+ <*> switch (long "no-armor" <> help "output binary")
+
+updateKeyP :: Parser UpdateKeyOptions
+updateKeyP =
+ UpdateKeyOptions
+ <$> switch (long "no-armor" <> help "output binary")
+ <*> switch
+ ( long "signing-only"
+ <> help "limit updated material to signing-capable key material"
+ )
+ <*> switch
+ ( long "revoke-deprecated-keys"
+ <> help
+ "emit revocations for deprecated key material when supported"
+ )
+ <*> switch
+ ( long "no-added-capabilities"
+ <> help
+ "do not add capabilities beyond existing target key material"
+ )
+ <*> many
+ ( strOption
+ ( long "with-key-password"
+ <> help "password for unlocking key material"
+ )
+ )
+ <*> many
+ ( strOption
+ ( long "merge-certs"
+ <> metavar "CERTS"
+ <> help "additional certificate files to merge into target keys"
+ )
+ )
+
+changeKeyPasswordP :: Parser ChangeKeyPasswordOptions
+changeKeyPasswordP =
+ ChangeKeyPasswordOptions
+ <$> switch (long "no-armor" <> help "output binary")
+ <*> many
+ ( strOption
+ ( long "old-key-password"
+ <> help "password(s) used to unlock existing secret key material"
+ )
+ )
+ <*> many
+ ( strOption
+ ( long "new-key-password"
+ <> help "password used to protect rewritten secret key material"
+ )
+ )
+
+dispatch :: POSIXTime -> Command -> IO ()
+dispatch cpt cmd' = banner' stderr >> hFlush stderr >> dispatch' cpt cmd'
+ where
+ dispatch' _ (VersionC o') = doVersion o'
+ dispatch' _ (ListProfilesC o') = doListProfiles o'
+ dispatch' t (GenerateKeyC o) = doGenerateKey t o
+ dispatch' _ (ChangeKeyPasswordC o) = doChangeKeyPassword o
+ dispatch' _ (MergeCertsC o) = doMergeCerts o
+ dispatch' t (ValidateUserIdC o) = doValidateUserId t o
+ dispatch' t (CertifyUserIdC o) = doCertifyUserId t o
+ dispatch' t (RevokeKeyC o) = doRevokeKey t o
+ dispatch' t (RevokeUserIdC o) = doRevokeUserId t o
+ dispatch' t (UpdateKeyC o) = doUpdateKey t o
+ dispatch' t (VerifyC o') = doVerify t o'
+ dispatch' t (InlineVerifyC o') = doInlineVerify t o'
+ dispatch' t (EncryptC o') = doEncrypt t o'
+ dispatch' t (DecryptC o') = doDecrypt t o'
+ dispatch' t (InlineSignC o') = doInlineSign t o'
+ dispatch' t (InlineDetachC o') = doInlineDetach t o'
+ dispatch' _ (ExtractCertC o) = doExtractCert o
+ dispatch' t (SignC o) = doSign t o
+ dispatch' _ (UnsupportedC c) =
+ failWith
+ UnsupportedSubcommand
+ ("command not yet implemented: " ++ c)
+ dispatch' _ DeArmorC = doDeArmor
+ dispatch' _ (ArmorC o) = doArmor o
+
+main :: IO ()
+main = do
+ hSetBuffering stderr LineBuffering
+ args <- getArgs
+ ensureKnownSubcommand knownSopSubcommands args
+ cpt <- getPOSIXTime
+ CliOptions {..} <-
+ customExecParser
+ (prefs showHelpOnError)
+ ( info
+ (helper <*> versioner "hop" <*> cliP)
+ ( headerDoc (Just (banner "hop"))
+ <> progDesc "hOpenPGP Validator Tool"
+ <> footerDoc (Just (warranty "hop"))
+ )
+ )
+ let _ = cliDebug
+ dispatch cpt cliCommand
+
+knownSopSubcommands :: [String]
+knownSopSubcommands =
+ [ "armor"
+ , "dearmor"
+ , "change-key-password"
+ , "decrypt"
+ , "encrypt"
+ , "certify-userid"
+ , "extract-cert"
+ , "generate-key"
+ , "inline-detach"
+ , "inline-sign"
+ , "inline-verify"
+ , "list-profiles"
+ , "merge-certs"
+ , "revoke-key"
+ , "revoke-userid"
+ , "sign"
+ , "update-key"
+ , "validate-userid"
+ , "verify"
+ , "version"
+ ]
+
+ensureKnownSubcommand :: [String] -> [String] -> IO ()
+ensureKnownSubcommand knownSubcommands args =
+ if any (`elem` ["-h", "--help", "--version"]) args
+ then pure ()
+ else case find (not . isPrefixOf "-") args of
+ Just subcommand
+ | subcommand `notElem` knownSubcommands ->
+ failWith
+ UnsupportedSubcommand
+ ("unsupported subcommand: " ++ subcommand)
+ _ -> pure ()
+
+cliP :: Parser CliOptions
+cliP =
+ CliOptions
+ <$> switch (long "debug" <> help "emit more verbose output")
+ <*> cmd
+
+banner' :: Handle -> IO ()
+banner' h =
+ hPutDoc
+ h
+ (banner "hop" <> hardline <> warranty "hop" <> hardline)
+
+data Vrf
+ = Vrf
+ { _vrfmsg :: String
+ , _vrfmfpr :: Maybe Fingerprint
+ }
+ deriving (Eq, Generic, Show)
+
+instance A.ToJSON Vrf
+
+cmd :: Parser Command
+cmd =
+ hsubparser
+ ( command
+ "armor"
+ (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout"))
+ <> command
+ "dearmor"
+ (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))
+ <> command
+ "change-key-password"
+ ( info
+ (ChangeKeyPasswordC <$> changeKeyPasswordP)
+ (progDesc "Update a key password")
+ )
+ <> command
+ "decrypt"
+ (info (DecryptC <$> decP) (progDesc "Decrypt a message"))
+ <> command
+ "encrypt"
+ (info (EncryptC <$> encP) (progDesc "Encrypt a message"))
+ <> command
+ "certify-userid"
+ ( info
+ (CertifyUserIdC <$> certifyUserIdP)
+ (progDesc "Certify user IDs in a certificate")
+ )
+ <> command
+ "extract-cert"
+ ( info
+ (ExtractCertC <$> ecoP)
+ ( progDesc
+ "Extract a certificate from a secret key and output it to stdout"
+ )
+ )
+ <> command
+ "generate-key"
+ ( info
+ (GenerateKeyC <$> gkoP)
+ (progDesc "Generate a secret key and output it to stdout")
+ )
+ <> command
+ "inline-detach"
+ ( info
+ (InlineDetachC <$> inlineDetachP)
+ (progDesc "Create inline detached signatures")
+ )
+ <> command
+ "inline-sign"
+ ( info
+ (InlineSignC <$> inlineSignP)
+ (progDesc "Create inline signatures")
+ )
+ <> command
+ "inline-verify"
+ ( info
+ (InlineVerifyC <$> ivoP)
+ (progDesc "Verify inline-signed data")
+ )
+ <> command
+ "list-profiles"
+ (info (ListProfilesC <$> lpoP) (progDesc "List SOP profiles"))
+ <> command
+ "merge-certs"
+ ( info
+ (MergeCertsC <$> mergeCertsP)
+ (progDesc "Merge OpenPGP certificates")
+ )
+ <> command
+ "revoke-key"
+ ( info
+ (RevokeKeyC <$> revokeKeyP)
+ (progDesc "Create a key revocation certificate")
+ )
+ <> command
+ "revoke-userid"
+ ( info
+ (RevokeUserIdC <$> revokeUserIdP)
+ (progDesc "Revoke a user ID")
+ )
+ <> command
+ "sign"
+ ( info
+ (SignC <$> soP)
+ (progDesc "Create detached signatures and output them to stdout")
+ )
+ <> command
+ "update-key"
+ (info (UpdateKeyC <$> updateKeyP) (progDesc "Update key material"))
+ <> command
+ "validate-userid"
+ ( info
+ (ValidateUserIdC <$> validateUserIdP)
+ (progDesc "Validate a certificate user ID")
+ )
+ <> command
+ "verify"
+ (info (VerifyC <$> voP) (progDesc "Verify signatures"))
+ <> command
+ "version"
+ ( info
+ (VersionC <$> vopP)
+ (progDesc "output hop version to stdout")
+ )
+ )
+
+armorTypes :: [(String, Maybe ArmorType)]
+armorTypes =
+ [ ("auto", Nothing)
+ , ("sig", Just ArmorSignature)
+ , ("key", Just ArmorPrivateKeyBlock)
+ , ("cert", Just ArmorPublicKeyBlock)
+ , ("message", Just ArmorMessage)
+ ]
+
+armorTypeReader :: String -> Either String (Maybe ArmorType)
+armorTypeReader = note "unknown armor type" . flip lookup armorTypes
+
+aoP :: Parser ArmoringOptions
+aoP =
+ ArmoringOptions
+ <$> option
+ (eitherReader armorTypeReader)
+ (long "label" <> metavar "LABEL" <> armortypeHelp)
+ <*> switch
+ ( long "allow-nested"
+ <> help "do the sane thing and unconditionally armor the output"
+ )
+ where
+ armortypeHelp =
+ helpDoc . Just $
+ pretty "ASCII armor type"
+ <> softline
+ <> list (map (pretty . fst) armorTypes)
+
+data ArmoringOptions
+ = ArmoringOptions
+ { label :: Maybe ArmorType
+ , allowNested :: Bool
+ }
+
+doArmor :: ArmoringOptions -> IO ()
+doArmor ArmoringOptions {..} = do
+ m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
+ let lbs = BL.fromChunks m
+ armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs
+ label' = guessLabel label (decodeFirstPacket lbs)
+ a = Armor label' [] lbs
+ BL.putStr $
+ if armoredAlready && not allowNested
+ then lbs
+ else AA.encodeLazy [a]
+ where
+ decodeFirstPacket = runGet Bin.get
+ -- UPSTREAM: openpgp-asciiarmor should export selectArmorType helper
+ -- to eliminate this pattern-matching boilerplate
+ guessLabel (Just l) _ = l
+ guessLabel Nothing (SignaturePkt _) = ArmorSignature
+ guessLabel Nothing (SecretKeyPkt _ _) = ArmorPrivateKeyBlock
+ guessLabel Nothing (PublicKeyPkt _) = ArmorPublicKeyBlock
+ guessLabel Nothing _ = ArmorMessage
+
+doVersion :: VersionOptions -> IO ()
+doVersion VersionOptions {..} = do
+ let selected = length (filter id [vBackend, vExtended, vSopSpec, vSopv])
+ when (selected > 1) $
+ failWith
+ IncompatibleOptions
+ "version: --backend, --extended, --sop-spec, and --sopv are mutually exclusive"
+ putStrLn $ "hop " ++ showVersion version
+ when vBackend $ putStrLn "backend: hOpenPGP"
+ when vExtended $ putStrLn "extended: yes"
+ when vSopSpec $
+ putStrLn "spec: draft-dkg-openpgp-stateless-cli-16"
+ when vSopv $ putStrLn "sopv: 1.0"
+
+gkoP :: Parser KeyGenOptions
+gkoP =
+ KeyGenOptions
+ <$> switch (long "armor" <> help "armor the output")
+ <*> switch (long "no-armor" <> help "don't armor the output")
+ <*> many
+ ( strOption
+ ( long "with-key-password"
+ <> help "password used to protect generated secret key material"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "profile"
+ <> metavar "PROFILE"
+ <> help
+ "key generation profile (default, rfc4880, compatibility, security, performance)"
+ )
+ )
+ <*> switch
+ (long "signing-only" <> help "generate signing-only key material")
+ <*> many
+ ( strArgument
+ (metavar "USERID" <> help "User ID associated with this key")
+ )
+
+data KeyGenOptions
+ = KeyGenOptions
+ { armor :: Bool
+ , noArmor :: Bool
+ , keyPasswords :: [String]
+ , keyProfile :: Maybe String
+ , keySigningOnly :: Bool
+ , userIds :: [String]
+ }
+
+doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()
+doGenerateKey pt KeyGenOptions {..} = do
+ when (armor && noArmor) $
+ failWith
+ IncompatibleOptions
+ "generate-key: --armor and --no-armor are mutually exclusive"
+ baseProfile <- parseKeyGenProfile keyProfile
+ let profile =
+ if keySigningOnly
+ then KeyGenSigningOnly
+ else baseProfile
+ password <- parseGenerateKeyPassword keyPasswords
+ let ts = ThirtyTwoBitTimeStamp (floor pt)
+ -- UPSTREAM: hOpenPGP should expose a supported legacy secret-key
+ -- re-encryption path so password-protected v4 key generation does not
+ -- need to switch to the v6 protection format here.
+ keyVersion =
+ if isJust password && keyVersionForProfile profile == V4
+ then V6
+ else keyVersionForProfile profile
+ primaryKeySpec = primaryKeySpecForProfile profile
+ sk <- generateSecretKey ts keyVersion primaryKeySpec
+ baseKey <-
+ buildKeyWith sk $ do
+ case userIds of
+ (primaryUid : restUids) -> do
+ addUserId ts True (T.pack primaryUid)
+ mapM_ (addUserId ts False . T.pack) restUids
+ [] -> pure ()
+ addSubkeysForProfile ts keyVersion profile
+ newkey <- get
+ return newkey
+ s <-
+ maybe
+ (pure baseKey)
+ (`encryptTransferableSecretKey` baseKey)
+ password
+ let lbs = runPut $ Bin.put s
+ BL.putStr $
+ if not armor && not noArmor
+ then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]
+ else lbs
+
+type KeyBuilder = StateT TKUnknown IO
+
+buildKeyWith :: SecretKey -> KeyBuilder a -> IO a
+buildKeyWith sk a = evalStateT a (bareTK sk)
+ where
+ bareTK (SecretKey pkp ska) = TKUnknown (pkp, Just ska) [] [] [] []
+
+data GeneratedKeySpec
+ = GeneratedRSAKey Int
+ | GeneratedEd25519Key
+ | GeneratedX25519Key
+ deriving (Eq)
+
+generateSecretKey
+ :: ThirtyTwoBitTimeStamp
+ -> KeyVersion
+ -> GeneratedKeySpec
+ -> IO SecretKey
+generateSecretKey ts keyVersion (GeneratedRSAKey bits) = do
+ (pub, priv) <- liftIO $ RSA.generate bits 0x10001
+ return $ SecretKey (pkp pub) (ska priv)
+ where
+ pkp pub = PKPayload keyVersion ts 0 RSA (RSAPubKey (RSA_PublicKey pub))
+ ska priv = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey priv)) 0 -- FIXME: calculate checksum
+generateSecretKey ts keyVersion GeneratedEd25519Key = do
+ priv <- Ed25519.generateSecretKey
+ let pub = Ed25519.toPublic priv
+ pubBytes = BA.convert pub :: B.ByteString
+ privBytes = BA.convert priv :: B.ByteString
+ pure $
+ SecretKey
+ ( PKPayload
+ keyVersion
+ ts
+ 0
+ (toFVal 27)
+ (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes))))
+ )
+ (SUUnencrypted (EdDSAPrivateKey Ed25519 privBytes) 0)
+generateSecretKey ts keyVersion GeneratedX25519Key = do
+ priv <- Curve25519.generateSecretKey
+ let pub = Curve25519.toPublic priv
+ pubBytes = BA.convert pub :: B.ByteString
+ privBytes = BA.convert priv :: B.ByteString
+ pure $
+ SecretKey
+ ( PKPayload
+ keyVersion
+ ts
+ 0
+ X25519
+ (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes))))
+ )
+ (SUUnencrypted (X25519PrivateKey privBytes) 0)
+
+data KeyGenProfile
+ = KeyGenDefault
+ | KeyGenRFC4880
+ | KeyGenSecurity
+ | KeyGenPerformance
+ | KeyGenSigningOnly
+ deriving (Eq)
+
+parseKeyGenProfile :: Maybe String -> IO KeyGenProfile
+parseKeyGenProfile Nothing = pure KeyGenDefault
+parseKeyGenProfile (Just "default") = pure KeyGenDefault
+parseKeyGenProfile (Just "rfc4880") = pure KeyGenRFC4880
+parseKeyGenProfile (Just "compatibility") = pure KeyGenRFC4880
+parseKeyGenProfile (Just "security") = pure KeyGenSecurity
+parseKeyGenProfile (Just "performance") = pure KeyGenPerformance
+parseKeyGenProfile (Just profile) =
+ failWith
+ UnsupportedProfile
+ ("generate-key: unsupported profile " ++ profile)
+
+keyVersionForProfile :: KeyGenProfile -> KeyVersion
+keyVersionForProfile KeyGenDefault = V6
+keyVersionForProfile KeyGenRFC4880 = V4
+keyVersionForProfile KeyGenSecurity = V6
+keyVersionForProfile KeyGenPerformance = V6
+keyVersionForProfile KeyGenSigningOnly = V6
+
+primaryKeySpecForProfile :: KeyGenProfile -> GeneratedKeySpec
+primaryKeySpecForProfile KeyGenRFC4880 = GeneratedRSAKey 4096
+primaryKeySpecForProfile _ = GeneratedEd25519Key
+
+parseGenerateKeyPassword :: [String] -> IO (Maybe BL.ByteString)
+parseGenerateKeyPassword [] = pure Nothing
+parseGenerateKeyPassword [passwordFile] =
+ Just
+ <$> ( loadPasswordFromFile
+ "generate-key"
+ "--with-key-password"
+ passwordFile
+ >>= normalizeHumanReadablePassword
+ "generate-key"
+ "--with-key-password"
+ )
+parseGenerateKeyPassword _ =
+ failWith
+ UnsupportedOption
+ "generate-key: multiple --with-key-password values are not supported"
+
+loadPasswordFiles
+ :: String -> String -> [String] -> IO [BL.ByteString]
+loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName)
+
+loadPasswordFromFile
+ :: String -> String -> FilePath -> IO BL.ByteString
+loadPasswordFromFile context optionName path = do
+ case stripPrefix "@ENV:" path of
+ Just varName
+ | null varName ->
+ failWith
+ BadData
+ (context ++ ": empty environment variable name in " ++ optionName)
+ | otherwise -> do
+ envValue <- lookupEnv varName
+ case envValue of
+ Nothing ->
+ failWith
+ MissingInput
+ ( context
+ ++ ": environment variable not found for "
+ ++ optionName
+ ++ ": "
+ ++ varName
+ )
+ Just envVal -> pure (BLC8.pack envVal)
+ Nothing ->
+ case stripPrefix "@FD:" path of
+ Just fdSpec -> loadPasswordFromFD context optionName fdSpec
+ Nothing ->
+ case path of
+ '@' : _ ->
+ failWith
+ UnsupportedSpecialPrefix
+ ( context
+ ++ ": unsupported special prefix for "
+ ++ optionName
+ ++ ": "
+ ++ path
+ )
+ _ -> do
+ exists <- doesFileExist path
+ unless exists $
+ failWith
+ MissingInput
+ ( context
+ ++ ": password file does not exist for "
+ ++ optionName
+ ++ ": "
+ ++ path
+ )
+ BL.readFile path
+
+loadPasswordFromFD
+ :: String -> String -> String -> IO BL.ByteString
+loadPasswordFromFD context optionName fdSpec =
+ case readMaybe fdSpec :: Maybe Int of
+ Just fdNum
+ | fdNum >= 0 ->
+ ( do
+ let fdPath = "/dev/fd/" ++ show fdNum
+ exists <- doesFileExist fdPath
+ unless exists $
+ failWith
+ MissingInput
+ ( context
+ ++ ": file descriptor not available for "
+ ++ optionName
+ ++ ": "
+ ++ fdSpec
+ )
+ contents <- BL.readFile fdPath
+ _ <- evaluate (BL.length contents)
+ pure contents
+ )
+ `catch` ( \err ->
+ failWith
+ MissingInput
+ ( context
+ ++ ": failed reading file descriptor for "
+ ++ optionName
+ ++ ": "
+ ++ fdSpec
+ ++ " ("
+ ++ displayException (err :: IOException)
+ ++ ")"
+ )
+ )
+ | otherwise ->
+ failWith
+ BadData
+ ( context
+ ++ ": invalid file descriptor in "
+ ++ optionName
+ ++ ": "
+ ++ fdSpec
+ )
+ _ ->
+ failWith
+ BadData
+ ( context
+ ++ ": invalid file descriptor in "
+ ++ optionName
+ ++ ": "
+ ++ fdSpec
+ )
+
+normalizeHumanReadablePassword
+ :: String -> String -> BL.ByteString -> IO BL.ByteString
+normalizeHumanReadablePassword context optionName passwordBytes =
+ case TE.decodeUtf8' (BL.toStrict passwordBytes) of
+ Left _ ->
+ failWith
+ PasswordNotHumanReadable
+ ( context
+ ++ ": password is not human-readable UTF-8 for "
+ ++ optionName
+ )
+ Right txt ->
+ pure
+ (BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt)))
+
+passwordRetryCandidates :: BL.ByteString -> [BL.ByteString]
+passwordRetryCandidates passwordBytes =
+ case TE.decodeUtf8' (BL.toStrict passwordBytes) of
+ Left _ -> [passwordBytes]
+ Right txt ->
+ let trimmed = BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt))
+ in if trimmed == passwordBytes
+ then [passwordBytes]
+ else [passwordBytes, trimmed]
+
+addSubkeysForProfile
+ :: ThirtyTwoBitTimeStamp
+ -> KeyVersion
+ -> KeyGenProfile
+ -> KeyBuilder ()
+addSubkeysForProfile ts keyVersion profile =
+ case profile of
+ KeyGenSigningOnly ->
+ addSubkey ts keyVersion profile [SignDataKey]
+ _ -> do
+ addSubkey
+ ts
+ keyVersion
+ profile
+ [EncryptStorageKey, EncryptCommunicationsKey]
+ addSubkey ts keyVersion profile [SignDataKey]
+ addSubkey ts keyVersion profile [AuthKey]
+
+subkeySpecForProfile
+ :: KeyGenProfile -> [KeyFlag] -> GeneratedKeySpec
+subkeySpecForProfile KeyGenRFC4880 _ = GeneratedRSAKey 4096
+subkeySpecForProfile _ keyflags
+ | any
+ (`elem` keyflags)
+ [EncryptStorageKey, EncryptCommunicationsKey] =
+ GeneratedX25519Key
+ | otherwise = GeneratedEd25519Key
+
+encryptTransferableSecretKey
+ :: BL.ByteString -> TKUnknown -> IO TKUnknown
+encryptTransferableSecretKey password tk = do
+ keyPair' <- encryptKeyPair (_tkuKey tk)
+ subs' <- mapM encryptSub (_tkuSubs tk)
+ pure tk {_tkuKey = keyPair', _tkuSubs = subs'}
+ where
+ encryptKeyPair (pkp, Just ska) = do
+ encrypted <- encryptSecretAddendumForOutput pkp ska
+ pure (pkp, Just encrypted)
+ encryptKeyPair keyPair = pure keyPair
+ encryptSub (SecretSubkeyPkt pkp ska, sigs) = do
+ encrypted <- encryptSecretAddendumForOutput pkp ska
+ pure (SecretSubkeyPkt pkp encrypted, sigs)
+ encryptSub sub = pure sub
+ encryptSecretAddendumForOutput pkp ska =
+ case ska of
+ SUUnencrypted {} -> doEncryptSecret
+ _ -> pure ska
+ where
+ doEncryptSecret = do
+ encryptedResult <-
+ encryptPrivateKey defaultPolicy pkp ska password
+ case encryptedResult of
+ Left err ->
+ failWith
+ BadData
+ ("generate-key: failed to protect secret key material: " ++ err)
+ Right val -> pure val
+
+rsaSigningKey :: SKAddendum -> IO RSA.PrivateKey
+rsaSigningKey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) =
+ pure (k {RSA.private_p = 0, RSA.private_q = 0})
+rsaSigningKey _ =
+ failWith
+ BadData
+ "generate-key: unsupported secret key format for RSA signing"
+
+issuerSubpacketsFor
+ :: String -> SomePKPayload -> IO [SigSubPacket]
+issuerSubpacketsFor context pkp =
+ case _keyVersion pkp of
+ V6 -> pure []
+ _ ->
+ case eightOctetKeyID pkp of
+ Left err ->
+ failWith
+ BadData
+ (context ++ ": could not derive issuer key id: " ++ show err)
+ Right keyId -> pure [SigSubPacket False (Issuer keyId)]
+
+addUserId
+ :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()
+addUserId ts primary userid = do
+ tk <- get
+ signed <- selfsign (_tkuKey tk) userid
+ modify (newUID signed)
+ where
+ newUID signed tk = tk {_tkuUIDs = _tkuUIDs tk ++ [signed]}
+ selfsign (pkp, Just ska) u = do
+ issuer <- liftIO (unhashed pkp)
+ sig <-
+ liftIO $
+ signWithKey
+ "generate-key"
+ pkp
+ PositiveCert
+ SHA512
+ (hashed pkp)
+ issuer
+ (userIdPayloadForSigning pkp (UserId u))
+ (Just ska)
+ pure (u, [sig])
+ selfsign _ _ =
+ liftIO $
+ failWith
+ BadData
+ "generate-key: primary key is missing secret key material"
+ hashed pkp =
+ [ SigSubPacket False (SigCreationTime ts)
+ , SigSubPacket
+ False
+ ( IssuerFingerprint
+ (issuerFingerprintVersionFor pkp)
+ (fingerprint pkp)
+ )
+ , SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey))
+ , SigSubPacket False (PrimaryUserId primary)
+ , SigSubPacket
+ False
+ (PreferredHashAlgorithms [SHA512, SHA256, SHA384, SHA224])
+ , SigSubPacket
+ False
+ (PreferredSymmetricAlgorithms [AES256, AES192, AES128])
+ ]
+ unhashed = issuerSubpacketsFor "generate-key"
+
+addSubkey
+ :: ThirtyTwoBitTimeStamp
+ -> KeyVersion
+ -> KeyGenProfile
+ -> [KeyFlag]
+ -> KeyBuilder ()
+addSubkey ts keyVersion profile keyflags = do
+ tk <- get
+ (SecretKey subpkp subska) <-
+ liftIO $
+ generateSecretKey
+ ts
+ keyVersion
+ (subkeySpecForProfile profile keyflags)
+ (pkp, ska) <-
+ case _tkuKey tk of
+ (primaryPkp, Just primarySka) -> pure (primaryPkp, primarySka)
+ _ ->
+ liftIO $
+ failWith
+ BadData
+ "generate-key: primary key is missing secret key material"
+ issuerPrimary <- liftIO (unhashed pkp)
+ issuerSub <- liftIO (unhashed subpkp)
+ embeddedBacksig <-
+ if SignDataKey `elem` keyflags
+ then
+ Just
+ <$> liftIO
+ ( signWithKey
+ "generate-key"
+ subpkp
+ PrimaryKeyBindingSig
+ SHA512
+ (hashed subpkp)
+ issuerSub
+ (subkeyPayloadForSigning pkp subpkp)
+ (Just subska)
+ )
+ else pure Nothing
+ bindingSig <-
+ liftIO $
+ signWithKey
+ "generate-key"
+ pkp
+ SubkeyBindingSig
+ SHA512
+ (hashedwithflags pkp)
+ ( maybe
+ issuerPrimary
+ ( \sig -> SigSubPacket False (EmbeddedSignature sig) : issuerPrimary
+ )
+ embeddedBacksig
+ )
+ (subkeyPayloadForSigning pkp subpkp)
+ (Just ska)
+ modify (addIt subpkp subska bindingSig)
+ where
+ addIt sp ss binding tk =
+ tk
+ { _tkuSubs = _tkuSubs tk ++ [(SecretSubkeyPkt sp ss, [binding])]
+ }
+ hashed pkp =
+ [ SigSubPacket False (SigCreationTime ts)
+ , SigSubPacket
+ False
+ ( IssuerFingerprint
+ (issuerFingerprintVersionFor pkp)
+ (fingerprint pkp)
+ )
+ ]
+ hashedwithflags pkp =
+ hashed pkp
+ ++ [SigSubPacket False (KeyFlags (S.fromList keyflags))]
+ unhashed = issuerSubpacketsFor "generate-key"
+
+putKeyForSigning :: SomePKPayload -> Bin.Put
+putKeyForSigning pkp@(PKPayload V6 _ _ _ _) = do
+ putWord8 0x9A
+ let bs = runPut (Bin.put pkp)
+ putWord32be (fromIntegral (BL.length bs))
+ putLazyByteString bs
+putKeyForSigning pkp = do
+ putWord8 0x99
+ let bs = runPut (Bin.put pkp)
+ putWord16be (fromIntegral (BL.length bs))
+ putLazyByteString bs
+
+putUserIdForSigning :: UserId -> Bin.Put
+putUserIdForSigning (UserId u) = do
+ let bs = TE.encodeUtf8 u
+ putWord8 0xB4
+ putWord32be (fromIntegral (B.length bs))
+ putByteString bs
+
+userIdPayloadForSigning
+ :: SomePKPayload -> UserId -> BL.ByteString
+userIdPayloadForSigning pkp uid =
+ runPut $ do
+ putKeyForSigning pkp
+ putUserIdForSigning uid
+
+subkeyPayloadForSigning
+ :: SomePKPayload -> SomePKPayload -> BL.ByteString
+subkeyPayloadForSigning primary sub =
+ runPut $ do
+ putKeyForSigning primary
+ putKeyForSigning sub
+
+issuerFingerprintVersionFor
+ :: SomePKPayload -> IssuerFingerprintVersion
+issuerFingerprintVersionFor pkp =
+ case _keyVersion pkp of
+ V6 -> IssuerFingerprintV6
+ _ -> IssuerFingerprintV4
+
+ecoP :: Parser ExtractCertOptions
+ecoP =
+ ExtractCertOptions
+ <$> switch (long "armor" <> help "armor the output")
+ <*> switch (long "no-armor" <> help "don't armor the output")
+
+data ExtractCertOptions
+ = ExtractCertOptions
+ { ecArmor :: Bool
+ , ecNoArmor :: Bool
+ }
+
+doExtractCert :: ExtractCertOptions -> IO ()
+doExtractCert ExtractCertOptions {..} = do
+ kbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
+ let lbs = BL.fromChunks kbs
+ pkts <- decodeOpenPGPInput "stdin" lbs
+ tks <-
+ runConduitRes $
+ CL.sourceList pkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapMaybe (either (const Nothing) id)
+ .| CC.sinkList
+ when (null tks) $
+ failWith
+ MissingInput
+ "extract-cert: no transferable secret key found on standard input"
+ let output = runPut $ mapM_ (Bin.put . pubToSecret) tks
+ BL.putStr $
+ if not ecArmor && not ecNoArmor
+ then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
+ else output
+ where
+ pubToSecret tk =
+ tk
+ { _tkuKey = pToS (_tkuKey tk)
+ , _tkuSubs = map subPToS (_tkuSubs tk)
+ }
+ pToS (pkp, _) = (pkp, Nothing)
+ subPToS (SecretSubkeyPkt pkp _, sigs) = (PublicSubkeyPkt pkp, sigs)
+ subPToS (PublicSubkeyPkt pkp, sigs) = (PublicSubkeyPkt pkp, sigs)
+ subPToS x = x
+
+doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()
+doChangeKeyPassword ChangeKeyPasswordOptions {..} = do
+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ packets <- decodeOpenPGPInput "stdin" input
+ tks <-
+ runConduitRes $
+ CL.sourceList packets
+ .| conduitToTKsDroppingEither
+ .| CL.mapMaybe (either (const Nothing) id)
+ .| CC.sinkList
+ when (null tks) $
+ failWith
+ MissingInput
+ "change-key-password: no transferable secret key found on standard input"
+ when (any (not . hasSecretKeyMaterial) tks) $
+ failWith
+ MissingInput
+ "change-key-password: expected transferable secret key input on standard input"
+ oldPasswordsRaw <-
+ loadPasswordFiles
+ "change-key-password"
+ "--old-key-password"
+ changeKeyPasswordOldPasswords
+ let oldPasswords = concatMap passwordRetryCandidates oldPasswordsRaw
+ newPassword <-
+ parseChangeKeyPasswordNewPassword changeKeyPasswordNewPasswords
+ unlockedTks <-
+ mapM
+ ( unlockTransferableSecretKeyMaterial
+ "change-key-password"
+ "standard input"
+ "--old-key-password"
+ oldPasswords
+ )
+ tks
+ rewrittenTks <-
+ case newPassword of
+ Just password -> mapM (encryptTransferableSecretKey password) unlockedTks
+ Nothing -> pure unlockedTks
+ let output = runPut (mapM_ Bin.put rewrittenTks)
+ BL.putStr $
+ if changeKeyPasswordNoArmor || BL.null output
+ then output
+ else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]
+
+parseChangeKeyPasswordNewPassword
+ :: [String] -> IO (Maybe BL.ByteString)
+parseChangeKeyPasswordNewPassword [] = pure Nothing
+parseChangeKeyPasswordNewPassword [passwordFile] =
+ Just
+ <$> ( loadPasswordFromFile
+ "change-key-password"
+ "--new-key-password"
+ passwordFile
+ >>= normalizeHumanReadablePassword
+ "change-key-password"
+ "--new-key-password"
+ )
+parseChangeKeyPasswordNewPassword _ =
+ failWith
+ UnsupportedOption
+ "change-key-password: multiple --new-key-password values are not supported"
+
+hasSecretKeyMaterial :: TKUnknown -> Bool
+hasSecretKeyMaterial tk =
+ case _tkuKey tk of
+ (_, Just _) -> True
+ _ -> any isSecretSubkeyPkt (_tkuSubs tk)
+ where
+ isSecretSubkeyPkt (SecretSubkeyPkt _ _, _) = True
+ isSecretSubkeyPkt _ = False
+
+doValidateUserId :: POSIXTime -> ValidateUserIdOptions -> IO ()
+doValidateUserId cpt ValidateUserIdOptions {..} = do
+ authorityTks <-
+ concat
+ <$> mapM
+ (loadCertTKsFromFile "validate-userid")
+ validateUserIdAuthorityFiles
+ validateAtTime <- verificationUpperBound cpt validateUserIdAt
+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ certPkts <- decodeOpenPGPInput "standard input" input
+ certTks <-
+ runConduitRes $
+ CL.sourceList certPkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ when (null certTks) $
+ failWith
+ MissingInput
+ "validate-userid: no certificate found on standard input"
+ let targetUserId = T.pack validateUserIdString
+ forM_ certTks $ \certTk ->
+ when
+ ( not
+ ( certificateHasMatchingValidatedUserId
+ authorityTks
+ validateAtTime
+ validateUserIdAddrSpecOnly
+ targetUserId
+ certTk
+ )
+ )
+ $ failWith
+ CertUserIdNoMatch
+ ( "validate-userid: certificate has no correctly bound user ID matching "
+ ++ validateUserIdString
+ )
+
+certificateHasMatchingValidatedUserId
+ :: [TKUnknown] -> Maybe UTCTime -> Bool -> Text -> TKUnknown -> Bool
+certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =
+ case verifyUnknownTKWith verifier validateAtTime certTk of
+ Left _ -> False
+ Right verifiedTk -> any matchingBoundUid (_tkuUIDs verifiedTk)
+ where
+ verifier = verifySigWith (verifyAgainstKeys (certTk : authorityTks))
+ matchingBoundUid (uid, sigs) =
+ useridMatches addrSpecOnly targetUserId uid
+ && any (signatureMatchesSigner certTk) sigs
+ && any
+ (\sig -> any (`signatureMatchesSigner` sig) authorityTks)
+ sigs
+
+useridMatches :: Bool -> Text -> Text -> Bool
+useridMatches False targetUserId uid = uid == targetUserId
+useridMatches True targetUserId uid =
+ case conventionalAddrSpec uid of
+ Just addrSpec -> addrSpec == targetUserId
+ Nothing -> False
+
+conventionalAddrSpec :: Text -> Maybe Text
+conventionalAddrSpec uid =
+ let (prefix, suffix) = T.breakOnEnd (T.pack "<") uid
+ in if T.null prefix
+ then Nothing
+ else case T.unsnoc suffix of
+ Just (addrSpec, '>')
+ | T.any (== '<') addrSpec -> Nothing
+ | otherwise -> guardNonEmpty (T.strip addrSpec)
+ _ -> Nothing
+ where
+ guardNonEmpty text
+ | T.null text = Nothing
+ | otherwise = Just text
+
+signatureMatchesSigner :: TKUnknown -> SignaturePayload -> Bool
+signatureMatchesSigner signer sig =
+ maybe
+ False
+ (keyMatchesFingerprint False signer)
+ (signatureIssuerFingerprint sig)
+ || maybe
+ False
+ (keyMatchesEightOctetKeyId False signer . Right)
+ (signatureIssuerKeyId sig)
+
+signatureIssuerFingerprint
+ :: SignaturePayload -> Maybe Fingerprint
+signatureIssuerFingerprint =
+ listToMaybe . mapMaybe getIssuerFingerprint . signatureSubpackets
+ where
+ getIssuerFingerprint (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) =
+ Just issuerFingerprint
+ getIssuerFingerprint _ = Nothing
+
+signatureIssuerKeyId :: SignaturePayload -> Maybe EightOctetKeyId
+signatureIssuerKeyId = listToMaybe . mapMaybe getIssuerKeyId . signatureSubpackets
+ where
+ getIssuerKeyId (SigSubPacket _ (Issuer issuerKeyId)) = Just issuerKeyId
+ getIssuerKeyId _ = Nothing
+
+signatureSubpackets :: SignaturePayload -> [SigSubPacket]
+signatureSubpackets (SigV4 _ _ _ hashed unhashed _ _) = hashed ++ unhashed
+signatureSubpackets (SigV6 _ _ _ _ hashed unhashed _ _) = hashed ++ unhashed
+signatureSubpackets _ = []
+
+doCertifyUserId :: POSIXTime -> CertifyUserIdOptions -> IO ()
+doCertifyUserId _cpt CertifyUserIdOptions {..} = do
+ signerPasswordsRaw <-
+ loadPasswordFiles
+ "certify-userid"
+ "--with-key-password"
+ certifyUserIdKeyPasswordFiles
+ let signerPasswords = concatMap passwordRetryCandidates signerPasswordsRaw
+ signerTks <-
+ concat
+ <$> mapM
+ (loadCertifySignerTKsFromFile signerPasswords)
+ certifyUserIdSignerFiles
+ when (null signerTks) $
+ failWith
+ MissingInput
+ "certify-userid: no signer certificate found"
+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ certPkts <- decodeOpenPGPInput "standard input" input
+ targetTks <-
+ runConduitRes $
+ CL.sourceList certPkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ when (null targetTks) $
+ failWith
+ MissingInput
+ "certify-userid: no certificate found on standard input"
+ let targetUserIds = map T.pack certifyUserIds
+ requireSelfSig = not certifyUserIdNoRequireSelfSig
+ updatedTargets <-
+ mapM
+ ( \targetTk ->
+ addUserIdCertifications
+ targetTk
+ targetUserIds
+ requireSelfSig
+ signerTks
+ )
+ targetTks
+ let output = runPut (mapM_ Bin.put updatedTargets)
+ armorOutput =
+ case certifyUserIdOutputFormat of
+ Just "binary" -> output
+ _ -> AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
+ BL.putStr armorOutput
+
+loadCertifySignerTKsFromFile
+ :: [BL.ByteString] -> String -> IO [TKUnknown]
+loadCertifySignerTKsFromFile signerPasswords path = do
+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
+ packets <- decodeOpenPGPInput path lbs
+ tks <-
+ runConduitRes $
+ CL.sourceList packets
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ let fallbackTks = signingFallbackTKs packets
+ when (null tks && null fallbackTks) $
+ failWith
+ MissingInput
+ ("certify-userid: no signer key material found in " ++ path)
+ mapM
+ ( unlockTransferableSecretKeyMaterial
+ "certify-userid failed"
+ path
+ "--with-key-password"
+ signerPasswords
+ )
+ (if null tks then fallbackTks else tks)
+
+addUserIdCertifications
+ :: TKUnknown -> [Text] -> Bool -> [TKUnknown] -> IO TKUnknown
+addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do
+ forM_ targetUserIds $ \targetUserId ->
+ case find ((== targetUserId) . fst) (_tkuUIDs targetTk) of
+ Nothing ->
+ failWith
+ CertUserIdNoMatch
+ ( "certify-userid: target certificate has no user ID matching "
+ ++ T.unpack targetUserId
+ )
+ Just (_, sigs) ->
+ when
+ ( requireSelfSig
+ && not (any (signatureMatchesSigner targetTk) sigs)
+ )
+ $ failWith
+ CertUserIdNoMatch
+ ( "certify-userid: target user ID has no self-signature: "
+ ++ T.unpack targetUserId
+ )
+ newSigs <-
+ concat
+ <$> forM
+ signerTks
+ ( \signerTk ->
+ forM
+ targetUserIds
+ ( \targetUserId -> do
+ sig <- createUIDCertification targetUserId signerTk
+ pure (targetUserId, sig)
+ )
+ )
+ let updateUID (uid, sigs) =
+ if uid `elem` targetUserIds
+ then (uid, sigs ++ map snd (filter ((== uid) . fst) newSigs))
+ else (uid, sigs)
+ pure $ targetTk {_tkuUIDs = map updateUID (_tkuUIDs targetTk)}
+
+createUIDCertification
+ :: Text -> TKUnknown -> IO SignaturePayload
+createUIDCertification targetUserId signerTk = do
+ let (signerPkp, mSignerSka) = _tkuKey signerTk
+ signerSka <-
+ case mSignerSka of
+ Just ska -> pure ska
+ Nothing ->
+ failWith
+ KeyCannotCertify
+ "certify-userid: signer certificate has no secret key material"
+ signingKey <- rsaSigningKey signerSka
+ issuer <- issuerSubpacketsFor "certify-userid" signerPkp
+ let hashed = [SigSubPacket False (SigCreationTime (_timestamp signerPkp))]
+ certification =
+ signUserIDwithRSA
+ signerPkp
+ (UserId targetUserId)
+ hashed
+ issuer
+ signingKey
+ case certification of
+ Left err ->
+ failWith
+ BadData
+ ("certify-userid: failed to create certification: " ++ show err)
+ Right sig -> pure sig
+
+doRevokeKey :: POSIXTime -> RevokeKeyOptions -> IO ()
+doRevokeKey _cpt RevokeKeyOptions {..} = do
+ keyPasswordsRaw <-
+ loadPasswordFiles
+ "revoke-key"
+ "--with-key-password"
+ revokeKeyPasswordFiles
+ let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ keyPkts <- decodeOpenPGPInput "standard input" input
+ keyTks <-
+ runConduitRes $
+ CL.sourceList keyPkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ when (null keyTks) $
+ failWith
+ MissingInput
+ "revoke-key: no key found on standard input"
+ revocationSigPkts <-
+ mapM (createKeyRevocation keyPasswords) keyTks
+ let output = runPut (mapM_ Bin.put revocationSigPkts)
+ BL.putStr $
+ if revokeKeyNoArmor
+ then output
+ else AA.encodeLazy [Armor ArmorSignature [] output]
+ where
+ createKeyRevocation keyPasswords' keyTk = do
+ unlockedTk <-
+ unlockTransferableSecretKeyMaterial
+ "revoke-key failed"
+ "standard input"
+ "--with-key-password"
+ keyPasswords'
+ keyTk
+ let (pkp, mSka) = _tkuKey unlockedTk
+ ska <-
+ case mSka of
+ Just s -> pure s
+ Nothing ->
+ failWith
+ KeyCannotCertify
+ "revoke-key: key has no secret key material"
+ signingKey <- rsaSigningKey ska
+ issuer <- issuerSubpacketsFor "revoke-key" pkp
+ let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]
+ revocation = signKeyRevocationWithRSA pkp hashed issuer signingKey
+ case revocation of
+ Left err ->
+ failWith
+ BadData
+ ("revoke-key: failed to create revocation: " ++ show err)
+ Right sig -> pure (SignaturePkt sig)
+
+doRevokeUserId :: POSIXTime -> RevokeUserIdOptions -> IO ()
+doRevokeUserId _cpt RevokeUserIdOptions {..} = do
+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ keyPkts <- decodeOpenPGPInput "standard input" input
+ keyTks <-
+ runConduitRes $
+ CL.sourceList keyPkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ when (null keyTks) $
+ failWith
+ MissingInput
+ "revoke-userid: no key found on standard input"
+ let keyTk = case keyTks of
+ (kt : _) -> kt
+ _ ->
+ error
+ "revoke-userid: no key found on standard input (should be caught above)"
+ (pkp, mSka) = _tkuKey keyTk
+ targetUserId = T.pack revokeUserIdString
+ unless (any ((== targetUserId) . fst) (_tkuUIDs keyTk)) $
+ failWith
+ MissingInput
+ ( "revoke-userid: key has no user ID matching "
+ ++ revokeUserIdString
+ )
+ ska <-
+ case mSka of
+ Just s -> pure s
+ Nothing ->
+ failWith
+ KeyCannotCertify
+ "revoke-userid: key has no secret key material"
+ signingKey <- rsaSigningKey ska
+ issuer <- issuerSubpacketsFor "revoke-userid" pkp
+ let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]
+ revocation =
+ signCertRevocationWithRSA
+ pkp
+ (UserId targetUserId)
+ hashed
+ issuer
+ signingKey
+ case revocation of
+ Left err ->
+ failWith
+ BadData
+ ("revoke-userid: failed to create revocation: " ++ show err)
+ Right sig -> do
+ let revocationSigPkt = SignaturePkt sig
+ output = runPut (Bin.put revocationSigPkt)
+ BL.putStr $
+ if revokeUserIdNoArmor
+ then output
+ else AA.encodeLazy [Armor ArmorSignature [] output]
+
+doUpdateKey :: POSIXTime -> UpdateKeyOptions -> IO ()
+doUpdateKey cpt UpdateKeyOptions {..} = do
+ keyPasswordsRaw <-
+ loadPasswordFiles
+ "update-key"
+ "--with-key-password"
+ updateKeyPasswordFiles
+ let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
+ when updateKeyRevokeDeprecatedKeys $
+ hPutStrLn
+ stderr
+ "Warning: update-key: --revoke-deprecated-keys requested, but no deprecated-key detector is available; proceeding without synthetic revocations."
+ stdinInput <-
+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ stdinPkts <- decodeOpenPGPInput "stdin" stdinInput
+ stdinTks <-
+ runConduitRes $
+ CL.sourceList stdinPkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ when (null stdinTks) $
+ failWith
+ MissingInput
+ "update-key: no key found on standard input"
+ updateSourceTks <-
+ concat <$> mapM loadVerifyTKsFromFile updateKeyMergeCerts
+ when (null updateSourceTks) $
+ failWith MissingInput "update-key: no update keys found"
+ stdinUnlocked <-
+ mapM
+ (unlockUpdateKeyMaterial "standard input" keyPasswords)
+ stdinTks
+ updateUnlocked <-
+ mapM
+ (unlockUpdateKeyMaterial "update input" keyPasswords)
+ updateSourceTks
+ let updateTks =
+ if updateKeySigningOnly
+ then filter (updateKeyHasSigningCapability cpt) updateUnlocked
+ else updateUnlocked
+ when (updateKeySigningOnly && null updateTks) $
+ failWith
+ MissingInput
+ "update-key: no signing-capable update keys found"
+ let updatedTks =
+ map
+ ( \targetTk ->
+ foldl'
+ (<>)
+ targetTk
+ ( selectUpdateMergeInputs
+ cpt
+ updateKeyNoAddedCapabilities
+ targetTk
+ updateTks
+ )
+ )
+ stdinUnlocked
+ -- Choose armor type based on whether updated key has secret material
+ armorType =
+ if any hasSecretKeyMaterial updatedTks
+ then ArmorPrivateKeyBlock
+ else ArmorPublicKeyBlock
+ output = runPut (mapM_ Bin.put updatedTks)
+ BL.putStr $
+ if updateKeyNoArmor
+ then output
+ else AA.encodeLazy [Armor armorType [] output]
+
+doMergeCerts :: MergeCertsOptions -> IO ()
+doMergeCerts MergeCertsOptions {..} = do
+ stdinInput <-
+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ stdinPkts <- decodeOpenPGPInput "stdin" stdinInput
+ stdinTks <-
+ runConduitRes $
+ CL.sourceList stdinPkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ mergeInTks <-
+ concat <$> mapM loadVerifyTKsFromFile mergeCertsFiles
+ let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks
+ output = runPut (mapM_ Bin.put mergedTks)
+ BL.putStr $
+ if mergeCertsNoArmor || BL.null output
+ then output
+ else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
+
+mergeCertificatesForOutput
+ :: [TKUnknown] -> [TKUnknown] -> [TKUnknown]
+mergeCertificatesForOutput stdinTks mergeInTks =
+ map mergeGroup (groupByPrimaryKey stdinTks)
+ where
+ -- Upstream could expose this as a dedicated helper over TKWithWireRep
+ -- so downstreams can keep packet provenance while merging certs.
+ mergeGroup (base, rest) =
+ let primary = certificatePrimaryFingerprint base
+ mergedStdin = foldl' (<>) base rest
+ matchingMergeInputs =
+ filter ((== primary) . certificatePrimaryFingerprint) mergeInTks
+ in foldl' (<>) mergedStdin matchingMergeInputs
+
+groupByPrimaryKey :: [TKUnknown] -> [(TKUnknown, [TKUnknown])]
+groupByPrimaryKey [] = []
+groupByPrimaryKey (tk : rest) =
+ let primary = certificatePrimaryFingerprint tk
+ (samePrimary, differentPrimary) =
+ partition ((== primary) . certificatePrimaryFingerprint) rest
+ in (tk, samePrimary) : groupByPrimaryKey differentPrimary
+
+certificatePrimaryFingerprint :: TKUnknown -> B.ByteString
+certificatePrimaryFingerprint =
+ BL.toStrict . unFingerprint . fingerprint . fst . _tkuKey
+
+unlockUpdateKeyMaterial
+ :: String -> [BL.ByteString] -> TKUnknown -> IO TKUnknown
+unlockUpdateKeyMaterial _ [] tk = pure tk
+unlockUpdateKeyMaterial source keyPasswords tk =
+ unlockTransferableSecretKeyMaterial
+ "update-key failed"
+ source
+ "--with-key-password"
+ keyPasswords
+ tk
+
+updateKeyHasSigningCapability :: POSIXTime -> TKUnknown -> Bool
+updateKeyHasSigningCapability cpt tk =
+ any
+ ( \funKey ->
+ S.null (fkufs funKey) || S.member SignDataKey (fkufs funKey)
+ )
+ (tkToFunKeysAt cpt tk)
+
+selectUpdateMergeInputs
+ :: POSIXTime
+ -> Bool
+ -> TKUnknown
+ -> [TKUnknown]
+ -> [TKUnknown]
+selectUpdateMergeInputs cpt noAddedCaps targetTk updateTks =
+ filteredByCaps
+ where
+ targetPrimary = certificatePrimaryFingerprint targetTk
+ mergeCandidates =
+ filter
+ ((== targetPrimary) . certificatePrimaryFingerprint)
+ updateTks
+ targetCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt targetTk))
+ addsCapabilities updateTk =
+ let updateCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt updateTk))
+ in not (S.null (updateCapabilities S.\\ targetCapabilities))
+ filteredByCaps =
+ if noAddedCaps
+ then filter (not . addsCapabilities) mergeCandidates
+ else mergeCandidates
+
+soP :: Parser SignOptions
+soP =
+ SignOptions
+ <$> switch (long "armor" <> help "armor the output")
+ <*> switch (long "no-armor" <> help "don't armor the output")
+ <*> optional
+ ( strOption
+ ( long "micalg-out"
+ <> metavar "MICALG"
+ <> help "write MIME micalg parameter value to file"
+ )
+ )
+ <*> many
+ ( strOption
+ ( long "with-key-password"
+ <> help "password for unlocking signing key material"
+ )
+ )
+ <*> option
+ (eitherReader asTypeReader)
+ (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)
+ <*> some
+ ( strArgument
+ ( metavar "KEYS..."
+ <> help "paths to at least one secret key, one key per filename"
+ )
+ )
+ where
+ astypeHelp =
+ helpDoc . Just $
+ pretty "what to treat the input as"
+ <> softline
+ <> list (map (pretty . fst) asTypes)
+
+data SignOptions
+ = SignOptions
+ { sArmor :: Bool
+ , sNoArmor :: Bool
+ , sMicalgOut :: Maybe String
+ , sKeyPasswords :: [String]
+ , sAs :: AsBinaryText
+ , sKeyFiles :: [String]
+ }
+
+asTypes :: [(String, AsBinaryText)]
+asTypes = [("binary", AsBinary), ("text", AsText)]
+
+data AsBinaryText
+ = AsBinary
+ | AsText
+ deriving (Eq)
+
+data InlineSignMode
+ = InlineSignAsBinary
+ | InlineSignAsText
+ | InlineSignAsClearSigned
+ deriving (Eq)
+
+data EncryptFor
+ = EncryptForAny
+ | EncryptForStorage
+ | EncryptForCommunications
+ deriving (Eq)
+
+asTypeReader :: String -> Either String AsBinaryText
+asTypeReader = note "unknown as type" . flip lookup asTypes
+
+encryptForReader :: String -> Either String EncryptFor
+encryptForReader "any" = Right EncryptForAny
+encryptForReader "storage" = Right EncryptForStorage
+encryptForReader "communications" = Right EncryptForCommunications
+encryptForReader _ =
+ Left
+ "encryption purpose must be one of: any, storage, communications"
+
+doSign :: POSIXTime -> SignOptions -> IO ()
+doSign pt SignOptions {..} = do
+ when (sNoArmor && sArmor) $
+ failWith
+ IncompatibleOptions
+ "sign: --armor and --no-armor are mutually exclusive"
+ forM_ sMicalgOut (ensureOutputPathAvailable "sign")
+ mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
+ when (sAs == AsText) $
+ ensureUTF8TextInput "sign" (BL.fromChunks mbs)
+ forM_
+ sMicalgOut
+ (\_ -> ensureCanonicalMIMETextInput (BL.fromChunks mbs))
+ signingPasswordsRaw <-
+ loadPasswordFiles "sign" "--with-key-password" sKeyPasswords
+ let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw
+ ks <- loadSigningKeys sKeyFiles signingPasswords
+ let ts = ThirtyTwoBitTimeStamp (floor pt)
+ payload' = BL.fromChunks mbs
+ payload = payload'
+ processedKeys <- mapM (normalizeSigningKey pt) ks
+ let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys
+ signingHash =
+ selectSigningHash
+ (concat perTransferKeySigners)
+ []
+ legacySigningHashFallbackOrder
+ when (any null perTransferKeySigners) $
+ failWith
+ KeyCannotSign
+ "sign: supplied key cannot produce detached signatures"
+ signatures <-
+ mapM
+ (signData sAs ts signingHash payload)
+ (concat perTransferKeySigners)
+ let output = runPut (mapM_ (Bin.put . SignaturePkt) signatures)
+ case sMicalgOut of
+ Just outPath ->
+ writeFileWithOutputExistsCheck
+ "sign"
+ outPath
+ (renderMicalg signatures)
+ Nothing -> pure ()
+ BL.putStr $
+ if not sArmor && not sNoArmor
+ then AA.encodeLazy [Armor ArmorSignature [] output]
+ else output
+ where
+ signData
+ :: AsBinaryText
+ -> ThirtyTwoBitTimeStamp
+ -> HashAlgorithm
+ -> BL.ByteString
+ -> FunKey
+ -> IO SignaturePayload
+ signData mode t signHash d k = do
+ let st = case mode of
+ AsBinary -> BinarySig
+ AsText -> CanonicalTextSig
+ payload = d
+ issuerPackets <- unhashed (fpkp k)
+ signWithKey
+ "sign"
+ (fpkp k)
+ st
+ signHash
+ (hashed (fpkp k) t)
+ issuerPackets
+ payload
+ (fmska k)
+ hashed pkp ct =
+ [ SigSubPacket False (SigCreationTime ct)
+ , SigSubPacket
+ False
+ ( IssuerFingerprint
+ (issuerFingerprintVersionFor pkp)
+ (fingerprint pkp)
+ )
+ ]
+ unhashed pkp = issuerSubpacketsFor "sign" pkp
+loadSigningKeys :: [String] -> [BL.ByteString] -> IO [TKUnknown]
+loadSigningKeys keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles
+ where
+ loadFromFile path = do
+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
+ packets <- decodeOpenPGPInput path lbs
+ tks <-
+ runConduitRes $
+ CL.sourceList packets
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ let fallbackTks = signingFallbackTKs packets
+ when (null tks && null fallbackTks) $
+ failWith
+ MissingInput
+ ("sign: no secret key material found in " ++ path)
+ mapM
+ (decryptSigningKeyMaterial path keyPasswords)
+ (if null tks then fallbackTks else tks)
+
+decryptSigningKeyMaterial
+ :: FilePath -> [BL.ByteString] -> TKUnknown -> IO TKUnknown
+decryptSigningKeyMaterial path keyPasswords =
+ unlockTransferableSecretKeyMaterial
+ "sign failed"
+ path
+ "--with-key-password"
+ keyPasswords
+
+unlockTransferableSecretKeyMaterial
+ :: String
+ -> FilePath
+ -> String
+ -> [BL.ByteString]
+ -> TKUnknown
+ -> IO TKUnknown
+-- Upstream could expose a TK-wide secret-key rewrite helper so SOP
+-- subcommands do not need to walk primary and subkey packets separately.
+unlockTransferableSecretKeyMaterial context path passwordOption keyPasswords tk = do
+ keyPair' <- decryptSecretPart (_tkuKey tk)
+ subs' <- mapM decryptSub (_tkuSubs tk)
+ pure tk {_tkuKey = keyPair', _tkuSubs = subs'}
+ where
+ decryptSecretPart (pkp, Just ska) = do
+ ska' <-
+ unlockSecretAddendum
+ context
+ path
+ passwordOption
+ keyPasswords
+ pkp
+ ska
+ pure (pkp, Just ska')
+ decryptSecretPart keyPair = pure keyPair
+ decryptSub (SecretSubkeyPkt pkp ska, sigs) = do
+ ska' <-
+ unlockSecretAddendum
+ context
+ path
+ passwordOption
+ keyPasswords
+ pkp
+ ska
+ pure (SecretSubkeyPkt pkp ska', sigs)
+ decryptSub sub = pure sub
+
+unlockSecretAddendum
+ :: String
+ -> FilePath
+ -> String
+ -> [BL.ByteString]
+ -> SomePKPayload
+ -> SKAddendum
+ -> IO SKAddendum
+unlockSecretAddendum _ _ _ _ _ sk@(SUUnencrypted _ _) = pure sk
+unlockSecretAddendum context path passwordOption [] _ _ =
+ failWith
+ KeyIsProtected
+ ( context
+ ++ ": encrypted key material in "
+ ++ path
+ ++ " requires "
+ ++ passwordOption
+ )
+unlockSecretAddendum context path passwordOption keyPasswords pkp sk =
+ case tryDecrypt keyPasswords of
+ Right decrypted -> pure decrypted
+ Left _ ->
+ failWith
+ KeyIsProtected
+ ( context
+ ++ ": could not unlock key material in "
+ ++ path
+ ++ " with provided "
+ ++ passwordOption
+ ++ " values"
+ )
+ where
+ tryDecrypt [] = Left ()
+ tryDecrypt (password : rest) =
+ case decryptPrivateKey (pkp, sk) password of
+ Left _ -> tryDecrypt rest
+ Right decrypted -> Right decrypted
+
+normalizeSigningKey :: POSIXTime -> TKUnknown -> IO TKUnknown
+normalizeSigningKey pt tk =
+ case processTK (Just pt) tk of
+ Left err ->
+ failWith
+ BadData
+ ("sign: invalid signing key material: " ++ show err)
+ Right normalized -> pure normalized
+
+signPayloadWithKeys
+ :: POSIXTime
+ -> AsBinaryText
+ -> BL.ByteString
+ -> [TKUnknown]
+ -> [HashAlgorithm]
+ -> [HashAlgorithm]
+ -> IO [SignaturePayload]
+signPayloadWithKeys pt asMode payload keys recipientHashPrefs fallbackOrder = do
+ processedKeys <- mapM (normalizeSigningKey pt) keys
+ let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys
+ signingHash =
+ selectSigningHash
+ (concat perTransferKeySigners)
+ recipientHashPrefs
+ fallbackOrder
+ when (any null perTransferKeySigners) $
+ failWith
+ KeyCannotSign
+ "encrypt: supplied key cannot produce signatures"
+ mapM
+ (signData asMode ts signingHash payload)
+ (concat perTransferKeySigners)
+ where
+ ts = ThirtyTwoBitTimeStamp (floor pt)
+ signData
+ :: AsBinaryText
+ -> ThirtyTwoBitTimeStamp
+ -> HashAlgorithm
+ -> BL.ByteString
+ -> FunKey
+ -> IO SignaturePayload
+ signData mode t signHash d' k = do
+ let st = case mode of
+ AsBinary -> BinarySig
+ AsText -> CanonicalTextSig
+ payload' = d'
+ issuerPackets <- unhashed (fpkp k)
+ signWithKey
+ "encrypt"
+ (fpkp k)
+ st
+ signHash
+ (hashed (fpkp k) t)
+ issuerPackets
+ payload'
+ (fmska k)
+ hashed pkp ct =
+ [ SigSubPacket False (SigCreationTime ct)
+ , SigSubPacket
+ False
+ ( IssuerFingerprint
+ (issuerFingerprintVersionFor pkp)
+ (fingerprint pkp)
+ )
+ ]
+ unhashed pkp = issuerSubpacketsFor "encrypt" pkp
+
+signingCapableFunKeys :: POSIXTime -> TKUnknown -> [FunKey]
+signingCapableFunKeys pt =
+ filter canSign . tkToFunKeysAt pt
+ where
+ canSign k =
+ canSignDataUsage (fkufs k)
+ && case fmska k of
+ Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
+ Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
+ Just (SUUnencrypted (UnknownSKey _) _) ->
+ isEd25519PKA (_pkalgo (fpkp k))
+ || isEdDSAPKA (_pkalgo (fpkp k))
+ || isEd448PKA (_pkalgo (fpkp k))
+ _ -> False
+ canSignDataUsage keyFlags = S.null keyFlags || S.member SignDataKey keyFlags
+
+-- Legacy alias kept for internal call sites that have not been updated.
+signingCapableRSAFunKeys :: POSIXTime -> TKUnknown -> [FunKey]
+signingCapableRSAFunKeys = signingCapableFunKeys
+
+{- | Algorithm-dispatching signature helper used by all sign paths.
+Supports RSA (v4), Ed25519 (v4), and Ed448 (v4).
+-}
+signWithKey
+ :: String
+ -- ^ context for error messages
+ -> SomePKPayload
+ -> SigType
+ -> HashAlgorithm
+ -> [SigSubPacket]
+ -- ^ hashed subpackets
+ -> [SigSubPacket]
+ -- ^ unhashed subpackets
+ -> BL.ByteString
+ -- ^ payload to sign
+ -> Maybe SKAddendum
+ -> IO SignaturePayload
+signWithKey ctx signerPKP st signHash hsd usd payload mska =
+ case mska of
+ Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) ->
+ validateRSASigningKeySize ctx signerPKP
+ >> if _keyVersion signerPKP == V6
+ then signRSAWithV6Salt (k {RSA.private_p = 0, RSA.private_q = 0})
+ else
+ signWithRSABuilder
+ signHash
+ (k {RSA.private_p = 0, RSA.private_q = 0})
+ Just (SUUnencrypted (EdDSAPrivateKey Ed25519 rawBytes) _) ->
+ case eitherCryptoError (Ed25519.secretKey rawBytes) of
+ Left err ->
+ failWith
+ BadData
+ (ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
+ Right sk
+ | _keyVersion signerPKP == V6 -> signEd25519 sk
+ | isEdDSAPKA (_pkalgo signerPKP) ->
+ case signDataWithEd25519Legacy st sk hsd usd payload of
+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
+ Right sig -> pure sig
+ | otherwise ->
+ case signDataWithEd25519 st sk hsd usd payload of
+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
+ Right sig -> pure sig
+ Just (SUUnencrypted (EdDSAPrivateKey Ed448 rawBytes) _) ->
+ case eitherCryptoError (Ed448.secretKey rawBytes) of
+ Left err ->
+ failWith
+ BadData
+ (ctx ++ " failed: bad Ed448 secret key: " ++ show err)
+ Right sk
+ | _keyVersion signerPKP == V6 -> signEd448 sk
+ | otherwise ->
+ case signDataWithEd448 st sk hsd usd payload of
+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
+ Right sig -> pure sig
+ Just (SUUnencrypted (UnknownSKey rawBytes) _) ->
+ case () of
+ _
+ | isEd25519PKA (_pkalgo signerPKP) ->
+ do
+ normalized <- normalizeUnknownSecretForEdDSA ctx 32 rawBytes
+ case eitherCryptoError (Ed25519.secretKey normalized) of
+ Left err ->
+ failWith
+ BadData
+ (ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
+ Right sk
+ | _keyVersion signerPKP == V6 -> signEd25519 sk
+ | isEdDSAPKA (_pkalgo signerPKP) ->
+ case signDataWithEd25519Legacy st sk hsd usd payload of
+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
+ Right sig -> pure sig
+ | otherwise ->
+ case signDataWithEd25519 st sk hsd usd payload of
+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
+ Right sig -> pure sig
+ | isEd448PKA (_pkalgo signerPKP) ->
+ do
+ normalized <- normalizeUnknownSecretForEdDSA ctx 57 rawBytes
+ case eitherCryptoError (Ed448.secretKey normalized) of
+ Left err ->
+ failWith
+ BadData
+ (ctx ++ " failed: bad Ed448 secret key: " ++ show err)
+ Right sk
+ | _keyVersion signerPKP == V6 -> signEd448 sk
+ | otherwise ->
+ case signDataWithEd448 st sk hsd usd payload of
+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
+ Right sig -> pure sig
+ _ ->
+ failWith
+ UnsupportedAsymmetricAlgo
+ ( ctx
+ ++ " failed: unsupported unknown signing key for algorithm "
+ ++ show (_pkalgo signerPKP)
+ )
+ _ ->
+ failWith
+ BadData
+ (ctx ++ " failed: unsupported or encrypted signing key")
+ where
+ signEd25519 sk =
+ signWithV6Salt
+ (\salt -> signDataWithEd25519V6 st salt sk hsd usd payload)
+ signEd448 sk =
+ signWithV6Salt
+ (\salt -> signDataWithEd448V6 st salt sk hsd usd payload)
+ signRSAWithV6Salt privateKey =
+ signWithV6Salt
+ (\salt -> signDataWithRSAV6 st salt privateKey hsd usd payload)
+ signWithV6Salt signer = go [32, 64, 16, 20, 28, 48] []
+ where
+ go [] _ =
+ failWith
+ BadData
+ (ctx ++ " failed: unable to construct a valid v6 signature salt")
+ go (n : rest) tried = do
+ bytes <- getRandomBytes n
+ case signer (SignatureSalt (BL.fromStrict bytes)) of
+ Right sig -> pure sig
+ Left (SignV6SaltSizeMismatch _ expected _) ->
+ let expectedLen = fromIntegral expected
+ in if expectedLen `elem` tried
+ then
+ failWith
+ BadData
+ (ctx ++ " failed: unable to resolve v6 signature salt size")
+ else go (expectedLen : rest) (expectedLen : tried)
+ Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
+ signWithRSABuilder hashToUse privateKey =
+ let builder =
+ SP.addUnhashedSubs
+ (SubpacketList usd)
+ ( SP.addHashedSubs
+ (SubpacketList hsd)
+ (SP.sigBuilderInit st hashToUse)
+ )
+ in case signDataWithRSABuilder builder privateKey payload of
+ Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
+ Right sig -> pure sig
+
+normalizeUnknownSecretForEdDSA
+ :: String -> Int -> BL.ByteString -> IO B.ByteString
+normalizeUnknownSecretForEdDSA ctx expectedLen rawLbs
+ | B.length raw == expectedLen = pure raw
+ | B.length raw >= 2 =
+ let bits =
+ (fromIntegral (B.index raw 0) `shiftL` 8)
+ .|. fromIntegral (B.index raw 1)
+ mpiBytes = (bits + 7) `div` 8
+ payload = B.drop 2 raw
+ in if B.length payload == mpiBytes && mpiBytes <= expectedLen
+ then pure (i2ospOf_ expectedLen (os2ip payload))
+ else bad
+ | otherwise = bad
+ where
+ raw = BL.toStrict rawLbs
+ bad =
+ failWith
+ BadData
+ ( ctx
+ ++ " failed: unsupported EdDSA secret key encoding (length="
+ ++ show (B.length raw)
+ ++ ")"
+ )
+
+validateRSASigningKeySize :: String -> SomePKPayload -> IO ()
+validateRSASigningKeySize ctx signerPKP =
+ case pubkeySize (_pubkey signerPKP) of
+ Right bits
+ | bits < 2048 ->
+ failWith
+ KeyCannotSign
+ ( ctx
+ ++ " failed: RSA signing keys smaller than 2048 bits are not supported"
+ )
+ | otherwise -> pure ()
+ Left err ->
+ failWith
+ BadData
+ (ctx ++ " failed: unable to determine RSA key size: " ++ err)
+
+-- FIXME: clean this up
+isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool
+isEd25519PKA pka = fromFVal pka == 27
+isEdDSAPKA pka = fromFVal pka == 22
+isEd448PKA pka = fromFVal pka == 28
+
+selectSigningHash
+ :: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm
+selectSigningHash signerKeys recipientHashPrefs fallbackOrder =
+ fromMaybe
+ SHA512
+ (find (hashSupportedByAllSigners signerKeys) candidateOrder)
+ where
+ requestedPrefs =
+ if null recipientHashPrefs
+ then signerPrefs
+ else recipientHashPrefs
+ signerPrefs = concatMap fpreferredHashes signerKeys
+ filteredRequested = filter (hashSupportedByAllSigners signerKeys) requestedPrefs
+ filteredSignerPrefs = filter (hashSupportedByAllSigners signerKeys) signerPrefs
+ candidateOrder = filteredRequested ++ filteredSignerPrefs ++ fallbackOrder
+
+legacySigningHashFallbackOrder :: [HashAlgorithm]
+legacySigningHashFallbackOrder = [SHA512, SHA384, SHA256, SHA224]
+
+rfc9580SigningHashFallbackOrder :: [HashAlgorithm]
+rfc9580SigningHashFallbackOrder = [SHA3_512, SHA3_256, SHA512, SHA384, SHA256, SHA224]
+
+hashSupportedByAllSigners :: [FunKey] -> HashAlgorithm -> Bool
+hashSupportedByAllSigners signers ha =
+ not (isDeprecatedHashAlgorithm ha)
+ && all (`signerSupportsHashAlgorithm` ha) signers
+
+signerSupportsHashAlgorithm :: FunKey -> HashAlgorithm -> Bool
+signerSupportsHashAlgorithm signer ha =
+ not (isDeprecatedHashAlgorithm ha)
+ && case _pkalgo (fpkp signer) of
+ RSA -> rsaPKCS15SupportedHash ha
+ DeprecatedRSASignOnly -> rsaPKCS15SupportedHash ha
+ DeprecatedRSAEncryptOnly -> rsaPKCS15SupportedHash ha
+ _ -> not (isOtherHashAlgorithm ha)
+
+rsaPKCS15SupportedHash :: HashAlgorithm -> Bool
+rsaPKCS15SupportedHash SHA224 = True
+rsaPKCS15SupportedHash SHA256 = True
+rsaPKCS15SupportedHash SHA384 = True
+rsaPKCS15SupportedHash SHA512 = True
+rsaPKCS15SupportedHash _ = False
+
+isDeprecatedHashAlgorithm :: HashAlgorithm -> Bool
+isDeprecatedHashAlgorithm DeprecatedMD5 = True
+isDeprecatedHashAlgorithm SHA1 = True
+isDeprecatedHashAlgorithm RIPEMD160 = True
+isDeprecatedHashAlgorithm _ = False
+
+isOtherHashAlgorithm :: HashAlgorithm -> Bool
+isOtherHashAlgorithm (OtherHA _) = True
+isOtherHashAlgorithm _ = False
+
+hashAlgorithmHeaderName :: HashAlgorithm -> String
+hashAlgorithmHeaderName DeprecatedMD5 = "MD5"
+hashAlgorithmHeaderName SHA1 = "SHA1"
+hashAlgorithmHeaderName RIPEMD160 = "RIPEMD160"
+hashAlgorithmHeaderName SHA224 = "SHA224"
+hashAlgorithmHeaderName SHA256 = "SHA256"
+hashAlgorithmHeaderName SHA384 = "SHA384"
+hashAlgorithmHeaderName SHA512 = "SHA512"
+hashAlgorithmHeaderName SHA3_256 = "SHA3-256"
+hashAlgorithmHeaderName SHA3_512 = "SHA3-512"
+hashAlgorithmHeaderName (OtherHA _) = "SHA512"
+
+ensureCanonicalMIMETextInput :: BL.ByteString -> IO ()
+ensureCanonicalMIMETextInput lbs = do
+ let bs = BL.toStrict lbs
+ when (B.any (> 0x7f) bs) $
+ failWith
+ ExpectedText
+ "sign: --micalg-out requires canonical 7-bit text data on standard input"
+ case TE.decodeUtf8' bs of
+ Left _ ->
+ failWith
+ ExpectedText
+ "sign: --micalg-out requires UTF-8 text data on standard input"
+ Right _ -> pure ()
+ when (not (canonicalCRLFLineEndings bs)) $
+ failWith
+ ExpectedText
+ "sign: --micalg-out requires CRLF line endings on standard input"
+ when (hasTrailingLineWhitespace bs) $
+ failWith
+ ExpectedText
+ "sign: --micalg-out requires no trailing line whitespace on standard input"
+ where
+ canonicalCRLFLineEndings bytes = go (B.unpack bytes)
+ where
+ go [] = True
+ go [13] = False
+ go (13 : 10 : rest) = go rest
+ go (13 : _) = False
+ go (10 : _) = False
+ go (_ : rest) = go rest
+ hasTrailingLineWhitespace bytes =
+ endsWithWhitespace bytes
+ || trailingWhitespaceBeforeCRLF (B.unpack bytes)
+ endsWithWhitespace bytes =
+ case B.unsnoc bytes of
+ Just (_, c) -> c == 32 || c == 9
+ Nothing -> False
+ trailingWhitespaceBeforeCRLF (a : 13 : 10 : rest)
+ | a == 32 || a == 9 = True
+ | otherwise = trailingWhitespaceBeforeCRLF (13 : 10 : rest)
+ trailingWhitespaceBeforeCRLF (_ : rest) = trailingWhitespaceBeforeCRLF rest
+ trailingWhitespaceBeforeCRLF _ = False
+
+ensureUTF8TextInput :: String -> BL.ByteString -> IO ()
+ensureUTF8TextInput subcommand lbs =
+ case TE.decodeUtf8' (BL.toStrict lbs) of
+ Left _ ->
+ failWith
+ ExpectedText
+ (subcommand ++ ": --as=text requires UTF-8 text on standard input")
+ Right _ -> pure ()
+
+renderMicalg :: [SignaturePayload] -> String
+renderMicalg signatures =
+ case nub (mapMaybe signatureMicalg signatures) of
+ [micalg] -> micalg
+ _ -> ""
+ where
+ signatureMicalg (SigV4 _ _ ha _ _ _ _) = hashAlgorithmMicalg ha
+ signatureMicalg _ = Nothing
+ hashAlgorithmMicalg DeprecatedMD5 = Just "pgp-md5"
+ hashAlgorithmMicalg SHA1 = Just "pgp-sha1"
+ hashAlgorithmMicalg RIPEMD160 = Just "pgp-ripemd160"
+ hashAlgorithmMicalg SHA224 = Just "pgp-sha224"
+ hashAlgorithmMicalg SHA256 = Just "pgp-sha256"
+ hashAlgorithmMicalg SHA384 = Just "pgp-sha384"
+ hashAlgorithmMicalg SHA512 = Just "pgp-sha512"
+ hashAlgorithmMicalg SHA3_256 = Just "pgp-sha3-256"
+ hashAlgorithmMicalg SHA3_512 = Just "pgp-sha3-512"
+ hashAlgorithmMicalg (OtherHA _) = Nothing
+
+signingFallbackTKs :: [Pkt] -> [TKUnknown]
+signingFallbackTKs packets =
+ [ TKUnknown (pkp, Just ska) [] [] [] []
+ | SecretKeyPkt pkp ska <- packets
+ ]
+
+data FunKey
+ = FunKey
+ { fpkp :: SomePKPayload
+ , fmska :: Maybe SKAddendum
+ , fkufs :: S.Set KeyFlag
+ , fpreferredHashes :: [HashAlgorithm]
+ , fpreferredSymmetricAlgorithms :: [SymmetricAlgorithm]
+ , fsupportsSEIPDv2 :: Bool
+ }
+ deriving (Show)
+
+tkToFunKeysAt :: POSIXTime -> TKUnknown -> [FunKey]
+tkToFunKeysAt pt tk@(TKUnknown (pkp, mska) _ uids _ subs) =
+ catMaybes (mainKey : map extract subs)
+ where
+ mainPreferredHashes = effectiveHashPreferencesAt pt tk
+ mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt tk
+ mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt tk
+ mainKey =
+ Just
+ ( FunKey
+ pkp
+ mska
+ (fromMaybe S.empty (grabASig uids >>= sig2KUFs))
+ mainPreferredHashes
+ mainPreferredSymmetricAlgorithms
+ mainSupportsSEIPDv2
+ )
+ sig2KUFs = getHasheds >=> find isKUF >=> getKUFs
+ grabASig :: [(a, [b])] -> Maybe b
+ grabASig = (listToMaybe >=> listToMaybe) . map snd -- FIXME: this should grab the "best" sig
+ getHasheds :: SignaturePayload -> Maybe [SigSubPacket]
+ getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds
+ getHasheds (SigV6 _ _ _ _ hasheds _ _ _) = Just hasheds
+ getHasheds _ = Nothing
+ getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag)
+ getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs
+ getKUFs _ = Nothing
+ extract ((SecretSubkeyPkt spkp sska), sigs) =
+ return
+ ( FunKey
+ spkp
+ (Just sska)
+ (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
+ mainPreferredHashes
+ mainPreferredSymmetricAlgorithms
+ mainSupportsSEIPDv2
+ )
+ extract ((PublicSubkeyPkt spkp), sigs) =
+ return
+ ( FunKey
+ spkp
+ Nothing
+ (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
+ mainPreferredHashes
+ mainPreferredSymmetricAlgorithms
+ mainSupportsSEIPDv2
+ )
+ extract _ = Nothing
+
+effectiveHashPreferencesAt
+ :: POSIXTime -> TKUnknown -> [HashAlgorithm]
+effectiveHashPreferencesAt pt tk =
+ concatMap toHashes $
+ fromMaybe
+ []
+ ( effectiveKeyPreferencesAt
+ (posixSecondsToUTCTime (realToFrac pt))
+ tk
+ )
+ where
+ toHashes (PreferredHashAlgorithms hashes) = hashes
+ toHashes _ = []
+
+effectiveSymmetricPreferencesAt
+ :: POSIXTime -> TKUnknown -> [SymmetricAlgorithm]
+effectiveSymmetricPreferencesAt pt tk =
+ concatMap toSymmetricAlgorithms $
+ fromMaybe
+ []
+ ( effectiveKeyPreferencesAt
+ (posixSecondsToUTCTime (realToFrac pt))
+ tk
+ )
+ where
+ toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms
+ toSymmetricAlgorithms _ = []
+
+effectiveSEIPDv2SupportAt :: POSIXTime -> TKUnknown -> Bool
+effectiveSEIPDv2SupportAt pt tk =
+ any supportsSEIPDv2Flag $
+ concatMap toFeatureFlags $
+ fromMaybe
+ []
+ ( effectiveKeyPreferencesAt
+ (posixSecondsToUTCTime (realToFrac pt))
+ tk
+ )
+ where
+ toFeatureFlags (Features flags) = S.toList flags
+ toFeatureFlags _ = []
+ supportsSEIPDv2Flag FeatureSEIPDv2 = True
+ supportsSEIPDv2Flag _ = False
+
+-- SOP Handler Stubs
+-- These implement the stateless OpenPGP CLI commands per draft-16
+
+doVerify :: POSIXTime -> VerifyOptions -> IO ()
+doVerify cpt VerifyOptions {..} = do
+ (krs, verifyTks) <- loadVerifyContext cpt verifyCertFiles
+ signatureInput <-
+ runConduitRes $ CC.sourceFile verifySigFile .| CC.sinkLazy
+ sigPkts <- decodeLikeSignaturePackets signatureInput
+ let sigs = V.fromList (filter isDetachedVerificationSignaturePkt sigPkts)
+ blob <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ upperBound <- verificationUpperBound cpt verifyNotAfter
+ lowerBound <- verificationLowerBound cpt verifyNotBefore
+ let sigsWithoutUnsupportedCritical =
+ V.filter
+ (not . detachedSignatureHasUnsupportedCriticalSubpackets)
+ sigs
+ binaryVerifications <-
+ verifyWithLiteralData
+ BinaryData
+ blob
+ sigsWithoutUnsupportedCritical
+ krs
+ upperBound
+ verifications <-
+ if any isRight binaryVerifications
+ then pure binaryVerifications
+ else
+ verifyWithLiteralData
+ TextData
+ blob
+ sigsWithoutUnsupportedCritical
+ krs
+ upperBound
+ let decodedVerifications = map (first show) verifications
+ signerPolicyAdjusted =
+ map
+ (enforceVerificationSignerPolicy cpt verifyTks)
+ decodedVerifications
+ let filtered =
+ filterByVerificationBounds
+ lowerBound
+ upperBound
+ signerPolicyAdjusted
+ policyFiltered =
+ filter (not . verificationResultUsesDeprecatedHash) filtered
+ mapM_
+ (putStrLn . renderSOPVerificationLine verifyTks)
+ (rights policyFiltered)
+ case any isRight policyFiltered of
+ True -> exitSuccess
+ _ -> failWith NoSignature "No acceptable signatures found"
+ where
+ decodeLikeSignaturePackets lbs = do
+ decodedArmors <-
+ decodeAsciiArmorInput
+ ("signature input in " ++ verifySigFile)
+ lbs
+ case decodedArmors of
+ Just armors ->
+ case firstBy isDetachedSignatureArmor armors of
+ Just (Armor ArmorSignature _ bs) ->
+ parseOpenPGPPackets
+ ("signature input in " ++ verifySigFile)
+ (BL.fromStrict (BLC8.toStrict bs))
+ _ ->
+ case firstBy isDetachedSignatureUnsupportedArmor armors of
+ Just (ClearSigned _ _ _) ->
+ failWith
+ BadData
+ ("verify: expected detached signatures in " ++ verifySigFile)
+ Just (Armor _ _ _) ->
+ failWith
+ BadData
+ ("verify: expected signature armor in " ++ verifySigFile)
+ _ ->
+ parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs
+ Nothing ->
+ parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs
+ verifyWithLiteralData format payload sigs keyring upperBound =
+ runConduitRes $
+ CC.yieldMany
+ (V.cons (LiteralDataPkt format mempty 0 payload) sigs)
+ .| conduitVerify keyring upperBound
+ .| CC.sinkList
+
+detachedSignatureHasUnsupportedCriticalSubpackets :: Pkt -> Bool
+detachedSignatureHasUnsupportedCriticalSubpackets (SignaturePkt sig) =
+ any criticalUnsupported (signatureHashedSubpackets sig)
+ where
+ criticalUnsupported (SigSubPacket True (OtherSigSub _ _)) = True
+ criticalUnsupported (SigSubPacket True (UserDefinedSigSub _ _)) = True
+ criticalUnsupported (SigSubPacket True (NotationData _ _ _)) = True
+ criticalUnsupported _ = False
+detachedSignatureHasUnsupportedCriticalSubpackets _ = False
+
+signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]
+signatureHashedSubpackets (SigV4 _ _ _ hashed _ _ _) = hashed
+signatureHashedSubpackets (SigV6 _ _ _ _ hashed _ _ _) = hashed
+signatureHashedSubpackets _ = []
+
+verificationResultUsesDeprecatedHash
+ :: Either String Verification -> Bool
+verificationResultUsesDeprecatedHash (Right verification) =
+ verificationUsesDeprecatedHash verification
+verificationResultUsesDeprecatedHash _ = False
+
+verificationUsesDeprecatedHash :: Verification -> Bool
+verificationUsesDeprecatedHash (Verification _ sigPayload _) =
+ isDeprecatedHashAlgorithm (signatureHashAlgorithm sigPayload)
+
+signatureHashAlgorithm :: SignaturePayload -> HashAlgorithm
+signatureHashAlgorithm (SigV3 _ _ _ _ ha _ _) = ha
+signatureHashAlgorithm (SigV4 _ _ ha _ _ _ _) = ha
+signatureHashAlgorithm (SigV6 _ _ ha _ _ _ _ _) = ha
+signatureHashAlgorithm (SigVOther _ _) = OtherHA 0
+
+enforceVerificationSignerPolicy
+ :: POSIXTime
+ -> [TKUnknown]
+ -> Either String Verification
+ -> Either String Verification
+enforceVerificationSignerPolicy _ _ result@(Left _) = result
+enforceVerificationSignerPolicy cpt verifyTks result@(Right verification)
+ | signerAllowed = result
+ | otherwise =
+ Left
+ "verification failed: signer key is not valid for signing at signature creation time"
+ where
+ signerAllowed = any signerMatchesProcessed verifyTks
+ signerFp = fingerprint (_verificationSigner verification)
+ verificationTimePosix =
+ maybe
+ cpt
+ (realToFrac . utcTimeToPOSIXSeconds)
+ (signatureCreationTime (_verificationSignature verification))
+ verificationTime = posixSecondsToUTCTime verificationTimePosix
+ signerMatchesProcessed tk
+ | not (keyMatchesFingerprint True tk signerFp) = False
+ | keyMatchesFingerprint False tk signerFp = True
+ | otherwise =
+ any (subkeyAllowsSigning verificationTime signerFp) (_tkuSubs tk)
+
+subkeyAllowsSigning
+ :: UTCTime -> Fingerprint -> (Pkt, [SignaturePayload]) -> Bool
+subkeyAllowsSigning t signerFp (pkt, sigs) =
+ case subkeyPayload pkt of
+ Just pkp
+ | fingerprint pkp == signerFp ->
+ any
+ (bindingSignatureAllowsSigning t)
+ (filter isSKBindingSig sigs)
+ _ -> False
+ where
+ subkeyPayload (PublicSubkeyPkt pkp) = Just pkp
+ subkeyPayload (SecretSubkeyPkt pkp _) = Just pkp
+ subkeyPayload _ = Nothing
+
+bindingSignatureAllowsSigning
+ :: UTCTime -> SignaturePayload -> Bool
+bindingSignatureAllowsSigning t sig =
+ allowsSigning && hasValidBacksig
+ where
+ allowsSigning =
+ let flagSets = signatureKeyFlagSets sig
+ in null flagSets || any (S.member SignDataKey) flagSets
+ hasValidBacksig =
+ any
+ ( \embedded ->
+ isPKBindingSig embedded
+ && not (signatureExpiredAt t embedded)
+ )
+ (signatureEmbeddedSignatures sig)
+
+signatureEmbeddedSignatures
+ :: SignaturePayload -> [SignaturePayload]
+signatureEmbeddedSignatures sig =
+ [ embedded
+ | SigSubPacket _ (EmbeddedSignature embedded) <-
+ signatureSubpackets sig
+ ]
+
+signatureKeyFlagSets :: SignaturePayload -> [S.Set KeyFlag]
+signatureKeyFlagSets sig =
+ [ flags
+ | SigSubPacket _ (KeyFlags flags) <- signatureSubpackets sig
+ ]
+
+signatureExpiredAt :: UTCTime -> SignaturePayload -> Bool
+signatureExpiredAt t sig =
+ case (signatureCreationTime sig, signatureValiditySeconds sig) of
+ (Just created, Just validitySeconds) ->
+ utcTimeToPOSIXSeconds t
+ >= utcTimeToPOSIXSeconds created + fromIntegral validitySeconds
+ _ -> False
+
+signatureValiditySeconds :: SignaturePayload -> Maybe Integer
+signatureValiditySeconds sig =
+ listToMaybe
+ [ fromIntegral secs
+ | SigSubPacket _ (SigExpirationTime (ThirtyTwoBitDuration secs)) <-
+ signatureSubpackets sig
+ ]
+verificationUpperBound
+ :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)
+verificationUpperBound cpt Nothing = return (Just (posixSecondsToUTCTime cpt))
+verificationUpperBound _ (Just "-") = return Nothing
+verificationUpperBound cpt (Just "now") =
+ return (Just (posixSecondsToUTCTime cpt))
+verificationUpperBound _ (Just s) = do
+ let m = iso8601ParseM s :: Maybe UTCTime
+ case m of
+ Just t -> return (Just t)
+ Nothing -> failWith BadData ("Invalid DATE value: " ++ s)
+
+verificationLowerBound
+ :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)
+verificationLowerBound _ Nothing = return Nothing
+verificationLowerBound _ (Just "-") = return Nothing
+verificationLowerBound cpt (Just "now") =
+ return (Just (posixSecondsToUTCTime cpt))
+verificationLowerBound _ (Just s) = do
+ let m = iso8601ParseM s :: Maybe UTCTime
+ case m of
+ Just t -> return (Just t)
+ Nothing -> failWith BadData ("Invalid DATE value: " ++ s)
+
+filterByVerificationBounds
+ :: Maybe UTCTime
+ -> Maybe UTCTime
+ -> [Either String Verification]
+ -> [Either String Verification]
+filterByVerificationBounds lower upper = map (>>= ensureBounds)
+ where
+ ensureBounds v =
+ case signatureCreationTime (_verificationSignature v) of
+ Nothing ->
+ Left "verification failed: signature is missing creation time"
+ Just sigTime
+ | Just upperBound <- upper
+ , sigTime > upperBound ->
+ Left
+ "verification failed: signature created after --not-after bound"
+ | Just lowerBound <- lower
+ , sigTime < lowerBound ->
+ Left
+ "verification failed: signature created before --not-before bound"
+ | otherwise -> Right v
+
+signatureCreationTime :: SignaturePayload -> Maybe UTCTime
+signatureCreationTime (SigV4 _ _ _ hashed _ _ _) =
+ firstCreationTime hashed
+signatureCreationTime (SigV6 _ _ _ _ hashed _ _ _) =
+ firstCreationTime hashed
+signatureCreationTime _ = Nothing
+
+firstCreationTime :: [SigSubPacket] -> Maybe UTCTime
+firstCreationTime = listToMaybe . mapMaybe getCreation
+ where
+ getCreation (SigSubPacket _ (SigCreationTime (ThirtyTwoBitTimeStamp ts))) =
+ Just (posixSecondsToUTCTime (fromIntegral ts))
+ getCreation _ = Nothing
+
+isDetachedVerificationSignaturePkt :: Pkt -> Bool
+isDetachedVerificationSignaturePkt (SignaturePkt (SigV4 sigType _ _ _ _ _ _)) =
+ sigType == BinarySig || sigType == CanonicalTextSig
+isDetachedVerificationSignaturePkt (SignaturePkt (SigV6 sigType _ _ _ _ _ _ _)) =
+ sigType == BinarySig || sigType == CanonicalTextSig
+isDetachedVerificationSignaturePkt _ = False
+
+doInlineVerify :: POSIXTime -> InlineVerifyOptions -> IO ()
+doInlineVerify cpt InlineVerifyOptions {..} = do
+ (krs, verifyTks) <- loadVerifyContext cpt inlineCertFiles
+ signedInput <-
+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ upperBound <- verificationUpperBound cpt inlineNotAfter
+ lowerBound <- verificationLowerBound cpt inlineNotBefore
+ (allowTrailingSignatures, parsedPackets) <-
+ inlineVerifyPackets signedInput
+ packets <-
+ normalizeInlineVerifyPackets
+ allowTrailingSignatures
+ parsedPackets
+ let verifications =
+ map (first show) (verifyPacketsBatch krs upperBound packets)
+ filtered = filterByVerificationBounds lowerBound upperBound verifications
+ successLines = map (renderSOPVerificationLine verifyTks) (rights filtered)
+ renderedOut =
+ if null successLines
+ then ""
+ else unlines successLines
+ case verificationsOut of
+ Just outPath ->
+ writeFileWithOutputExistsCheck
+ "inline-verify"
+ outPath
+ renderedOut
+ Nothing -> pure ()
+ case any isRight filtered of
+ True ->
+ extractSingleLiteralPayload packets >>= BL.putStr >> exitSuccess
+ _ -> failWith NoSignature "No acceptable signatures found"
+ where
+ inlineVerifyPackets :: BL.ByteString -> IO (Bool, [Pkt])
+ inlineVerifyPackets lbs = do
+ decodedArmors <- decodeAsciiArmorInput "inline-verify input" lbs
+ case decodedArmors of
+ Just armors ->
+ case listToMaybe (filter isInlineVerifyCandidateArmor armors) of
+ Just (Armor ArmorMessage _ bs) -> do
+ let packetBytes = BL.fromStrict (BLC8.toStrict bs)
+ packets <-
+ parseInlineVerifyMessagePackets
+ "inline-verify armored message"
+ packetBytes
+ pure (False, packets)
+ Just (ClearSigned headers cleartext signatureArmor) -> do
+ validateClearSignedEnvelopeBounds lbs
+ validateClearSignedHeaders headers
+ sigPkts <- clearSignedSignaturePackets signatureArmor
+ pure
+ ( True
+ , LiteralDataPkt
+ TextData
+ BL.empty
+ 0
+ (BL.fromStrict (BLC8.toStrict cleartext))
+ : sigPkts
+ )
+ Just (Armor _ _ _) ->
+ failWith
+ BadData
+ "inline-verify expects an armored OpenPGP message or cleartext signed message"
+ Nothing -> do
+ packets <-
+ parseInlineVerifyMessagePackets "inline-verify input" lbs
+ pure (False, packets)
+ Nothing -> do
+ packets <-
+ parseInlineVerifyMessagePackets "inline-verify input" lbs
+ pure (False, packets)
+
+ parseInlineVerifyMessagePackets
+ :: String -> BL.ByteString -> IO [Pkt]
+ parseInlineVerifyMessagePackets context packetBytes = do
+ rawPkts <- parseRawOpenPGPPackets context packetBytes
+ when (any compressedPacketParseFailed rawPkts) $
+ failWith
+ BadData
+ "inline-verify input has malformed compressed packet data"
+ when (any compressedPacketIsEmpty rawPkts) $
+ failWith
+ BadData
+ "inline-verify input has empty compressed packet data"
+ expanded <- expandPacketsStrict context rawPkts
+ when
+ (any isMarkerPacket expanded && any isCompressedPacket rawPkts)
+ $ failWith
+ BadData
+ "inline-verify input has malformed compressed packet sequence"
+ pure expanded
+
+ expandPacketsStrict :: String -> [Pkt] -> IO [Pkt]
+ expandPacketsStrict context =
+ fmap concat . mapM expandPacket
+ where
+ expandPacket pkt =
+ case decompressPkt pkt of
+ Left err ->
+ failWith
+ BadData
+ ( context
+ ++ ": failed to parse compressed packet: "
+ ++ renderCompressionError err
+ )
+ Right packets -> pure packets
+
+isInlineVerifyCandidateArmor :: Armor -> Bool
+isInlineVerifyCandidateArmor (Armor ArmorMessage _ _) = True
+isInlineVerifyCandidateArmor ClearSigned {} = True
+isInlineVerifyCandidateArmor _ = False
+
+clearSignedSignaturePackets :: Armor -> IO [Pkt]
+clearSignedSignaturePackets (Armor ArmorSignature _ sigbs) =
+ let sigPktsSource =
+ parseOpenPGPPackets
+ "cleartext signature block"
+ (BL.fromStrict (BLC8.toStrict sigbs))
+ in do
+ parsed <- sigPktsSource
+ let sigPkts = filter isSignaturePkt parsed
+ if null sigPkts
+ then
+ failWith
+ BadData
+ "cleartext signature block has no signature packets"
+ else return sigPkts
+clearSignedSignaturePackets (Armor _ _ _) =
+ failWith
+ BadData
+ "cleartext signed message does not contain an armored signature block"
+clearSignedSignaturePackets (ClearSigned _ _ inner) =
+ clearSignedSignaturePackets inner
+
+isSignaturePkt :: Pkt -> Bool
+isSignaturePkt SignaturePkt {} = True
+isSignaturePkt _ = False
+
+normalizeInlineVerifyPackets :: Bool -> [Pkt] -> IO [Pkt]
+normalizeInlineVerifyPackets allowTrailingSignatures pkts
+ | any isBrokenPacket relevantPkts =
+ failWith
+ BadData
+ "inline-verify input contains malformed packet encoding"
+ | any (not . isInlineVerificationPacket) filteredPkts =
+ failWith
+ BadData
+ "inline-verify input contains unsupported packet types"
+ | otherwise =
+ case ( [pkt | pkt@LiteralDataPkt {} <- filteredPkts]
+ , [pkt | pkt@SignaturePkt {} <- filteredPkts]
+ ) of
+ ([], _) ->
+ failWith
+ BadData
+ "inline-verify input has no literal message payload"
+ ([_], []) ->
+ failWith
+ BadData
+ "inline-verify input has no signatures"
+ ([lit], sigs)
+ | not hasOnePass
+ && ( null signaturePositions
+ || not (all (< literalIndex) signaturePositions)
+ )
+ && ( not allowTrailingSignatures
+ || not (all (> literalIndex) signaturePositions)
+ ) ->
+ failWith
+ BadData
+ "inline-verify input has malformed signed-message packet order"
+ | otherwise -> pure (lit : sigs)
+ (_, _) ->
+ failWith
+ BadData
+ "inline-verify input contains multiple literal payloads"
+ where
+ relevantPkts = filter (not . isMarkerPacket) pkts
+ filteredPkts = filter (not . isIgnorableInlineVerifyPacket) relevantPkts
+ packetPositions = zip [0 :: Int ..] filteredPkts
+ signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]
+ onePassPositions = [i | (i, OnePassSignaturePkt {}) <- packetPositions]
+ literalPositions = [i | (i, LiteralDataPkt {}) <- packetPositions]
+ hasOnePass = not (null onePassPositions)
+ literalIndex =
+ case literalPositions of
+ (i : _) -> i
+ [] -> -1
+ isBrokenPacket BrokenPacketPkt {} = True
+ isBrokenPacket _ = False
+
+isIgnorableInlineVerifyPacket :: Pkt -> Bool
+isIgnorableInlineVerifyPacket (OtherPacketPkt tag _) = tag >= 40
+isIgnorableInlineVerifyPacket _ = False
+
+isInlineVerificationPacket :: Pkt -> Bool
+isInlineVerificationPacket LiteralDataPkt {} = True
+isInlineVerificationPacket SignaturePkt {} = True
+isInlineVerificationPacket OnePassSignaturePkt {} = True
+isInlineVerificationPacket (OtherPacketPkt tag _) = tag >= 40
+isInlineVerificationPacket BrokenPacketPkt {} = False
+isInlineVerificationPacket _ = False
+
+doEncrypt :: POSIXTime -> EncryptOptions -> IO ()
+doEncrypt cpt EncryptOptions {..} = do
+ when (encNoArmor && encArmor) $
+ failWith
+ IncompatibleOptions
+ "encrypt: --armor and --no-armor are mutually exclusive"
+ payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ when (encAs == AsText) $
+ ensureUTF8TextInput "encrypt" payload
+ when encWithoutIntegrityCheck $
+ failWith
+ UnsupportedOption
+ "encrypt: --without-integrity-check is not supported by this backend"
+ symmetricPasswordsRaw <-
+ loadPasswordFiles "encrypt" "--with-password" encPasswords
+ symmetricPasswords <-
+ mapM
+ (normalizeHumanReadablePassword "encrypt" "--with-password")
+ symmetricPasswordsRaw
+ signingKeyPasswordsRaw <-
+ loadPasswordFiles
+ "encrypt"
+ "--with-key-password"
+ encSignWithKeyPasswords
+ let signingKeyPasswords = concatMap passwordRetryCandidates signingKeyPasswordsRaw
+ encryptProfile <- parseEncryptProfile encProfile
+ when
+ (not (null encRecipientCerts) && not (null symmetricPasswords))
+ $ failWith
+ UnsupportedOption
+ "encrypt: combining recipient certificates with --with-password is not yet supported"
+ recipientKeys <-
+ if null encRecipientCerts
+ then pure []
+ else loadEncryptRecipients cpt encFor encRecipientCerts
+ recipientHashPrefs <-
+ if null encRecipientCerts
+ then pure []
+ else loadRecipientPreferredHashes cpt encRecipientCerts
+ signatures <-
+ if null encSignWithKeyFiles
+ then pure []
+ else do
+ signingKeys <-
+ loadSigningKeys encSignWithKeyFiles signingKeyPasswords
+ signPayloadWithKeys
+ cpt
+ encAs
+ payload
+ signingKeys
+ recipientHashPrefs
+ ( case encryptProfile of
+ EncryptProfileRFC9580 -> rfc9580SigningHashFallbackOrder
+ EncryptProfileRFC4880 -> legacySigningHashFallbackOrder
+ )
+ out <-
+ case encRecipientCerts of
+ [] ->
+ doEncryptWithPassword
+ encryptProfile
+ payload
+ symmetricPasswords
+ encSessionKeyOutFile
+ _ ->
+ doEncryptForRecipients
+ encryptProfile
+ encAs
+ payload
+ signatures
+ recipientKeys
+ encSessionKeyOutFile
+ BL.putStr $
+ if encNoArmor
+ then out
+ else AA.encodeLazy [Armor ArmorMessage [] out]
+
+doEncryptWithPassword
+ :: EncryptProfile
+ -> BL.ByteString
+ -> [BL.ByteString]
+ -> Maybe String
+ -> IO BL.ByteString
+doEncryptWithPassword encryptProfile payload passwords sessionKeyOutFile = do
+ password <-
+ case passwords of
+ [] ->
+ failWith
+ MissingArg
+ "encrypt: supply at least one recipient certificate or --with-password"
+ [p] -> pure p
+ _ ->
+ failWith
+ UnsupportedOption
+ "encrypt: multiple --with-password values are not yet supported"
+ let exposure =
+ if isJust sessionKeyOutFile
+ then ExposeSessionMaterial
+ else DoNotExposeSessionMaterial
+ encrypted <-
+ case encryptProfile of
+ EncryptProfileRFC9580 -> do
+ s2kSalt <- Salt16 <$> getRandomBytes 16
+ iv <- IV <$> getRandomBytes 32
+ pure $
+ encryptMessage
+ RFC9580EncryptMessageOptions
+ { rfc9580EncryptMessageExposure = exposure
+ , rfc9580EncryptMessageSymmetricAlgorithm = AES256
+ , rfc9580EncryptMessageS2K = Argon2 s2kSalt 1 4 15
+ , rfc9580EncryptMessageIV = iv
+ }
+ (mkPassphrase password)
+ (mkClearPayload payload)
+ EncryptProfileRFC4880 -> do
+ salt <- Salt8 <$> getRandomBytes 8
+ iv <- IV <$> getRandomBytes 16
+ pure $
+ encryptMessage
+ RFC4880EncryptMessageOptions
+ { rfc4880EncryptMessageExposure = exposure
+ , rfc4880EncryptMessageSymmetricAlgorithm = AES256
+ , rfc4880EncryptMessageS2K = IteratedSalted SHA256 salt 65536
+ , rfc4880EncryptMessageIV = iv
+ }
+ (mkPassphrase password)
+ (mkClearPayload payload)
+ case encrypted of
+ Left err -> failWith BadData ("encrypt failed: " ++ show err)
+ Right (ciphertext, mRecoveredSession) -> do
+ forM_ sessionKeyOutFile $ \path ->
+ case mRecoveredSession of
+ Just recoveredSession ->
+ writeFileWithOutputExistsCheck
+ "encrypt"
+ path
+ ( renderSessionKeyOutLine
+ (fromFVal (recoveredSessionAlgorithm recoveredSession))
+ (unSessionKey (recoveredSessionKey recoveredSession))
+ ++ "\n"
+ )
+ Nothing ->
+ failWith
+ UnsupportedOption
+ "encrypt: --session-key-out unavailable for this password encryption mode"
+ pure (encryptedPayloadBytes ciphertext)
+
+doEncryptForRecipients
+ :: EncryptProfile
+ -> AsBinaryText
+ -> BL.ByteString
+ -> [SignaturePayload]
+ -> [FunKey]
+ -> Maybe String
+ -> IO BL.ByteString
+doEncryptForRecipients encryptProfile asMode payload signatures recipients sessionKeyOutFile = do
+ let targets = map recipientTargetFor recipients
+ payloadShape =
+ defaultRecipientPayloadShape
+ { recipientPayloadDataType = literalDataType
+ , recipientPayloadUseOnePassSignatures = not (null signatures)
+ , recipientPayloadSignatures = signatures
+ }
+ result <-
+ if useStrictEncryptProfile
+ then
+ encryptForRecipients
+ RecipientEncryptRequest
+ { recipientEncryptRequestTargets = targets
+ , recipientEncryptRequestPayloadShape = payloadShape
+ , recipientEncryptRequestPayload = BL.toStrict payload
+ , recipientEncryptRequestSymmetricOverride = symmetricOverride
+ , recipientEncryptRequestOverrides =
+ RecipientEncryptRequestSEIPDv2Overrides
+ { recipientEncryptRequestAEADOverride = Nothing
+ , recipientEncryptRequestChunkSizeOverride = Nothing
+ , recipientEncryptRequestSaltOverride = Nothing
+ }
+ }
+ else
+ encryptForRecipients
+ RecipientEncryptRequest
+ { recipientEncryptRequestTargets = targets
+ , recipientEncryptRequestPayloadShape = payloadShape
+ , recipientEncryptRequestPayload = BL.toStrict payload
+ , recipientEncryptRequestSymmetricOverride = symmetricOverride
+ , recipientEncryptRequestOverrides =
+ RecipientEncryptRequestSEIPDv1Overrides
+ { recipientEncryptRequestIVOverride = Nothing
+ }
+ }
+ RecipientEncryptResult {..} <-
+ case result of
+ Left err ->
+ failWith
+ (sopFailureForPKESKEncryptError err)
+ ("encrypt failed: " ++ renderPKESKEncryptError err)
+ Right val -> pure val
+ forM_ sessionKeyOutFile $ \path ->
+ writeFileWithOutputExistsCheck
+ "encrypt"
+ path
+ ( renderSessionKeyOutLine
+ (fromFVal (pkeskSessionAlgorithm recipientEncryptSessionMaterial))
+ (unSessionKey (pkeskSessionKey recipientEncryptSessionMaterial))
+ ++ "\n"
+ )
+ pure (runPut (Bin.put (Block recipientEncryptPackets)))
+ where
+ literalDataType =
+ case asMode of
+ AsBinary -> BinaryData
+ AsText -> UTF8Data
+ anyRecipientSupportsSEIPDv2 = any fsupportsSEIPDv2 recipients
+ symmetricOverride
+ | useStrictEncryptProfile =
+ preferredStrictSymmetric <|> Just AES256
+ | otherwise = preferredLegacySymmetric
+ isV6Recipient pkp = _keyVersion pkp == V6
+ useStrictEncryptProfile =
+ case encryptProfile of
+ EncryptProfileRFC9580 ->
+ anyRecipientSupportsSEIPDv2
+ || any (isV6Recipient . fpkp) recipients
+ EncryptProfileRFC4880 ->
+ anyRecipientSupportsSEIPDv2
+ || any (isV6Recipient . fpkp) recipients
+ preferredStrictSymmetric =
+ preferredRecipientSymmetric isSupportedStrictEncryptSymmetric
+ preferredLegacySymmetric =
+ preferredRecipientSymmetric isSupportedLegacyEncryptSymmetric
+ preferredRecipientSymmetric isSupported =
+ case filter
+ (not . null)
+ (map fpreferredSymmetricAlgorithms recipients) of
+ [] -> Nothing
+ (prefList : prefLists) ->
+ listToMaybe
+ [ candidate
+ | candidate <- filter isSupported prefList
+ , all (candidate `elem`) prefLists
+ ]
+ isSupportedStrictEncryptSymmetric algo =
+ algo `elem` [AES128, AES192, AES256]
+ -- Legacy profile fallback should not hard-fail on deprecated/unsupported
+ -- recipient preferences (e.g. IDEA in AEADED interop fixtures).
+ isSupportedLegacyEncryptSymmetric algo =
+ algo `elem` [AES128, AES192, AES256]
+ recipientTargetFor funkey =
+ let recipient = fpkp funkey
+ recipientNeedsV6PKESK =
+ useStrictEncryptProfile
+ && (fsupportsSEIPDv2 funkey || _keyVersion recipient == V6)
+ in if _keyVersion recipient == V6
+ then
+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
+ else case _pkalgo recipient of
+ ECDH ->
+ -- Under strict (SEIPDv2) mode, keep Curve25519-compatible v4 ECDH keys on
+ -- the X25519/v6 path so ESK/payload versions stay aligned.
+ if recipientNeedsV6PKESK
+ then case normalizeX25519CompatibleECDHRecipient recipient of
+ Just x25519Recipient ->
+ recipientEncryptionTargetWithStrategy
+ x25519Recipient
+ RecipientPreferV6
+ Nothing ->
+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
+ else
+ recipientEncryptionTargetWithStrategy
+ recipient
+ RecipientForceV3Interop
+ DeprecatedRSAEncryptOnly ->
+ if recipientNeedsV6PKESK
+ then
+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
+ else
+ recipientEncryptionTargetWithStrategy
+ recipient
+ RecipientForceV3Interop
+ RSA ->
+ if recipientNeedsV6PKESK
+ then
+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
+ else
+ recipientEncryptionTargetWithStrategy
+ recipient
+ RecipientForceV3Interop
+ _ ->
+ if recipientNeedsV6PKESK
+ then
+ recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
+ else recipientEncryptionTarget recipient
+
+ normalizeX25519CompatibleECDHRecipient pkp =
+ case _pubkey pkp of
+ ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->
+ Just
+ ( PKPayload
+ (_keyVersion pkp)
+ (_timestamp pkp)
+ (_v3exp pkp)
+ X25519
+ (_pubkey pkp)
+ )
+ _ -> Nothing
+
+parseEncryptProfile :: Maybe String -> IO EncryptProfile
+parseEncryptProfile Nothing = pure EncryptProfileRFC9580
+parseEncryptProfile (Just profileName) =
+ case profileName of
+ "default" -> pure EncryptProfileRFC9580
+ "rfc9580" -> pure EncryptProfileRFC9580
+ "security" -> pure EncryptProfileRFC9580
+ "performance" -> pure EncryptProfileRFC9580
+ "rfc4880" -> pure EncryptProfileRFC4880
+ "compatibility" -> pure EncryptProfileRFC4880
+ _ ->
+ failWith
+ UnsupportedProfile
+ ("encrypt: unsupported profile " ++ profileName)
+
+doDecrypt :: POSIXTime -> DecryptOptions -> IO ()
+doDecrypt cpt DecryptOptions {..} = do
+ when (decNoArmor && decArmor) $
+ failWith
+ IncompatibleOptions
+ "decrypt: --armor and --no-armor are mutually exclusive"
+ when decWithoutIntegrityCheck $
+ failWith
+ UnsupportedOption
+ "decrypt: --without-integrity-check is not supported by this backend"
+ sessionKeys <- parseDecryptSessionKeys decSessionKeys
+ (verificationOutputPath, usingDeprecatedVerifyOut) <-
+ resolveDecryptVerificationsOut
+ decVerificationsOutFile
+ decDeprecatedVerifyOutFile
+ let hasVerifyWith = not (null decVerifyCerts)
+ hasVerifyOut = isJust verificationOutputPath
+ hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter
+ doingVerification = hasVerifyWith && hasVerifyOut
+ when (hasVerifyWith /= hasVerifyOut) $
+ failWith
+ IncompleteVerification
+ "decrypt: verification requires both --verify-with and --verifications-out"
+ when (hasVerifyBounds && not doingVerification) $
+ failWith
+ IncompleteVerification
+ "decrypt: --verify-not-before/--verify-not-after require both --verify-with and --verifications-out"
+ passwords <-
+ loadPasswordFiles "decrypt" "--with-password" decPasswords
+ keyPasswordsRaw <-
+ loadPasswordFiles "decrypt" "--with-key-password" decKeyPasswords
+ let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
+ when (null passwords && null sessionKeys && null decKeyFiles) $
+ failWith
+ MissingArg
+ "decrypt: supply KEYS, --with-password, or --with-session-key"
+ ciphertextInput <-
+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ ciphertext <- decodeCiphertextInput ciphertextInput
+ validateDecryptPartialBodyEncoding ciphertext
+ ciphertextPktsRaw <-
+ parseRawOpenPGPPackets "decrypt input" ciphertext
+ let ciphertextPkts =
+ filter
+ ( \pkt ->
+ not
+ ( isForwardCompatUnknownESKPacket pkt
+ || isUnsupportedSKESKPacket pkt
+ )
+ )
+ ciphertextPktsRaw
+ -- Pre-flight: reject messages with no encrypted payload at all (upstream
+ -- won't produce a useful DecryptMalformedStructure for the empty case).
+ when (not (any isEncryptedPayloadPacket ciphertextPkts)) $
+ failWith BadData "decrypt input: no encrypted data packet found"
+ validateCiphertextPacketLayout ciphertextPkts
+ recipientKeys <-
+ loadDecryptRecipientKeys cpt decKeyFiles keyPasswords
+ when
+ ( null recipientKeys
+ && not (null decKeyFiles)
+ && null passwords
+ && null sessionKeys
+ )
+ $ failWith
+ CannotDecrypt
+ "decrypt failed: no usable secret key material found in provided KEYS"
+ let passwordAttempts =
+ case passwords of
+ [] -> [[]]
+ _ ->
+ map
+ (\password -> [password])
+ (concatMap passwordRetryCandidates passwords)
+ runDecryptAttemptWithPolicy decryptPolicy keyCandidates passwordBytes = do
+ passwordQueue <- newIORef passwordBytes
+ sessionKeyQueue <-
+ newIORef (map decryptSessionKeyMaterial sessionKeys)
+ let decryptInputPkts = prioritizeDecryptablePKESKs keyCandidates ciphertextPkts
+ let keyResolutionResolver =
+ selectRecipientKeyInfosByRecipientIdentifier keyCandidates
+ let opts =
+ Decrypt.DecryptOptions
+ { Decrypt.decryptOptionsKeyResolution =
+ DecryptWithUnwrapCandidatesCallback keyResolutionResolver
+ , Decrypt.decryptOptionsPolicy = decryptPolicy
+ , Decrypt.decryptOptionsPassphraseCallback =
+ decryptInputCallback passwordQueue sessionKeyQueue
+ }
+ (outcome, pkts) <-
+ runConduitRes $
+ CL.sourceList decryptInputPkts
+ .| fuseBoth (Decrypt.conduitDecrypt opts) CL.consume
+ case outcome of
+ DecryptMalformedStructure reason ->
+ pure (Left reason)
+ DecryptTruncated ->
+ failWith BadData "decrypt failed: encrypted message is truncated"
+ _ -> pure (Right pkts)
+ tryDecryptWithPasswords [passwordBytes] =
+ runDecryptAttempt recipientKeys passwordBytes
+ `catch` decryptIOFailureToSOP
+ tryDecryptWithPasswords (passwordBytes : rest) =
+ runDecryptAttempt recipientKeys passwordBytes `catch` retryNext
+ where
+ retryNext :: ExitCode -> IO [Pkt]
+ retryNext exitCode
+ | exitCode == ExitFailure (failureCode CannotDecrypt) =
+ tryDecryptWithPasswords rest
+ | otherwise = throwIO exitCode
+ tryDecryptWithPasswords [] =
+ failWith
+ CannotDecrypt
+ "decrypt failed: passphrase required but not provided"
+ decryptIOFailureToSOP :: IOException -> IO [Pkt]
+ decryptIOFailureToSOP err =
+ failWith
+ CannotDecrypt
+ ("decrypt failed: " ++ displayException err)
+ runDecryptAttempt keyCandidates passwordBytes = do
+ strictOutcome <-
+ runDecryptAttemptWithPolicy
+ defaultDecryptPolicy
+ keyCandidates
+ passwordBytes
+ case strictOutcome of
+ Right pkts -> pure pkts
+ Left reason
+ | shouldRetryLenientDecrypt reason keyCandidates passwordBytes -> do
+ lenientOutcome <-
+ runDecryptAttemptWithPolicy
+ lenientDecryptPolicy
+ keyCandidates
+ passwordBytes
+ case lenientOutcome of
+ Right pkts -> pure pkts
+ Left lenientReason ->
+ failWith
+ BadData
+ ( "decrypt failed: malformed encrypted message structure ("
+ ++ lenientReason
+ ++ ")"
+ )
+ | otherwise ->
+ failWith
+ BadData
+ ( "decrypt failed: malformed encrypted message structure ("
+ ++ reason
+ ++ ")"
+ )
+ shouldRetryLenientDecrypt reason keyCandidates passwordBytes
+ | "ESK packets must immediately precede encrypted data"
+ `isInfixOf` reason =
+ True
+ | "ESK packets present but none are version-aligned with SEIPDv2 payload"
+ `isInfixOf` reason =
+ null passwordBytes
+ && not (null keyCandidates)
+ && any isLegacyRSAPKESK ciphertextPkts
+ | otherwise = False
+ isLegacyRSAPKESK (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) =
+ pka == RSA || pka == DeprecatedRSAEncryptOnly
+ isLegacyRSAPKESK _ = False
+ decryptedPktsRaw <- tryDecryptWithPasswords passwordAttempts
+ sessionKeyOutLine <-
+ resolveSessionKeyOut
+ decSessionKeyOutFile
+ sessionKeys
+ ciphertextPkts
+ recipientKeys
+ (concatMap passwordRetryCandidates passwords)
+ decryptedPkts <- do
+ decompressed <-
+ mapM
+ ( either (\e -> failWith BadData (renderCompressionError e)) pure
+ . recursivelyDecompressPacket
+ )
+ decryptedPktsRaw
+ pure (concat decompressed)
+ validateDecryptedMessageStructure decryptedPktsRaw decryptedPkts
+ payload <- extractSingleLiteralPayload decryptedPkts
+ BL.putStr payload
+ case (decSessionKeyOutFile, sessionKeyOutLine) of
+ (Just path, Just line) -> writeFileWithOutputExistsCheck "decrypt" path (line ++ "\n")
+ _ -> pure ()
+ when doingVerification $
+ doDecryptVerifyOutput
+ cpt
+ decVerifyCerts
+ verificationOutputPath
+ decVerifyNotBefore
+ decVerifyNotAfter
+ decryptedPkts
+ when usingDeprecatedVerifyOut $
+ hPutStrLn
+ stderr
+ "Warning: --verify-out is deprecated; use --verifications-out instead."
+
+data DecryptSessionKey
+ = DecryptSessionKey
+ { decryptSessionKeyMaterial :: BL.ByteString
+ , decryptSessionKeyOutLine :: Maybe String
+ }
+
+decryptInputCallback
+ :: IORef [BL.ByteString]
+ -> IORef [BL.ByteString]
+ -> String
+ -> IO BL.ByteString
+decryptInputCallback _passwordQueue sessionKeyQueue prompt
+ | "PKESK session key material" `isInfixOf` prompt = do
+ mSessionKeyMaterial <-
+ atomicModifyIORef' sessionKeyQueue $ \keys ->
+ case keys of
+ [] -> ([], Nothing)
+ (k : rest) -> (rest, Just k)
+ case mSessionKeyMaterial of
+ Just sessionKeyMaterial -> pure sessionKeyMaterial
+ Nothing ->
+ failWith
+ CannotDecrypt
+ "decrypt failed: PKESK session key material required but not provided"
+decryptInputCallback passwordQueue _ _ = do
+ mPassword <-
+ atomicModifyIORef' passwordQueue $ \passwords ->
+ case passwords of
+ [] -> ([], Nothing)
+ (p : rest) -> (rest, Just p)
+ case mPassword of
+ Just password -> pure password
+ Nothing ->
+ failWith
+ CannotDecrypt
+ "decrypt failed: passphrase required but not provided"
+
+parseDecryptSessionKeys :: [String] -> IO [DecryptSessionKey]
+parseDecryptSessionKeys = mapM parseSessionKeySpec
+
+parseSessionKeySpec :: String -> IO DecryptSessionKey
+parseSessionKeySpec spec =
+ case break (== ':') spec of
+ (_, "") -> do
+ material <- decodeHexBytes spec
+ pure
+ DecryptSessionKey
+ { decryptSessionKeyMaterial = BL.fromStrict material
+ , decryptSessionKeyOutLine = sessionKeyOutLineFromMaterial material
+ }
+ (algoSpec, ':' : keyHex) -> do
+ algo <- parseAlgorithmOctet algoSpec
+ keyBytes <- decodeHexBytes keyHex
+ when (B.null keyBytes) $
+ failWith
+ BadData
+ "decrypt: --with-session-key key material cannot be empty"
+ pure
+ DecryptSessionKey
+ { decryptSessionKeyMaterial =
+ BL.fromStrict (encodeOpenPGPSessionKey algo keyBytes)
+ , decryptSessionKeyOutLine =
+ Just (renderSessionKeyOutLine algo keyBytes)
+ }
+ _ -> failWith BadData "decrypt: invalid --with-session-key format"
+
+resolveSessionKeyOut
+ :: Maybe String
+ -> [DecryptSessionKey]
+ -> [Pkt]
+ -> [PKESKRecipientKey]
+ -> [BL.ByteString]
+ -> IO (Maybe String)
+resolveSessionKeyOut Nothing _ _ _ _ = pure Nothing
+resolveSessionKeyOut (Just _) sessionKeys ciphertextPkts recipientKeys passwordCandidates =
+ case mapMaybe decryptSessionKeyOutLine sessionKeys of
+ (line : _) -> pure (Just line)
+ [] -> do
+ discoveredLine <-
+ recoverSessionKeyOutFromCiphertext
+ ciphertextPkts
+ recipientKeys
+ passwordCandidates
+ case discoveredLine of
+ Just line -> pure (Just line)
+ Nothing -> pure Nothing
+
+recoverSessionKeyOutFromCiphertext
+ :: [Pkt]
+ -> [PKESKRecipientKey]
+ -> [BL.ByteString]
+ -> IO (Maybe String)
+recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates =
+ case recoverFromSKESK of
+ Just line -> pure (Just line)
+ Nothing -> recoverFromLegacyRSAPKESK
+ where
+ recoverFromSKESK =
+ listToMaybe $
+ mapMaybe
+ ( \(SKESKPayloadV4 sa s2k maybeEsk, passphrase) ->
+ case maybeEsk of
+ Nothing ->
+ case skesk2Key (SKESK4Packet sa s2k Nothing) passphrase of
+ Left _ -> Nothing
+ Right sessionKey ->
+ Just (renderSessionKeyOutLine (fromFVal sa) sessionKey)
+ Just esk ->
+ case skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase of
+ Left _ -> Nothing
+ Right (algo, sessionKey) ->
+ Just (renderSessionKeyOutLine (fromFVal algo) sessionKey)
+ )
+ [ (payload, passphrase)
+ | payload <- skeskPayloadsV4
+ , passphrase <- passwordCandidates
+ ]
+ skeskPayloadsV4 =
+ mapMaybe
+ ( \pkt ->
+ case pkt of
+ SKESKPkt (SKESKPayloadV4Packet payload) -> Just payload
+ _ -> Nothing
+ )
+ ciphertextPkts
+ recoverFromLegacyRSAPKESK =
+ recoverRSACombos
+ [(mpi, rsaKey) | mpi <- rsaPKESKMPIs, rsaKey <- rsaRecipientKeys]
+ recoverRSACombos [] = pure Nothing
+ recoverRSACombos ((mpi, rsaKey) : rest) = do
+ encodedResult <- decryptLegacyRSAPKESK rsaKey mpi
+ case encodedResult of
+ Left _ -> recoverRSACombos rest
+ Right encoded ->
+ case decodeOpenPGPEncodedSessionKey encoded of
+ Right (algo, keyBytes) ->
+ pure (Just (renderSessionKeyOutLine (fromFVal algo) keyBytes))
+ Left _ -> recoverRSACombos rest
+ rsaPKESKMPIs =
+ mapMaybe
+ ( \pkt ->
+ case pkt of
+ PKESKPkt
+ (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka (mpi :| [])))
+ | pka == RSA || pka == DeprecatedRSAEncryptOnly ->
+ Just mpi
+ _ -> Nothing
+ )
+ ciphertextPkts
+ rsaRecipientKeys =
+ mapMaybe
+ ( \keyInfo ->
+ case pkeskRecipientSKey keyInfo of
+ RSAPrivateKey (RSA_PrivateKey privateKey) -> Just privateKey
+ _ -> Nothing
+ )
+ recipientKeys
+
+decryptLegacyRSAPKESK
+ :: RSA.PrivateKey -> MPI -> IO (Either String B.ByteString)
+decryptLegacyRSAPKESK privateKey mpi = do
+ attempted <-
+ P15.decryptSafer privateKey (mpiToCiphertext privateKey mpi)
+ pure (first show attempted)
+ where
+ mpiToCiphertext rsaKey (MPI encodedMPI) =
+ let modulusBytes = rsaModulusOctets rsaKey
+ in i2ospOf_ modulusBytes encodedMPI
+ rsaModulusOctets rsaKey =
+ let modulusBits = integerBitLength (RSA.public_n (RSA.private_pub rsaKey))
+ in max 1 ((modulusBits + 7) `div` 8)
+ integerBitLength n
+ | n <= 0 = 0
+ | otherwise = go n 0
+ where
+ go 0 bits = bits
+ go val bits = go (val `div` 2) (bits + 1)
+
+parseAlgorithmOctet :: String -> IO Word8
+parseAlgorithmOctet algoSpec =
+ case readMaybe algoSpec :: Maybe Int of
+ Just octet
+ | octet >= 0 && octet <= 255 ->
+ case toFVal (fromIntegral octet) :: SymmetricAlgorithm of
+ OtherSA _ ->
+ failWith
+ BadData
+ ("decrypt: unsupported --with-session-key algorithm: " ++ algoSpec)
+ _ -> pure (fromIntegral octet)
+ _ ->
+ failWith
+ BadData
+ ("decrypt: invalid --with-session-key algorithm: " ++ algoSpec)
+
+decodeHexBytes :: String -> IO B.ByteString
+decodeHexBytes hex =
+ if odd (length hex)
+ then
+ failWith
+ BadData
+ "decrypt: hex key material must have an even number of digits"
+ else B.pack <$> go hex
+ where
+ go [] = pure []
+ go (a : b : rest) = do
+ hi <- nibble a
+ lo <- nibble b
+ (fromIntegral (hi * 16 + lo) :) <$> go rest
+ go _ = failWith BadData "decrypt: malformed hex key material"
+ nibble c =
+ if isHexDigit c
+ then pure (digitToInt c)
+ else failWith BadData "decrypt: key material must be hexadecimal"
+
+isEncryptedPayloadPacket :: Pkt -> Bool
+isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True
+isEncryptedPayloadPacket SymEncDataPkt {} = True
+isEncryptedPayloadPacket _ = False
+
+isForwardCompatUnknownESKPacket :: Pkt -> Bool
+isForwardCompatUnknownESKPacket (OtherPacketPkt tag _) = tag == 1 || tag == 3
+isForwardCompatUnknownESKPacket (BrokenPacketPkt _ tag _) = tag == 1 || tag == 3
+isForwardCompatUnknownESKPacket _ = False
+
+isUnsupportedSKESKPacket :: Pkt -> Bool
+isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ s2k _))) = isUnknownS2K s2k
+isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ s2k _ _ _))) = isUnknownS2K s2k
+isUnsupportedSKESKPacket _ = False
+
+isUnknownS2K :: S2K -> Bool
+isUnknownS2K OtherS2K {} = True
+isUnknownS2K _ = False
+
+validateCiphertextPacketLayout :: [Pkt] -> IO ()
+validateCiphertextPacketLayout pkts =
+ case findIndex isEncryptedPayloadPacket pkts of
+ Nothing -> pure ()
+ Just payloadIndex ->
+ let trailing =
+ filter
+ (not . isMarkerPacketPacket)
+ (drop (payloadIndex + 1) pkts)
+ in when (not (null trailing)) $
+ failWith
+ BadData
+ "decrypt input: malformed encrypted message structure (unexpected packets after encrypted data)"
+
+isMarkerPacketPacket :: Pkt -> Bool
+isMarkerPacketPacket MarkerPkt {} = True
+isMarkerPacketPacket _ = False
+
+validateDecryptedMessageStructure :: [Pkt] -> [Pkt] -> IO ()
+validateDecryptedMessageStructure rawPkts pkts = do
+ let literalCount = length [() | LiteralDataPkt {} <- pkts]
+ signatureCount = length [() | SignaturePkt {} <- pkts]
+ onePassCount = length [() | OnePassSignaturePkt {} <- pkts]
+ hasCompressedRaw = any isCompressedPacket rawPkts
+ hasUnknownPackets = any isUnknownPacket rawPkts || any isUnknownPacket pkts
+ maxCompressionDepth = maximum (0 : map compressionDepth rawPkts)
+ when (any compressedPacketParseFailed rawPkts) $
+ failWith
+ BadData
+ "decrypt failed: malformed compressed data stream"
+ when (maxCompressionDepth > 2) $
+ failWith
+ BadData
+ "decrypt failed: malformed encrypted message structure (excessive compression nesting)"
+ when (hasCompressedRaw && any isMarkerPacket pkts) $
+ failWith
+ BadData
+ "decrypt failed: malformed encrypted message structure (compressed marker packet)"
+ when (any isDisallowedDecryptedPacketType pkts) $
+ failWith
+ BadData
+ "decrypt failed: malformed encrypted message structure (unexpected packet type in plaintext)"
+ when (literalCount == 0) $
+ failWith
+ BadData
+ "decrypt failed: malformed encrypted message structure (no literal data payload found)"
+ when (literalCount > 1) $
+ failWith
+ BadData
+ "decrypt failed: malformed encrypted message structure (multiple literal payloads)"
+ when
+ (not hasUnknownPackets && onePassCount > 0 && signatureCount == 0)
+ $ failWith
+ BadData
+ "decrypt failed: malformed signed message structure (one-pass signature without trailing signature)"
+ when
+ ( not hasUnknownPackets
+ && signatureCount > 0
+ && onePassCount == 0
+ && not isOldStyleSignedMessage
+ )
+ $ failWith
+ BadData
+ "decrypt failed: malformed signed message structure (trailing signature without one-pass signature)"
+ where
+ isOldStyleSignedMessage =
+ case [i | (i, LiteralDataPkt {}) <- packetPositions] of
+ [literalIndex] ->
+ not (null signaturePositions)
+ && all (< literalIndex) signaturePositions
+ _ -> False
+ packetPositions = zip [0 :: Int ..] (filter (not . isMarkerPacket) pkts)
+ signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]
+
+compressedPacketParseFailed :: Pkt -> Bool
+compressedPacketParseFailed pkt@CompressedDataPkt {} = isLeft (decompressPkt pkt)
+compressedPacketParseFailed _ = False
+
+recursivelyDecompressPacket
+ :: Pkt -> Either CompressionError [Pkt]
+recursivelyDecompressPacket pkt@CompressedDataPkt {} = do
+ inner <- decompressPkt pkt
+ concat <$> mapM recursivelyDecompressPacket inner
+recursivelyDecompressPacket pkt = Right [pkt]
+
+compressedPacketIsEmpty :: Pkt -> Bool
+compressedPacketIsEmpty pkt@CompressedDataPkt {} =
+ case decompressPkt pkt of
+ Right [] -> True
+ _ -> False
+compressedPacketIsEmpty _ = False
+
+isCompressedPacket :: Pkt -> Bool
+isCompressedPacket CompressedDataPkt {} = True
+isCompressedPacket _ = False
+
+compressionDepth :: Pkt -> Int
+compressionDepth pkt@CompressedDataPkt {} =
+ let inner = either (const []) id (decompressPkt pkt)
+ in if null inner
+ then 1
+ else 1 + maximum (0 : map compressionDepth inner)
+compressionDepth _ = 0
+
+isMarkerPacket :: Pkt -> Bool
+isMarkerPacket MarkerPkt {} = True
+isMarkerPacket _ = False
+
+isUnknownPacket :: Pkt -> Bool
+isUnknownPacket OtherPacketPkt {} = True
+isUnknownPacket BrokenPacketPkt {} = True
+isUnknownPacket _ = False
+
+isDisallowedDecryptedPacketType :: Pkt -> Bool
+isDisallowedDecryptedPacketType PKESKPkt {} = True
+isDisallowedDecryptedPacketType SKESKPkt {} = True
+isDisallowedDecryptedPacketType PublicKeyPkt {} = True
+isDisallowedDecryptedPacketType PublicSubkeyPkt {} = True
+isDisallowedDecryptedPacketType SecretKeyPkt {} = True
+isDisallowedDecryptedPacketType SecretSubkeyPkt {} = True
+isDisallowedDecryptedPacketType SymEncDataPkt {} = True
+isDisallowedDecryptedPacketType SymEncIntegrityProtectedDataPkt {} = True
+isDisallowedDecryptedPacketType _ = False
+
+encodeOpenPGPSessionKey :: Word8 -> B.ByteString -> B.ByteString
+encodeOpenPGPSessionKey algo keyBytes =
+ B.cons
+ algo
+ ( keyBytes
+ <> B.pack [fromIntegral (checksum `div` 256), fromIntegral checksum]
+ )
+ where
+ checksum :: Int
+ checksum =
+ B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536
+
+sessionKeyOutLineFromMaterial :: B.ByteString -> Maybe String
+sessionKeyOutLineFromMaterial raw = do
+ (algo, keyBytes) <- decodeOpenPGPSessionKeyMaterial raw
+ pure (renderSessionKeyOutLine algo keyBytes)
+
+decodeOpenPGPSessionKeyMaterial
+ :: B.ByteString -> Maybe (Word8, B.ByteString)
+decodeOpenPGPSessionKeyMaterial raw = do
+ (algo, body) <- B.uncons raw
+ case toFVal (fromIntegral algo) :: SymmetricAlgorithm of
+ OtherSA _ -> Nothing
+ _ -> do
+ let bodyLen = B.length body
+ if bodyLen < 3
+ then Nothing
+ else do
+ let keyBytes = B.take (bodyLen - 2) body
+ checksumHi = fromIntegral (B.index body (bodyLen - 2)) :: Int
+ checksumLo = fromIntegral (B.index body (bodyLen - 1)) :: Int
+ checksumExpected = checksumHi * 256 + checksumLo
+ checksumActual =
+ B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536
+ if B.null keyBytes || checksumActual /= checksumExpected
+ then Nothing
+ else Just (algo, keyBytes)
+
+renderSessionKeyOutLine :: Word8 -> B.ByteString -> String
+renderSessionKeyOutLine algo keyBytes =
+ show algo ++ ":" ++ hexEncodeBytes keyBytes
+
+hexEncodeBytes :: B.ByteString -> String
+hexEncodeBytes = concatMap encodeByte . B.unpack
+ where
+ encodeByte w =
+ [ nibble (w `shiftR` 4)
+ , nibble (w .&. 0x0f)
+ ]
+ nibble n = "0123456789abcdef" !! fromIntegral n
+
+extractSingleLiteralPayload :: [Pkt] -> IO BL.ByteString
+extractSingleLiteralPayload pkts =
+ case [p | LiteralDataPkt _ _ _ p <- pkts] of
+ [payload] -> pure payload
+ [] ->
+ failWith
+ BadData
+ "decrypt failed: malformed encrypted message structure (no literal data payload found)"
+ _ ->
+ failWith
+ BadData
+ "decrypt failed: malformed encrypted message structure (multiple literal data payloads found)"
+
+doDecryptVerifyOutput
+ :: POSIXTime
+ -> [String]
+ -> Maybe String
+ -> Maybe String
+ -> Maybe String
+ -> [Pkt]
+ -> IO ()
+doDecryptVerifyOutput cpt certFiles outFile notBeforeArg notAfterArg decryptedPkts = do
+ when (null certFiles) $
+ failWith
+ IncompleteVerification
+ "decrypt: verification requires at least one --verify-with cert"
+ (krs, verifyTks) <- loadVerifyContext cpt certFiles
+ upperBound <- verificationUpperBound cpt notAfterArg
+ lowerBound <- verificationLowerBound cpt notBeforeArg
+ verificationPkts <-
+ normalizeDecryptVerificationPackets decryptedPkts
+ let verifications =
+ map
+ (first show)
+ (verifyPacketsBatch krs upperBound verificationPkts)
+ filtered = filterByVerificationBounds lowerBound upperBound verifications
+ successLines =
+ map (renderSOPVerificationLine verifyTks) (rights filtered)
+ renderedOut =
+ if null successLines
+ then ""
+ else unlines successLines
+ case outFile of
+ Just path -> writeFileWithOutputExistsCheck "decrypt" path renderedOut
+ Nothing -> pure ()
+
+normalizeDecryptVerificationPackets :: [Pkt] -> IO [Pkt]
+normalizeDecryptVerificationPackets pkts =
+ case ( [pkt | pkt@LiteralDataPkt {} <- pkts]
+ , [pkt | pkt@SignaturePkt {} <- pkts]
+ ) of
+ ([], _) ->
+ failWith
+ CannotDecrypt
+ "decrypt failed: no literal data payload found"
+ ([lit], []) -> pure [lit]
+ ([lit], sigs) -> pure (lit : sigs)
+ (_, _) ->
+ failWith
+ BadData
+ "decrypt failed: malformed signed message structure (multiple literal payloads)"
+
+resolveDecryptVerificationsOut
+ :: Maybe String -> Maybe String -> IO (Maybe String, Bool)
+resolveDecryptVerificationsOut newPath oldPath =
+ case (newPath, oldPath) of
+ (Just p, Nothing) -> pure (Just p, False)
+ (Nothing, Just p) -> pure (Just p, True)
+ (Just pNew, Just pOld)
+ | pNew == pOld -> pure (Just pNew, True)
+ | otherwise ->
+ failWith
+ IncompatibleOptions
+ "decrypt: --verifications-out and --verify-out cannot target different files"
+ (Nothing, Nothing) -> pure (Nothing, False)
+
+renderSOPVerificationLine
+ :: [TKUnknown] -> Verification -> String
+renderSOPVerificationLine verifyTks v =
+ ts ++ " " ++ signerFp ++ " " ++ certFp ++ " " ++ modeLabel
+ where
+ sig = _verificationSignature v
+ ts = renderSOPVerificationTimestamp sig
+ signer = fingerprint (_verificationSigner v)
+ signerFp = hexEncodeBytes (BL.toStrict (unFingerprint signer))
+ modeLabel = signatureModeField sig
+ certFp =
+ case find (\tk -> keyMatchesFingerprint True tk signer) verifyTks of
+ Just tk ->
+ hexEncodeBytes
+ (BL.toStrict (unFingerprint (fingerprint (fst (_tkuKey tk)))))
+ Nothing -> signerFp
+
+signatureModeField :: SignaturePayload -> String
+signatureModeField sig =
+ case sig of
+ SigV4 CanonicalTextSig _ _ _ _ _ _ -> "mode:text"
+ SigV6 CanonicalTextSig _ _ _ _ _ _ _ -> "mode:text"
+ _ -> "mode:binary"
+
+renderSOPVerificationTimestamp :: SignaturePayload -> String
+renderSOPVerificationTimestamp sig =
+ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $
+ case signatureCreationTime sig of
+ Just t -> t
+ Nothing -> posixSecondsToUTCTime 0
+
+writeFileWithOutputExistsCheck
+ :: String -> FilePath -> String -> IO ()
+writeFileWithOutputExistsCheck subcommand path content = do
+ ensureOutputPathAvailable subcommand path
+ writeFile path content
+
+parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
+parseOpenPGPPackets context bytes =
+ ( do
+ let packets =
+ concatMap
+ (either (const []) id . decompressPkt)
+ (parsePkts bytes)
+ _ <- evaluate (length packets)
+ pure packets
+ )
+ `catch` parseFailure
+ where
+ parseFailure :: SomeException -> IO [Pkt]
+ parseFailure err =
+ failWith
+ BadData
+ ( context
+ ++ ": failed to parse OpenPGP packets: "
+ ++ displayException err
+ )
+
+parseRawOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
+parseRawOpenPGPPackets context bytes =
+ ( do
+ let packets = parsePkts bytes
+ _ <- evaluate (length packets)
+ pure packets
+ )
+ `catch` parseFailure
+ where
+ parseFailure :: SomeException -> IO [Pkt]
+ parseFailure err =
+ failWith
+ BadData
+ ( context
+ ++ ": failed to parse OpenPGP packets: "
+ ++ displayException err
+ )
+
+validateDecryptPartialBodyEncoding :: BL.ByteString -> IO ()
+validateDecryptPartialBodyEncoding ciphertext =
+ case ensureNoShortFirstPartialBodyChunk (BL.toStrict ciphertext) of
+ Left err ->
+ failWith
+ BadData
+ ("decrypt input: invalid partial body encoding (" ++ err ++ ")")
+ Right () -> pure ()
+
+ensureNoShortFirstPartialBodyChunk
+ :: B.ByteString -> Either String ()
+ensureNoShortFirstPartialBodyChunk = parsePackets
+ where
+ parsePackets bs
+ | B.null bs = Right ()
+ | otherwise = do
+ (header, rest) <-
+ noteLeft "truncated packet header" (B.uncons bs)
+ if header .&. 0x80 /= 0x80
+ then Left "invalid packet header octet"
+ else do
+ remaining <-
+ if header .&. 0x40 == 0x40
+ then parseNewPacketBody rest
+ else parseOldPacketBody (header .&. 0x03) rest
+ parsePackets remaining
+
+ parseOldPacketBody lengthType bs =
+ case lengthType of
+ 0 -> do
+ (lenOctet, rest) <-
+ noteLeft "truncated old-format one-octet length" (B.uncons bs)
+ dropExact
+ "truncated old-format packet body"
+ (fromIntegral lenOctet)
+ rest
+ 1 -> do
+ (hi, afterHi) <-
+ noteLeft "truncated old-format two-octet length" (B.uncons bs)
+ (lo, rest) <-
+ noteLeft
+ "truncated old-format two-octet length"
+ (B.uncons afterHi)
+ let len = fromIntegral hi * 256 + fromIntegral lo
+ dropExact "truncated old-format packet body" len rest
+ 2 -> do
+ (b1, afterB1) <-
+ noteLeft "truncated old-format four-octet length" (B.uncons bs)
+ (b2, afterB2) <-
+ noteLeft
+ "truncated old-format four-octet length"
+ (B.uncons afterB1)
+ (b3, afterB3) <-
+ noteLeft
+ "truncated old-format four-octet length"
+ (B.uncons afterB2)
+ (b4, rest) <-
+ noteLeft
+ "truncated old-format four-octet length"
+ (B.uncons afterB3)
+ let len =
+ (fromIntegral b1 `shiftL` 24)
+ + (fromIntegral b2 `shiftL` 16)
+ + (fromIntegral b3 `shiftL` 8)
+ + fromIntegral b4
+ dropExact "truncated old-format packet body" len rest
+ 3 -> Right B.empty
+ _ -> Left "invalid old-format length type"
+
+ parseNewPacketBody = parseNewLengthChunks True
+
+ parseNewLengthChunks isFirstChunk bs = do
+ (chunkLength, isPartial, afterLength) <- parseNewLength bs
+ when (isFirstChunk && isPartial && chunkLength < 512) $
+ Left
+ ( "first partial chunk is too short ("
+ ++ show chunkLength
+ ++ " octets, minimum is 512)"
+ )
+ afterChunk <-
+ dropExact
+ "truncated new-format packet body chunk"
+ chunkLength
+ afterLength
+ if isPartial
+ then parseNewLengthChunks False afterChunk
+ else Right afterChunk
+
+ parseNewLength bs = do
+ (lengthOctet, rest) <-
+ noteLeft "truncated new-format length" (B.uncons bs)
+ case lengthOctet of
+ _
+ | lengthOctet < 192 ->
+ Right (fromIntegral lengthOctet, False, rest)
+ | lengthOctet < 224 -> do
+ (nextOctet, afterNext) <-
+ noteLeft "truncated new-format two-octet length" (B.uncons rest)
+ let len =
+ ((fromIntegral lengthOctet - 192) `shiftL` 8)
+ + fromIntegral nextOctet
+ + 192
+ Right (len, False, afterNext)
+ | lengthOctet < 255 ->
+ Right
+ ( 1 `shiftL` fromIntegral (lengthOctet .&. 0x1f)
+ , True
+ , rest
+ )
+ | otherwise -> do
+ (b1, afterB1) <-
+ noteLeft "truncated new-format five-octet length" (B.uncons rest)
+ (b2, afterB2) <-
+ noteLeft
+ "truncated new-format five-octet length"
+ (B.uncons afterB1)
+ (b3, afterB3) <-
+ noteLeft
+ "truncated new-format five-octet length"
+ (B.uncons afterB2)
+ (b4, afterB4) <-
+ noteLeft
+ "truncated new-format five-octet length"
+ (B.uncons afterB3)
+ let len =
+ (fromIntegral b1 `shiftL` 24)
+ + (fromIntegral b2 `shiftL` 16)
+ + (fromIntegral b3 `shiftL` 8)
+ + fromIntegral b4
+ Right (len, False, afterB4)
+
+ dropExact context n bs
+ | B.length bs < n = Left context
+ | otherwise = Right (B.drop n bs)
+
+ noteLeft err = maybe (Left err) Right
+
+ensureOutputPathAvailable :: String -> FilePath -> IO ()
+ensureOutputPathAvailable subcommand path = do
+ exists <- doesFileExist path
+ when exists $
+ failWith
+ OutputExists
+ (subcommand ++ ": output path already exists: " ++ path)
+
+loadVerifyContext
+ :: POSIXTime -> [String] -> IO (PublicKeyring, [TKUnknown])
+loadVerifyContext _ certFiles = do
+ allTks <-
+ mapMaybe enforceVerifyPrimaryKeyPolicy
+ . map sanitizeVerifyTK
+ . concat
+ <$> mapM (loadCertTKsFromFile "verify") certFiles
+ let publicTks =
+ mapMaybe
+ ( \tk ->
+ case fromUnknownToTK tk of
+ Right (SomePublicTK publicTk) -> Just publicTk
+ _ -> Nothing
+ )
+ allTks
+ keyring <-
+ runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap
+ pure (keyring, allTks)
+
+loadVerifyTKsFromFile :: String -> IO [TKUnknown]
+loadVerifyTKsFromFile path = do
+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
+ certPkts <- decodeOpenPGPInput path lbs
+ runConduitRes $
+ CL.sourceList certPkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+
+loadCertTKsFromFile :: String -> String -> IO [TKUnknown]
+loadCertTKsFromFile context path = do
+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
+ certPkts <- decodeOpenPGPInput path lbs
+ rejectSecretKeyPackets context path certPkts
+ runConduitRes $
+ CL.sourceList certPkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+
+rejectSecretKeyPackets :: String -> String -> [Pkt] -> IO ()
+rejectSecretKeyPackets context path packets =
+ when (any isSecretKeyPacket packets) $
+ failWith
+ BadData
+ ( context
+ ++ ": certificate input contains secret key material in "
+ ++ path
+ )
+ where
+ isSecretKeyPacket SecretKeyPkt {} = True
+ isSecretKeyPacket SecretSubkeyPkt {} = True
+ isSecretKeyPacket _ = False
+
+sanitizeVerifyTK :: TKUnknown -> TKUnknown
+sanitizeVerifyTK tk =
+ case primaryKeyIdentity (_tkuKey tk) of
+ Nothing -> tk
+ Just (primaryFp, primaryKeyId) ->
+ tk
+ { _tkuSubs =
+ map
+ ( \(pkt, sigs) ->
+ let sanitized =
+ mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs
+ in if isSubkeyPacket pkt
+ then (pkt, sanitized)
+ else (pkt, sigs)
+ )
+ (_tkuSubs tk)
+ }
+ where
+ isSubkeyPacket PublicSubkeyPkt {} = True
+ isSubkeyPacket SecretSubkeyPkt {} = True
+ isSubkeyPacket _ = False
+
+enforceVerifyPrimaryKeyPolicy :: TKUnknown -> Maybe TKUnknown
+enforceVerifyPrimaryKeyPolicy tk =
+ if primaryKeyTooSmallForVerification (_tkuKey tk)
+ then Nothing
+ else Just tk
+
+primaryKeyTooSmallForVerification
+ :: (SomePKPayload, Maybe SKAddendum) -> Bool
+primaryKeyTooSmallForVerification (pkp, _) =
+ case _pkalgo pkp of
+ RSA -> rsaTooSmall
+ DeprecatedRSASignOnly -> rsaTooSmall
+ DeprecatedRSAEncryptOnly -> rsaTooSmall
+ _ -> False
+ where
+ rsaTooSmall =
+ case pubkeySize (_pubkey pkp) of
+ Right bits -> bits < 2048
+ Left _ -> False
+
+primaryKeyIdentity
+ :: (SomePKPayload, Maybe SKAddendum)
+ -> Maybe (Fingerprint, EightOctetKeyId)
+primaryKeyIdentity (pkp, _) = do
+ keyId <- either (const Nothing) Just (eightOctetKeyID pkp)
+ pure (fingerprint pkp, keyId)
+
+sanitizeBindingSignature
+ :: Fingerprint
+ -> EightOctetKeyId
+ -> SignaturePayload
+ -> Maybe SignaturePayload
+sanitizeBindingSignature _ _ sig
+ | hasUnsupportedCriticalSubpacket sig = Nothing
+ | hasUnsupportedCriticalEmbeddedBacksig sig = Nothing
+ | otherwise = Just sig
+ where
+ hasUnsupportedCriticalSubpacket sp =
+ any isUnsupportedCriticalSubpacket (signatureHashedSubpackets sp)
+ hasUnsupportedCriticalEmbeddedBacksig sp =
+ any
+ ( \ssp ->
+ case _sspPayload ssp of
+ EmbeddedSignature embedded ->
+ any
+ isUnsupportedCriticalSubpacket
+ (signatureHashedSubpackets embedded)
+ _ -> False
+ )
+ (signatureHashedSubpackets sp)
+ isUnsupportedCriticalSubpacket (SigSubPacket isCritical payload) =
+ isCritical
+ && case payload of
+ UserDefinedSigSub {} -> True
+ OtherSigSub {} -> True
+ NotationData {} -> True
+ _ -> False
+
+loadDecryptRecipientKeys
+ :: POSIXTime
+ -> [String]
+ -> [BL.ByteString]
+ -> IO [PKESKRecipientKey]
+loadDecryptRecipientKeys _ [] _ = pure []
+loadDecryptRecipientKeys cpt keyFiles passwords = concat <$> mapM loadFromFile keyFiles
+ where
+ loadFromFile path = do
+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
+ packets <- decodeOpenPGPInput path lbs
+ -- Build the set of fingerprints that are explicitly non-encryption-capable.
+ -- Keys not resolvable via TK (processTK failure, bare material) are allowed.
+ nonEncFps <- buildNonEncryptionFingerprintSet packets
+ keys <-
+ mapM (packetRecipientKey path nonEncFps) packets
+ >>= pure . catMaybes
+ let brokenSecretKeyErrors =
+ nub
+ [ err
+ | BrokenPacketPkt err tag _ <- packets
+ , tag == 5 || tag == 7
+ ]
+ when (null keys && not (null brokenSecretKeyErrors)) $
+ failWith
+ CannotDecrypt
+ ( "decrypt failed: could not load usable secret key material from "
+ ++ path
+ ++ " ("
+ ++ intercalate "; " brokenSecretKeyErrors
+ ++ ")"
+ )
+ pure keys
+ -- Build a set of fingerprints that are EXPLICITLY non-encryption-capable.
+ -- Only keys whose binding signature carries a KeyFlags subpacket that does
+ -- NOT include any encryption bit are added. Keys with no binding-sig TK
+ -- (processTK failed, bare secret material, etc.) are NOT blocked — we fall
+ -- back to allowing them so that newly-generated or unusual keys still work.
+ buildNonEncryptionFingerprintSet packets = do
+ tks <-
+ runConduitRes $
+ CL.sourceList packets
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ let normTks = rights (map (processTK (Just cpt)) tks)
+ let tkDerived = S.fromList (concatMap nonEncryptionFingerprints normTks)
+ rawDerived = S.fromList (explicitNonEncryptionSubkeyFingerprints packets)
+ return (S.union tkDerived rawDerived)
+ nonEncryptionFingerprints tk =
+ -- Primary key: add to blocklist only if explicit key-flags are present
+ -- and all of them exclude encryption usage.
+ let (primaryPkp, _) = _tkuKey tk
+ primaryFp = unFingerprint (fingerprint primaryPkp)
+ primarySigs =
+ concatMap snd (_tkuUIDs tk)
+ ++ concatMap snd (_tkuUAts tk)
+ ++ _tkuRevs tk
+ primaryEntry = [primaryFp | not (sigsAllowEncryption primarySigs)]
+ -- Subkeys: same rule as primary.
+ subEntries =
+ [ unFingerprint (fingerprint pkp)
+ | (pkt, sigs) <- _tkuSubs tk
+ , Just pkp <- [secretOrPublicSubkeyPayload pkt]
+ , not (sigsAllowEncryption sigs)
+ ]
+ blocked = primaryEntry ++ subEntries
+ in if tkHasAnyEncryptionCapableKey tk
+ then blocked
+ else []
+ explicitNonEncryptionSubkeyFingerprints packets =
+ let (mPending, blocked) = foldl' step (Nothing, []) packets
+ in maybe
+ blocked
+ ( \(fp, hasEnc, sawKeyFlags) -> finalize fp hasEnc sawKeyFlags blocked
+ )
+ mPending
+ where
+ step (mPending, blocked) pkt =
+ case pkt of
+ PublicSubkeyPkt pkp ->
+ ( Just (unFingerprint (fingerprint pkp), False, False)
+ , finalizePending mPending blocked
+ )
+ SecretSubkeyPkt pkp _ ->
+ ( Just (unFingerprint (fingerprint pkp), False, False)
+ , finalizePending mPending blocked
+ )
+ SignaturePkt sig ->
+ case mPending of
+ Nothing -> (Nothing, blocked)
+ Just (fp, hasEnc, sawKeyFlags) ->
+ let usableSig =
+ if signatureHasUnsupportedCriticalSubpackets sig
+ then []
+ else keyFlagsFromSig sig
+ hasEnc' = hasEnc || any hasEncryptionFlag usableSig
+ sawKeyFlags' = sawKeyFlags || not (null usableSig)
+ in (Just (fp, hasEnc', sawKeyFlags'), blocked)
+ _ -> (Nothing, finalizePending mPending blocked)
+ finalizePending Nothing blocked = blocked
+ finalizePending (Just (fp, hasEnc, sawKeyFlags)) blocked =
+ finalize fp hasEnc sawKeyFlags blocked
+ finalize fp hasEnc sawKeyFlags blocked
+ | sawKeyFlags && not hasEnc = fp : blocked
+ | otherwise = blocked
+ tkHasAnyEncryptionCapableKey tk =
+ let (primaryPkp, _) = _tkuKey tk
+ primarySigs =
+ concatMap snd (_tkuUIDs tk)
+ ++ concatMap snd (_tkuUAts tk)
+ ++ _tkuRevs tk
+ primaryAllows =
+ supportsRecipientPKESKAlgorithm primaryPkp
+ && sigsAllowEncryption primarySigs
+ subAllows =
+ any
+ ( \(pkt, sigs) ->
+ case secretOrPublicSubkeyPayload pkt of
+ Just pkp ->
+ supportsRecipientPKESKAlgorithm pkp && sigsAllowEncryption sigs
+ Nothing -> False
+ )
+ (_tkuSubs tk)
+ in primaryAllows || subAllows
+ sigsAllowEncryption [] = True
+ sigsAllowEncryption sigs =
+ let usableSigs = filter (not . signatureHasUnsupportedCriticalSubpackets) sigs
+ flagSets = concatMap keyFlagsFromSig usableSigs
+ in if null usableSigs
+ then False
+ else null flagSets || any hasEncryptionFlag flagSets
+ hasEncryptionFlag flags =
+ S.member EncryptCommunicationsKey flags
+ || S.member EncryptStorageKey flags
+ keyFlagsFromSig sig =
+ case sig of
+ SigV4 _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds
+ SigV6 _ _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds
+ _ -> []
+ signatureHasUnsupportedCriticalSubpackets sig =
+ let hasheds =
+ case sig of
+ SigV4 _ _ _ hs _ _ _ -> hs
+ SigV6 _ _ _ _ hs _ _ _ -> hs
+ _ -> []
+ in any isUnsupportedCritical hasheds
+ isUnsupportedCritical (SigSubPacket isCritical payload) =
+ isCritical
+ && case payload of
+ OtherSigSub {} -> True
+ UserDefinedSigSub {} -> True
+ NotationData {} -> True
+ _ -> False
+ keyFlagsFromSubpackets subpackets =
+ [ flags
+ | SigSubPacket _ (KeyFlags flags) <- subpackets
+ ]
+ secretOrPublicSubkeyPayload (SecretSubkeyPkt pkp _) = Just pkp
+ secretOrPublicSubkeyPayload (PublicSubkeyPkt pkp) = Just pkp
+ secretOrPublicSubkeyPayload _ = Nothing
+ packetRecipientKey path nonEncFps (SecretKeyPkt pkp ska) =
+ let fp = unFingerprint (fingerprint pkp)
+ in if S.member fp nonEncFps
+ then pure Nothing
+ else decryptRecipientKey path pkp ska
+ packetRecipientKey path nonEncFps (SecretSubkeyPkt pkp ska) =
+ let fp = unFingerprint (fingerprint pkp)
+ in if S.member fp nonEncFps
+ then pure Nothing
+ else decryptRecipientKey path pkp ska
+ packetRecipientKey _ _ _ = pure Nothing
+ decryptRecipientKey path pkp ska =
+ case secretKeyProtectionPolicyViolation pkp ska of
+ Just violation ->
+ failWith
+ KeyIsProtected
+ ( "decrypt failed: unsupported secret key protection in "
+ ++ path
+ ++ " ("
+ ++ violation
+ ++ ")"
+ )
+ Nothing ->
+ case ska of
+ SUUnencrypted skey _ ->
+ pure
+ ( Just
+ ( PKESKRecipientKey
+ { pkeskRecipientPKPayload = Just pkp
+ , pkeskRecipientSKey = skey
+ }
+ )
+ )
+ _ ->
+ case passwords of
+ [] ->
+ failWith
+ KeyIsProtected
+ ( "decrypt failed: encrypted key in "
+ ++ path
+ ++ " requires --with-key-password"
+ )
+ _ ->
+ case tryDecryptKey passwords of
+ Left _ ->
+ failWith
+ KeyIsProtected
+ ( "decrypt failed: could not decrypt key in "
+ ++ path
+ ++ " with provided --with-key-password values"
+ )
+ Right (SUUnencrypted skey _) ->
+ pure
+ ( Just
+ ( PKESKRecipientKey
+ { pkeskRecipientPKPayload = Just pkp
+ , pkeskRecipientSKey = skey
+ }
+ )
+ )
+ Right _ ->
+ failWith
+ KeyIsProtected
+ ("decrypt failed: unsupported secret key protection in " ++ path)
+ where
+ secretKeyProtectionPolicyViolation recipientPkp addendum =
+ let rejectArgon2WithoutAEAD s2k
+ | isArgon2S2K s2k =
+ Just "Argon2 S2K is only allowed with AEAD-protected secret keys"
+ | otherwise = Nothing
+ rejectSimpleForV6 s2k
+ | isSimpleS2K s2k =
+ Just "v6 secret key packets MUST NOT use simple S2K"
+ | otherwise = Nothing
+ in case addendum of
+ SUS16bit _ s2k _ _ ->
+ case _keyVersion recipientPkp of
+ V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k
+ _ -> rejectArgon2WithoutAEAD s2k
+ SUSSHA1 _ s2k _ _ ->
+ case _keyVersion recipientPkp of
+ V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k
+ _ -> rejectArgon2WithoutAEAD s2k
+ SUSym {} ->
+ if _keyVersion recipientPkp == V6
+ then
+ Just
+ "v6 secret key packets MUST NOT use legacy CFB secret-key protection"
+ else Nothing
+ _ -> Nothing
+ isArgon2S2K Argon2 {} = True
+ isArgon2S2K _ = False
+ isSimpleS2K (Simple _) = True
+ isSimpleS2K _ = False
+ tryDecryptKey [] = Left ()
+ tryDecryptKey (password : rest) =
+ case decryptPrivateKey (pkp, ska) password of
+ Left _ -> tryDecryptKey rest
+ Right decrypted -> Right decrypted
+
+decodeOpenPGPInput :: String -> BL.ByteString -> IO [Pkt]
+decodeOpenPGPInput path input = do
+ decodedArmors <-
+ decodeAsciiArmorInput ("OpenPGP input in " ++ path) input
+ case decodedArmors of
+ Just armors ->
+ case firstBy isOpenPGPArmorBlock armors of
+ Just (Armor _ _ bs) ->
+ parseOpenPGPPackets
+ ("armored OpenPGP input in " ++ path)
+ (BL.fromStrict (BLC8.toStrict bs))
+ _ ->
+ case firstBy isClearSignedArmor armors of
+ Just _ ->
+ failWith
+ BadData
+ ("Expected key data in " ++ path ++ ", got cleartext signature")
+ _ -> parseOpenPGPPackets "OpenPGP input" input
+ Nothing -> parseOpenPGPPackets "OpenPGP input" input
+
+loadRecipientPreferredHashes
+ :: POSIXTime -> [String] -> IO [HashAlgorithm]
+loadRecipientPreferredHashes cpt certFiles =
+ concat <$> mapM loadFromFile certFiles
+ where
+ loadFromFile path = do
+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
+ pkts <- decodeOpenPGPInput path lbs
+ rejectSecretKeyPackets "encrypt" path pkts
+ tks <-
+ runConduitRes $
+ CL.sourceList pkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ normalized <- mapM (normalizeRecipient path) tks
+ pure
+ (concatMap (effectiveHashPreferencesAt cpt) normalized)
+ normalizeRecipient path tk =
+ case processTK (Just cpt) tk of
+ Left err ->
+ failWith
+ BadData
+ ( "encrypt: invalid recipient certificate in "
+ ++ path
+ ++ ": "
+ ++ show err
+ )
+ Right normalized -> pure normalized
+
+loadEncryptRecipients
+ :: POSIXTime -> EncryptFor -> [String] -> IO [FunKey]
+loadEncryptRecipients cpt encPurpose certFiles = do
+ recipients <- concat <$> mapM loadRecipientsFromFile certFiles
+ if null recipients
+ then
+ failWith
+ CertCannotEncrypt
+ "encrypt: no supported recipient encryption keys found in provided certificates"
+ else pure recipients
+ where
+ loadRecipientsFromFile path = do
+ lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
+ pkts <- decodeOpenPGPInput path lbs
+ rejectSecretKeyPackets "encrypt" path pkts
+ rejectCriticalUnknownRecipientPackets path pkts
+ tks <-
+ runConduitRes $
+ CL.sourceList pkts
+ .| conduitToTKsDroppingEither
+ .| CL.mapFoldable (join . hush)
+ .| CC.sinkList
+ normalized <- mapM (normalizeEncryptRecipientTK path) tks
+ let selected =
+ selectEncryptRecipients
+ encPurpose
+ (concatMap (tkToFunKeysAt cpt) normalized)
+ packetFallback =
+ nub
+ ( concatMap tkToEncryptPayloads normalized
+ ++ mapMaybe extractEncryptRecipientPayload pkts
+ )
+ pure $
+ case encPurpose of
+ EncryptForAny
+ | null selected -> map payloadToFunKey packetFallback
+ _ -> selected
+ normalizeEncryptRecipientTK path tk =
+ case processTK (Just cpt) tk of
+ Left err ->
+ failWith
+ BadData
+ ( "encrypt: invalid recipient certificate in "
+ ++ path
+ ++ ": "
+ ++ show err
+ )
+ Right normalized ->
+ if not
+ (isTKTimeValid (posixSecondsToUTCTime (realToFrac cpt)) normalized)
+ then
+ failWith
+ CertCannotEncrypt
+ ("encrypt: recipient certificate in " ++ path ++ " is expired")
+ else
+ if not (primaryUserIDExpirationAllowsAt cpt normalized)
+ then
+ failWith
+ CertCannotEncrypt
+ ("encrypt: recipient certificate in " ++ path ++ " is expired")
+ else pure normalized
+ rejectCriticalUnknownRecipientPackets path =
+ mapM_
+ ( \pkt ->
+ case pkt of
+ OtherPacketPkt tag _
+ | tag < 40 ->
+ if isForwardCompatRecipientPacketTag tag
+ then pure ()
+ else
+ failWith
+ BadData
+ ( "encrypt: invalid recipient certificate in "
+ ++ path
+ ++ ": critical unknown packet tag "
+ ++ show tag
+ )
+ BrokenPacketPkt _ tag _
+ | tag < 40 ->
+ if isForwardCompatRecipientPacketTag tag
+ then pure ()
+ else
+ failWith
+ BadData
+ ( "encrypt: invalid recipient certificate in "
+ ++ path
+ ++ ": critical unknown packet tag "
+ ++ show tag
+ )
+ _ -> pure ()
+ )
+ isForwardCompatRecipientPacketTag tag = tag `elem` [5, 6, 7, 14]
+ payloadToFunKey pkp = FunKey pkp Nothing S.empty [] [] False
+
+primaryUserIDExpirationAllowsAt :: POSIXTime -> TKUnknown -> Bool
+primaryUserIDExpirationAllowsAt now tk =
+ case primaryUidSigs of
+ [] -> True
+ _ ->
+ any
+ (signatureKeyExpirationAllowsAt now primaryCreatedAt)
+ primaryUidSigs
+ where
+ primaryCreatedAt = fromIntegral (_timestamp (fst (_tkuKey tk)))
+ primaryUidSigs =
+ [ sig
+ | (_, sigs) <- _tkuUIDs tk
+ , sig <- sigs
+ , signatureMarksPrimaryUserId sig
+ ]
+
+signatureMarksPrimaryUserId :: SignaturePayload -> Bool
+signatureMarksPrimaryUserId sig =
+ any isPrimaryUIDSubpacket (signatureSubpackets sig)
+ where
+ isPrimaryUIDSubpacket (SigSubPacket _ (PrimaryUserId True)) = True
+ isPrimaryUIDSubpacket _ = False
+
+signatureKeyExpirationAllowsAt
+ :: POSIXTime -> POSIXTime -> SignaturePayload -> Bool
+signatureKeyExpirationAllowsAt now createdAt sig =
+ case signatureKeyValiditySeconds sig of
+ Nothing -> True
+ Just 0 -> True
+ Just validitySeconds -> now < createdAt + fromIntegral validitySeconds
+
+signatureKeyValiditySeconds :: SignaturePayload -> Maybe Integer
+signatureKeyValiditySeconds sig =
+ listToMaybe
+ [ fromIntegral secs
+ | SigSubPacket _ (KeyExpirationTime (ThirtyTwoBitDuration secs)) <-
+ signatureSubpackets sig
+ ]
+
+selectEncryptRecipients :: EncryptFor -> [FunKey] -> [FunKey]
+selectEncryptRecipients encPurpose keys =
+ chosen
+ where
+ supported = filter (supportsRecipientPKESKAlgorithm . fpkp) keys
+ (matchingPurpose, unrestrictedPurpose) =
+ partition (keyMatchesEncryptPurpose encPurpose . fkufs) supported
+ chosen =
+ case encPurpose of
+ EncryptForAny
+ | null matchingPurpose -> unrestrictedPurpose
+ _ -> matchingPurpose
+
+tkToEncryptPayloads :: TKUnknown -> [SomePKPayload]
+tkToEncryptPayloads (TKUnknown (pkp, _) _ _ _ subs) =
+ filter
+ supportsRecipientPKESKAlgorithm
+ (pkp : mapMaybe extractSubkeyPayload subs)
+ where
+ extractSubkeyPayload (PublicSubkeyPkt subPkp, _) = Just subPkp
+ extractSubkeyPayload (SecretSubkeyPkt subPkp _, _) = Just subPkp
+ extractSubkeyPayload _ = Nothing
+
+extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload
+extractEncryptRecipientPayload pkt =
+ case pkt of
+ PublicKeyPkt pkp
+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp
+ PublicSubkeyPkt pkp
+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp
+ SecretKeyPkt pkp _
+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp
+ SecretSubkeyPkt pkp _
+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp
+ _ -> Nothing
+
+keyMatchesEncryptPurpose :: EncryptFor -> S.Set KeyFlag -> Bool
+keyMatchesEncryptPurpose encPurpose keyFlags =
+ not (S.null (keyFlags `S.intersection` encryptUsageFlags))
+ where
+ encryptUsageFlags =
+ case encPurpose of
+ EncryptForAny -> S.fromList [EncryptStorageKey, EncryptCommunicationsKey]
+ EncryptForStorage -> S.singleton EncryptStorageKey
+ EncryptForCommunications -> S.singleton EncryptCommunicationsKey
+
+supportsRecipientPKESKAlgorithm :: SomePKPayload -> Bool
+supportsRecipientPKESKAlgorithm pkp =
+ _pkalgo pkp
+ `elem` [ RSA
+ , DeprecatedRSAEncryptOnly
+ , ElgamalEncryptOnly
+ , ECDH
+ , X25519
+ , X448
+ ]
+ && hasSupportedRecipientIdentifierLength pkp
+
+hasSupportedRecipientIdentifierLength :: SomePKPayload -> Bool
+hasSupportedRecipientIdentifierLength pkp =
+ let keyIdentifierLen = BL.length (unFingerprint (fingerprint pkp))
+ in keyIdentifierLen == 16
+ || keyIdentifierLen == 20
+ || keyIdentifierLen == 32
+
+renderPKESKEncryptError :: PKESKEncryptError -> String
+renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm symAlgo err) =
+ "unsupported session-key algorithm "
+ ++ show symAlgo
+ ++ ": "
+ ++ err
+renderPKESKEncryptError (InvalidSessionKeyLength symAlgo expected got) =
+ "invalid session-key length for "
+ ++ show symAlgo
+ ++ " (expected "
+ ++ show expected
+ ++ ", got "
+ ++ show got
+ ++ ")"
+renderPKESKEncryptError (UnsupportedRecipientAlgorithm pka) =
+ "unsupported recipient public-key algorithm: " ++ show pka
+renderPKESKEncryptError (InvalidRecipientKeyMaterial pka err) =
+ "invalid recipient key material for " ++ show pka ++ ": " ++ err
+renderPKESKEncryptError (RecipientKdfFailure pka err) =
+ "recipient KDF failure for " ++ show pka ++ ": " ++ err
+renderPKESKEncryptError (RecipientKeyWrapFailure pka err) =
+ "recipient key-wrap failure for " ++ show pka ++ ": " ++ err
+renderPKESKEncryptError (PayloadBuildFailure err) = "payload build failure: " ++ err
+renderPKESKEncryptError NoRecipientsProvided = "no recipients were provided"
+renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) =
+ "recipient capability selection failure: " ++ show err
+renderPKESKEncryptError (InvalidRecipientIdentifier err) =
+ "invalid recipient identifier: " ++ err
+
+sopFailureForPKESKEncryptError :: PKESKEncryptError -> SopFailure
+sopFailureForPKESKEncryptError err =
+ case err of
+ UnsupportedRecipientAlgorithm _ -> UnsupportedAsymmetricAlgo
+ RecipientCapabilitySelectionFailure _ -> CertCannotEncrypt
+ NoRecipientsProvided -> CertCannotEncrypt
+ _ -> BadData
+
+{- | Resolve a PKESK recipient key using two strategies depending on whether
+the probe carries a wildcard recipient ID (eight zero bytes) or a real key
+ID / fingerprint.
+
+* Non-wildcard probes: the callback is invoked once for each PKESK attempt,
+ so we do an idempotent lookup by recipient identifier from the full
+ candidate list to avoid consuming keys needed by later PKESKs.
+
+* Wildcard probes (all-zero legacy recipient ID): hOpenPGP retries the
+ callback after failed unwrap attempts. We therefore pop one candidate from
+ a shared queue on each callback invocation.
+-}
+selectRecipientKeyInfosByRecipientIdentifier
+ :: [PKESKRecipientKey]
+ -> KeyIdentifier
+ -> PubKeyAlgorithm
+ -> IO [PKESKRecipientKey]
+selectRecipientKeyInfosByRecipientIdentifier keyInfos keyIdentifier pka =
+ pure $
+ case keyIdentifier of
+ KeyIdentifierWildcard -> compatible
+ KeyIdentifierEightOctet recipientKeyId ->
+ filter (matchesLegacyRecipientKeyId recipientKeyId) compatible
+ KeyIdentifierFingerprint recipientFingerprint ->
+ filter
+ (matchesRecipientIdentifier (unFingerprint recipientFingerprint))
+ compatible
+ where
+ compatible =
+ [ keyInfo
+ | keyInfo <- keyInfos
+ , supportsPKESKAlgorithm pka keyInfo
+ ]
+
+prioritizeDecryptablePKESKs
+ :: [PKESKRecipientKey] -> [Pkt] -> [Pkt]
+prioritizeDecryptablePKESKs keyInfos pkts =
+ nonMatchingPrefix ++ matchingPrefix ++ suffix
+ where
+ (prefix, suffix) = break isEncryptedPayloadPacket pkts
+ (matchingPrefix, nonMatchingPrefix) =
+ partition
+ ( \pkt ->
+ case pkt of
+ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)) ->
+ any (matchesRecipientIdentifier rid) keyInfos
+ PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ eoki _ _)) ->
+ any (matchesLegacyRecipientKeyId eoki) keyInfos
+ _ -> False
+ )
+ prefix
+
+supportsPKESKAlgorithm
+ :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool
+supportsPKESKAlgorithm pka keyInfo =
+ case pkeskRecipientSKey keyInfo of
+ RSAPrivateKey {} -> pka == RSA || pka == DeprecatedRSAEncryptOnly
+ ElGamalPrivateKey {} -> pka == ElgamalEncryptOnly
+ ECDHPrivateKey {} -> pka == ECDH || pka == X25519
+ X25519PrivateKey {} -> pka == X25519
+ X448PrivateKey {} -> pka == X448
+ UnknownSKey {} ->
+ (pka == X25519 || pka == X448)
+ && case pkeskRecipientPKPayload keyInfo of
+ Just pkp -> _pkalgo pkp == pka
+ Nothing -> False
+ _ -> False
+
+matchesRecipientIdentifier
+ :: BL.ByteString -> PKESKRecipientKey -> Bool
+matchesRecipientIdentifier rid keyInfo =
+ case pkeskRecipientPKPayload keyInfo of
+ Nothing -> False
+ Just pkp ->
+ let identifier = BL.toStrict rid
+ fps = recipientFingerprintsForMatch pkp
+ in any (identifier `elem`) (map recipientIdMatchVariants fps)
+
+recipientFingerprintsForMatch :: SomePKPayload -> [B.ByteString]
+recipientFingerprintsForMatch pkp =
+ baseFp : maybeToList normalizedX25519Fp
+ where
+ baseFp = BL.toStrict (unFingerprint (fingerprint pkp))
+ normalizedX25519Fp =
+ BL.toStrict . unFingerprint . fingerprint
+ <$> normalizeX25519CompatiblePKP pkp
+
+normalizeX25519CompatiblePKP
+ :: SomePKPayload -> Maybe SomePKPayload
+normalizeX25519CompatiblePKP pkp =
+ case _pubkey pkp of
+ ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->
+ Just
+ ( PKPayload
+ (_keyVersion pkp)
+ (_timestamp pkp)
+ (_v3exp pkp)
+ X25519
+ (_pubkey pkp)
+ )
+ _ -> Nothing
+
+recipientIdMatchVariants :: B.ByteString -> [B.ByteString]
+recipientIdMatchVariants fp =
+ [ fp
+ , B.cons 0x04 fp
+ , B.cons 0x06 fp
+ , B.cons 0xFE fp
+ ]
+
+matchesLegacyRecipientKeyId
+ :: EightOctetKeyId -> PKESKRecipientKey -> Bool
+matchesLegacyRecipientKeyId eoki keyInfo =
+ case pkeskRecipientPKPayload keyInfo of
+ Nothing -> False
+ Just pkp ->
+ case eightOctetKeyID pkp of
+ Right keyId -> keyId == eoki
+ Left _ -> False
+
+decodeCiphertextInput :: BL.ByteString -> IO BL.ByteString
+decodeCiphertextInput input = do
+ decodedArmors <- decodeAsciiArmorInput "decrypt input" input
+ case decodedArmors of
+ Just armors ->
+ case firstBy isArmorMessageBlock armors of
+ Just (Armor ArmorMessage _ bs) -> return (BL.fromStrict (BLC8.toStrict bs))
+ _ ->
+ case firstBy isOpenPGPArmorBlock armors of
+ Just _ ->
+ failWith
+ BadData
+ "decrypt expects an armored OpenPGP message"
+ _ -> return input
+ Nothing -> return input
+
+doInlineSign :: POSIXTime -> InlineSignOptions -> IO ()
+doInlineSign pt InlineSignOptions {..} = do
+ when (inlineSignNoArmor && inlineSignArmor) $
+ failWith
+ IncompatibleOptions
+ "inline-sign: --armor and --no-armor are mutually exclusive"
+ forM_
+ inlineSignProfile
+ ( \profile ->
+ failWith
+ UnsupportedOption
+ ("inline-sign: unsupported option --profile=" ++ profile)
+ )
+ let inlineMode = fromMaybe InlineSignAsBinary inlineSignAs
+ mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
+ when (inlineMode /= InlineSignAsBinary) $
+ ensureUTF8TextInput "inline-sign" (BL.fromChunks mbs)
+ signingPasswordsRaw <-
+ loadPasswordFiles
+ "inline-sign"
+ "--with-key-password"
+ inlineSignKeyPasswords
+ let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw
+ ks <- loadSigningKeys inlineSignKeyFiles signingPasswords
+ processedKeys <- mapM (normalizeSigningKey pt) ks
+ let ts = ThirtyTwoBitTimeStamp (floor pt)
+ payloadRaw = BL.fromChunks mbs
+ funkeys = concatMap (tkToFunKeysAt pt) processedKeys
+ signingKeys = filter isInlineRSASigner funkeys
+ inlineSignHash =
+ selectSigningHash signingKeys [] legacySigningHashFallbackOrder
+ when (null signingKeys) $
+ failWith MissingInput "inline-sign: no signing-capable key found"
+ sigs <-
+ mapM
+ ( signInlineData
+ ts
+ (inlineSignSignatureMode inlineMode)
+ inlineSignHash
+ payloadRaw
+ )
+ signingKeys
+ case inlineMode of
+ InlineSignAsClearSigned -> doInlineSignCleartext inlineSignHash payloadRaw sigs
+ InlineSignAsText -> doInlineSignText payloadRaw sigs
+ InlineSignAsBinary -> doInlineSignBinary payloadRaw sigs
+ where
+ inlineSignSignatureMode mode =
+ case mode of
+ InlineSignAsBinary -> AsBinary
+ InlineSignAsText -> AsText
+ InlineSignAsClearSigned -> AsText
+ doInlineSignCleartext inlineSignHash payloadRaw sigs = do
+ when inlineSignNoArmor $
+ failWith
+ IncompatibleOptions
+ "inline-sign --as=clearsigned requires armored output"
+ let cleartextPayload =
+ if not (BL.null payloadRaw) && BL.last payloadRaw == 0x0a
+ then payloadRaw <> BL.singleton 0x0a
+ else payloadRaw
+ sigBytes = runPut $ mapM_ (Bin.put . SignaturePkt) sigs
+ hashHeader = ("Hash", hashAlgorithmHeaderName inlineSignHash)
+ clearSigned =
+ ClearSigned
+ [hashHeader]
+ (BLC8.fromStrict (BL.toStrict cleartextPayload))
+ (Armor ArmorSignature [] (BLC8.fromStrict (BL.toStrict sigBytes)))
+ BLC8.putStr (AA.encodeLazy [clearSigned])
+ doInlineSignText payloadRaw sigs =
+ doInlineSignMessage UTF8Data payloadRaw sigs
+ doInlineSignBinary payloadRaw sigs = do
+ doInlineSignMessage BinaryData payloadRaw sigs
+ doInlineSignMessage literalDataType payloadRaw sigs = do
+ let pktBytes =
+ runPut $
+ Bin.put
+ ( Block
+ ( map SignaturePkt sigs
+ ++ [LiteralDataPkt literalDataType BL.empty 0 payloadRaw]
+ )
+ )
+ BL.putStr $
+ if not inlineSignNoArmor && not inlineSignArmor
+ then AA.encodeLazy [Armor ArmorMessage [] pktBytes]
+ else
+ if inlineSignArmor
+ then AA.encodeLazy [Armor ArmorMessage [] pktBytes]
+ else pktBytes
+
+inlineSignModeReader :: String -> Either String InlineSignMode
+inlineSignModeReader "binary" = Right InlineSignAsBinary
+inlineSignModeReader "text" = Right InlineSignAsText
+inlineSignModeReader "clearsigned" = Right InlineSignAsClearSigned
+inlineSignModeReader _ =
+ Left "signature mode must be one of: binary, text, clearsigned"
+
+isInlineSigningCapable :: FunKey -> Bool
+isInlineSigningCapable k =
+ (S.null (fkufs k) || S.member SignDataKey (fkufs k))
+ && case fmska k of
+ Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
+ Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
+ Just (SUUnencrypted (UnknownSKey _) _) ->
+ isEd25519PKA (_pkalgo (fpkp k))
+ || isEdDSAPKA (_pkalgo (fpkp k))
+ || isEd448PKA (_pkalgo (fpkp k))
+ _ -> False
+
+-- Legacy alias.
+isInlineRSASigner :: FunKey -> Bool
+isInlineRSASigner = isInlineSigningCapable
+
+signInlineData
+ :: ThirtyTwoBitTimeStamp
+ -> AsBinaryText
+ -> HashAlgorithm
+ -> BL.ByteString
+ -> FunKey
+ -> IO SignaturePayload
+signInlineData ts mode signHash payload k =
+ do
+ issuerPackets <- inlineUnhashed (fpkp k)
+ signWithKey
+ "inline-sign"
+ (fpkp k)
+ sigType
+ signHash
+ (inlineHashed (fpkp k) ts)
+ issuerPackets
+ payload
+ (fmska k)
+ where
+ sigType =
+ case mode of
+ AsBinary -> BinarySig
+ AsText -> CanonicalTextSig
+
+inlineHashed
+ :: SomePKPayload -> ThirtyTwoBitTimeStamp -> [SigSubPacket]
+inlineHashed pkp ts =
+ [ SigSubPacket False (SigCreationTime ts)
+ , SigSubPacket
+ False
+ ( IssuerFingerprint
+ (issuerFingerprintVersionFor pkp)
+ (fingerprint pkp)
+ )
+ ]
+
+inlineUnhashed :: SomePKPayload -> IO [SigSubPacket]
+inlineUnhashed pkp =
+ issuerSubpacketsFor "inline-sign" pkp
+
+doInlineDetach :: POSIXTime -> InlineDetachOptions -> IO ()
+doInlineDetach _ InlineDetachOptions {..} = do
+ ensureOutputPathAvailable "inline-detach" inlineDetachOutputSigs
+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
+ (msgData, sigPkts) <- splitInlineSigned input
+ writeDetachedSignatures
+ inlineDetachNoArmor
+ inlineDetachOutputSigs
+ sigPkts
+ BL.putStr msgData
+
+splitInlineSigned :: BL.ByteString -> IO (BL.ByteString, [Pkt])
+splitInlineSigned lbs = do
+ decodedArmors <- decodeAsciiArmorInput "inline-detach input" lbs
+ case decodedArmors of
+ Just armors ->
+ case firstBy isInlineSignedArmorCandidate armors of
+ Just (Armor ArmorMessage _ bs) ->
+ parseOpenPGPPackets
+ "inline-detach armored message"
+ (BL.fromStrict (BLC8.toStrict bs))
+ >>= splitInlineSignedPackets
+ Just (ClearSigned headers cleartext signatureArmor) -> do
+ validateClearSignedHeaders headers
+ sigPkts <- clearSignedSignaturePackets signatureArmor
+ return (BL.fromStrict (BLC8.toStrict cleartext), sigPkts)
+ _ ->
+ parseOpenPGPPackets "inline-detach input" lbs
+ >>= splitInlineSignedPackets
+ Nothing ->
+ parseOpenPGPPackets "inline-detach input" lbs
+ >>= splitInlineSignedPackets
+
+firstBy :: (a -> Bool) -> [a] -> Maybe a
+firstBy predicate = find predicate
+
+decodeAsciiArmorInput
+ :: String -> BL.ByteString -> IO (Maybe [Armor])
+decodeAsciiArmorInput context input =
+ case validateAsciiArmorEnvelope input of
+ Just err ->
+ failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
+ Nothing -> do
+ let primaryDecode = AA.decodeLazy input :: Either String [Armor]
+ case primaryDecode of
+ Right (_ : _) -> pure (Just (fromRight [] primaryDecode))
+ _ -> do
+ let normalizedInput = normalizeAsciiArmorForLenientDecode input
+ fallbackDecode =
+ if normalizedInput /= input
+ then AA.decodeLazy normalizedInput :: Either String [Armor]
+ else primaryDecode
+ case fallbackDecode of
+ Right []
+ | looksLikeAsciiArmor input ->
+ failWith
+ BadData
+ (context ++ ": malformed ASCII armor: no armor blocks found")
+ Right [] -> pure Nothing
+ Right armors -> pure (Just armors)
+ Left err
+ | looksLikeAsciiArmor input ->
+ failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
+ | otherwise -> pure Nothing
+
+normalizeAsciiArmorForLenientDecode
+ :: BL.ByteString -> BL.ByteString
+normalizeAsciiArmorForLenientDecode input
+ | not (looksLikeAsciiArmor input) = input
+ | otherwise =
+ BL.fromStrict
+ . TE.encodeUtf8
+ . T.unlines
+ . normalizeAsciiArmorLines
+ $ T.lines normalizedLineEndings
+ where
+ normalizedLineEndings =
+ T.replace
+ (T.pack "\r")
+ (T.pack "\n")
+ ( T.replace
+ (T.pack "\r\n")
+ (T.pack "\n")
+ (TE.decodeUtf8 (BL.toStrict input))
+ )
+
+data LenientArmorDecodeState
+ = LenientOutsideArmor
+ | LenientArmorHeaders Bool Bool
+ | LenientArmorBody Bool
+
+normalizeAsciiArmorLines :: [Text] -> [Text]
+normalizeAsciiArmorLines = go LenientOutsideArmor
+ where
+ go _ [] = []
+ go state (line : rest) =
+ let trimmedLine = T.dropWhileEnd isSpace line
+ whitespaceOnly = T.all isSpace line
+ beginLabel = beginArmorLabelText trimmedLine
+ isBegin = isJust beginLabel
+ isEnd = T.isPrefixOf (T.pack "-----END PGP ") trimmedLine
+ hasHeaderSeparator = T.any (== ':') trimmedLine
+ in case state of
+ LenientOutsideArmor
+ | isBegin ->
+ let isClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
+ shouldStripHeaders = not isClearSigned
+ in trimmedLine
+ : go (LenientArmorHeaders shouldStripHeaders isClearSigned) rest
+ | otherwise -> trimmedLine : go LenientOutsideArmor rest
+ LenientArmorHeaders stripHeaders isClearSigned
+ | whitespaceOnly ->
+ T.empty : go (LenientArmorBody isClearSigned) rest
+ | isEnd -> T.empty : trimmedLine : go LenientOutsideArmor rest
+ | stripHeaders && hasHeaderSeparator ->
+ go (LenientArmorHeaders stripHeaders isClearSigned) rest
+ | otherwise ->
+ trimmedLine : go (LenientArmorBody isClearSigned) rest
+ LenientArmorBody isClearSigned
+ | isEnd -> trimmedLine : go LenientOutsideArmor rest
+ | isBegin ->
+ let nestedClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
+ shouldStripHeaders = not nestedClearSigned
+ in trimmedLine
+ : go
+ (LenientArmorHeaders shouldStripHeaders nestedClearSigned)
+ rest
+ | otherwise ->
+ let bodyLine =
+ if isClearSigned
+ then line
+ else trimmedLine
+ in bodyLine : go (LenientArmorBody isClearSigned) rest
+
+beginArmorLabelText :: Text -> Maybe Text
+beginArmorLabelText line = do
+ rest <- T.stripPrefix (T.pack "-----BEGIN PGP ") line
+ T.stripSuffix (T.pack "-----") rest
+
+validateClearSignedHeaders :: [(String, String)] -> IO ()
+validateClearSignedHeaders headers =
+ unless (all (isAllowedHeaderKey . fst) headers) $
+ failWith
+ BadData
+ "cleartext signed message contains unsupported armor headers"
+ where
+ isAllowedHeaderKey hkey =
+ map toLower hkey `elem` ["hash"]
+
+validateClearSignedEnvelopeBounds :: BL.ByteString -> IO ()
+validateClearSignedEnvelopeBounds input = do
+ let text = TE.decodeUtf8With lenientDecode (BL.toStrict input)
+ normalized = T.replace (T.pack "\r") (T.pack "") text
+ ls = T.lines normalized
+ beginMarker = T.pack "-----BEGIN PGP SIGNED MESSAGE-----"
+ endMarker = T.pack "-----END PGP SIGNATURE-----"
+ firstBegin = findIndex ((== beginMarker) . T.strip) ls
+ hasVisibleText line = not (T.all isSpace line)
+ findIndexFrom start predicate =
+ fmap (+ start) (findIndex predicate (drop start ls))
+ case firstBegin of
+ Nothing -> pure ()
+ Just beginIx -> do
+ when (any hasVisibleText (take beginIx ls)) $
+ failWith
+ BadData
+ "cleartext signed message has non-whitespace text before armor header"
+ case findIndexFrom beginIx ((== endMarker) . T.strip) of
+ Nothing -> pure ()
+ Just endIx ->
+ when (any hasVisibleText (drop (endIx + 1) ls)) $
+ failWith
+ BadData
+ "cleartext signed message has non-whitespace text after signature block"
+
+looksLikeAsciiArmor :: BL.ByteString -> Bool
+looksLikeAsciiArmor input =
+ BLC8.pack "-----BEGIN PGP "
+ `BL.isPrefixOf` BLC8.dropWhile isAsciiArmorLeadingWhitespace input
+
+isAsciiArmorLeadingWhitespace :: Char -> Bool
+isAsciiArmorLeadingWhitespace c = c `elem` [' ', '\t', '\r', '\n']
+
+validateAsciiArmorEnvelope :: BL.ByteString -> Maybe String
+validateAsciiArmorEnvelope input
+ | not (looksLikeAsciiArmor input) = Nothing
+ | otherwise =
+ validateArmorBlocks
+ (BLC8.lines (BLC8.dropWhile isAsciiArmorLeadingWhitespace input))
+
+validateArmorBlocks :: [BL.ByteString] -> Maybe String
+validateArmorBlocks [] = Nothing
+validateArmorBlocks (line : rest) =
+ case beginArmorLabel line of
+ -- UPSTREAM: openpgp-asciiarmor should export detectCleartextSignedBlock helper
+ -- to encapsulate this RFC 4880 cleartext signature framework detection
+ Just "SIGNED MESSAGE" -> validateClearSignedBlock rest
+ Just label -> validateBinaryArmorBlock label rest
+ Nothing -> Nothing
+
+validateClearSignedBlock :: [BL.ByteString] -> Maybe String
+validateClearSignedBlock ls =
+ case break hasBeginArmorLabel ls of
+ (_, []) ->
+ Just
+ "cleartext signed message is missing an armored signature block"
+ (_, beginLine : rest) ->
+ case beginArmorLabel beginLine of
+ Just "SIGNATURE" -> validateBinaryArmorBlock "SIGNATURE" rest
+ Just label ->
+ Just
+ ( "cleartext signed message must be followed by a PGP SIGNATURE block, found PGP "
+ ++ label
+ )
+ Nothing ->
+ Just
+ "cleartext signed message has an invalid armored signature header"
+
+validateBinaryArmorBlock
+ :: String -> [BL.ByteString] -> Maybe String
+validateBinaryArmorBlock label ls =
+ case break hasEndArmorLabel ls of
+ (_, []) -> Just ("missing END PGP " ++ label ++ " footer")
+ (_, endLine : rest) ->
+ case endArmorLabel endLine of
+ Just endLabel
+ | endLabel == label -> validateArmorBlocks rest
+ | otherwise ->
+ Just
+ ( "mismatched footer: expected END PGP "
+ ++ label
+ ++ ", found END PGP "
+ ++ endLabel
+ )
+ Nothing -> Just ("invalid END PGP " ++ label ++ " footer")
+
+hasBeginArmorLabel :: BL.ByteString -> Bool
+hasBeginArmorLabel = isJust . beginArmorLabel
+
+hasEndArmorLabel :: BL.ByteString -> Bool
+hasEndArmorLabel = isJust . endArmorLabel
+
+beginArmorLabel :: BL.ByteString -> Maybe String
+beginArmorLabel = armorBoundaryLabel "-----BEGIN PGP " "-----"
+
+endArmorLabel :: BL.ByteString -> Maybe String
+endArmorLabel = armorBoundaryLabel "-----END PGP " "-----"
+
+armorBoundaryLabel
+ :: String -> String -> BL.ByteString -> Maybe String
+armorBoundaryLabel prefix suffix line = do
+ rest <- stripPrefix prefix (BLC8.unpack line)
+ if suffix `isSuffixOf` rest
+ then pure (take (length rest - length suffix) rest)
+ else Nothing
+
+isOpenPGPArmorBlock :: Armor -> Bool
+isOpenPGPArmorBlock (Armor _ _ _) = True
+isOpenPGPArmorBlock _ = False
+
+isArmorMessageBlock :: Armor -> Bool
+isArmorMessageBlock (Armor ArmorMessage _ _) = True
+isArmorMessageBlock _ = False
+
+isDetachedSignatureArmor :: Armor -> Bool
+isDetachedSignatureArmor (Armor ArmorSignature _ _) = True
+isDetachedSignatureArmor _ = False
+
+isDetachedSignatureUnsupportedArmor :: Armor -> Bool
+isDetachedSignatureUnsupportedArmor (Armor _ _ _) = True
+isDetachedSignatureUnsupportedArmor ClearSigned {} = True
+
+isClearSignedArmor :: Armor -> Bool
+isClearSignedArmor ClearSigned {} = True
+isClearSignedArmor _ = False
+
+isInlineSignedArmorCandidate :: Armor -> Bool
+isInlineSignedArmorCandidate (Armor ArmorMessage _ _) = True
+isInlineSignedArmorCandidate ClearSigned {} = True
+isInlineSignedArmorCandidate _ = False
+
+splitInlineSignedPackets :: [Pkt] -> IO (BL.ByteString, [Pkt])
+splitInlineSignedPackets pkts = do
+ let msgPkts = [p | p@LiteralDataPkt {} <- pkts]
+ sigPkts = [p | p@SignaturePkt {} <- pkts]
+ case msgPkts of
+ [LiteralDataPkt _ _ _ payload]
+ | null sigPkts ->
+ failWith BadData "inline-detach input has no signatures"
+ | otherwise -> return (payload, sigPkts)
+ [] ->
+ failWith
+ BadData
+ "inline-detach input has no literal message payload"
+ _ ->
+ failWith
+ BadData
+ "inline-detach input contains multiple literal payloads"
+
+writeDetachedSignatures :: Bool -> String -> [Pkt] -> IO ()
+writeDetachedSignatures noArmor outPath sigPkts = do
+ let sigBytes = runPut $ mapM_ Bin.put sigPkts
+ out =
+ if noArmor
+ then sigBytes
+ else
+ BL.fromStrict
+ (BLC8.toStrict (AA.encodeLazy [Armor ArmorSignature [] sigBytes]))
+ BL.writeFile outPath out
+
+doListProfiles :: ListProfilesOptions -> IO ()
+doListProfiles lpos =
+ case profileSubcommand lpos of
+ "generate-key" ->
+ putStr
+ "default: implementation defaults\nrfc4880: RSA-4096 interoperability-focused key generation\ncompatibility: broad interoperability defaults (alias of rfc4880)\nsecurity: security-oriented key generation\nperformance: performance-oriented key generation\n"
+ "encrypt" ->
+ putStr
+ "default: implementation defaults (alias of rfc9580, security, and performance)\nrfc9580: RFC 9580 packet format preferences\nrfc4880: RFC 4880 packet format preferences\ncompatibility: broad interoperability defaults (alias of rfc4880)\n"
+ _ ->
+ failWith
+ UnsupportedProfile
+ "Subcommand does not support profiles"
diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal
--- a/hopenpgp-tools.cabal
+++ b/hopenpgp-tools.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: hopenpgp-tools
-version: 0.25.1
+version: 0.25.2
synopsis: hOpenPGP-based command-line tools
description: command-line tools for performing some OpenPGP-related operations
homepage: https://salsa.debian.org/clint/hOpenPGP-tools
@@ -129,4 +129,4 @@
source-repository this
type: git
location: https://salsa.debian.org/clint/hopenpgp-tools.git
- tag: hopenpgp-tools/0.25.1
+ tag: hopenpgp-tools/0.25.2
diff --git a/hot.hs b/hot.hs
--- a/hot.hs
+++ b/hot.hs
@@ -15,11 +15,13 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-
{-# LANGUAGE RecordWildCards #-}
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
-import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..))
+import Codec.Encryption.OpenPGP.ASCIIArmor.Types
+ ( Armor (..)
+ , ArmorType (..)
+ )
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Control.Applicative (optional)
@@ -32,148 +34,165 @@
import Data.Binary.Get (Get)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
-import Data.Conduit (ConduitM, (.|), runConduitRes)
+import Data.Conduit (ConduitM, runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Filter
- ( FilterPredicates(RPFilterPredicate)
- , conduitPktFilter
- )
+ ( FilterPredicates (RPFilterPredicate)
+ , conduitPktFilter
+ )
import Data.Conduit.Serialization.Binary (conduitGet, conduitPut)
import Data.Void (Void)
import qualified Data.Yaml as Y
-import HOpenPGP.Tools.Common.Armor (doDeArmor)
-import HOpenPGP.Tools.Common.Common (banner, prependAuto, versioner, warranty)
-import HOpenPGP.Tools.Common.Parser (parsePExp)
-
-import System.IO
- ( BufferMode(..)
- , Handle
- , hFlush
- , hPutStrLn
- , hSetBuffering
- , stderr
- , stdin
- , stdout
- )
-import System.Exit (exitFailure)
-
-import Prettyprinter
- ( Pretty
- , (<+>)
- , group
- , hardline
- , list
- , pretty
- , softline
- )
-import Prettyprinter.Render.Text (hPutDoc)
import Options.Applicative.Builder
- ( argument
- , command
- , eitherReader
- , footerDoc
- , headerDoc
- , help
- , helpDoc
- , info
- , long
- , metavar
- , option
- , prefs
- , progDesc
- , showDefaultWith
- , showHelpOnError
- , str
- , strOption
- , value
- )
-import Options.Applicative.Extra (customExecParser, helper, hsubparser)
+ ( argument
+ , command
+ , eitherReader
+ , footerDoc
+ , headerDoc
+ , help
+ , helpDoc
+ , info
+ , long
+ , metavar
+ , option
+ , prefs
+ , progDesc
+ , showDefaultWith
+ , showHelpOnError
+ , str
+ , strOption
+ , value
+ )
+import Options.Applicative.Extra
+ ( customExecParser
+ , helper
+ , hsubparser
+ )
import Options.Applicative.Types (Parser)
+import Prettyprinter
+ ( Pretty
+ , group
+ , hardline
+ , list
+ , pretty
+ , softline
+ , (<+>)
+ )
+import Prettyprinter.Render.Text (hPutDoc)
+import System.Exit (exitFailure)
+import System.IO
+ ( BufferMode (..)
+ , Handle
+ , hFlush
+ , hPutStrLn
+ , hSetBuffering
+ , stderr
+ , stdin
+ , stdout
+ )
+import HOpenPGP.Tools.Common.Armor (doDeArmor)
+import HOpenPGP.Tools.Common.Common
+ ( banner
+ , prependAuto
+ , versioner
+ , warranty
+ )
+import HOpenPGP.Tools.Common.Parser (parsePExp)
+
data Command
- = DumpC DumpOptions
- | DeArmorC
- | ArmorC ArmoringOptions
- | FilterC FilteringOptions
+ = DumpC DumpOptions
+ | DeArmorC
+ | ArmorC ArmoringOptions
+ | FilterC FilteringOptions
-data DumpOptions =
- DumpOptions
+data DumpOptions
+ = DumpOptions
{ outputformat :: DumpOutputFormat
}
-data FilteringOptions =
- FilteringOptions
+data FilteringOptions
+ = FilteringOptions
{ fExpression :: String
}
data DumpOutputFormat
- = DumpPretty
- | DumpJSON
- | DumpYAML
- | DumpShow
- deriving (Bounded, Enum, Read, Show)
+ = DumpPretty
+ | DumpJSON
+ | DumpYAML
+ | DumpShow
+ deriving (Bounded, Enum, Read, Show)
doDump :: DumpOptions -> IO ()
doDump DumpOptions {..} =
- runConduitRes $
- CB.sourceHandle stdin .| conduitGet (get :: Get Pkt) .|
- case outputformat of
- DumpPretty -> prettyPrinter
- DumpJSON -> jsonSink
- DumpYAML -> yamlSink
- DumpShow -> printer
+ runConduitRes $
+ CB.sourceHandle stdin
+ .| conduitGet (get :: Get Pkt)
+ .| case outputformat of
+ DumpPretty -> prettyPrinter
+ DumpJSON -> jsonSink
+ DumpYAML -> yamlSink
+ DumpShow -> printer
-- Print every input value to standard output.
-printer :: (Show a, MonadIO m) => ConduitM a Void m ()
+printer :: (MonadIO m, Show a) => ConduitM a Void m ()
printer = CL.mapM_ (liftIO . print)
-prettyPrinter :: (Pretty a, MonadIO m) => ConduitM a Void m ()
+prettyPrinter :: (MonadIO m, Pretty a) => ConduitM a Void m ()
prettyPrinter =
- CL.mapM_ (liftIO . hPutDoc stdout . (<> hardline) . group . pretty)
+ CL.mapM_
+ (liftIO . hPutDoc stdout . (<> hardline) . group . pretty)
jsonSink :: (A.ToJSON a, MonadIO m) => ConduitM a Void m ()
jsonSink = CL.mapM_ (liftIO . BL.putStr . flip BL.snoc 0x0a . A.encode)
-yamlSink :: (Y.ToJSON a, MonadIO m) => ConduitM a Void m ()
+yamlSink :: (MonadIO m, Y.ToJSON a) => ConduitM a Void m ()
yamlSink = CL.mapM_ (liftIO . B.putStr . flip B.snoc 0x0a . Y.encode)
doFilter :: FilteringOptions -> IO ()
doFilter fo =
- parseExpressions fo >>= \parsed ->
- case parsed of
- Left err -> dieHot err
- Right predicates ->
- runConduitRes $
- CB.sourceHandle stdin .| conduitGet (get :: Get Pkt) .|
- conduitPktFilter predicates .|
- CL.map put .|
- conduitPut .|
- CB.sinkHandle stdout
+ parseExpressions fo >>= \parsed ->
+ case parsed of
+ Left err -> dieHot err
+ Right predicates ->
+ runConduitRes $
+ CB.sourceHandle stdin
+ .| conduitGet (get :: Get Pkt)
+ .| conduitPktFilter predicates
+ .| CL.map put
+ .| conduitPut
+ .| CB.sinkHandle stdout
doP :: Parser DumpOptions
doP =
- DumpOptions <$>
- option
- (prependAuto "Dump")
- (long "output-format" <>
- metavar "FORMAT" <>
- value DumpPretty <> showDefaultWith (drop 4 . show) <> ofHelp)
+ DumpOptions
+ <$> option
+ (prependAuto "Dump")
+ ( long "output-format"
+ <> metavar "FORMAT"
+ <> value DumpPretty
+ <> showDefaultWith (drop 4 . show)
+ <> ofHelp
+ )
where
ofHelp =
- helpDoc . Just $
- pretty "output format" <>
- hardline <> list (map (pretty . drop 4 . show) ofchoices)
+ helpDoc . Just $
+ pretty "output format"
+ <> hardline
+ <> list (map (pretty . drop 4 . show) ofchoices)
ofchoices = [minBound .. maxBound] :: [DumpOutputFormat]
foP :: Parser FilteringOptions
foP =
- FilteringOptions <$> argument str (metavar "EXPRESSION" <> filterTargetHelp)
+ FilteringOptions
+ <$> argument str (metavar "EXPRESSION" <> filterTargetHelp)
where
filterTargetHelp =
- helpDoc . Just $
- pretty "packet filter expression" <+>
- softline <> pretty "see source for current syntax"
+ helpDoc . Just $
+ pretty "packet filter expression"
+ <+> softline
+ <> pretty "see source for current syntax"
dispatch :: Command -> IO ()
dispatch c = (banner' stderr >> hFlush stderr) >> dispatch' c
@@ -185,88 +204,105 @@
main :: IO ()
main = do
- hSetBuffering stderr LineBuffering
- customExecParser
- (prefs showHelpOnError)
- (info
- (helper <*> versioner "hot" <*> cmd)
- (headerDoc (Just (banner "hot")) <>
- progDesc "hOpenPGP OpenPGP-message Tool" <>
- footerDoc (Just (warranty "hot")))) >>=
- dispatch
+ hSetBuffering stderr LineBuffering
+ customExecParser
+ (prefs showHelpOnError)
+ ( info
+ (helper <*> versioner "hot" <*> cmd)
+ ( headerDoc (Just (banner "hot"))
+ <> progDesc "hOpenPGP OpenPGP-message Tool"
+ <> footerDoc (Just (warranty "hot"))
+ )
+ )
+ >>= dispatch
cmd :: Parser Command
cmd =
- hsubparser
- (command "armor" (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout")) <>
- command
- "dearmor"
- (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout")) <>
- command
- "dump"
- (info (DumpC <$> doP) (progDesc "Dump OpenPGP packets from stdin")) <>
- command
- "filter"
- (info
- (FilterC <$> foP)
- (progDesc "Filter some packets from stdin to stdout")))
+ hsubparser
+ ( command
+ "armor"
+ (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout"))
+ <> command
+ "dearmor"
+ (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))
+ <> command
+ "dump"
+ (info (DumpC <$> doP) (progDesc "Dump OpenPGP packets from stdin"))
+ <> command
+ "filter"
+ ( info
+ (FilterC <$> foP)
+ (progDesc "Filter some packets from stdin to stdout")
+ )
+ )
banner' :: Handle -> IO ()
-banner' h = hPutDoc h (banner "hot" <> hardline <> warranty "hot" <> hardline)
+banner' h =
+ hPutDoc
+ h
+ (banner "hot" <> hardline <> warranty "hot" <> hardline)
-parseExpressions :: FilteringOptions -> IO (Either String (FilterPredicates r a))
+parseExpressions
+ :: FilteringOptions -> IO (Either String (FilterPredicates r a))
parseExpressions FilteringOptions {..} = do
- parsed <- parseE fExpression
- pure (RPFilterPredicate <$> parsed)
+ parsed <- parseE fExpression
+ pure (RPFilterPredicate <$> parsed)
where
parseE e = do
- parsed <- try (evaluate (parsePExp e :: Either String (Reader Pkt Bool))) :: IO (Either ErrorCall (Either String (Reader Pkt Bool)))
- pure $
- case parsed of
- Left err -> Left (show (err :: ErrorCall))
- Right value -> value
+ parsed <-
+ try (evaluate (parsePExp e :: Either String (Reader Pkt Bool)))
+ :: IO (Either ErrorCall (Either String (Reader Pkt Bool)))
+ pure $
+ case parsed of
+ Left err -> Left (show (err :: ErrorCall))
+ Right v -> v
armorTypes :: [(String, ArmorType)]
armorTypes =
- [ ("message", ArmorMessage)
- , ("pubkeyblock", ArmorPublicKeyBlock)
- , ("privkeyblock", ArmorPrivateKeyBlock)
- , ("signature", ArmorSignature)
- ]
+ [ ("message", ArmorMessage)
+ , ("pubkeyblock", ArmorPublicKeyBlock)
+ , ("privkeyblock", ArmorPrivateKeyBlock)
+ , ("signature", ArmorSignature)
+ ]
armorTypeReader :: String -> Either String ArmorType
armorTypeReader = note "unknown armor type" . flip lookup armorTypes
aoP :: Parser ArmoringOptions
aoP =
- ArmoringOptions <$>
- optional
- (strOption
- (long "comment" <> metavar "COMMENT" <> help "ASCII armor Comment field")) <*>
- option
- (eitherReader armorTypeReader)
- (long "armor-type" <> metavar "ARMORTYPE" <> armortypeHelp)
+ ArmoringOptions
+ <$> optional
+ ( strOption
+ ( long "comment"
+ <> metavar "COMMENT"
+ <> help "ASCII armor Comment field"
+ )
+ )
+ <*> option
+ (eitherReader armorTypeReader)
+ (long "armor-type" <> metavar "ARMORTYPE" <> armortypeHelp)
where
armortypeHelp =
- helpDoc . Just $
- pretty "ASCII armor type" <>
- softline <> list (map (pretty . fst) armorTypes)
+ helpDoc . Just $
+ pretty "ASCII armor type"
+ <> softline
+ <> list (map (pretty . fst) armorTypes)
-data ArmoringOptions =
- ArmoringOptions
+data ArmoringOptions
+ = ArmoringOptions
{ comment :: Maybe String
, armortype :: ArmorType
}
doArmor :: ArmoringOptions -> IO ()
doArmor ArmoringOptions {..} = do
- m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
- let a =
- Armor
- armortype
- (maybe [] (\x -> [("Comment", x)]) comment)
- (BL.fromChunks m)
- BL.putStr $ AA.encodeLazy [a]
+ m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
+ let a =
+ Armor
+ armortype
+ (maybe [] (\x -> [("Comment", x)]) comment)
+ (BL.fromChunks m)
+ BL.putStr $ AA.encodeLazy [a]
dieHot :: String -> IO a
dieHot msg = hPutStrLn stderr msg >> exitFailure