hopenpgp-tools-0.25.7: 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 LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module HOpenPGP.Tools.Hokey.Lint
( doLint
) where
import Codec.Encryption.OpenPGP.Types
( SomeTK
, SpacedFingerprint (..)
)
import Control.Monad (void)
import Control.Monad.Trans.Writer.Lazy (execWriter, tell)
import qualified Data.Aeson as A
import Data.Binary (get)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Keyring
( conduitDropErrorsAndNothings
, conduitToSomeTKsDroppingEither
)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Foldable (sequenceA_, traverse_)
import qualified Data.Map as Map
import qualified Data.Set as Set
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 Prettyprinter
( Doc
, annotate
, colon
, flatAlt
, indent
, line
, list
, pretty
, vsep
, (<+>)
)
import qualified Prettyprinter.Render.Terminal as PPA
import System.IO
( stdin
)
import HOpenPGP.Tools.Hokey.Lint.Policy
( LintPolicy (..)
, checkKeyAlgorithmAndSize
, checkKeyBestOf
, checkKeyCreationTime
, checkKeyFingerprint
, checkKeyHasEncryptionCapableSubkey
, checkKeyStatus
, checkKeySubkeys
, checkKeyUIDsAndUAts
, checkKeyVersion
, mkLintContext
)
import HOpenPGP.Tools.Hokey.Lint.Types
( Color (..)
, CrossCertReport (..)
, KAS (..)
, KeyReport (..)
, LintContext (..)
, Result (..)
, RevocationStatus (..)
, SubkeyReport (..)
, SubkeyRevocationDigestWarning (..)
, UIDReport (..)
, getResult
)
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)
checkKey :: LintPolicy LintContext KeyReport
checkKey = LintPolicy $ \ctx ->
let kr =
KeyReport
{ keyStatus = unPolicy checkKeyStatus ctx
, keyFingerprint = unPolicy checkKeyFingerprint ctx
, keyVer = unPolicy checkKeyVersion ctx
, keyCreationTime = unPolicy checkKeyCreationTime ctx
, keyAlgorithmAndSize = unPolicy checkKeyAlgorithmAndSize ctx
, keyUIDsAndUAts = unPolicy checkKeyUIDsAndUAts ctx
, keyBestOf = unPolicy checkKeyBestOf ctx
, keySubkeys = unPolicy checkKeySubkeys ctx
, keyHasEncryptionCapableSubkey =
unPolicy checkKeyHasEncryptionCapableSubkey ctx
}
in kr
<$ sequenceA_
[ void (keyStatus kr)
, void (keyFingerprint kr)
, void (keyVer kr)
, void (keyAlgorithmAndSize kr)
, void (keyHasEncryptionCapableSubkey kr)
, traverse_ void (getResult (keySubkeys kr))
, traverse_ void (getResult (keyUIDsAndUAts kr))
]
prettyKeyReport :: POSIXTime -> SomeTK -> Doc PPA.AnsiStyle
prettyKeyReport cpt stk = do
let keyReport = getResult (unPolicy checkKey (mkLintContext (Just cpt) stk))
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 (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 (getResult (keyUIDsAndUAts keyReport)))
)
, pretty "Checking subkeys" <> colon
, indent
2
( pretty "one of the subkeys is encryption-capable"
<> colon
<+> coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)
)
<> mconcat (map subkeyrep (getResult (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 -> SomeTK -> BL.ByteString
jsonReport ps stk =
A.encode
(getResult (unPolicy checkKey (mkLintContext (Just ps) stk)))
yamlReport :: POSIXTime -> SomeTK -> B.ByteString
yamlReport ps stk =
Y.encode . (: []) $
getResult (unPolicy checkKey (mkLintContext (Just ps) stk))
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)