-- hokey.hs: hOpenPGP key tool
-- Copyright © 2013 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.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.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.IxSet ((@=))
import qualified Data.IxSet as IxSet
import Data.Serialize (get)
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.Types (Parser)
import System.Directory (getHomeDirectory)
import System.IO (hPutStrLn, stderr)
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))
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)
where
rsadsa2 = (key^.tkPKP^.pkalgo == RSA && rsasize >= 2048) ||
(key^.tkPKP^.pkalgo == DSA && dsasize >= 2048)
rsasize = (\(RSAPubKey x) -> RSA.public_size x) (key^.tkPKP^.pubkey) * 8
dsasize = (\(DSAPubKey x) -> bitcount . DSA.params_q . DSA.public_params $ x) (key^.tkPKP^.pubkey) -- should go into lib
bitcount = (*8) . length . unfoldr (\x -> if x == 0 then Nothing else Just (True, x `shiftR` 8))
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)) -> durationPrettyPrinter x) $ filter isKET xs
isKET (SigSubPacket _ (KeyExpirationTime _)) = True
isKET _ = False
-- 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 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
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