diff options
-rw-r--r-- | kiki.hs | 2 | ||||
-rw-r--r-- | lib/KeyDB.hs | 11 | ||||
-rw-r--r-- | lib/KeyRing.hs | 2 | ||||
-rw-r--r-- | lib/KeyRing/BuildKeyDB.hs | 14 | ||||
-rw-r--r-- | lib/Transforms.hs | 16 |
5 files changed, 23 insertions, 22 deletions
@@ -259,7 +259,7 @@ show_whose_key input_key db = | |||
259 | case ks of | 259 | case ks of |
260 | [KeyData k _ uids _] -> do | 260 | [KeyData k _ uids _] -> do |
261 | putStrLn $ fingerprint (packet k) | 261 | putStrLn $ fingerprint (packet k) |
262 | mapM_ putStrLn $ Map.keys uids | 262 | mapM_ putStrLn $ unUidString <$> Map.keys uids |
263 | (_:_) -> error "ambiguous" | 263 | (_:_) -> error "ambiguous" |
264 | [] -> return () | 264 | [] -> return () |
265 | 265 | ||
diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs index 1f0849c..1aef747 100644 --- a/lib/KeyDB.hs +++ b/lib/KeyDB.hs | |||
@@ -21,6 +21,7 @@ module KeyDB | |||
21 | , sortByHint | 21 | , sortByHint |
22 | , flattenKeys | 22 | , flattenKeys |
23 | , flattenFiltered | 23 | , flattenFiltered |
24 | , UidString(..) | ||
24 | ) where | 25 | ) where |
25 | 26 | ||
26 | import Control.Monad | 27 | import Control.Monad |
@@ -38,12 +39,14 @@ type SigAndTrust = ( MappedPacket | |||
38 | , TrustMap ) -- trust packets | 39 | , TrustMap ) -- trust packets |
39 | data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show | 40 | data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show |
40 | 41 | ||
42 | data UidString = UidString { unUidString :: String } deriving (Show, Eq, Ord) | ||
43 | |||
41 | -- | This is a GPG Identity which includes a master key and all its UIDs and | 44 | -- | This is a GPG Identity which includes a master key and all its UIDs and |
42 | -- subkeys and associated signatures. | 45 | -- subkeys and associated signatures. |
43 | data KeyData = KeyData | 46 | data KeyData = KeyData |
44 | { keyMappedPacket :: MappedPacket -- main key | 47 | { keyMappedPacket :: MappedPacket -- main key |
45 | , keySigAndTrusts :: [SigAndTrust] -- sigs on main key | 48 | , keySigAndTrusts :: [SigAndTrust] -- sigs on main key |
46 | , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids | 49 | , keyUids :: (Map.Map UidString ([SigAndTrust],OriginMap)) -- uids |
47 | , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys | 50 | , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys |
48 | } deriving Show | 51 | } deriving Show |
49 | 52 | ||
@@ -118,14 +121,14 @@ flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPubl | |||
118 | _)) = True | 121 | _)) = True |
119 | isSecret _ = False | 122 | isSecret _ = False |
120 | 123 | ||
121 | flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] | 124 | flattenUid :: FilePath -> Bool -> (UidString,([SigAndTrust],OriginMap)) -> [MappedPacket] |
122 | flattenUid fname ispub (str,(sigs,om)) = | 125 | flattenUid fname ispub (UidString str,(sigs,om)) = |
123 | (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs | 126 | (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs |
124 | 127 | ||
125 | flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] | 128 | flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] |
126 | flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs | 129 | flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs |
127 | 130 | ||
128 | flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] | 131 | flattenAllUids :: FilePath -> Bool -> Map.Map UidString ([SigAndTrust],OriginMap) -> [MappedPacket] |
129 | flattenAllUids fname ispub uids = | 132 | flattenAllUids fname ispub uids = |
130 | concatSort fname head (flattenUid fname ispub) (Map.assocs uids) | 133 | concatSort fname head (flattenUid fname ispub) (Map.assocs uids) |
131 | 134 | ||
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index b946e54..70edb9e 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs | |||
@@ -667,7 +667,7 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk | |||
667 | where wk = workingKey (rtGrip rt) (rtKeyDB rt) | 667 | where wk = workingKey (rtGrip rt) (rtKeyDB rt) |
668 | dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt) | 668 | dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt) |
669 | $ locations p | 669 | $ locations p |
670 | has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids | 670 | has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ first unUidString <$> Map.toList uids |
671 | where | 671 | where |
672 | goodsig (uidstr,(sigs,_)) = not . null $ do | 672 | goodsig (uidstr,(sigs,_)) = not . null $ do |
673 | sig0 <- fmap (packet . fst) sigs | 673 | sig0 <- fmap (packet . fst) sigs |
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index cd1bae9..0eddc51 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs | |||
@@ -30,7 +30,6 @@ import qualified Data.ByteString.Lazy as L (ByteString, concat, empty, | |||
30 | null, toChunks, | 30 | null, toChunks, |
31 | toStrict, head) | 31 | toStrict, head) |
32 | import Data.Char | 32 | import Data.Char |
33 | import Data.Functor | ||
34 | import Data.List | 33 | import Data.List |
35 | import qualified Data.Map as Map | 34 | import qualified Data.Map as Map |
36 | import Data.Maybe | 35 | import Data.Maybe |
@@ -55,7 +54,6 @@ import qualified System.Posix.Types as Posix | |||
55 | import Data.Hourglass | 54 | import Data.Hourglass |
56 | import Foreign.C.Types (CTime (..)) | 55 | import Foreign.C.Types (CTime (..)) |
57 | import Data.Traversable (sequenceA) | 56 | import Data.Traversable (sequenceA) |
58 | import qualified Data.Traversable as Traversable | ||
59 | import System.IO (openFile, IOMode(ReadMode)) | 57 | import System.IO (openFile, IOMode(ReadMode)) |
60 | 58 | ||
61 | import System.Posix.IO (fdToHandle) | 59 | import System.Posix.IO (fdToHandle) |
@@ -678,7 +676,7 @@ insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = | |||
678 | uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do | 676 | uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do |
679 | let has_torid = do | 677 | let has_torid = do |
680 | -- TODO: check for omitted real name field | 678 | -- TODO: check for omitted real name field |
681 | (sigtrusts,om) <- Map.lookup idstr uids | 679 | (sigtrusts,om) <- Map.lookup (UidString idstr) uids |
682 | listToMaybe $ do | 680 | listToMaybe $ do |
683 | s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) | 681 | s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) |
684 | signatures_over $ verify (Message [packet top]) s | 682 | signatures_over $ verify (Message [packet top]) s |
@@ -700,7 +698,7 @@ insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = | |||
700 | let om = Map.singleton fname (origin sig (-1)) | 698 | let om = Map.singleton fname (origin sig (-1)) |
701 | trust = Map.empty | 699 | trust = Map.empty |
702 | return $ KikiSuccess | 700 | return $ KikiSuccess |
703 | ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} | 701 | ( Map.insert (UidString idstr) ([( (mappedPacket fname sig) {locations=om} |
704 | , trust)],om) uids | 702 | , trust)],om) uids |
705 | , [] ) | 703 | , [] ) |
706 | 704 | ||
@@ -801,7 +799,7 @@ matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps | |||
801 | 799 | ||
802 | matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us | 800 | matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us |
803 | where | 801 | where |
804 | us = filter (isInfixOf pat) $ Map.keys uids | 802 | us = filter (isInfixOf pat) $ unUidString <$> Map.keys uids |
805 | 803 | ||
806 | doImport | 804 | doImport |
807 | :: PacketTranscoder | 805 | :: PacketTranscoder |
@@ -946,7 +944,7 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops | |||
946 | isName (NotationDataPacket True "hostname@" _) = True | 944 | isName (NotationDataPacket True "hostname@" _) = True |
947 | isName _ = False | 945 | isName _ = False |
948 | uids0 = fmap zapIfHasName uids | 946 | uids0 = fmap zapIfHasName uids |
949 | fstuid = head $ do | 947 | fstuid = UidString $ head $ do |
950 | p <- map packet $ flattenAllUids "" True uids | 948 | p <- map packet $ flattenAllUids "" True uids |
951 | maybeToList $ isUserID p | 949 | maybeToList $ isUserID p |
952 | uids1 = Map.adjust addnames fstuid uids0 | 950 | uids1 = Map.adjust addnames fstuid uids0 |
@@ -1069,14 +1067,14 @@ dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) | |||
1069 | update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p | 1067 | update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p |
1070 | = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) | 1068 | = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) |
1071 | update (Just (KeyData key sigs uids subkeys)) | Just uid <- isUserID p | 1069 | update (Just (KeyData key sigs uids subkeys)) | Just uid <- isUserID p |
1072 | = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) uid uids) | 1070 | = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (UidString uid) uids) |
1073 | subkeys | 1071 | subkeys |
1074 | update (Just (KeyData key sigs uids subkeys)) | 1072 | update (Just (KeyData key sigs uids subkeys)) |
1075 | = case sub of | 1073 | = case sub of |
1076 | MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys | 1074 | MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys |
1077 | UserIDPacket uid-> Just $ KeyData key | 1075 | UserIDPacket uid-> Just $ KeyData key |
1078 | sigs | 1076 | sigs |
1079 | (Map.alter (mergeUidSig n ptt) uid uids) | 1077 | (Map.alter (mergeUidSig n ptt) (UidString uid) uids) |
1080 | subkeys | 1078 | subkeys |
1081 | _ | isKey sub -> Just $ KeyData key | 1079 | _ | isKey sub -> Just $ KeyData key |
1082 | sigs | 1080 | sigs |
diff --git a/lib/Transforms.hs b/lib/Transforms.hs index edc18bb..7750ec5 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs | |||
@@ -664,7 +664,7 @@ performManipulations doDecrypt rt wk manip = do | |||
664 | , Packet ) -- key who signed | 664 | , Packet ) -- key who signed |
665 | ] | 665 | ] |
666 | vs = do | 666 | vs = do |
667 | x <- maybeToList $ Map.lookup uid (keyUids kd) | 667 | x <- maybeToList $ Map.lookup (UidString uid) (keyUids kd) |
668 | sig <- map (packet . fst) (fst x) | 668 | sig <- map (packet . fst) (fst x) |
669 | o <- overs sig | 669 | o <- overs sig |
670 | take 1 $ do -- Stop attempting to verify after the first success. | 670 | take 1 $ do -- Stop attempting to verify after the first success. |
@@ -681,7 +681,7 @@ performManipulations doDecrypt rt wk manip = do | |||
681 | f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x | 681 | f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x |
682 | , om `Map.union` snd x ) | 682 | , om `Map.union` snd x ) |
683 | -- XXX: Shouldn't this signature generation show up in the KikiReport ? | 683 | -- XXX: Shouldn't this signature generation show up in the KikiReport ? |
684 | return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report ) | 684 | return $ KikiSuccess $ ( kd { keyUids = Map.adjust f (UidString uid) (keyUids kd) }, report ) |
685 | 685 | ||
686 | perform (kd,report) (SubKeyDeletion topk subk) = do | 686 | perform (kd,report) (SubKeyDeletion topk subk) = do |
687 | let kk = keykey $ packet $ keyMappedPacket kd | 687 | let kk = keykey $ packet $ keyMappedPacket kd |
@@ -755,13 +755,13 @@ parseUID str = UserIDRecord { | |||
755 | resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] | 755 | resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] |
756 | resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops | 756 | resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops |
757 | where | 757 | where |
758 | ops = map (\u -> InducerSignature u []) us | 758 | ops = map (\(UidString u) -> InducerSignature u []) us |
759 | us = filter torStyle $ Map.keys umap | 759 | us = filter torStyle $ Map.keys umap |
760 | torStyle str = and [ uid_topdomain parsed == "onion" | 760 | torStyle (UidString str) = and [ uid_topdomain parsed == "onion" |
761 | , uid_realname parsed `elem` ["","Anonymous"] | 761 | , uid_realname parsed `elem` ["","Anonymous"] |
762 | , uid_user parsed == "root" | 762 | , uid_user parsed == "root" |
763 | , fmap (match . fst) (lookup (packet k) torbindings) | 763 | , fmap (match . fst) (lookup (packet k) torbindings) |
764 | == Just True ] | 764 | == Just True ] |
765 | where parsed = parseUID str | 765 | where parsed = parseUID str |
766 | match = (==subdom) . take (fromIntegral len) | 766 | match = (==subdom) . take (fromIntegral len) |
767 | subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] | 767 | subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] |