-- 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.KeyInfo (keySize)
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 && keysize >= 2048) ||
                  (key^.tkPKP^.pkalgo == DSA && keysize >= 2048)
        keysize = keySize (key^.tkPKP^.pubkey)
	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