-- 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, helper)
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 (helper <*> 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