diff options
-rw-r--r-- | keys.hs | 133 |
1 files changed, 112 insertions, 21 deletions
@@ -1,6 +1,8 @@ | |||
1 | {-# LANGUAGE ViewPatterns #-} | 1 | {-# LANGUAGE ViewPatterns #-} |
2 | {-# LANGUAGE TupleSections #-} | 2 | {-# LANGUAGE TupleSections #-} |
3 | {-# LANGUAGE OverloadedStrings #-} | 3 | {-# LANGUAGE OverloadedStrings #-} |
4 | {-# LANGUAGE RankNTypes #-} | ||
5 | {-# LANGUAGE FlexibleInstances #-} | ||
4 | module Main where | 6 | module Main where |
5 | 7 | ||
6 | import Debug.Trace | 8 | import Debug.Trace |
@@ -10,7 +12,8 @@ import qualified Data.ByteString.Lazy as L | |||
10 | import qualified Data.ByteString.Lazy.Char8 as Char8 | 12 | import qualified Data.ByteString.Lazy.Char8 as Char8 |
11 | import qualified Data.ByteString as S | 13 | import qualified Data.ByteString as S |
12 | import Control.Monad | 14 | import Control.Monad |
13 | import Text.Show.Pretty | 15 | import qualified Text.Show.Pretty as PP |
16 | import Text.PrettyPrint as PP | ||
14 | import Data.List | 17 | import Data.List |
15 | import Data.OpenPGP.CryptoAPI | 18 | import Data.OpenPGP.CryptoAPI |
16 | import Data.Ord | 19 | import Data.Ord |
@@ -35,6 +38,7 @@ import System.Exit | |||
35 | import ControlMaybe | 38 | import ControlMaybe |
36 | import Data.Char | 39 | import Data.Char |
37 | import Control.Arrow (second) | 40 | import Control.Arrow (second) |
41 | import Data.Traversable | ||
38 | 42 | ||
39 | data RSAPublicKey = RSAKey MPI MPI | 43 | data RSAPublicKey = RSAKey MPI MPI |
40 | 44 | ||
@@ -433,8 +437,13 @@ parseOptionFile fname = do | |||
433 | notComment cs = not (all isSpace cs) | 437 | notComment cs = not (all isSpace cs) |
434 | return ys | 438 | return ys |
435 | 439 | ||
436 | options_from_file :: Term a -> (String,String,Term (Maybe String)) -> ([String],Term (Maybe String)) -> IO [String] | 440 | options_from_file :: |
437 | options_from_file term (homevar,appdir,home) (optfile_alts,options_file) = doit | 441 | (forall a. [String] -> Term a -> IO (Either EvalExit a)) |
442 | -> Term b | ||
443 | -> (String,String,Term (Maybe String)) | ||
444 | -> ([String],Term (Maybe String)) | ||
445 | -> IO [String] | ||
446 | options_from_file unwrapCmd term (homevar,appdir,home) (optfile_alts,options_file) = doit | ||
438 | where | 447 | where |
439 | homedir = envhomedir <$> home | 448 | homedir = envhomedir <$> home |
440 | envhomedir opt = do | 449 | envhomedir opt = do |
@@ -443,26 +452,24 @@ options_from_file term (homevar,appdir,home) (optfile_alts,options_file) = doit | |||
443 | home <- flip fmap getHomeDirectory $ | 452 | home <- flip fmap getHomeDirectory $ |
444 | \d -> fmap (const d) $ guard (d/="") | 453 | \d -> fmap (const d) $ guard (d/="") |
445 | let homegnupg = (++('/':appdir)) <$> home | 454 | let homegnupg = (++('/':appdir)) <$> home |
446 | return $ (opt `mplus` gnupghome `mplus` homegnupg) | 455 | let val = (opt `mplus` gnupghome `mplus` homegnupg) |
456 | return $ val | ||
447 | 457 | ||
448 | doit = do | 458 | doit = do |
449 | args <- getArgs | 459 | args <- getArgs |
460 | {- | ||
450 | let wants_help = | 461 | let wants_help = |
451 | not . null $ filter cryForHelp args | 462 | not . null $ filter cryForHelp args |
452 | where cryForHelp "--help" = True | 463 | where cryForHelp "--help" = True |
453 | cryForHelp "--version" = True | 464 | cryForHelp "--version" = True |
454 | cryForHelp x = | 465 | cryForHelp x = |
455 | and (zipWith (==) x "--help=") | 466 | and (zipWith (==) x "--help=") |
467 | -} | ||
456 | (o,h) <- do | 468 | (o,h) <- do |
457 | val <- unwrap args (liftA2 (,) options_file homedir, defTI) | 469 | val <- unwrapCmd args (liftA2 (,) options_file homedir) |
458 | case val of | 470 | case val of |
459 | _ | wants_help -> return (Nothing,Nothing) | ||
460 | {- | ||
461 | Left e -> putStrLn ("Unable to find home directory ") | ||
462 | >> exitFailure | ||
463 | -} | ||
464 | Left e -> return (Nothing,Nothing) | 471 | Left e -> return (Nothing,Nothing) |
465 | Right (o,h) -> fmap (o,) h | 472 | Right (o,h) -> (o,) <$> h |
466 | ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> | 473 | ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> |
467 | let optfiles = map (second ((h++"/")++)) | 474 | let optfiles = map (second ((h++"/")++)) |
468 | (maybe optfile_alts' (:[]) o') | 475 | (maybe optfile_alts' (:[]) o') |
@@ -487,23 +494,107 @@ options_from_file term (homevar,appdir,home) (optfile_alts,options_file) = doit | |||
487 | appendArgs args newargs | 494 | appendArgs args newargs |
488 | return args | 495 | return args |
489 | 496 | ||
497 | runWithOptionsFile :: (Term (IO b), TermInfo) -> IO b | ||
490 | runWithOptionsFile (term,ti) = do | 498 | runWithOptionsFile (term,ti) = do |
491 | as <- options_from_file term | 499 | as <- options_from_file unwrapCmd |
500 | term | ||
492 | ("GNUPGHOME",".gnupg",opt_homedir) | 501 | ("GNUPGHOME",".gnupg",opt_homedir) |
493 | (["keys.conf","gpg.conf-2","gpg.conf"] | 502 | (["keys.conf","gpg.conf-2","gpg.conf"] |
494 | ,opt_options) | 503 | ,opt_options) |
495 | q <- eval as (term , ti) | 504 | q <- eval as (term , ti) |
496 | q | 505 | q |
506 | where | ||
507 | unwrapCmd args term = unwrap args (term,defTI) | ||
497 | 508 | ||
498 | main = do | 509 | runChoiceWithOptionsFile :: |
499 | q <- runWithOptionsFile (listSecretKeys, defTI { termName = "keys", CmdTheLine.version = "0.1" }) | 510 | (Term (IO b), TermInfo) -> [(Term (IO b), TermInfo)] -> IO b |
500 | return () | 511 | runChoiceWithOptionsFile (realterm,ti) choices = do |
512 | as <- options_from_file unwrapCmd | ||
513 | realterm | ||
514 | ("GNUPGHOME",".gnupg",opt_homedir) | ||
515 | (["keys.conf","gpg.conf-2","gpg.conf"] | ||
516 | ,opt_options) | ||
517 | -- putStrLn $ "as = " ++ show as | ||
518 | q <- evalChoice as (realterm , ti) choices | ||
519 | q | ||
501 | where | 520 | where |
502 | -- showhome = flip const <$> opt_options <*> ( (>>= putStrLn) <$> homedir ) | 521 | unwrapCmd args t = |
503 | showhome = opt_default_key <:> opt_options <:> ( (>>= putStrLn) <$> homedir ) | 522 | unwrapChoice args (realterm <:> t,ti) (map (neuter t) choices) |
504 | a <:> b = flip const <$> a <*> b | 523 | neuter term (t,ti) = (t <:> term, ti) |
505 | infixr 2 <:> | ||
506 | 524 | ||
507 | listSecretKeys = opt_options <:> (>>= list) <$> secret_packets | 525 | data Command = |
526 | List | ||
527 | | Autosign | ||
528 | deriving (Eq,Show,Read,Enum) | ||
508 | 529 | ||
509 | list (Message pkts) = putStrLn $ listKeys pkts | 530 | capitolizeFirstLetter (x:xs) = toUpper x : xs |
531 | capitolizeFirstLetter xs = xs | ||
532 | |||
533 | instance ArgVal Command where | ||
534 | converter = | ||
535 | ( maybe (Left $ text "unknown command") Right | ||
536 | . fmap fst . listToMaybe . reads | ||
537 | . capitolizeFirstLetter . map toLower | ||
538 | , text . map toLower . show | ||
539 | ) | ||
540 | class AutoMaybe a | ||
541 | instance AutoMaybe Command | ||
542 | instance (ArgVal a, AutoMaybe a) => ArgVal (Maybe a) where | ||
543 | converter = | ||
544 | ( toRight Just . fst converter | ||
545 | , maybe (text "(unspecified)") id . fmap (snd converter) | ||
546 | ) | ||
547 | |||
548 | toRight f (Right x) = Right (f x) | ||
549 | toRight f (Left y) = Left y | ||
550 | |||
551 | cmd :: Term Command | ||
552 | cmd = required . pos 0 Nothing $ posInfo | ||
553 | { posName = "command" | ||
554 | , posDoc = "What action to perform." | ||
555 | } | ||
556 | |||
557 | a <:> b = flip const <$> a <*> b | ||
558 | infixr 2 <:> | ||
559 | |||
560 | |||
561 | selectAction cmd actions = actions !! fromEnum cmd | ||
562 | |||
563 | cmdInfo :: ArgVal cmd => | ||
564 | cmd -> String -> Term a -> (cmd, (Term a, TermInfo)) | ||
565 | cmdInfo cmd doc action = | ||
566 | ( cmd | ||
567 | , ( action | ||
568 | , defTI { termName = print cmd | ||
569 | , termDoc = doc } ) ) | ||
570 | where | ||
571 | print = show . snd converter | ||
572 | |||
573 | cmdlist :: (Command, (Term (IO ()), TermInfo)) | ||
574 | cmdlist = cmdInfo List "list key pairs for which secrets are known" $ | ||
575 | (>>= putStrLn . listKeys . unMessage) <$> secret_packets | ||
576 | where unMessage (Message pkts) = pkts | ||
577 | |||
578 | cmdautosign = cmdInfo Autosign "auto-sign tor-style uids" $ | ||
579 | pure (putStrLn "autosign") | ||
580 | |||
581 | |||
582 | multiCommand :: | ||
583 | TermInfo | ||
584 | -> [(Command, (Term a, TermInfo))] | ||
585 | -> ( (Term a, TermInfo) | ||
586 | , [(Term a, TermInfo)] ) | ||
587 | multiCommand ti choices = | ||
588 | ( ( selectAction <$> cmd <*> sequenceA (map strip choices) | ||
589 | , ti ) | ||
590 | , map snd choices ) | ||
591 | where | ||
592 | selectAction cmd choices = | ||
593 | fromJust $ lookup (cmd::Command) choices | ||
594 | strip (cmd,(action,_)) = fmap (cmd,) action | ||
595 | |||
596 | main = do | ||
597 | let version = defTI { termName = "keys", CmdTheLine.version = "0.1" } | ||
598 | q <- uncurry runChoiceWithOptionsFile $ multiCommand version | ||
599 | [ cmdlist, cmdautosign ] | ||
600 | return () | ||