-- hokey.hs: hOpenPGP key tool
-- Copyright © 2013-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 <http://www.gnu.org/licenses/>.
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 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, elemIndex, findIndex)
import Data.Maybe (fromMaybe)
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, 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
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 = 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
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
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
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)
| otherwise = Nothing
data Options = Options {
keyring :: String
, target :: String
}
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" )
dispatch :: Command -> IO ()
dispatch (Lint o) = 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 (cmd homedir) idm) >>= dispatch
cmd :: String -> Parser Command
cmd homedir = subparser
( command "lint" (info ( Lint <$> lintO homedir) ( progDesc "check key(s) for 'best practices'" )))
doLint :: Options -> IO ()
doLint o = do
keys <- grabMatchingKeys (keyring o) (target o)
mapM_ checkKey keys