-- hot.hs: hOpenPGP Tool
-- Copyright © 2012-2026  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/>.
{-# LANGUAGE RecordWildCards #-}

import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
    ( Armor (..)
    , ArmorType (..)
    )
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Control.Applicative (optional)
import Control.Error.Util (note)
import Control.Exception (ErrorCall, evaluate, try)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Reader (Reader)
import qualified Data.Aeson as A
import Data.Binary (get, put)
import Data.Binary.Get (Get)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (ConduitM, runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Filter
    ( FilterPredicates (RPFilterPredicate)
    , conduitPktFilter
    )
import Data.Conduit.Serialization.Binary (conduitGet, conduitPut)
import Data.Void (Void)
import qualified Data.Yaml as Y
import Options.Applicative.Builder
    ( argument
    , command
    , eitherReader
    , footerDoc
    , headerDoc
    , help
    , helpDoc
    , info
    , long
    , metavar
    , option
    , prefs
    , progDesc
    , showDefaultWith
    , showHelpOnError
    , str
    , strOption
    , value
    )
import Options.Applicative.Extra
    ( customExecParser
    , helper
    , hsubparser
    )
import Options.Applicative.Types (Parser)
import Prettyprinter
    ( Pretty
    , group
    , hardline
    , list
    , pretty
    , softline
    , (<+>)
    )
import Prettyprinter.Render.Text (hPutDoc)
import System.Exit (exitFailure)
import System.IO
    ( BufferMode (..)
    , Handle
    , hFlush
    , hPutStrLn
    , hSetBuffering
    , stderr
    , stdin
    , stdout
    )

import HOpenPGP.Tools.Common.Armor (doDeArmor)
import HOpenPGP.Tools.Common.Common
    ( banner
    , prependAuto
    , versioner
    , warranty
    )
import HOpenPGP.Tools.Common.Parser (parsePExp)

data Command
    = DumpC DumpOptions
    | DeArmorC
    | ArmorC ArmoringOptions
    | FilterC FilteringOptions

data DumpOptions
    = DumpOptions
    { outputformat :: DumpOutputFormat
    }

data FilteringOptions
    = FilteringOptions
    { fExpression :: String
    }

data DumpOutputFormat
    = DumpPretty
    | DumpJSON
    | DumpYAML
    | DumpShow
    deriving (Bounded, Enum, Read, Show)

doDump :: DumpOptions -> IO ()
doDump DumpOptions {..} =
    runConduitRes $
        CB.sourceHandle stdin
            .| conduitGet (get :: Get Pkt)
            .| case outputformat of
                DumpPretty -> prettyPrinter
                DumpJSON -> jsonSink
                DumpYAML -> yamlSink
                DumpShow -> printer

-- Print every input value to standard output.
printer :: (MonadIO m, Show a) => ConduitM a Void m ()
printer = CL.mapM_ (liftIO . print)

prettyPrinter :: (MonadIO m, Pretty a) => ConduitM a Void m ()
prettyPrinter =
    CL.mapM_
        (liftIO . hPutDoc stdout . (<> hardline) . group . pretty)

jsonSink :: (A.ToJSON a, MonadIO m) => ConduitM a Void m ()
jsonSink = CL.mapM_ (liftIO . BL.putStr . flip BL.snoc 0x0a . A.encode)

yamlSink :: (MonadIO m, Y.ToJSON a) => ConduitM a Void m ()
yamlSink = CL.mapM_ (liftIO . B.putStr . flip B.snoc 0x0a . Y.encode)

doFilter :: FilteringOptions -> IO ()
doFilter fo =
    parseExpressions fo >>= \parsed ->
        case parsed of
            Left err -> dieHot err
            Right predicates ->
                runConduitRes $
                    CB.sourceHandle stdin
                        .| conduitGet (get :: Get Pkt)
                        .| conduitPktFilter predicates
                        .| CL.map put
                        .| conduitPut
                        .| CB.sinkHandle stdout

doP :: Parser DumpOptions
doP =
    DumpOptions
        <$> option
            (prependAuto "Dump")
            ( long "output-format"
                <> metavar "FORMAT"
                <> value DumpPretty
                <> showDefaultWith (drop 4 . show)
                <> ofHelp
            )
  where
    ofHelp =
        helpDoc . Just $
            pretty "output format"
                <> hardline
                <> list (map (pretty . drop 4 . show) ofchoices)
    ofchoices = [minBound .. maxBound] :: [DumpOutputFormat]

foP :: Parser FilteringOptions
foP =
    FilteringOptions
        <$> argument str (metavar "EXPRESSION" <> filterTargetHelp)
  where
    filterTargetHelp =
        helpDoc . Just $
            pretty "packet filter expression"
                <+> softline
                <> pretty "see source for current syntax"

dispatch :: Command -> IO ()
dispatch c = (banner' stderr >> hFlush stderr) >> dispatch' c
  where
    dispatch' (DumpC o) = doDump o
    dispatch' DeArmorC = doDeArmor
    dispatch' (ArmorC o) = doArmor o
    dispatch' (FilterC o) = doFilter o

main :: IO ()
main = do
    hSetBuffering stderr LineBuffering
    customExecParser
        (prefs showHelpOnError)
        ( info
            (helper <*> versioner "hot" <*> cmd)
            ( headerDoc (Just (banner "hot"))
                <> progDesc "hOpenPGP OpenPGP-message Tool"
                <> footerDoc (Just (warranty "hot"))
            )
        )
        >>= dispatch

cmd :: Parser Command
cmd =
    hsubparser
        ( command
            "armor"
            (info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout"))
            <> command
                "dearmor"
                (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))
            <> command
                "dump"
                (info (DumpC <$> doP) (progDesc "Dump OpenPGP packets from stdin"))
            <> command
                "filter"
                ( info
                    (FilterC <$> foP)
                    (progDesc "Filter some packets from stdin to stdout")
                )
        )

banner' :: Handle -> IO ()
banner' h =
    hPutDoc
        h
        (banner "hot" <> hardline <> warranty "hot" <> hardline)

parseExpressions
    :: FilteringOptions -> IO (Either String (FilterPredicates r a))
parseExpressions FilteringOptions {..} = do
    parsed <- parseE fExpression
    pure (RPFilterPredicate <$> parsed)
  where
    parseE e = do
        parsed <-
            try (evaluate (parsePExp e :: Either String (Reader Pkt Bool)))
                :: IO (Either ErrorCall (Either String (Reader Pkt Bool)))
        pure $
            case parsed of
                Left err -> Left (show (err :: ErrorCall))
                Right v -> v

armorTypes :: [(String, ArmorType)]
armorTypes =
    [ ("message", ArmorMessage)
    , ("pubkeyblock", ArmorPublicKeyBlock)
    , ("privkeyblock", ArmorPrivateKeyBlock)
    , ("signature", ArmorSignature)
    ]

armorTypeReader :: String -> Either String ArmorType
armorTypeReader = note "unknown armor type" . flip lookup armorTypes

aoP :: Parser ArmoringOptions
aoP =
    ArmoringOptions
        <$> optional
            ( strOption
                ( long "comment"
                    <> metavar "COMMENT"
                    <> help "ASCII armor Comment field"
                )
            )
        <*> option
            (eitherReader armorTypeReader)
            (long "armor-type" <> metavar "ARMORTYPE" <> armortypeHelp)
  where
    armortypeHelp =
        helpDoc . Just $
            pretty "ASCII armor type"
                <> softline
                <> list (map (pretty . fst) armorTypes)

data ArmoringOptions
    = ArmoringOptions
    { comment :: Maybe String
    , armortype :: ArmorType
    }

doArmor :: ArmoringOptions -> IO ()
doArmor ArmoringOptions {..} = do
    m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
    let a =
            Armor
                armortype
                (maybe [] (\x -> [("Comment", x)]) comment)
                (BL.fromChunks m)
    BL.putStr $ AA.encodeLazy [a]

dieHot :: String -> IO a
dieHot msg = hPutStrLn stderr msg >> exitFailure
