summaryrefslogtreecommitdiff
path: root/keys.hs
diff options
context:
space:
mode:
Diffstat (limited to 'keys.hs')
-rw-r--r--keys.hs199
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
25import Data.ASN1.Types 25import Data.ASN1.Types
26import Data.ASN1.Encoding 26import Data.ASN1.Encoding
27import Data.ASN1.BinaryEncoding 27import Data.ASN1.BinaryEncoding
28import System.Console.CmdTheLine as CmdTheLine
29import System.Console.CmdTheLine.GetOpt
30import System.Console.GetOpt
31import Control.Applicative
32import System.Environment
33import System.Directory
34import System.Exit
35import ControlMaybe
36import Data.Char
37import Control.Arrow (second)
28 38
29data RSAPublicKey = RSAKey MPI MPI 39data RSAPublicKey = RSAKey MPI MPI
30 40
@@ -44,8 +54,11 @@ rsaKeyFromPacket p@(PublicKeyPacket {}) = do
44 n <- lookup 'n' $ key p 54 n <- lookup 'n' $ key p
45 e <- lookup 'e' $ key p 55 e <- lookup 'e' $ key p
46 return $ RSAKey n e 56 return $ RSAKey n e
57rsaKeyFromPacket p@(SecretKeyPacket {}) = do
58 n <- lookup 'n' $ key p
59 e <- lookup 'e' $ key p
60 return $ RSAKey n e
47rsaKeyFromPacket _ = Nothing 61rsaKeyFromPacket _ = Nothing
48
49derRSA rsa = do 62derRSA rsa = do
50 k <- rsaKeyFromPacket rsa 63 k <- rsaKeyFromPacket rsa
51 return $ encodeASN1 DER (toASN1 k []) 64 return $ encodeASN1 DER (toASN1 k [])
@@ -213,7 +226,7 @@ listKeys pkts = do
213 kinds = map (\(_,_,k,h,_)->defaultkind k h) as 226 kinds = map (\(_,_,k,h,_)->defaultkind k h) as
214 kindwidth = maximum $ map length kinds 227 kindwidth = maximum $ map length kinds
215 kindcol = min 20 kindwidth 228 kindcol = min 20 kindwidth
216 code (c,_,_,_,_) = -c 229 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
217 ownerkey (_,(a,_),_,_,_) = a 230 ownerkey (_,(a,_),_,_,_) = a
218 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b 231 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
219 gs = groupBy sameMaster (sortBy (comparing code) as) 232 gs = groupBy sameMaster (sortBy (comparing code) as)
@@ -227,15 +240,21 @@ listKeys pkts = do
227 2 -> " <-- " 240 2 -> " <-- "
228 3 -> " <-> " 241 3 -> " <-> "
229 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' 242 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
230 " " {- ++grip top -} 243 -- torhash = maybe "" id $ derToBase32 <$> derRSA sub
231 ++ ar ++ formkind ++" "++ fingerprint sub ++ "\n" 244 concat [ " "
245 -- , grip top
246 , ar
247 , formkind
248 , " "
249 , fingerprint sub
250 -- , " " ++ torhash
251 , "\n" ]
232 -- ++ ppShow hashed 252 -- ++ ppShow hashed
233 torkeys = do 253 torkeys = do
234 (code,(top,sub), kind, hashed,claimants) <- subs 254 (code,(top,sub), kind, hashed,claimants) <- subs
235 guard ("tor" `elem` kind) 255 guard ("tor" `elem` kind)
236 guard (code .&. 0x2 /= 0) 256 guard (code .&. 0x2 /= 0)
237 der <- maybeToList $ derRSA sub 257 maybeToList $ derToBase32 <$> derRSA sub
238 return $ derToBase32 der
239 uid = {- maybe "" id . listToMaybe $ -} do 258 uid = {- maybe "" id . listToMaybe $ -} do
240 (keys,sigs) <- certs 259 (keys,sigs) <- certs
241 sig <- sigs 260 sig <- sigs
@@ -257,7 +276,7 @@ listKeys pkts = do
257 listToMaybe $ filter match torkeys 276 listToMaybe $ filter match torkeys
258 " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n" 277 " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n"
259 (_,sigs) = unzip certs 278 (_,sigs) = unzip certs
260 "master-key " ++ fingerprint top ++ "\n" ++ uid ++ subkeys ++ "\n" 279 "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n"
261 280
262 281
263data PGPKeyFlags = 282data PGPKeyFlags =
@@ -307,7 +326,7 @@ keyflags flgs@(KeyFlagsPacket {}) =
307 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags 326 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
308 -- other flags: 327 -- other flags:
309 -- split_key 328 -- split_key
310 -- authentication 329 -- authentication (ssh-client)
311 -- group_key 330 -- group_key
312 where 331 where
313 bit v f = if f flgs then v else 0 332 bit v f = if f flgs then v else 0
@@ -322,7 +341,167 @@ modifyUID (UserIDPacket str) = UserIDPacket str'
322 mod x = x 341 mod x = x
323modifyUID other = other 342modifyUID other = other
324 343
344todo = error "unimplemented"
345
346-- TODO: switch to System.Environment.lookupEnv
347-- when linking against newer base libraries.
348lookupEnv var =
349 handleIO_ (return Nothing) $ fmap Just (getEnv var)
350
351homedir :: Term (IO String)
352homedir = envhomedir <$> opt_homedir
353 where
354 envhomedir opt = do
355 gnupghome <- lookupEnv "GNUPGHOME" >>=
356 \d -> return $ d >>= guard . (/="") >> d
357 home <- lookupEnv "HOME" >>=
358 \d -> return $ d >>= guard . (/="") >> d
359 {-
360 home <- flip fmap getHomeDirectory $
361 \d -> fmap (const d) $ guard (d/="")
362 -}
363 let homegnupg = (++"/.gnupg") <$> home
364 return $ maybe "" id (opt `mplus` gnupghome `mplus` homegnupg)
365
366opt_homedir = optDescrToTerm $ Option
367 "" ["homedir"]
368 (ReqArg id "dir")
369 (concat
370 [ "path to pubring.gpg"
371 , " and secring.gpg"
372 , " (default = ${GNUPGHOME:-$HOME/.gnupg})" ])
373
374opt_options = optDescrToTerm $ Option
375 "" ["options"]
376 (ReqArg id "file")
377 $ concat
378 [ "Read options from file and do not try to read"
379 , " them from the default options file in the"
380 , " homedir (see --homedir). This option is"
381 , " ignored if used in an options file."
382 , " The default options file is the first existing"
383 , " out of keys.conf, gpg.conf-2, and gpg.conf."]
384
385opt_default_key = optDescrToTerm $ Option
386 "" ["default-key"]
387 (ReqArg id "name")
388 $ concat
389 [ "Use name as the default key to sign with. If"
390 , " this option is not used, the default key is"
391 , " the first key found in the secret keyring."]
392
393opt_list_secret_keys = optDescrToTerm $ Option
394 "K" ["list-secret-keys"]
395 (NoArg ())
396 $ concat
397 [ "List all keys from the secret keyrings." ]
398
399
400unmaybe def = fmap (maybe def id)
401
402opt_secret_keyring = expandPath <$> unmaybe "" opt_homedir <*> prim
403 where
404 prim = unmaybe "secring.gpg" . optDescrToTerm $ Option
405 "" ["secret-keyring"]
406 (ReqArg id "file")
407 $ concat
408 [ "Utilize secret keys in the specified file."
409 , "(default: secring.gpg)" ]
410
411expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs)
412 | otherwise = c:cs
413expandPath path [] = []
414
415secret_packets :: Term (IO Message)
416secret_packets = readPacketsFromFile <$> opt_secret_keyring
417
418readPacketsFromFile :: FilePath -> IO Message
419readPacketsFromFile fname = do
420 input <- L.readFile fname
421 return $
422 case decodeOrFail input of
423 Right (_,_,msg ) -> msg
424 Left (_,_,_) -> Message []
425
426
427parseOptionFile fname = do
428 xs <- fmap lines (readFile fname)
429 let ys = filter notComment xs
430 notComment ('#':_) = False
431 notComment cs = not (all isSpace cs)
432 return ys
433
434options_from_file :: Term a -> (String,String,Term (Maybe String)) -> ([String],Term (Maybe String)) -> IO [String]
435options_from_file term (homevar,appdir,home) (optfile_alts,options_file) = doit
436 where
437 homedir = envhomedir <$> home
438 envhomedir opt = do
439 gnupghome <- lookupEnv homevar >>=
440 \d -> return $ d >>= guard . (/="") >> d
441 home <- flip fmap getHomeDirectory $
442 \d -> fmap (const d) $ guard (d/="")
443 let homegnupg = (++('/':appdir)) <$> home
444 return $ (opt `mplus` gnupghome `mplus` homegnupg)
445
446 doit = do
447 args <- getArgs
448 let wants_help =
449 not . null $ filter cryForHelp args
450 where cryForHelp "--help" = True
451 cryForHelp "--version" = True
452 cryForHelp x =
453 and (zipWith (==) x "--help=")
454 (o,h) <- do
455 val <- unwrap args (liftA2 (,) options_file homedir, defTI)
456 case val of
457 _ | wants_help -> return (Nothing,Nothing)
458 {-
459 Left e -> putStrLn ("Unable to find home directory ")
460 >> exitFailure
461 -}
462 Left e -> return (Nothing,Nothing)
463 Right (o,h) -> fmap (o,) h
464 ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
465 let optfiles = map (second ((h++"/")++))
466 (maybe optfile_alts' (:[]) o')
467 optfile_alts' = zip (False:repeat True) optfile_alts
468 o' = fmap (False,) o
469 in filterM (doesFileExist . snd) optfiles
470 args <- flip (maybe $ return args) ofile $ \(forgive,fname) -> do
471 let h' = fromJust h
472 newargs <- (:) <$> pure ("homedir "++h') <*> parseOptionFile fname
473 let toArgs = toHead ("--"++) . words
474 toHead f (x:xs) = f x : xs
475 toHead f [] = []
476 voidTerm = fmap (const ())
477 appendArgs as [] = return as
478 appendArgs as (configline:cs) = do
479 let xs = toArgs configline
480 w <-unwrap (xs++as) (voidTerm term,defTI)
481 case w of
482 Left _ -> appendArgs as cs
483 Right _ -> appendArgs (xs++as) cs
484 -- TODO: check errors if forgive = False
485 appendArgs args newargs
486 return args
487
488runWithOptionsFile (term,ti) = do
489 as <- options_from_file term
490 ("GNUPGHOME",".gnupg",opt_homedir)
491 (["keys.conf","gpg.conf-2","gpg.conf"]
492 ,opt_options)
493 q <- eval as (term , ti)
494 q
495
325main = do 496main = do
326 pkts <- getPackets 497 q <- runWithOptionsFile (listSecretKeys, defTI { termName = "keys", CmdTheLine.version = "0.1" })
327 putStrLn $ listKeys pkts -- (map modifyUID pkts)
328 return () 498 return ()
499 where
500 -- showhome = flip const <$> opt_options <*> ( (>>= putStrLn) <$> homedir )
501 showhome = opt_default_key <:> opt_options <:> ( (>>= putStrLn) <$> homedir )
502 a <:> b = flip const <$> a <*> b
503 infixr 2 <:>
504
505 listSecretKeys = opt_options <:> (>>= list) <$> secret_packets
506
507 list (Message pkts) = putStrLn $ listKeys pkts