hopenpgp-tools 0.4 → 0.4.1
raw patch · 4 files changed
+57/−28 lines, 4 filesdep +errorsdep +yamldep ~hOpenPGP
Dependencies added: errors, yaml
Dependency ranges changed: hOpenPGP
Files
- HOpenPGP/Tools/Common.hs +1/−1
- hkt.hs +8/−9
- hokey.hs +41/−13
- hopenpgp-tools.cabal +7/−5
HOpenPGP/Tools/Common.hs view
@@ -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))
hkt.hs view
@@ -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
hokey.hs view
@@ -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")
hopenpgp-tools.cabal view
@@ -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