hopenpgp-tools-0.2: hkt.hs

-- hkt.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 HOpenPGP.Tools.Common (banner, versioner, warranty, keyMatchesFingerprint, keyMatchesEightOctetKeyId, keyMatchesUIDSubString)
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID)
import Codec.Encryption.OpenPGP.KeyInfo (keySize, pkalgoAbbrev)
import Codec.Encryption.OpenPGP.KeySelection (parseEightOctetKeyId, parseFingerprint)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Types
import Control.Applicative ((<$>),(<*>), optional, (<|>))
import Control.Lens ((^.))
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 qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
import Data.Foldable (traverse_)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Serialize (get, put, runPut)
import qualified Data.Text as T
import System.Directory (getHomeDirectory)

import Options.Applicative.Builder (argument, command, footer, header, help, info, long, metavar, prefs, progDesc, showHelpOnError, str, strOption, subparser)
import Options.Applicative.Extra (customExecParser, helper)
import Options.Applicative.Types (Parser)

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

grabMatchingKeys :: FilePath -> String -> IO [TK]
grabMatchingKeys fp srch = runResourceT $
    CB.sourceFile fp $= conduitGet get $= conduitToTKsDropping $= CL.filter matchAny $$ CL.consume
    where
        matchAny tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) efp <|> fmap (keyMatchesEightOctetKeyId True tk) eeok <|> return (keyMatchesUIDSubString srch tk)
        efp = parseFingerprint . T.pack $ srch
        eeok = parseEightOctetKeyId . T.pack $ srch

showKey :: TK -> IO ()
showKey key = putStrLn . unlines . execWriter $ do
    tell [ "pub   " ++ show (keySize (key^.tkPKP^.pubkey)) ++ pkalgoAbbrev (key^.tkPKP^.pkalgo) ++ "/0x" ++ (show . eightOctetKeyID $ key^.tkPKP ) ]
    tell $ map (\(x,_) -> "uid                            " ++ x) (key^.tkUIDs)
    tell $ map (\(PublicSubkeyPkt x,_,_) -> "sub   " ++ show (keySize (x^.pubkey)) ++ pkalgoAbbrev (x^.pkalgo) ++ "/0x" ++ (show . eightOctetKeyID $ x)) (key^.tkSubs)

data Options = Options {
    keyring :: String
  , target :: String
}

data Command = List Options | ExportPubkeys Options

listO :: String -> Parser Options
listO 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 (List o) = banner' stderr >> hFlush stderr >> doList o
dispatch (ExportPubkeys o) = banner' stderr >> hFlush stderr >> doExportPubkeys o

main :: IO ()
main = do
    hSetBuffering stderr LineBuffering
    homedir <- getHomeDirectory
    customExecParser (prefs showHelpOnError) (info (helper <*> versioner <*> cmd homedir) (header (banner "hkt") <> progDesc "hOpenPGP Keyring Tool" <> footer (warranty "hot"))) >>= dispatch

cmd :: String -> Parser Command
cmd homedir = subparser
    ( command "list" (info ( List <$> listO homedir) ( progDesc "list matching keys" ))
   <> command "export-pubkeys" (info ( ExportPubkeys <$> listO homedir) ( progDesc "export matching keys to stdout" )))

banner' :: Handle -> IO ()
banner' h = hPutStrLn h (banner "hkt" ++ "\n" ++ warranty "hkt")

doList :: Options -> IO ()
doList o = do
    keys <- grabMatchingKeys (keyring o) (target o)
    mapM_ showKey keys

doExportPubkeys :: Options -> IO ()
doExportPubkeys o = do
    keys <- grabMatchingKeys (keyring o) (target o)
    mapM_ (B.putStr . putTK') keys
    where
        putTK' key = runPut $ do
            put (PublicKey (_tkPKP key))
            mapM_ (put . Signature) (_tkRevs key)
            mapM_ putUid' (_tkUIDs key)
            mapM_ putUat' (_tkUAts key)
            mapM_ putSub' (_tkSubs key)
        putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps
        putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps
        putSub' (p, sp, msp) = put p >> (put . Signature) sp >> traverse_ (put . Signature) msp