hopenpgp-tools 0.0.2 → 0.0.3
raw patch · 4 files changed
+65/−54 lines, 4 filesdep +ansi-wl-pprintdep +textdep ~hOpenPGPdep ~optparse-applicative
Dependencies added: ansi-wl-pprint, text
Dependency ranges changed: hOpenPGP, optparse-applicative
Files
- hkt.hs +6/−10
- hokey.hs +47/−33
- hopenpgp-tools.cabal +7/−5
- hot.hs +5/−6
hkt.hs view
@@ -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
hokey.hs view
@@ -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) -> " <uat>:" ++ (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) -> (" <uat>:"):((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) -> (" <uat>:"):((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 "<uat>" (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 "<uat>" 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 "<uat>" 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
hopenpgp-tools.cabal view
@@ -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 <clint@debian.org>-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
hot.hs view
@@ -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