From 6a7ecebf5424c6a6e621c8bf46b04d1cde1cc1d8 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 14 Aug 2013 03:28:32 -0400 Subject: Use CmdTheLine for argument parsing. --- keys.hs | 199 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 189 insertions(+), 10 deletions(-) (limited to 'keys.hs') 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 -- cgit v1.2.3