diff --git a/HOpenPGP/Tools/Common.hs b/HOpenPGP/Tools/Common.hs --- a/HOpenPGP/Tools/Common.hs +++ b/HOpenPGP/Tools/Common.hs @@ -71,5 +71,5 @@ keyMatchesUIDSubString uidstr = any (map toLower uidstr `isInfixOf`) . map (map toLower . fst) . _tkUIDs keyMatchesPKPred :: Eq a => (PKPayload -> a) -> Bool -> TK -> a -> Bool -keyMatchesPKPred p False = (==) . p . _tkPKP +keyMatchesPKPred p False = (==) . p . fst . _tkKey keyMatchesPKPred p True = \tk v -> any (== v) (map p (tk ^.. biplate)) diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -19,12 +19,12 @@ import HOpenPGP.Tools.Common (banner, versioner, warranty, keyMatchesFingerprint, keyMatchesEightOctetKeyId, keyMatchesUIDSubString) import HOpenPGP.Tools.ExpressionParsing (pPE) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID) -import Codec.Encryption.OpenPGP.KeyInfo (keySize, pkalgoAbbrev) +import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize, pkalgoAbbrev) import Codec.Encryption.OpenPGP.KeySelection (parseEightOctetKeyId, parseFingerprint) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types import Control.Applicative ((<$>),(<*>), optional, (<|>)) -import Control.Lens ((^.)) +import Control.Lens ((^.), _1) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) import qualified Data.Attoparsec.Text as A import qualified Data.ByteString as B @@ -34,7 +34,6 @@ import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Filter (Expr(..), PKPPredicate(..), PKPOp(..), PKPVar(..), PKPValue(..)) import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping) -import Data.Foldable (traverse_) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Serialize (get, put, runPut) @@ -52,15 +51,15 @@ CB.sourceFile fp $= conduitGet get $= conduitToTKsDropping $= CL.filter (if filt then filterMatch else matchAny) $$ CL.consume where matchAny tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) efp <|> fmap (keyMatchesEightOctetKeyId True tk) eeok <|> return (keyMatchesUIDSubString srch tk) - filterMatch tk = eval pkpEval (either error id (A.parseOnly pPE (T.pack srch))) (_tkPKP tk) + filterMatch tk = eval pkpEval (either error id (A.parseOnly pPE (T.pack srch))) (tk^.tkKey._1) efp = parseFingerprint . T.pack $ srch eeok = parseEightOctetKeyId . T.pack $ srch showKey :: TK -> IO () showKey key = putStrLn . unlines . execWriter $ do - tell [ "pub " ++ show (keySize (key^.tkPKP^.pubkey)) ++ pkalgoAbbrev (key^.tkPKP^.pkalgo) ++ "/0x" ++ (show . eightOctetKeyID $ key^.tkPKP ) ] + tell [ "pub " ++ either (const "unknown") show (pubkeySize (key^.tkKey._1.pubkey)) ++ pkalgoAbbrev (key^.tkKey._1.pkalgo) ++ "/0x" ++ (show . eightOctetKeyID $ key^.tkKey._1 ) ] tell $ map (\(x,_) -> "uid " ++ x) (key^.tkUIDs) - tell $ map (\(PublicSubkeyPkt x,_,_) -> "sub " ++ show (keySize (x^.pubkey)) ++ pkalgoAbbrev (x^.pkalgo) ++ "/0x" ++ (show . eightOctetKeyID $ x)) (key^.tkSubs) + tell $ map (\(PublicSubkeyPkt x,_) -> "sub " ++ either (const "unknown") show (pubkeySize (x^.pubkey)) ++ pkalgoAbbrev (x^.pkalgo) ++ "/0x" ++ (show . eightOctetKeyID $ x)) (key^.tkSubs) data Options = Options { keyring :: String @@ -108,14 +107,14 @@ mapM_ (B.putStr . putTK') keys where putTK' key = runPut $ do - put (PublicKey (_tkPKP key)) + put (PublicKey (key^.tkKey._1)) mapM_ (put . Signature) (_tkRevs key) mapM_ putUid' (_tkUIDs key) mapM_ putUat' (_tkUAts key) mapM_ putSub' (_tkSubs key) putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps - putSub' (p, sp, msp) = put p >> (put . Signature) sp >> traverse_ (put . Signature) msp + putSub' (p, sps) = put p >> mapM_ (put . Signature) sps -- FIXME: deduplicate the following code eval :: (a -> v -> Bool) -> Expr a -> v -> Bool @@ -135,7 +134,7 @@ opreduce PKGreaterThan = (>) vreduce (PKPVVersion, p) = PKPInt (kv (_keyVersion p)) vreduce (PKPVPKA, p) = PKPPKA (_pkalgo p) - vreduce (PKPVKeysize, p) = PKPInt (keySize . _pubkey $ p) + vreduce (PKPVKeysize, p) = PKPInt (either (const 0) id . pubkeySize . _pubkey $ p) -- FIXME: this should be smarter vreduce (PKPVTimestamp, p) = PKPInt (fromIntegral (_timestamp p)) kv DeprecatedV3 = 3 kv V4 = 4 diff --git a/hokey.hs b/hokey.hs --- a/hokey.hs +++ b/hokey.hs @@ -21,12 +21,13 @@ import HOpenPGP.Tools.Common (banner, versioner, warranty) import Codec.Encryption.OpenPGP.Expirations (getKeyExpirationTimesFromSignature) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID) -import Codec.Encryption.OpenPGP.KeyInfo (keySize) +import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize, pkalgoAbbrev) import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys) import Codec.Encryption.OpenPGP.Types import Control.Applicative ((<$>),(<*>)) import Control.Arrow ((***), second) -import Control.Lens ((^.)) +import Control.Error.Util (hush) +import Control.Lens ((^.), (&), _1) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) import qualified Crypto.Hash.SHA3 as SHA3 import qualified Data.Aeson as A @@ -41,12 +42,13 @@ import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping) import Data.List (unfoldr, elemIndex, findIndex, sortBy, intercalate) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, catMaybes, listToMaybe) -import Data.Monoid ((<>), mconcat) +import Data.Maybe (fromMaybe, mapMaybe, listToMaybe) +import Data.Monoid ((<>), mconcat, Monoid(..)) import Data.Ord (comparing, Down(..)) import Data.Serialize (get) import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime) import Data.Time.Format (formatTime) +import qualified Data.Yaml as Y import GHC.Generics import Options.Applicative.Builder (command, footer, header, help, info, long, metavar, prefs, progDesc, showDefault, showHelpOnError, option, subparser, value) @@ -60,11 +62,12 @@ data KAS = KAS { pubkeyalgo :: Colored PubKeyAlgorithm - , pubkeysize :: Colored Int + , pubkeysize :: Colored (Maybe Int) + , stringrep :: String } deriving Generic data Color = Green | Yellow | Red - deriving Generic + deriving (Eq, Generic, Ord) data Colored a = Colored { color :: Maybe Color @@ -81,6 +84,7 @@ , keyCreationTime :: TimeStamp , keyAlgorithmAndSize :: KAS , keyUIDsAndUAts :: FakeMap String UIDReport + , keyBestOf :: Maybe UIDReport } deriving Generic data UIDReport = UIDReport { @@ -106,18 +110,35 @@ instance A.ToJSON TwentyOctetFingerprint where toJSON = A.toJSON . show +instance Monoid UIDReport where + mempty = UIDReport [] [] [] + mappend (UIDReport a b c) (UIDReport d e f) = UIDReport (a++d) (b++e) (c++f) + checkKey :: Maybe POSIXTime -> TK -> KeyReport -checkKey mpt key = KeyReport (either id (const "good") processedTK) (fingerprint $ key^.tkPKP) (colorizeKV (key^.tkPKP^.keyVersion)) (key^.tkPKP^.timestamp) (KAS (colorizePKA (key^.tkPKP^.pkalgo)) (colorizePKS (keySize (key^.tkPKP^.pubkey)))) (FakeMap (map (second uidr) (processedOrOrig^.tkUIDs) ++ map (uatspsToString *** uidr) (processedOrOrig^.tkUAts))) +checkKey mpt key = (\x -> x { keyBestOf = populateBestOf x }) KeyReport { + keyStatus = either id (const "good") processedTK + , keyFingerprint = key^.tkKey._1 & fingerprint + , keyVer = key^.tkKey._1^.keyVersion & colorizeKV + , keyCreationTime = key^.tkKey._1^.timestamp + , keyAlgorithmAndSize = KAS { + pubkeyalgo = key^.tkKey._1^.pkalgo & colorizePKA + , pubkeysize = key^.tkKey._1^.pubkey & colorizePKS . pubkeySize + , stringrep = (key^.tkKey._1^.pubkey & either (const "unknown") show . pubkeySize) ++ (key^.tkKey._1^.pkalgo & pkalgoAbbrev) + } + , keyUIDsAndUAts = FakeMap (map (second uidr) (processedOrOrig^.tkUIDs) ++ map (uatspsToString *** uidr) (processedOrOrig^.tkUAts)) + , keyBestOf = Nothing +} where processedOrOrig = either (const key) id processedTK processedTK = verifyTKWith (verifySigWith (verifyAgainstKeys [key])) (fmap posixSecondsToUTCTime mpt) . stripOlderSigs . stripOtherSigs $ key colorizeKV kv = uncurry Colored (if kv == V4 then (Just Green, Nothing) else (Just Red, Just "not a V4 key")) kv colorizePKA pka = uncurry Colored (if pka == RSA then (Just Green, Nothing) else (Just Yellow, Just "not an RSA key")) pka - colorizePKS pks = uncurry Colored (colorizePKS' pks) pks - colorizePKS' pks + colorizePKS pks = uncurry Colored (colorizePKS' pks) (hush pks) + colorizePKS' (Right pks) | pks >= 3072 = (Just Green, Nothing) | pks >= 2048 = (Just Yellow, Just "Public key size between 2048 and 3072 bits") | otherwise = (Just Red, Just "Public key size under 2048 bits") + colorizePKS' (Left _) = (Just Red, Just "public key algorithm not understood") colorizePHAs x = uncurry Colored (if fSHA2Family x < ei DeprecatedMD5 x && fSHA2Family x < ei SHA1 x then (Just Green, Nothing) else (Just Red, Just "weak hash with higher preference")) x fSHA2Family = fi (`elem` [SHA512,SHA384,SHA256,SHA224]) ei x y = fromMaybe maxBound (elemIndex x y) @@ -129,11 +150,11 @@ | otherwise = Colored (Just Green) Nothing kes sigissuer (SigVOther 2 _) = Nothing sigissuer (SigV3 {}) = Nothing - sigissuer (SigV4 _ _ _ ys xs _ _) = listToMaybe . catMaybes . map (getIssuer . _sspPayload) $ (ys++xs) -- FIXME: what should this be if there are multiple matches? + sigissuer (SigV4 _ _ _ ys xs _ _) = listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys++xs) -- FIXME: what should this be if there are multiple matches? sigissuer (SigVOther _ _) = error "We're in the future." -- FIXME getIssuer i@(Issuer _) = Just i getIssuer _ = Nothing - eoki = eightOctetKeyID . _tkPKP + eoki = eightOctetKeyID . fst . _tkKey hashAlgo (SigV4 _ _ x _ _ _ _) = x phas (SigV4 _ _ _ xs _ _ _) = colorizePHAs . concatMap (\(SigSubPacket _ (PreferredHashAlgorithms x)) -> x) $ filter isPHA xs phas _ = Colored Nothing Nothing [] @@ -159,7 +180,10 @@ 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 (colorizeKETs (fromMaybe 0 mpt) (key^.tkPKP^.timestamp) . getKeyExpirationTimesFromSignature) sps) -- should that be 0? + uidr sps = UIDReport (has sps) (map phas sps) (map (colorizeKETs (fromMaybe 0 mpt) (key^.tkKey._1^.timestamp) . getKeyExpirationTimesFromSignature) sps) -- should that be 0? + populateBestOf krep = Just (UIDReport <$> best . uidSelfSigHashAlgorithms <*> best . uidPreferredHashAlgorithms <*> best . uidKeyExpirationTimes $ mconcat (justTheUIDRs krep)) + justTheUIDRs = map snd . unFakeMap . keyUIDsAndUAts + best = take 1 . sortBy (comparing color) prettyKeyReport :: POSIXTime -> TK -> Doc prettyKeyReport cpt key = do @@ -187,6 +211,9 @@ jsonReport :: POSIXTime -> [TK] -> BL.ByteString jsonReport ps keys = A.encode (map (checkKey (Just ps)) keys) +yamlReport :: POSIXTime -> [TK] -> B.ByteString +yamlReport ps keys = Y.encode (map (checkKey (Just ps)) keys) + -- this does not have the same sense of calendar anyone else might durationPrettyPrinter :: TimeStamp -> String durationPrettyPrinter = concat . unfoldr durU @@ -198,7 +225,7 @@ | x > 0 = Just ((++"s") . show $ x, 0) | otherwise = Nothing -data OutputFormat = Pretty | JSON +data OutputFormat = Pretty | JSON | YAML deriving (Eq, Read, Show) data Options = Options { @@ -236,6 +263,7 @@ where output Pretty cpt = mapM_ (putDoc . prettyKeyReport cpt) output JSON cpt = BL.putStr . jsonReport cpt + output YAML cpt = B.putStr . yamlReport 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.4 +version: 0.4.1 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools @@ -23,7 +23,7 @@ , cereal , cereal-conduit , conduit - , hOpenPGP >= 0.11 + , hOpenPGP >= 1.0 , lens , openpgp-asciiarmor >= 0.1 , optparse-applicative >= 0.7 @@ -47,13 +47,15 @@ , crypto-pubkey , cryptohash >= 0.7.7 , directory - , hOpenPGP >= 0.13 + , errors + , hOpenPGP >= 1.0 , lens , old-locale , optparse-applicative >= 0.5.0 , text , time , transformers + , yaml default-language: Haskell2010 executable hkt @@ -69,7 +71,7 @@ , conduit , crypto-pubkey , directory - , hOpenPGP >= 0.11.2 + , hOpenPGP >= 1.0 , ixset , lens , optparse-applicative >= 0.5.0 @@ -84,4 +86,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hopenpgp-tools.git - tag: hopenpgp-tools/0.4 + tag: hopenpgp-tools/0.4.1