hopenpgp-tools-0.0.2: hot.hs

{-# LANGUAGE RecordWildCards #-}

-- hot.hs: hOpenPGP Tool
-- Copyright © 2012-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 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 (Pkt)
import Control.Applicative ((<$>),(<*>), optional, pure)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (($=), ($$), Sink, runResourceT)
import Data.Conduit.Cereal (conduitGet)
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Serialize (get)
import Data.Serialize.Get (Get)

import Data.Version (showVersion)
import Data.Monoid ((<>))

import System.IO (stdin, stderr, hPutStrLn, hFlush, hSetBuffering, BufferMode(..))

import Options.Applicative.Builder (command, help, idm, info, long, metavar, nullOption, reader, progDesc, strOption, subparser, ParseError(..))
import Options.Applicative.Extra (execParser)
import Options.Applicative.Types (Parser, ReadM(..))

data Command = DumpC | DeArmorC | ArmorC ArmoringOptions

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

doDump :: IO ()
doDump = do
    runResourceT $ CB.sourceHandle stdin $= conduitGet (get :: Get Pkt) $$ printer

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

doDeArmor :: IO ()
doDeArmor = do
    a <- runResourceT $ CB.sourceHandle stdin $$ CL.consume
    case AA.decode (B.concat a) of
        Left e -> hPutStrLn stderr $ "Failure to decode ASCII Armor:" ++ e
        Right msgs -> BL.putStr $ BL.concat (map (\(Armor _ _ bs) -> bs) msgs)

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

armorTypeReader :: String -> ReadM ArmorType
armorTypeReader = ReadM . armorTypeReader'
    where
        armorTypeReader' "message" = Right ArmorMessage	 
        armorTypeReader' "pubkeyblock" = Right ArmorPublicKeyBlock	 
        armorTypeReader' "privkeyblock" = Right ArmorPrivateKeyBlock	 
        armorTypeReader' "signature" = Right ArmorSignature
        armorTypeReader' _ = Left (ErrorMsg "unknown armor type")

aoP :: Parser ArmoringOptions
aoP = ArmoringOptions
    <$> optional (strOption (long "comment" <> metavar "COMMENT" <> help "ASCII armor Comment field"))
    <*> nullOption (long "armor-type" <> reader armorTypeReader <> metavar "ARMORTYPE" <> help "ASCII armor type")

dispatch :: Command -> IO ()
dispatch DumpC = doDump
dispatch DeArmorC = doDeArmor
dispatch (ArmorC o) = doArmor o

main :: IO ()
main = do
    hSetBuffering stderr LineBuffering
    hPutStrLn stderr $ "hot version " ++ showVersion version ++ ", Copyright (C) 2012-2013  Clint Adams\n\
   \hot comes with ABSOLUTELY NO WARRANTY.\n\
   \This is free software, and you are welcome to redistribute it\n\
   \under certain conditions.\n"
    hFlush stderr

    execParser (info cmd idm) >>= dispatch

cmd :: Parser Command
cmd = subparser
  ( command "dump" (info ( pure DumpC ) ( progDesc "Dump OpenPGP packets from stdin" ))
 <> command "dearmor" (info ( pure DeArmorC ) ( progDesc "Dearmor stdin to stdout" ))
 <> command "armor" (info ( ArmorC <$> aoP ) ( progDesc "Armor stdin to stdout" ))
  )