1 files changed, 189 insertions, 10 deletions

diff --git a/keys.hs b/keys.hs
index db17cf4..a32a3dd 100644
--- a/keys.hs
+++ b/keys.hs
@@ -25,6 +25,16 @@ import qualified Crypto.PubKey.RSA as RSA
 import Data.ASN1.Types
 import Data.ASN1.Encoding
 import Data.ASN1.BinaryEncoding
+import System.Console.CmdTheLine as CmdTheLine
+import System.Console.CmdTheLine.GetOpt
+import System.Console.GetOpt
+import Control.Applicative
+import System.Environment
+import System.Directory
+import System.Exit
+import ControlMaybe
+import Data.Char
+import Control.Arrow (second)
 
 data RSAPublicKey = RSAKey MPI MPI
 
@@ -44,8 +54,11 @@ rsaKeyFromPacket p@(PublicKeyPacket {}) = do
     n <- lookup 'n' $ key p
     e <- lookup 'e' $ key p
     return $ RSAKey n e
+rsaKeyFromPacket p@(SecretKeyPacket {}) = do
+    n <- lookup 'n' $ key p
+    e <- lookup 'e' $ key p
+    return $ RSAKey n e
 rsaKeyFromPacket _ = Nothing
-
 derRSA rsa = do
     k <- rsaKeyFromPacket rsa
     return $ encodeASN1 DER (toASN1 k [])
@@ -213,7 +226,7 @@ listKeys pkts = do
         kinds = map (\(_,_,k,h,_)->defaultkind k h) as
         kindwidth = maximum $ map length kinds
         kindcol = min 20 kindwidth
-        code (c,_,_,_,_) = -c
+        code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
         ownerkey (_,(a,_),_,_,_) = a
         sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
         gs = groupBy sameMaster (sortBy (comparing code) as)
@@ -227,15 +240,21 @@ listKeys pkts = do
                         2 -> " <-- "
                         3 -> " <-> "
                 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
-            " " {- ++grip top -} 
-                ++ ar ++ formkind ++" "++ fingerprint sub ++ "\n"
+                -- torhash = maybe "" id $ derToBase32 <$> derRSA sub
+            concat  [ " "
+                    -- , grip top
+                    , ar
+                    , formkind 
+                    , " "
+                    , fingerprint sub 
+                    -- , " " ++ torhash
+                    , "\n" ]
                 -- ++ ppShow hashed
         torkeys = do
             (code,(top,sub), kind, hashed,claimants) <- subs
             guard ("tor" `elem` kind)
             guard (code .&. 0x2 /= 0)
-            der <- maybeToList $ derRSA sub
-            return $ derToBase32 der
+            maybeToList $ derToBase32 <$> derRSA sub
         uid = {- maybe "" id . listToMaybe $ -} do
             (keys,sigs) <- certs
             sig <- sigs
@@ -257,7 +276,7 @@ listKeys pkts = do
                         listToMaybe $ filter match torkeys
             " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n"
         (_,sigs) = unzip certs
-    "master-key " ++ fingerprint top ++ "\n" ++ uid ++ subkeys ++ "\n"
+    "master-key " ++ fingerprint top ++ "\n" ++ uid ++"  ...\n" ++ subkeys ++ "\n"
     
 
 data PGPKeyFlags =
@@ -307,7 +326,7 @@ keyflags flgs@(KeyFlagsPacket {}) =
         .|. bit 0x8 encrypt_storage )     :: Maybe PGPKeyFlags
     -- other flags:
     --  split_key
-    --  authentication
+    --  authentication (ssh-client)
     --  group_key
  where
     bit v f = if f flgs then v else 0
@@ -322,7 +341,167 @@ modifyUID (UserIDPacket str) = UserIDPacket str'
     mod x     = x
 modifyUID other              = other
 
+todo = error "unimplemented"
+
+-- TODO: switch to System.Environment.lookupEnv
+--       when linking against newer base libraries.
+lookupEnv var = 
+    handleIO_ (return Nothing) $ fmap Just (getEnv var)
+
+homedir :: Term (IO String)
+homedir = envhomedir <$> opt_homedir
+ where
+    envhomedir opt = do
+        gnupghome <- lookupEnv "GNUPGHOME" >>=
+                  \d -> return $ d >>= guard . (/="") >> d
+        home <- lookupEnv "HOME" >>=
+                  \d -> return $ d >>= guard . (/="") >> d
+        {-
+        home <- flip fmap getHomeDirectory $
+                  \d -> fmap (const d) $ guard (d/="")
+        -}
+        let homegnupg = (++"/.gnupg") <$> home
+        return $ maybe "" id (opt `mplus` gnupghome `mplus` homegnupg)
+
+opt_homedir = optDescrToTerm $ Option
+                    "" ["homedir"]
+                    (ReqArg id "dir")
+                    (concat
+                        [ "path to pubring.gpg"
+                        , " and secring.gpg"
+                        , " (default = ${GNUPGHOME:-$HOME/.gnupg})" ])
+
+opt_options =  optDescrToTerm $ Option
+                "" ["options"]
+                (ReqArg id "file")
+                $ concat
+                    [ "Read options from file and do not try to read"
+                    , " them from the default options file in the"
+                    , " homedir (see --homedir). This option is"
+                    , " ignored if used in an options file."
+                    , " The default options file is the first existing"
+                    , " out of keys.conf, gpg.conf-2, and gpg.conf."]
+
+opt_default_key = optDescrToTerm $ Option
+                "" ["default-key"]
+                (ReqArg id "name")
+                $ concat
+                    [ "Use name as the default key to sign with. If"
+                    , " this option is not used, the default key is"
+                    , " the first key found in the secret keyring."]
+
+opt_list_secret_keys = optDescrToTerm $ Option
+                "K" ["list-secret-keys"]
+                (NoArg ())
+                $ concat
+                    [ "List all keys from the secret keyrings." ]
+
+
+unmaybe def = fmap (maybe def id)
+
+opt_secret_keyring = expandPath <$> unmaybe "" opt_homedir <*> prim
+ where
+    prim = unmaybe "secring.gpg" . optDescrToTerm $ Option
+                "" ["secret-keyring"]
+                (ReqArg id "file")
+                $ concat
+                    [ "Utilize secret keys in the specified file."
+                    , "(default: secring.gpg)" ]
+
+expandPath path (c:cs) | c/='/'    = path ++ "/" ++ (c:cs)
+                       | otherwise = c:cs
+expandPath path []                 = []
+
+secret_packets :: Term (IO Message)
+secret_packets = readPacketsFromFile <$> opt_secret_keyring
+
+readPacketsFromFile :: FilePath -> IO Message
+readPacketsFromFile fname = do
+    input <- L.readFile fname
+    return $
+      case decodeOrFail input of
+        Right (_,_,msg ) -> msg
+        Left  (_,_,_)    -> Message []
+
+
+parseOptionFile fname = do
+    xs <- fmap lines (readFile fname)
+    let ys = filter notComment xs
+        notComment ('#':_) = False
+        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
+ where
+    homedir = envhomedir <$> home
+    envhomedir opt = do
+        gnupghome <- lookupEnv homevar >>=
+                  \d -> return $ d >>= guard . (/="") >> d
+        home <- flip fmap getHomeDirectory $
+                  \d -> fmap (const d) $ guard (d/="")
+        let homegnupg = (++('/':appdir)) <$> home
+        return $ (opt `mplus` gnupghome `mplus` homegnupg)
+
+    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)
+            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
+        ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> 
+                let optfiles = map (second ((h++"/")++)) 
+                                   (maybe optfile_alts' (:[]) o')
+                    optfile_alts' = zip (False:repeat True) optfile_alts
+                    o' = fmap (False,) o
+                in filterM (doesFileExist . snd) optfiles
+        args <- flip (maybe $ return args) ofile $ \(forgive,fname) -> do
+            let h' = fromJust h
+            newargs <- (:) <$> pure ("homedir "++h') <*> parseOptionFile fname
+            let toArgs = toHead ("--"++) . words
+                toHead f (x:xs) = f x : xs
+                toHead f []     = []
+                voidTerm = fmap (const ())
+                appendArgs as [] = return as
+                appendArgs as (configline:cs) = do
+                    let xs = toArgs configline
+                    w <-unwrap (xs++as) (voidTerm term,defTI)
+                    case w of
+                        Left  _ -> appendArgs as cs
+                        Right _ -> appendArgs (xs++as) cs
+            -- TODO: check errors if forgive = False
+            appendArgs args newargs
+        return args
+
+runWithOptionsFile (term,ti) = do
+    as <- options_from_file term
+                            ("GNUPGHOME",".gnupg",opt_homedir)
+                            (["keys.conf","gpg.conf-2","gpg.conf"]
+                            ,opt_options)
+    q <- eval as (term , ti)
+    q
+
 main = do
-    pkts <- getPackets
-    putStrLn $ listKeys pkts -- (map modifyUID pkts)
+    q <- runWithOptionsFile (listSecretKeys, defTI { termName = "keys", CmdTheLine.version = "0.1" })
     return ()
+ where
+    -- showhome =  flip const <$> opt_options <*> ( (>>= putStrLn) <$> homedir )
+    showhome =  opt_default_key <:> opt_options <:> ( (>>= putStrLn) <$> homedir )
+    a <:> b = flip const <$> a <*> b
+    infixr 2 <:>
+
+    listSecretKeys = opt_options <:> (>>= list) <$> secret_packets
+
+    list (Message pkts) = putStrLn $ listKeys pkts