hopenpgp-tools-0.25.5/ 0000755 0000000 0000000 00000000000 07346545000 012752 5 ustar 00 0000000 0000000 hopenpgp-tools-0.25.5/HOpenPGP/Tools/Common/ 0000755 0000000 0000000 00000000000 07346545000 016662 5 ustar 00 0000000 0000000 hopenpgp-tools-0.25.5/HOpenPGP/Tools/Common/Armor.hs 0000644 0000000 0000000 00000003271 07346545000 020301 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.Lazy as BL
import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import System.IO (stdin)
doDeArmor :: IO ()
doDeArmor = do
a <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
let lbs = BL.fromChunks a
case BL.uncons lbs of
Just (firstByte, _)
| firstByte >= 0x80 -> BL.putStr lbs
| otherwise ->
case (AA.decode (BL.toStrict lbs) :: Either String [Armor]) of
Right msgs -> BL.putStr $ BL.concat [bs | Armor _ _ bs <- msgs]
Left _ -> BL.putStr lbs
Nothing -> pure ()
hopenpgp-tools-0.25.5/HOpenPGP/Tools/Common/Common.hs 0000644 0000000 0000000 00000020134 07346545000 020446 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
, primaryPKP
) where
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Codec.Encryption.OpenPGP.SignatureQualities (sigCT)
import Codec.Encryption.OpenPGP.Types
import Control.Error.Util (hush)
import Control.Monad.Trans.Reader
( Reader
, ReaderT
, ask
, local
, reader
, runReader
, withReader
)
import Data.Binary (put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString.Lazy as BL
-- hmm --
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Version (showVersion)
import Options.Applicative.Builder
( auto
, help
, hidden
, infoOption
, long
, short
)
import Options.Applicative.Types (Parser, ReadM (..))
import Prettyprinter
( Doc
, defaultLayoutOptions
, hardline
, layoutPretty
, pretty
, (<+>)
)
import qualified Prettyprinter.Render.Text as PPA
import Paths_hopenpgp_tools (version)
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 -> SomeTK -> Fingerprint -> Bool
keyMatchesFingerprint = keyMatchesPKPred fingerprint
keyMatchesEightOctetKeyId
:: Bool -> SomeTK -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow
keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID
keyMatchesExactUIDString :: Text -> SomeTK -> Bool
keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkUIDs . someTKToPublicViewTK
keyMatchesUIDSubString :: Text -> SomeTK -> Bool
keyMatchesUIDSubString uidstr stk =
any (T.toLower uidstr `T.isInfixOf`)
. map (T.toLower . fst)
. _tkUIDs $
someTKToPublicViewTK stk
keyMatchesPKPred
:: Eq a => (SomePKPayload -> a) -> Bool -> SomeTK -> a -> Bool
keyMatchesPKPred p False = (==) . p . primaryPKP
keyMatchesPKPred p True = \stk v -> elem v (p (primaryPKP stk) : map p (tkGetSubs stk))
primaryPKP :: SomeTK -> SomePKPayload
primaryPKP = keyPktPKPayload . _tkPrimaryKey . someTKToPublicViewTK
-- The following should probably be moved elsewhere
tkUsingPKP :: Reader SomePKPayload a -> Reader SomeTK a
tkUsingPKP = withReader primaryPKP
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 :: SomeTK -> [Text]
tkGetUIDs = map fst . _tkUIDs . someTKToPublicViewTK
tkGetSubs :: SomeTK -> [SomePKPayload]
tkGetSubs stk = mapMaybe (grabPKP . fst) (_tkSubs (someTKToPublicViewTK stk))
where
grabPKP kp = Just (keyPktPKPayload kp)
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)
where
-- FIXME: deduplicate this and hOpenPGP .Internal
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.5/HOpenPGP/Tools/Common/HKP.hs 0000644 0000000 0000000 00000011302 07346545000 017635 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 (..)
, Fingerprint
, SomePKPayload (..)
, SomeTK (..)
, TK (..)
, keyPktPKPayload
, someTKToPublicViewTK
, someTKToUnknown
)
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
( conduitDropErrorsAndNothings
, conduitToSomeTKsDroppingEither
)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Data.Lens (biplate)
import Data.Either (rights)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Network.HTTP.Client
( Response (..)
, httpLbs
, newManager
, parseUrlThrow
, setQueryString
)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (ok200)
import Prettyprinter (pretty)
import HOpenPGP.Tools.Common.TKUtils (processTK)
primaryPKP :: SomeTK -> SomePKPayload
primaryPKP = keyPktPKPayload . _tkPrimaryKey . someTKToPublicViewTK
data FetchValidationMethod
= MatchPrimaryKeyFingerprint
| MatchPrimaryOrAnySubkeyFingerprint
| AnySelfSigned
deriving (Bounded, Enum, Eq, Read, Show)
fetchKeys
:: String
-> FetchValidationMethod
-> Fingerprint
-> ExceptT String IO [SomeTK]
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 . primaryPKP . snd) processedKeys
where
fvp MatchPrimaryKeyFingerprint k = fingerprint k == q
fvp MatchPrimaryOrAnySubkeyFingerprint k' =
any (\k'' -> fingerprint k'' == q) (k' ^.. biplate)
fvp AnySelfSigned _ = True
basereq = "/pks/lookup"
newqs q' =
[ ("op", Just "get")
, ("options", Just "mr")
, ("exact", Just "on")
, ("search", Just (BC8.pack ("0x" <> show (pretty q')))) -- FIXME: butter
]
validateKeys
:: BL.ByteString -> ExceptT String IO [(SomeTK, SomeTK)] -- FIXME: conduit fail
validateKeys larmors = do
bytestrings <-
ExceptT $
return $
fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
keys <-
liftIO . runConduitRes $
CB.sourceLbs bytestrings
.| conduitGet get
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| CL.consume
cpt <- liftIO getPOSIXTime
return . rights $
map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
where
armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs
armorToBS _ = mempty
rearmorKeys :: [SomeTK] -> B.ByteString
rearmorKeys stks =
if null stks
then mempty
else
AA.encode
. return
. Armor ArmorPublicKeyBlock [("Comment", "filtered by hokey")]
. runPut
. put
. Block
$ map someTKToUnknown stks
hopenpgp-tools-0.25.5/HOpenPGP/Tools/Common/Lexer.x 0000644 0000000 0000000 00000010767 07346545000 020145 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.5/HOpenPGP/Tools/Common/Parser.y 0000644 0000000 0000000 00000020144 07346545000 020311 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 SomeTK Bool)
parseTKExp s = runAlex s parseTK
parsePExp :: String -> Either String (Reader Pkt Bool)
parsePExp s = runAlex s parseP
}
hopenpgp-tools-0.25.5/HOpenPGP/Tools/Common/TKUtils.hs 0000644 0000000 0000000 00000011274 07346545000 020562 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
, verifyTKWithTyped
) where
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.Policy
( VerificationPolicy
, defaultVerificationPolicy
)
import Codec.Encryption.OpenPGP.Signatures
( renderVerificationError
, verifyAgainstKeys
, verifySigWith
, verifyTKWith
)
import Codec.Encryption.OpenPGP.Types
import Control.Arrow (second)
import Control.Error.Util (hush)
import Data.Bifunctor (first)
import Data.List (sortOn)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Ord (Down (..))
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
verifyTKWithTyped
:: VerificationPolicy
-> [SomeTK]
-> Maybe UTCTime
-> SomeTK
-> Either String SomeTK
verifyTKWithTyped policy keyring mt stk = do
verifiedStk <- case stk of
SomePublicTK publicTk ->
first
renderVerificationError
(SomePublicTK <$> verifyTKWith vsf mt publicTk)
SomeSecretTK secretTk ->
first
renderVerificationError
(SomeSecretTK <$> verifyTKWith vsf mt secretTk)
pure verifiedStk
where
vsf =
verifySigWith
policy
(verifyAgainstKeys (map someTKToPublicViewTK keyring))
processTK
:: Maybe POSIXTime -> SomeTK -> Either String SomeTK
processTK mpt stk =
verifyTKWithTyped
defaultVerificationPolicy
[stk]
(fmap posixSecondsToUTCTime mpt)
strippedStk
where
strippedStk = stripOlderSigs (stripOtherSigs stk)
stripOtherSigs (SomePublicTK tk) = SomePublicTK (stripOtherSigsTK tk)
stripOtherSigs (SomeSecretTK tk) = SomeSecretTK (stripOtherSigsTK tk)
stripOlderSigs (SomePublicTK tk) = SomePublicTK (stripOlderSigsTK tk)
stripOlderSigs (SomeSecretTK tk) = SomeSecretTK (stripOlderSigsTK tk)
stripOtherSigsTK tk =
tk
{ _tkUIDs = map (second alleged) (_tkUIDs tk)
, _tkUAts = map (second alleged) (_tkUAts tk)
}
stripOlderSigsTK tk =
tk
{ _tkUIDs = map (second newest) (_tkUIDs tk)
, _tkUAts = map (second newest) (_tkUAts tk)
}
newest = take 1 . sortOn (Down . take 1 . sigcts)
sigcts (SigV4 _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs
sigcts (SigV6 _ _ _ _ xs _ _ _) = mapMaybe sigCreationTimeFromSubpacket xs
sigcts _ = []
pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))
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)
sigissuer (SigV6 _ _ _ _ ys xs _ _) =
listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys ++ xs)
sigissuer _ = Nothing
sigissuerfp (SigV4 _ _ _ ys xs _ _) =
listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs)
sigissuerfp (SigV6 _ _ _ _ ys xs _ _) =
listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys ++ xs)
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.5/HOpenPGP/Tools/Common/WKD.hs 0000644 0000000 0000000 00000016652 07346545000 017655 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
( SomeTK (..)
, someTKToPublicViewTK
, _tkUIDs
)
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 Data.Bits (shiftL, shiftR, (.&.), (.|.))
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Keyring
( conduitDropErrorsAndNothings
, conduitToSomeTKsDroppingEither
)
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 Network.HTTP.Client
( Manager
, Response (..)
, httpLbs
, newManager
, parseUrlThrow
, setQueryString
)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (ok200)
import HOpenPGP.Tools.Common.HKP (FetchValidationMethod (..))
import HOpenPGP.Tools.Common.TKUtils (processTK)
fetchKeys
:: FetchValidationMethod
-> Text
-> ExceptT String IO [SomeTK]
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 [SomeTK]
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 [SomeTK]
decodeWkdResponse body =
if isArmored body
then decodeArmored body
else decodeBinary body
decodeBinary :: BL.ByteString -> ExceptT String IO [SomeTK]
decodeBinary bytes =
liftIO . runConduitRes $
CB.sourceLbs bytes
.| conduitGet get
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| CL.consume
decodeArmored :: BL.ByteString -> ExceptT String IO [SomeTK]
decodeArmored larmors = do
bytestrings <-
ExceptT . return $
fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
liftIO . runConduitRes $
CB.sourceLbs bytestrings
.| conduitGet get
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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) -> SomeTK -> Bool
mailboxMatchesKey (localPart, domain) stk =
let mailbox = T.toLower (localPart <> "@" <> domain)
bracketedMailbox = "<" <> mailbox <> ">"
uids = map fst (_tkUIDs (someTKToPublicViewTK stk))
in any
( \uid ->
let lowered = T.toLower uid
in lowered == mailbox || bracketedMailbox `T.isInfixOf` lowered
)
uids
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.5/HOpenPGP/Tools/Hokey/ 0000755 0000000 0000000 00000000000 07346545000 016511 5 ustar 00 0000000 0000000 hopenpgp-tools-0.25.5/HOpenPGP/Tools/Hokey/Canonicalize.hs 0000644 0000000 0000000 00000004550 07346545000 021450 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
( SomeTK (..)
, someTKToUnknown
, _tkRevs
, _tkSubs
, _tkUAts
, _tkUIDs
)
import Control.Lens (mapped, over, _2)
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
( conduitDropErrorsAndNothings
, conduitToSomeTKsDroppingEither
)
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
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| CL.map canonicalize
.| CL.map someTKToUnknown
.| CL.map put
.| conduitPut
.| CB.sinkHandle stdout
where
canonicalize (SomePublicTK tk) = SomePublicTK (canonicalizeTK tk)
canonicalize (SomeSecretTK tk) = SomeSecretTK (canonicalizeTK tk)
canonicalizeTK tk =
tk
{ _tkRevs = sort (_tkRevs tk)
, _tkUIDs = indepthsort (_tkUIDs tk)
, _tkUAts = indepthsort (_tkUAts tk)
, _tkSubs = indepthsort (_tkSubs tk)
}
indepthsort :: (Ord a, Ord b) => [(a, [b])] -> [(a, [b])]
indepthsort = nub . sort . over (mapped . _2) sort
hopenpgp-tools-0.25.5/HOpenPGP/Tools/Hokey/Fetch.hs 0000644 0000000 0000000 00000003563 07346545000 020105 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 System.IO
( hPutStrLn
, stderr
)
import HOpenPGP.Tools.Common.HKP (rearmorKeys)
import qualified HOpenPGP.Tools.Common.HKP as HKP
import qualified HOpenPGP.Tools.Common.WKD as WKD
import HOpenPGP.Tools.Hokey.Options
( FetchMethod (..)
, FetchOptions (..)
)
doFetch :: FetchOptions -> IO ()
doFetch o = do
ekeys <-
runExceptT $
case fetchMethod o of
HKP -> do
fp <- ExceptT . return . parseFingerprint . T.pack $ fetchQuery o
HKP.fetchKeys (keyServer o) (fetchValidation o) fp
WKD -> WKD.fetchKeys (fetchValidation o) (T.pack (fetchQuery o))
case ekeys of
Left e -> hPutStrLn stderr $ "error fetching keys: " ++ e
Right ks -> B.putStr $ rearmorKeys ks
hopenpgp-tools-0.25.5/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs 0000644 0000000 0000000 00000040552 07346545000 021624 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
, conduitToSomeTKsDroppingEither
)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Foldable (find)
import Data.List (intercalate, sortOn)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Ord (Down (..))
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock.POSIX
( POSIXTime
, getPOSIXTime
, posixSecondsToUTCTime
)
import Network.Socket
( Family (AF_UNIX)
, SockAddr (..)
, Socket
, SocketType (Stream)
, close
, connect
, defaultProtocol
, socket
)
import qualified Network.Socket.ByteString as NSB
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
import System.IO
( hPutStrLn
, stderr
, stdin
)
import HOpenPGP.Tools.Common.Common (renderFingerprint)
import HOpenPGP.Tools.Hokey.Options (InjectSSHAgentOptions (..))
doInjectSSHAgent :: InjectSSHAgentOptions -> IO ()
doInjectSSHAgent opts = do
socketPath <-
resolveSSHAgentSocketPath (injectSSHAgentSocket opts)
input <- readInjectedSecretKeyMaterial opts
cpt <- getPOSIXTime
authCandidates <-
runConduitRes $
CL.sourceList (BL.toChunks input)
.| conduitGet get
.| conduitToSomeTKsDroppingEither
.| CL.mapMaybe (either (const Nothing) (>>= someTKToSecretTK))
.| conduitToAuthSecretSubkeysAt (posixSecondsToUTCTime cpt)
.| CL.consume
injectableCandidates <-
if null authCandidates
then inferInjectableAuthSubkeys cpt input
else pure (map candidateFromAuthSecretSubkey authCandidates)
whenEmpty
injectableCandidates
"inject-ssh-agent: no authentication-capable secret subkey found"
selectedRequests <-
selectInjectableAuthSubkeys
(injectSSHAgentComment opts)
injectableCandidates
mapM_
( \(selected, request) -> do
sendAddIdentityToSSHAgent socketPath request
hPutStrLn stderr $
"inject-ssh-agent: added authentication subkey "
++ renderFingerprint
(fingerprint (injectableAuthSubkeyPKP selected))
++ " to ssh-agent"
)
selectedRequests
candidateFromAuthSecretSubkey
:: AuthSecretSubkeyAtTime -> InjectableAuthSubkey
candidateFromAuthSecretSubkey 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
.| conduitToSomeTKsDroppingEither
.| CL.mapMaybe (either (const Nothing) (>>= someTKToSecretTK))
.| CL.consume
pure (concatMap inferFromTK tks)
where
inferFromTK tk =
let mPrimaryUID = fst <$> listToMaybe (_tkUIDs tk)
in mapMaybe (inferFromSubkey mPrimaryUID) (_tkSubs tk)
inferFromSubkey
:: Maybe Text
-> (KeyPkt k, [SignaturePayload])
-> Maybe InjectableAuthSubkey
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 EdSigningCurve25519 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 EdSigningCurve448 _) _ ->
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 EdSigningCurve25519 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.5/HOpenPGP/Tools/Hokey/Lint.hs 0000644 0000000 0000000 00000104176 07346545000 017764 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 LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module HOpenPGP.Tools.Hokey.Lint
( doLint
) where
import Codec.Encryption.OpenPGP.Expirations
( getKeyExpirationTimesFromSignature
)
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.KeyInfo
( pkalgoAbbrev
, pubkeySize
)
import Codec.Encryption.OpenPGP.Ontology
( isCT
, isCertRevocationSig
, isKUF
, isPHA
, isPKBindingSig
, isSKBindingSig
)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Control.Arrow ((***))
import Control.Error.Util (hush)
import Control.Lens ((&))
import Control.Monad (void)
import Control.Monad.Trans.Writer.Lazy (execWriter, tell)
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
import qualified Data.Aeson as A
import Data.Binary (get)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Keyring
( conduitDropErrorsAndNothings
, conduitToSomeTKsDroppingEither
)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Foldable (find, maximumBy, sequenceA_, traverse_)
import Data.List (elemIndex, findIndex, intercalate, nub, sortOn)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord (comparing)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock.POSIX
( POSIXTime
, getPOSIXTime
, posixSecondsToUTCTime
)
import Data.Time.Format (formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import qualified Data.Yaml as Y
import GHC.Generics
import Prettyprinter
( Doc
, annotate
, colon
, flatAlt
, indent
, line
, list
, pretty
, vsep
, (<+>)
)
import qualified Prettyprinter.Render.Terminal as PPA
import System.IO
( stdin
)
import HOpenPGP.Tools.Common.Common
( renderFingerprint
, renderKeyID
)
import HOpenPGP.Tools.Common.TKUtils (processTK)
import HOpenPGP.Tools.Hokey.Options
( LintOptions (..)
, LintOutputFormat (..)
)
linebreak :: Doc ann
linebreak = flatAlt line mempty
green, yellow, red :: Doc PPA.AnsiStyle -> Doc PPA.AnsiStyle
green = annotate (PPA.color PPA.Green)
yellow = annotate (PPA.color PPA.Yellow)
red = annotate (PPA.color PPA.Red)
data KAS
= KAS
{ pubkeyalgo :: Result PubKeyAlgorithm
, pubkeysize :: Result (Maybe Int)
, stringrep :: String
}
deriving (Generic)
data Color
= Green
| Yellow
| Red
deriving (Eq, Generic, Ord)
data Result a = Result
{ resultColor :: Maybe Color
, resultFindings :: Maybe [String]
, resultValue :: a
}
deriving (Functor, Generic)
instance Applicative Result where
pure x = Result Nothing Nothing x
(Result c1 e1 f) <*> (Result c2 e2 x) =
Result (max c1 c2) (e1 <> e2) (f x)
instance Monad Result where
(Result c1 e1 x) >>= f =
let Result c2 e2 y = f x
in Result (max c1 c2) (e1 <> e2) y
colored :: Maybe Color -> Maybe [String] -> a -> Result a
colored c e x = Result c e x
withColor :: Maybe Color -> a -> Result a
withColor c x = Result c Nothing x
getResult :: Result a -> a
getResult (Result _ _ x) = x
newtype LintPolicy src a
= LintPolicy
{ unPolicy :: src -> Maybe POSIXTime -> Result a
}
deriving (Functor, Generic)
instance Applicative (LintPolicy src) where
pure x = LintPolicy (\_ _ -> pure x)
(LintPolicy f) <*> (LintPolicy x) = LintPolicy (\src mpt -> f src mpt <*> x src mpt)
data KeyReport
= KeyReport
{ keyStatus :: Result String
, keyFingerprint :: Result Fingerprint
, keyVer :: Result KeyVersion
, keyCreationTime :: Result ThirtyTwoBitTimeStamp
, keyAlgorithmAndSize :: Result KAS
, keyUIDsAndUAts :: Map.Map Text (Result UIDReport)
, keyBestOf :: Maybe UIDReport
, keySubkeys :: [Result SubkeyReport]
, keyHasEncryptionCapableSubkey :: Result Bool
}
deriving (Generic)
data UIDReport
= UIDReport
{ uidSelfSigHashAlgorithms :: [Result HashAlgorithm]
, uidPreferredHashAlgorithms :: [Result [HashAlgorithm]]
, uidKeyExpirationTimes :: [Result [ThirtyTwoBitDuration]]
, uidKeyUsageFlags :: [Result (Set.Set KeyFlag)]
, uidRevocationStatus :: [RevocationStatus]
}
deriving (Generic)
data SubkeyReport
= SubkeyReport
{ skFingerprint :: Result Fingerprint
, skVer :: Result KeyVersion
, skCreationTime :: ThirtyTwoBitTimeStamp
, skAlgorithmAndSize :: Result KAS
, skBindingSigHashAlgorithms :: [Result HashAlgorithm]
, skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning]
, skUsageFlags :: [Result (Set.Set KeyFlag)]
, skCrossCerts :: CrossCertReport
}
deriving (Generic)
data SubkeyRevocationDigestWarning
= SubkeyRevocationDigestWarning
{ srwHashAlgorithm :: HashAlgorithm
, srwSubkeyFingerprint :: String
, srwSubkeyKeyID :: Maybe String
, srwMessage :: String
}
deriving (Generic)
data CrossCertReport
= CrossCertReport
{ ccPresent :: Result Bool
, ccHashAlgorithms :: [Result HashAlgorithm]
}
deriving (Generic)
data RevocationStatus
= RevocationStatus
{ isRevoked :: Bool
, revocationCode :: String
, revocationReason :: Text
}
deriving (Generic)
instance A.ToJSON KAS
instance A.ToJSON Color
instance (A.ToJSON a) => A.ToJSON (Result a)
instance A.ToJSON KeyReport
instance A.ToJSON UIDReport
instance A.ToJSON SubkeyReport
instance A.ToJSON SubkeyRevocationDigestWarning
instance A.ToJSON CrossCertReport
instance A.ToJSON RevocationStatus
instance Semigroup UIDReport where
(<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') =
UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e')
instance Monoid UIDReport where
mempty = UIDReport [] [] [] [] []
mappend = (<>)
checkKey :: LintPolicy SomeTK KeyReport
checkKey = LintPolicy $ \tk mpt -> checkKey' mpt tk
checkKey' :: Maybe POSIXTime -> SomeTK -> Result KeyReport
checkKey' mpt stk =
kr
<$ sequenceA_
[ void (keyStatus kr)
, void (keyFingerprint kr)
, void (keyVer kr)
, void (keyAlgorithmAndSize kr)
, void (keyHasEncryptionCapableSubkey kr)
, traverse_ void (keySubkeys kr)
, traverse_ void (keyUIDsAndUAts kr)
]
where
procResult = processTK mpt stk
processedTK = either (const stk) id procResult
publicView = someTKToPublicViewTK processedTK
primaryKey = keyPktPKPayload (_tkPrimaryKey publicView)
kr =
KeyReport
{ keyStatus = pure (either id (const "good") procResult)
, keyFingerprint = pure (fingerprint primaryKey)
, keyVer = colorizeKV (_keyVersion primaryKey)
, keyCreationTime = pure (_timestamp primaryKey)
, keyAlgorithmAndSize = kasIt primaryKey
, keyUIDsAndUAts = uidMap
, keyBestOf = populateBestOf uidMap
, keySubkeys = subkeys
, keyHasEncryptionCapableSubkey =
hasEncryptionCapableSubkey
(concatMap (skUsageFlags . getResult) subkeys)
}
uidMap =
Map.fromListWith (liftA2 (<>)) $
map
(\(x, y) -> (x, uidr (Just x) y))
(_tkUIDs publicView)
++ map
(uatspsToText *** uidr Nothing)
(_tkUAts publicView)
subkeys = map (checkSK (fingerprint primaryKey)) (_tkSubs publicView)
uidr :: Maybe Text -> [SignaturePayload] -> Result UIDReport
uidr Nothing sps =
UIDReport
<$> pure (has sps)
<*> pure (map phas sps)
<*> pure
( map
( colorizeKETs
(fromMaybe 0 mpt)
(unThirtyTwoBitTimeStamp (_timestamp primaryKey))
. getKeyExpirationTimesFromSignature
)
sps -- should that be 0?
)
<*> pure (kufs False sps)
<*> pure (findRevocationReason sps)
uidr (Just u) sps =
colorizeUID
u
( UIDReport
(has sps)
(map phas sps)
( map
( colorizeKETs
(fromMaybe 0 mpt)
(unThirtyTwoBitTimeStamp (_timestamp primaryKey))
. getKeyExpirationTimesFromSignature
)
sps -- should that be 0?
)
(kufs False sps)
(findRevocationReason sps)
)
kasIt :: SomePKPayload -> Result KAS
kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize)
kasIt' :: PubKeyAlgorithm -> Either String Int -> Result KAS
kasIt' pka epks =
let pr = colorizePKA pka
prs = colorizePKS pka epks
strRep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka)
in colored
(max (resultColor pr) (resultColor prs))
(resultFindings pr <> resultFindings prs)
(KAS pr prs strRep)
colorizeKV :: KeyVersion -> Result KeyVersion
colorizeKV kv
| kv `elem` [V4, V6] = withColor (Just Green) kv
| otherwise =
colored (Just Red) (Just ["not a V4 or V6 key"]) kv
colorizePKA :: PubKeyAlgorithm -> Result PubKeyAlgorithm
colorizePKA pka
| pka `elem` [RSA, EdDSA, ECDH, X25519, X448] -- FIXME: incomplete
=
colored (Just Green) Nothing pka
| otherwise =
colored
(Just Yellow)
(Just ["public key algorithm neither RSA nor EdDSA"])
pka
colorizePKS
:: PubKeyAlgorithm -> Either String Int -> Result (Maybe Int)
colorizePKS pka (Right pks)
-- Group 256-bit ECC curves
| pka `elem` [X25519, ECDH, EdDSA] && pks >= 256 -- FIXME: incomplete
=
withColor (Just Green) (Just pks)
-- Group 448-bit ECC curves
| pka `elem` [X448] && pks >= 448 -- FIXME: incomplete
=
withColor (Just Green) (Just pks)
-- Catch-all for undersized ECC curves
| pka `elem` [X25519, X448, ECDH, EdDSA] -- FIXME: incomplete
=
colored
(Just Yellow)
(Just ["Public key size insufficient for ECC algorithm"])
(Just pks)
-- RSA size checks
| pka == RSA && pks >= 3072 =
withColor (Just Green) (Just pks)
| pka == RSA && pks >= 2048 =
colored
(Just Yellow)
(Just ["Public key size between 2048 and 3072 bits"])
(Just pks)
| pka == RSA =
colored
(Just Red)
(Just ["Public key size under 2048 bits"])
(Just pks)
-- Fallback for unknown algorithms but known sizes
| otherwise =
pure (Just pks)
colorizePKS _ (Left _) =
colored
(Just Red)
(Just ["public key algorithm not understood"])
Nothing
colorizePHAs :: [HashAlgorithm] -> Result [HashAlgorithm]
colorizePHAs x
| preferredWeakHash x =
colored (Just Red) (Just ["weak hash with higher preference"]) x
| otherwise = withColor (Just Green) x
fSHA2or3Family =
fi (`elem` [SHA512, SHA384, SHA256, SHA224, SHA3_512, SHA3_256])
firstStrongSHA2or3 xs = fSHA2or3Family xs
preferredWeakHash xs =
any
( \ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2or3 xs
)
knownWeakHashAlgorithms
fi x y = fromMaybe maxBound (findIndex x y)
colorizeKETs ct ts kes
| null kes = colored (Just Red) (Just ["no expiration set"]) kes
| any (\ke -> realToFrac ts + realToFrac ke < ct) kes =
colored (Just Red) (Just ["expiration passed"]) kes
| any
(\ke -> realToFrac ts + realToFrac ke > ct + (5 * 31557600))
kes =
colored (Just Yellow) (Just ["expiration too far in future"]) kes
| otherwise = colored (Just Green) Nothing kes
eoki pkp
| _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
| _keyVersion pkp == DeprecatedV3
&& elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
hush . eightOctetKeyID $ pkp
| otherwise = Nothing
phas sig =
colorizePHAs
( concatMap
( \case
SigSubPacket _ (PreferredHashAlgorithms x) -> x
_ -> []
)
(filter isPHA (hasheds sig))
)
has = map (colorizeHA . hashAlgo) . alleged
colorizeHA :: HashAlgorithm -> Result HashAlgorithm
colorizeHA ha
| isKnownWeakHashAlgorithm ha =
colored (Just Red) (Just ["weak hash algorithm"]) ha
| otherwise = pure ha
sigcts sig =
map
( \case
SigSubPacket _ (SigCreationTime x) -> x
_ -> error "unexpected subpacket type"
)
(filter isCT (hasheds sig))
alleged =
filter
( \sig ->
primaryFingerprint `elem` sigissuerFPs sig
|| ((==) <$> sigissuer sig <*> eoki primaryKey)
== Just True
)
where
primaryFingerprint = fingerprint primaryKey
uatspsToText = T.pack . uatspsToString
uatspsToString us =
""
uaspToString (ImageAttribute hdr d) =
hdrToString hdr
++ ':'
: show (BL.length d)
++ ':'
: BC8.unpack
(Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
uaspToString (OtherUASub t d) =
"other-"
++ show t
++ ':'
: show (BL.length d)
++ ':'
: BC8.unpack
(Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
hdrToString (ImageHV1 JPEG) = "jpeg"
hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)
populateBestOf
:: Map.Map Text (Result UIDReport) -> Maybe UIDReport
populateBestOf um
| Map.null um = Nothing
| otherwise =
Just
( UIDReport
<$> best . uidSelfSigHashAlgorithms
<*> best
. uidPreferredHashAlgorithms
<*> best
. uidKeyExpirationTimes
<*> best
. uidKeyUsageFlags
<*> pure []
$ mconcat (justTheUIDRs um)
)
justTheUIDRs = map getResult . Map.elems
-- Pick the single most favorable Result from a list, for display as
-- a representative "best of" example.
--
-- This doesn't use Ord because there could be a Nothing in the list
-- and that would be "best".
--
-- That also implies that this should get an overhaul.
best :: [Result a] -> [Result a]
best = take 1 . sortOn (bestOfRank . resultColor)
bestOfRank :: Maybe Color -> Int
bestOfRank (Just Green) = 0
bestOfRank (Just Yellow) = 1
bestOfRank (Just Red) = 2
bestOfRank Nothing = 3
colorizeUID :: Text -> UIDReport -> Result UIDReport
colorizeUID u ur =
let strU = T.unpack u
check cond msg =
if cond
then colored (Just Yellow) (Just [msg]) ()
else pure ()
in check ('(' `elem` strU) "parenthesis in uid"
*> check ('<' `notElem` strU) "no left angle bracket in uid"
*> pure ur
findRevocationReason = concatMap grabReasons . filter isCertRevocationSig
grabReasons (SigV4 CertRevocationSig _ _ hashedSubs _ _ _) =
mapMaybe (grabReasons' . _sspPayload) hashedSubs
grabReasons (SigV6 CertRevocationSig _ _ _ hashedSubs _ _ _) =
mapMaybe (grabReasons' . _sspPayload) hashedSubs
grabReasons _ = []
grabReasons' (ReasonForRevocation a b) =
Just (RevocationStatus True (show a) b)
grabReasons' _ = Nothing
kufs s =
mapMaybe
( \sig ->
case find isKUF (hasheds sig) of
Just (SigSubPacket _ (KeyFlags x)) -> Just (colorizeKUFs s x)
_ -> Nothing
)
. newestWith (any isKUF . hasheds)
colorizeKUFs
:: Bool -> Set.Set KeyFlag -> Result (Set.Set KeyFlag)
colorizeKUFs False x
| encrypts && signsOrCertifies =
colored (Just Yellow) (Just ["both signing & encryption"]) x
| otherwise = withColor (Just Green) x
where
encrypts =
Set.member EncryptStorageKey x
|| Set.member EncryptCommunicationsKey x
signsOrCertifies = Set.member SignDataKey x || Set.member CertifyKeysKey x
colorizeKUFs True x
| certifies =
colored (Just Red) (Just ["certification-capable subkey"]) x
| encryptsAndSigns =
colored (Just Yellow) (Just ["both signing & encryption"]) x
| otherwise = withColor (Just Green) x
where
certifies = Set.member CertifyKeysKey x
encryptsAndSigns =
( Set.member EncryptStorageKey x
|| Set.member EncryptCommunicationsKey x
)
&& Set.member SignDataKey x
sigTime :: SignaturePayload -> ThirtyTwoBitTimeStamp
sigTime sig = case sigcts sig of
(t : _) -> t
[] -> 0
newestWith p sigs =
let filtered = filter p sigs
in if null filtered
then []
else [maximumBy (comparing sigTime) filtered]
checkSK
:: Fingerprint
-> (KeyPkt k, [SignaturePayload])
-> Result SubkeyReport
checkSK pf (KeyPktPublicSubkey pkp, sigs) = checkSK' pf pkp sigs
checkSK pf (KeyPktSecretSubkey pkp _, sigs) = checkSK' pf pkp sigs
checkSK _ _ = error "checkSK: unexpected packet type"
checkSK' pf pkp sigs =
skr
<$ sequenceA_
[ void (skFingerprint skr)
, void (skVer skr)
, void (skAlgorithmAndSize skr)
, traverse_ void (skBindingSigHashAlgorithms skr)
, traverse_ void (skUsageFlags skr)
, void (ccPresent (skCrossCerts skr))
, traverse_ void (ccHashAlgorithms (skCrossCerts skr))
]
where
skr =
( \x -> x {skCrossCerts = ccr (map getResult (skUsageFlags x)) sigs}
)
SubkeyReport
{ skFingerprint = colorizeF pf (fingerprint pkp)
, skVer = colorizeKV (_keyVersion pkp)
, skCreationTime = _timestamp pkp
, skAlgorithmAndSize = kasIt pkp
, skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)
, skRevocationSigWeakDigests =
subkeyRevocationSigWeakDigests pkp sigs
, skUsageFlags = kufs True (filter isSKBindingSig sigs)
, skCrossCerts = CrossCertReport (pure False) []
}
hasEncryptionCapableSubkey
:: [Result (Set.Set KeyFlag)] -> Result Bool
hasEncryptionCapableSubkey skrs =
let hasEncryption =
any
( ( \x ->
Set.member EncryptStorageKey x
|| Set.member EncryptCommunicationsKey x
)
. getResult
)
skrs
in if hasEncryption
then withColor (Just Green) True
else
colored
(Just Red)
(Just ["no encryption-capable subkey present"])
False
embeddedSigs =
filter isPKBindingSig
. concatMap getEmbeds
. filter isSKBindingSig
getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
getEmbeds (SigV6 _ _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
getEmbeds _ = []
getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]
getEmbed _ = []
ccr kufs' sigs =
CrossCertReport
(colorES kufs' sigs)
(map (colorizeHA . hashAlgo) sigs)
colorES :: [Set.Set KeyFlag] -> [SignaturePayload] -> Result Bool
colorES kufs' sigs =
let noEmbedded = null (embeddedSigs sigs)
signCapable = any (Set.member SignDataKey) kufs'
authCapable = any (Set.member AuthKey) kufs'
in case (noEmbedded, signCapable, authCapable) of
(True, True, True) ->
colored
(Just Red)
(Just ["signing- and auth-capable subkey without cross-cert"])
False
(True, True, False) ->
colored
(Just Red)
(Just ["signing-capable subkey without cross-cert"])
False
(True, False, True) ->
colored
(Just Yellow)
(Just ["auth-capable subkey without cross-cert"])
False
_ ->
withColor (Just Green) True
colorizeF :: Fingerprint -> Fingerprint -> Result Fingerprint
colorizeF pf fp
| pf == fp =
colored
(Just Red)
(Just ["subkey has same fingerprint as primary key"])
fp
| otherwise = withColor (Just Green) fp
subkeyRevocationSigWeakDigests pkp =
mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp)
. filter isSubkeyRevocationSignature
mkSubkeyRevocationSigWeakDigestWarning pkp sig =
let ha = hashAlgo sig
in if isKnownWeakHashAlgorithm ha
then
Just
SubkeyRevocationDigestWarning
{ srwHashAlgorithm = ha
, srwSubkeyFingerprint = renderFingerprint (fingerprint pkp)
, srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp))
, srwMessage =
"subkey revocation signature uses known-weak digest algorithm"
}
else Nothing
prettyKeyReport :: POSIXTime -> SomeTK -> Doc PPA.AnsiStyle
prettyKeyReport cpt stk = do
let keyReportResult = unPolicy checkKey stk (Just cpt)
keyReport = getResult keyReportResult
execWriter $
tell $
vsep
[ pretty "Key has potential validity"
<> colon
<+> pretty (getResult (keyStatus keyReport))
, pretty "Key has fingerprint"
<> colon
<+> pretty (SpacedFingerprint (getResult (keyFingerprint keyReport)))
, pretty "Checking to see if key is OpenPGPv4 or v6"
<> colon
<+> coloredToColor (pretty . show) (keyVer keyReport)
, ( \kas ->
pretty "Checking the strength of your primary asymmetric key"
<> colon
<+> coloredToColor pretty (pubkeyalgo kas)
<+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)
)
(getResult (keyAlgorithmAndSize keyReport))
, pretty "Checking user-ID- and user-attribute-related items"
<> colon
<> mconcat
( map
(uidtrip (getResult (keyCreationTime keyReport)))
(Map.toList (keyUIDsAndUAts keyReport))
)
, pretty "Checking subkeys" <> colon
, indent
2
( pretty "one of the subkeys is encryption-capable"
<> colon
<+> coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)
)
<> mconcat (map subkeyrep (keySubkeys keyReport))
]
<> linebreak
where
coloredToColor f (Result (Just Green) _ x) = green (f x)
coloredToColor f (Result (Just Yellow) _ x) = yellow (f x)
coloredToColor f (Result (Just Red) _ x) = red (f x)
coloredToColor f (Result Nothing _ x) = f x
uidtrip ts (uText, r@(Result _ _ ur))
| null (uidRevocationStatus ur) =
linebreak
<> indent 2 (coloredToColor pretty (T.unpack uText <$ r))
<> colon
<> linebreak
<> indent
4
( pretty "Self-sig hash algorithms"
<> colon
<+> (list . map (coloredToColor pretty) . uidSelfSigHashAlgorithms)
ur
)
<> linebreak
<> indent
4
( pretty "Preferred hash algorithms"
<> colon
<+> mconcat
(map (coloredToColor pretty) (uidPreferredHashAlgorithms ur))
)
<> linebreak
<> indent
4
( pretty "Key expiration times"
<> colon
<+> mconcat
( map
(coloredToColor list . fmap (map (pretty . keyExp ts)))
(uidKeyExpirationTimes ur)
)
)
<> linebreak
<> indent
4
( pretty "Key usage flags"
<> colon
<+> (list . map (coloredToColor (pretty . Set.toList)))
(uidKeyUsageFlags ur)
)
| otherwise =
linebreak
<> indent 2 (coloredToColor pretty (T.unpack uText <$ r))
<> colon
<+> pretty "[revoked]"
<> linebreak
<> indent
4
( pretty "Revocation code"
<> colon
<+> list (map (pretty . revocationCode) (uidRevocationStatus ur))
)
<> linebreak
<> indent
4
( pretty "Revocation reason"
<> colon
<+> list
( map
(pretty . T.unpack . revocationReason)
(uidRevocationStatus ur)
)
)
keyExp ts ke =
(show . pretty) ke
++ " = "
++ formatTime
defaultTimeLocale
"%c"
(posixSecondsToUTCTime (realToFrac ts + realToFrac ke))
subkeyrep skrResult =
let skr = getResult skrResult
in subkeydetail skr
subkeydetail skr =
linebreak
<> indent
2
( pretty "fpr"
<> colon
<+> coloredToColor
pretty
(fmap SpacedFingerprint (skFingerprint skr))
)
<> linebreak
<> indent
4
(pretty "version" <> colon <+> coloredToColor pretty (skVer skr))
<> linebreak
<> indent
4
(pretty "timestamp" <> colon <+> pretty (skCreationTime skr))
<> linebreak
<> indent
4
( ( \kas ->
pretty "algo/size"
<> colon
<+> coloredToColor pretty (pubkeyalgo kas)
<+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)
)
(getResult (skAlgorithmAndSize skr))
)
<> linebreak
<> indent
4
( pretty "binding sig hash algorithms"
<> colon
<+> (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms)
skr
)
<> linebreak
<> indent
4
( pretty "weak subkey revocation digests"
<> colon
<+> if null (skRevocationSigWeakDigests skr)
then pretty "[]"
else
list
( map
( \w ->
red
( pretty (srwHashAlgorithm w)
<> colon
<+> pretty (srwSubkeyFingerprint w)
<> colon
<+> maybe (pretty "") pretty (srwSubkeyKeyID w)
)
)
(skRevocationSigWeakDigests skr)
)
)
<> linebreak
<> indent
4
( pretty "usage flags"
<> colon
<+> (list . map (coloredToColor (pretty . Set.toList)))
(skUsageFlags skr)
)
<> linebreak
<> indent
4
( pretty "embedded cross-cert"
<> colon
<+> (coloredToColor pretty . ccPresent . skCrossCerts) skr
)
<> linebreak
<> indent
4
( pretty "cross-cert hash algorithms"
<> colon
<+> ( list
. map (coloredToColor pretty)
. ccHashAlgorithms
. skCrossCerts
)
skr
)
jsonReport :: POSIXTime -> SomeTK -> BL.ByteString
jsonReport ps stk = A.encode (getResult (unPolicy checkKey stk (Just ps)))
yamlReport :: POSIXTime -> SomeTK -> B.ByteString
yamlReport ps stk =
Y.encode . (: []) $ getResult (unPolicy checkKey stk (Just ps))
doLint :: LintOptions -> IO ()
doLint o = do
cpt <- getPOSIXTime
keys <-
runConduitRes $
CB.sourceHandle stdin
.| conduitGet get
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| CL.consume
output (lintOutputFormat o) cpt keys
where
output Pretty cpt = mapM_ (PPA.putDoc . prettyKeyReport cpt)
output JSON cpt =
mapM_
(BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt)
output YAML cpt = mapM_ (B.putStr . yamlReport cpt)
sigissuer :: SignaturePayload -> Maybe EightOctetKeyId
getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId
hashAlgo :: SignaturePayload -> HashAlgorithm
sigissuer (SigVOther 2 _) = Nothing
sigissuer SigV3 {} = Nothing
sigissuer (SigV4 _ _ _ ys xs _ _) =
let issuers = mapMaybe (getIssuer . _sspPayload) (ys ++ xs)
in case nub issuers of
[issuer] -> Just issuer
_ -> Nothing
sigissuer (SigV6 {}) = Nothing -- v6 signatures are forbidden from carrying Issuer subpackets; see sigissuerFPs
sigissuer (SigVOther _ _) = Nothing
getIssuer (Issuer i) = Just i
getIssuer _ = Nothing
sigissuerFPs :: SignaturePayload -> [Fingerprint]
sigissuerFPs (SigV4 _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)
sigissuerFPs (SigV6 _ _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)
sigissuerFPs _ = []
getIssuerFP :: SigSubPacketPayload -> Maybe Fingerprint
getIssuerFP (IssuerFingerprint _ fp) = Just fp
getIssuerFP _ = Nothing
hashAlgo (SigV3 _ _ _ _ x _ _) = x
hashAlgo (SigV4 _ _ x _ _ _ _) = x
hashAlgo (SigV6 _ _ x _ _ _ _ _) = x
hashAlgo (SigVOther _ _) = OtherHA 0
knownWeakHashAlgorithms :: [HashAlgorithm]
knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]
isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool
isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms
isSubkeyRevocationSignature :: SignaturePayload -> Bool
isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig
isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig
isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig
isSubkeyRevocationSignature _ = False
hasheds :: SignaturePayload -> [SigSubPacket]
hasheds (SigV4 _ _ _ xs _ _ _) = xs
hasheds (SigV6 _ _ _ _ xs _ _ _) = xs
hasheds _ = []
hopenpgp-tools-0.25.5/HOpenPGP/Tools/Hokey/Options.hs 0000644 0000000 0000000 00000011244 07346545000 020502 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 Options.Applicative.Builder
( argument
, auto
, help
, helpDoc
, long
, metavar
, option
, showDefault
, str
, value
)
import Options.Applicative.Types (Parser)
import Prettyprinter
( hardline
, list
, pretty
)
import HOpenPGP.Tools.Common.HKP (FetchValidationMethod (..))
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.5/LICENSE 0000644 0000000 0000000 00000103330 07346545000 013757 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.5/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 014407 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
hopenpgp-tools-0.25.5/hkt.hs 0000644 0000000 0000000 00000060321 07346545000 014076 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.Policy
( defaultVerificationPolicy
)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
( EightOctetKeyId
, Fingerprint
, HashAlgorithm (..)
, PublicKey (..)
, PublicKeyring
, SigSubPacket (_sspPayload)
, SigSubPacketPayload (..)
, Signature (..)
, SignaturePayload (..)
, SomePKPayload (..)
, SomeTK (..)
, TK (..)
, UserAttribute (..)
, UserId (..)
, keyPktPKPayload
, keyPktToPkt
, someTKToPublicViewTK
, someTKToUnknown
, _pkalgo
, _pubkey
)
import Control.Applicative (optional, (<|>))
import Control.Arrow ((&&&))
import Control.Exception (ErrorCall, evaluate, try)
import Control.Lens ((^..), _1)
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 (RFilterPredicate)
, runPredicate
)
import Data.Conduit.OpenPGP.Keyring
( conduitDropErrorsAndNothings
, conduitToSomeTKsDroppingEither
, 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 qualified Data.IxSet.Typed as IxSet
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.Time.Clock.POSIX
( getPOSIXTime
, posixSecondsToUTCTime
)
import Data.Tuple (swap)
import Data.Void (Void)
import qualified Data.Yaml as Y
import GHC.Generics
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
( defaultLayoutOptions
, fillSep
, hardline
, layoutPretty
, list
, pretty
, (<+>)
)
import Prettyprinter.Render.Text (hPutDoc, putDoc)
import qualified Prettyprinter.Render.Text as PPA
import System.Directory (getHomeDirectory)
import System.Exit (exitFailure)
import System.IO
( BufferMode (..)
, Handle
, hFlush
, hPutStrLn
, hSetBuffering
, stderr
)
import HOpenPGP.Tools.Common.Common
( banner
, keyMatchesEightOctetKeyId
, keyMatchesFingerprint
, keyMatchesUIDSubString
, versioner
, warranty
)
import HOpenPGP.Tools.Common.Parser (parseTKExp)
import HOpenPGP.Tools.Common.TKUtils (verifyTKWithTyped)
grabMatchingKeysConduit
:: (MonadResource m, MonadThrow m)
=> FilePath
-> Bool
-> FilterPredicates Void SomeTK
-> Text
-> ConduitM () SomeTK m ()
grabMatchingKeysConduit fp filt ufp srch =
CB.sourceFile fp
.| conduitGet get
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| ( if filt
then CL.filter (runPredicate 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 [SomeTK]
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
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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 :: [SomeTK] -> IO PublicKeyring
grabMatchingPublicKeyring keys =
runConduitRes $
CL.sourceList (mapMaybe someTKToPublicTk keys)
.| sinkPublicKeyringMap
where
someTKToPublicTk (SomePublicTK publicTk) = Just publicTk
someTKToPublicTk (SomeSecretTK secretTk) = Just (someTKToPublicViewTK (SomeSecretTK secretTk))
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 :: SomeTK -> TKey
tkToTKey stk =
TKey
{ publickey = mkey (keyPktPKPayload (_tkPrimaryKey publicView))
, uids = _tkUIDs publicView ^.. traverse . _1
, subkeys =
mapMaybe
(\kp -> Just (mkey (keyPktPKPayload kp)))
(map fst (_tkSubs publicView))
}
where
publicView = someTKToPublicViewTK stk
mkey =
Key
<$> either (const Nothing) Just . pubkeySize . _pubkey
<*> show
. _pkalgo
<*> pkalgoAbbrev
. _pkalgo
<*> renderFingerprint
. fingerprint
showTKey :: TKey -> IO ()
showTKey tkey =
putDoc $
pretty "pub "
<+> sizeabbrevkeyid (publickey tkey)
<> hardline
<> mconcat
( map
( \x ->
pretty "uid "
<+> pretty (T.unpack x)
<> hardline
)
(uids tkey)
)
<> mconcat
( map
(\x -> pretty "sub " <+> sizeabbrevkeyid x <> hardline)
(subkeys tkey)
)
<> hardline
where
sizeabbrevkeyid k =
pretty (maybe "unknown" show (keysize k))
<> pretty (keyalgoabbreviation k)
<> pretty "/"
<> pretty (fpr k)
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 _ =
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 $ map someTKToUnknown keys
YAML -> B.putStr . Y.encode $ map someTKToUnknown keys
where
putTK' tk =
runPut $ do
put (PublicKey (keyPktPKPayload (_tkPrimaryKey publicView)))
mapM_ (put . Signature) (_tkRevs publicView)
mapM_ putUid' (_tkUIDs publicView)
mapM_ putUat' (_tkUAts publicView)
mapM_
putSub'
(map (\(kp, sigs) -> (keyPktToPkt kp, sigs)) (_tkSubs publicView))
where
publicView = someTKToPublicViewTK tk
putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps
putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps
putSub' (p, sps) = put p >> mapM_ (put . Signature) sps
doGraph :: Options -> IO ()
doGraph o = do
let ttarget1 = T.pack . target1
cpt <- getPOSIXTime
keys <-
grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
kr <- grabMatchingPublicKeyring keys
let g =
buildKeyGraph
( (buildMaps &&& id)
( rights
( map
( verifyTKWithTyped
defaultVerificationPolicy
(map SomePublicTK (IxSet.toList 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 :: [SomeTK] -> (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 :: SomeTK -> (KeyMaps, Int) -> (KeyMaps, Int)
mapsInsertions stk (KeyMaps k2f f2i i2f, i) =
let publicView = someTKToPublicViewTK stk
fp = fingerprint (keyPktPKPayload (_tkPrimaryKey publicView))
keyids =
rights . map eightOctetKeyID $
(someTKToUnknown stk ^.. 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), [SomeTK])
-> 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
let publicView = someTKToPublicViewTK tk
target <-
lookupNode
(fingerprint (keyPktPKPayload (_tkPrimaryKey publicView)))
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 =
someTKToUnknown tk ^.. biplate :: [SignaturePayload]
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 CL.filter (runPredicate filter2)
else CL.filter (matchAny (ttarget2 o))
)
.| CL.consume
keys2 <-
runConduitRes $
CL.sourceList keys
.| ( if filt
then CL.filter (runPredicate filter3)
else CL.filter (matchAny (ttarget3 o))
)
.| CL.consume
let ((KeyMaps k2f f2i i2f, i), ks) =
(buildMaps &&& id)
( rights
( map
( verifyTKWithTyped
defaultVerificationPolicy
(map SomePublicTK (IxSet.toList kr))
(Just (posixSecondsToUTCTime cpt))
)
keys
)
)
keygraph <-
either dieHKT pure (buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks))
let keysToIs =
mapMaybe
( \x ->
HashMap.lookup
( fingerprint
(keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK x)))
)
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 SomeTK))
parseFilterPredicateIO e = do
parsed <-
try (evaluate (RFilterPredicate <$> parseTKExp (T.unpack e)))
:: IO
( Either
ErrorCall
(Either String (FilterPredicates Void SomeTK))
)
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.5/hokey.hs 0000644 0000000 0000000 00000006371 07346545000 014434 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.5/hop.hs 0000644 0000000 0000000 00000707156 07346545000 014114 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 DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
( Armor (..)
, ArmorType (..)
)
import Codec.Encryption.OpenPGP.Compression
( CompressionError
, decompressPkt
, renderCompressionError
)
import Codec.Encryption.OpenPGP.Encrypt
( PKESKEncryptError (..)
, PKESKSessionMaterial (..)
, RecipientEncryptRequest (..)
, RecipientEncryptRequestOverrides (..)
, RecipientEncryptResult (..)
, RecipientPKESKVersionStrategyW (..)
, RecipientPayloadShape (..)
, defaultRecipientPayloadShape
, encryptForRecipients
, recipientEncryptionTarget
, recipientEncryptionTargetWithStrategyTyped
)
import Codec.Encryption.OpenPGP.Expirations
( effectiveKeyPreferencesAt
, isTKTimeValid
)
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Codec.Encryption.OpenPGP.Message
( EncryptMessageOptions (..)
, RecoveredSessionMaterial (..)
, SessionMaterialExposure (..)
, encryptMessage
, encryptedPayloadBytes
, mkClearPayload
)
import Codec.Encryption.OpenPGP.Ontology
( isKUF
, isPKBindingSig
, isSKBindingSig
)
import Codec.Encryption.OpenPGP.Policy
( defaultDecryptPolicy
, defaultPolicy
, defaultVerificationPolicy
, lenientDecryptPolicy
)
import Codec.Encryption.OpenPGP.S2K
( decodeOpenPGPEncodedSessionKey
, skesk2Key
, skesk2SessionKey
)
import Codec.Encryption.OpenPGP.SecretKey
( decryptPrivateKey
, encryptSecretKeyWithPolicy
)
import Codec.Encryption.OpenPGP.Serialize (parsePkts)
import Codec.Encryption.OpenPGP.Signatures
( SignError (..)
, renderSignError
, signDataWithEd25519
, signDataWithEd25519Legacy
, signDataWithEd25519V6
, signDataWithEd448
, signDataWithEd448V6
, signDataWithRSABuilder
, signDataWithRSAV6
, signKeyRevocationWithRSA
, signUserIDwithRSA
)
import qualified Codec.Encryption.OpenPGP.Subpackets as SP
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Version as HOV
import Control.Applicative (many, optional, some, (<|>))
import Control.Error.Util (note)
import Control.Exception
( IOException
, SomeException
, catch
, displayException
, evaluate
, throwIO
)
import Control.Lens ((^..))
import Control.Monad (forM, forM_, unless, when, (>=>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)
import Crypto.Error (eitherCryptoError)
import Crypto.Number.Serialize (i2ospOf_, os2ip)
import qualified Crypto.PubKey.Curve25519 as Curve25519
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import qualified Data.Aeson as A
import Data.Bifunctor (first)
import qualified Data.Binary as Bin
import Data.Binary.Get (runGet)
import Data.Binary.Put
( putByteString
, putLazyByteString
, putWord16be
, putWord32be
, putWord8
, runPut
)
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Char (digitToInt, isHexDigit, isSpace, toLower)
import Data.Conduit (fuseBoth, runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.Combinators as CC
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Decrypt
( DecryptKeyResolution (..)
, DecryptOutcome (..)
, PKESKRecipientKey (..)
)
import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt
import Data.Conduit.OpenPGP.Keyring
( conduitDropErrorsAndNothings
, conduitToSomeTKsDroppingEither
, sinkPublicKeyringMap
)
import Data.Conduit.OpenPGP.Verify
( conduitVerify
, verifyPacketsBatch
)
import Data.Data.Lens (biplate)
import Data.Either (fromRight, isLeft, isRight, rights)
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.List
( find
, findIndex
, intercalate
, isInfixOf
, isPrefixOf
, isSuffixOf
, nub
, partition
, stripPrefix
)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
( catMaybes
, fromMaybe
, isJust
, listToMaybe
, mapMaybe
, maybeToList
)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Text.Encoding.Error (lenientDecode)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX
( POSIXTime
, getPOSIXTime
, posixSecondsToUTCTime
, utcTimeToPOSIXSeconds
)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.Format.ISO8601 (iso8601ParseM)
import qualified Data.Vector as V
import Data.Version (showVersion)
import Data.Word (Word8)
import GHC.Generics
import Options.Applicative.Builder
( argument
, command
, eitherReader
, footerDoc
, headerDoc
, help
, helpDoc
, info
, long
, metavar
, option
, prefs
, progDesc
, showHelpOnError
, str
, strArgument
, strOption
, switch
, value
)
import Options.Applicative.Extra
( execParserPure
, helper
, hsubparser
, renderFailure
)
import Options.Applicative.Types
( CompletionResult (..)
, Parser
, ParserResult (..)
)
import Prettyprinter
( hardline
, list
, pretty
, softline
)
import Prettyprinter.Render.Text (hPutDoc)
import System.Directory (doesFileExist)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit
( ExitCode (..)
, exitSuccess
, exitWith
)
import System.IO
( BufferMode (..)
, Handle
, hFlush
, hPutStrLn
, hSetBuffering
, stderr
, stdin
)
import Text.Read (readMaybe)
import HOpenPGP.Tools.Common.Armor (doDeArmor)
import HOpenPGP.Tools.Common.Common
( banner
, keyMatchesEightOctetKeyId
, keyMatchesFingerprint
, versioner
, warranty
)
import HOpenPGP.Tools.Common.TKUtils
( processTK
, verifyTKWithTyped
)
import Paths_hopenpgp_tools (version)
data Command
= VersionC VersionOptions
| ListProfilesC ListProfilesOptions
| GenerateKeyC KeyGenOptions
| ChangeKeyPasswordC ChangeKeyPasswordOptions
| MergeCertsC MergeCertsOptions
| ValidateUserIdC ValidateUserIdOptions
| CertifyUserIdC CertifyUserIdOptions
| RevokeKeyC RevokeKeyOptions
| UpdateKeyC UpdateKeyOptions
| VerifyC VerifyOptions
| InlineVerifyC InlineVerifyOptions
| EncryptC EncryptOptions
| DecryptC DecryptOptions
| InlineSignC InlineSignOptions
| InlineDetachC InlineDetachOptions
| ExtractCertC ExtractCertOptions
| SignC SignOptions
| UnsupportedC String
| DeArmorC
| ArmorC
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
, encProfile :: Maybe String
, encAs :: AsBinaryText
, encSignWithKeyFiles :: [String]
, encSignWithKeyPasswords :: [String]
, encSessionKeyOutFile :: Maybe String
, encFor :: EncryptFor
, encPasswords :: [String]
, encRecipientCerts :: [String]
}
data EncryptProfile
= EncryptProfileRFC9580
| EncryptProfileRFC4880
deriving (Eq)
data Profile p = Profile
{ profileName :: String
, profileDescription :: String
, profileValue :: p
, profileAliases :: [String]
}
encryptProfiles :: [Profile EncryptProfile]
encryptProfiles =
[ Profile
"rfc9580"
"SEIPDv2"
EncryptProfileRFC9580
["default", "security", "performance"]
, Profile
"rfc4880"
"SEIPDv1"
EncryptProfileRFC4880
["compatibility"]
]
data DecryptOptions
= DecryptOptions
{ decNoArmor :: Bool
, decVerifyNotBefore :: Maybe String
, decVerifyNotAfter :: Maybe String
, decSessionKeys :: [String]
, decSessionKeyOutFile :: Maybe String
, decPasswords :: [String]
, decKeyPasswords :: [String]
, decKeyFiles :: [String]
, decVerifyCerts :: [String]
, decVerificationsOutFile :: Maybe String
}
data InlineSignOptions
= InlineSignOptions
{ inlineSignNoArmor :: Bool
, inlineSignAs :: Maybe InlineSignMode
, inlineSignKeyFiles :: [String]
, inlineSignKeyPasswords :: [String]
}
data InlineDetachOptions
= InlineDetachOptions
{ inlineDetachNoArmor :: Bool
, inlineDetachOutputSigs :: String
}
data ChangeKeyPasswordOptions
= ChangeKeyPasswordOptions
{ changeKeyPasswordNoArmor :: Bool
, changeKeyPasswordOldPasswords :: [String]
, changeKeyPasswordNewPassword :: Maybe 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]
, certifyUserIdNoArmor :: Bool
, certifyUserIdNoRequireSelfSig :: Bool
, certifyUserIdKeyPasswordFiles :: [String]
, certifyUserIdSignerFiles :: [String]
}
data RevokeKeyOptions
= RevokeKeyOptions
{ revokeKeyNoArmor :: Bool
, revokeKeyPasswordFiles :: [String]
}
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
| PrimaryKeyBad
| 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 PrimaryKeyBad = 103
failureCode CertUserIdNoMatch = 107
failureCode KeyCannotCertify = 109
failWith :: MonadIO m => SopFailure -> String -> m a
failWith f msg = liftIO $ do
BLC8.hPutStrLn stderr (BLC8.pack msg)
exitWith (ExitFailure (failureCode f))
voP :: Parser VerifyOptions
voP =
VerifyOptions
<$> optional
( strOption
( long "not-before"
<> metavar "DATE"
<> help "ignore signatures before DATE"
)
)
<*> optional
( strOption
( long "not-after"
<> metavar "DATE"
<> help "ignore signatures after DATE"
)
)
<*> argument str (metavar "SIGNATURES" <> sigHelp)
<*> some (strArgument (metavar "CERTS..." <> certHelp))
where
sigHelp =
helpDoc . Just $
pretty "file containing OpenPGP signatures"
certHelp =
helpDoc . Just $
pretty "one or more certificate files"
ivoP :: Parser InlineVerifyOptions
ivoP =
InlineVerifyOptions
<$> optional
( strOption
( long "not-before"
<> metavar "DATE"
<> help "ignore signatures before DATE"
)
)
<*> optional
( strOption
( long "not-after"
<> metavar "DATE"
<> help "ignore signatures after DATE"
)
)
<*> optional
( strOption
( long "verifications-out"
<> metavar "VERIFICATIONS"
<> help "write verification records to file"
)
)
<*> some (strArgument (metavar "CERTS..." <> certHelp))
where
certHelp =
helpDoc . Just $
pretty "one or more certificate files"
lpoP :: Parser ListProfilesOptions
lpoP =
ListProfilesOptions
<$> strArgument
(metavar "SUBCOMMAND" <> help "subcommand to list profiles for")
vopP :: Parser VersionOptions
vopP =
VersionOptions
<$> switch
(long "backend" <> help "show backend implementation version")
<*> switch
(long "extended" <> help "show extended version information")
<*> switch (long "sop-spec" <> help "show targeted sop draft")
<*> switch
(long "sopv" <> help "show implemented sopv subset version")
encP :: Parser EncryptOptions
encP =
EncryptOptions
<$> switch (long "no-armor" <> help "output binary")
<*> 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
)
<*> 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")
<*> 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"
)
)
inlineSignP :: Parser InlineSignOptions
inlineSignP =
InlineSignOptions
<$> switch (long "no-armor" <> help "output binary")
<*> 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)"
)
)
<*> switch
( long "no-armor"
<> help "output 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"
)
)
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"
)
)
<*> optional
( strOption
( long "new-key-password"
<> help "password used to protect rewritten secret key material"
)
)
dispatch :: POSIXTime -> Command -> IO ()
dispatch cpt cmd' = banner' stderr >> hFlush stderr >> dispatch' cpt cmd'
where
dispatch' _ (VersionC o') = doVersion o'
dispatch' _ (ListProfilesC o') = doListProfiles o'
dispatch' t (GenerateKeyC o) = doGenerateKey t o
dispatch' _ (ChangeKeyPasswordC o) = doChangeKeyPassword o
dispatch' _ (MergeCertsC o) = doMergeCerts o
dispatch' t (ValidateUserIdC o) = doValidateUserId t o
dispatch' t (CertifyUserIdC o) = doCertifyUserId t o
dispatch' t (RevokeKeyC o) = doRevokeKey t o
dispatch' t (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 = doArmor
main :: IO ()
main = do
hSetBuffering stderr LineBuffering
args <- getArgs
ensureKnownSubcommand knownSopSubcommands args
cpt <- getPOSIXTime
let result =
execParserPure
(prefs showHelpOnError)
( info
(helper <*> versioner "hop" <*> cliP)
( headerDoc (Just (banner "hop"))
<> progDesc "hOpenPGP SOP Tool"
<> footerDoc (Just (warranty "hop"))
)
)
args
case result of
Success cliOptions -> do
let _ = cliDebug cliOptions
dispatch cpt (cliCommand cliOptions)
Failure f -> do
let (msg, ec) = renderFailure f "hop"
case ec of
ExitSuccess -> putStrLn msg >> exitSuccess
ExitFailure 1
| "Invalid option" `isInfixOf` msg
|| "Invalid argument" `isInfixOf` msg ->
hPutStrLn stderr msg >> exitWith (ExitFailure 37)
| otherwise ->
hPutStrLn stderr msg >> exitWith (ExitFailure 19)
_ -> hPutStrLn stderr msg >> exitWith ec
CompletionInvoked compl -> do
progn <- getProgName
msg <- execCompletion compl progn
putStr msg
exitSuccess
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"
, "sign"
, "update-key"
, "validate-userid"
, "verify"
, "version"
]
ensureKnownSubcommand :: [String] -> [String] -> IO ()
ensureKnownSubcommand knownSubcommands args =
if any (`elem` ["-h", "--help", "--version"]) args
then pure ()
else case find (not . isPrefixOf "-") args of
Just subcommand
| subcommand `notElem` knownSubcommands ->
failWith
UnsupportedSubcommand
("unsupported subcommand: " ++ subcommand)
_ -> pure ()
cliP :: Parser CliOptions
cliP =
CliOptions
<$> switch (long "debug" <> help "emit more verbose output")
<*> cmd
banner' :: Handle -> IO ()
banner' h =
hPutDoc
h
(banner "hop" <> hardline <> warranty "hop" <> hardline)
data Vrf
= Vrf
{ _vrfmsg :: String
, _vrfmfpr :: Maybe Fingerprint
}
deriving (Eq, Generic, Show)
instance A.ToJSON Vrf
cmd :: Parser Command
cmd =
hsubparser
( command
"armor"
(info (pure ArmorC) (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
"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")
)
)
doArmor :: IO ()
doArmor = do
m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
let lbs = BL.fromChunks m
armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs
if armoredAlready
then BL.putStr lbs
else do
let label' = guessLabel (decodeAllPackets lbs) lbs
a = Armor label' [] lbs
BL.putStr $ AA.encodeLazy [a]
where
decodeAllPackets lbs = runGet (many Bin.get) lbs
guessLabel [] _ = ArmorMessage
guessLabel (pkt : _) lbs =
case pkt of
SignaturePkt _ ->
if all isSignaturePacket (decodeAllPackets lbs)
then ArmorSignature
else ArmorMessage
SecretKeyPkt _ _ -> ArmorPrivateKeyBlock
PublicKeyPkt _ -> ArmorPublicKeyBlock
_ -> ArmorMessage
isSignaturePacket SignaturePkt {} = True
isSignaturePacket _ = False
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"
when vBackend $
putStrLn $
"hOpenPGP " ++ HOV.version
when vExtended $ do
mapM_ putStrLn $
[ "hop " ++ showVersion version
, ""
, "This is hop, from hopenpgp-tools " ++ showVersion version ++ ","
, "built with hOpenPGP " ++ HOV.version
]
when vSopSpec $
putStrLn "draft-dkg-openpgp-stateless-cli-16"
when vSopv $
putStrLn "1.0"
unless (vBackend || vExtended || vSopSpec || vSopv) $
putStrLn $
"hop " ++ showVersion version
gkoP :: Parser KeyGenOptions
gkoP =
KeyGenOptions
<$> switch (long "no-armor" <> help "don't armor the output")
<*> optional
( 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
{ noArmor :: Bool
, keyPassword :: Maybe String
, keyProfile :: Maybe String
, keySigningOnly :: Bool
, userIds :: [String]
}
doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()
doGenerateKey pt KeyGenOptions {..} = do
profile <- parseKeyGenProfile keyProfile
password <- parseGenerateKeyPassword keyPassword
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 keySigningOnly
newkey <- get
return newkey
s <-
maybe
(pure (SomeSecretTK baseKey))
(`encryptTransferableSecretKey` (SomeSecretTK baseKey))
password
let lbs = runPut $ Bin.put (someTKToUnknown s)
BL.putStr $
if not noArmor
then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]
else lbs
type KeyBuilder = StateT (TK 'SecretTK) IO
buildKeyWith :: SecretKey -> KeyBuilder a -> IO a
buildKeyWith sk a = evalStateT a (bareTK sk)
where
bareTK (SecretKey pkp ska) =
TK
{ _tkPrimaryKey = KeyPktSecretPrimary pkp ska
, _tkRevs = []
, _tkUIDs = []
, _tkUAts = []
, _tkSubs = []
}
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
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip pubBytes)))
)
)
(SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 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
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip pubBytes)))
)
)
(SUUnencrypted (X25519PrivateKey privBytes) 0)
data KeyGenProfile
= KeyGenRFC4880
| KeyGenSecurity
| KeyGenSigningOnly
deriving (Eq)
keyGenProfiles :: [Profile KeyGenProfile]
keyGenProfiles =
[ Profile
"security"
"Ed25519 signing key, X25519 encryption subkey"
KeyGenSecurity
["default", "performance", "rfc9580"]
, Profile
"rfc4880"
"RSA-4096 (v4 keys)"
KeyGenRFC4880
["compatibility"]
]
resolveProfile :: String -> [Profile p] -> Maybe p
resolveProfile name profiles =
lookup name [(profileName p, profileValue p) | p <- profiles]
<|> profileValue
<$> find (\p -> name `elem` profileAliases p) profiles
parseKeyGenProfile :: Maybe String -> IO KeyGenProfile
parseKeyGenProfile Nothing = pure KeyGenSecurity
parseKeyGenProfile (Just name) =
case resolveProfile name keyGenProfiles of
Just p -> pure p
Nothing ->
failWith
UnsupportedProfile
("generate-key: unsupported profile " ++ name)
keyVersionForProfile :: KeyGenProfile -> KeyVersion
keyVersionForProfile KeyGenRFC4880 = V4
keyVersionForProfile KeyGenSecurity = V6
keyVersionForProfile KeyGenSigningOnly = V6
primaryKeySpecForProfile :: KeyGenProfile -> GeneratedKeySpec
primaryKeySpecForProfile KeyGenRFC4880 = GeneratedRSAKey 4096
primaryKeySpecForProfile _ = GeneratedEd25519Key
parseGenerateKeyPassword
:: Maybe String -> IO (Maybe BL.ByteString)
parseGenerateKeyPassword Nothing = pure Nothing
parseGenerateKeyPassword (Just passwordFile) =
Just
<$> ( loadPasswordFromFile
"generate-key"
"--with-key-password"
passwordFile
>>= normalizeHumanReadablePassword
"generate-key"
"--with-key-password"
)
loadPasswordFiles
:: String -> String -> [String] -> IO [BL.ByteString]
loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName)
loadPasswordFromFile
:: String -> String -> FilePath -> IO BL.ByteString
loadPasswordFromFile context optionName path = do
case stripPrefix "@ENV:" path of
Just varName
| null varName ->
failWith
BadData
(context ++ ": empty environment variable name in " ++ optionName)
| otherwise -> do
envValue <- lookupEnv varName
case envValue of
Nothing ->
failWith
MissingInput
( context
++ ": environment variable not found for "
++ optionName
++ ": "
++ varName
)
Just envVal -> pure (BLC8.pack envVal)
Nothing ->
case stripPrefix "@FD:" path of
Just fdSpec -> loadPasswordFromFD context optionName fdSpec
Nothing ->
case path of
'@' : _ ->
failWith
UnsupportedSpecialPrefix
( context
++ ": unsupported special prefix for "
++ optionName
++ ": "
++ path
)
_ -> do
exists <- doesFileExist path
unless exists $
failWith
MissingInput
( context
++ ": password file does not exist for "
++ optionName
++ ": "
++ path
)
BL.readFile path
loadPasswordFromFD
:: String -> String -> String -> IO BL.ByteString
loadPasswordFromFD context optionName fdSpec =
case readMaybe fdSpec :: Maybe Int of
Just fdNum
| fdNum >= 0 ->
( do
let fdPath = "/dev/fd/" ++ show fdNum
exists <- doesFileExist fdPath
unless exists $
failWith
MissingInput
( context
++ ": file descriptor not available for "
++ optionName
++ ": "
++ fdSpec
)
contents <- BL.readFile fdPath
_ <- evaluate (BL.length contents)
pure contents
)
`catch` ( \err ->
failWith
MissingInput
( context
++ ": failed reading file descriptor for "
++ optionName
++ ": "
++ fdSpec
++ " ("
++ displayException (err :: IOException)
++ ")"
)
)
| otherwise ->
failWith
BadData
( context
++ ": invalid file descriptor in "
++ optionName
++ ": "
++ fdSpec
)
_ ->
failWith
BadData
( context
++ ": invalid file descriptor in "
++ optionName
++ ": "
++ fdSpec
)
loadInputFromFile
:: String -> String -> FilePath -> IO BL.ByteString
loadInputFromFile context optionName path = do
case stripPrefix "@ENV:" path of
Just varName
| null varName ->
failWith
BadData
(context ++ ": empty environment variable name in " ++ optionName)
| otherwise -> do
envValue <- lookupEnv varName
case envValue of
Nothing ->
failWith
MissingInput
( context
++ ": environment variable not found for "
++ optionName
++ ": "
++ varName
)
Just envVal -> pure (BLC8.pack envVal)
Nothing ->
case stripPrefix "@FD:" path of
Just fdSpec -> loadInputFromFD 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
++ ": file does not exist for "
++ optionName
++ ": "
++ path
)
BL.readFile path
loadInputFromFD
:: String -> String -> String -> IO BL.ByteString
loadInputFromFD 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
-> Bool
-> KeyBuilder ()
addSubkeysForProfile ts keyVersion _profile signingOnly = do
addSubkey ts keyVersion _profile [SignDataKey]
unless signingOnly $ do
addSubkey
ts
keyVersion
_profile
[EncryptStorageKey, EncryptCommunicationsKey]
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 -> SomeTK -> IO SomeTK
encryptTransferableSecretKey password stk =
case stk of
SomePublicTK _ -> pure stk
SomeSecretTK tk ->
case _tkPrimaryKey tk of
KeyPktSecretPrimary pkp ska -> do
encrypted <- encryptSecretAddendumForOutput pkp ska
subs' <- mapM encryptSub (_tkSubs tk)
pure $
SomeSecretTK
tk
{ _tkPrimaryKey = KeyPktSecretPrimary pkp encrypted
, _tkSubs = subs'
}
_ -> pure stk
where
encryptSub
:: (MonadIO m, MonadRandom m) => (KeyPkt k, b) -> m (KeyPkt k, b)
encryptSub (KeyPktSecretSubkey pkp ska, sigs) = do
encrypted <- liftIO $ encryptSecretAddendumForOutput pkp ska
pure (KeyPktSecretSubkey pkp encrypted, sigs)
encryptSub other = pure other
encryptSecretAddendumForOutput pkp ska =
case ska of
SUUnencrypted skey _ -> doEncryptSecret skey
_ -> pure ska
where
doEncryptSecret skey = do
encryptedResult <-
encryptSecretKeyWithPolicy
defaultPolicy
pkp
skey
(Passphrase password)
case encryptedResult of
Left err ->
failWith
BadData
( "generate-key: failed to protect secret key material: "
++ show err
)
Right val -> pure val
rsaSigningKey :: SKAddendum -> IO RSA.PrivateKey
rsaSigningKey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) =
pure (k {RSA.private_p = 0, RSA.private_q = 0})
rsaSigningKey _ =
failWith
BadData
"generate-key: unsupported secret key format for RSA signing"
issuerSubpacketsFor
:: String -> SomePKPayload -> IO [SigSubPacket]
issuerSubpacketsFor context pkp =
case _keyVersion pkp of
V6 -> pure []
_ ->
case eightOctetKeyID pkp of
Left err ->
failWith
BadData
(context ++ ": could not derive issuer key id: " ++ show err)
Right keyId -> pure [SigSubPacket False (Issuer keyId)]
addUserId
:: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()
addUserId ts primary userid = do
tk <- get
let pkp = keyPktPKPayload (_tkPrimaryKey tk)
ska :: SKAddendum
ska = case _tkPrimaryKey tk of
KeyPktSecretPrimary _ ska' -> ska'
_ -> error "addUserId: expected secret primary key"
signed <- selfsign pkp ska userid
modify (newUID signed)
where
newUID signed tk = tk {_tkUIDs = _tkUIDs tk ++ [signed]}
selfsign pkp 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])
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)
let pkp = keyPktPKPayload (_tkPrimaryKey tk)
ska :: SKAddendum
ska = case _tkPrimaryKey tk of
KeyPktSecretPrimary _ ska' -> ska'
_ -> error "addSubkey: expected secret primary key"
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
{ _tkSubs = _tkSubs tk ++ [(KeyPktSecretSubkey 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 "no-armor" <> help "don't armor the output")
data ExtractCertOptions
= ExtractCertOptions
{ 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
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| CC.sinkList
when (null tks) $
failWith
MissingInput
"extract-cert: no transferable secret key found on standard input"
let output = runPut $ mapM_ (Bin.put . someTKToUnknown . pubToSecret) tks
BL.putStr $
if not ecNoArmor
then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
else output
where
pubToSecret tk =
case tk of
SomeSecretTK _ -> SomePublicTK (someTKToPublicViewTK tk)
SomePublicTK publicTk -> SomePublicTK publicTk
doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()
doChangeKeyPassword ChangeKeyPasswordOptions {..} = do
input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
packets <- decodeOpenPGPInput "stdin" input
tks <-
runConduitRes $
CL.sourceList packets
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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 changeKeyPasswordNewPassword
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 . someTKToUnknown) rewrittenTks)
BL.putStr $
if changeKeyPasswordNoArmor || BL.null output
then output
else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]
parseChangeKeyPasswordNewPassword
:: Maybe String -> IO (Maybe BL.ByteString)
parseChangeKeyPasswordNewPassword Nothing = pure Nothing
parseChangeKeyPasswordNewPassword (Just passwordFile) =
Just
<$> ( loadPasswordFromFile
"change-key-password"
"--new-key-password"
passwordFile
>>= normalizeHumanReadablePassword
"change-key-password"
"--new-key-password"
)
hasSecretKeyMaterial :: SomeTK -> Bool
hasSecretKeyMaterial tk =
case tk of
SomeSecretTK _ -> True
SomePublicTK _ -> 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
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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
:: [SomeTK] -> Maybe UTCTime -> Bool -> Text -> SomeTK -> Bool
certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =
case verifyTKWithTyped
defaultVerificationPolicy
(certTk : authorityTks)
validateAtTime
certTk of
Left _ -> False
Right verifiedTk ->
any matchingBoundUid (_tkUIDs (someTKToPublicViewTK verifiedTk))
where
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 :: SomeTK -> 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
( \p ->
loadCertifySignerTKsFromFile signerPasswords "certify-userid" p
)
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
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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 . someTKToUnknown) updatedTargets)
BL.putStr $
if certifyUserIdNoArmor
then output
else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
loadCertifySignerTKsFromFile
:: [BL.ByteString] -> String -> String -> IO [SomeTK]
loadCertifySignerTKsFromFile signerPasswords context path = do
lbs <- loadInputFromFile context "file" path
packets <- decodeOpenPGPInput path lbs
tks <-
runConduitRes $
CL.sourceList packets
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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
:: SomeTK -> [Text] -> Bool -> [SomeTK] -> IO SomeTK
addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do
forM_ targetUserIds $ \targetUserId ->
case find
((== targetUserId) . fst)
(_tkUIDs (someTKToPublicViewTK 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 $ case targetTk of
SomePublicTK tk -> SomePublicTK tk {_tkUIDs = map updateUID (_tkUIDs tk)}
SomeSecretTK tk -> SomeSecretTK tk {_tkUIDs = map updateUID (_tkUIDs tk)}
createUIDCertification
:: Text -> SomeTK -> IO SignaturePayload
createUIDCertification targetUserId signerTk = do
signerSka <-
case signerTk of
SomeSecretTK secretTk ->
case _tkPrimaryKey secretTk of
KeyPktSecretPrimary _ ska -> pure ska
_ ->
failWith
KeyCannotCertify
"certify-userid: signer certificate has no secret key material"
SomePublicTK _ ->
failWith
KeyCannotCertify
"certify-userid: signer certificate has no secret key material"
let signerPkp =
keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK signerTk))
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
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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
(pkp, mSka) <-
case unlockedTk of
SomeSecretTK secretTk ->
pure $ case _tkPrimaryKey secretTk of
KeyPktSecretPrimary pkp ska -> (pkp, Just ska)
_ -> error "createKeyRevocation: unexpected primary key type"
SomePublicTK publicTk ->
pure $ case _tkPrimaryKey publicTk of
KeyPktPublicPrimary pkp -> (pkp, Nothing)
_ -> error "createKeyRevocation: unexpected primary key type"
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)
hasBadPrimaryKey :: SomeTK -> Bool
hasBadPrimaryKey stk =
primaryKeyTooSmallForVerification stk
|| hasHardPrimaryKeyRevocation stk
hasHardPrimaryKeyRevocation :: SomeTK -> Bool
hasHardPrimaryKeyRevocation stk =
any isHardKeyRevocation (_tkRevs (someTKToPublicViewTK stk))
where
isHardKeyRevocation sig = case sig of
SigV4 KeyRevocationSig _ _ hashedSubs _ _ _ ->
any hasHardReason hashedSubs
SigV6 KeyRevocationSig _ _ _ hashedSubs _ _ _ ->
any hasHardReason hashedSubs
_ -> False
where
hasHardReason (SigSubPacket _ (ReasonForRevocation reason _)) =
not (reason `elem` [KeySuperseded, KeyRetiredAndNoLongerUsed])
hasHardReason _ = False
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
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| CC.sinkList
when (null stdinTks) $
failWith
MissingInput
"update-key: no key found on standard input"
updateSourceTks <-
concat
<$> mapM
(\p -> loadVerifyTKsFromFile "update-key" p)
updateKeyMergeCerts
when (null updateSourceTks) $
failWith MissingInput "update-key: no update keys found"
stdinUnlocked <-
mapM
(unlockUpdateKeyMaterial "standard input" keyPasswords)
stdinTks
when (any hasBadPrimaryKey stdinUnlocked) $
failWith
PrimaryKeyBad
"update-key: primary key is too weak or hard-revoked"
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 ->
let mergedTkUnknown =
foldl'
(<>)
(someTKToUnknown targetTk)
( map
someTKToUnknown
( selectUpdateMergeInputs
cpt
updateKeyNoAddedCapabilities
targetTk
updateTks
)
)
in case fromUnknownToTKEither mergedTkUnknown of
Right mergedStk -> mergedStk
Left _ -> targetTk
)
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 . someTKToUnknown) 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
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| CC.sinkList
mergeInTks <-
concat
<$> mapM
(\p -> loadVerifyTKsFromFile "merge-certs" p)
mergeCertsFiles
let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks
output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedTks)
BL.putStr $
if mergeCertsNoArmor || BL.null output
then output
else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
mergeCertificatesForOutput
:: [SomeTK] -> [SomeTK] -> [SomeTK]
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 =
case fromUnknownToTKEither
(foldl' (<>) (someTKToUnknown base) (map someTKToUnknown rest)) of
Right mergedStk -> mergedStk
Left _ -> base
matchingMergeInputs =
filter ((== primary) . certificatePrimaryFingerprint) mergeInTks
mergedAll =
case fromUnknownToTKEither
( foldl'
(<>)
(someTKToUnknown mergedStdin)
(map someTKToUnknown matchingMergeInputs)
) of
Right mergedStk -> mergedStk
Left _ -> mergedStdin
in mergedAll
groupByPrimaryKey :: [SomeTK] -> [(SomeTK, [SomeTK])]
groupByPrimaryKey [] = []
groupByPrimaryKey (tk : rest) =
let primary = certificatePrimaryFingerprint tk
(samePrimary, differentPrimary) =
partition ((== primary) . certificatePrimaryFingerprint) rest
in (tk, samePrimary) : groupByPrimaryKey differentPrimary
certificatePrimaryFingerprint :: SomeTK -> B.ByteString
certificatePrimaryFingerprint =
BL.toStrict
. unFingerprint
. fingerprint
. keyPktPKPayload
. _tkPrimaryKey
. someTKToPublicViewTK
unlockUpdateKeyMaterial
:: String -> [BL.ByteString] -> SomeTK -> IO SomeTK
unlockUpdateKeyMaterial _ [] tk = pure tk
unlockUpdateKeyMaterial source keyPasswords tk =
unlockTransferableSecretKeyMaterial
"update-key failed"
source
"--with-key-password"
keyPasswords
tk
updateKeyHasSigningCapability :: POSIXTime -> SomeTK -> Bool
updateKeyHasSigningCapability cpt tk =
any
( \funKey ->
S.null (fkufs funKey) || S.member SignDataKey (fkufs funKey)
)
(tkToFunKeysAt cpt tk)
selectUpdateMergeInputs
:: POSIXTime
-> Bool
-> SomeTK
-> [SomeTK]
-> [SomeTK]
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 "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
{ 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
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 "sign" 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 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 -> [String] -> [BL.ByteString] -> IO [SomeTK]
loadSigningKeys context keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles
where
loadFromFile path = do
lbs <- loadInputFromFile context "file" path
packets <- decodeOpenPGPInput path lbs
tks <-
runConduitRes $
CL.sourceList packets
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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] -> SomeTK -> IO SomeTK
decryptSigningKeyMaterial path keyPasswords =
unlockTransferableSecretKeyMaterial
"sign failed"
path
"--with-key-password"
keyPasswords
unlockTransferableSecretKeyMaterial
:: String
-> FilePath
-> String
-> [BL.ByteString]
-> SomeTK
-> IO SomeTK
-- 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 stk = do
case stk of
SomePublicTK _ -> pure stk
SomeSecretTK tk -> do
let pkp = keyPktPKPayload (_tkPrimaryKey tk)
ska' <-
unlockSecretAddendum
context
path
passwordOption
keyPasswords
pkp
( case _tkPrimaryKey tk of
KeyPktSecretPrimary _ ska -> ska
_ ->
error
"unlockTransferableSecretKeyMaterial: expected secret primary key"
)
let primaryKey = KeyPktSecretPrimary pkp ska'
subs' <- mapM decryptSub (_tkSubs tk)
pure $
SomeSecretTK tk {_tkPrimaryKey = primaryKey, _tkSubs = subs'}
where
decryptSub :: MonadIO m => (KeyPkt k, b) -> m (KeyPkt k, b)
decryptSub (KeyPktSecretSubkey pkp ska, sigs) = do
ska' <-
unlockSecretAddendum
context
path
passwordOption
keyPasswords
pkp
ska
pure (KeyPktSecretSubkey pkp ska', sigs)
decryptSub other = pure other
unlockSecretAddendum
:: MonadIO m
=> String
-> FilePath
-> String
-> [BL.ByteString]
-> SomePKPayload
-> SKAddendum
-> m 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 -> SomeTK -> IO SomeTK
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
-> [SomeTK]
-> [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 -> SomeTK -> [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 -> SomeTK -> [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 EdSigningCurve25519 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 EdSigningCurve448 rawBytes) _) ->
case eitherCryptoError (Ed448.secretKey rawBytes) of
Left err ->
failWith
BadData
(ctx ++ " failed: bad Ed448 secret key: " ++ show err)
Right sk
| _keyVersion signerPKP == V6 -> signEd448 sk
| otherwise ->
case signDataWithEd448 st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
Just (SUUnencrypted (UnknownSKey rawBytes) _) ->
case () of
_
| isEd25519PKA (_pkalgo signerPKP) ->
do
normalized <- normalizeUnknownSecretForEdDSA ctx 32 rawBytes
case eitherCryptoError (Ed25519.secretKey normalized) of
Left err ->
failWith
BadData
(ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
Right sk
| _keyVersion signerPKP == V6 -> signEd25519 sk
| isEdDSAPKA (_pkalgo signerPKP) ->
case signDataWithEd25519Legacy st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
| otherwise ->
case signDataWithEd25519 st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
| isEd448PKA (_pkalgo signerPKP) ->
do
normalized <- normalizeUnknownSecretForEdDSA ctx 57 rawBytes
case eitherCryptoError (Ed448.secretKey normalized) of
Left err ->
failWith
BadData
(ctx ++ " failed: bad Ed448 secret key: " ++ show err)
Right sk
| _keyVersion signerPKP == V6 -> signEd448 sk
| otherwise ->
case signDataWithEd448 st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
_ ->
failWith
UnsupportedAsymmetricAlgo
( ctx
++ " failed: unsupported unknown signing key for algorithm "
++ show (_pkalgo signerPKP)
)
_ ->
failWith
BadData
(ctx ++ " failed: unsupported or encrypted signing key")
where
signEd25519 sk =
signWithV6Salt
(\salt -> signDataWithEd25519V6 st salt sk hsd usd payload)
signEd448 sk =
signWithV6Salt
(\salt -> signDataWithEd448V6 st salt sk hsd usd payload)
signRSAWithV6Salt privateKey =
signWithV6Salt
(\salt -> signDataWithRSAV6 st salt privateKey hsd usd payload)
signWithV6Salt signer = go [32, 64, 16, 20, 28, 48] []
where
go [] _ =
failWith
BadData
(ctx ++ " failed: unable to construct a valid v6 signature salt")
go (n : rest) tried = do
bytes <- getRandomBytes n
case signer (SignatureSalt (BL.fromStrict bytes)) of
Right sig -> pure sig
Left (SignV6SaltSizeMismatch _ expected _) ->
let expectedLen = fromIntegral expected
in if expectedLen `elem` tried
then
failWith
BadData
(ctx ++ " failed: unable to resolve v6 signature salt size")
else go (expectedLen : rest) (expectedLen : tried)
Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
signWithRSABuilder hashToUse privateKey =
let builder =
SP.addUnhashedSubs
(SubpacketList usd)
( SP.addHashedSubs
(SubpacketList hsd)
(SP.sigBuilderInit st hashToUse)
)
in case signDataWithRSABuilder builder privateKey payload of
Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
Right sig -> pure sig
normalizeUnknownSecretForEdDSA
:: String -> Int -> BL.ByteString -> IO B.ByteString
normalizeUnknownSecretForEdDSA ctx expectedLen rawLbs
| B.length raw == expectedLen = pure raw
| B.length raw >= 2 =
let bits =
(fromIntegral (B.index raw 0) `shiftL` 8)
.|. fromIntegral (B.index raw 1)
mpiBytes = (bits + 7) `div` 8
payload = B.drop 2 raw
in if B.length payload == mpiBytes && mpiBytes <= expectedLen
then pure (i2ospOf_ expectedLen (os2ip payload))
else bad
| otherwise = bad
where
raw = BL.toStrict rawLbs
bad =
failWith
BadData
( ctx
++ " failed: unsupported EdDSA secret key encoding (length="
++ show (B.length raw)
++ ")"
)
validateRSASigningKeySize :: String -> SomePKPayload -> IO ()
validateRSASigningKeySize ctx signerPKP =
case pubkeySize (_pubkey signerPKP) of
Right bits
| bits < 2048 ->
failWith
KeyCannotSign
( ctx
++ " failed: RSA signing keys smaller than 2048 bits are not supported"
)
| otherwise -> pure ()
Left err ->
failWith
BadData
(ctx ++ " failed: unable to determine RSA key size: " ++ err)
-- FIXME: clean this up
isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool
isEd25519PKA pka = fromFVal pka == 27
isEdDSAPKA pka = fromFVal pka == 22
isEd448PKA pka = fromFVal pka == 28
selectSigningHash
:: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm
selectSigningHash signerKeys recipientHashPrefs fallbackOrder =
fromMaybe
SHA512
(find (hashSupportedByAllSigners signerKeys) candidateOrder)
where
requestedPrefs =
if null recipientHashPrefs
then signerPrefs
else recipientHashPrefs
signerPrefs = concatMap fpreferredHashes signerKeys
filteredRequested = filter (hashSupportedByAllSigners signerKeys) requestedPrefs
filteredSignerPrefs = filter (hashSupportedByAllSigners signerKeys) signerPrefs
candidateOrder = filteredRequested ++ filteredSignerPrefs ++ fallbackOrder
legacySigningHashFallbackOrder :: [HashAlgorithm]
legacySigningHashFallbackOrder = [SHA512, SHA384, SHA256, SHA224]
rfc9580SigningHashFallbackOrder :: [HashAlgorithm]
rfc9580SigningHashFallbackOrder = [SHA3_512, SHA3_256, SHA512, SHA384, SHA256, SHA224]
hashSupportedByAllSigners :: [FunKey] -> HashAlgorithm -> Bool
hashSupportedByAllSigners signers ha =
not (isDeprecatedHashAlgorithm ha)
&& all (`signerSupportsHashAlgorithm` ha) signers
signerSupportsHashAlgorithm :: FunKey -> HashAlgorithm -> Bool
signerSupportsHashAlgorithm signer ha =
not (isDeprecatedHashAlgorithm ha)
&& case _pkalgo (fpkp signer) of
RSA -> rsaPKCS15SupportedHash ha
DeprecatedRSASignOnly -> rsaPKCS15SupportedHash ha
DeprecatedRSAEncryptOnly -> rsaPKCS15SupportedHash ha
_ -> not (isOtherHashAlgorithm ha)
rsaPKCS15SupportedHash :: HashAlgorithm -> Bool
rsaPKCS15SupportedHash SHA224 = True
rsaPKCS15SupportedHash SHA256 = True
rsaPKCS15SupportedHash SHA384 = True
rsaPKCS15SupportedHash SHA512 = True
rsaPKCS15SupportedHash _ = False
isDeprecatedHashAlgorithm :: HashAlgorithm -> Bool
isDeprecatedHashAlgorithm DeprecatedMD5 = True
isDeprecatedHashAlgorithm SHA1 = True
isDeprecatedHashAlgorithm RIPEMD160 = True
isDeprecatedHashAlgorithm _ = False
isOtherHashAlgorithm :: HashAlgorithm -> Bool
isOtherHashAlgorithm (OtherHA _) = True
isOtherHashAlgorithm _ = False
hashAlgorithmHeaderName :: HashAlgorithm -> String
hashAlgorithmHeaderName DeprecatedMD5 = "MD5"
hashAlgorithmHeaderName SHA1 = "SHA1"
hashAlgorithmHeaderName RIPEMD160 = "RIPEMD160"
hashAlgorithmHeaderName SHA224 = "SHA224"
hashAlgorithmHeaderName SHA256 = "SHA256"
hashAlgorithmHeaderName SHA384 = "SHA384"
hashAlgorithmHeaderName SHA512 = "SHA512"
hashAlgorithmHeaderName SHA3_256 = "SHA3-256"
hashAlgorithmHeaderName SHA3_512 = "SHA3-512"
hashAlgorithmHeaderName (OtherHA _) = "SHA512"
ensureCanonicalMIMETextInput :: BL.ByteString -> IO ()
ensureCanonicalMIMETextInput lbs = do
let bs = BL.toStrict lbs
when (B.any (> 0x7f) bs) $
failWith
ExpectedText
"sign: --micalg-out requires canonical 7-bit text data on standard input"
case TE.decodeUtf8' bs of
Left _ ->
failWith
ExpectedText
"sign: --micalg-out requires UTF-8 text data on standard input"
Right _ -> pure ()
when (not (canonicalCRLFLineEndings bs)) $
failWith
ExpectedText
"sign: --micalg-out requires CRLF line endings on standard input"
when (hasTrailingLineWhitespace bs) $
failWith
ExpectedText
"sign: --micalg-out requires no trailing line whitespace on standard input"
where
canonicalCRLFLineEndings bytes = go (B.unpack bytes)
where
go [] = True
go [13] = False
go (13 : 10 : rest) = go rest
go (13 : _) = False
go (10 : _) = False
go (_ : rest) = go rest
hasTrailingLineWhitespace bytes =
endsWithWhitespace bytes
|| trailingWhitespaceBeforeCRLF (B.unpack bytes)
endsWithWhitespace bytes =
case B.unsnoc bytes of
Just (_, c) -> c == 32 || c == 9
Nothing -> False
trailingWhitespaceBeforeCRLF (a : 13 : 10 : rest)
| a == 32 || a == 9 = True
| otherwise = trailingWhitespaceBeforeCRLF (13 : 10 : rest)
trailingWhitespaceBeforeCRLF (_ : rest) = trailingWhitespaceBeforeCRLF rest
trailingWhitespaceBeforeCRLF _ = False
ensureUTF8TextInput :: String -> BL.ByteString -> IO ()
ensureUTF8TextInput subcommand lbs =
case TE.decodeUtf8' (BL.toStrict lbs) of
Left _ ->
failWith
ExpectedText
(subcommand ++ ": --as=text requires UTF-8 text on standard input")
Right _ -> pure ()
renderMicalg :: [SignaturePayload] -> String
renderMicalg signatures =
case nub (mapMaybe signatureMicalg signatures) of
[micalg] -> micalg
_ -> ""
where
signatureMicalg (SigV4 _ _ ha _ _ _ _) = hashAlgorithmMicalg ha
signatureMicalg _ = Nothing
hashAlgorithmMicalg DeprecatedMD5 = Just "pgp-md5"
hashAlgorithmMicalg SHA1 = Just "pgp-sha1"
hashAlgorithmMicalg RIPEMD160 = Just "pgp-ripemd160"
hashAlgorithmMicalg SHA224 = Just "pgp-sha224"
hashAlgorithmMicalg SHA256 = Just "pgp-sha256"
hashAlgorithmMicalg SHA384 = Just "pgp-sha384"
hashAlgorithmMicalg SHA512 = Just "pgp-sha512"
hashAlgorithmMicalg SHA3_256 = Just "pgp-sha3-256"
hashAlgorithmMicalg SHA3_512 = Just "pgp-sha3-512"
hashAlgorithmMicalg (OtherHA _) = Nothing
signingFallbackTKs :: [Pkt] -> [SomeTK]
signingFallbackTKs packets =
[ SomeSecretTK
TK
{ _tkPrimaryKey = KeyPktSecretPrimary pkp ska
, _tkRevs = []
, _tkUIDs = []
, _tkUAts = []
, _tkSubs = []
}
| 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 -> SomeTK -> [FunKey]
tkToFunKeysAt pt stk =
catMaybes
( mainKey : case stk of
SomePublicTK _ -> map extractPublic (_tkSubs publicView)
SomeSecretTK secretTk -> map extractSecret (_tkSubs secretTk)
)
where
publicView = someTKToPublicViewTK stk
pkp = keyPktPKPayload (_tkPrimaryKey publicView)
mska = case stk of
SomeSecretTK secretTk -> case _tkPrimaryKey secretTk of
KeyPktSecretPrimary _ ska -> Just ska
_ -> Nothing
SomePublicTK _ -> Nothing
uids = _tkUIDs publicView
mainPreferredHashes = effectiveHashPreferencesAt pt stk
mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt stk
mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt stk
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
extractPublic :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey
extractPublic (KeyPktPublicSubkey spkp, sigs) =
return
( FunKey
spkp
Nothing
(fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
mainPreferredHashes
mainPreferredSymmetricAlgorithms
mainSupportsSEIPDv2
)
extractPublic _ = Nothing
extractSecret :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey
extractSecret (KeyPktSecretSubkey spkp sska, sigs) =
return
( FunKey
spkp
(Just sska)
(fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
mainPreferredHashes
mainPreferredSymmetricAlgorithms
mainSupportsSEIPDv2
)
extractSecret _ = Nothing
effectiveHashPreferencesAt
:: POSIXTime -> SomeTK -> [HashAlgorithm]
effectiveHashPreferencesAt pt tk =
concatMap toHashes $
fromMaybe
[]
( effectiveKeyPreferencesAt
(posixSecondsToUTCTime (realToFrac pt))
(someTKToPublicViewTK tk)
)
where
toHashes (PreferredHashAlgorithms hashes) = hashes
toHashes _ = []
effectiveSymmetricPreferencesAt
:: POSIXTime -> SomeTK -> [SymmetricAlgorithm]
effectiveSymmetricPreferencesAt pt tk =
concatMap toSymmetricAlgorithms $
fromMaybe
[]
( effectiveKeyPreferencesAt
(posixSecondsToUTCTime (realToFrac pt))
(someTKToPublicViewTK tk)
)
where
toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms
toSymmetricAlgorithms _ = []
effectiveSEIPDv2SupportAt :: POSIXTime -> SomeTK -> Bool
effectiveSEIPDv2SupportAt pt tk =
any supportsSEIPDv2Flag $
concatMap toFeatureFlags $
fromMaybe
[]
( effectiveKeyPreferencesAt
(posixSecondsToUTCTime (realToFrac pt))
(someTKToPublicViewTK 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
-> [SomeTK]
-> 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)
( map
(\(kp, sigs) -> (keyPktToPkt kp, sigs))
(_tkSubs (someTKToPublicViewTK 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
payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
when (encAs == AsText) $
ensureUTF8TextInput "encrypt" payload
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 "encrypt" 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
}
(Passphrase 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
}
(Passphrase password)
(mkClearPayload payload)
case encrypted of
Left err -> failWith BadData ("encrypt failed: " ++ show err)
Right (ciphertext, mRecoveredSession) -> do
forM_ sessionKeyOutFile $ \path ->
case mRecoveredSession of
Just recoveredSession ->
writeFileWithOutputExistsCheck
"encrypt"
path
( renderSessionKeyOutLine
(fromFVal (recoveredSessionAlgorithm recoveredSession))
(unSessionKey (recoveredSessionKey recoveredSession))
++ "\n"
)
Nothing ->
failWith
UnsupportedOption
"encrypt: --session-key-out unavailable for this password encryption mode"
pure (encryptedPayloadBytes ciphertext)
doEncryptForRecipients
:: EncryptProfile
-> AsBinaryText
-> BL.ByteString
-> [SignaturePayload]
-> [FunKey]
-> Maybe String
-> IO BL.ByteString
doEncryptForRecipients encryptProfile asMode payload signatures recipients sessionKeyOutFile = do
let targets = map recipientTargetFor recipients
payloadShape =
defaultRecipientPayloadShape
{ recipientPayloadDataType = literalDataType
, recipientPayloadUseOnePassSignatures = not (null signatures)
, recipientPayloadSignatures = signatures
}
result <-
if useStrictEncryptProfile
then
encryptForRecipients
RecipientEncryptRequest
{ recipientEncryptRequestTargets = targets
, recipientEncryptRequestPayloadShape = payloadShape
, recipientEncryptRequestPayload = BL.toStrict payload
, recipientEncryptRequestSymmetricOverride = symmetricOverride
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Nothing
, recipientEncryptRequestChunkSizeOverride = Nothing
, recipientEncryptRequestSaltOverride = Nothing
}
}
else
encryptForRecipients
RecipientEncryptRequest
{ recipientEncryptRequestTargets = targets
, recipientEncryptRequestPayloadShape = payloadShape
, recipientEncryptRequestPayload = BL.toStrict payload
, recipientEncryptRequestSymmetricOverride = symmetricOverride
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv1Overrides
{ recipientEncryptRequestIVOverride = Nothing
}
}
RecipientEncryptResult {..} <-
case result of
Left err ->
failWith
(sopFailureForPKESKEncryptError err)
("encrypt failed: " ++ renderPKESKEncryptError err)
Right val -> pure val
forM_ sessionKeyOutFile $ \path ->
writeFileWithOutputExistsCheck
"encrypt"
path
( renderSessionKeyOutLine
(fromFVal (pkeskSessionAlgorithm recipientEncryptSessionMaterial))
(unSessionKey (pkeskSessionKey recipientEncryptSessionMaterial))
++ "\n"
)
pure (runPut (Bin.put (Block recipientEncryptPackets)))
where
literalDataType =
case asMode of
AsBinary -> BinaryData
AsText -> UTF8Data
anyRecipientSupportsSEIPDv2 = any fsupportsSEIPDv2 recipients
symmetricOverride
| useStrictEncryptProfile =
preferredStrictSymmetric <|> Just AES256
| otherwise = preferredLegacySymmetric
isV6Recipient pkp = _keyVersion pkp == V6
useStrictEncryptProfile =
case encryptProfile of
EncryptProfileRFC9580 ->
anyRecipientSupportsSEIPDv2
|| any (isV6Recipient . fpkp) recipients
EncryptProfileRFC4880 ->
anyRecipientSupportsSEIPDv2
|| any (isV6Recipient . fpkp) recipients
preferredStrictSymmetric =
preferredRecipientSymmetric isSupportedStrictEncryptSymmetric
preferredLegacySymmetric =
preferredRecipientSymmetric isSupportedLegacyEncryptSymmetric
preferredRecipientSymmetric isSupported =
case filter
(not . null)
(map fpreferredSymmetricAlgorithms recipients) of
[] -> Nothing
(prefList : prefLists) ->
listToMaybe
[ candidate
| candidate <- filter isSupported prefList
, all (candidate `elem`) prefLists
]
isSupportedStrictEncryptSymmetric algo =
algo `elem` [AES128, AES192, AES256]
-- Legacy profile fallback should not hard-fail on deprecated/unsupported
-- recipient preferences (e.g. IDEA in AEADED interop fixtures).
isSupportedLegacyEncryptSymmetric algo =
algo `elem` [AES128, AES192, AES256]
recipientTargetFor funkey =
let recipient = fpkp funkey
recipientNeedsV6PKESK =
useStrictEncryptProfile
&& (fsupportsSEIPDv2 funkey || _keyVersion recipient == V6)
in if _keyVersion recipient == V6
then
recipientEncryptionTargetWithStrategyTyped
recipient
RecipientPreferV6W
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 ->
recipientEncryptionTargetWithStrategyTyped
x25519Recipient
RecipientPreferV6W
Nothing ->
recipientEncryptionTargetWithStrategyTyped
recipient
RecipientPreferV6W
else
recipientEncryptionTargetWithStrategyTyped
recipient
RecipientForceV3InteropW
DeprecatedRSAEncryptOnly ->
if recipientNeedsV6PKESK
then
recipientEncryptionTargetWithStrategyTyped
recipient
RecipientPreferV6W
else
recipientEncryptionTargetWithStrategyTyped
recipient
RecipientForceV3InteropW
RSA ->
if recipientNeedsV6PKESK
then
recipientEncryptionTargetWithStrategyTyped
recipient
RecipientPreferV6W
else
recipientEncryptionTargetWithStrategyTyped
recipient
RecipientForceV3InteropW
_ ->
if recipientNeedsV6PKESK
then
recipientEncryptionTargetWithStrategyTyped
recipient
RecipientPreferV6W
else recipientEncryptionTarget recipient
normalizeX25519CompatibleECDHRecipient pkp =
case _pubkey pkp of
ECDHPubKey (EdDSAPubKey EdSigningCurve25519 _) _ _ ->
Just
( PKPayload
(_keyVersion pkp)
(_timestamp pkp)
(_v3exp pkp)
X25519
(_pubkey pkp)
)
_ -> Nothing
parseEncryptProfile :: Maybe String -> IO EncryptProfile
parseEncryptProfile Nothing = pure EncryptProfileRFC9580
parseEncryptProfile (Just name) =
case resolveProfile name encryptProfiles of
Just p -> pure p
Nothing ->
failWith
UnsupportedProfile
("encrypt: unsupported profile " ++ name)
doDecrypt :: POSIXTime -> DecryptOptions -> IO ()
doDecrypt cpt DecryptOptions {..} = do
sessionKeys <- parseDecryptSessionKeys decSessionKeys
verificationOutputPath <-
resolveDecryptVerificationsOut decVerificationsOutFile
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 "decrypt" 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
data DecryptSessionKey
= DecryptSessionKey
{ decryptSessionKeyMaterial :: BL.ByteString
, decryptSessionKeyOutLine :: Maybe String
}
decryptInputCallback
:: IORef [BL.ByteString]
-> IORef [BL.ByteString]
-> String
-> IO BL.ByteString
decryptInputCallback _passwordQueue sessionKeyQueue prompt
| "PKESK session key material" `isInfixOf` prompt = do
mSessionKeyMaterial <-
atomicModifyIORef' sessionKeyQueue $ \keys ->
case keys of
[] -> ([], Nothing)
(k : rest) -> (rest, Just k)
case mSessionKeyMaterial of
Just sessionKeyMaterial -> pure sessionKeyMaterial
Nothing ->
failWith
CannotDecrypt
"decrypt failed: PKESK session key material required but not provided"
decryptInputCallback passwordQueue _ _ = do
mPassword <-
atomicModifyIORef' passwordQueue $ \passwords ->
case passwords of
[] -> ([], Nothing)
(p : rest) -> (rest, Just p)
case mPassword of
Just password -> pure password
Nothing ->
failWith
CannotDecrypt
"decrypt failed: passphrase required but not provided"
parseDecryptSessionKeys :: [String] -> IO [DecryptSessionKey]
parseDecryptSessionKeys = mapM parseSessionKeySpec
parseSessionKeySpec :: String -> IO DecryptSessionKey
parseSessionKeySpec spec =
case break (== ':') spec of
(_, "") -> do
material <- decodeHexBytes spec
pure
DecryptSessionKey
{ decryptSessionKeyMaterial = BL.fromStrict material
, decryptSessionKeyOutLine = sessionKeyOutLineFromMaterial material
}
(algoSpec, ':' : keyHex) -> do
algo <- parseAlgorithmOctet algoSpec
keyBytes <- decodeHexBytes keyHex
when (B.null keyBytes) $
failWith
BadData
"decrypt: --with-session-key key material cannot be empty"
pure
DecryptSessionKey
{ decryptSessionKeyMaterial =
BL.fromStrict (encodeOpenPGPSessionKey algo keyBytes)
, decryptSessionKeyOutLine =
Just (renderSessionKeyOutLine algo keyBytes)
}
_ -> failWith BadData "decrypt: invalid --with-session-key format"
resolveSessionKeyOut
:: Maybe String
-> [DecryptSessionKey]
-> [Pkt]
-> [PKESKRecipientKey]
-> [BL.ByteString]
-> IO (Maybe String)
resolveSessionKeyOut Nothing _ _ _ _ = pure Nothing
resolveSessionKeyOut (Just _) sessionKeys ciphertextPkts recipientKeys passwordCandidates =
case mapMaybe decryptSessionKeyOutLine sessionKeys of
(line : _) -> pure (Just line)
[] -> do
discoveredLine <-
recoverSessionKeyOutFromCiphertext
ciphertextPkts
recipientKeys
passwordCandidates
case discoveredLine of
Just line -> pure (Just line)
Nothing -> pure Nothing
recoverSessionKeyOutFromCiphertext
:: [Pkt]
-> [PKESKRecipientKey]
-> [BL.ByteString]
-> IO (Maybe String)
recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates =
case recoverFromSKESK of
Just line -> pure (Just line)
Nothing -> recoverFromLegacyRSAPKESK
where
recoverFromSKESK =
listToMaybe $
mapMaybe
( \(SKESKPayloadV4 sa s2k maybeEsk, passphrase) ->
case maybeEsk of
Nothing ->
case skesk2Key (SKESK4Packet sa s2k Nothing) passphrase of
Left _ -> Nothing
Right sessionKey ->
Just (renderSessionKeyOutLine (fromFVal sa) sessionKey)
Just esk ->
case skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase of
Left _ -> Nothing
Right (algo, sessionKey) ->
Just (renderSessionKeyOutLine (fromFVal algo) sessionKey)
)
[ (payload, passphrase)
| payload <- skeskPayloadsV4
, passphrase <- passwordCandidates
]
skeskPayloadsV4 =
mapMaybe
( \pkt ->
case pkt of
SKESKPkt (SKESKPayloadV4Packet payload) -> Just payload
_ -> Nothing
)
ciphertextPkts
recoverFromLegacyRSAPKESK =
recoverRSACombos
[(mpi, rsaKey) | mpi <- rsaPKESKMPIs, rsaKey <- rsaRecipientKeys]
recoverRSACombos [] = pure Nothing
recoverRSACombos ((mpi, rsaKey) : rest) = do
encodedResult <- decryptLegacyRSAPKESK rsaKey mpi
case encodedResult of
Left _ -> recoverRSACombos rest
Right encoded ->
case decodeOpenPGPEncodedSessionKey encoded of
Right (algo, keyBytes) ->
pure (Just (renderSessionKeyOutLine (fromFVal algo) keyBytes))
Left _ -> recoverRSACombos rest
rsaPKESKMPIs =
mapMaybe
( \pkt ->
case pkt of
PKESKPkt
(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka (mpi :| [])))
| pka == RSA || pka == DeprecatedRSAEncryptOnly ->
Just mpi
_ -> Nothing
)
ciphertextPkts
rsaRecipientKeys =
mapMaybe
( \keyInfo ->
case pkeskRecipientSKey keyInfo of
RSAPrivateKey (RSA_PrivateKey privateKey) -> Just privateKey
_ -> Nothing
)
recipientKeys
decryptLegacyRSAPKESK
:: RSA.PrivateKey -> MPI -> IO (Either String B.ByteString)
decryptLegacyRSAPKESK privateKey mpi = do
attempted <-
P15.decryptSafer privateKey (mpiToCiphertext privateKey mpi)
pure (first show attempted)
where
mpiToCiphertext rsaKey (MPI encodedMPI) =
let modulusBytes = rsaModulusOctets rsaKey
in i2ospOf_ modulusBytes encodedMPI
rsaModulusOctets rsaKey =
let modulusBits = integerBitLength (RSA.public_n (RSA.private_pub rsaKey))
in max 1 ((modulusBits + 7) `div` 8)
integerBitLength n
| n <= 0 = 0
| otherwise = go n 0
where
go 0 bits = bits
go val bits = go (val `div` 2) (bits + 1)
parseAlgorithmOctet :: String -> IO Word8
parseAlgorithmOctet algoSpec =
case readMaybe algoSpec :: Maybe Int of
Just octet
| octet >= 0 && octet <= 255 ->
case toFVal (fromIntegral octet) :: SymmetricAlgorithm of
OtherSA _ ->
failWith
BadData
("decrypt: unsupported --with-session-key algorithm: " ++ algoSpec)
_ -> pure (fromIntegral octet)
_ ->
failWith
BadData
("decrypt: invalid --with-session-key algorithm: " ++ algoSpec)
decodeHexBytes :: String -> IO B.ByteString
decodeHexBytes hex =
if odd (length hex)
then
failWith
BadData
"decrypt: hex key material must have an even number of digits"
else B.pack <$> go hex
where
go [] = pure []
go (a : b : rest) = do
hi <- nibble a
lo <- nibble b
(fromIntegral (hi * 16 + lo) :) <$> go rest
go _ = failWith BadData "decrypt: malformed hex key material"
nibble c =
if isHexDigit c
then pure (digitToInt c)
else failWith BadData "decrypt: key material must be hexadecimal"
isEncryptedPayloadPacket :: Pkt -> Bool
isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True
isEncryptedPayloadPacket SymEncDataPkt {} = True
isEncryptedPayloadPacket _ = False
isForwardCompatUnknownESKPacket :: Pkt -> Bool
isForwardCompatUnknownESKPacket (OtherPacketPkt tag _) = tag == 1 || tag == 3
isForwardCompatUnknownESKPacket (BrokenPacketPkt _ tag _) = tag == 1 || tag == 3
isForwardCompatUnknownESKPacket _ = False
isUnsupportedSKESKPacket :: Pkt -> Bool
isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ s2k _))) = isUnknownS2K s2k
isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ s2k _ _ _))) = isUnknownS2K s2k
isUnsupportedSKESKPacket _ = False
isUnknownS2K :: S2K -> Bool
isUnknownS2K OtherS2K {} = True
isUnknownS2K _ = False
validateCiphertextPacketLayout :: [Pkt] -> IO ()
validateCiphertextPacketLayout pkts =
case findIndex isEncryptedPayloadPacket pkts of
Nothing -> pure ()
Just payloadIndex ->
let trailing =
filter
(not . isMarkerPacketPacket)
(drop (payloadIndex + 1) pkts)
in when (not (null trailing)) $
failWith
BadData
"decrypt input: malformed encrypted message structure (unexpected packets after encrypted data)"
isMarkerPacketPacket :: Pkt -> Bool
isMarkerPacketPacket MarkerPkt {} = True
isMarkerPacketPacket _ = False
validateDecryptedMessageStructure :: [Pkt] -> [Pkt] -> IO ()
validateDecryptedMessageStructure rawPkts pkts = do
let literalCount = length [() | LiteralDataPkt {} <- pkts]
signatureCount = length [() | SignaturePkt {} <- pkts]
onePassCount = length [() | OnePassSignaturePkt {} <- pkts]
hasCompressedRaw = any isCompressedPacket rawPkts
hasUnknownPackets = any isUnknownPacket rawPkts || any isUnknownPacket pkts
maxCompressionDepth = maximum (0 : map compressionDepth rawPkts)
when (any compressedPacketParseFailed rawPkts) $
failWith
BadData
"decrypt failed: malformed compressed data stream"
when (maxCompressionDepth > 2) $
failWith
BadData
"decrypt failed: malformed encrypted message structure (excessive compression nesting)"
when (hasCompressedRaw && any isMarkerPacket pkts) $
failWith
BadData
"decrypt failed: malformed encrypted message structure (compressed marker packet)"
when (any isDisallowedDecryptedPacketType pkts) $
failWith
BadData
"decrypt failed: malformed encrypted message structure (unexpected packet type in plaintext)"
when (literalCount == 0) $
failWith
BadData
"decrypt failed: malformed encrypted message structure (no literal data payload found)"
when (literalCount > 1) $
failWith
BadData
"decrypt failed: malformed encrypted message structure (multiple literal payloads)"
when
(not hasUnknownPackets && onePassCount > 0 && signatureCount == 0)
$ failWith
BadData
"decrypt failed: malformed signed message structure (one-pass signature without trailing signature)"
when
( not hasUnknownPackets
&& signatureCount > 0
&& onePassCount == 0
&& not isOldStyleSignedMessage
)
$ failWith
BadData
"decrypt failed: malformed signed message structure (trailing signature without one-pass signature)"
where
isOldStyleSignedMessage =
case [i | (i, LiteralDataPkt {}) <- packetPositions] of
[literalIndex] ->
not (null signaturePositions)
&& all (< literalIndex) signaturePositions
_ -> False
packetPositions = zip [0 :: Int ..] (filter (not . isMarkerPacket) pkts)
signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]
compressedPacketParseFailed :: Pkt -> Bool
compressedPacketParseFailed pkt@CompressedDataPkt {} = isLeft (decompressPkt pkt)
compressedPacketParseFailed _ = False
recursivelyDecompressPacket
:: Pkt -> Either CompressionError [Pkt]
recursivelyDecompressPacket pkt@CompressedDataPkt {} = do
inner <- decompressPkt pkt
concat <$> mapM recursivelyDecompressPacket inner
recursivelyDecompressPacket pkt = Right [pkt]
compressedPacketIsEmpty :: Pkt -> Bool
compressedPacketIsEmpty pkt@CompressedDataPkt {} =
case decompressPkt pkt of
Right [] -> True
_ -> False
compressedPacketIsEmpty _ = False
isCompressedPacket :: Pkt -> Bool
isCompressedPacket CompressedDataPkt {} = True
isCompressedPacket _ = False
compressionDepth :: Pkt -> Int
compressionDepth pkt@CompressedDataPkt {} =
let inner = either (const []) id (decompressPkt pkt)
in if null inner
then 1
else 1 + maximum (0 : map compressionDepth inner)
compressionDepth _ = 0
isMarkerPacket :: Pkt -> Bool
isMarkerPacket MarkerPkt {} = True
isMarkerPacket _ = False
isUnknownPacket :: Pkt -> Bool
isUnknownPacket OtherPacketPkt {} = True
isUnknownPacket BrokenPacketPkt {} = True
isUnknownPacket _ = False
isDisallowedDecryptedPacketType :: Pkt -> Bool
isDisallowedDecryptedPacketType PKESKPkt {} = True
isDisallowedDecryptedPacketType SKESKPkt {} = True
isDisallowedDecryptedPacketType PublicKeyPkt {} = True
isDisallowedDecryptedPacketType PublicSubkeyPkt {} = True
isDisallowedDecryptedPacketType SecretKeyPkt {} = True
isDisallowedDecryptedPacketType SecretSubkeyPkt {} = True
isDisallowedDecryptedPacketType SymEncDataPkt {} = True
isDisallowedDecryptedPacketType SymEncIntegrityProtectedDataPkt {} = True
isDisallowedDecryptedPacketType _ = False
encodeOpenPGPSessionKey :: Word8 -> B.ByteString -> B.ByteString
encodeOpenPGPSessionKey algo keyBytes =
B.cons
algo
( keyBytes
<> B.pack [fromIntegral (checksum `div` 256), fromIntegral checksum]
)
where
checksum :: Int
checksum =
B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536
sessionKeyOutLineFromMaterial :: B.ByteString -> Maybe String
sessionKeyOutLineFromMaterial raw = do
(algo, keyBytes) <- decodeOpenPGPSessionKeyMaterial raw
pure (renderSessionKeyOutLine algo keyBytes)
decodeOpenPGPSessionKeyMaterial
:: B.ByteString -> Maybe (Word8, B.ByteString)
decodeOpenPGPSessionKeyMaterial raw = do
(algo, body) <- B.uncons raw
case toFVal (fromIntegral algo) :: SymmetricAlgorithm of
OtherSA _ -> Nothing
_ -> do
let bodyLen = B.length body
if bodyLen < 3
then Nothing
else do
let keyBytes = B.take (bodyLen - 2) body
checksumHi = fromIntegral (B.index body (bodyLen - 2)) :: Int
checksumLo = fromIntegral (B.index body (bodyLen - 1)) :: Int
checksumExpected = checksumHi * 256 + checksumLo
checksumActual =
B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536
if B.null keyBytes || checksumActual /= checksumExpected
then Nothing
else Just (algo, keyBytes)
renderSessionKeyOutLine :: Word8 -> B.ByteString -> String
renderSessionKeyOutLine algo keyBytes =
show algo ++ ":" ++ hexEncodeBytes keyBytes
hexEncodeBytes :: B.ByteString -> String
hexEncodeBytes = concatMap encodeByte . B.unpack
where
encodeByte w =
[ nibble (w `shiftR` 4)
, nibble (w .&. 0x0f)
]
nibble n = "0123456789abcdef" !! fromIntegral n
extractSingleLiteralPayload :: [Pkt] -> IO BL.ByteString
extractSingleLiteralPayload pkts =
case [p | LiteralDataPkt _ _ _ p <- pkts] of
[payload] -> pure payload
[] ->
failWith
BadData
"decrypt failed: malformed encrypted message structure (no literal data payload found)"
_ ->
failWith
BadData
"decrypt failed: malformed encrypted message structure (multiple literal data payloads found)"
doDecryptVerifyOutput
:: POSIXTime
-> [String]
-> Maybe String
-> Maybe String
-> Maybe String
-> [Pkt]
-> IO ()
doDecryptVerifyOutput cpt certFiles outFile notBeforeArg notAfterArg decryptedPkts = do
when (null certFiles) $
failWith
IncompleteVerification
"decrypt: verification requires at least one --verify-with cert"
(krs, verifyTks) <- loadVerifyContext cpt certFiles
upperBound <- verificationUpperBound cpt notAfterArg
lowerBound <- verificationLowerBound cpt notBeforeArg
verificationPkts <-
normalizeDecryptVerificationPackets decryptedPkts
let verifications =
map
(first show)
(verifyPacketsBatch krs upperBound verificationPkts)
filtered = filterByVerificationBounds lowerBound upperBound verifications
successLines =
map (renderSOPVerificationLine verifyTks) (rights filtered)
renderedOut =
if null successLines
then ""
else unlines successLines
case outFile of
Just path -> writeFileWithOutputExistsCheck "decrypt" path renderedOut
Nothing -> pure ()
normalizeDecryptVerificationPackets :: [Pkt] -> IO [Pkt]
normalizeDecryptVerificationPackets pkts =
case ( [pkt | pkt@LiteralDataPkt {} <- pkts]
, [pkt | pkt@SignaturePkt {} <- pkts]
) of
([], _) ->
failWith
CannotDecrypt
"decrypt failed: no literal data payload found"
([lit], []) -> pure [lit]
([lit], sigs) -> pure (lit : sigs)
(_, _) ->
failWith
BadData
"decrypt failed: malformed signed message structure (multiple literal payloads)"
resolveDecryptVerificationsOut
:: Maybe String -> IO (Maybe String)
resolveDecryptVerificationsOut newPath =
pure $ case newPath of
Just p -> Just p
Nothing -> Nothing
renderSOPVerificationLine
:: [SomeTK] -> Verification -> String
renderSOPVerificationLine verifyTks v =
ts
++ " "
++ signerFp
++ " "
++ certFp
++ " "
++ modeLabel
++ " "
++ jsonTrailer
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
(keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk)))
)
)
)
Nothing -> signerFp
jsonTrailer = "{\"signers\":[{\"fingerprint\":\"" ++ signerFp ++ "\"}]}"
signatureModeField :: SignaturePayload -> String
signatureModeField sig =
case sig of
SigV4 CanonicalTextSig _ _ _ _ _ _ -> "mode:text"
SigV6 CanonicalTextSig _ _ _ _ _ _ _ -> "mode:text"
_ -> "mode:binary"
renderSOPVerificationTimestamp :: SignaturePayload -> String
renderSOPVerificationTimestamp sig =
formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $
case signatureCreationTime sig of
Just t -> t
Nothing -> posixSecondsToUTCTime 0
writeFileWithOutputExistsCheck
:: String -> FilePath -> String -> IO ()
writeFileWithOutputExistsCheck subcommand path content = do
ensureOutputPathAvailable subcommand path
writeFile path content
parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
parseOpenPGPPackets context bytes =
( do
let packets =
concatMap
(either (const []) id . decompressPkt)
(parsePkts bytes)
_ <- evaluate (length packets)
pure packets
)
`catch` parseFailure
where
parseFailure :: SomeException -> IO [Pkt]
parseFailure err =
failWith
BadData
( context
++ ": failed to parse OpenPGP packets: "
++ displayException err
)
parseRawOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
parseRawOpenPGPPackets context bytes =
( do
let packets = parsePkts bytes
_ <- evaluate (length packets)
pure packets
)
`catch` parseFailure
where
parseFailure :: SomeException -> IO [Pkt]
parseFailure err =
failWith
BadData
( context
++ ": failed to parse OpenPGP packets: "
++ displayException err
)
validateDecryptPartialBodyEncoding :: BL.ByteString -> IO ()
validateDecryptPartialBodyEncoding ciphertext =
case ensureNoShortFirstPartialBodyChunk (BL.toStrict ciphertext) of
Left err ->
failWith
BadData
("decrypt input: invalid partial body encoding (" ++ err ++ ")")
Right () -> pure ()
ensureNoShortFirstPartialBodyChunk
:: B.ByteString -> Either String ()
ensureNoShortFirstPartialBodyChunk = parsePackets
where
parsePackets bs
| B.null bs = Right ()
| otherwise = do
(header, rest) <-
noteLeft "truncated packet header" (B.uncons bs)
if header .&. 0x80 /= 0x80
then Left "invalid packet header octet"
else do
remaining <-
if header .&. 0x40 == 0x40
then parseNewPacketBody rest
else parseOldPacketBody (header .&. 0x03) rest
parsePackets remaining
parseOldPacketBody lengthType bs =
case lengthType of
0 -> do
(lenOctet, rest) <-
noteLeft "truncated old-format one-octet length" (B.uncons bs)
dropExact
"truncated old-format packet body"
(fromIntegral lenOctet)
rest
1 -> do
(hi, afterHi) <-
noteLeft "truncated old-format two-octet length" (B.uncons bs)
(lo, rest) <-
noteLeft
"truncated old-format two-octet length"
(B.uncons afterHi)
let len = fromIntegral hi * 256 + fromIntegral lo
dropExact "truncated old-format packet body" len rest
2 -> do
(b1, afterB1) <-
noteLeft "truncated old-format four-octet length" (B.uncons bs)
(b2, afterB2) <-
noteLeft
"truncated old-format four-octet length"
(B.uncons afterB1)
(b3, afterB3) <-
noteLeft
"truncated old-format four-octet length"
(B.uncons afterB2)
(b4, rest) <-
noteLeft
"truncated old-format four-octet length"
(B.uncons afterB3)
let len =
(fromIntegral b1 `shiftL` 24)
+ (fromIntegral b2 `shiftL` 16)
+ (fromIntegral b3 `shiftL` 8)
+ fromIntegral b4
dropExact "truncated old-format packet body" len rest
3 -> Right B.empty
_ -> Left "invalid old-format length type"
parseNewPacketBody = parseNewLengthChunks True
parseNewLengthChunks isFirstChunk bs = do
(chunkLength, isPartial, afterLength) <- parseNewLength bs
when (isFirstChunk && isPartial && chunkLength < 512) $
Left
( "first partial chunk is too short ("
++ show chunkLength
++ " octets, minimum is 512)"
)
afterChunk <-
dropExact
"truncated new-format packet body chunk"
chunkLength
afterLength
if isPartial
then parseNewLengthChunks False afterChunk
else Right afterChunk
parseNewLength bs = do
(lengthOctet, rest) <-
noteLeft "truncated new-format length" (B.uncons bs)
case lengthOctet of
_
| lengthOctet < 192 ->
Right (fromIntegral lengthOctet, False, rest)
| lengthOctet < 224 -> do
(nextOctet, afterNext) <-
noteLeft "truncated new-format two-octet length" (B.uncons rest)
let len =
((fromIntegral lengthOctet - 192) `shiftL` 8)
+ fromIntegral nextOctet
+ 192
Right (len, False, afterNext)
| lengthOctet < 255 ->
Right
( 1 `shiftL` fromIntegral (lengthOctet .&. 0x1f)
, True
, rest
)
| otherwise -> do
(b1, afterB1) <-
noteLeft "truncated new-format five-octet length" (B.uncons rest)
(b2, afterB2) <-
noteLeft
"truncated new-format five-octet length"
(B.uncons afterB1)
(b3, afterB3) <-
noteLeft
"truncated new-format five-octet length"
(B.uncons afterB2)
(b4, afterB4) <-
noteLeft
"truncated new-format five-octet length"
(B.uncons afterB3)
let len =
(fromIntegral b1 `shiftL` 24)
+ (fromIntegral b2 `shiftL` 16)
+ (fromIntegral b3 `shiftL` 8)
+ fromIntegral b4
Right (len, False, afterB4)
dropExact context n bs
| B.length bs < n = Left context
| otherwise = Right (B.drop n bs)
noteLeft err = maybe (Left err) Right
ensureOutputPathAvailable :: String -> FilePath -> IO ()
ensureOutputPathAvailable subcommand path = do
exists <- doesFileExist path
when exists $
failWith
OutputExists
(subcommand ++ ": output path already exists: " ++ path)
loadVerifyContext
:: POSIXTime -> [String] -> IO (PublicKeyring, [SomeTK])
loadVerifyContext _ certFiles = do
allTks <-
mapMaybe enforceVerifyPrimaryKeyPolicy
. map sanitizeVerifyTK
. concat
<$> mapM (loadCertTKsFromFile "verify") certFiles
let publicTks =
mapMaybe
( \tk ->
case tk of
SomePublicTK publicTk -> Just publicTk
SomeSecretTK secretTk -> Just (publicViewTK secretTk)
)
allTks
keyring <-
runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap
pure (keyring, allTks)
loadVerifyTKsFromFile :: String -> String -> IO [SomeTK]
loadVerifyTKsFromFile context path = do
lbs <- loadInputFromFile context "file" path
certPkts <- decodeOpenPGPInput path lbs
runConduitRes $
CL.sourceList certPkts
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| CC.sinkList
loadCertTKsFromFile :: String -> String -> IO [SomeTK]
loadCertTKsFromFile context path = do
lbs <- loadInputFromFile context "file" path
certPkts <- decodeOpenPGPInput path lbs
rejectSecretKeyPackets context path certPkts
runConduitRes $
CL.sourceList certPkts
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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 :: SomeTK -> SomeTK
sanitizeVerifyTK stk =
case primaryKeyIdentity stk of
Nothing -> stk
Just _ ->
case stk of
SomePublicTK tk -> SomePublicTK tk {_tkSubs = map sanitize (_tkSubs tk)}
SomeSecretTK tk -> SomeSecretTK tk {_tkSubs = map sanitize (_tkSubs tk)}
where
publicView = someTKToPublicViewTK stk
pkp = keyPktPKPayload (_tkPrimaryKey publicView)
primaryFp = fingerprint pkp
primaryKeyId =
either
(error "sanitizeVerifyTK: no key ID")
id
(eightOctetKeyID pkp)
sanitize
:: (KeyPkt k, [SignaturePayload]) -> (KeyPkt k, [SignaturePayload])
sanitize (kp, sigs) =
let sanitized =
mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs
in if isSubkeyPacket (keyPktToPkt kp)
then (kp, sanitized)
else (kp, sigs)
isSubkeyPacket (PublicSubkeyPkt {}) = True
isSubkeyPacket (SecretSubkeyPkt {}) = True
isSubkeyPacket _ = False
enforceVerifyPrimaryKeyPolicy :: SomeTK -> Maybe SomeTK
enforceVerifyPrimaryKeyPolicy tk =
if primaryKeyTooSmallForVerification tk
then Nothing
else Just tk
primaryKeyTooSmallForVerification :: SomeTK -> Bool
primaryKeyTooSmallForVerification stk =
case _pkalgo pkp of
RSA -> rsaTooSmall
DeprecatedRSASignOnly -> rsaTooSmall
DeprecatedRSAEncryptOnly -> rsaTooSmall
_ -> False
where
pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))
rsaTooSmall =
case pubkeySize (_pubkey pkp) of
Right bits -> bits < 2048
Left _ -> False
primaryKeyIdentity
:: SomeTK -> Maybe (Fingerprint, EightOctetKeyId)
primaryKeyIdentity stk = do
let pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))
keyId <- either (const Nothing) Just (eightOctetKeyID pkp)
pure (fingerprint pkp, keyId)
sanitizeBindingSignature
:: Fingerprint
-> EightOctetKeyId
-> SignaturePayload
-> Maybe SignaturePayload
sanitizeBindingSignature _ _ sig
| hasUnsupportedCriticalSubpacket sig = Nothing
| hasUnsupportedCriticalEmbeddedBacksig sig = Nothing
| otherwise = Just sig
where
hasUnsupportedCriticalSubpacket sp =
any isUnsupportedCriticalSubpacket (signatureHashedSubpackets sp)
hasUnsupportedCriticalEmbeddedBacksig sp =
any
( \ssp ->
case _sspPayload ssp of
EmbeddedSignature embedded ->
any
isUnsupportedCriticalSubpacket
(signatureHashedSubpackets embedded)
_ -> False
)
(signatureHashedSubpackets sp)
isUnsupportedCriticalSubpacket (SigSubPacket isCritical payload) =
isCritical
&& case payload of
UserDefinedSigSub {} -> True
OtherSigSub {} -> True
NotationData {} -> True
_ -> False
loadDecryptRecipientKeys
:: POSIXTime
-> String
-> [String]
-> [BL.ByteString]
-> IO [PKESKRecipientKey]
loadDecryptRecipientKeys _ _ [] _ = pure []
loadDecryptRecipientKeys cpt context keyFiles passwords = concat <$> mapM loadFromFile keyFiles
where
loadFromFile path = do
lbs <- loadInputFromFile context "file" path
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
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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 = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk))
primaryFp = unFingerprint (fingerprint primaryPkp)
publicView = someTKToPublicViewTK tk
primarySigs =
concatMap snd (_tkUIDs publicView)
++ concatMap snd (_tkUAts publicView)
++ _tkRevs publicView
primaryEntry = [primaryFp | not (sigsAllowEncryption primarySigs)]
-- Subkeys: same rule as primary.
subEntries =
[ unFingerprint (fingerprint pkp)
| (kp, sigs) <- _tkSubs publicView
, let pkp = keyPktPKPayload kp
, 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 = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk))
publicView = someTKToPublicViewTK tk
primarySigs =
concatMap snd (_tkUIDs publicView)
++ concatMap snd (_tkUAts publicView)
++ _tkRevs publicView
primaryAllows =
supportsRecipientPKESKAlgorithm primaryPkp
&& sigsAllowEncryption primarySigs
subAllows =
any
( \(kp, sigs) ->
supportsRecipientPKESKAlgorithm (keyPktPKPayload kp)
&& sigsAllowEncryption sigs
)
(_tkSubs publicView)
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
]
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 <- loadInputFromFile "encrypt" "file" path
pkts <- decodeOpenPGPInput path lbs
rejectSecretKeyPackets "encrypt" path pkts
tks <-
runConduitRes $
CL.sourceList pkts
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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 <- loadInputFromFile "encrypt" "file" path
pkts <- decodeOpenPGPInput path lbs
rejectSecretKeyPackets "encrypt" path pkts
rejectCriticalUnknownRecipientPackets path pkts
tks <-
runConduitRes $
CL.sourceList pkts
.| conduitToSomeTKsDroppingEither
.| conduitDropErrorsAndNothings
.| 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))
(someTKToPublicViewTK 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 -> SomeTK -> Bool
primaryUserIDExpirationAllowsAt now tk =
case primaryUidSigs of
[] -> True
_ ->
any
(signatureKeyExpirationAllowsAt now primaryCreatedAt)
primaryUidSigs
where
publicView = someTKToPublicViewTK tk
primaryCreatedAt =
fromIntegral
(_timestamp (keyPktPKPayload (_tkPrimaryKey publicView)))
primaryUidSigs =
[ sig
| (_, sigs) <- _tkUIDs publicView
, 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 :: SomeTK -> [SomePKPayload]
tkToEncryptPayloads stk =
filter
supportsRecipientPKESKAlgorithm
(someTKToUnknown stk ^.. biplate :: [SomePKPayload])
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 EdSigningCurve25519 _) _ _ ->
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
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 "inline-sign" 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
then AA.encodeLazy [Armor ArmorMessage [] pktBytes]
else pktBytes
inlineSignModeReader :: String -> Either String InlineSignMode
inlineSignModeReader "binary" = Right InlineSignAsBinary
inlineSignModeReader "text" = Right InlineSignAsText
inlineSignModeReader "clearsigned" = Right InlineSignAsClearSigned
inlineSignModeReader _ =
Left "signature mode must be one of: binary, text, clearsigned"
isInlineSigningCapable :: FunKey -> Bool
isInlineSigningCapable k =
(S.null (fkufs k) || S.member SignDataKey (fkufs k))
&& case fmska k of
Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
Just (SUUnencrypted (UnknownSKey _) _) ->
isEd25519PKA (_pkalgo (fpkp k))
|| isEdDSAPKA (_pkalgo (fpkp k))
|| isEd448PKA (_pkalgo (fpkp k))
_ -> False
-- Legacy alias.
isInlineRSASigner :: FunKey -> Bool
isInlineRSASigner = isInlineSigningCapable
signInlineData
:: ThirtyTwoBitTimeStamp
-> AsBinaryText
-> HashAlgorithm
-> BL.ByteString
-> FunKey
-> IO SignaturePayload
signInlineData ts mode signHash payload k =
do
issuerPackets <- inlineUnhashed (fpkp k)
signWithKey
"inline-sign"
(fpkp k)
sigType
signHash
(inlineHashed (fpkp k) ts)
issuerPackets
payload
(fmska k)
where
sigType =
case mode of
AsBinary -> BinarySig
AsText -> CanonicalTextSig
inlineHashed
:: SomePKPayload -> ThirtyTwoBitTimeStamp -> [SigSubPacket]
inlineHashed pkp ts =
[ SigSubPacket False (SigCreationTime ts)
, SigSubPacket
False
( IssuerFingerprint
(issuerFingerprintVersionFor pkp)
(fingerprint pkp)
)
]
inlineUnhashed :: SomePKPayload -> IO [SigSubPacket]
inlineUnhashed pkp =
issuerSubpacketsFor "inline-sign" pkp
doInlineDetach :: POSIXTime -> InlineDetachOptions -> IO ()
doInlineDetach _ InlineDetachOptions {..} = do
ensureOutputPathAvailable "inline-detach" inlineDetachOutputSigs
input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
(msgData, sigPkts) <- splitInlineSigned input
writeDetachedSignatures
inlineDetachNoArmor
inlineDetachOutputSigs
sigPkts
BL.putStr msgData
splitInlineSigned :: BL.ByteString -> IO (BL.ByteString, [Pkt])
splitInlineSigned lbs = do
decodedArmors <- decodeAsciiArmorInput "inline-detach input" lbs
case decodedArmors of
Just armors ->
case firstBy isInlineSignedArmorCandidate armors of
Just (Armor ArmorMessage _ bs) ->
parseOpenPGPPackets
"inline-detach armored message"
(BL.fromStrict (BLC8.toStrict bs))
>>= splitInlineSignedPackets
Just (ClearSigned headers cleartext signatureArmor) -> do
validateClearSignedHeaders headers
sigPkts <- clearSignedSignaturePackets signatureArmor
return (BL.fromStrict (BLC8.toStrict cleartext), sigPkts)
_ ->
parseOpenPGPPackets "inline-detach input" lbs
>>= splitInlineSignedPackets
Nothing ->
parseOpenPGPPackets "inline-detach input" lbs
>>= splitInlineSignedPackets
firstBy :: (a -> Bool) -> [a] -> Maybe a
firstBy predicate = find predicate
decodeAsciiArmorInput
:: String -> BL.ByteString -> IO (Maybe [Armor])
decodeAsciiArmorInput context input =
case validateAsciiArmorEnvelope input of
Just err ->
failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
Nothing -> do
let primaryDecode = AA.decodeLazy input :: Either String [Armor]
case primaryDecode of
Right (_ : _) -> pure (Just (fromRight [] primaryDecode))
_ -> do
let normalizedInput = normalizeAsciiArmorForLenientDecode input
fallbackDecode =
if normalizedInput /= input
then AA.decodeLazy normalizedInput :: Either String [Armor]
else primaryDecode
case fallbackDecode of
Right []
| looksLikeAsciiArmor input ->
failWith
BadData
(context ++ ": malformed ASCII armor: no armor blocks found")
Right [] -> pure Nothing
Right armors -> pure (Just armors)
Left err
| looksLikeAsciiArmor input ->
failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
| otherwise -> pure Nothing
normalizeAsciiArmorForLenientDecode
:: BL.ByteString -> BL.ByteString
normalizeAsciiArmorForLenientDecode input
| not (looksLikeAsciiArmor input) = input
| otherwise =
BL.fromStrict
. TE.encodeUtf8
. T.unlines
. normalizeAsciiArmorLines
$ T.lines normalizedLineEndings
where
normalizedLineEndings =
T.replace
(T.pack "\r")
(T.pack "\n")
( T.replace
(T.pack "\r\n")
(T.pack "\n")
(TE.decodeUtf8 (BL.toStrict input))
)
data LenientArmorDecodeState
= LenientOutsideArmor
| LenientArmorHeaders Bool Bool
| LenientArmorBody Bool
normalizeAsciiArmorLines :: [Text] -> [Text]
normalizeAsciiArmorLines = go LenientOutsideArmor
where
go _ [] = []
go state (line : rest) =
let trimmedLine = T.dropWhileEnd isSpace line
whitespaceOnly = T.all isSpace line
beginLabel = beginArmorLabelText trimmedLine
isBegin = isJust beginLabel
isEnd = T.isPrefixOf (T.pack "-----END PGP ") trimmedLine
hasHeaderSeparator = T.any (== ':') trimmedLine
in case state of
LenientOutsideArmor
| isBegin ->
let isClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
shouldStripHeaders = not isClearSigned
in trimmedLine
: go (LenientArmorHeaders shouldStripHeaders isClearSigned) rest
| otherwise -> trimmedLine : go LenientOutsideArmor rest
LenientArmorHeaders stripHeaders isClearSigned
| whitespaceOnly ->
T.empty : go (LenientArmorBody isClearSigned) rest
| isEnd -> T.empty : trimmedLine : go LenientOutsideArmor rest
| stripHeaders && hasHeaderSeparator ->
go (LenientArmorHeaders stripHeaders isClearSigned) rest
| otherwise ->
trimmedLine : go (LenientArmorBody isClearSigned) rest
LenientArmorBody isClearSigned
| isEnd -> trimmedLine : go LenientOutsideArmor rest
| isBegin ->
let nestedClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
shouldStripHeaders = not nestedClearSigned
in trimmedLine
: go
(LenientArmorHeaders shouldStripHeaders nestedClearSigned)
rest
| otherwise ->
let bodyLine =
if isClearSigned
then line
else trimmedLine
in bodyLine : go (LenientArmorBody isClearSigned) rest
beginArmorLabelText :: Text -> Maybe Text
beginArmorLabelText line = do
rest <- T.stripPrefix (T.pack "-----BEGIN PGP ") line
T.stripSuffix (T.pack "-----") rest
validateClearSignedHeaders :: [(String, String)] -> IO ()
validateClearSignedHeaders headers =
unless (all (isAllowedHeaderKey . fst) headers) $
failWith
BadData
"cleartext signed message contains unsupported armor headers"
where
isAllowedHeaderKey hkey =
map toLower hkey `elem` ["hash"]
validateClearSignedEnvelopeBounds :: BL.ByteString -> IO ()
validateClearSignedEnvelopeBounds input = do
let text = TE.decodeUtf8With lenientDecode (BL.toStrict input)
normalized = T.replace (T.pack "\r") (T.pack "") text
ls = T.lines normalized
beginMarker = T.pack "-----BEGIN PGP SIGNED MESSAGE-----"
endMarker = T.pack "-----END PGP SIGNATURE-----"
firstBegin = findIndex ((== beginMarker) . T.strip) ls
hasVisibleText line = not (T.all isSpace line)
findIndexFrom start predicate =
fmap (+ start) (findIndex predicate (drop start ls))
case firstBegin of
Nothing -> pure ()
Just beginIx -> do
when (any hasVisibleText (take beginIx ls)) $
failWith
BadData
"cleartext signed message has non-whitespace text before armor header"
case findIndexFrom beginIx ((== endMarker) . T.strip) of
Nothing -> pure ()
Just endIx ->
when (any hasVisibleText (drop (endIx + 1) ls)) $
failWith
BadData
"cleartext signed message has non-whitespace text after signature block"
looksLikeAsciiArmor :: BL.ByteString -> Bool
looksLikeAsciiArmor input =
BLC8.pack "-----BEGIN PGP "
`BL.isPrefixOf` BLC8.dropWhile isAsciiArmorLeadingWhitespace input
isAsciiArmorLeadingWhitespace :: Char -> Bool
isAsciiArmorLeadingWhitespace c = c `elem` [' ', '\t', '\r', '\n']
validateAsciiArmorEnvelope :: BL.ByteString -> Maybe String
validateAsciiArmorEnvelope input
| not (looksLikeAsciiArmor input) = Nothing
| otherwise =
validateArmorBlocks
(BLC8.lines (BLC8.dropWhile isAsciiArmorLeadingWhitespace input))
validateArmorBlocks :: [BL.ByteString] -> Maybe String
validateArmorBlocks [] = Nothing
validateArmorBlocks (line : rest) =
case beginArmorLabel line of
-- UPSTREAM: openpgp-asciiarmor should export detectCleartextSignedBlock helper
-- to encapsulate this RFC 4880 cleartext signature framework detection
Just "SIGNED MESSAGE" -> validateClearSignedBlock rest
Just label -> validateBinaryArmorBlock label rest
Nothing -> Nothing
validateClearSignedBlock :: [BL.ByteString] -> Maybe String
validateClearSignedBlock ls =
case break hasBeginArmorLabel ls of
(_, []) ->
Just
"cleartext signed message is missing an armored signature block"
(_, beginLine : rest) ->
case beginArmorLabel beginLine of
Just "SIGNATURE" -> validateBinaryArmorBlock "SIGNATURE" rest
Just label ->
Just
( "cleartext signed message must be followed by a PGP SIGNATURE block, found PGP "
++ label
)
Nothing ->
Just
"cleartext signed message has an invalid armored signature header"
validateBinaryArmorBlock
:: String -> [BL.ByteString] -> Maybe String
validateBinaryArmorBlock label ls =
case break hasEndArmorLabel ls of
(_, []) -> Just ("missing END PGP " ++ label ++ " footer")
(_, endLine : rest) ->
case endArmorLabel endLine of
Just endLabel
| endLabel == label -> validateArmorBlocks rest
| otherwise ->
Just
( "mismatched footer: expected END PGP "
++ label
++ ", found END PGP "
++ endLabel
)
Nothing -> Just ("invalid END PGP " ++ label ++ " footer")
hasBeginArmorLabel :: BL.ByteString -> Bool
hasBeginArmorLabel = isJust . beginArmorLabel
hasEndArmorLabel :: BL.ByteString -> Bool
hasEndArmorLabel = isJust . endArmorLabel
beginArmorLabel :: BL.ByteString -> Maybe String
beginArmorLabel = armorBoundaryLabel "-----BEGIN PGP " "-----"
endArmorLabel :: BL.ByteString -> Maybe String
endArmorLabel = armorBoundaryLabel "-----END PGP " "-----"
armorBoundaryLabel
:: String -> String -> BL.ByteString -> Maybe String
armorBoundaryLabel prefix suffix line = do
rest <- stripPrefix prefix (BLC8.unpack line)
if suffix `isSuffixOf` rest
then pure (take (length rest - length suffix) rest)
else Nothing
isOpenPGPArmorBlock :: Armor -> Bool
isOpenPGPArmorBlock (Armor _ _ _) = True
isOpenPGPArmorBlock _ = False
isArmorMessageBlock :: Armor -> Bool
isArmorMessageBlock (Armor ArmorMessage _ _) = True
isArmorMessageBlock _ = False
isDetachedSignatureArmor :: Armor -> Bool
isDetachedSignatureArmor (Armor ArmorSignature _ _) = True
isDetachedSignatureArmor _ = False
isDetachedSignatureUnsupportedArmor :: Armor -> Bool
isDetachedSignatureUnsupportedArmor (Armor _ _ _) = True
isDetachedSignatureUnsupportedArmor ClearSigned {} = True
isClearSignedArmor :: Armor -> Bool
isClearSignedArmor ClearSigned {} = True
isClearSignedArmor _ = False
isInlineSignedArmorCandidate :: Armor -> Bool
isInlineSignedArmorCandidate (Armor ArmorMessage _ _) = True
isInlineSignedArmorCandidate ClearSigned {} = True
isInlineSignedArmorCandidate _ = False
splitInlineSignedPackets :: [Pkt] -> IO (BL.ByteString, [Pkt])
splitInlineSignedPackets pkts = do
let msgPkts = [p | p@LiteralDataPkt {} <- pkts]
sigPkts = [p | p@SignaturePkt {} <- pkts]
case msgPkts of
[LiteralDataPkt _ _ _ payload]
| null sigPkts ->
failWith BadData "inline-detach input has no signatures"
| otherwise -> return (payload, sigPkts)
[] ->
failWith
BadData
"inline-detach input has no literal message payload"
_ ->
failWith
BadData
"inline-detach input contains multiple literal payloads"
writeDetachedSignatures :: Bool -> String -> [Pkt] -> IO ()
writeDetachedSignatures noArmor outPath sigPkts = do
let sigBytes = runPut $ mapM_ Bin.put sigPkts
out =
if noArmor
then sigBytes
else
BL.fromStrict
(BLC8.toStrict (AA.encodeLazy [Armor ArmorSignature [] sigBytes]))
BL.writeFile outPath out
doListProfiles :: ListProfilesOptions -> IO ()
doListProfiles lpos =
( case profileSubcommand lpos of
"generate-key" ->
mapM_
( \p ->
putStrLn $
profileName p ++ ": " ++ profileDescription p ++ aliasesSuffix p
)
keyGenProfiles
"encrypt" ->
mapM_
( \p ->
putStrLn $
profileName p ++ ": " ++ profileDescription p ++ aliasesSuffix p
)
encryptProfiles
_ ->
failWith
UnsupportedProfile
"Subcommand does not support profiles"
)
where
aliasesSuffix p = case profileAliases p of
[] -> ""
s : [] -> " (alias: " ++ s ++ ")"
as -> " (aliases: " ++ intercalate ", " as ++ ")"
hopenpgp-tools-0.25.5/hopenpgp-tools.cabal 0000644 0000000 0000000 00000011363 07346545000 016720 0 ustar 00 0000000 0000000 cabal-version: 3.0
name: hopenpgp-tools
version: 0.25.5
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.2 && < 3.3
, 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
, HOpenPGP.Tools.Common.TKUtils
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.5
hopenpgp-tools-0.25.5/hot.hs 0000644 0000000 0000000 00000021043 07346545000 014100 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 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)
import Prettyprinter
( Pretty
, group
, hardline
, list
, pretty
, softline
, (<+>)
)
import Prettyprinter.Render.Text (hPutDoc)
import System.Exit (exitFailure)
import System.IO
( BufferMode (..)
, Handle
, hFlush
, hPutStrLn
, hSetBuffering
, stderr
, stdin
, stdout
)
import HOpenPGP.Tools.Common.Armor (doDeArmor)
import HOpenPGP.Tools.Common.Common
( banner
, prependAuto
, versioner
, warranty
)
import HOpenPGP.Tools.Common.Parser (parsePExp)
data Command
= DumpC DumpOptions
| DeArmorC
| ArmorC ArmoringOptions
| FilterC FilteringOptions
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 :: (MonadIO m, Show a) => ConduitM a Void m ()
printer = CL.mapM_ (liftIO . print)
prettyPrinter :: (MonadIO m, Pretty a) => 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 :: (MonadIO m, Y.ToJSON a) => ConduitM a Void m ()
yamlSink = CL.mapM_ (liftIO . B.putStr . flip B.snoc 0x0a . Y.encode)
doFilter :: FilteringOptions -> IO ()
doFilter fo =
parseExpressions fo >>= \parsed ->
case parsed of
Left err -> dieHot err
Right predicates ->
runConduitRes $
CB.sourceHandle stdin
.| conduitGet (get :: Get Pkt)
.| conduitPktFilter predicates
.| CL.map put
.| conduitPut
.| CB.sinkHandle stdout
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 v -> v
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