diff options
author | joe <joe@jerkface.net> | 2014-04-16 21:26:14 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2014-04-16 21:26:14 -0400 |
commit | b66b977dac1d90dae54c1abe6560276f944ff9d7 (patch) | |
tree | d7fe92b602a503725044240021ffcc5485f5919b | |
parent | 80cd56e64d6c506d9ede50ac357ceec47df8393e (diff) |
writePEMKeys
-rw-r--r-- | KeyRing.hs | 118 |
1 files changed, 102 insertions, 16 deletions
@@ -9,6 +9,7 @@ module KeyRing where | |||
9 | import System.Environment | 9 | import System.Environment |
10 | import Control.Monad | 10 | import Control.Monad |
11 | import Data.Maybe | 11 | import Data.Maybe |
12 | import Data.Either | ||
12 | import Data.Char | 13 | import Data.Char |
13 | import Data.Ord | 14 | import Data.Ord |
14 | import Data.List | 15 | import Data.List |
@@ -84,6 +85,9 @@ data FileType = KeyRingFile PassWordFile | |||
84 | 85 | ||
85 | data RefType = ConstRef | MutableRef (Maybe Initializer) | 86 | data RefType = ConstRef | MutableRef (Maybe Initializer) |
86 | 87 | ||
88 | isMutable (MutableRef {}) = True | ||
89 | isMutable _ = False | ||
90 | |||
87 | initializer (MutableRef x) = x | 91 | initializer (MutableRef x) = x |
88 | initializer _ = Nothing | 92 | initializer _ = Nothing |
89 | 93 | ||
@@ -236,7 +240,7 @@ data KikiCondition a = KikiSuccess a | |||
236 | | BadPassphrase | 240 | | BadPassphrase |
237 | | FailedToMakeSignature | 241 | | FailedToMakeSignature |
238 | | CantFindHome | 242 | | CantFindHome |
239 | | AmbiguousKeySpec | 243 | | AmbiguousKeySpec FilePath |
240 | | CannotImportMasterKey | 244 | | CannotImportMasterKey |
241 | deriving ( Functor, Show ) | 245 | deriving ( Functor, Show ) |
242 | 246 | ||
@@ -266,6 +270,9 @@ keyPacket (KeyData k _ _ _) = packet k | |||
266 | 270 | ||
267 | keyMappedPacket (KeyData k _ _ _) = k | 271 | keyMappedPacket (KeyData k _ _ _) = k |
268 | 272 | ||
273 | subkeyPacket (SubKey k _ ) = packet k | ||
274 | subkeyMappedPacket (SubKey k _ ) = k | ||
275 | |||
269 | 276 | ||
270 | usage (NotationDataPacket | 277 | usage (NotationDataPacket |
271 | { human_readable = True | 278 | { human_readable = True |
@@ -544,6 +551,20 @@ selectKey0 wantPublic (spec,mtag) db = do | |||
544 | zs = snd $ seek_key subspec ys1 | 551 | zs = snd $ seek_key subspec ys1 |
545 | listToMaybe zs | 552 | listToMaybe zs |
546 | 553 | ||
554 | selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] | ||
555 | selectAll wantPublic (spec,mtag) db = do | ||
556 | let Message ps = flattenKeys wantPublic db | ||
557 | ys = snd $ seek_key spec ps | ||
558 | y <- take 1 ys | ||
559 | case mtag of | ||
560 | Nothing -> return (y,Nothing) | ||
561 | Just tag -> | ||
562 | let search ys1 = do | ||
563 | let zs = snd $ seek_key (KeyTag y tag) ys1 | ||
564 | z <- take 1 zs | ||
565 | (y,Just z):search (drop 1 zs) | ||
566 | in search (drop 1 ys) | ||
567 | |||
547 | seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) | 568 | seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) |
548 | seek_key (KeyGrip grip) sec = (pre, subs) | 569 | seek_key (KeyGrip grip) sec = (pre, subs) |
549 | where | 570 | where |
@@ -747,7 +768,7 @@ doImport doDecrypt db (fname,subspec,ms,_) = do | |||
747 | (listToMaybe parsedkey) $ \key -> do | 768 | (listToMaybe parsedkey) $ \key -> do |
748 | let (m0,tailms) = splitAt 1 ms | 769 | let (m0,tailms) = splitAt 1 ms |
749 | if (not (null tailms) || null m0) | 770 | if (not (null tailms) || null m0) |
750 | then return AmbiguousKeySpec | 771 | then return $ AmbiguousKeySpec fname |
751 | else doImportG doDecrypt db m0 tag fname key | 772 | else doImportG doDecrypt db m0 tag fname key |
752 | 773 | ||
753 | doImportG | 774 | doImportG |
@@ -919,8 +940,6 @@ writeRingKeys krd db wk secring pubring = do | |||
919 | let ks = Map.elems db | 940 | let ks = Map.elems db |
920 | isring (KeyRingFile {}) = True | 941 | isring (KeyRingFile {}) = True |
921 | isring _ = False | 942 | isring _ = False |
922 | isMutable (MutableRef {}) = True | ||
923 | isMutable _ = False | ||
924 | fs = do | 943 | fs = do |
925 | (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) | 944 | (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) |
926 | guard (isring ftyp) | 945 | guard (isring ftyp) |
@@ -960,6 +979,49 @@ writeRingKeys krd db wk secring pubring = do | |||
960 | return $ KikiSuccess report | 979 | return $ KikiSuccess report |
961 | 980 | ||
962 | 981 | ||
982 | {- | ||
983 | getSubkeysForExport kk subspec db = do | ||
984 | kd <- maybeToList $ Map.lookup kk db | ||
985 | subkeysForExport subspec kd | ||
986 | -} | ||
987 | |||
988 | subkeysForExport subspec (KeyData key _ _ subkeys) = do | ||
989 | let subs tag = do | ||
990 | e <- Map.elems subkeys | ||
991 | guard $ doSearch key tag e | ||
992 | return $ subkeyPacket e | ||
993 | maybe [packet key] subs subspec | ||
994 | where | ||
995 | doSearch key tag (SubKey sub_mp sigtrusts) = | ||
996 | let (_,v,_) = findTag tag | ||
997 | (packet key) | ||
998 | (packet sub_mp) | ||
999 | sigtrusts | ||
1000 | in fmap fst v==Just True | ||
1001 | |||
1002 | writePEMKeys :: KeyDB | ||
1003 | -> [(FilePath,Maybe String,[Packet],Maybe Initializer)] | ||
1004 | -> IO (KikiCondition [(FilePath,KikiReportAction)]) | ||
1005 | writePEMKeys db exports = do | ||
1006 | ds <- mapM decryptKeys exports | ||
1007 | let ds' = map functorToEither ds | ||
1008 | if null (lefts ds') | ||
1009 | then do | ||
1010 | rs <- mapM (uncurry $ writeKeyToFile False "PEM") | ||
1011 | (rights ds') | ||
1012 | return $ KikiSuccess (concat rs) | ||
1013 | else do | ||
1014 | return (head $ lefts ds') | ||
1015 | where | ||
1016 | doDecrypt = todo | ||
1017 | writeKeyToFile = todo -- writeKeyToFile False "PEM" fname pun | ||
1018 | |||
1019 | decryptKeys (fname,subspec,[p],_) = do | ||
1020 | pun <- doDecrypt p | ||
1021 | flip (maybe $ return BadPassphrase) pun $ \pun -> do | ||
1022 | return $ KikiSuccess (fname,pun) | ||
1023 | |||
1024 | |||
963 | runKeyRing :: KeyRingData -> IO (KikiResult KeyRingRuntime) | 1025 | runKeyRing :: KeyRingData -> IO (KikiResult KeyRingRuntime) |
964 | runKeyRing keyring = do | 1026 | runKeyRing keyring = do |
965 | homedir <- getHomeDir (homeSpec keyring) | 1027 | homedir <- getHomeDir (homeSpec keyring) |
@@ -999,17 +1061,39 @@ runKeyRing keyring = do | |||
999 | f <- resolveInputFile secring pubring f | 1061 | f <- resolveInputFile secring pubring f |
1000 | return (f,t) | 1062 | return (f,t) |
1001 | 1063 | ||
1002 | 1064 | let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do | |
1003 | -- create nonexistent files via external commands | ||
1004 | externals_ret <- do | ||
1005 | let cmds = do | ||
1006 | (fname,(rtyp,ftyp)) <- nonexistents | 1065 | (fname,(rtyp,ftyp)) <- nonexistents |
1007 | cmd <- maybeToList (initializer rtyp) | 1066 | guard $ isMutable rtyp |
1008 | (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip) | 1067 | (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip) |
1009 | $ getUsage ftyp | 1068 | $ getUsage ftyp |
1010 | let ms = map fst $ filterMatches topspec (Map.toList db) | 1069 | -- ms will contain duplicates if a top key has multiple matching |
1011 | guard $ isNothing $ selectPublicKey (topspec,subspec) db | 1070 | -- subkeys. This is intentional. |
1012 | return (fname,subspec,ms,cmd) | 1071 | let -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db |
1072 | -- ms = filterMatches topspec $ Map.toList db | ||
1073 | ns = do | ||
1074 | (kk,kd) <- filterMatches topspec $ Map.toList db | ||
1075 | return (kk , subkeysForExport subspec kd) | ||
1076 | return (fname,subspec,ns,initializer rtyp) | ||
1077 | (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) | ||
1078 | notmissing | ||
1079 | exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 | ||
1080 | |||
1081 | |||
1082 | ambiguity (f,topspec,subspec,_) = do | ||
1083 | return $ KikiResult (AmbiguousKeySpec f) [] | ||
1084 | |||
1085 | ifnotnull (x:xs) f g = f x | ||
1086 | ifnotnull _ f g = g | ||
1087 | |||
1088 | ifnotnull ambiguous ambiguity $ do | ||
1089 | |||
1090 | -- create nonexistent files via external commands | ||
1091 | externals_ret <- do | ||
1092 | let cmds = mapMaybe getcmd missing | ||
1093 | where | ||
1094 | getcmd (fname,subspec,ms,mcmd) = do | ||
1095 | cmd <- mcmd | ||
1096 | return (fname,subspec,ms,cmd) | ||
1013 | rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do | 1097 | rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do |
1014 | e <- systemEnv [ ("file",fname) | 1098 | e <- systemEnv [ ("file",fname) |
1015 | , ("usage",maybe "" id subspec) ] | 1099 | , ("usage",maybe "" id subspec) ] |
@@ -1019,11 +1103,11 @@ runKeyRing keyring = do | |||
1019 | ExitSuccess -> return (tup,ExternallyGeneratedFile) | 1103 | ExitSuccess -> return (tup,ExternallyGeneratedFile) |
1020 | 1104 | ||
1021 | v <- foldM importPEMKey (KikiSuccess (db,[])) $ do | 1105 | v <- foldM importPEMKey (KikiSuccess (db,[])) $ do |
1022 | (tup,r) <- rs | 1106 | ((f,subspec,ms,cmd),r) <- rs |
1023 | guard $ case r of | 1107 | guard $ case r of |
1024 | ExternallyGeneratedFile -> True | 1108 | ExternallyGeneratedFile -> True |
1025 | _ -> False | 1109 | _ -> False |
1026 | return tup | 1110 | return (f,subspec,map fst ms,cmd) |
1027 | 1111 | ||
1028 | try v $ \(db,import_rs) -> do | 1112 | try v $ \(db,import_rs) -> do |
1029 | return $ KikiSuccess (db, map (\((f,_,_,_),r)->(f,r)) rs | 1113 | return $ KikiSuccess (db, map (\((f,_,_,_),r)->(f,r)) rs |
@@ -1037,7 +1121,8 @@ runKeyRing keyring = do | |||
1037 | r <- writeRingKeys keyring db wk secring pubring | 1121 | r <- writeRingKeys keyring db wk secring pubring |
1038 | try' r $ \report_rings -> do | 1122 | try' r $ \report_rings -> do |
1039 | 1123 | ||
1040 | -- todo writePEMKeys | 1124 | r <- writePEMKeys db exports |
1125 | try' r $ \report_pems -> do | ||
1041 | 1126 | ||
1042 | let rt = KeyRingRuntime | 1127 | let rt = KeyRingRuntime |
1043 | { rtPubring = pubring | 1128 | { rtPubring = pubring |
@@ -1049,7 +1134,8 @@ runKeyRing keyring = do | |||
1049 | $ concat [ report_imports | 1134 | $ concat [ report_imports |
1050 | , report_externals | 1135 | , report_externals |
1051 | , report_wallets | 1136 | , report_wallets |
1052 | , report_rings ] | 1137 | , report_rings |
1138 | , report_pems ] | ||
1053 | 1139 | ||
1054 | forM_ lked $ \(Just lk, fname) -> dotlock_release lk | 1140 | forM_ lked $ \(Just lk, fname) -> dotlock_release lk |
1055 | 1141 | ||