hopenpgp-tools-0.25.2: HOpenPGP/Tools/Hokey/Lint.hs
-- 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 <http://www.gnu.org/licenses/>.
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module HOpenPGP.Tools.Hokey.Lint
( doLint
) where
import Codec.Encryption.OpenPGP.Expirations
( getKeyExpirationTimesFromSignature
)
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.KeyInfo
( pkalgoAbbrev
, pubkeySize
)
import Codec.Encryption.OpenPGP.Ontology
( isCT
, isCertRevocationSig
, isKUF
, isPHA
, isPKBindingSig
, isSKBindingSig
)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Control.Arrow ((***))
import Control.Error.Util (hush)
import Control.Lens ((&), (^.), _1)
import Control.Monad (join, void)
import Control.Monad.Trans.Writer.Lazy (execWriter, tell)
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
import qualified Data.Aeson as A
import Data.Binary (get)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Foldable (find, maximumBy, sequenceA_, traverse_)
import Data.List (elemIndex, findIndex, intercalate, nub, sortOn)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord (comparing)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock.POSIX
( POSIXTime
, getPOSIXTime
, posixSecondsToUTCTime
)
import Data.Time.Format (formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import qualified Data.Yaml as Y
import GHC.Generics
import Prettyprinter
( Doc
, annotate
, colon
, flatAlt
, indent
, line
, list
, pretty
, vsep
, (<+>)
)
import qualified Prettyprinter.Render.Terminal as PPA
import System.IO
( stdin
)
import HOpenPGP.Tools.Common.Common
( renderFingerprint
, renderKeyID
)
import HOpenPGP.Tools.Common.TKUtils (processTK)
import HOpenPGP.Tools.Hokey.Options
( LintOptions (..)
, LintOutputFormat (..)
)
linebreak :: Doc ann
linebreak = flatAlt line mempty
green, yellow, red :: Doc PPA.AnsiStyle -> Doc PPA.AnsiStyle
green = annotate (PPA.color PPA.Green)
yellow = annotate (PPA.color PPA.Yellow)
red = annotate (PPA.color PPA.Red)
data KAS
= KAS
{ pubkeyalgo :: Result PubKeyAlgorithm
, pubkeysize :: Result (Maybe Int)
, stringrep :: String
}
deriving (Generic)
data Color
= Green
| Yellow
| Red
deriving (Eq, Generic, Ord)
data Result a = Result
{ resultColor :: Maybe Color
, resultFindings :: Maybe [String]
, resultValue :: a
}
deriving (Functor, Generic)
instance Applicative Result where
pure x = Result Nothing Nothing x
(Result c1 e1 f) <*> (Result c2 e2 x) =
Result (max c1 c2) (e1 <> e2) (f x)
instance Monad Result where
(Result c1 e1 x) >>= f =
let Result c2 e2 y = f x
in Result (max c1 c2) (e1 <> e2) y
colored :: Maybe Color -> Maybe [String] -> a -> Result a
colored c e x = Result c e x
withColor :: Maybe Color -> a -> Result a
withColor c x = Result c Nothing x
getResult :: Result a -> a
getResult (Result _ _ x) = x
newtype LintPolicy src a
= LintPolicy
{ unPolicy :: src -> Maybe POSIXTime -> Result a
}
deriving (Functor, Generic)
instance Applicative (LintPolicy src) where
pure x = LintPolicy (\_ _ -> pure x)
(LintPolicy f) <*> (LintPolicy x) = LintPolicy (\src mpt -> f src mpt <*> x src mpt)
data KeyReport
= KeyReport
{ keyStatus :: Result String
, keyFingerprint :: Result Fingerprint
, keyVer :: Result KeyVersion
, keyCreationTime :: Result ThirtyTwoBitTimeStamp
, keyAlgorithmAndSize :: Result KAS
, keyUIDsAndUAts :: Map.Map Text (Result UIDReport)
, keyBestOf :: Maybe UIDReport
, keySubkeys :: [Result SubkeyReport]
, keyHasEncryptionCapableSubkey :: Result Bool
}
deriving (Generic)
data UIDReport
= UIDReport
{ uidSelfSigHashAlgorithms :: [Result HashAlgorithm]
, uidPreferredHashAlgorithms :: [Result [HashAlgorithm]]
, uidKeyExpirationTimes :: [Result [ThirtyTwoBitDuration]]
, uidKeyUsageFlags :: [Result (Set.Set KeyFlag)]
, uidRevocationStatus :: [RevocationStatus]
}
deriving (Generic)
data SubkeyReport
= SubkeyReport
{ skFingerprint :: Result Fingerprint
, skVer :: Result KeyVersion
, skCreationTime :: ThirtyTwoBitTimeStamp
, skAlgorithmAndSize :: Result KAS
, skBindingSigHashAlgorithms :: [Result HashAlgorithm]
, skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning]
, skUsageFlags :: [Result (Set.Set KeyFlag)]
, skCrossCerts :: CrossCertReport
}
deriving (Generic)
data SubkeyRevocationDigestWarning
= SubkeyRevocationDigestWarning
{ srwHashAlgorithm :: HashAlgorithm
, srwSubkeyFingerprint :: String
, srwSubkeyKeyID :: Maybe String
, srwMessage :: String
}
deriving (Generic)
data CrossCertReport
= CrossCertReport
{ ccPresent :: Result Bool
, ccHashAlgorithms :: [Result HashAlgorithm]
}
deriving (Generic)
data RevocationStatus
= RevocationStatus
{ isRevoked :: Bool
, revocationCode :: String
, revocationReason :: Text
}
deriving (Generic)
instance A.ToJSON KAS
instance A.ToJSON Color
instance (A.ToJSON a) => A.ToJSON (Result a)
instance A.ToJSON KeyReport
instance A.ToJSON UIDReport
instance A.ToJSON SubkeyReport
instance A.ToJSON SubkeyRevocationDigestWarning
instance A.ToJSON CrossCertReport
instance A.ToJSON RevocationStatus
instance Semigroup UIDReport where
(<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') =
UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e')
instance Monoid UIDReport where
mempty = UIDReport [] [] [] [] []
mappend = (<>)
checkKey :: LintPolicy TKUnknown KeyReport
checkKey = LintPolicy $ \tk mpt -> checkKey' mpt tk
checkKey' :: Maybe POSIXTime -> TKUnknown -> Result KeyReport
checkKey' mpt tk =
kr
<$ sequenceA_
[ void (keyStatus kr)
, void (keyFingerprint kr)
, void (keyVer kr)
, void (keyAlgorithmAndSize kr)
, void (keyHasEncryptionCapableSubkey kr)
, traverse_ void (keySubkeys kr)
, traverse_ void (keyUIDsAndUAts kr)
]
where
kr =
KeyReport
{ keyStatus = pure (either id (const "good") procResult)
, keyFingerprint = pure (fingerprint primaryKey)
, keyVer = colorizeKV (_keyVersion primaryKey)
, keyCreationTime = pure (_timestamp primaryKey)
, keyAlgorithmAndSize = kasIt primaryKey
, keyUIDsAndUAts = uidMap
, keyBestOf = populateBestOf uidMap
, keySubkeys = subkeys
, keyHasEncryptionCapableSubkey =
hasEncryptionCapableSubkey
(concatMap (skUsageFlags . getResult) subkeys)
}
uidMap =
Map.fromListWith (liftA2 (<>)) $
map
(\(x, y) -> (x, uidr (Just x) y))
(processedTK ^. tkuUIDs)
++ map
(uatspsToText *** uidr Nothing)
(processedTK ^. tkuUAts)
subkeys =
map (checkSK (fingerprint primaryKey)) (processedTK ^. tkuSubs)
procResult = processTK mpt tk
processedTK = either (const tk) id procResult
primaryKey = processedTK ^. tkuKey . _1
uidr :: Maybe Text -> [SignaturePayload] -> Result UIDReport
uidr Nothing sps =
UIDReport
<$> pure (has sps)
<*> pure (map phas sps)
<*> pure
( map
( colorizeKETs
(fromMaybe 0 mpt)
(unThirtyTwoBitTimeStamp (_timestamp primaryKey))
. getKeyExpirationTimesFromSignature
)
sps -- should that be 0?
)
<*> pure (kufs False sps)
<*> pure (findRevocationReason sps)
uidr (Just u) sps =
colorizeUID
u
( UIDReport
(has sps)
(map phas sps)
( map
( colorizeKETs
(fromMaybe 0 mpt)
(unThirtyTwoBitTimeStamp (_timestamp primaryKey))
. getKeyExpirationTimesFromSignature
)
sps -- should that be 0?
)
(kufs False sps)
(findRevocationReason sps)
)
kasIt :: SomePKPayload -> Result KAS
kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize)
kasIt' :: PubKeyAlgorithm -> Either String Int -> Result KAS
kasIt' pka epks =
let pr = colorizePKA pka
prs = colorizePKS pka epks
strRep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka)
in colored
(max (resultColor pr) (resultColor prs))
(resultFindings pr <> resultFindings prs)
(KAS pr prs strRep)
colorizeKV :: KeyVersion -> Result KeyVersion
colorizeKV kv
| kv `elem` [V4, V6] = withColor (Just Green) kv
| otherwise =
colored (Just Red) (Just ["not a V4 or V6 key"]) kv
colorizePKA :: PubKeyAlgorithm -> Result PubKeyAlgorithm
colorizePKA pka
| pka `elem` [RSA, EdDSA, ECDH, X25519, X448] -- FIXME: incomplete
=
colored (Just Green) Nothing pka
| otherwise =
colored
(Just Yellow)
(Just ["public key algorithm neither RSA nor EdDSA"])
pka
colorizePKS
:: PubKeyAlgorithm -> Either String Int -> Result (Maybe Int)
colorizePKS pka (Right pks)
-- Group 256-bit ECC curves
| pka `elem` [X25519, ECDH, EdDSA] && pks >= 256 -- FIXME: incomplete
=
withColor (Just Green) (Just pks)
-- Group 448-bit ECC curves
| pka `elem` [X448] && pks >= 448 -- FIXME: incomplete
=
withColor (Just Green) (Just pks)
-- Catch-all for undersized ECC curves
| pka `elem` [X25519, X448, ECDH, EdDSA] -- FIXME: incomplete
=
colored
(Just Yellow)
(Just ["Public key size insufficient for ECC algorithm"])
(Just pks)
-- RSA size checks
| pka == RSA && pks >= 3072 =
withColor (Just Green) (Just pks)
| pka == RSA && pks >= 2048 =
colored
(Just Yellow)
(Just ["Public key size between 2048 and 3072 bits"])
(Just pks)
| pka == RSA =
colored
(Just Red)
(Just ["Public key size under 2048 bits"])
(Just pks)
-- Fallback for unknown algorithms but known sizes
| otherwise =
pure (Just pks)
colorizePKS _ (Left _) =
colored
(Just Red)
(Just ["public key algorithm not understood"])
Nothing
colorizePHAs :: [HashAlgorithm] -> Result [HashAlgorithm]
colorizePHAs x
| preferredWeakHash x =
colored (Just Red) (Just ["weak hash with higher preference"]) x
| otherwise = withColor (Just Green) x
fSHA2or3Family =
fi (`elem` [SHA512, SHA384, SHA256, SHA224, SHA3_512, SHA3_256])
firstStrongSHA2or3 xs = fSHA2or3Family xs
preferredWeakHash xs =
any
( \ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2or3 xs
)
knownWeakHashAlgorithms
fi x y = fromMaybe maxBound (findIndex x y)
colorizeKETs ct ts kes
| null kes = colored (Just Red) (Just ["no expiration set"]) kes
| any (\ke -> realToFrac ts + realToFrac ke < ct) kes =
colored (Just Red) (Just ["expiration passed"]) kes
| any
(\ke -> realToFrac ts + realToFrac ke > ct + (5 * 31557600))
kes =
colored (Just Yellow) (Just ["expiration too far in future"]) kes
| otherwise = colored (Just Green) Nothing kes
eoki pkp
| _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp
| _keyVersion pkp == DeprecatedV3
&& elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] =
hush . eightOctetKeyID $ pkp
| otherwise = Nothing
phas sig =
colorizePHAs
( concatMap
( \case
SigSubPacket _ (PreferredHashAlgorithms x) -> x
_ -> []
)
(filter isPHA (hasheds sig))
)
has = map (colorizeHA . hashAlgo) . alleged
colorizeHA :: HashAlgorithm -> Result HashAlgorithm
colorizeHA ha
| isKnownWeakHashAlgorithm ha =
colored (Just Red) (Just ["weak hash algorithm"]) ha
| otherwise = pure ha
sigcts sig =
map
( \case
SigSubPacket _ (SigCreationTime x) -> x
_ -> error "unexpected subpacket type"
)
(filter isCT (hasheds sig))
alleged =
filter
( \sig ->
primaryFingerprint `elem` sigissuerFPs sig
|| ((==) <$> sigissuer sig <*> eoki primaryKey)
== Just True
)
where
primaryFingerprint = fingerprint primaryKey
uatspsToText = T.pack . uatspsToString
uatspsToString us =
"<uat:[" ++ intercalate "," (map uaspToString us) ++ "]>"
uaspToString (ImageAttribute hdr d) =
hdrToString hdr
++ ':'
: show (BL.length d)
++ ':'
: BC8.unpack
(Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
uaspToString (OtherUASub t d) =
"other-"
++ show t
++ ':'
: show (BL.length d)
++ ':'
: BC8.unpack
(Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d)))
hdrToString (ImageHV1 JPEG) = "jpeg"
hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)
populateBestOf
:: Map.Map Text (Result UIDReport) -> Maybe UIDReport
populateBestOf um
| Map.null um = Nothing
| otherwise =
Just
( UIDReport
<$> best . uidSelfSigHashAlgorithms
<*> best
. uidPreferredHashAlgorithms
<*> best
. uidKeyExpirationTimes
<*> best
. uidKeyUsageFlags
<*> pure []
$ mconcat (justTheUIDRs um)
)
justTheUIDRs = map getResult . Map.elems
-- Pick the single most favorable Result from a list, for display as
-- a representative "best of" example.
--
-- This doesn't use Ord because there could be a Nothing in the list
-- and that would be "best".
--
-- That also implies that this should get an overhaul.
best :: [Result a] -> [Result a]
best = take 1 . sortOn (bestOfRank . resultColor)
bestOfRank :: Maybe Color -> Int
bestOfRank (Just Green) = 0
bestOfRank (Just Yellow) = 1
bestOfRank (Just Red) = 2
bestOfRank Nothing = 3
colorizeUID :: Text -> UIDReport -> Result UIDReport
colorizeUID u ur =
let strU = T.unpack u
check cond msg =
if cond
then colored (Just Yellow) (Just [msg]) ()
else pure ()
in check ('(' `elem` strU) "parenthesis in uid"
*> check ('<' `notElem` strU) "no left angle bracket in uid"
*> pure ur
findRevocationReason = concatMap grabReasons . filter isCertRevocationSig
grabReasons (SigV4 CertRevocationSig _ _ hashedSubs _ _ _) =
mapMaybe (grabReasons' . _sspPayload) hashedSubs
grabReasons (SigV6 CertRevocationSig _ _ _ hashedSubs _ _ _) =
mapMaybe (grabReasons' . _sspPayload) hashedSubs
grabReasons _ = []
grabReasons' (ReasonForRevocation a b) =
Just (RevocationStatus True (show a) b)
grabReasons' _ = Nothing
kufs s =
mapMaybe
( \sig ->
case find isKUF (hasheds sig) of
Just (SigSubPacket _ (KeyFlags x)) -> Just (colorizeKUFs s x)
_ -> Nothing
)
. newestWith (any isKUF . hasheds)
colorizeKUFs
:: Bool -> Set.Set KeyFlag -> Result (Set.Set KeyFlag)
colorizeKUFs False x
| encrypts && signsOrCertifies =
colored (Just Yellow) (Just ["both signing & encryption"]) x
| otherwise = withColor (Just Green) x
where
encrypts =
Set.member EncryptStorageKey x
|| Set.member EncryptCommunicationsKey x
signsOrCertifies = Set.member SignDataKey x || Set.member CertifyKeysKey x
colorizeKUFs True x
| certifies =
colored (Just Red) (Just ["certification-capable subkey"]) x
| encryptsAndSigns =
colored (Just Yellow) (Just ["both signing & encryption"]) x
| otherwise = withColor (Just Green) x
where
certifies = Set.member CertifyKeysKey x
encryptsAndSigns =
( Set.member EncryptStorageKey x
|| Set.member EncryptCommunicationsKey x
)
&& Set.member SignDataKey x
sigTime :: SignaturePayload -> ThirtyTwoBitTimeStamp
sigTime sig = case sigcts sig of
(t : _) -> t
[] -> 0
newestWith p sigs =
let filtered = filter p sigs
in if null filtered
then []
else [maximumBy (comparing sigTime) filtered]
checkSK
:: Fingerprint -> (Pkt, [SignaturePayload]) -> Result SubkeyReport
checkSK pf (PublicSubkeyPkt pkp, sigs) = checkSK' pf pkp sigs
checkSK pf (SecretSubkeyPkt pkp _, sigs) = checkSK' pf pkp sigs
checkSK _ _ = error "checkSK: unexpected packet type"
checkSK' pf pkp sigs =
skr
<$ sequenceA_
[ void (skFingerprint skr)
, void (skVer skr)
, void (skAlgorithmAndSize skr)
, traverse_ void (skBindingSigHashAlgorithms skr)
, traverse_ void (skUsageFlags skr)
, void (ccPresent (skCrossCerts skr))
, traverse_ void (ccHashAlgorithms (skCrossCerts skr))
]
where
skr =
( \x -> x {skCrossCerts = ccr (map getResult (skUsageFlags x)) sigs}
)
SubkeyReport
{ skFingerprint = colorizeF pf (fingerprint pkp)
, skVer = colorizeKV (_keyVersion pkp)
, skCreationTime = _timestamp pkp
, skAlgorithmAndSize = kasIt pkp
, skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)
, skRevocationSigWeakDigests =
subkeyRevocationSigWeakDigests pkp sigs
, skUsageFlags = kufs True (filter isSKBindingSig sigs)
, skCrossCerts = CrossCertReport (pure False) []
}
hasEncryptionCapableSubkey
:: [Result (Set.Set KeyFlag)] -> Result Bool
hasEncryptionCapableSubkey skrs =
let hasEncryption =
any
( ( \x ->
Set.member EncryptStorageKey x
|| Set.member EncryptCommunicationsKey x
)
. getResult
)
skrs
in if hasEncryption
then withColor (Just Green) True
else
colored
(Just Red)
(Just ["no encryption-capable subkey present"])
False
embeddedSigs =
filter isPKBindingSig
. concatMap getEmbeds
. filter isSKBindingSig
getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
getEmbeds (SigV6 _ _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys)
getEmbeds _ = []
getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]
getEmbed _ = []
ccr kufs' sigs =
CrossCertReport
(colorES kufs' sigs)
(map (colorizeHA . hashAlgo) sigs)
colorES :: [Set.Set KeyFlag] -> [SignaturePayload] -> Result Bool
colorES kufs' sigs =
let noEmbedded = null (embeddedSigs sigs)
signCapable = any (Set.member SignDataKey) kufs'
authCapable = any (Set.member AuthKey) kufs'
in case (noEmbedded, signCapable, authCapable) of
(True, True, True) ->
colored
(Just Red)
(Just ["signing- and auth-capable subkey without cross-cert"])
False
(True, True, False) ->
colored
(Just Red)
(Just ["signing-capable subkey without cross-cert"])
False
(True, False, True) ->
colored
(Just Yellow)
(Just ["auth-capable subkey without cross-cert"])
False
_ ->
withColor (Just Green) True
colorizeF :: Fingerprint -> Fingerprint -> Result Fingerprint
colorizeF pf fp
| pf == fp =
colored
(Just Red)
(Just ["subkey has same fingerprint as primary key"])
fp
| otherwise = withColor (Just Green) fp
subkeyRevocationSigWeakDigests pkp =
mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp)
. filter isSubkeyRevocationSignature
mkSubkeyRevocationSigWeakDigestWarning pkp sig =
let ha = hashAlgo sig
in if isKnownWeakHashAlgorithm ha
then
Just
SubkeyRevocationDigestWarning
{ srwHashAlgorithm = ha
, srwSubkeyFingerprint = renderFingerprint (fingerprint pkp)
, srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp))
, srwMessage =
"subkey revocation signature uses known-weak digest algorithm"
}
else Nothing
prettyKeyReport :: POSIXTime -> TKUnknown -> Doc PPA.AnsiStyle
prettyKeyReport cpt tk = do
let keyReportResult = unPolicy checkKey tk (Just cpt)
keyReport = getResult keyReportResult
execWriter $
tell $
vsep
[ pretty "Key has potential validity"
<> colon
<+> pretty (getResult (keyStatus keyReport))
, pretty "Key has fingerprint"
<> colon
<+> pretty (SpacedFingerprint (getResult (keyFingerprint keyReport)))
, pretty "Checking to see if key is OpenPGPv4 or v6"
<> colon
<+> coloredToColor (pretty . show) (keyVer keyReport)
, ( \kas ->
pretty "Checking the strength of your primary asymmetric key"
<> colon
<+> coloredToColor pretty (pubkeyalgo kas)
<+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)
)
(getResult (keyAlgorithmAndSize keyReport))
, pretty "Checking user-ID- and user-attribute-related items"
<> colon
<> mconcat
( map
(uidtrip (getResult (keyCreationTime keyReport)))
(Map.toList (keyUIDsAndUAts keyReport))
)
, pretty "Checking subkeys" <> colon
, indent
2
( pretty "one of the subkeys is encryption-capable"
<> colon
<+> coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)
)
<> mconcat (map subkeyrep (keySubkeys keyReport))
]
<> linebreak
where
coloredToColor f (Result (Just Green) _ x) = green (f x)
coloredToColor f (Result (Just Yellow) _ x) = yellow (f x)
coloredToColor f (Result (Just Red) _ x) = red (f x)
coloredToColor f (Result Nothing _ x) = f x
uidtrip ts (uText, r@(Result _ _ ur))
| null (uidRevocationStatus ur) =
linebreak
<> indent 2 (coloredToColor pretty (T.unpack uText <$ r))
<> colon
<> linebreak
<> indent
4
( pretty "Self-sig hash algorithms"
<> colon
<+> (list . map (coloredToColor pretty) . uidSelfSigHashAlgorithms)
ur
)
<> linebreak
<> indent
4
( pretty "Preferred hash algorithms"
<> colon
<+> mconcat
(map (coloredToColor pretty) (uidPreferredHashAlgorithms ur))
)
<> linebreak
<> indent
4
( pretty "Key expiration times"
<> colon
<+> mconcat
( map
(coloredToColor list . fmap (map (pretty . keyExp ts)))
(uidKeyExpirationTimes ur)
)
)
<> linebreak
<> indent
4
( pretty "Key usage flags"
<> colon
<+> (list . map (coloredToColor (pretty . Set.toList)))
(uidKeyUsageFlags ur)
)
| otherwise =
linebreak
<> indent 2 (coloredToColor pretty (T.unpack uText <$ r))
<> colon
<+> pretty "[revoked]"
<> linebreak
<> indent
4
( pretty "Revocation code"
<> colon
<+> list (map (pretty . revocationCode) (uidRevocationStatus ur))
)
<> linebreak
<> indent
4
( pretty "Revocation reason"
<> colon
<+> list
( map
(pretty . T.unpack . revocationReason)
(uidRevocationStatus ur)
)
)
keyExp ts ke =
(show . pretty) ke
++ " = "
++ formatTime
defaultTimeLocale
"%c"
(posixSecondsToUTCTime (realToFrac ts + realToFrac ke))
subkeyrep skrResult =
let skr = getResult skrResult
in subkeydetail skr
subkeydetail skr =
linebreak
<> indent
2
( pretty "fpr"
<> colon
<+> coloredToColor
pretty
(fmap SpacedFingerprint (skFingerprint skr))
)
<> linebreak
<> indent
4
(pretty "version" <> colon <+> coloredToColor pretty (skVer skr))
<> linebreak
<> indent
4
(pretty "timestamp" <> colon <+> pretty (skCreationTime skr))
<> linebreak
<> indent
4
( ( \kas ->
pretty "algo/size"
<> colon
<+> coloredToColor pretty (pubkeyalgo kas)
<+> coloredToColor (maybe (pretty "unknown") pretty) (pubkeysize kas)
)
(getResult (skAlgorithmAndSize skr))
)
<> linebreak
<> indent
4
( pretty "binding sig hash algorithms"
<> colon
<+> (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms)
skr
)
<> linebreak
<> indent
4
( pretty "weak subkey revocation digests"
<> colon
<+> if null (skRevocationSigWeakDigests skr)
then pretty "[]"
else
list
( map
( \w ->
red
( pretty (srwHashAlgorithm w)
<> colon
<+> pretty (srwSubkeyFingerprint w)
<> colon
<+> maybe (pretty "<no-key-id>") pretty (srwSubkeyKeyID w)
)
)
(skRevocationSigWeakDigests skr)
)
)
<> linebreak
<> indent
4
( pretty "usage flags"
<> colon
<+> (list . map (coloredToColor (pretty . Set.toList)))
(skUsageFlags skr)
)
<> linebreak
<> indent
4
( pretty "embedded cross-cert"
<> colon
<+> (coloredToColor pretty . ccPresent . skCrossCerts) skr
)
<> linebreak
<> indent
4
( pretty "cross-cert hash algorithms"
<> colon
<+> ( list
. map (coloredToColor pretty)
. ccHashAlgorithms
. skCrossCerts
)
skr
)
jsonReport :: POSIXTime -> TKUnknown -> BL.ByteString
jsonReport ps tk = A.encode (getResult (unPolicy checkKey tk (Just ps)))
yamlReport :: POSIXTime -> TKUnknown -> B.ByteString
yamlReport ps tk = Y.encode . (: []) $ getResult (unPolicy checkKey tk (Just ps))
doLint :: LintOptions -> IO ()
doLint o = do
cpt <- getPOSIXTime
keys <-
runConduitRes $
CB.sourceHandle stdin
.| conduitGet get
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CL.consume
output (lintOutputFormat o) cpt keys
where
output Pretty cpt = mapM_ (PPA.putDoc . prettyKeyReport cpt)
output JSON cpt =
mapM_
(BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt)
output YAML cpt = mapM_ (B.putStr . yamlReport cpt)
sigissuer :: SignaturePayload -> Maybe EightOctetKeyId
getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId
hashAlgo :: SignaturePayload -> HashAlgorithm
sigissuer (SigVOther 2 _) = Nothing
sigissuer SigV3 {} = Nothing
sigissuer (SigV4 _ _ _ ys xs _ _) =
let issuers = mapMaybe (getIssuer . _sspPayload) (ys ++ xs)
in case nub issuers of
[issuer] -> Just issuer
_ -> Nothing
sigissuer (SigV6 {}) = Nothing -- v6 signatures are forbidden from carrying Issuer subpackets; see sigissuerFPs
sigissuer (SigVOther _ _) = Nothing
getIssuer (Issuer i) = Just i
getIssuer _ = Nothing
sigissuerFPs :: SignaturePayload -> [Fingerprint]
sigissuerFPs (SigV4 _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)
sigissuerFPs (SigV6 _ _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs)
sigissuerFPs _ = []
getIssuerFP :: SigSubPacketPayload -> Maybe Fingerprint
getIssuerFP (IssuerFingerprint _ fp) = Just fp
getIssuerFP _ = Nothing
hashAlgo (SigV3 _ _ _ _ x _ _) = x
hashAlgo (SigV4 _ _ x _ _ _ _) = x
hashAlgo (SigV6 _ _ x _ _ _ _ _) = x
hashAlgo (SigVOther _ _) = OtherHA 0
knownWeakHashAlgorithms :: [HashAlgorithm]
knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]
isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool
isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms
isSubkeyRevocationSignature :: SignaturePayload -> Bool
isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig
isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig
isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig
isSubkeyRevocationSignature _ = False
hasheds :: SignaturePayload -> [SigSubPacket]
hasheds (SigV4 _ _ _ xs _ _ _) = xs
hasheds (SigV6 _ _ _ _ xs _ _ _) = xs
hasheds _ = []