From 8c698eec9024e015eda514f00e327872770036c2 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 14 Aug 2013 21:05:11 -0400 Subject: Implemented list/autosign multi-command interface --- keys.hs | 133 ++++++++++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 112 insertions(+), 21 deletions(-) (limited to 'keys.hs') diff --git a/keys.hs b/keys.hs index 73d3192..00116f8 100644 --- a/keys.hs +++ b/keys.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} module Main where import Debug.Trace @@ -10,7 +12,8 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as Char8 import qualified Data.ByteString as S import Control.Monad -import Text.Show.Pretty +import qualified Text.Show.Pretty as PP +import Text.PrettyPrint as PP import Data.List import Data.OpenPGP.CryptoAPI import Data.Ord @@ -35,6 +38,7 @@ import System.Exit import ControlMaybe import Data.Char import Control.Arrow (second) +import Data.Traversable data RSAPublicKey = RSAKey MPI MPI @@ -433,8 +437,13 @@ parseOptionFile fname = do notComment cs = not (all isSpace cs) return ys -options_from_file :: Term a -> (String,String,Term (Maybe String)) -> ([String],Term (Maybe String)) -> IO [String] -options_from_file term (homevar,appdir,home) (optfile_alts,options_file) = doit +options_from_file :: + (forall a. [String] -> Term a -> IO (Either EvalExit a)) + -> Term b + -> (String,String,Term (Maybe String)) + -> ([String],Term (Maybe String)) + -> IO [String] +options_from_file unwrapCmd term (homevar,appdir,home) (optfile_alts,options_file) = doit where homedir = envhomedir <$> home envhomedir opt = do @@ -443,26 +452,24 @@ options_from_file term (homevar,appdir,home) (optfile_alts,options_file) = doit home <- flip fmap getHomeDirectory $ \d -> fmap (const d) $ guard (d/="") let homegnupg = (++('/':appdir)) <$> home - return $ (opt `mplus` gnupghome `mplus` homegnupg) + let val = (opt `mplus` gnupghome `mplus` homegnupg) + return $ val doit = do args <- getArgs + {- let wants_help = not . null $ filter cryForHelp args where cryForHelp "--help" = True cryForHelp "--version" = True cryForHelp x = and (zipWith (==) x "--help=") + -} (o,h) <- do - val <- unwrap args (liftA2 (,) options_file homedir, defTI) + val <- unwrapCmd args (liftA2 (,) options_file homedir) case val of - _ | wants_help -> return (Nothing,Nothing) - {- - Left e -> putStrLn ("Unable to find home directory ") - >> exitFailure - -} Left e -> return (Nothing,Nothing) - Right (o,h) -> fmap (o,) h + Right (o,h) -> (o,) <$> h ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> let optfiles = map (second ((h++"/")++)) (maybe optfile_alts' (:[]) o') @@ -487,23 +494,107 @@ options_from_file term (homevar,appdir,home) (optfile_alts,options_file) = doit appendArgs args newargs return args +runWithOptionsFile :: (Term (IO b), TermInfo) -> IO b runWithOptionsFile (term,ti) = do - as <- options_from_file term + as <- options_from_file unwrapCmd + term ("GNUPGHOME",".gnupg",opt_homedir) (["keys.conf","gpg.conf-2","gpg.conf"] ,opt_options) q <- eval as (term , ti) q + where + unwrapCmd args term = unwrap args (term,defTI) -main = do - q <- runWithOptionsFile (listSecretKeys, defTI { termName = "keys", CmdTheLine.version = "0.1" }) - return () +runChoiceWithOptionsFile :: + (Term (IO b), TermInfo) -> [(Term (IO b), TermInfo)] -> IO b +runChoiceWithOptionsFile (realterm,ti) choices = do + as <- options_from_file unwrapCmd + realterm + ("GNUPGHOME",".gnupg",opt_homedir) + (["keys.conf","gpg.conf-2","gpg.conf"] + ,opt_options) + -- putStrLn $ "as = " ++ show as + q <- evalChoice as (realterm , ti) choices + q where - -- showhome = flip const <$> opt_options <*> ( (>>= putStrLn) <$> homedir ) - showhome = opt_default_key <:> opt_options <:> ( (>>= putStrLn) <$> homedir ) - a <:> b = flip const <$> a <*> b - infixr 2 <:> + unwrapCmd args t = + unwrapChoice args (realterm <:> t,ti) (map (neuter t) choices) + neuter term (t,ti) = (t <:> term, ti) - listSecretKeys = opt_options <:> (>>= list) <$> secret_packets +data Command = + List + | Autosign + deriving (Eq,Show,Read,Enum) - list (Message pkts) = putStrLn $ listKeys pkts +capitolizeFirstLetter (x:xs) = toUpper x : xs +capitolizeFirstLetter xs = xs + +instance ArgVal Command where + converter = + ( maybe (Left $ text "unknown command") Right + . fmap fst . listToMaybe . reads + . capitolizeFirstLetter . map toLower + , text . map toLower . show + ) +class AutoMaybe a +instance AutoMaybe Command +instance (ArgVal a, AutoMaybe a) => ArgVal (Maybe a) where + converter = + ( toRight Just . fst converter + , maybe (text "(unspecified)") id . fmap (snd converter) + ) + +toRight f (Right x) = Right (f x) +toRight f (Left y) = Left y + +cmd :: Term Command +cmd = required . pos 0 Nothing $ posInfo + { posName = "command" + , posDoc = "What action to perform." + } + +a <:> b = flip const <$> a <*> b +infixr 2 <:> + + +selectAction cmd actions = actions !! fromEnum cmd + +cmdInfo :: ArgVal cmd => + cmd -> String -> Term a -> (cmd, (Term a, TermInfo)) +cmdInfo cmd doc action = + ( cmd + , ( action + , defTI { termName = print cmd + , termDoc = doc } ) ) + where + print = show . snd converter + +cmdlist :: (Command, (Term (IO ()), TermInfo)) +cmdlist = cmdInfo List "list key pairs for which secrets are known" $ + (>>= putStrLn . listKeys . unMessage) <$> secret_packets + where unMessage (Message pkts) = pkts + +cmdautosign = cmdInfo Autosign "auto-sign tor-style uids" $ + pure (putStrLn "autosign") + + +multiCommand :: + TermInfo + -> [(Command, (Term a, TermInfo))] + -> ( (Term a, TermInfo) + , [(Term a, TermInfo)] ) +multiCommand ti choices = + ( ( selectAction <$> cmd <*> sequenceA (map strip choices) + , ti ) + , map snd choices ) + where + selectAction cmd choices = + fromJust $ lookup (cmd::Command) choices + strip (cmd,(action,_)) = fmap (cmd,) action + +main = do + let version = defTI { termName = "keys", CmdTheLine.version = "0.1" } + q <- uncurry runChoiceWithOptionsFile $ multiCommand version + [ cmdlist, cmdautosign ] + return () -- cgit v1.2.3