diff options
Diffstat (limited to 'keys.hs')
-rw-r--r-- | keys.hs | 85 |
1 files changed, 16 insertions, 69 deletions
@@ -3,6 +3,7 @@ | |||
3 | {-# LANGUAGE OverloadedStrings #-} | 3 | {-# LANGUAGE OverloadedStrings #-} |
4 | {-# LANGUAGE RankNTypes #-} | 4 | {-# LANGUAGE RankNTypes #-} |
5 | {-# LANGUAGE FlexibleInstances #-} | 5 | {-# LANGUAGE FlexibleInstances #-} |
6 | {-# LANGUAGE DeriveDataTypeable #-} | ||
6 | module Main where | 7 | module Main where |
7 | 8 | ||
8 | import Debug.Trace | 9 | import Debug.Trace |
@@ -28,9 +29,6 @@ import qualified Crypto.PubKey.RSA as RSA | |||
28 | import Data.ASN1.Types | 29 | import Data.ASN1.Types |
29 | import Data.ASN1.Encoding | 30 | import Data.ASN1.Encoding |
30 | import Data.ASN1.BinaryEncoding | 31 | import Data.ASN1.BinaryEncoding |
31 | import System.Console.CmdTheLine as CmdTheLine | ||
32 | import System.Console.CmdTheLine.GetOpt | ||
33 | import System.Console.GetOpt | ||
34 | import Control.Applicative | 32 | import Control.Applicative |
35 | import System.Environment | 33 | import System.Environment |
36 | import System.Directory | 34 | import System.Directory |
@@ -39,6 +37,7 @@ import ControlMaybe | |||
39 | import Data.Char | 37 | import Data.Char |
40 | import Control.Arrow (second) | 38 | import Control.Arrow (second) |
41 | import Data.Traversable | 39 | import Data.Traversable |
40 | import System.Console.CmdArgs | ||
42 | 41 | ||
43 | data RSAPublicKey = RSAKey MPI MPI | 42 | data RSAPublicKey = RSAKey MPI MPI |
44 | 43 | ||
@@ -352,74 +351,12 @@ todo = error "unimplemented" | |||
352 | lookupEnv var = | 351 | lookupEnv var = |
353 | handleIO_ (return Nothing) $ fmap Just (getEnv var) | 352 | handleIO_ (return Nothing) $ fmap Just (getEnv var) |
354 | 353 | ||
355 | homedir :: Term (IO String) | ||
356 | homedir = envhomedir <$> opt_homedir | ||
357 | where | ||
358 | envhomedir opt = do | ||
359 | gnupghome <- lookupEnv "GNUPGHOME" >>= | ||
360 | \d -> return $ d >>= guard . (/="") >> d | ||
361 | home <- lookupEnv "HOME" >>= | ||
362 | \d -> return $ d >>= guard . (/="") >> d | ||
363 | {- | ||
364 | home <- flip fmap getHomeDirectory $ | ||
365 | \d -> fmap (const d) $ guard (d/="") | ||
366 | -} | ||
367 | let homegnupg = (++"/.gnupg") <$> home | ||
368 | return $ maybe "" id (opt `mplus` gnupghome `mplus` homegnupg) | ||
369 | |||
370 | opt_homedir = optDescrToTerm $ Option | ||
371 | "" ["homedir"] | ||
372 | (ReqArg id "dir") | ||
373 | (concat | ||
374 | [ "path to pubring.gpg" | ||
375 | , " and secring.gpg" | ||
376 | , " (default = ${GNUPGHOME:-$HOME/.gnupg})" ]) | ||
377 | |||
378 | opt_options = optDescrToTerm $ Option | ||
379 | "" ["options"] | ||
380 | (ReqArg id "file") | ||
381 | $ concat | ||
382 | [ "Read options from file and do not try to read" | ||
383 | , " them from the default options file in the" | ||
384 | , " homedir (see --homedir). This option is" | ||
385 | , " ignored if used in an options file." | ||
386 | , " The default options file is the first existing" | ||
387 | , " out of keys.conf, gpg.conf-2, and gpg.conf."] | ||
388 | |||
389 | opt_default_key = optDescrToTerm $ Option | ||
390 | "" ["default-key"] | ||
391 | (ReqArg id "name") | ||
392 | $ concat | ||
393 | [ "Use name as the default key to sign with. If" | ||
394 | , " this option is not used, the default key is" | ||
395 | , " the first key found in the secret keyring."] | ||
396 | |||
397 | opt_list_secret_keys = optDescrToTerm $ Option | ||
398 | "K" ["list-secret-keys"] | ||
399 | (NoArg ()) | ||
400 | $ concat | ||
401 | [ "List all keys from the secret keyrings." ] | ||
402 | |||
403 | |||
404 | unmaybe def = fmap (maybe def id) | 354 | unmaybe def = fmap (maybe def id) |
405 | 355 | ||
406 | opt_secret_keyring = expandPath <$> unmaybe "" opt_homedir <*> prim | ||
407 | where | ||
408 | -- TODO: alow multiple instances of --secret-keyring | ||
409 | -- See: System.Console.CmdTheLine.Arg.vFlagAll | ||
410 | prim = unmaybe "secring.gpg" . optDescrToTerm $ Option | ||
411 | "" ["secret-keyring"] | ||
412 | (ReqArg id "file") | ||
413 | $ concat | ||
414 | [ "Utilize secret keys in the specified file." | ||
415 | , "(default: secring.gpg)" ] | ||
416 | |||
417 | expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs) | 356 | expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs) |
418 | | otherwise = c:cs | 357 | | otherwise = c:cs |
419 | expandPath path [] = [] | 358 | expandPath path [] = [] |
420 | 359 | ||
421 | secret_packets :: Term (IO Message) | ||
422 | secret_packets = readPacketsFromFile <$> opt_secret_keyring | ||
423 | 360 | ||
424 | readPacketsFromFile :: FilePath -> IO Message | 361 | readPacketsFromFile :: FilePath -> IO Message |
425 | readPacketsFromFile fname = do | 362 | readPacketsFromFile fname = do |
@@ -437,6 +374,7 @@ parseOptionFile fname = do | |||
437 | notComment cs = not (all isSpace cs) | 374 | notComment cs = not (all isSpace cs) |
438 | return ys | 375 | return ys |
439 | 376 | ||
377 | {- | ||
440 | options_from_file :: | 378 | options_from_file :: |
441 | (forall a. [String] -> Term a -> IO (Either EvalExit a)) | 379 | (forall a. [String] -> Term a -> IO (Either EvalExit a)) |
442 | -> Term b | 380 | -> Term b |
@@ -592,9 +530,18 @@ multiCommand ti choices = | |||
592 | selectAction cmd choices = | 530 | selectAction cmd choices = |
593 | fromJust $ lookup (cmd::Command) choices | 531 | fromJust $ lookup (cmd::Command) choices |
594 | strip (cmd,(action,_)) = fmap (cmd,) action | 532 | strip (cmd,(action,_)) = fmap (cmd,) action |
533 | -} | ||
534 | |||
535 | data Keys = | ||
536 | List | ||
537 | | AutoSign {input :: FilePath, output :: FilePath} | ||
538 | deriving (Show, Data, Typeable) | ||
595 | 539 | ||
596 | main = do | 540 | main = do |
597 | let version = defTI { termName = "keys", CmdTheLine.version = "0.1" } | 541 | args <- cmdArgs $ modes [List &= help "list keys",AutoSign (def &= argPos 1 |
598 | q <- uncurry runChoiceWithOptionsFile $ multiCommand version | 542 | &= typFile ) |
599 | [ cmdlist, cmdautosign ] | 543 | (def &=argPos 2 |
600 | return () | 544 | &= typFile)] |
545 | &= summary "keys - a pgp key editing utility" | ||
546 | putStrLn $ show args | ||
547 | |||