diff options
Diffstat (limited to 'kiki.hs')
-rw-r--r-- | kiki.hs | 83 |
1 files changed, 62 insertions, 21 deletions
@@ -243,8 +243,8 @@ backsig _ = Nothing | |||
243 | isSubkeySignature (SubkeySignature {}) = True | 243 | isSubkeySignature (SubkeySignature {}) = True |
244 | isSubkeySignature _ = False | 244 | isSubkeySignature _ = False |
245 | 245 | ||
246 | isMasterKey k@(PublicKeyPacket {}) = not $ is_subkey k | 246 | isPublicMaster k@(PublicKeyPacket {}) = not $ is_subkey k |
247 | isMasterKey _ = False | 247 | isPublicMaster _ = False |
248 | 248 | ||
249 | now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime | 249 | now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime |
250 | 250 | ||
@@ -829,6 +829,7 @@ data OriginFlags = OriginFlags { | |||
829 | originallyPublic :: Bool, | 829 | originallyPublic :: Bool, |
830 | originalNum :: Int | 830 | originalNum :: Int |
831 | } | 831 | } |
832 | deriving Show | ||
832 | origin :: Packet -> Int -> OriginFlags | 833 | origin :: Packet -> Int -> OriginFlags |
833 | origin p n = OriginFlags ispub n | 834 | origin p n = OriginFlags ispub n |
834 | where | 835 | where |
@@ -970,6 +971,8 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs) | |||
970 | , tb `Map.union` ta ) | 971 | , tb `Map.union` ta ) |
971 | 972 | ||
972 | where | 973 | where |
974 | -- TODO: when merging items, we should delete invalidated origins | ||
975 | -- from the orgin map. | ||
973 | mergeItem ys x = if x `elem` ys then ys else ys++[x] | 976 | mergeItem ys x = if x `elem` ys then ys else ys++[x] |
974 | 977 | ||
975 | mergeSameSig n a b = trace ("discarding dup "++show a) b | 978 | mergeSameSig n a b = trace ("discarding dup "++show a) b |
@@ -982,22 +985,8 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs) | |||
982 | "Unable to merge subkey signature: "++(words (show sig) >>= take 1) | 985 | "Unable to merge subkey signature: "++(words (show sig) >>= take 1) |
983 | 986 | ||
984 | flattenKeys :: Bool -> KeyDB -> Message | 987 | flattenKeys :: Bool -> KeyDB -> Message |
985 | flattenKeys isPublic db = Message $ concatMap flattenTop (prefilter . Map.assocs $ db) | 988 | flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop isPublic . snd) (prefilter . Map.assocs $ db) |
986 | where | 989 | where |
987 | flattenTop (_,(KeyData key sigs uids subkeys)) = | ||
988 | unk key : ( concatMap flattenUid (Map.assocs (fst uids)) | ||
989 | ++ concatMap flattenSub (Map.assocs subkeys)) | ||
990 | |||
991 | flattenUid (str,sigs) = UserIDPacket str : concatMap unsig sigs | ||
992 | |||
993 | flattenSub (_,SubKey key sigs) = unk key: concatMap unsig sigs | ||
994 | |||
995 | unk = (if isPublic then secretToPublic else id) . packet | ||
996 | unsig (sig,trustmap) = [packet sig]++ take 1 (Map.elems $ Map.filterWithKey f trustmap) | ||
997 | where | ||
998 | f "%secring" _ = not isPublic | ||
999 | f _ _ = isPublic | ||
1000 | |||
1001 | prefilter = if isPublic then id else filter isSecret | 990 | prefilter = if isPublic then id else filter isSecret |
1002 | where | 991 | where |
1003 | isSecret (_,(KeyData | 992 | isSecret (_,(KeyData |
@@ -1007,7 +996,58 @@ flattenKeys isPublic db = Message $ concatMap flattenTop (prefilter . Map.assocs | |||
1007 | _)) = True | 996 | _)) = True |
1008 | isSecret _ = False | 997 | isSecret _ = False |
1009 | 998 | ||
1010 | writeOutKeyrings db = return () -- TODO | 999 | |
1000 | flattenTop :: Bool -> KeyData -> [MappedPacket] | ||
1001 | flattenTop ispub (KeyData key sigs uids subkeys) = | ||
1002 | unk ispub key : ( concatMap (flattenUid ispub (snd uids)) (Map.assocs (fst uids)) | ||
1003 | ++ concatMap (flattenSub ispub) (Map.elems subkeys)) | ||
1004 | |||
1005 | flattenUid :: Bool -> OriginMap -> (String,[SigAndTrust]) -> [MappedPacket] | ||
1006 | flattenUid ispub om (str,sigs) = MappedPacket (UserIDPacket str) om : concatMap (unsig ispub) sigs | ||
1007 | |||
1008 | flattenSub :: Bool -> SubKey -> [MappedPacket] | ||
1009 | flattenSub ispub (SubKey key sigs) = unk ispub key: concatMap (unsig ispub) sigs | ||
1010 | |||
1011 | unk :: Bool -> MappedPacket -> MappedPacket | ||
1012 | unk isPublic = if isPublic then toPacket secretToPublic else id | ||
1013 | where toPacket f (MappedPacket p m) = MappedPacket (f p) m | ||
1014 | unsig :: Bool -> SigAndTrust -> [MappedPacket] | ||
1015 | unsig isPublic (sig,trustmap) = [sig]++ map (flip MappedPacket Map.empty) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) | ||
1016 | where | ||
1017 | f "%secring" _ = not isPublic | ||
1018 | f _ _ = isPublic | ||
1019 | |||
1020 | ifSecret (SecretKeyPacket {}) t f = t | ||
1021 | ifSecret _ t f = f | ||
1022 | |||
1023 | showPacket :: Packet -> String | ||
1024 | showPacket p | isKey p = (if is_subkey p | ||
1025 | then showPacket0 p | ||
1026 | else ifSecret p "----Secret-----" "----Public-----") | ||
1027 | ++ " "++ fingerprint p | ||
1028 | | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) | ||
1029 | | otherwise = showPacket0 p | ||
1030 | showPacket0 p = concat . take 1 $ words (show p) | ||
1031 | |||
1032 | writeOutKeyrings db = do | ||
1033 | let ks = Map.elems db | ||
1034 | fs = Map.keys (foldr unionfiles Map.empty ks) | ||
1035 | where unionfiles (KeyData p _ _ _) m = | ||
1036 | Map.union m (locations p) | ||
1037 | fromfile f (KeyData p _ _ _) = Map.member f $ locations p | ||
1038 | let s = do | ||
1039 | f <- fs | ||
1040 | let x = do | ||
1041 | d@(KeyData p _ _ _) <- filter (fromfile f) ks | ||
1042 | n <- maybeToList $ Map.lookup f (locations p) | ||
1043 | flattenTop (originallyPublic n) d | ||
1044 | changes = filter notnew x | ||
1045 | where notnew p = isNothing (Map.lookup f $ locations p) | ||
1046 | unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++ | ||
1047 | ( "CHANGES: " : map ((" "++) . showPacket . packet) changes) | ||
1048 | putStrLn s | ||
1049 | -- putStrLn $ "fs = " ++ show fs | ||
1050 | return () -- TODO | ||
1011 | 1051 | ||
1012 | data Arguments = | 1052 | data Arguments = |
1013 | Cross_Merge { homedir :: Maybe FilePath | 1053 | Cross_Merge { homedir :: Maybe FilePath |
@@ -1091,7 +1131,7 @@ main = do | |||
1091 | 1131 | ||
1092 | uidScan pub = scanl (\(mkey,u) w -> | 1132 | uidScan pub = scanl (\(mkey,u) w -> |
1093 | case () of | 1133 | case () of |
1094 | _ | isMasterKey w -> (w,u) | 1134 | _ | isPublicMaster w -> (w,u) |
1095 | _ | isUserID w -> (mkey,w) | 1135 | _ | isUserID w -> (mkey,w) |
1096 | _ | otherwise -> (mkey,u) | 1136 | _ | otherwise -> (mkey,u) |
1097 | ) | 1137 | ) |
@@ -1222,7 +1262,7 @@ main = do | |||
1222 | cleanup (_,(topkey,_,pkt)) = (topkey,pkt) | 1262 | cleanup (_,(topkey,_,pkt)) = (topkey,pkt) |
1223 | putStrLn $ "-------- signed ------> " -- ++ show (length pub, length pub') | 1263 | putStrLn $ "-------- signed ------> " -- ++ show (length pub, length pub') |
1224 | putStrLn "" | 1264 | putStrLn "" |
1225 | putStrLn $ listKeysFiltered (map fingerprint (filter isMasterKey pub')) (sec++pub') | 1265 | putStrLn $ listKeysFiltered (map fingerprint (filter isPublicMaster pub')) (sec++pub') |
1226 | 1266 | ||
1227 | let signed_bs = encode (Message pub') | 1267 | let signed_bs = encode (Message pub') |
1228 | L.writeFile (output cmd) signed_bs | 1268 | L.writeFile (output cmd) signed_bs |
@@ -1435,7 +1475,8 @@ existingKey (prepk,pks) remainder wkun wk parsedkey tag pre uids subkeys output_ | |||
1435 | putStrLn "Adding valid signature to existing key..." | 1475 | putStrLn "Adding valid signature to existing key..." |
1436 | newKey wkun wk [pk] tag pre uids (trail++prepk++remainder) output_file grip | 1476 | newKey wkun wk [pk] tag pre uids (trail++prepk++remainder) output_file grip |
1437 | (sig,ov):vs -> do | 1477 | (sig,ov):vs -> do |
1438 | -- TODO: update sig to contain usage@ = tag | 1478 | -- sig exists. |
1479 | -- update sig to contain usage@ = tag | ||
1439 | let hs = filter (\p->isNotation p && notation_name p=="usage@") (hashed_subpackets sig) | 1480 | let hs = filter (\p->isNotation p && notation_name p=="usage@") (hashed_subpackets sig) |
1440 | ks = map notation_value hs | 1481 | ks = map notation_value hs |
1441 | isNotation (NotationDataPacket {}) = True | 1482 | isNotation (NotationDataPacket {}) = True |