diff options
Diffstat (limited to 'kiki.hs')
-rw-r--r-- | kiki.hs | 225 |
1 files changed, 173 insertions, 52 deletions
@@ -32,7 +32,6 @@ import qualified Data.ByteString as S | |||
32 | import qualified Data.ByteString.Lazy as L | 32 | import qualified Data.ByteString.Lazy as L |
33 | import qualified Data.ByteString.Lazy.Char8 as Char8 | 33 | import qualified Data.ByteString.Lazy.Char8 as Char8 |
34 | import qualified Data.Map as Map | 34 | import qualified Data.Map as Map |
35 | import qualified Data.Text as T | ||
36 | import Control.Arrow (first,second) | 35 | import Control.Arrow (first,second) |
37 | import Data.Binary.Get (runGet) | 36 | import Data.Binary.Get (runGet) |
38 | import Data.Binary.Put (putWord32be,runPut,putByteString) | 37 | import Data.Binary.Put (putWord32be,runPut,putByteString) |
@@ -598,37 +597,6 @@ kiki_usage bSecret cmd = putStr $ | |||
598 | ," 5E24CD442AA6965D2012E62A905C24185D5379C2" | 597 | ," 5E24CD442AA6965D2012E62A905C24185D5379C2" |
599 | ] | 598 | ] |
600 | 599 | ||
601 | doAutosign rt kd@(KeyData k ksigs umap submap) = ops | ||
602 | where | ||
603 | ops = map (\u -> InducerSignature u []) us | ||
604 | us = filter torStyle $ Map.keys umap | ||
605 | torStyle str = and [ uid_topdomain parsed == "onion" | ||
606 | , uid_realname parsed `elem` ["","Anonymous"] | ||
607 | , uid_user parsed == "root" | ||
608 | , fmap (match . fst) (lookup (packet k) torbindings) | ||
609 | == Just True ] | ||
610 | where parsed = parseUID str | ||
611 | match = (==subdom) . take (fromIntegral len) | ||
612 | subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] | ||
613 | subdom = Char8.unpack subdom0 | ||
614 | len = T.length (uid_subdomain parsed) | ||
615 | torbindings = getTorKeys (map packet $ flattenTop "" True kd) | ||
616 | getTorKeys pub = do | ||
617 | xs <- groupBindings pub | ||
618 | (_,(top,sub),us,_,_) <- xs | ||
619 | guard ("tor" `elem` us) | ||
620 | let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub | ||
621 | return (top,(torhash,sub)) | ||
622 | |||
623 | groupBindings pub = gs | ||
624 | where (_,bindings) = getBindings pub | ||
625 | bindings' = accBindings bindings | ||
626 | code (c,(m,s),_,_,_) = (fingerprint_material m,-c) | ||
627 | ownerkey (_,(a,_),_,_,_) = a | ||
628 | sameMaster (ownerkey->a) (ownerkey->b) | ||
629 | = fingerprint_material a==fingerprint_material b | ||
630 | gs = groupBy sameMaster (sortBy (comparing code) bindings') | ||
631 | |||
632 | processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) | 600 | processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) |
633 | where | 601 | where |
634 | (args,trail1) = break (=="--") args_raw | 602 | (args,trail1) = break (=="--") args_raw |
@@ -725,7 +693,9 @@ sync bExport bImport bSecret cmdarg args_raw = do | |||
725 | , spill = KF_Match usage | 693 | , spill = KF_Match usage |
726 | , typ = PEMFile | 694 | , typ = PEMFile |
727 | , access = Sec | 695 | , access = Sec |
728 | , initializer = cmd' }) | 696 | , initializer = cmd' |
697 | , transforms = [] | ||
698 | } ) | ||
729 | else if isNothing cmd' | 699 | else if isNothing cmd' |
730 | then ( ArgFile path | 700 | then ( ArgFile path |
731 | , (buildStreamInfo KF_None PEMFile) | 701 | , (buildStreamInfo KF_None PEMFile) |
@@ -735,18 +705,10 @@ sync bExport bImport bSecret cmdarg args_raw = do | |||
735 | , (buildStreamInfo reftyp WalletFile) { access = Sec })) | 705 | , (buildStreamInfo reftyp WalletFile) { access = Sec })) |
736 | wallets | 706 | wallets |
737 | rings = map (\fname -> ( ArgFile fname | 707 | rings = map (\fname -> ( ArgFile fname |
738 | , buildStreamInfo reftyp $ KeyRingFile passfd)) | 708 | , buildStreamInfo reftyp KeyRingFile )) |
739 | keyrings_ | 709 | keyrings_ |
740 | hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs | 710 | hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs |
741 | where decorate fname = (ArgFile fname, buildStreamInfo reftyp Hosts) | 711 | where decorate fname = (ArgFile fname, buildStreamInfo reftyp Hosts) |
742 | importStyle = maybe (\_ _ -> subkeysOnly) | ||
743 | (\f rt kd -> f rt kd >> importPublic) | ||
744 | $ mplus import_f importifauth_f | ||
745 | where | ||
746 | import_f = do Map.lookup "--import" margs | ||
747 | return $ \rt kd -> Just () | ||
748 | importifauth_f = do Map.lookup "--import-if-authentic" margs | ||
749 | return guardAuthentic | ||
750 | pubfill = maybe KF_Subkeys id | 712 | pubfill = maybe KF_Subkeys id |
751 | $ mplus import_f importifauth_f | 713 | $ mplus import_f importifauth_f |
752 | where | 714 | where |
@@ -758,22 +720,25 @@ sync bExport bImport bSecret cmdarg args_raw = do | |||
758 | , fill = rtyp | 720 | , fill = rtyp |
759 | , spill = KF_All | 721 | , spill = KF_All |
760 | , access = AutoAccess | 722 | , access = AutoAccess |
761 | , initializer = Nothing } | 723 | , initializer = Nothing |
724 | , transforms = [] } | ||
762 | kikiOp = KeyRingOperation | 725 | kikiOp = KeyRingOperation |
763 | { kFiles = Map.fromList $ | 726 | { opFiles = Map.fromList $ |
764 | [ ( HomeSec, buildStreamInfo (if bSecret && bImport then KF_All | 727 | [ ( HomeSec, buildStreamInfo (if bSecret && bImport then KF_All |
765 | else KF_None) | 728 | else KF_None) |
766 | (KeyRingFile passfd) ) | 729 | KeyRingFile ) |
767 | , ( HomePub, buildStreamInfo (if bImport then pubfill | 730 | , ( HomePub, buildStreamInfo (if bImport then pubfill |
768 | else KF_None) | 731 | else KF_None) |
769 | (KeyRingFile Nothing) ) | 732 | KeyRingFile ) |
770 | ] | 733 | ] |
771 | ++ rings | 734 | ++ rings |
772 | ++ if bSecret then pems else [] | 735 | ++ if bSecret then pems else [] |
773 | ++ if bSecret then walts else [] | 736 | ++ if bSecret then walts else [] |
774 | ++ hosts | 737 | ++ hosts |
775 | , kManip = maybe noManip (const doAutosign) $ Map.lookup "--autosign" margs | 738 | , opPassphrases = do pfile <- maybeToList passfd |
776 | , homeSpec = homespec | 739 | return $ PassphraseSpec Nothing Nothing pfile |
740 | , opTransforms = maybe [] (const [Autosign]) $ Map.lookup "--autosign" margs | ||
741 | , opHome = homespec | ||
777 | } | 742 | } |
778 | 743 | ||
779 | (\f -> maybe f (const $ kiki_usage bSecret cmdarg) $ Map.lookup "--help" margs) $ do | 744 | (\f -> maybe f (const $ kiki_usage bSecret cmdarg) $ Map.lookup "--help" margs) $ do |
@@ -860,13 +825,14 @@ kiki "show" args = do | |||
860 | hosts = [] | 825 | hosts = [] |
861 | walts = [] | 826 | walts = [] |
862 | streaminfo = StreamInfo { fill = KF_None | 827 | streaminfo = StreamInfo { fill = KF_None |
863 | , typ = KeyRingFile passfd | 828 | , typ = KeyRingFile |
864 | , spill = KF_All | 829 | , spill = KF_All |
865 | , initializer = Nothing | 830 | , initializer = Nothing |
866 | , access = AutoAccess | 831 | , access = AutoAccess |
832 | , transforms = [] | ||
867 | } | 833 | } |
868 | kikiOp = KeyRingOperation | 834 | kikiOp = KeyRingOperation |
869 | { kFiles = Map.fromList $ | 835 | { opFiles = Map.fromList $ |
870 | [ ( HomeSec, streaminfo { access = Sec }) | 836 | [ ( HomeSec, streaminfo { access = Sec }) |
871 | , ( HomePub, streaminfo { access = Pub }) | 837 | , ( HomePub, streaminfo { access = Pub }) |
872 | ] | 838 | ] |
@@ -874,8 +840,10 @@ kiki "show" args = do | |||
874 | ++ pems | 840 | ++ pems |
875 | ++ walts | 841 | ++ walts |
876 | ++ hosts | 842 | ++ hosts |
877 | , kManip = noManip | 843 | , opPassphrases = do pfile <- maybeToList passfd |
878 | , homeSpec = homespec | 844 | return $ PassphraseSpec Nothing Nothing pfile |
845 | , opTransforms = [] | ||
846 | , opHome = homespec | ||
879 | } | 847 | } |
880 | 848 | ||
881 | (\f -> maybe f (const $ kiki_usage False "show") $ Map.lookup "--help" margs) $ do | 849 | (\f -> maybe f (const $ kiki_usage False "show") $ Map.lookup "--help" margs) $ do |
@@ -904,6 +872,158 @@ kiki "show" args = do | |||
904 | forM_ report $ \(fname,act) -> do | 872 | forM_ report $ \(fname,act) -> do |
905 | putStrLn $ fname ++ ": " ++ reportString act | 873 | putStrLn $ fname ++ ": " ++ reportString act |
906 | 874 | ||
875 | kiki "merge" [] = do | ||
876 | putStr . unlines $ | ||
877 | [ "kiki merge [ --passphrase-fd=FD ... ]" | ||
878 | , " ( --home[=HOMEDIR]" | ||
879 | , " | --type=(keyring|pem|wallet|hosts)" | ||
880 | , " | --access=[auto|secret|public]" | ||
881 | , " | --flow=(fill|spill|sync)[,(subkeys|match=SPEC)]" | ||
882 | , " | --create=CMD" | ||
883 | , " | --autosign[=no]" | ||
884 | , " | --" | ||
885 | , " | FILE ) ..."] | ||
886 | kiki "merge" args | "--help" `elem` args = do | ||
887 | kiki "merge" [] | ||
888 | -- TODO: more help | ||
889 | kiki "merge" args = do | ||
890 | KikiResult rt report <- runKeyRing op | ||
891 | case rt of | ||
892 | KikiSuccess rt -> return () | ||
893 | err -> putStrLn $ errorString err | ||
894 | forM_ report $ \(fname,act) -> do | ||
895 | putStrLn $ fname ++ ": " ++ reportString act | ||
896 | where | ||
897 | (_,(_,op)) = foldl' buildOp (True,(flow,noop)) args | ||
898 | noop = KeyRingOperation | ||
899 | { opFiles = Map.empty | ||
900 | , opTransforms = [] | ||
901 | , opHome = Nothing | ||
902 | , opPassphrases = [] | ||
903 | } | ||
904 | flow = StreamInfo | ||
905 | { access = AutoAccess | ||
906 | , typ = KeyRingFile | ||
907 | , spill = KF_None | ||
908 | , fill = KF_None | ||
909 | , initializer = Nothing | ||
910 | , transforms = [] | ||
911 | } | ||
912 | updateFlow fil spil mtch flow = spill' $ fill' $ flow | ||
913 | where | ||
914 | fill' flow = flow { fill = if fil then val else KF_None } | ||
915 | spill' flow = flow { spill = if spil then val else KF_None } | ||
916 | val = either (\subkeys -> if subkeys then KF_Subkeys else KF_All) | ||
917 | KF_Match | ||
918 | mtch | ||
919 | parseFlow spec = | ||
920 | if null bads | ||
921 | then Just ( ( "spill" `elem` goods | ||
922 | || "sync" `elem` goods | ||
923 | , "fill" `elem` goods | ||
924 | || "sync" `elem` goods ) | ||
925 | , maybe (Left $ "subkeys" `elem` goods) | ||
926 | Right | ||
927 | match ) | ||
928 | else Nothing | ||
929 | where | ||
930 | ws = case groupBy (\_ c->c/=',') spec of | ||
931 | w:xs -> w:map (drop 1) xs | ||
932 | [] -> [] | ||
933 | (goods,bads) = partition acceptable ws | ||
934 | acceptable "spill" = True | ||
935 | acceptable "fill" = True | ||
936 | acceptable "sync" = True | ||
937 | acceptable "subkeys" = True | ||
938 | acceptable s | "match=" `isPrefixOf` s = True | ||
939 | acceptable _ = False | ||
940 | match = listToMaybe $ do | ||
941 | m <- filter ("match=" `isPrefixOf`) goods | ||
942 | return $ drop 6 m | ||
943 | |||
944 | doFile :: StreamInfo -> KeyRingOperation -> FilePath -> (StreamInfo,KeyRingOperation) | ||
945 | doFile flow op fname = | ||
946 | ( flow | ||
947 | , op { opFiles= Map.insert (ArgFile fname) flow (opFiles op) }) | ||
948 | |||
949 | doAutosign :: Bool -> StreamInfo -> KeyRingOperation -> (StreamInfo,KeyRingOperation) | ||
950 | doAutosign True flow op = | ||
951 | if Map.null (opFiles op) | ||
952 | then (flow, op { opTransforms = opTransforms op ++ [Autosign] }) | ||
953 | else (flow { transforms = transforms flow ++ [Autosign] }, op) | ||
954 | doAutosign False flow op = | ||
955 | ( flow { transforms = filter (/=Autosign) (transforms flow) } | ||
956 | , op { opTransforms = filter (/=Autosign) (opTransforms op) } ) | ||
957 | |||
958 | doPassphrase :: StreamInfo -> KeyRingOperation -> String -> (StreamInfo,KeyRingOperation) | ||
959 | doPassphrase flow op pass = | ||
960 | if Map.null (opFiles op) | ||
961 | then ( flow | ||
962 | , op { opPassphrases = PassphraseSpec Nothing Nothing pfd | ||
963 | : opPassphrases op } ) | ||
964 | else error "passphrase-fd must come before any file arguments or --home" | ||
965 | where | ||
966 | pfd = FileDesc (read pass) | ||
967 | |||
968 | buildOp (False,(flow,op)) fname = (False,doFile flow op fname) | ||
969 | buildOp (True,(flow,op)) arg@(splitArg->parsed) = | ||
970 | case parsed of | ||
971 | Left ("",Nothing) -> (False,(flow,op)) | ||
972 | _ -> (True,) dispatch | ||
973 | where | ||
974 | dispatch = | ||
975 | case parsed of | ||
976 | Right fname -> doFile flow op fname | ||
977 | Left ("autosign",Nothing) -> doAutosign True flow op | ||
978 | Left ("autosign",Just "y") -> doAutosign True flow op | ||
979 | Left ("autosign",Just "yes") -> doAutosign True flow op | ||
980 | Left ("autosign",Just "true") -> doAutosign True flow op | ||
981 | Left ("autosign",Just "n") -> doAutosign False flow op | ||
982 | Left ("autosign",Just "no") -> doAutosign False flow op | ||
983 | Left ("autosign",Just "false")-> doAutosign False flow op | ||
984 | Left ("passphrase-fd",Just pass) -> doPassphrase flow op pass | ||
985 | Left ("create",Just cmd) -> | ||
986 | ( flow { initializer = if null cmd then Nothing else Just cmd } | ||
987 | , op ) | ||
988 | Left ("type",Just "keyring") -> ( flow { typ = KeyRingFile }, op ) | ||
989 | Left ("type",Just "pem" ) -> ( flow { typ = PEMFile }, op ) | ||
990 | Left ("type",Just "wallet" ) -> ( flow { typ = WalletFile }, op ) | ||
991 | Left ("type",Just "hosts" ) -> ( flow { typ = Hosts }, op ) | ||
992 | Left ("access",Just "public") -> ( flow { access = Pub }, op ) | ||
993 | Left ("access",Just "secret") -> ( flow { access = Sec }, op ) | ||
994 | Left ("access",Just "auto") -> ( flow { access = AutoAccess }, op ) | ||
995 | Left ("home",mb) -> | ||
996 | ( flow | ||
997 | , op { opFiles = Map.insert HomePub flow { typ=KeyRingFile | ||
998 | , access=Pub } | ||
999 | $ Map.insert HomeSec flow { typ=KeyRingFile | ||
1000 | , access=Sec } | ||
1001 | $ opFiles op | ||
1002 | , opHome = opHome op `mplus` mb | ||
1003 | } | ||
1004 | ) | ||
1005 | Left ("flow",Just flowspec) -> | ||
1006 | case parseFlow flowspec of | ||
1007 | Just ( (fil,spil), mtch ) -> | ||
1008 | ( updateFlow fil spil mtch flow | ||
1009 | , op ) | ||
1010 | Nothing -> error "Valid flow words are: spill,fill,sync,subkeys or match=KEYSPEC" | ||
1011 | Left (option,_) -> error $ "Unrecognized option: " ++ option | ||
1012 | |||
1013 | splitArg :: String -> Either (String,Maybe String) String | ||
1014 | splitArg arg = | ||
1015 | case hyphens of | ||
1016 | "" -> Right name | ||
1017 | "-" -> error $ "Unrecognized option: " ++ arg | ||
1018 | _ -> Left $ parseLongOption name | ||
1019 | where | ||
1020 | (hyphens, name) = span (=='-') arg | ||
1021 | parseLongOption name = (key,val v) | ||
1022 | where | ||
1023 | (key,v) = break (=='=') name | ||
1024 | val ('=':vs) = Just vs | ||
1025 | val _ = Nothing | ||
1026 | |||
907 | commands :: [(String,String)] | 1027 | commands :: [(String,String)] |
908 | commands = | 1028 | commands = |
909 | [ ( "help", "display usage information" ) | 1029 | [ ( "help", "display usage information" ) |
@@ -916,6 +1036,7 @@ commands = | |||
916 | , ( "export-secret", "export (both public and secret) information into your keyring" ) | 1036 | , ( "export-secret", "export (both public and secret) information into your keyring" ) |
917 | , ( "export-public", "import (public) information into your keyring" ) | 1037 | , ( "export-public", "import (public) information into your keyring" ) |
918 | , ( "working-key", "show the current working master key and its subkeys" ) | 1038 | , ( "working-key", "show the current working master key and its subkeys" ) |
1039 | , ( "merge", "low level import/export operation" ) | ||
919 | ] | 1040 | ] |
920 | 1041 | ||
921 | main = do | 1042 | main = do |