-- 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 HOpenPGP.Tools.ExpressionParsing (pPE)
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.Attoparsec.Text as A
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.Filter (Expr(..), PKPPredicate(..), PKPOp(..), PKPVar(..), PKPValue(..))
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, switch)
import Options.Applicative.Extra (customExecParser, helper)
import Options.Applicative.Types (Parser)
import System.IO (Handle, hFlush, hPutStrLn, stderr, hSetBuffering, BufferMode(..))
grabMatchingKeys :: FilePath -> Bool -> String -> IO [TK]
grabMatchingKeys fp filt srch = runResourceT $
CB.sourceFile fp $= conduitGet get $= conduitToTKsDropping $= CL.filter (if filt then filterMatch else matchAny) $$ CL.consume
where
matchAny tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) efp <|> fmap (keyMatchesEightOctetKeyId True tk) eeok <|> return (keyMatchesUIDSubString srch tk)
filterMatch tk = eval pkpEval (either error id (A.parseOnly pPE (T.pack srch))) (_tkPKP 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
, targetIsFilter :: Bool
, 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" )))
<*> switch ( long "filter" <> help "treat target as filter" )
<*> 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 "hkt"))) >>= 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) (targetIsFilter o) (target o)
mapM_ showKey keys
doExportPubkeys :: Options -> IO ()
doExportPubkeys o = do
keys <- grabMatchingKeys (keyring o) (targetIsFilter 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
-- FIXME: deduplicate the following code
eval :: (a -> v -> Bool) -> Expr a -> v -> Bool
eval t e v = ev e
where
ev EAny = True
ev (EAnd e1 e2) = ev e1 && ev e2
ev (EOr e1 e2) = ev e1 || ev e2
ev (ENot e1) = (not . ev) e1
ev (E e') = t e' v
pkpEval :: PKPPredicate -> PKPayload -> Bool
pkpEval (PKPPredicate lhs o rhs) pkp = uncurry (opreduce o) (vreduce (lhs,pkp),rhs)
where
opreduce PKEquals = (==)
opreduce PKLessThan = (<)
opreduce PKGreaterThan = (>)
vreduce (PKPVVersion, p) = PKPInt (kv (_keyVersion p))
vreduce (PKPVPKA, p) = PKPPKA (_pkalgo p)
vreduce (PKPVKeysize, p) = PKPInt (keySize . _pubkey $ p)
vreduce (PKPVTimestamp, p) = PKPInt (fromIntegral (_timestamp p))
kv DeprecatedV3 = 3
kv V4 = 4