Implemented list/autosign multi-command interface

1 files changed, 112 insertions, 21 deletions

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 ()