diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -23,14 +23,10 @@ import Control.Applicative ((<$>),(<*>), optional) import Control.Lens ((^.)) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.DSA as DSA -import Data.Bits (shiftR) 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) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.IxSet ((@=)) @@ -39,8 +35,8 @@ import Data.Version (showVersion) import System.Directory (getHomeDirectory) -import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, progDesc, str, strOption, subparser) -import Options.Applicative.Extra (execParser) +import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, prefs, progDesc, showHelpOnError, str, strOption, subparser) +import Options.Applicative.Extra (customExecParser) import Options.Applicative.Types (Parser) import System.IO (hPutStrLn, stderr) @@ -52,9 +48,9 @@ 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 " ++ show (keySize (key^.tkPKP^.pubkey)) ++ pkalgoAbbrev (key^.tkPKP^.pkalgo) ++ "/0x" ++ (show . eightOctetKeyID $ key^.tkPKP ) ] 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 " ++ show (keySize (x^.pubkey)) ++ pkalgoAbbrev (x^.pkalgo) ++ "/0x" ++ (show . eightOctetKeyID $ x)) (key^.tkSubs) data Options = Options { keyring :: String @@ -65,7 +61,7 @@ listO :: String -> Parser Options listO homedir = Options - <$> (fromMaybe (homedir ++ "/.gnupg/pubring.gpg") <$> (optional $ strOption + <$> (fromMaybe (homedir ++ "/.gnupg/pubring.gpg") <$> optional (strOption ( long "keyring" <> metavar "FILE" <> help "file containing keyring" ))) @@ -81,7 +77,7 @@ \hkt comes with ABSOLUTELY NO WARRANTY.\n\ \This is free software, and you are welcome to redistribute it\n\ \under certain conditions.\n" - execParser (info (cmd homedir) idm) >>= dispatch + customExecParser (prefs showHelpOnError) (info (cmd homedir) idm) >>= dispatch cmd :: String -> Parser Command cmd homedir = subparser diff --git a/hokey.hs b/hokey.hs --- a/hokey.hs +++ b/hokey.hs @@ -1,5 +1,5 @@ -- hokey.hs: hOpenPGP key tool --- Copyright © 2013 Clint Adams +-- Copyright © 2013-2014 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab -- @@ -19,57 +19,59 @@ import Paths_hopenpgp_tools (version) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID) import Codec.Encryption.OpenPGP.KeyInfo (keySize) +import Codec.Encryption.OpenPGP.KeySelection (parseEightOctetKeyId) import Codec.Encryption.OpenPGP.Types import Control.Applicative ((<$>),(<*>), optional) import Control.Lens ((^.), (^?!), ix) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.DSA as DSA -import Data.Bits (shiftR) 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 Data.List (unfoldr) +import Data.List (unfoldr, elemIndex, findIndex) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) +import Data.Monoid ((<>), mconcat) import Data.IxSet ((@=)) import qualified Data.IxSet as IxSet import Data.Serialize (get) +import qualified Data.Text as T import Data.Version (showVersion) -import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, progDesc, str, strOption, subparser) -import Options.Applicative.Extra (execParser) +import Options.Applicative.Builder (argument, command, help, idm, info, long, metavar, prefs, progDesc, showHelpOnError, str, strOption, subparser) +import Options.Applicative.Extra (customExecParser) import Options.Applicative.Types (Parser) import System.Directory (getHomeDirectory) import System.IO (hPutStrLn, stderr) +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 - return $! IxSet.toList (kr @= (read eok :: EightOctetKeyId)) + let eoki = either ((const . error) "you must specify an eight-octet key ID") id (parseEightOctetKeyId (T.pack eok)) + return $! IxSet.toList (kr @= eoki) checkKey :: TK -> IO () -checkKey key = putStrLn . unlines . execWriter $ do - tell [ "Key has fingerprint: " ++ (show . fingerprint $ key^.tkPKP) ] - tell [ "Checking to see if key is OpenPGPv4: " ++ (show $ V4 == key^.tkPKP^.keyVersion) ] - tell [ "Checking to see if key is RSA or DSA (>= 2048-bit): " ++ (show $ rsadsa2) ] - tell [ "Checking self-sig hash algorithms (poorly): " ] -- FIXME - tell $ map (\(x,ys) -> " " ++ x ++ ": " ++ (show . map hashAlgo . filter (\x -> sigissuer x == Issuer (eoki key)) $ ys)) (key^.tkUIDs) - tell $ map (\(_,ys) -> " :" ++ (show . map hashAlgo . filter (\x -> sigissuer x == Issuer (eoki key)) $ ys)) (key^.tkUAts) - tell [ "Checking preferred hash algorithms (poorly): " ] -- FIXME - tell $ concatMap (\(x,ys) -> (" " ++ x ++ ":"):((map ((" "++) . show . phas) . filter (\x -> sigissuer x == Issuer (eoki key)) $ ys))) (key^.tkUIDs) - tell $ concatMap (\(_,ys) -> (" :"):((map ((" "++) . show . phas) . filter (\x -> sigissuer x == Issuer (eoki key)) $ ys))) (key^.tkUAts) - tell [ "Checking key expiration times (poorly): " ] -- FIXME - tell $ concatMap (\(x,ys) -> (" " ++ x ++ ":"):((map ((" "++) . show . kets) . filter (\x -> sigissuer x == Issuer (eoki key)) $ ys))) (key^.tkUIDs) - tell $ concatMap (\(_,ys) -> (" :"):((map ((" "++) . show . kets) . filter (\x -> sigissuer x == Issuer (eoki key)) $ ys))) (key^.tkUAts) +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 + ) where - rsadsa2 = (key^.tkPKP^.pkalgo == RSA && keysize >= 2048) || - (key^.tkPKP^.pkalgo == DSA && keysize >= 2048) keysize = keySize (key^.tkPKP^.pubkey) - sigissuer (SigV3 _ _ _ _ _ _ _) = 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" @@ -78,19 +80,31 @@ phas (SigV4 _ _ _ xs _ _ _) = concatMap (\(SigSubPacket _ (PreferredHashAlgorithms x)) -> x) $ filter isPHA xs isPHA (SigSubPacket _ (PreferredHashAlgorithms _)) = True isPHA _ = False - kets (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (KeyExpirationTime x)) -> durationPrettyPrinter x) $ filter isKET xs + 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 + 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) + 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 + 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 -- this does not have the same sense of calendar anyone else might durationPrettyPrinter :: TimeStamp -> String durationPrettyPrinter = concat . unfoldr durU where durU x - | x >= 31557600 = Just $ ((++"y") . show $ x `div` 31557600, x `mod` 31557600) - | x >= 2629800 = Just $ ((++"m") . show $ x `div` 2629800, x `mod` 2629800) - | x >= 86400 = Just $ ((++"d") . show $ x `div` 86400, x `mod` 86400) - | x > 0 = Just $ ((++"s") . show $ x, 0) + | x >= 31557600 = Just ((++"y") . show $ x `div` 31557600, x `mod` 31557600) + | x >= 2629800 = Just ((++"m") . show $ x `div` 2629800, x `mod` 2629800) + | x >= 86400 = Just ((++"d") . show $ x `div` 86400, x `mod` 86400) + | x > 0 = Just ((++"s") . show $ x, 0) | otherwise = Nothing data Options = Options { @@ -102,7 +116,7 @@ lintO :: String -> Parser Options lintO homedir = Options - <$> (fromMaybe (homedir ++ "/.gnupg/pubring.gpg") <$> (optional $ strOption + <$> (fromMaybe (homedir ++ "/.gnupg/pubring.gpg") <$> optional (strOption ( long "keyring" <> metavar "FILE" <> help "file containing keyring" ))) @@ -114,11 +128,11 @@ main :: IO () main = do homedir <- getHomeDirectory - hPutStrLn stderr $ "hokey version " ++ showVersion version ++ ", Copyright (C) 2013 Clint Adams\n\ + 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" - execParser (info (cmd homedir) idm) >>= dispatch + customExecParser (prefs showHelpOnError) (info (cmd homedir) idm) >>= dispatch cmd :: String -> Parser Command cmd homedir = subparser 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.0.2 +version: 0.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 @@ -7,7 +7,7 @@ license-file: LICENSE author: Clint Adams maintainer: Clint Adams -copyright: 2012-2013 Clint Adams +copyright: 2012-2014 Clint Adams category: Codec, Data build-type: Simple cabal-version: >=1.10 @@ -30,16 +30,18 @@ main-is: hokey.hs ghc-options: -Wall build-depends: base > 4 && < 5 + , ansi-wl-pprint , bytestring , cereal , cereal-conduit , conduit , crypto-pubkey , directory - , hOpenPGP >= 0.8 + , hOpenPGP >= 0.10 , ixset , lens - , optparse-applicative + , optparse-applicative >= 0.5.0 + , text , transformers default-language: Haskell2010 @@ -56,7 +58,7 @@ , hOpenPGP >= 0.8 , ixset , lens - , optparse-applicative + , optparse-applicative >= 0.5.0 , transformers default-language: Haskell2010 diff --git a/hot.hs b/hot.hs --- a/hot.hs +++ b/hot.hs @@ -39,8 +39,8 @@ import System.IO (stdin, stderr, hPutStrLn, hFlush, hSetBuffering, BufferMode(..)) -import Options.Applicative.Builder (command, help, idm, info, long, metavar, nullOption, reader, progDesc, strOption, subparser, ParseError(..)) -import Options.Applicative.Extra (execParser) +import Options.Applicative.Builder (command, help, idm, info, long, metavar, nullOption, reader, prefs, progDesc, showHelpOnError, strOption, subparser, ParseError(..)) +import Options.Applicative.Extra (customExecParser) import Options.Applicative.Types (Parser, ReadM(..)) data Command = DumpC | DeArmorC | ArmorC ArmoringOptions @@ -51,8 +51,7 @@ } doDump :: IO () -doDump = do - runResourceT $ CB.sourceHandle stdin $= conduitGet (get :: Get Pkt) $$ printer +doDump = runResourceT $ CB.sourceHandle stdin $= conduitGet (get :: Get Pkt) $$ printer -- Print every input value to standard output. printer :: (Show a, MonadIO m) => Sink a m () @@ -68,7 +67,7 @@ doArmor :: ArmoringOptions -> IO () doArmor ArmoringOptions{..} = do m <- runResourceT $ CB.sourceHandle stdin $$ CL.consume - let a = Armor armortype ([("Version", "hot " ++ showVersion version)] ++ maybe [] (\x -> [("Comment", x)]) comment ) (BL.fromChunks m) + let a = Armor armortype (("Version", "hot " ++ showVersion version):maybe [] (\x -> [("Comment", x)]) comment ) (BL.fromChunks m) BL.putStr $ AA.encodeLazy [a] armorTypeReader :: String -> ReadM ArmorType @@ -99,7 +98,7 @@ \under certain conditions.\n" hFlush stderr - execParser (info cmd idm) >>= dispatch + customExecParser (prefs showHelpOnError) (info cmd idm) >>= dispatch cmd :: Parser Command cmd = subparser