diff --git a/hokey.hs b/hokey.hs --- a/hokey.hs +++ b/hokey.hs @@ -21,29 +21,31 @@ import HOpenPGP.Tools.Common (banner, versioner, warranty) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID) import Codec.Encryption.OpenPGP.KeyInfo (keySize) -import Codec.Encryption.OpenPGP.Signatures (verifyTK) +import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys) import Codec.Encryption.OpenPGP.Types import Control.Applicative ((<$>),(<*>)) import Control.Arrow ((***), second) import Control.Lens ((^.), (^?!), ix) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) +import qualified Crypto.Hash.SHA3 as SHA3 import qualified Data.Aeson as A import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Base16 as Base16 import Data.Conduit (($=),($$), runResourceT) import qualified Data.Conduit.Binary as CB import Data.Conduit.Cereal (conduitGet) import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping) import Data.IxSet (empty, insert) -import Data.List (unfoldr, elemIndex, findIndex, sortBy) -import Data.Map (Map) -import qualified Data.Map as Map +import Data.List (unfoldr, elemIndex, findIndex, sortBy, intercalate) import Data.Maybe (fromMaybe) import Data.Monoid ((<>), mconcat) import Data.Ord (comparing, Down(..)) import Data.Serialize (get) -import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime) import Data.Time.Format (formatTime) import GHC.Generics @@ -54,7 +56,7 @@ import System.IO (Handle, hFlush, hPutStrLn, stderr, stdin, hSetBuffering, BufferMode(..)) import System.Locale (defaultTimeLocale) -import Text.PrettyPrint.ANSI.Leijen (colon, green, indent, linebreak, list, putDoc, red, text, yellow, (<+>)) -- need 0.6.7 for hardline +import Text.PrettyPrint.ANSI.Leijen (colon, green, indent, linebreak, list, putDoc, red, text, yellow, (<+>), Doc) -- need 0.6.7 for hardline data KAS = KAS { pubkeyalgo :: PubKeyAlgorithm @@ -67,13 +69,18 @@ , keyVer :: KeyVersion , keyCreationTime :: TimeStamp , keyAlgorithmAndSize :: KAS - , keySelfSigHashAlgorithms :: Map String [HashAlgorithm] - , keyPreferredHashAlgorithms :: Map String [[HashAlgorithm]] - , keyExpirationTimes :: Map String [[TimeStamp]] + , keyUIDsAndUAts :: [(String, UIDReport)] } deriving Generic +data UIDReport = UIDReport { + uidSelfSigHashAlgorithms :: [HashAlgorithm] + , uidPreferredHashAlgorithms :: [[HashAlgorithm]] + , uidKeyExpirationTimes :: [[TimeStamp]] +} deriving Generic + instance A.ToJSON KAS instance A.ToJSON KeyReport +instance A.ToJSON UIDReport instance A.ToJSON HashAlgorithm where toJSON = A.toJSON . show instance A.ToJSON PubKeyAlgorithm where @@ -84,11 +91,11 @@ instance A.ToJSON TwentyOctetFingerprint where toJSON = A.toJSON . show -checkKey :: TK -> IO KeyReport -checkKey key = getPOSIXTime >>= \cpt -> return (KeyReport (either (const "not-good") (const "good") (processedTK cpt)) (fingerprint $ key^.tkPKP) (key^.tkPKP^.keyVersion) (key^.tkPKP^.timestamp) (KAS (key^.tkPKP^.pkalgo) (keySize (key^.tkPKP^.pubkey))) (Map.fromList (map (second has) ((processedOrOrig cpt)^.tkUIDs) ++ map (const "" *** has) ((processedOrOrig cpt)^.tkUAts))) (Map.fromList (map (second (map phas . alleged)) ((processedOrOrig cpt)^.tkUIDs) ++ map (const "" *** (map phas . alleged)) ((processedOrOrig cpt)^.tkUAts))) (Map.fromList (map (second (map kets . alleged)) ((processedOrOrig cpt)^.tkUIDs) ++ map (const "" *** (map kets . alleged)) ((processedOrOrig cpt)^.tkUAts)))) +checkKey :: Maybe UTCTime -> TK -> KeyReport +checkKey mct key = KeyReport (either (const "not-good") (const "good") processedTK) (fingerprint $ key^.tkPKP) (key^.tkPKP^.keyVersion) (key^.tkPKP^.timestamp) (KAS (key^.tkPKP^.pkalgo) (keySize (key^.tkPKP^.pubkey))) (map (second uidr) (processedOrOrig^.tkUIDs) ++ map (uatspsToString *** uidr) (processedOrOrig^.tkUAts)) where - processedOrOrig = either (const key) id . processedTK - processedTK t = verifyTK (insert key empty) (Just (posixSecondsToUTCTime t)) . stripOlderSigs . stripOtherSigs $ key + processedOrOrig = either (const key) id processedTK + processedTK = verifyTKWith (verifySigWith (verifyAgainstKeys [key])) mct . stripOlderSigs . stripOtherSigs $ key sigissuer (SigVOther 2 _) = OtherSigSub 666 B.empty -- this is dumb sigissuer (SigV3 {}) = OtherSigSub 666 B.empty -- this is dumb sigissuer (SigV4 _ _ _ _ xs _ _) = xs^?!ix 0^.sspPayload -- this is a horrible stack of stupid assumptions @@ -116,26 +123,32 @@ _tkUIDs = map (second newest) (_tkUIDs tk) , _tkUAts = map (second newest) (_tkUAts tk) } + uatspsToString us = "" + uaspToString (ImageAttribute hdr d) = hdrToString hdr ++ ':':show (B.length d) ++ ':':BC8.unpack (Base16.encode (SHA3.hash 48 d)) + uaspToString (OtherUASub t d) = "other-" ++ show t ++ ':':show (B.length d) ++ ':':BC8.unpack (Base16.encode (SHA3.hash 48 d)) + hdrToString (ImageHV1 JPEG) = "jpeg" + hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt) + uidr sps = UIDReport (has sps) (map phas sps) (map kets sps) -prettyKeyReport :: TK -> IO () -prettyKeyReport key = getPOSIXTime >>= \cpt -> checkKey key >>= \keyReport -> putDoc . execWriter $ tell +prettyKeyReport :: POSIXTime -> TK -> Doc +prettyKeyReport cpt key = do + let keyReport = checkKey (Just (posixSecondsToUTCTime cpt)) key + execWriter $ tell ( linebreak <> text "Key has potential validity:" <+> text (keyStatus keyReport) <> linebreak <> text "Key has fingerprint:" <+> text (show (keyFingerprint keyReport)) <> linebreak <> text "Checking to see if key is OpenPGPv4:" <+> colorIf (green,red) (==V4) (keyVer keyReport) <> linebreak <> (\kas -> text "Checking to see if key is RSA or DSA (>= 2048-bit):" <+> colorIf (green,yellow) (==RSA) (pubkeyalgo kas) <+> colorIf3 (green,yellow,red) (>= 3072) (>=2048) (pubkeysize kas)) (keyAlgorithmAndSize keyReport) - <> linebreak <> text "Checking self-sig hash algorithms (poorly):" - <> mconcat (map (\(x,ys) -> slpair x (listHAs ys)) (Map.toList (keySelfSigHashAlgorithms keyReport))) - <> linebreak <> text "Checking preferred hash algorithms (poorly):" -- FIXME - <> mconcat (map (\(x,ys) -> mlpair x listPHAs ys) (Map.toList (keyPreferredHashAlgorithms keyReport))) - <> linebreak <> text "Checking key expiration times based on" <+> text (formatTime defaultTimeLocale "%c" (posixSecondsToUTCTime . realToFrac $ (key^.tkPKP^.timestamp))) <+> text "(creation) and" <+> text (formatTime defaultTimeLocale "%c" (posixSecondsToUTCTime cpt)) <+> text "(current) times (poorly):" -- FIXME - <> mconcat (map (\(x,ys) -> mlpair x (listKETs cpt (keyCreationTime keyReport)) ys) (Map.toList (keyExpirationTimes keyReport))) + <> linebreak <> text "Checking user-ID- and user-attribute-related items:" + <> mconcat (map (uidtrip (keyCreationTime keyReport)) (keyUIDsAndUAts keyReport)) <> linebreak ) where colorIf (y,n) p x = ((if p x then y else n) . text . show) x colorIf3 (g,y,r) p1 p2 x = ((if p1 x then g else (if p2 x then y else r)) . text . show) x - slpair x y = linebreak <> indent 2 (text x <> colon <+> y) - mlpair x f ys = linebreak <> indent 2 (text x) <> colon <> mconcat (map ((linebreak <>) . indent 4 . f) ys) + uidtrip ts (u, ur) = linebreak <> indent 2 (text u) <> colon + <> linebreak <> indent 4 (text "Self-sig hash algorithms" <> colon <+> (listHAs . uidSelfSigHashAlgorithms) ur) + <> linebreak <> indent 4 (text "Preferred hash algorithms" <> colon <+> mconcat (map ((linebreak <>) . indent 2 . listPHAs) (uidPreferredHashAlgorithms ur))) + <> linebreak <> indent 4 (text "Key expiration times" <> colon <+> mconcat (map ((linebreak <>) . indent 2 . listKETs cpt ts) (uidKeyExpirationTimes ur))) listHAs = list . map (\x -> ((if x `elem` [DeprecatedMD5, SHA1] then red else id) . text . show) x) listPHAs x = (if fSHA2Family x < ei DeprecatedMD5 x && fSHA2Family x < ei SHA1 x then green else red) . list . map (text . show) $ x listKETs ct ts x = colorExpiration ct ts x . list . map (text . keyExp ts) $ x @@ -149,8 +162,8 @@ | otherwise = green keyExp ts ke = durationPrettyPrinter ke ++ " = " ++ formatTime defaultTimeLocale "%c" (posixSecondsToUTCTime (realToFrac ts + realToFrac ke)) -jsonReport :: TK -> IO () -jsonReport key = checkKey key >>= \keyReport -> BL.putStr (A.encode keyReport) +jsonReport :: POSIXTime -> TK -> BL.ByteString +jsonReport _ key = A.encode (checkKey Nothing key) -- FIXME: pass time when it matters in the JSON -- this does not have the same sense of calendar anyone else might durationPrettyPrinter :: TimeStamp -> String @@ -195,11 +208,12 @@ doLint :: Options -> IO () doLint o = do + cpt <- getPOSIXTime keys <- runResourceT $ CB.sourceHandle stdin $= conduitGet get $= conduitToTKsDropping $$ CL.consume - mapM_ (output (outputFormat o)) keys + output (outputFormat o) cpt keys where - output Pretty = prettyKeyReport - output JSON = jsonReport + output Pretty cpt = mapM_ (putDoc . prettyKeyReport cpt) + output JSON cpt = BL.putStr . BL.concat . map (jsonReport cpt) banner' :: Handle -> IO () banner' h = hPutStrLn h (banner "hokey" ++ "\n" ++ warranty "hokey") diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal --- a/hopenpgp-tools.cabal +++ b/hopenpgp-tools.cabal @@ -1,5 +1,5 @@ name: hopenpgp-tools -version: 0.2 +version: 0.3 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools @@ -37,14 +37,16 @@ build-depends: base > 4 && < 5 , aeson , ansi-wl-pprint + , base16-bytestring , bytestring , cereal , cereal-conduit , conduit , containers , crypto-pubkey + , cryptohash >= 0.7.7 , directory - , hOpenPGP >= 0.10.2 + , hOpenPGP >= 0.12 , ixset , lens , old-locale @@ -80,4 +82,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hopenpgp-tools.git - tag: hopenpgp-tools/0.2 + tag: hopenpgp-tools/0.3