-- 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