diff --git a/HOpenPGP/Tools/Common.hs b/HOpenPGP/Tools/Common.hs new file mode 100644 --- /dev/null +++ b/HOpenPGP/Tools/Common.hs @@ -0,0 +1,75 @@ +-- Common.hs: hOpenPGP-tools common functions +-- Copyright © 2012-2014 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 . + +module HOpenPGP.Tools.Common ( + banner + , versioner + , warranty + , keyMatchesFingerprint + , keyMatchesEightOctetKeyId + , keyMatchesExactUIDString + , keyMatchesUIDSubString + , keyMatchesPKPred +) where + +import Paths_hopenpgp_tools (version) +import Data.Version (showVersion) + +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Types +import Control.Lens ((^..)) +import Data.Char (toLower) +import Data.Data.Lens (biplate) +import Data.List (isInfixOf) +import Data.Monoid ((<>)) +import Options.Applicative.Builder (help, infoOption, long, short) +import Options.Applicative.Types (Parser) + +banner :: String -> String +{-# INLINE banner #-} +banner name = name ++ " (hopenpgp-tools) " ++ showVersion version ++ "\n\ + \Copyright (C) 2012-2014 Clint Adams" + +warranty :: String -> String +{-# INLINE warranty #-} +warranty name = name ++ " comes with ABSOLUTELY NO WARRANTY.\n\ + \This is free software, and you are welcome to redistribute it\n\ + \under certain conditions." + +versioner :: Parser (a -> a) +{-# INLINE versioner #-} +versioner = infoOption (showVersion version) $ + long "version" + <> short 'V' + <> help "Show version information" + +keyMatchesFingerprint :: Bool -> TK -> TwentyOctetFingerprint -> Bool +keyMatchesFingerprint = keyMatchesPKPred fingerprint + +keyMatchesEightOctetKeyId :: Bool -> TK -> EightOctetKeyId -> Bool +keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID + +keyMatchesExactUIDString :: String -> TK -> Bool +keyMatchesExactUIDString uidstr = any (==uidstr) . map fst . _tkUIDs + +keyMatchesUIDSubString :: String -> TK -> Bool +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 True = \tk v -> any (== v) (map p (tk ^.. biplate)) diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -16,35 +16,41 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -import Paths_hopenpgp_tools (version) +import HOpenPGP.Tools.Common (banner, versioner, warranty, keyMatchesFingerprint, keyMatchesEightOctetKeyId, keyMatchesUIDSubString) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID) import Codec.Encryption.OpenPGP.KeyInfo (keySize, pkalgoAbbrev) +import Codec.Encryption.OpenPGP.KeySelection (parseEightOctetKeyId, parseFingerprint) +import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types -import Control.Applicative ((<$>),(<*>), optional) +import Control.Applicative ((<$>),(<*>), optional, (<|>)) import Control.Lens ((^.)) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) +import qualified Data.ByteString as B import Data.Conduit (($=),($$), runResourceT) import qualified Data.Conduit.Binary as CB import Data.Conduit.Cereal (conduitGet) -import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping, sinkKeyringMap) +import qualified Data.Conduit.List as CL +import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping) +import Data.Foldable (traverse_) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) -import Data.IxSet ((@=)) -import qualified Data.IxSet as IxSet -import Data.Serialize (get) -import Data.Version (showVersion) +import Data.Serialize (get, put, runPut) +import qualified Data.Text as T import System.Directory (getHomeDirectory) -import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, prefs, progDesc, showHelpOnError, str, strOption, subparser) +import Options.Applicative.Builder (argument, command, footer, header, help, info, long, metavar, prefs, progDesc, showHelpOnError, str, strOption, subparser) import Options.Applicative.Extra (customExecParser, helper) import Options.Applicative.Types (Parser) -import System.IO (hPutStrLn, stderr) +import System.IO (Handle, hFlush, hPutStrLn, stderr, hSetBuffering, BufferMode(..)) grabMatchingKeys :: FilePath -> String -> IO [TK] -grabMatchingKeys fp eok = do - kr <- runResourceT $ CB.sourceFile fp $= conduitGet get $= conduitToTKsDropping $$ sinkKeyringMap - return $! IxSet.toList (kr @= (read eok :: EightOctetKeyId)) +grabMatchingKeys fp srch = runResourceT $ + CB.sourceFile fp $= conduitGet get $= conduitToTKsDropping $= CL.filter matchAny $$ CL.consume + where + matchAny tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) efp <|> fmap (keyMatchesEightOctetKeyId True tk) eeok <|> return (keyMatchesUIDSubString srch tk) + efp = parseFingerprint . T.pack $ srch + eeok = parseEightOctetKeyId . T.pack $ srch showKey :: TK -> IO () showKey key = putStrLn . unlines . execWriter $ do @@ -57,7 +63,7 @@ , target :: String } -data Command = List Options +data Command = List Options | ExportPubkeys Options listO :: String -> Parser Options listO homedir = Options @@ -68,22 +74,39 @@ <*> argument str ( metavar "TARGET" ) dispatch :: Command -> IO () -dispatch (List o) = doList o +dispatch (List o) = banner' stderr >> hFlush stderr >> doList o +dispatch (ExportPubkeys o) = banner' stderr >> hFlush stderr >> doExportPubkeys o main :: IO () main = do + hSetBuffering stderr LineBuffering homedir <- getHomeDirectory - hPutStrLn stderr $ "hkt version " ++ showVersion version ++ ", Copyright (C) 2013-2014 Clint Adams\n\ - \hkt comes with ABSOLUTELY NO WARRANTY.\n\ - \This is free software, and you are welcome to redistribute it\n\ - \under certain conditions.\n" - customExecParser (prefs showHelpOnError) (info (helper <*> cmd homedir) idm) >>= dispatch + customExecParser (prefs showHelpOnError) (info (helper <*> versioner <*> cmd homedir) (header (banner "hkt") <> progDesc "hOpenPGP Keyring Tool" <> footer (warranty "hot"))) >>= dispatch cmd :: String -> Parser Command cmd homedir = subparser - ( command "list" (info ( List <$> listO homedir) ( progDesc "list matching keys" ))) + ( command "list" (info ( List <$> listO homedir) ( progDesc "list matching keys" )) + <> command "export-pubkeys" (info ( ExportPubkeys <$> listO homedir) ( progDesc "export matching keys to stdout" ))) +banner' :: Handle -> IO () +banner' h = hPutStrLn h (banner "hkt" ++ "\n" ++ warranty "hkt") + doList :: Options -> IO () doList o = do keys <- grabMatchingKeys (keyring o) (target o) mapM_ showKey keys + +doExportPubkeys :: Options -> IO () +doExportPubkeys o = do + keys <- grabMatchingKeys (keyring o) (target o) + mapM_ (B.putStr . putTK') keys + where + putTK' key = runPut $ do + put (PublicKey (_tkPKP key)) + 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 diff --git a/hokey.hs b/hokey.hs --- a/hokey.hs +++ b/hokey.hs @@ -16,87 +16,142 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -import Paths_hopenpgp_tools (version) +{-# LANGUAGE DeriveGeneric #-} + +import HOpenPGP.Tools.Common (banner, versioner, warranty) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID) import Codec.Encryption.OpenPGP.KeyInfo (keySize) -import Codec.Encryption.OpenPGP.KeySelection (parseEightOctetKeyId) +import Codec.Encryption.OpenPGP.Signatures (verifyTK) import Codec.Encryption.OpenPGP.Types -import Control.Applicative ((<$>),(<*>), optional) +import Control.Applicative ((<$>),(<*>)) +import Control.Arrow ((***), second) import Control.Lens ((^.), (^?!), ix) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) +import qualified Data.Aeson as A import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import Data.Conduit (($=),($$), runResourceT) import qualified Data.Conduit.Binary as CB import Data.Conduit.Cereal (conduitGet) -import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping, sinkKeyringMap) -import Data.List (unfoldr, elemIndex, findIndex) +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.Maybe (fromMaybe) import Data.Monoid ((<>), mconcat) -import Data.IxSet ((@=)) -import qualified Data.IxSet as IxSet +import Data.Ord (comparing, Down(..)) import Data.Serialize (get) -import qualified Data.Text as T -import Data.Version (showVersion) +import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime) +import Data.Time.Format (formatTime) +import GHC.Generics -import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, prefs, progDesc, showHelpOnError, str, strOption, subparser) +import Options.Applicative.Builder (command, footer, header, help, info, long, metavar, prefs, progDesc, showDefault, showHelpOnError, option, subparser, value) import Options.Applicative.Extra (customExecParser, helper) import Options.Applicative.Types (Parser) -import System.Directory (getHomeDirectory) -import System.IO (hPutStrLn, stderr) +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 -grabMatchingKeys :: FilePath -> String -> IO [TK] -grabMatchingKeys fp eok = do - kr <- runResourceT $ CB.sourceFile fp $= conduitGet get $= conduitToTKsDropping $$ sinkKeyringMap - let eoki = either ((const . error) "you must specify an eight-octet key ID") id (parseEightOctetKeyId (T.pack eok)) - return $! IxSet.toList (kr @= eoki) +data KAS = KAS { + pubkeyalgo :: PubKeyAlgorithm + , pubkeysize :: Int +} deriving Generic -checkKey :: TK -> IO () -checkKey key = putDoc . execWriter $ tell - ( linebreak <> text "Key has fingerprint:" <+> text (show . fingerprint $ key^.tkPKP) - <> linebreak <> text "Checking to see if key is OpenPGPv4:" <+> colorIf (green,red) (==V4) (key^.tkPKP^.keyVersion) - <> linebreak <> text "Checking to see if key is RSA or DSA (>= 2048-bit):" <+> colorIf (green,yellow) (==RSA) (key^.tkPKP^.pkalgo) <+> colorIf3 (green,yellow,red) (>= 3072) (>=2048) keysize - <> linebreak <> text "Checking self-sig hash algorithms (poorly):" - <> mconcat (map (\(x,ys) -> slpair x (listHAs ys)) (key^.tkUIDs)) - <> mconcat (map (\(_,ys) -> slpair "" (listHAs ys)) (key^.tkUAts)) - <> linebreak <> text "Checking preferred hash algorithms (poorly):" -- FIXME - <> mconcat (map (\(x,ys) -> mlpair x listPHAs (alleged ys)) (key^.tkUIDs)) - <> mconcat (map (\(_,ys) -> mlpair "" listPHAs (alleged ys)) (key^.tkUAts)) - <> linebreak <> text "Checking key expiration times (poorly):" -- FIXME - <> mconcat (map (\(x,ys) -> mlpair x listKETs (alleged ys)) (key^.tkUIDs)) - <> mconcat (map (\(_,ys) -> mlpair "" listKETs (alleged ys)) (key^.tkUAts)) - <> linebreak - ) +data KeyReport = KeyReport { + keyStatus :: String + , keyFingerprint :: TwentyOctetFingerprint + , keyVer :: KeyVersion + , keyCreationTime :: TimeStamp + , keyAlgorithmAndSize :: KAS + , keySelfSigHashAlgorithms :: Map String [HashAlgorithm] + , keyPreferredHashAlgorithms :: Map String [[HashAlgorithm]] + , keyExpirationTimes :: Map String [[TimeStamp]] +} deriving Generic + +instance A.ToJSON KAS +instance A.ToJSON KeyReport +instance A.ToJSON HashAlgorithm where + toJSON = A.toJSON . show +instance A.ToJSON PubKeyAlgorithm where + toJSON = A.toJSON . show +instance A.ToJSON KeyVersion where + toJSON DeprecatedV3 = A.toJSON (3 :: Int) + toJSON V4 = A.toJSON (4 :: Int) +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)))) where - keysize = keySize (key^.tkPKP^.pubkey) - 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 - sigissuer (SigVOther _ _) = error "We're in the future." - sigissuer _ = error "WTF" - eoki = eightOctetKeyID . _tkPKP - hashAlgo (SigV4 _ _ x _ _ _ _) = x + processedOrOrig = either (const key) id . processedTK + processedTK t = verifyTK (insert key empty) (Just (posixSecondsToUTCTime t)) . 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 + sigissuer (SigVOther _ _) = error "We're in the future." + sigissuer _ = error "WTF" + eoki = eightOctetKeyID . _tkPKP + hashAlgo (SigV4 _ _ x _ _ _ _) = x phas (SigV4 _ _ _ xs _ _ _) = concatMap (\(SigSubPacket _ (PreferredHashAlgorithms x)) -> x) $ filter isPHA xs isPHA (SigSubPacket _ (PreferredHashAlgorithms _)) = True isPHA _ = False kets (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET xs isKET (SigSubPacket _ (KeyExpirationTime _)) = True isKET _ = False - slpair x y = linebreak <> indent 2 (text x <> colon <+> y) has = map hashAlgo . alleged + isCT (SigSubPacket _ (SigCreationTime _)) = True + isCT _ = False + sigcts (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs alleged = filter (\x -> sigissuer x == Issuer (eoki key)) - mlpair x f ys = linebreak <> indent 2 (text x) <> colon <> mconcat (map ((linebreak <>) . indent 4 . f) ys) + newest = take 1 . sortBy (comparing (Down . take 1 . sigcts)) -- FIXME: this is terrible + stripOtherSigs tk = tk { + _tkUIDs = map (second alleged) (_tkUIDs tk) + , _tkUAts = map (second alleged) (_tkUAts tk) + } + stripOlderSigs tk = tk { + _tkUIDs = map (second newest) (_tkUIDs tk) + , _tkUAts = map (second newest) (_tkUAts tk) + } + +prettyKeyReport :: TK -> IO () +prettyKeyReport key = getPOSIXTime >>= \cpt -> checkKey key >>= \keyReport -> putDoc . 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 + ) + 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 - listHAs = list . map (\x -> ((if x `elem` [DeprecatedMD5, SHA1] then red else id) . text . show) x) . has - listPHAs = (\x -> (if fSHA2Family x < ei DeprecatedMD5 x && fSHA2Family x < ei SHA1 x then green else red) . list . map (text . show) $ x) . phas + 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) + 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 fSHA2Family = fi (`elem` [SHA512,SHA384,SHA256,SHA224]) ei x y = fromMaybe maxBound (elemIndex x y) fi x y = fromMaybe maxBound (findIndex x y) - listKETs = (\x -> (if null x || any (> (5*31557600)) x then red else green) . list . map (text . durationPrettyPrinter) $ x) . kets + colorExpiration ct ts kes + | null kes = red + | any (\ke -> realToFrac ts + realToFrac ke < ct) kes = red + | any (\ke -> realToFrac ts + realToFrac ke > ct + (5*31557600)) kes = yellow + | 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) + -- this does not have the same sense of calendar anyone else might durationPrettyPrinter :: TimeStamp -> String durationPrettyPrinter = concat . unfoldr durU @@ -108,38 +163,43 @@ | x > 0 = Just ((++"s") . show $ x, 0) | otherwise = Nothing +data OutputFormat = Pretty | JSON + deriving (Eq, Read, Show) + data Options = Options { - keyring :: String - , target :: String + outputFormat :: OutputFormat } data Command = Lint Options -lintO :: String -> Parser Options -lintO homedir = Options - <$> (fromMaybe (homedir ++ "/.gnupg/pubring.gpg") <$> optional (strOption - ( long "keyring" - <> metavar "FILE" - <> help "file containing keyring" ))) - <*> argument str ( metavar "TARGET" ) +lintO :: Parser Options +lintO = Options + <$> option + ( long "output-format" + <> metavar "FORMAT" + <> value Pretty + <> showDefault + <> help "output format" ) dispatch :: Command -> IO () -dispatch (Lint o) = doLint o +dispatch (Lint o) = banner' stderr >> hFlush stderr >> doLint o main :: IO () main = do - homedir <- getHomeDirectory - hPutStrLn stderr $ "hokey version " ++ showVersion version ++ ", Copyright (C) 2013-2014 Clint Adams\n\ - \hokey comes with ABSOLUTELY NO WARRANTY.\n\ - \This is free software, and you are welcome to redistribute it\n\ - \under certain conditions.\n" - customExecParser (prefs showHelpOnError) (info (helper <*> cmd homedir) idm) >>= dispatch + hSetBuffering stderr LineBuffering + customExecParser (prefs showHelpOnError) (info (helper <*> versioner <*> cmd) (header (banner "hokey") <> progDesc "hOpenPGP Key utility" <> footer (warranty "hokey"))) >>= dispatch -cmd :: String -> Parser Command -cmd homedir = subparser - ( command "lint" (info ( Lint <$> lintO homedir) ( progDesc "check key(s) for 'best practices'" ))) +cmd :: Parser Command +cmd = subparser + ( command "lint" (info ( Lint <$> lintO) ( progDesc "check key(s) for 'best practices'" ))) doLint :: Options -> IO () doLint o = do - keys <- grabMatchingKeys (keyring o) (target o) - mapM_ checkKey keys + keys <- runResourceT $ CB.sourceHandle stdin $= conduitGet get $= conduitToTKsDropping $$ CL.consume + mapM_ (output (outputFormat o)) keys + where + output Pretty = prettyKeyReport + output JSON = jsonReport + +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.1 +version: 0.2 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools @@ -15,6 +15,7 @@ executable hot main-is: hot.hs ghc-options: -Wall + other-modules: HOpenPGP.Tools.Common build-depends: base > 4 && < 5 , attoparsec >= 0.10.0.0 , bytestring @@ -22,6 +23,7 @@ , cereal-conduit , conduit , hOpenPGP >= 0.11 + , lens , openpgp-asciiarmor >= 0.1 , optparse-applicative >= 0.7 , text @@ -31,25 +33,31 @@ executable hokey main-is: hokey.hs ghc-options: -Wall + other-modules: HOpenPGP.Tools.Common build-depends: base > 4 && < 5 + , aeson , ansi-wl-pprint , bytestring , cereal , cereal-conduit , conduit + , containers , crypto-pubkey , directory , hOpenPGP >= 0.10.2 , ixset , lens + , old-locale , optparse-applicative >= 0.5.0 , text + , time , transformers default-language: Haskell2010 executable hkt main-is: hkt.hs ghc-options: -Wall + other-modules: HOpenPGP.Tools.Common build-depends: base > 4 && < 5 , bytestring , cereal @@ -57,10 +65,11 @@ , conduit , crypto-pubkey , directory - , hOpenPGP >= 0.8 + , hOpenPGP >= 0.11.2 , ixset , lens , optparse-applicative >= 0.5.0 + , text , transformers default-language: Haskell2010 @@ -71,4 +80,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hopenpgp-tools.git - tag: hopenpgp-tools/0.1 + tag: hopenpgp-tools/0.2 diff --git a/hot.hs b/hot.hs --- a/hot.hs +++ b/hot.hs @@ -19,6 +19,7 @@ -- along with this program. If not, see . import Paths_hopenpgp_tools (version) +import HOpenPGP.Tools.Common (banner, versioner, warranty) import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..)) import Codec.Encryption.OpenPGP.Serialize () @@ -39,9 +40,9 @@ import qualified Data.Text as T import Data.Version (showVersion) -import System.IO (stdin, stderr, stdout, hPutStrLn, hFlush, hSetBuffering, BufferMode(..)) +import System.IO (stdin, stderr, stdout, Handle, hFlush, hPutStrLn, hSetBuffering, BufferMode(..)) -import Options.Applicative.Builder (command, help, idm, info, long, metavar, nullOption, reader, prefs, progDesc, showHelpOnError, strOption, subparser, ParseError(..)) +import Options.Applicative.Builder (command, footer, header, help, info, long, metavar, nullOption, reader, prefs, progDesc, showHelpOnError, strOption, subparser, ParseError(..)) import Options.Applicative.Extra (customExecParser, helper) import Options.Applicative.Types (Parser, ReadM(..)) @@ -102,21 +103,17 @@ <*> optional (strOption (long "other" <> metavar "EXPR" <> help "other-packet filtering expression")) dispatch :: Command -> IO () -dispatch DumpC = doDump -dispatch DeArmorC = doDeArmor -dispatch (ArmorC o) = doArmor o -dispatch (FilterC o) = doFilter o +dispatch c = (banner' stderr >> hFlush stderr) >> dispatch' c + where + dispatch' DumpC = doDump + dispatch' DeArmorC = doDeArmor + dispatch' (ArmorC o) = doArmor o + dispatch' (FilterC o) = doFilter o main :: IO () main = do hSetBuffering stderr LineBuffering - hPutStrLn stderr $ "hot version " ++ showVersion version ++ ", Copyright (C) 2012-2014 Clint Adams\n\ - \hot comes with ABSOLUTELY NO WARRANTY.\n\ - \This is free software, and you are welcome to redistribute it\n\ - \under certain conditions.\n" - hFlush stderr - - customExecParser (prefs showHelpOnError) (info (helper <*> cmd) idm) >>= dispatch + customExecParser (prefs showHelpOnError) (info (helper <*> versioner <*> cmd) (header (banner "hot") <> progDesc "hOpenPGP OpenPGP-message Tool" <> footer (warranty "hot"))) >>= dispatch cmd :: Parser Command cmd = subparser @@ -126,6 +123,9 @@ <> command "filter" (info ( FilterC <$> foP ) ( progDesc "Filter some packets from stdin to stdout" )) ) +banner' :: Handle -> IO () +banner' h = hPutStrLn h (banner "hot" ++ "\n" ++ warranty "hot") + parseExpressions :: FilteringOptions -> FilterPredicates parseExpressions FilteringOptions{..} = FilterPredicates (mp parsePE pkpExpression) (mp parseSE spExpression) (mp parseOE oExpression) where @@ -244,7 +244,7 @@ rhs <- oValToken return (E (OPredicate lhs op rhs)) where - oVarToken = (A.string "tag" *> pure OVTag) + oVarToken = A.string "tag" *> pure OVTag oOpToken = (A.string "==" *> pure OEquals) <|> (A.string "=" *> pure OEquals) <|> (A.string "<" *> pure OLessThan)