hopenpgp-tools-0.25.1/ 0000755 0000000 0000000 00000000000 07346545000 012746 5 ustar 00 0000000 0000000 hopenpgp-tools-0.25.1/HOpenPGP/Tools/Common/ 0000755 0000000 0000000 00000000000 07346545000 016656 5 ustar 00 0000000 0000000 hopenpgp-tools-0.25.1/HOpenPGP/Tools/Common/Armor.hs 0000644 0000000 0000000 00000003017 07346545000 020273 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
-- Armor.hs: hOpenPGP-tools common ASCII de-Armor function
-- Copyright © 2012-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
module HOpenPGP.Tools.Common.Armor
( doDeArmor
) where
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..))
import qualified Data.ByteString as B
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 System.IO (hPutStrLn, stderr, stdin)
doDeArmor :: IO ()
doDeArmor = do
a <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
case AA.decode (B.concat a) of
Left e -> hPutStrLn stderr $ "Failure to decode ASCII Armor:" ++ e
Right msgs -> BL.putStr $ BL.concat [ bs | Armor _ _ bs <- msgs ]
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Common/Common.hs 0000644 0000000 0000000 00000017217 07346545000 020452 0 ustar 00 0000000 0000000 -- Common.hs: hOpenPGP-tools common functions
-- Copyright © 2012-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
module HOpenPGP.Tools.Common.Common
( banner
, versioner
, warranty
, prependAuto
, keyMatchesFingerprint
, keyMatchesEightOctetKeyId
, keyMatchesExactUIDString
, keyMatchesUIDSubString
, keyMatchesPKPred
-- hmm
, pkpGetPKVersion
, pkpGetPKAlgo
, pkpGetKeysize
, pkpGetTimestamp
, pkpGetFingerprint
, pkpGetEOKI
, tkUsingPKP
, pUsingPKP
, pUsingSP
, tkGetUIDs
, tkGetSubs
, anyOrAll
, anyReader
, oGetTag
, oGetLength
, spGetSigVersion
, spGetSigType
, spGetPKAlgo
, spGetHashAlgo
, spGetSCT
, maybeR
, renderKeyID
, renderFingerprint
) where
import Data.Version (showVersion)
import Paths_hopenpgp_tools (version)
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.SignatureQualities (sigCT)
import Codec.Encryption.OpenPGP.Types
import Control.Lens ((^..))
import Data.Binary (put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString.Lazy as BL
import Data.Data.Lens (biplate)
import Data.Text (Text)
import qualified Data.Text as T
import Options.Applicative.Builder (auto, help, hidden, infoOption, long, short)
import Options.Applicative.Types (Parser, ReadM(..))
import Prettyprinter (Doc, (<+>), hardline, pretty, defaultLayoutOptions, layoutPretty)
import qualified Prettyprinter.Render.Text as PPA
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Control.Error.Util (hush)
import Control.Monad.Trans.Reader
( Reader
, ReaderT
, ask
, local
, reader
, runReader
, withReader
)
-- hmm --
import Data.Maybe (fromMaybe, mapMaybe)
banner :: String -> Doc ann
{-# INLINE banner #-}
banner name =
pretty name <+>
pretty "(hopenpgp-tools)" <+>
pretty (showVersion version) <>
hardline <> pretty "Copyright (C) 2012-2026 Clint Adams"
warranty :: String -> Doc ann
{-# INLINE warranty #-}
warranty name =
pretty name <+>
pretty "comes with ABSOLUTELY NO WARRANTY." <+>
pretty "This is free software, and you are welcome to redistribute it" <+>
pretty "under certain conditions."
versioner :: String -> Parser (a -> a)
{-# INLINE versioner #-}
versioner name =
infoOption (name ++ " (hopenpgp-tools) " ++ showVersion version) $
long "version" <> short 'V' <> help "Show version information" <> hidden
prependAuto :: Read a => String -> ReadM a
prependAuto s = ReadM (local (s ++) (unReadM auto))
keyMatchesFingerprint :: Bool -> TKUnknown -> Fingerprint -> Bool
keyMatchesFingerprint = keyMatchesPKPred fingerprint
keyMatchesEightOctetKeyId :: Bool -> TKUnknown -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow
keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID
keyMatchesExactUIDString :: Text -> TKUnknown -> Bool
keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkuUIDs
keyMatchesUIDSubString :: Text -> TKUnknown -> Bool
keyMatchesUIDSubString uidstr =
any (T.toLower uidstr `T.isInfixOf`) . map (T.toLower . fst) . _tkuUIDs
keyMatchesPKPred :: Eq a => (SomePKPayload -> a) -> Bool -> TKUnknown -> a -> Bool
keyMatchesPKPred p False = (==) . p . fst . _tkuKey
keyMatchesPKPred p True = \tk v -> elem v (map p (tk ^.. biplate))
-- The following should probably be moved elsewhere
tkUsingPKP :: Reader SomePKPayload a -> Reader TKUnknown a
tkUsingPKP = withReader (fst . _tkuKey)
pkpGetPKVersion :: SomePKPayload -> Integer
pkpGetPKVersion t =
if _keyVersion t == DeprecatedV3
then 3
else 4
pkpGetPKAlgo :: SomePKPayload -> Integer
pkpGetPKAlgo = fromIntegral . fromFVal . _pkalgo
pkpGetKeysize :: SomePKPayload -> Integer
pkpGetKeysize = fromIntegral . fromMaybe 0 . hush . pubkeySize . _pubkey
pkpGetTimestamp :: SomePKPayload -> Integer
pkpGetTimestamp = fromIntegral . _timestamp
pkpGetFingerprint :: SomePKPayload -> Fingerprint
pkpGetFingerprint = fingerprint
pkpGetEOKI :: SomePKPayload -> String
pkpGetEOKI = either (const "UNKNOWN") show . eightOctetKeyID
tkGetUIDs :: TKUnknown -> [Text]
tkGetUIDs = map fst . _tkuUIDs
tkGetSubs :: TKUnknown -> [SomePKPayload]
tkGetSubs = mapMaybe (grabPKP . fst) . _tkuSubs
where
grabPKP (PublicSubkeyPkt p) = Just p
grabPKP (SecretSubkeyPkt p _) = Just p
grabPKP _ = Nothing
anyOrAll ::
(Monad m, Monad m1)
=> ((a1 -> c) -> a -> ReaderT a m b)
-> (m1 a1 -> c)
-> ReaderT a m b
anyOrAll aa op = ask >>= aa (op . return)
anyReader :: Reader a Bool -> Reader [a] Bool
anyReader p = any (runReader p) `fmap` ask
oGetTag :: Pkt -> Integer
oGetTag = fromIntegral . pktTag
oGetLength :: Pkt -> Integer
oGetLength = fromIntegral . BL.length . runPut . put -- FIXME: this should be a length that makes sense
spGetSigVersion :: Pkt -> Maybe Integer
spGetSigVersion (SignaturePkt s) = Just (sigVersion s)
where
sigVersion SigV3 {} = 3
sigVersion SigV4 {} = 4
sigVersion SigV6 {} = 6
sigVersion (SigVOther v _) = fromIntegral v
spGetSigVersion _ = Nothing
spGetSigType :: Pkt -> Maybe Integer
spGetSigType (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigType s)
-- FIXME: deduplicate this and hOpenPGP .Internal
where
sigType :: SignaturePayload -> Maybe SigType
sigType (SigV3 st _ _ _ _ _ _) = Just st
sigType (SigV4 st _ _ _ _ _ _) = Just st
sigType _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild
spGetSigType _ = Nothing
spGetPKAlgo :: Pkt -> Maybe Integer
spGetPKAlgo (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigPKA s)
where
sigPKA (SigV3 _ _ _ pka _ _ _) = Just pka
sigPKA (SigV4 _ pka _ _ _ _ _) = Just pka
sigPKA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild
spGetPKAlgo _ = Nothing
spGetHashAlgo :: Pkt -> Maybe Integer
spGetHashAlgo (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigHA s)
where
sigHA (SigV3 _ _ _ _ ha _ _) = Just ha
sigHA (SigV4 _ _ ha _ _ _ _) = Just ha
sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild
spGetHashAlgo _ = Nothing
spGetSCT :: Pkt -> Maybe Integer
spGetSCT (SignaturePkt s) = fmap fromIntegral (sigCT s)
spGetSCT _ = Nothing
pUsingPKP :: Reader (Maybe SomePKPayload) a -> Reader Pkt a
pUsingPKP = withReader grabPayload
where
grabPayload (SecretKeyPkt p _) = Just p
grabPayload (PublicKeyPkt p) = Just p
grabPayload (SecretSubkeyPkt p _) = Just p
grabPayload (PublicSubkeyPkt p) = Just p
grabPayload _ = Nothing
pUsingSP :: Reader (Maybe SignaturePayload) a -> Reader Pkt a
pUsingSP = withReader grabPayload
where
grabPayload (SignaturePkt s) = Just s
grabPayload _ = Nothing
maybeR :: a -> Reader r a -> Reader (Maybe r) a
maybeR x r = reader (maybe x (runReader r))
renderKeyID :: EightOctetKeyId -> String
renderKeyID =
T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty
renderFingerprint :: Fingerprint -> String
renderFingerprint =
T.unpack . PPA.renderStrict . layoutPretty defaultLayoutOptions . pretty
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Common/HKP.hs 0000644 0000000 0000000 00000010210 07346545000 017626 0 ustar 00 0000000 0000000 -- HKP.hs: hOpenPGP key tool
-- Copyright © 2016-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- 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
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
( Armor(Armor)
, ArmorType(ArmorPublicKeyBlock)
)
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.Types
( Block(..)
, TKUnknown(..)
, Fingerprint
)
import Control.Applicative (liftA2)
import Control.Arrow ((&&&))
import Control.Lens ((^..))
import Control.Monad.IO.Class (liftIO)
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 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.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
)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (ok200)
import Prettyprinter (pretty)
data FetchValidationMethod
= MatchPrimaryKeyFingerprint
| MatchPrimaryOrAnySubkeyFingerprint
| AnySelfSigned
deriving (Bounded, Enum, Eq, Read, Show)
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
where
fvp MatchPrimaryKeyFingerprint k = fingerprint k == q
fvp MatchPrimaryOrAnySubkeyFingerprint k =
any (\k -> fingerprint k == q) (k ^.. biplate)
fvp AnySelfSigned k = 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
]
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
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
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Common/Lexer.x 0000644 0000000 0000000 00000010767 07346545000 020141 0 ustar 00 0000000 0000000 {
{-# OPTIONS -w #-}
module HOpenPGP.Tools.Common.Lexer
( alexEOF
, alexSetInput
, alexGetInput
, alexError
, alexScan
, ignorePendingBytes
, alexGetStartCode
, runAlex
, Alex(..)
, Token(..)
, AlexReturn(..)
, AlexPosn(..)
) where
import Prelude hiding (lex)
import Numeric (readHex)
import Codec.Encryption.OpenPGP.Types (Fingerprint(..), EightOctetKeyId(..))
}
%wrapper "monad"
$digit = 0-9
$hexdigit = [0-9A-Fa-f]
tokens :-
$white+ ;
a { lex' TokenA }
and { lex' TokenAnd }
any { lex' TokenAny }
every { lex' TokenEvery }
not { lex' TokenNot }
now { lex' TokenNow }
one { lex' TokenOne }
or { lex' TokenOr }
subkey { lex' TokenSubkey }
tag { lex' TokenTag }
of { lex' TokenOf }
\=\= { lex' TokenEq }
\= { lex' TokenEq }
equals { lex' TokenEq }
\< { lex' TokenLt }
\> { lex' TokenGt }
\( { lex' TokenLParen }
\) { lex' TokenRParen }
contains { lex' TokenContains }
pkversion { lex' TokenPKVersion }
sigversion { lex' TokenSigVersion }
[Ss]ig[Tt]ype { lex' TokenSigType }
[Pp][Kk][Aa]lgo { lex' TokenPKAlgo }
[Ss]ig[Pp][Kk][Aa]lgo { lex' TokenSigPKAlgo }
[Hh]ash[Aa]lgo { lex' TokenHashAlgo }
[Rr][Ss][Aa] { lex' TokenRSA }
[Dd][Ss][Aa] { lex' TokenDSA }
[Ee]l[Gg]amal { lex' TokenElgamal }
[Ee][Cc][Dd][Ss][Aa] { lex' TokenECDSA }
[Ee][Cc][Dd][Hh] { lex' TokenECDH }
[Dd][Hh] { lex' TokenDH }
[Bb]inary { lex' TokenBinary }
[Cc]anonical[Tt]ext { lex' TokenCanonicalText }
[Ss]tandalone { lex' TokenStandalone }
[Gg]eneric[Cc]ert { lex' TokenGenericCert }
[Pp]ersona[Cc]ert { lex' TokenPersonaCert }
[Cc]asual[Cc]ert { lex' TokenCasualCert }
[Pp]ositive[Cc]ert { lex' TokenPositiveCert }
[Ss]ubkey[Bb]inding[Ss]ig { lex' TokenSubkeyBindingSig }
[Pp]rimary[Kk]ey[Bb]inding[Ss]ig { lex' TokenPrimaryKeyBindingSig }
[Ss]ignature[Dd]irectly[Oo]n[Aa][Kk]ey { lex' TokenSignatureDirectlyOnAKey }
[Kk]ey[Rr]evocation[Ss]ig { lex' TokenKeyRevocationSig }
[Ss]ubkey[Rr]evocation[Ss]ig { lex' TokenSubkeyRevocationSig }
[Cc]ert[Rr]evocation[Ss]ig { lex' TokenCertRevocationSig }
[Tt]imestamp[Ss]ig { lex' TokenTimestampSig }
[Mm][Dd]5 { lex' TokenMD5 }
[Ss][Hh][Aa]1 { lex' TokenSHA1 }
[Rr][Ii][Pp][Ee][Mm][Dd]160 { lex' TokenRIPEMD160 }
[Ss][Hh][Aa]256 { lex' TokenSHA256 }
[Ss][Hh][Aa]384 { lex' TokenSHA384 }
[Ss][Hh][Aa]512 { lex' TokenSHA512 }
[Ss][Hh][Aa]224 { lex' TokenSHA224 }
[Uu][Ii][Dd]s { lex' TokenUids }
keysize { lex' TokenKeysize }
length { lex' TokenLength }
timestamp { lex' TokenTimestamp }
fingerprint { lex' TokenFingerprint }
keyid { lex' TokenKeyID }
[Ss]ig[Cc]reation[Tt]ime { lex' TokenSigCreationTime }
$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{4} { lex (TokenFpr . read) }
0x$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{4} { lex (TokenFpr . read . drop 2) }
$hexdigit{8}$hexdigit{8} { lex (TokenLongID . Right . read) }
0x$hexdigit{8}$hexdigit{8} { lex (TokenLongID . Right . read . drop 2) }
$digit+ { lex (TokenInt . fromIntegral . read) }
$hexdigit+ { lex (TokenInt . fromIntegral . fst . head . readHex) }
0x$hexdigit+ { lex (TokenInt . fromIntegral . fst . head . readHex . drop 2) }
\".*\" { lex (TokenStr . ((zipWith const . drop 1) <*> (drop 2))) }
{
data Token
= TokenTag
| TokenAfter
| TokenAnd
| TokenAny
| TokenBefore
| TokenNot
| TokenNow
| TokenOr
| TokenInt Integer
| TokenEq
| TokenLt
| TokenGt
| TokenLParen
| TokenRParen
| TokenEOF
| TokenPKVersion
| TokenSigVersion
| TokenSigType
| TokenPKAlgo
| TokenSigPKAlgo
| TokenHashAlgo
| TokenRSA
| TokenDSA
| TokenElgamal
| TokenECDSA
| TokenECDH
| TokenDH
| TokenBinary
| TokenCanonicalText
| TokenStandalone
| TokenGenericCert
| TokenPersonaCert
| TokenCasualCert
| TokenPositiveCert
| TokenSubkeyBindingSig
| TokenPrimaryKeyBindingSig
| TokenSignatureDirectlyOnAKey
| TokenKeyRevocationSig
| TokenSubkeyRevocationSig
| TokenCertRevocationSig
| TokenTimestampSig
| TokenMD5
| TokenSHA1
| TokenRIPEMD160
| TokenSHA256
| TokenSHA384
| TokenSHA512
| TokenSHA224
| TokenKeysize
| TokenTimestamp
| TokenFingerprint
| TokenKeyID
| TokenFpr Fingerprint
| TokenLongID (Either String EightOctetKeyId)
| TokenLength
| TokenEvery
| TokenOne
| TokenOf
| TokenContains
| TokenUids
| TokenStr String
| TokenA
| TokenSubkey
| TokenSigCreationTime
deriving (Eq,Show)
alexEOF = return TokenEOF
lex :: (String -> a) -> AlexAction a
lex f = \(_,_,_,s) i -> return (f (take i s))
lex' :: a -> AlexAction a
lex' = lex . const
}
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Common/Parser.y 0000644 0000000 0000000 00000020147 07346545000 020310 0 ustar 00 0000000 0000000 {
{-# OPTIONS -w #-}
module HOpenPGP.Tools.Common.Parser( parseTKExp, parsePExp ) where
import Codec.Encryption.OpenPGP.Types
-- import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..))
import HOpenPGP.Tools.Common.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, spGetSCT, pUsingPKP, pUsingSP, maybeR)
import HOpenPGP.Tools.Common.Lexer
import Control.Applicative (liftA2)
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Control.Error.Util (hush)
import Control.Monad.Loops (allM, anyM)
import Control.Monad.Trans.Reader (ask, reader, Reader, withReader)
import Data.List (isInfixOf)
import qualified Data.Text as T
import Prettyprinter (pretty)
}
%name parseTK Exp
%name parseP CFExp
%tokentype { Token }
%monad { Alex }
%lexer { lexwrap } { TokenEOF }
%error { happyError }
%token
a { TokenA }
and { TokenAnd }
any { TokenAny }
contains { TokenContains }
every { TokenEvery }
not { TokenNot }
now { TokenNow }
of { TokenOf }
one { TokenOne }
or { TokenOr }
subkey { TokenSubkey }
tag { TokenTag }
int { TokenInt $$ }
'=' { TokenEq }
'<' { TokenLt }
'>' { TokenGt }
'(' { TokenLParen }
')' { TokenRParen }
pkversion { TokenPKVersion }
sigversion { TokenSigVersion }
sigtype { TokenSigType }
pkalgo { TokenPKAlgo }
sigpkalgo { TokenSigPKAlgo }
hashalgo { TokenHashAlgo }
rsa { TokenRSA }
dsa { TokenDSA }
elgamal { TokenElgamal }
ecdsa { TokenECDSA }
ecdh { TokenECDH }
dh { TokenDH }
binary { TokenBinary }
canonicaltext { TokenCanonicalText }
standalone { TokenStandalone }
genericcert { TokenGenericCert }
personacert { TokenPersonaCert }
casualcert { TokenCasualCert }
positivecert { TokenPositiveCert }
subkeybindingsig { TokenSubkeyBindingSig }
primarykeybindingsig { TokenPrimaryKeyBindingSig }
signaturedirectlyonakey { TokenSignatureDirectlyOnAKey }
keyrevocationsig { TokenKeyRevocationSig }
subkeyrevocationsig { TokenSubkeyRevocationSig }
certrevocationsig { TokenCertRevocationSig }
timestampsig { TokenTimestampSig }
md5 { TokenMD5 }
sha1 { TokenSHA1 }
ripemd160 { TokenRIPEMD160 }
sha256 { TokenSHA256 }
sha384 { TokenSHA384 }
sha512 { TokenSHA512 }
sha224 { TokenSHA224 }
keysize { TokenKeysize }
timestamp { TokenTimestamp }
fingerprint { TokenFingerprint }
keyid { TokenKeyID }
sigcreationtime { TokenSigCreationTime }
fpr { TokenFpr $$ }
longid { TokenLongID $$ }
length { TokenLength }
str { TokenStr $$ }
uids { TokenUids }
%%
Exp : any { return True }
| not Exp { fmap not $2 }
| Exp and Exp { liftA2 (&&) $1 $3 }
| Exp or Exp { liftA2 (||) $1 $3 }
| PExp { tkUsingPKP $1 }
| TExp { $1 }
PExp : pkversion PIOp int { $2 (reader pkpGetPKVersion) (return $3) }
| pkalgo PIOp Ppkalgos { $2 (reader pkpGetPKAlgo) (return $3) }
| keysize PIOp int { $2 (reader pkpGetKeysize) (return $3) }
| timestamp PIOp int { $2 (reader pkpGetTimestamp) (return $3) }
| fingerprint PSOp Pfingerprint { $2 (reader (show . pretty . pkpGetFingerprint)) (return $3) }
| keyid PSOp Plongid { $2 (reader pkpGetEOKI) (return $3) }
TExp : every one of uids AATOp str { withReader tkGetUIDs (anyOrAll allM ($5 (return (T.pack $6)))) }
| any one of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($5 (return (T.pack $6)))) }
| any of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($4 (return (T.pack $5)))) }
| a subkey PExp { withReader tkGetSubs (anyReader $3) }
PIOp : '=' { liftA2 (==) }
| '<' { liftA2 (<) }
| '>' { liftA2 (>) }
PSOp : '=' { liftA2 (==) }
| contains { liftA2 (flip isInfixOf) }
AATOp : '=' { liftA2 (==) }
| contains { liftA2 T.isInfixOf }
Ppkalgos : rsa { fromIntegral (fromFVal RSA) }
| dsa { fromIntegral (fromFVal DSA) }
| elgamal { fromIntegral (fromFVal ElgamalEncryptOnly) }
| ecdsa { fromIntegral (fromFVal ECDSA) }
| ecdh { fromIntegral (fromFVal ECDH) }
| dh { fromIntegral (fromFVal DH) }
| int { fromIntegral $1 }
Pfingerprint : fpr { (show . pretty) $1 }
Plongid : longid { either (const "BROKEN") show $1 }
CFExp : any { return True }
| not CFExp { fmap not $2 }
| CFExp and CFExp { liftA2 (&&) $1 $3 }
| CFExp or CFExp { liftA2 (||) $1 $3 }
| OExp { $1 }
| SPExp { $1 }
| PExp { pUsingPKP (maybeR True $1) }
OExp : tag OIOp int { $2 (reader oGetTag) (return $3) }
| length OIOp int { $2 (reader oGetLength) (return $3) }
OIOp : '=' { liftA2 (==) }
| '<' { liftA2 (<) }
| '>' { liftA2 (>) }
SPExp : sigversion SIOp int { $2 (reader spGetSigVersion) (return (Just $3)) }
| sigtype SIOp Ssigtypes { $2 (reader spGetSigType) (return (Just $3)) }
| sigpkalgo SIOp Spkalgos { $2 (reader spGetPKAlgo) (return (Just $3)) }
| hashalgo SIOp Shashalgos { $2 (reader spGetHashAlgo) (return (Just $3)) }
| sigcreationtime SIOp Stimespec { $2 (reader spGetSCT) (return (Just $3)) }
SIOp : '=' { liftA2 (==) }
| '<' { liftA2 (<) }
| '>' { liftA2 (>) }
Ssigtypes : binary { fromIntegral (fromFVal BinarySig) }
| canonicaltext { fromIntegral (fromFVal CanonicalTextSig) }
| standalone { fromIntegral (fromFVal StandaloneSig) }
| genericcert { fromIntegral (fromFVal GenericCert) }
| personacert { fromIntegral (fromFVal PersonaCert) }
| casualcert { fromIntegral (fromFVal CasualCert) }
| positivecert { fromIntegral (fromFVal PositiveCert) }
| subkeybindingsig { fromIntegral (fromFVal SubkeyBindingSig) }
| primarykeybindingsig { fromIntegral (fromFVal PrimaryKeyBindingSig) }
| signaturedirectlyonakey { fromIntegral (fromFVal SignatureDirectlyOnAKey) }
| keyrevocationsig { fromIntegral (fromFVal KeyRevocationSig) }
| subkeyrevocationsig { fromIntegral (fromFVal SubkeyRevocationSig) }
| certrevocationsig { fromIntegral (fromFVal CertRevocationSig) }
| timestampsig { fromIntegral (fromFVal TimestampSig) }
| int { fromIntegral $1 }
Spkalgos : rsa { fromIntegral (fromFVal RSA) }
| dsa { fromIntegral (fromFVal DSA) }
| elgamal { fromIntegral (fromFVal ElgamalEncryptOnly) }
| ecdsa { fromIntegral (fromFVal ECDSA) }
| ecdh { fromIntegral (fromFVal ECDH) }
| dh { fromIntegral (fromFVal DH) }
| int { fromIntegral $1 }
Shashalgos : md5 { fromIntegral (fromFVal DeprecatedMD5) }
| sha1 { fromIntegral (fromFVal SHA1) }
| ripemd160 { fromIntegral (fromFVal RIPEMD160) }
| sha256 { fromIntegral (fromFVal SHA256) }
| sha384 { fromIntegral (fromFVal SHA384) }
| sha512 { fromIntegral (fromFVal SHA512) }
| sha224 { fromIntegral (fromFVal SHA224) }
| int { fromIntegral $1 }
Stimespec : now { 0 }
| int { fromIntegral $1 }
{
lexwrap :: (Token -> Alex a) -> Alex a
lexwrap cont = do
t <- alexMonadScan'
cont t
alexMonadScan' = do
inp <- alexGetInput
sc <- alexGetStartCode
case alexScan inp sc of
AlexEOF -> alexEOF
AlexError (pos, _, _, _) -> alexError (show pos)
AlexSkip inp' len -> do
alexSetInput inp'
alexMonadScan'
AlexToken inp' len action -> do
alexSetInput inp'
action (ignorePendingBytes inp) len
getPosn :: Alex (Int,Int)
getPosn = do
(AlexPn _ l c,_,_,_) <- alexGetInput
return (l,c)
happyError :: Token -> Alex a
happyError t = do
(l,c) <- getPosn
error (show l ++ ":" ++ show c ++ ": Parse error on Token: " ++ show t ++ "\n")
parseTKExp :: String -> Either String (Reader TKUnknown Bool)
parseTKExp s = runAlex s parseTK
parsePExp :: String -> Either String (Reader Pkt Bool)
parsePExp s = runAlex s parseP
}
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Common/TKUtils.hs 0000644 0000000 0000000 00000007553 07346545000 020563 0 ustar 00 0000000 0000000 -- TKUtils.hs: hOpenPGP-tools TK-related common functions
-- Copyright © 2013-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
module HOpenPGP.Tools.Common.TKUtils
( processTK
) where
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.Signatures
( VerificationError
, verifyAgainstKeys
, verifySigWith
, verifyUnknownTKWith
)
import Codec.Encryption.OpenPGP.Types
import Control.Arrow (second)
import Control.Error.Util (hush)
import Control.Lens ((^.), _1)
import Data.Bifunctor (first)
import Data.List (sortOn)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Ord (Down(..))
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
-- should this fail or should 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
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)
}
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
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?
sigissuer (SigV6 _ _ _ _ ys xs _ _) =
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?
sigissuerfp (SigV6 _ _ _ _ ys xs _ _) =
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
fp
| _keyVersion pkp == V4 = Just . fingerprint $ pkp
| otherwise = Nothing
getIssuer (Issuer i) = Just i
getIssuer _ = Nothing
getIssuerFP (IssuerFingerprint IssuerFingerprintV4 i) = Just i
getIssuerFP _ = Nothing
assI x = ((==) <$> sigissuer x <*> eoki) == Just True
assIFP x = ((==) <$> sigissuerfp x <*> fp) == Just True
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Common/WKD.hs 0000644 0000000 0000000 00000015165 07346545000 017647 0 ustar 00 0000000 0000000 -- WKD.hs: hOpenPGP key tool
-- Copyright © 2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- 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
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
( 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 qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
import Data.Binary (get)
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 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.Either (rights)
import Data.Text (Text)
import qualified Data.Text as T
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
)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (ok200)
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
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 @"
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
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
decodeWkdResponse :: BL.ByteString -> ExceptT String IO [TKUnknown]
decodeWkdResponse 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
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
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
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))
sha1 :: B.ByteString -> B.ByteString
sha1 bs = BA.convert (CH.hashWith CHA.SHA1 bs :: CH.Digest CHA.SHA1)
zbase32 :: B.ByteString -> B.ByteString
zbase32 = BC8.pack . encodeZBase32 . B.unpack
encodeZBase32 :: [Word8] -> String
encodeZBase32 = go 0 0
where
alphabet = "ybndrfg8ejkmcpqxot1uwisza345h769"
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
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Hokey/ 0000755 0000000 0000000 00000000000 07346545000 016505 5 ustar 00 0000000 0000000 hopenpgp-tools-0.25.1/HOpenPGP/Tools/Hokey/Canonicalize.hs 0000644 0000000 0000000 00000003606 07346545000 021445 0 ustar 00 0000000 0000000 -- Canonicalize.hs: hOpenPGP key tool canonicalize subcommand
-- Copyright © 2013-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
module HOpenPGP.Tools.Hokey.Canonicalize
(
doCanonicalize
) where
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Control.Lens (_2, mapped, over)
import Data.Binary (get, put)
import Data.Conduit ((.|), runConduitRes)
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
import Data.Conduit.Serialization.Binary (conduitGet, conduitPut)
import Data.List (nub, sort)
import System.IO
( stdin
, stdout
)
doCanonicalize :: IO ()
doCanonicalize =
runConduitRes $ CB.sourceHandle stdin .| conduitGet get .|
conduitToTKsDropping .|
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)
}
indepthsort :: (Ord a, Ord b) => [(a, [b])] -> [(a, [b])]
indepthsort = nub . sort . over (mapped . _2) sort
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Hokey/Fetch.hs 0000644 0000000 0000000 00000003427 07346545000 020100 0 ustar 00 0000000 0000000 -- Fetch.hs: hOpenPGP key tool fetch subcommand
-- Copyright © 2013-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
module HOpenPGP.Tools.Hokey.Fetch
(
doFetch
) where
import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)
import Codec.Encryption.OpenPGP.Serialize ()
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import qualified Data.ByteString as B
import qualified Data.Text as T
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
)
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
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs 0000644 0000000 0000000 00000034143 07346545000 021617 0 ustar 00 0000000 0000000 -- InjectSSHAgent.hs: hOpenPGP key tool inject-ssh-agent subcommand
-- Copyright © 2013-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- 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
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.Ontology
( 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 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 (AuthSecretSubkeyAtTime, authSecretSubkeyPrimaryUID, authSecretSubkeyValue, conduitToAuthSecretSubkeysAt, conduitToSecretTKs)
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 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 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
)
doInjectSSHAgent :: InjectSSHAgentOptions -> IO ()
doInjectSSHAgent opts = do
socketPath <- resolveSSHAgentSocketPath (injectSSHAgentSocket opts)
input <- readInjectedSecretKeyMaterial opts
cpt <- getPOSIXTime
authCandidates <-
runConduitRes $
CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|
conduitToAuthSecretSubkeysAt (posixSecondsToUTCTime cpt) .|
CL.consume
injectableCandidates <-
if null authCandidates
then inferInjectableAuthSubkeys cpt input
else pure (map candidateFromAuthSecretSubkey authCandidates)
whenEmpty injectableCandidates "inject-ssh-agent: no authentication-capable secret subkey found"
selectedRequests <-
selectInjectableAuthSubkeys
(injectSSHAgentComment opts)
injectableCandidates
mapM_
(\(selected, request) -> do
sendAddIdentityToSSHAgent socketPath request
hPutStrLn stderr $
"inject-ssh-agent: added authentication subkey " ++
renderFingerprint (fingerprint (injectableAuthSubkeyPKP selected)) ++
" to ssh-agent")
selectedRequests
candidateFromAuthSecretSubkey :: AuthSecretSubkeyAtTime -> InjectableAuthSubkey
candidateFromAuthSecretSubkey authSubkey =
InjectableAuthSubkey
{ injectableAuthSubkeyPKP = authSecretSubkeyPKP authSubkey
, injectableAuthSubkeySKA = authSecretSubkeySKA authSubkey
, injectableAuthSubkeyPrimaryUID = authSecretSubkeyPrimaryUID authSubkey
}
inferInjectableAuthSubkeys ::
POSIXTime -> BL.ByteString -> IO [InjectableAuthSubkey]
inferInjectableAuthSubkeys _cpt input = do
tks <-
runConduitRes $
CL.sourceList (BL.toChunks input) .| conduitGet get .| conduitToSecretTKs .|
CL.consume
pure (concatMap inferFromTK tks)
where
inferFromTK tk =
let mPrimaryUID = fst <$> listToMaybe (_tkUIDs tk)
in mapMaybe (inferFromSubkey mPrimaryUID) (_tkSubs tk)
inferFromSubkey :: Maybe Text -> (KeyPkt k, [SignaturePayload]) -> Maybe InjectableAuthSubkey
inferFromSubkey mPrimaryUID (KeyPktSecretSubkey pkp ska, sigs)
| hasAuthCapability sigs =
Just
InjectableAuthSubkey
{ injectableAuthSubkeyPKP = pkp
, injectableAuthSubkeySKA = ska
, injectableAuthSubkeyPrimaryUID = mPrimaryUID
}
inferFromSubkey _ _ = Nothing
hasAuthCapability sigs =
any
(Set.member AuthKey)
(mapMaybe signatureKeyFlags (newestWithUsageFlags (filter isSKBindingSig sigs)))
newestWithUsageFlags =
take 1 . sortOn (Down . take 1 . sigCreationTimes) . filter (any isKUF . signatureHashedSubpackets)
sigCreationTimes = mapMaybe sigCreationTimeFromSubpacket . signatureHashedSubpackets
sigCreationTimeFromSubpacket (SigSubPacket _ (SigCreationTime ct)) = Just ct
sigCreationTimeFromSubpacket _ = Nothing
signatureHashedSubpackets (SigV4 _ _ _ hasheds _ _ _) = hasheds
signatureHashedSubpackets (SigV6 _ _ _ _ hasheds _ _ _) = hasheds
signatureHashedSubpackets _ = []
signatureKeyFlags sig = do
sp <- find isKUF (signatureHashedSubpackets sig)
case sp of
SigSubPacket _ (KeyFlags flags) -> Just flags
_ -> Nothing
resolveSSHAgentSocketPath :: Maybe String -> IO String
resolveSSHAgentSocketPath (Just path) = pure path
resolveSSHAgentSocketPath Nothing = do
envPath <- lookupEnv "SSH_AUTH_SOCK"
case envPath of
Just path -> pure path
Nothing ->
failInject
"inject-ssh-agent: SSH_AUTH_SOCK is not set; use --ssh-agent-socket"
readInjectedSecretKeyMaterial :: InjectSSHAgentOptions -> IO BL.ByteString
readInjectedSecretKeyMaterial opts = do
chunks <-
case injectSSHAgentFromFD opts of
Nothing -> runConduitRes $ CB.sourceHandle stdin .| CL.consume
Just fd
| fd < 0 ->
failInject "inject-ssh-agent: --from-fd must be a non-negative integer"
| otherwise ->
runConduitRes $ CB.sourceFile ("/dev/fd/" ++ show fd) .| CL.consume
let input = BL.fromChunks chunks
if BL.null input
then
failInject
"inject-ssh-agent: no secret key bytes were provided on the selected input stream"
else pure input
selectInjectableAuthSubkeys ::
Maybe String -> [InjectableAuthSubkey] -> IO [(InjectableAuthSubkey, BL.ByteString)]
selectInjectableAuthSubkeys mComment candidates
| null selectedRequests =
failInject
("inject-ssh-agent: auth-capable subkeys were found, but none are supported for ssh-agent injection: " ++
intercalate "; " (reverse errs))
| otherwise = pure (reverse selectedRequests)
where
(errs, selectedRequests) = foldl' pick ([], []) candidates
pick (accErrs, accSelected) candidate =
case
sshAddIdentityRequest
(fromMaybe (defaultSSHComment candidate) mComment)
(injectableAuthSubkeyPKP candidate)
(injectableAuthSubkeySKA candidate) of
Left err -> (err : accErrs, accSelected)
Right request -> (accErrs, (candidate, request) : accSelected)
defaultSSHComment candidate =
case injectableAuthSubkeyPrimaryUID candidate of
Just uid -> T.unpack uid
Nothing -> "openpgp:" ++ BC8.unpack (Base16.encode (BL.toStrict (unFingerprint (fingerprint (injectableAuthSubkeyPKP candidate)))))
sshAddIdentityRequest ::
String -> SomePKPayload -> SKAddendum -> Either String BL.ByteString
sshAddIdentityRequest comment subkeyPKP subkeySKA =
case subkeySKA of
SUUnencrypted (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) _ ->
Right $ frameSSHAgentRequest (rsaAddIdentityPayload (BC8.pack comment) rsaPrivateKey)
SUUnencrypted (EdDSAPrivateKey Ed25519 secretSeed) _ ->
frameSSHAgentRequest <$>
ed25519AddIdentityPayload (BC8.pack comment) subkeyPKP secretSeed
SUUnencrypted (UnknownSKey rawSecret) _
| isEd25519PKA (_pkalgo subkeyPKP) ->
frameSSHAgentRequest <$>
ed25519AddIdentityPayload
(BC8.pack comment)
subkeyPKP
(BL.toStrict rawSecret)
SUUnencrypted (EdDSAPrivateKey Ed448 _) _ ->
Left
("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
" uses Ed448, which is not supported by ssh-agent add-identity")
SUUnencrypted _ _ ->
Left
("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
" uses an unsupported key algorithm for ssh-agent injection")
_ ->
Left
("subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++
" is encrypted; decrypt it before injection")
authSecretSubkeyPKP :: AuthSecretSubkeyAtTime -> SomePKPayload
authSecretSubkeyPKP = keyPktPKPayload . authSecretSubkeyValue
authSecretSubkeySKA :: AuthSecretSubkeyAtTime -> SKAddendum
authSecretSubkeySKA = secretKeyPktSKAddendum . authSecretSubkeyValue
rsaAddIdentityPayload :: B.ByteString -> RSA.PrivateKey -> BL.ByteString
rsaAddIdentityPayload comment privateKey =
runPut $ do
putWord8 17
putSSHString (BC8.pack "ssh-rsa")
putSSHMpint (RSA.public_n (RSA.private_pub privateKey))
putSSHMpint (RSA.public_e (RSA.private_pub privateKey))
putSSHMpint (RSA.private_d privateKey)
putSSHMpint (RSA.private_qinv privateKey)
putSSHMpint (RSA.private_p privateKey)
putSSHMpint (RSA.private_q privateKey)
putSSHString comment
ed25519AddIdentityPayload ::
B.ByteString -> SomePKPayload -> B.ByteString -> Either String BL.ByteString
ed25519AddIdentityPayload comment pkp rawSecret = do
publicKey <- ed25519PublicPoint pkp
secretSeed <- normalizeEd25519Secret rawSecret
pure $
runPut $ do
putWord8 17
putSSHString (BC8.pack "ssh-ed25519")
putSSHString publicKey
putSSHString (secretSeed <> publicKey)
putSSHString comment
ed25519PublicPoint :: SomePKPayload -> Either String B.ByteString
ed25519PublicPoint pkp =
case _pubkey pkp of
EdDSAPubKey Ed25519 point ->
maybe
(Left ("invalid Ed25519 public point for subkey " ++ renderFingerprint (fingerprint pkp)))
Right
(edPointToRawBytes point)
_ -> Left ("subkey " ++ renderFingerprint (fingerprint pkp) ++ " does not have an Ed25519 public key")
edPointToRawBytes :: EdPoint -> Maybe B.ByteString
edPointToRawBytes (NativeEPoint (EPoint i)) = integerToFixedBytes 32 i
edPointToRawBytes (PrefixedNativeEPoint (EPoint i)) = do
prefixed <- integerToFixedBytes 33 i
case B.uncons prefixed of
Just (0x40, raw) -> Just raw
_ -> Nothing
normalizeEd25519Secret :: B.ByteString -> Either String B.ByteString
normalizeEd25519Secret rawSecret
| B.length rawSecret == 32 = Right rawSecret
| otherwise =
Left
("expected 32-byte Ed25519 secret seed, got " ++ show (B.length rawSecret) ++ " bytes")
putSSHString :: B.ByteString -> Put
putSSHString bs = putWord32be (fromIntegral (B.length bs)) >> putByteString bs
putSSHMpint :: Integer -> Put
putSSHMpint n
| n <= 0 = putWord32be 0
| otherwise = putSSHString encoded
where
raw = integerToUnsignedBytes n
encoded =
case B.uncons raw of
Just (firstByte, _)
| testBit firstByte 7 -> B.cons 0x00 raw
_ -> raw
integerToFixedBytes :: Int -> Integer -> Maybe B.ByteString
integerToFixedBytes width n
| n < 0 = Nothing
| B.length raw > width = Nothing
| otherwise = Just (B.replicate (width - B.length raw) 0x00 <> raw)
where
raw =
if n == 0
then B.singleton 0x00
else integerToUnsignedBytes n
integerToUnsignedBytes :: Integer -> B.ByteString
integerToUnsignedBytes n =
B.reverse $
B.unfoldr
(\value ->
if value == 0
then Nothing
else Just (fromIntegral (value .&. 0xff), value `shiftR` 8))
n
isEd25519PKA :: PubKeyAlgorithm -> Bool
isEd25519PKA pka = fromFVal pka == 27
frameSSHAgentRequest :: BL.ByteString -> BL.ByteString
frameSSHAgentRequest body =
runPut $ putWord32be (fromIntegral (BL.length body)) >> putLazyByteString body
sendAddIdentityToSSHAgent :: FilePath -> BL.ByteString -> IO ()
sendAddIdentityToSSHAgent socketPath request =
bracket
(socket AF_UNIX Stream defaultProtocol)
close
(\sock -> do
connect sock (SockAddrUnix socketPath)
NSB.sendAll sock (BL.toStrict request)
response <- readSSHAgentPacket sock
case B.uncons response of
Just (6, _) -> pure ()
Just (5, _) ->
failInject "inject-ssh-agent: ssh-agent rejected the supplied key"
Just (code, _) ->
failInject
("inject-ssh-agent: ssh-agent returned unexpected response type " ++
show code)
Nothing ->
failInject
"inject-ssh-agent: ssh-agent returned an empty response packet")
readSSHAgentPacket :: Socket -> IO B.ByteString
readSSHAgentPacket sock = do
lenPrefix <- recvExact sock 4
let packetLen = fromIntegral (runGet getWord32be (BL.fromStrict lenPrefix))
recvExact sock packetLen
recvExact :: Socket -> Int -> IO B.ByteString
recvExact _ 0 = pure B.empty
recvExact sock remaining = go B.empty remaining
where
go acc 0 = pure acc
go acc bytesRemaining = do
chunk <- NSB.recv sock bytesRemaining
if B.null chunk
then
failInject
"inject-ssh-agent: ssh-agent socket closed while reading response"
else go (acc <> chunk) (bytesRemaining - B.length chunk)
whenEmpty :: [a] -> String -> IO ()
whenEmpty [] msg = failInject msg
whenEmpty _ _ = pure ()
failInject :: String -> IO a
failInject msg = hPutStrLn stderr msg >> exitFailure
data InjectableAuthSubkey =
InjectableAuthSubkey
{ injectableAuthSubkeyPKP :: SomePKPayload
, injectableAuthSubkeySKA :: SKAddendum
, injectableAuthSubkeyPrimaryUID :: Maybe Text
}
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Hokey/Lint.hs 0000644 0000000 0000000 00000061103 07346545000 017750 0 ustar 00 0000000 0000000 -- Lint.hs: hOpenPGP key tool lint subcommand
-- Copyright © 2013-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- 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
hopenpgp-tools-0.25.1/HOpenPGP/Tools/Hokey/Options.hs 0000644 0000000 0000000 00000007465 07346545000 020510 0 ustar 00 0000000 0000000 -- Options.hs: hOpenPGP key tool command-line options
-- Copyright © 2013-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
module HOpenPGP.Tools.Hokey.Options
(
-- 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
)
import Options.Applicative.Types (Parser)
import Prettyprinter
( hardline
, list
, pretty
)
data LintOutputFormat
= Pretty
| JSON
| YAML
deriving (Bounded, Enum, Eq, Read, Show)
data LintOptions =
LintOptions
{ lintOutputFormat :: LintOutputFormat
}
data FetchOptions =
FetchOptions
{ keyServer :: String
, fetchMethod :: FetchMethod
, fetchValidation :: FetchValidationMethod
, fetchQuery :: String
}
data InjectSSHAgentOptions =
InjectSSHAgentOptions
{ injectSSHAgentFromFD :: Maybe Int
, injectSSHAgentSocket :: Maybe String
, injectSSHAgentComment :: Maybe String
}
data FetchMethod
= HKP
| WKD
deriving (Bounded, Enum, Eq, Read, Show)
lintO :: Parser LintOptions
lintO =
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)
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")
where
fmHelp =
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)
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"))
hopenpgp-tools-0.25.1/LICENSE 0000644 0000000 0000000 00000103330 07346545000 013753 0 ustar 00 0000000 0000000 GNU AFFERO GENERAL PUBLIC LICENSE
Version 3, 19 November 2007
Copyright (C) 2007 Free Software Foundation, Inc.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU Affero General Public License is a free, copyleft license for
software and other kinds of works, specifically designed to ensure
cooperation with the community in the case of network server software.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
our General Public Licenses are intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
Developers that use our General Public Licenses protect your rights
with two steps: (1) assert copyright on the software, and (2) offer
you this License which gives you legal permission to copy, distribute
and/or modify the software.
A secondary benefit of defending all users' freedom is that
improvements made in alternate versions of the program, if they
receive widespread use, become available for other developers to
incorporate. Many developers of free software are heartened and
encouraged by the resulting cooperation. However, in the case of
software used on network servers, this result may fail to come about.
The GNU General Public License permits making a modified version and
letting the public access it on a server without ever releasing its
source code to the public.
The GNU Affero General Public License is designed specifically to
ensure that, in such cases, the modified source code becomes available
to the community. It requires the operator of a network server to
provide the source code of the modified version running there to the
users of that server. Therefore, public use of a modified version, on
a publicly accessible server, gives the public access to the source
code of the modified version.
An older license, called the Affero General Public License and
published by Affero, was designed to accomplish similar goals. This is
a different license, not a version of the Affero GPL, but Affero has
released a new version of the Affero GPL which permits relicensing under
this license.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU Affero General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Remote Network Interaction; Use with the GNU General Public License.
Notwithstanding any other provision of this License, if you modify the
Program, your modified version must prominently offer all users
interacting with it remotely through a computer network (if your version
supports such interaction) an opportunity to receive the Corresponding
Source of your version by providing access to the Corresponding Source
from a network server at no charge, through some standard or customary
means of facilitating copying of software. This Corresponding Source
shall include the Corresponding Source for any work covered by version 3
of the GNU General Public License that is incorporated pursuant to the
following paragraph.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the work with which it is combined will remain governed by version
3 of the GNU General Public License.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU Affero General Public License from time to time. Such new versions
will be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU Affero General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU Affero General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU Affero General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
Copyright (C)
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see .
Also add information on how to contact you by electronic and paper mail.
If your software can interact with users remotely through a computer
network, you should also make sure that it provides a way for users to
get its source. For example, if your program is a web application, its
interface could display a "Source" link that leads users to an archive
of the code. There are many ways you could offer source, and different
solutions will be better for different programs; see section 13 for the
specific requirements.
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU AGPL, see
.
hopenpgp-tools-0.25.1/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 014403 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
hopenpgp-tools-0.25.1/hkt.hs 0000644 0000000 0000000 00000046640 07346545000 014102 0 ustar 00 0000000 0000000 -- hkt.hs: hOpenPGP key tool
-- Copyright © 2013-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- 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.KeySelection
( parseEightOctetKeyId
, parseFingerprint
)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Signatures
( verifyAgainstKeyring
, verifySigWith
, verifyUnknownTKWith
)
import Codec.Encryption.OpenPGP.Types
import Control.Applicative ((<|>), optional)
import Control.Arrow ((&&&))
import Control.Exception (ErrorCall, evaluate, try)
import Control.Lens ((^.), (^..), _1, _2)
import Control.Monad.Trans.Except (except, runExcept)
import Control.Monad.Trans.Resource (MonadResource, MonadThrow)
import qualified Data.Aeson as A
import Data.Binary (get, put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (ConduitM, (.|), runConduitRes)
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Filter
( FilterPredicates(RTKFilterPredicate)
, conduitTKFilter
)
import Data.Conduit.OpenPGP.Keyring
( conduitToTKsDropping
, sinkPublicKeyringMap
)
import Data.Conduit.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.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.SP (sp)
import Data.GraphViz (GraphvizParams(..), graphToDot, nonClusteredParams)
import Data.GraphViz.Attributes (toLabel)
import Data.GraphViz.Types (printDotGraph)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import Data.List (nub, sort)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TLIO
import Data.Void (Void)
import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)
import Data.Tuple (swap)
import qualified Data.Yaml as Y
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)
import Options.Applicative.Types (Parser)
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)
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)
where
matchAny 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
where
matchAny 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
where
unknownToPublicTK tk =
case fromUnknownToTK tk of
Right (SomePublicTK publicTk) -> Just publicTk
Right (SomeSecretTK secretTk) -> Just (publicViewTK secretTk)
Left _ -> Nothing
data Key =
Key
{ keysize :: Maybe Int
, keyalgo :: String
, keyalgoabbreviation :: String
, fpr :: String
}
deriving (Generic)
data TKey =
TKey
{ publickey :: Key
, uids :: [Text]
, subkeys :: [Key]
}
deriving (Generic)
instance A.ToJSON Key
instance A.ToJSON TKey
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)
}
where
mkey =
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
where
sizeabbrevkeyid 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
data Options =
Options
{ keyring :: String
, graphOutputFormat :: GraphOutputFormat
, pathsOutputFormat :: PathsOutputFormat
, targetIsFilter :: Bool
, target1 :: String
, target2 :: String
, target3 :: String
}
data Command
= CmdList Options
| CmdExportPubkeys Options
| CmdGraph Options
| CmdFindPaths Options
data GraphOutputFormat
= GraphViz
| LossyPretty
deriving (Bounded, Enum, Eq, Read, Show)
data PathsOutputFormat
= 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 ""
where
targetHelp =
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 ""
where
ofhelp =
helpDoc . Just $ pretty "output format" <> hardline <>
list (map (pretty . show) ofchoices)
ofchoices = [minBound .. maxBound] :: [GraphOutputFormat]
targetHelp =
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)
where
targetHelp =
helpDoc . Just $
pretty "target (which keys to use in pathfinding)*"
fromHelp =
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)*"
dispatch :: Command -> IO ()
dispatch (CmdList o) = banner' stderr >> hFlush stderr >> doList o
dispatch (CmdExportPubkeys 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
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))))
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)."
]
banner' :: Handle -> IO ()
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 ""
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
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)
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
where
nonClusteredLabeledNodesParams =
nonClusteredParams {fmtNode = \(_, l) -> [toLabel $ renderFingerprint l]}
buildMaps :: [TKUnknown] -> (KeyMaps, Int)
buildMaps =
foldr mapsInsertions (KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0)
-- FIXME: this presumes no keyID collisions in the input
data KeyMaps =
KeyMaps
{ _k2f :: HashMap EightOctetKeyId Fingerprint
, _f2i :: HashMap Fingerprint Int
, _i2f :: HashMap Int Fingerprint
}
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')
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))
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))
edgeFor target (ha, i) = do
source <- lookupSource i
pure (source, target, ha)
lookupSource i =
case HashMap.lookup i k2f >>= flip HashMap.lookup f2i of
Just source -> Right source
Nothing ->
Left ("hkt: no source node for signature issuer key ID " ++ show i)
lookupNode fp =
case HashMap.lookup fp f2i of
Just node -> Right node
Nothing ->
Left ("hkt: no graph node for fingerprint " ++ renderFingerprint fp)
fakejoin (x, y) = fmap ((,) x) y
sigs tk =
concat
((tk ^.. tkuUIDs . traverse . _2) ++ (tk ^.. tkuUAts . traverse . _2))
samesies (x, y, _) = x == y
data PaF =
PaF
{ certPaths :: [Path]
, keyFingerprints :: Map String Fingerprint
}
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
-- 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 ""
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)
parseFilterPredicateIO :: Text -> IO (Either String (FilterPredicates Void TKUnknown))
parseFilterPredicateIO e = do
parsed <-
try (evaluate (RTKFilterPredicate <$> parseTKExp (T.unpack e))) ::
IO (Either ErrorCall (Either String (FilterPredicates Void TKUnknown)))
pure $
case parsed of
Left err -> Left (show err)
Right result -> result
dieHKT :: String -> IO a
dieHKT msg = hPutStrLn stderr msg >> exitFailure
-- FIXME: deduplicate the following code
sigissuer :: SignaturePayload -> Maybe EightOctetKeyId
getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId
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
hopenpgp-tools-0.25.1/hokey.hs 0000644 0000000 0000000 00000006371 07346545000 014430 0 ustar 00 0000000 0000000 -- hokey.hs: hOpenPGP key tool
-- Copyright © 2013-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- 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 GADTs #-}
{-# LANGUAGE TypeApplications #-}
import HOpenPGP.Tools.Common.Common (banner, versioner, warranty)
import Options.Applicative.Builder
( command
, footerDoc
, headerDoc
, info
, prefs
, progDesc
, showHelpOnError
)
import Options.Applicative.Extra (customExecParser, helper, hsubparser)
import Options.Applicative.Types (Parser)
import System.IO
( BufferMode(..)
, Handle
, hFlush
, hSetBuffering
, stderr
)
import Prettyprinter (hardline)
import qualified Prettyprinter.Render.Terminal as PPA
import HOpenPGP.Tools.Hokey.Options
( FetchOptions
, InjectSSHAgentOptions
, LintOptions
, fetchO
, injectSSHAgentO
, lintO
)
import HOpenPGP.Tools.Hokey.Canonicalize (doCanonicalize)
import HOpenPGP.Tools.Hokey.Fetch (doFetch)
import HOpenPGP.Tools.Hokey.InjectSSHAgent (doInjectSSHAgent)
import HOpenPGP.Tools.Hokey.Lint (doLint)
data Command
= CmdLint LintOptions
| CmdCanonicalize
| CmdFetch FetchOptions
| CmdInjectSSHAgent InjectSSHAgentOptions
dispatch :: Command -> IO ()
dispatch (CmdFetch o) = banner' stderr >> hFlush stderr >> doFetch o
dispatch (CmdLint o) = banner' stderr >> hFlush stderr >> doLint o
dispatch CmdCanonicalize = banner' stderr >> hFlush stderr >> doCanonicalize
dispatch (CmdInjectSSHAgent o) =
banner' stderr >> hFlush stderr >> doInjectSSHAgent o
main :: IO ()
main = do
hSetBuffering stderr LineBuffering
customExecParser
(prefs showHelpOnError)
(info
(helper <*> versioner "hokey" <*> cmd)
(headerDoc (Just (banner "hokey")) <>
progDesc "hOpenPGP Key utility" <>
footerDoc (Just (warranty "hokey")))) >>=
dispatch
cmd :: Parser Command
cmd =
hsubparser
(command
"canonicalize"
(info
(pure CmdCanonicalize)
(progDesc "arrange key components in a canonical ordering")) <>
command
"fetch"
(info
(CmdFetch <$> fetchO)
(progDesc "fetch key(s) via HKP or WKD")) <>
command
"inject-ssh-agent"
(info
(CmdInjectSSHAgent <$> injectSSHAgentO)
(progDesc "Read exported secret key bytes, pick an auth-capable subkey, and add it to ssh-agent")) <>
command
"lint"
(info (CmdLint <$> lintO) (progDesc "check key(s) for 'best practices'")))
banner' :: Handle -> IO ()
banner' h =
PPA.hPutDoc h (banner "hokey" <> hardline <> warranty "hokey" <> hardline)
hopenpgp-tools-0.25.1/hop.hs 0000644 0000000 0000000 00000572552 07346545000 014110 0 ustar 00 0000000 0000000 -- hop.hs: hOpenPGP-stateless OpenPGP (sop) tool
-- Copyright © 2019-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- 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"
hopenpgp-tools-0.25.1/hopenpgp-tools.cabal 0000644 0000000 0000000 00000011276 07346545000 016717 0 ustar 00 0000000 0000000 cabal-version: 3.0
name: hopenpgp-tools
version: 0.25.1
synopsis: hOpenPGP-based command-line tools
description: command-line tools for performing some OpenPGP-related operations
homepage: https://salsa.debian.org/clint/hOpenPGP-tools
license: AGPL-3.0-or-later
license-file: LICENSE
author: Clint Adams
maintainer: Clint Adams
copyright: 2012-2026 Clint Adams
category: Codec, Data
build-type: Simple
flag use-memory
description: Use the 'memory' package instead of 'ram'
default: False
common deps
autogen-modules: Paths_hopenpgp_tools
build-depends: base >= 4.15 && < 5
, aeson
, binary >= 0.6.4
, binary-conduit
, bytestring
, conduit >= 1.3
, errors
, hOpenPGP >= 3.0.2 && < 3.1
, lens
, optparse-applicative >= 0.18.1
, prettyprinter >= 1.7
, text
, transformers >= 0.4
, yaml
ghc-options: -Wall
other-modules: HOpenPGP.Tools.Common.Common
, Paths_hopenpgp_tools
executable hot
import: deps
main-is: hot.hs
autogen-modules: Paths_hopenpgp_tools
other-modules: HOpenPGP.Tools.Common.Armor
, HOpenPGP.Tools.Common.Lexer
, HOpenPGP.Tools.Common.Parser
build-depends: array
, conduit-extra >= 1.1
, monad-loops
, openpgp-asciiarmor >= 1
build-tool-depends: alex:alex, happy:happy
default-language: Haskell2010
executable hokey
import: deps
main-is: hokey.hs
other-modules: HOpenPGP.Tools.Common.HKP
, HOpenPGP.Tools.Common.TKUtils
, HOpenPGP.Tools.Common.WKD
, HOpenPGP.Tools.Hokey.Options
, HOpenPGP.Tools.Hokey.Canonicalize
, HOpenPGP.Tools.Hokey.Fetch
, HOpenPGP.Tools.Hokey.InjectSSHAgent
, HOpenPGP.Tools.Hokey.Lint
build-depends: base16-bytestring
, conduit-extra >= 1.1
, containers
, http-client >= 0.4.30
, http-client-tls
, http-types
, network
, openpgp-asciiarmor >= 1
, prettyprinter-ansi-terminal >= 1.1.2
, time
, time-locale-compat
if flag(use-memory)
build-depends: crypton < 1.1, memory
else
build-depends: crypton >= 1.1, ram
default-language: Haskell2010
executable hkt
import: deps
main-is: hkt.hs
other-modules: HOpenPGP.Tools.Common.Lexer
, HOpenPGP.Tools.Common.Parser
build-depends: array
, containers
, conduit-extra >= 1.1
, directory
, fgl >= 5.5.4
, graphviz
, ixset-typed
, monad-loops
, resourcet
, time
, unordered-containers
build-tool-depends: alex:alex, happy:happy
default-language: Haskell2010
executable hop
import: deps
main-is: hop.hs
other-modules: HOpenPGP.Tools.Common.Armor
, HOpenPGP.Tools.Common.Lexer
, HOpenPGP.Tools.Common.Parser
, HOpenPGP.Tools.Common.TKUtils
build-depends: array
, conduit-extra >= 1.1
, containers
, crypton
, directory
, monad-loops
, mtl
, openpgp-asciiarmor >= 1
, resourcet
, time
, vector
if flag(use-memory)
build-depends: memory
else
build-depends: ram
build-tool-depends: alex:alex, happy:happy
default-language: Haskell2010
source-repository head
type: git
location: https://salsa.debian.org/clint/hopenpgp-tools.git
source-repository this
type: git
location: https://salsa.debian.org/clint/hopenpgp-tools.git
tag: hopenpgp-tools/0.25.1
hopenpgp-tools-0.25.1/hot.hs 0000644 0000000 0000000 00000017041 07346545000 014077 0 ustar 00 0000000 0000000 -- hot.hs: hOpenPGP Tool
-- Copyright © 2012-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- 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.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Control.Applicative (optional)
import Control.Error.Util (note)
import Control.Exception (ErrorCall, evaluate, try)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Reader (Reader)
import qualified Data.Aeson as A
import Data.Binary (get, put)
import Data.Binary.Get (Get)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
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
)
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)
import Options.Applicative.Types (Parser)
data Command
= DumpC DumpOptions
| DeArmorC
| ArmorC ArmoringOptions
| FilterC FilteringOptions
data DumpOptions =
DumpOptions
{ outputformat :: DumpOutputFormat
}
data FilteringOptions =
FilteringOptions
{ fExpression :: String
}
data DumpOutputFormat
= 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
-- Print every input value to standard output.
printer :: (Show a, MonadIO m) => ConduitM a Void m ()
printer = CL.mapM_ (liftIO . print)
prettyPrinter :: (Pretty a, MonadIO m) => ConduitM a Void m ()
prettyPrinter =
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 = 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
doP :: Parser DumpOptions
doP =
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)
ofchoices = [minBound .. maxBound] :: [DumpOutputFormat]
foP :: Parser FilteringOptions
foP =
FilteringOptions <$> argument str (metavar "EXPRESSION" <> filterTargetHelp)
where
filterTargetHelp =
helpDoc . Just $
pretty "packet filter expression" <+>
softline <> pretty "see source for current syntax"
dispatch :: Command -> IO ()
dispatch c = (banner' stderr >> hFlush stderr) >> dispatch' c
where
dispatch' (DumpC o) = doDump o
dispatch' DeArmorC = doDeArmor
dispatch' (ArmorC o) = doArmor o
dispatch' (FilterC o) = doFilter o
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
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")))
banner' :: Handle -> IO ()
banner' h = hPutDoc h (banner "hot" <> hardline <> warranty "hot" <> hardline)
parseExpressions :: FilteringOptions -> IO (Either String (FilterPredicates r a))
parseExpressions FilteringOptions {..} = do
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
armorTypes :: [(String, ArmorType)]
armorTypes =
[ ("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)
where
armortypeHelp =
helpDoc . Just $
pretty "ASCII armor type" <>
softline <> list (map (pretty . fst) armorTypes)
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]
dieHot :: String -> IO a
dieHot msg = hPutStrLn stderr msg >> exitFailure