diff options
author | James Crayne <jim.crayne@gmail.com> | 2014-04-21 21:47:02 -0400 |
---|---|---|
committer | James Crayne <jim.crayne@gmail.com> | 2014-04-21 21:47:02 -0400 |
commit | 3737be4b3daf242ec13cdbc8100a751f5882a1a1 (patch) | |
tree | 4c911d9310905935c37d8b8b40cb7a1a05e3c7d4 /kiki.hs | |
parent | 3b4c266da5ca78bb47fbfd84e47046b068704905 (diff) |
some minor cleanup
Diffstat (limited to 'kiki.hs')
-rw-r--r-- | kiki.hs | 67 |
1 files changed, 33 insertions, 34 deletions
@@ -49,7 +49,7 @@ import qualified Data.Map as Map | |||
49 | import DotLock | 49 | import DotLock |
50 | -- import Codec.Crypto.ECC.Base -- hecc package | 50 | -- import Codec.Crypto.ECC.Base -- hecc package |
51 | -- import Text.Printf | 51 | -- import Text.Printf |
52 | import qualified CryptoCoins as CryptoCoins | 52 | import qualified CryptoCoins |
53 | import LengthPrefixedBE | 53 | import LengthPrefixedBE |
54 | import Data.Binary.Put (putWord32be,runPut,putByteString) | 54 | import Data.Binary.Put (putWord32be,runPut,putByteString) |
55 | import Data.Binary.Get (runGet) | 55 | import Data.Binary.Get (runGet) |
@@ -57,6 +57,9 @@ import Data.Binary.Get (runGet) | |||
57 | import KeyRing | 57 | import KeyRing |
58 | import Base58 | 58 | import Base58 |
59 | 59 | ||
60 | -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-} | ||
61 | -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-} | ||
62 | |||
60 | -- instance Default S.ByteString where def = S.empty | 63 | -- instance Default S.ByteString where def = S.empty |
61 | 64 | ||
62 | warn str = hPutStrLn stderr str | 65 | warn str = hPutStrLn stderr str |
@@ -220,8 +223,7 @@ listKeysFiltered grips pkts = do | |||
220 | let (certs,bs) = getBindings pkts | 223 | let (certs,bs) = getBindings pkts |
221 | as = accBindings bs | 224 | as = accBindings bs |
222 | defaultkind (k:_) hs = k | 225 | defaultkind (k:_) hs = k |
223 | defaultkind [] hs = maybe "subkey" | 226 | defaultkind [] hs = fromMaybe "subkey" |
224 | id | ||
225 | ( listToMaybe | 227 | ( listToMaybe |
226 | . mapMaybe (fmap usageString . keyflags) | 228 | . mapMaybe (fmap usageString . keyflags) |
227 | $ hs) | 229 | $ hs) |
@@ -245,7 +247,7 @@ listKeysFiltered grips pkts = do | |||
245 | 2 -> " <-- " | 247 | 2 -> " <-- " |
246 | 3 -> " <-> " | 248 | 3 -> " <-> " |
247 | formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' | 249 | formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' |
248 | -- torhash = maybe "" id $ derToBase32 <$> derRSA sub | 250 | -- torhash = fromMaybe "" $ derToBase32 <$> derRSA sub |
249 | (netid,kind') = maybe (0x0,"bitcoin") | 251 | (netid,kind') = maybe (0x0,"bitcoin") |
250 | (\n->(CryptoCoins.publicByteFromName n,n)) | 252 | (\n->(CryptoCoins.publicByteFromName n,n)) |
251 | $ listToMaybe kind | 253 | $ listToMaybe kind |
@@ -269,7 +271,7 @@ listKeysFiltered grips pkts = do | |||
269 | guard ("tor" `elem` kind) | 271 | guard ("tor" `elem` kind) |
270 | guard (code .&. 0x2 /= 0) | 272 | guard (code .&. 0x2 /= 0) |
271 | maybeToList $ derToBase32 <$> derRSA sub | 273 | maybeToList $ derToBase32 <$> derRSA sub |
272 | uid = {- maybe "" id . listToMaybe $ -} do | 274 | uid = {- fromMaybe "" . listToMaybe $ -} do |
273 | (keys,sigs) <- certs | 275 | (keys,sigs) <- certs |
274 | sig <- sigs | 276 | sig <- sigs |
275 | guard (isCertificationSig sig) | 277 | guard (isCertificationSig sig) |
@@ -293,11 +295,10 @@ listKeysFiltered grips pkts = do | |||
293 | let subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] | 295 | let subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] |
294 | len = L.length subdom0 | 296 | len = L.length subdom0 |
295 | subdom = Char8.unpack subdom0 | 297 | subdom = Char8.unpack subdom0 |
296 | match = ( (==subdom) . take (fromIntegral len)) | 298 | match = (==subdom) . take (fromIntegral len) |
297 | guard (len >= 16) | 299 | guard (len >= 16) |
298 | listToMaybe $ filter match torkeys | 300 | listToMaybe $ filter match torkeys |
299 | unlines $ [ " " ++ ar ++ "@" ++ " " ++ uid_full parsed ] | 301 | unlines $ (" " ++ ar ++ "@" ++ " " ++ uid_full parsed) : showsigs secondary |
300 | ++ showsigs secondary | ||
301 | -- (_,sigs) = unzip certs | 302 | -- (_,sigs) = unzip certs |
302 | "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" | 303 | "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" |
303 | 304 | ||
@@ -320,7 +321,7 @@ modifyUID other = other | |||
320 | 321 | ||
321 | 322 | ||
322 | readPublicKey :: Char8.ByteString -> RSAPublicKey | 323 | readPublicKey :: Char8.ByteString -> RSAPublicKey |
323 | readPublicKey bs = maybe er id $ do | 324 | readPublicKey bs = fromMaybe er $ do |
324 | let (pre,bs1) = Char8.splitAt 7 bs | 325 | let (pre,bs1) = Char8.splitAt 7 bs |
325 | guard $ pre == "ssh-rsa" | 326 | guard $ pre == "ssh-rsa" |
326 | let (sp,bs2) = Char8.span isSpace bs1 | 327 | let (sp,bs2) = Char8.span isSpace bs1 |
@@ -367,7 +368,7 @@ show_all db = do | |||
367 | let Message packets = flattenKeys True db | 368 | let Message packets = flattenKeys True db |
368 | putStrLn $ listKeys packets | 369 | putStrLn $ listKeys packets |
369 | 370 | ||
370 | show_whose_key input_key db = do | 371 | show_whose_key input_key db = |
371 | flip (maybe $ return ()) input_key $ \input_key -> do | 372 | flip (maybe $ return ()) input_key $ \input_key -> do |
372 | let ks = whoseKey input_key db | 373 | let ks = whoseKey input_key db |
373 | case ks of | 374 | case ks of |
@@ -379,7 +380,7 @@ show_whose_key input_key db = do | |||
379 | 380 | ||
380 | show_pem keyspec wkgrip db = do | 381 | show_pem keyspec wkgrip db = do |
381 | let s = parseSpec wkgrip keyspec | 382 | let s = parseSpec wkgrip keyspec |
382 | flip (maybe $ warn (keyspec ++ ": not found") >> return ()) | 383 | flip (maybe . void $ warn (keyspec ++ ": not found")) |
383 | (selectPublicKey s db) | 384 | (selectPublicKey s db) |
384 | $ \k -> do | 385 | $ \k -> do |
385 | let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k | 386 | let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k |
@@ -390,7 +391,7 @@ show_pem keyspec wkgrip db = do | |||
390 | 391 | ||
391 | show_ssh keyspec wkgrip db = do | 392 | show_ssh keyspec wkgrip db = do |
392 | let s = parseSpec wkgrip keyspec | 393 | let s = parseSpec wkgrip keyspec |
393 | flip (maybe $ warn (keyspec ++ ": not found") >> return ()) | 394 | flip (maybe . void $ warn (keyspec ++ ": not found")) |
394 | (selectPublicKey s db) | 395 | (selectPublicKey s db) |
395 | $ \k -> do | 396 | $ \k -> do |
396 | let Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k | 397 | let Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k |
@@ -409,7 +410,7 @@ show_key keyspec wkgrip db = do | |||
409 | 410 | ||
410 | show_wip keyspec wkgrip db = do | 411 | show_wip keyspec wkgrip db = do |
411 | let s = parseSpec wkgrip keyspec | 412 | let s = parseSpec wkgrip keyspec |
412 | flip (maybe $ warn (keyspec ++ ": not found") >> return ()) | 413 | flip (maybe $ void (warn (keyspec ++ ": not found"))) |
413 | (selectSecretKey s db) | 414 | (selectSecretKey s db) |
414 | $ \k -> do | 415 | $ \k -> do |
415 | let nwb = maybe 0x80 CryptoCoins.secretByteFromName $ snd s | 416 | let nwb = maybe 0x80 CryptoCoins.secretByteFromName $ snd s |
@@ -495,7 +496,7 @@ doBTCImport doDecrypt db (ms,subspec,content) = do | |||
495 | flip (maybe $ return db) | 496 | flip (maybe $ return db) |
496 | (listToMaybe parsedkey) $ \key -> do | 497 | (listToMaybe parsedkey) $ \key -> do |
497 | let (m0,tailms) = splitAt 1 ms | 498 | let (m0,tailms) = splitAt 1 ms |
498 | when (not (null tailms) || null m0) | 499 | unless ((null tailms) || null m0) |
499 | $ error "Key specification is ambiguous." | 500 | $ error "Key specification is ambiguous." |
500 | doImportG doDecrypt db m0 tag "" key | 501 | doImportG doDecrypt db m0 tag "" key |
501 | -} | 502 | -} |
@@ -512,7 +513,7 @@ whoseKey :: RSAPublicKey -> KeyDB -> [KeyData] | |||
512 | whoseKey rsakey db = filter matchkey (Map.elems db) | 513 | whoseKey rsakey db = filter matchkey (Map.elems db) |
513 | where | 514 | where |
514 | matchkey (KeyData k _ _ subs) = | 515 | matchkey (KeyData k _ _ subs) = |
515 | not . null . filter (ismatch k) $ Map.elems subs | 516 | any (ismatch k) $ Map.elems subs |
516 | 517 | ||
517 | ismatch k (SubKey mp sigs) = | 518 | ismatch k (SubKey mp sigs) = |
518 | Just rsakey == rsaKeyFromPacket (packet mp) | 519 | Just rsakey == rsaKeyFromPacket (packet mp) |
@@ -530,8 +531,7 @@ whoseKey rsakey db = filter matchkey (Map.elems db) | |||
530 | signatures_over $ verify (Message [sub]) s2 | 531 | signatures_over $ verify (Message [sub]) s2 |
531 | 532 | ||
532 | 533 | ||
533 | kiki_usage = do | 534 | kiki_usage = putStr . unlines $ |
534 | putStr . unlines $ | ||
535 | ["kiki - a pgp key editing utility" | 535 | ["kiki - a pgp key editing utility" |
536 | ,"" | 536 | ,"" |
537 | ,"kiki [OPTIONS]" | 537 | ,"kiki [OPTIONS]" |
@@ -680,7 +680,7 @@ main = do | |||
680 | unkeysRef <- newIORef Map.empty | 680 | unkeysRef <- newIORef Map.empty |
681 | pwRef <- newIORef Nothing | 681 | pwRef <- newIORef Nothing |
682 | let keypairs0 = | 682 | let keypairs0 = |
683 | flip map (maybe [] id $ Map.lookup "--keypairs" margs) $ \specfile -> do | 683 | flip map (fromMaybe [] $ Map.lookup "--keypairs" margs) $ \specfile -> do |
684 | let (spec,efilecmd) = break (=='=') specfile | 684 | let (spec,efilecmd) = break (=='=') specfile |
685 | guard $ take 1 efilecmd=="=" | 685 | guard $ take 1 efilecmd=="=" |
686 | let filecmd = drop 1 efilecmd | 686 | let filecmd = drop 1 efilecmd |
@@ -693,17 +693,17 @@ main = do | |||
693 | Just (spec,file,cmd) | 693 | Just (spec,file,cmd) |
694 | {- | 694 | {- |
695 | publics = | 695 | publics = |
696 | flip map (maybe [] id $ Map.lookup "--public" margs) $ \specfile -> do | 696 | flip map (fromMaybe [] $ Map.lookup "--public" margs) $ \specfile -> do |
697 | let (spec,efile) = break (=='=') specfile | 697 | let (spec,efile) = break (=='=') specfile |
698 | guard $ take 1 efile=="=" | 698 | guard $ take 1 efile=="=" |
699 | let file= drop 1 efile | 699 | let file= drop 1 efile |
700 | Just (spec,file) | 700 | Just (spec,file) |
701 | -} | 701 | -} |
702 | keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs | 702 | keyrings_ = fromMaybe [] $ Map.lookup "--keyrings" margs |
703 | wallets = maybe [] id $ Map.lookup "--wallets" margs | 703 | wallets = fromMaybe [] $ Map.lookup "--wallets" margs |
704 | passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs | 704 | passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs |
705 | 705 | ||
706 | when (not . null $ filter isNothing keypairs0) $ do | 706 | unless (any isNothing keypairs0) $ do |
707 | warn "syntax error" | 707 | warn "syntax error" |
708 | exitFailure | 708 | exitFailure |
709 | 709 | ||
@@ -749,8 +749,7 @@ main = do | |||
749 | ++ pems | 749 | ++ pems |
750 | ++ walts | 750 | ++ walts |
751 | ++ hosts | 751 | ++ hosts |
752 | , kImports = Map.fromList $ | 752 | , kImports = Map.fromList [ ( HomePub, importStyle ) ] |
753 | [ ( HomePub, importStyle ) ] | ||
754 | , kManip = maybe noManip (const doAutosign) $ Map.lookup "--autosign" margs | 753 | , kManip = maybe noManip (const doAutosign) $ Map.lookup "--autosign" margs |
755 | , homeSpec = homespec | 754 | , homeSpec = homespec |
756 | } | 755 | } |
@@ -761,19 +760,19 @@ main = do | |||
761 | KikiSuccess rt -> do -- interpret --show-* commands. | 760 | KikiSuccess rt -> do -- interpret --show-* commands. |
762 | let grip = rtGrip rt | 761 | let grip = rtGrip rt |
763 | let shspec = Map.fromList [("--show-wk", const $ show_wk (rtSecring rt) grip) | 762 | let shspec = Map.fromList [("--show-wk", const $ show_wk (rtSecring rt) grip) |
764 | ,("--show-all",const $ show_all) | 763 | ,("--show-all",const show_all) |
765 | ,("--show-whose-key", const $ show_whose_key input_key) | 764 | ,("--show-whose-key", const $ show_whose_key input_key) |
766 | ,("--show-key",\[x] -> show_key x $ maybe "" id grip) | 765 | ,("--show-key",\[x] -> show_key x $ fromMaybe "" grip) |
767 | ,("--show-pem",\[x] -> show_pem x $ maybe "" id grip) | 766 | ,("--show-pem",\[x] -> show_pem x $ fromMaybe "" grip) |
768 | ,("--show-ssh",\[x] -> show_ssh x $ maybe "" id grip) | 767 | ,("--show-ssh",\[x] -> show_ssh x $ fromMaybe "" grip) |
769 | ,("--show-wip",\[x] -> show_wip x $ maybe "" id grip) | 768 | ,("--show-wip",\[x] -> show_wip x $ fromMaybe "" grip) |
770 | ,("--help", \_ _ ->kiki_usage)] | 769 | ,("--help", \_ _ ->kiki_usage)] |
771 | shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs | 770 | shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs |
772 | 771 | ||
773 | forM_ shargs $ \(cmd,args) -> cmd args (rtKeyDB rt) | 772 | forM_ shargs $ \(cmd,args) -> cmd args (rtKeyDB rt) |
774 | e -> putStrLn $ show (fmap (const ()) e) | 773 | e -> print (void e)--(fmap (const ()) e) |
775 | 774 | ||
776 | putStrLn $ show report | 775 | print report |
777 | return() | 776 | return() |
778 | where | 777 | where |
779 | 778 | ||
@@ -788,7 +787,7 @@ main = do | |||
788 | , fmap (match . fst) (lookup (packet k) torbindings) | 787 | , fmap (match . fst) (lookup (packet k) torbindings) |
789 | == Just True ] | 788 | == Just True ] |
790 | where parsed = parseUID str | 789 | where parsed = parseUID str |
791 | match = ( (==subdom) . take (fromIntegral len)) | 790 | match = (==subdom) . take (fromIntegral len) |
792 | subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] | 791 | subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] |
793 | subdom = Char8.unpack subdom0 | 792 | subdom = Char8.unpack subdom0 |
794 | len = T.length (uid_subdomain parsed) | 793 | len = T.length (uid_subdomain parsed) |
@@ -797,7 +796,7 @@ main = do | |||
797 | xs <- groupBindings pub | 796 | xs <- groupBindings pub |
798 | (_,(top,sub),us,_,_) <- xs | 797 | (_,(top,sub),us,_,_) <- xs |
799 | guard ("tor" `elem` us) | 798 | guard ("tor" `elem` us) |
800 | let torhash = maybe "" id $ derToBase32 <$> derRSA sub | 799 | let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub |
801 | return (top,(torhash,sub)) | 800 | return (top,(torhash,sub)) |
802 | 801 | ||
803 | isSameKey a b = sort (key apub) == sort (key bpub) | 802 | isSameKey a b = sort (key apub) == sort (key bpub) |
@@ -823,7 +822,7 @@ groupBindings pub = | |||
823 | {- | 822 | {- |
824 | makeTorUID g timestamp wkun keyflags topkey torkey = uid:signatures_over sig | 823 | makeTorUID g timestamp wkun keyflags topkey torkey = uid:signatures_over sig |
825 | where | 824 | where |
826 | torhash sub = maybe "" id $ derToBase32 <$> derRSA sub | 825 | torhash sub = fromMaybe "" $ derToBase32 <$> derRSA sub |
827 | s = "Anonymous <root@" ++ take 16 (torhash torkey) ++ ".onion>" | 826 | s = "Anonymous <root@" ++ take 16 (torhash torkey) ++ ".onion>" |
828 | uid = UserIDPacket s | 827 | uid = UserIDPacket s |
829 | sig = fst $ torsig g topkey wkun uid timestamp keyflags | 828 | sig = fst $ torsig g topkey wkun uid timestamp keyflags |