diff options
-rw-r--r-- | kiki.cabal | 3 | ||||
-rw-r--r-- | kiki.hs | 14 | ||||
-rw-r--r-- | lib/CommandLine.hs | 65 | ||||
-rw-r--r-- | lib/Data/List/Merge.hs | 78 | ||||
-rw-r--r-- | lib/GnuPGAgent.hs | 5 | ||||
-rw-r--r-- | lib/KeyRing.hs | 4 | ||||
-rw-r--r-- | lib/KeyRing/BuildKeyDB.hs | 6 | ||||
-rw-r--r-- | lib/KeyRing/Types.hs | 2 | ||||
-rw-r--r-- | lib/Kiki.hs | 2 | ||||
-rw-r--r-- | lib/PacketTranscoder.hs | 4 | ||||
-rw-r--r-- | lib/Transforms.hs | 24 |
11 files changed, 113 insertions, 94 deletions
@@ -83,7 +83,8 @@ library | |||
83 | PacketTranscoder, | 83 | PacketTranscoder, |
84 | Transforms, | 84 | Transforms, |
85 | Data.OpenPGP.Util, | 85 | Data.OpenPGP.Util, |
86 | Text.XXD | 86 | Text.XXD, |
87 | Data.List.Merge | ||
87 | Build-Depends: base >= 4.8.0.0, | 88 | Build-Depends: base >= 4.8.0.0, |
88 | openpgp-asciiarmor, | 89 | openpgp-asciiarmor, |
89 | asn1-encoding, | 90 | asn1-encoding, |
@@ -72,7 +72,7 @@ isCertificationSig _ = True | |||
72 | fpmatch :: Maybe [Char] -> Packet -> Bool | 72 | fpmatch :: Maybe [Char] -> Packet -> Bool |
73 | fpmatch grip key = | 73 | fpmatch grip key = |
74 | (==) Nothing | 74 | (==) Nothing |
75 | (fmap (backend (fingerprint key)) grip >>= guard . not) | 75 | (fmap (backend (show $ fingerprint key)) grip >>= guard . not) |
76 | where | 76 | where |
77 | backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys) | 77 | backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys) |
78 | 78 | ||
@@ -105,11 +105,11 @@ listKeysFiltered grips pkts = do | |||
105 | matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True | 105 | matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True |
106 | matchgrip _ = False | 106 | matchgrip _ = False |
107 | gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as) | 107 | gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as) |
108 | singles = filter (\k -> fingerprint k `notElem` map fingerprint parents) masterkeys -- \\ parents | 108 | singles = filter (\k -> show (fingerprint k) `notElem` map (show . fingerprint) parents) masterkeys -- \\ parents |
109 | where parents = do | 109 | where parents = do |
110 | subs@((_,(top,_),_,_,_):_) <- gs | 110 | subs@((_,(top,_),_,_,_):_) <- gs |
111 | return top | 111 | return top |
112 | showsigs claimants = map (\k -> " " ++ "^ signed: " ++ fingerprint k) claimants | 112 | showsigs claimants = map (\k -> " " ++ "^ signed: " ++ show (fingerprint k)) claimants |
113 | subs0 <- map Left gs ++ map Right singles | 113 | subs0 <- map Left gs ++ map Right singles |
114 | let (top,subs) = case subs0 of Left subs1@((_,(top0,_),_,_,_):_) -> (top0,subs1) | 114 | let (top,subs) = case subs0 of Left subs1@((_,(top0,_),_,_,_):_) -> (top0,subs1) |
115 | Right top0 -> (top0,[]) | 115 | Right top0 -> (top0,[]) |
@@ -133,7 +133,7 @@ listKeysFiltered grips pkts = do | |||
133 | , ar | 133 | , ar |
134 | , formkind | 134 | , formkind |
135 | , " " | 135 | , " " |
136 | , fingerprint sub | 136 | , show $ fingerprint sub |
137 | , kcipher sub | 137 | , kcipher sub |
138 | -- , " " ++ (torhash sub) | 138 | -- , " " ++ (torhash sub) |
139 | -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub)) | 139 | -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub)) |
@@ -179,7 +179,7 @@ listKeysFiltered grips pkts = do | |||
179 | listToMaybe $ filter match torkeys | 179 | listToMaybe $ filter match torkeys |
180 | unlines $ (" " ++ ar ++ "@" ++ " " ++ uid_full parsed) : showsigs secondary | 180 | unlines $ (" " ++ ar ++ "@" ++ " " ++ uid_full parsed) : showsigs secondary |
181 | -- (_,sigs) = unzip certs | 181 | -- (_,sigs) = unzip certs |
182 | "master-key " ++ fingerprint top ++ kcipher top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" | 182 | "master-key " ++ show (fingerprint top) ++ kcipher top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" |
183 | 183 | ||
184 | 184 | ||
185 | {- | 185 | {- |
@@ -258,7 +258,7 @@ show_whose_key input_key db = | |||
258 | let ks = whoseKey input_key db | 258 | let ks = whoseKey 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 $ show $ fingerprint (packet k) |
262 | mapM_ putStrLn $ unUidString <$> Map.keys uids | 262 | mapM_ putStrLn $ unUidString <$> Map.keys uids |
263 | (_:_) -> error "ambiguous" | 263 | (_:_) -> error "ambiguous" |
264 | [] -> return () | 264 | [] -> return () |
@@ -1762,7 +1762,7 @@ tarC (sargs,margs) = do | |||
1762 | case r of | 1762 | case r of |
1763 | KikiSuccess p -> return $ Just p | 1763 | KikiSuccess p -> return $ Just p |
1764 | _ -> do | 1764 | _ -> do |
1765 | hPutStrLn stderr $ "Failed to decrypt "++fingerprint k++"." | 1765 | hPutStrLn stderr $ "Failed to decrypt "++show (fingerprint k) ++ "." |
1766 | return Nothing | 1766 | return Nothing |
1767 | -- | | 1767 | -- | |
1768 | -- | 1768 | -- |
diff --git a/lib/CommandLine.hs b/lib/CommandLine.hs index 4897b21..6bd42ea 100644 --- a/lib/CommandLine.hs +++ b/lib/CommandLine.hs | |||
@@ -37,6 +37,7 @@ import Numeric.Interval (Interval(..), singleton, (...), inf, sup, hull) | |||
37 | import qualified Numeric.Interval as I | 37 | import qualified Numeric.Interval as I |
38 | import Numeric.Interval.Bounded | 38 | import Numeric.Interval.Bounded |
39 | import SuperOrd | 39 | import SuperOrd |
40 | import Data.List.Merge | ||
40 | 41 | ||
41 | -- trace :: String -> a -> a | 42 | -- trace :: String -> a -> a |
42 | -- trace _ x = x | 43 | -- trace _ x = x |
@@ -120,51 +121,6 @@ packBits bs = sum $ zipWith (\b n -> if b then n else 0) bs $ iterate (*2) 1 | |||
120 | -} | 121 | -} |
121 | 122 | ||
122 | 123 | ||
123 | -- | mergeData | ||
124 | -- | ||
125 | -- > mergeData compare [1,3,5] [2,2,4,6] ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)] | ||
126 | -- | ||
127 | -- Given a comparison function and two sorted lists, 'mergeData' will return | ||
128 | -- a RLE compressed (run-length encoded) list of the comparison results | ||
129 | -- encountered while merging the lists. | ||
130 | -- | ||
131 | -- This data is enough information to perform the merge without doing the | ||
132 | -- comparisons or to reverse a merged list back to two sorted lists. | ||
133 | -- | ||
134 | -- When one list is exausted, the length of the remaining list is returned as | ||
135 | -- a run-length for LT or GT depending on whether the left list or the right | ||
136 | -- list has elements. | ||
137 | mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)] | ||
138 | mergeData comp (x:xs) (y:ys) | ||
139 | | comp x y == LT = case mergeData comp xs (y:ys) of | ||
140 | (n,LT):ys -> let n'=n+1 in n' `seq` (n',LT):ys | ||
141 | ys -> (1,LT):ys | ||
142 | | comp x y == EQ = case mergeData comp xs ys of | ||
143 | (n,EQ):ys -> let n'=n+1 in n' `seq` (n',EQ):ys | ||
144 | ys -> (1,EQ):ys | ||
145 | | comp x y == GT = case mergeData comp (x:xs) ys of | ||
146 | (n,GT):ys -> let n'=n+1 in n' `seq` (n',GT):ys | ||
147 | ys -> (1,GT):ys | ||
148 | mergeData comp [] [] = [] | ||
149 | mergeData comp [] ys = (length ys, GT) : [] | ||
150 | mergeData comp xs [] = (length xs, LT) : [] | ||
151 | |||
152 | mergeLists :: [(Int,Ordering)] -> (a -> a -> a) -> [a] -> [a] -> [a] | ||
153 | mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys | ||
154 | where | ||
155 | (ls,xs') = splitAt n xs | ||
156 | mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys' | ||
157 | where | ||
158 | (les,xs') = splitAt n xs | ||
159 | (res,ys') = splitAt n ys | ||
160 | es = zipWith f les res | ||
161 | mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys' | ||
162 | where | ||
163 | (gs,ys') = splitAt n ys | ||
164 | mergeLists [] f [] ys = ys | ||
165 | mergeLists [] f xs [] = xs | ||
166 | mergeLists [] f xs ys = error "xs ++ ys" | ||
167 | |||
168 | {- | 124 | {- |
169 | computeMask :: Int -> Ordering -> Ordering -> [(Int,Ordering)] -> Integer | 125 | computeMask :: Int -> Ordering -> Ordering -> [(Int,Ordering)] -> Integer |
170 | computeMask k w t [] = 0 | 126 | computeMask k w t [] = 0 |
@@ -207,21 +163,6 @@ mergeIntegers [] f !x !0 = x | |||
207 | mergeIntegers [] f !x !y = error "x .|. y" | 163 | mergeIntegers [] f !x !y = error "x .|. y" |
208 | -} | 164 | -} |
209 | 165 | ||
210 | splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a]) | ||
211 | splitLists ((n,LT):os) xs = (ls ++ lls, rrs) | ||
212 | where | ||
213 | (ls,xs') = splitAt n xs | ||
214 | (lls,rrs) = splitLists os xs' | ||
215 | splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs) | ||
216 | where | ||
217 | (es,xs') = splitAt n xs | ||
218 | (lls,rrs) = splitLists os xs' | ||
219 | splitLists ((n,GT):os) xs = (lls, rs ++ rrs) | ||
220 | where | ||
221 | (rs,xs') = splitAt n xs | ||
222 | (lls,rrs) = splitLists os xs' | ||
223 | splitLists [] xs = (xs,xs) | ||
224 | |||
225 | {- | 166 | {- |
226 | mergeBy :: Show a => (a -> a -> Ordering) -> [a] -> [a] | 167 | mergeBy :: Show a => (a -> a -> Ordering) -> [a] -> [a] |
227 | -> ( (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer | 168 | -> ( (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer |
@@ -452,10 +393,6 @@ removeIntersection [] ys = ([],ys) | |||
452 | removeIntersection xs [] = (xs,[]) | 393 | removeIntersection xs [] = (xs,[]) |
453 | 394 | ||
454 | 395 | ||
455 | -- ordinary sorted list merge. | ||
456 | mergeL :: Ord a => [a] -> [a] -> [a] | ||
457 | mergeL as bs = mergeLists (mergeData compare as bs) const as bs | ||
458 | |||
459 | -- | runArgs | 396 | -- | runArgs |
460 | -- | 397 | -- |
461 | -- (os,us) - named arguments(options, name-value pairs), and unnamed arguments | 398 | -- (os,us) - named arguments(options, name-value pairs), and unnamed arguments |
diff --git a/lib/Data/List/Merge.hs b/lib/Data/List/Merge.hs new file mode 100644 index 0000000..30853d9 --- /dev/null +++ b/lib/Data/List/Merge.hs | |||
@@ -0,0 +1,78 @@ | |||
1 | module Data.List.Merge where | ||
2 | |||
3 | -- | Ordinary Ord-based sorted list merge. | ||
4 | -- | ||
5 | -- TODO: verify fusion. | ||
6 | mergeL :: Ord a => [a] -> [a] -> [a] | ||
7 | mergeL as bs = mergeLists (mergeData compare as bs) const as bs | ||
8 | |||
9 | -- | Merge lists based on pre-computed comparison results. Use 'mergeData' to | ||
10 | -- perform the comparisons. | ||
11 | mergeLists :: [(Int,Ordering)] -- ^ comparison results. | ||
12 | -> (a -> a -> a) -- ^ combining function applied when 'EQ' is encountered. | ||
13 | -> [a] -- ^ sorted list | ||
14 | -> [a] -- ^ sorted list | ||
15 | -> [a] -- ^ merged sorted list | ||
16 | mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys | ||
17 | where | ||
18 | (ls,xs') = splitAt n xs | ||
19 | mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys' | ||
20 | where | ||
21 | (les,xs') = splitAt n xs | ||
22 | (res,ys') = splitAt n ys | ||
23 | es = zipWith f les res | ||
24 | mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys' | ||
25 | where | ||
26 | (gs,ys') = splitAt n ys | ||
27 | mergeLists [] _ [] ys = ys | ||
28 | mergeLists [] _ xs [] = xs | ||
29 | mergeLists [] _ _ _ = error "mergeLists: insufficient data." -- xs ++ ys | ||
30 | |||
31 | -- | Inverse to 'mergeLists': given a list of comparison results, partition a | ||
32 | -- list into the parts necessary for 'mergeLists' to recreate it. | ||
33 | splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a]) | ||
34 | splitLists ((n,LT):os) xs = (ls ++ lls, rrs) | ||
35 | where | ||
36 | (ls,xs') = splitAt n xs | ||
37 | (lls,rrs) = splitLists os xs' | ||
38 | splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs) | ||
39 | where | ||
40 | (es,xs') = splitAt n xs | ||
41 | (lls,rrs) = splitLists os xs' | ||
42 | splitLists ((n,GT):os) xs = (lls, rs ++ rrs) | ||
43 | where | ||
44 | (rs,xs') = splitAt n xs | ||
45 | (lls,rrs) = splitLists os xs' | ||
46 | splitLists [] xs = (xs,xs) | ||
47 | |||
48 | |||
49 | -- | mergeData | ||
50 | -- | ||
51 | -- > mergeData compare [1,3,5] [2,2,4,6] ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)] | ||
52 | -- | ||
53 | -- Given a comparison function and two sorted lists, 'mergeData' will return | ||
54 | -- a RLE compressed (run-length encoded) list of the comparison results | ||
55 | -- encountered while merging the lists. | ||
56 | -- | ||
57 | -- This data is enough information to perform the merge without doing the | ||
58 | -- comparisons or to reverse a merged list back to two sorted lists. | ||
59 | -- | ||
60 | -- When one list is exhausted, the length of the remaining list is returned | ||
61 | -- as a run-length for LT or GT depending on whether the left list or the | ||
62 | -- right list has elements. | ||
63 | mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)] | ||
64 | mergeData comp (x:xs) (y:ys) | ||
65 | | comp x y == LT = case mergeData comp xs (y:ys) of | ||
66 | (n,LT):zs -> let n'=n+1 in n' `seq` (n',LT):zs | ||
67 | zs -> (1,LT):zs | ||
68 | | comp x y == EQ = case mergeData comp xs ys of | ||
69 | (n,EQ):zs -> let n'=n+1 in n' `seq` (n',EQ):zs | ||
70 | zs -> (1,EQ):zs | ||
71 | | otherwise = case mergeData comp (x:xs) ys of | ||
72 | (n,GT):zs -> let n'=n+1 in n' `seq` (n',GT):zs | ||
73 | zs -> (1,GT):zs | ||
74 | mergeData _ [] [] = [] | ||
75 | mergeData _ [] ys = (length ys, GT) : [] | ||
76 | mergeData _ xs [] = (length xs, LT) : [] | ||
77 | |||
78 | |||
diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs index d73ceed..e5f91a2 100644 --- a/lib/GnuPGAgent.hs +++ b/lib/GnuPGAgent.hs | |||
@@ -18,7 +18,8 @@ import Data.Bool | |||
18 | import Data.Char | 18 | import Data.Char |
19 | import Data.Maybe | 19 | import Data.Maybe |
20 | import Data.OpenPGP | 20 | import Data.OpenPGP |
21 | import Data.OpenPGP.Util | 21 | import qualified Data.OpenPGP.Util |
22 | ;import Data.OpenPGP.Util hiding (fingerprint) | ||
22 | import Data.Word | 23 | import Data.Word |
23 | import Network.Socket | 24 | import Network.Socket |
24 | import System.Directory | 25 | import System.Directory |
@@ -35,6 +36,8 @@ import ProcessUtils | |||
35 | import Control.Monad.Fix | 36 | import Control.Monad.Fix |
36 | import Control.Concurrent (threadDelay) | 37 | import Control.Concurrent (threadDelay) |
37 | 38 | ||
39 | fingerprint = show . Data.OpenPGP.Util.fingerprint | ||
40 | |||
38 | data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } | 41 | data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } |
39 | 42 | ||
40 | launchAgent :: FilePath -> Maybe [(String,String)] -> IO (Maybe GnuPGAgent) | 43 | launchAgent :: FilePath -> Maybe [(String,String)] -> IO (Maybe GnuPGAgent) |
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 70edb9e..3da3565 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs | |||
@@ -883,7 +883,7 @@ writeKeyToFile stream@(StreamInfo { typ = PEMFile }) fname packet = do | |||
883 | writeStamped (InputFileContext "" "") fname stamp output | 883 | writeStamped (InputFileContext "" "") fname stamp output |
884 | setFileCreationMask saved_mask | 884 | setFileCreationMask saved_mask |
885 | return [(fname, ExportedSubkey)] | 885 | return [(fname, ExportedSubkey)] |
886 | Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)] | 886 | Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ show $ fingerprint packet)] |
887 | 887 | ||
888 | writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do | 888 | writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do |
889 | case key_algorithm packet of | 889 | case key_algorithm packet of |
@@ -922,7 +922,7 @@ writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do | |||
922 | writeStamped (InputFileContext "" "") fname stamp output | 922 | writeStamped (InputFileContext "" "") fname stamp output |
923 | setFileCreationMask saved_mask | 923 | setFileCreationMask saved_mask |
924 | return [(fname, ExportedSubkey)] | 924 | return [(fname, ExportedSubkey)] |
925 | algo -> return [(fname, UnableToExport algo $ fingerprint packet)] | 925 | algo -> return [(fname, UnableToExport algo $ show $ fingerprint packet)] |
926 | 926 | ||
927 | writePEMKeys :: (PacketDecrypter) | 927 | writePEMKeys :: (PacketDecrypter) |
928 | -> KeyDB | 928 | -> KeyDB |
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index 0eddc51..587d812 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs | |||
@@ -127,7 +127,7 @@ buildKeyDB ctx grip0 keyring = do | |||
127 | ringPackets <- Map.traverseWithKey readp ringMap | 127 | ringPackets <- Map.traverseWithKey readp ringMap |
128 | let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) | 128 | let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) |
129 | 129 | ||
130 | let grip = grip0 `mplus` (fingerprint <$> fstkey) | 130 | let grip = grip0 `mplus` (show . fingerprint <$> fstkey) |
131 | where | 131 | where |
132 | fstkey = do | 132 | fstkey = do |
133 | (_,Message ps) <- Map.lookup HomeSec ringPackets | 133 | (_,Message ps) <- Map.lookup HomeSec ringPackets |
@@ -691,7 +691,7 @@ insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = | |||
691 | sig_ov <- pgpSign (Message [wkun]) | 691 | sig_ov <- pgpSign (Message [wkun]) |
692 | tor_ov | 692 | tor_ov |
693 | SHA1 | 693 | SHA1 |
694 | (fingerprint wkun) | 694 | (show $ fingerprint wkun) |
695 | flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) | 695 | flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) |
696 | (sig_ov >>= listToMaybe . signatures_over) | 696 | (sig_ov >>= listToMaybe . signatures_over) |
697 | $ \sig -> do | 697 | $ \sig -> do |
@@ -1216,7 +1216,7 @@ fingerdress :: Packet -> SockAddr | |||
1216 | fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str | 1216 | fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str |
1217 | where | 1217 | where |
1218 | zero = SockAddrInet 0 0 | 1218 | zero = SockAddrInet 0 0 |
1219 | addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk) | 1219 | addr_str = colons $ "fd" ++ drop 10 (map toLower $ show $ fingerprint topk) |
1220 | colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs | 1220 | colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs |
1221 | colons xs = xs | 1221 | colons xs = xs |
1222 | 1222 | ||
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs index 4a0b34e..5318b31 100644 --- a/lib/KeyRing/Types.hs +++ b/lib/KeyRing/Types.hs | |||
@@ -350,7 +350,7 @@ isTrust _ = False | |||
350 | -- matchpr fp = Data.List.Extra.takeEnd (length fp) | 350 | -- matchpr fp = Data.List.Extra.takeEnd (length fp) |
351 | -- | 351 | -- |
352 | matchpr :: String -> Packet -> String | 352 | matchpr :: String -> Packet -> String |
353 | matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp | 353 | matchpr fp k = reverse $ zipWith const (reverse (show $ fingerprint k)) fp |
354 | 354 | ||
355 | 355 | ||
356 | 356 | ||
diff --git a/lib/Kiki.hs b/lib/Kiki.hs index e919b88..64dc2bd 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs | |||
@@ -497,7 +497,7 @@ getMyIdentity :: KeyRingRuntime -> Maybe MyIdentity | |||
497 | getMyIdentity rt = do | 497 | getMyIdentity rt = do |
498 | wk <- rtWorkingKey rt | 498 | wk <- rtWorkingKey rt |
499 | Hostnames wkaddr _ _ _ <- getHostnames <$> lookupKeyData (keykey wk) (rtKeyDB rt) | 499 | Hostnames wkaddr _ _ _ <- getHostnames <$> lookupKeyData (keykey wk) (rtKeyDB rt) |
500 | return $ MyIdentity wkaddr (fingerprint wk) | 500 | return $ MyIdentity wkaddr (show $ fingerprint wk) |
501 | 501 | ||
502 | refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () | 502 | refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () |
503 | refreshCache rt rootdir = do | 503 | refreshCache rt rootdir = do |
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs index 16d1db5..759d83f 100644 --- a/lib/PacketTranscoder.hs +++ b/lib/PacketTranscoder.hs | |||
@@ -40,9 +40,9 @@ keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT | |||
40 | keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT | 40 | keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT |
41 | keyCompare what a b | keykey a==keykey b = EQ | 41 | keyCompare what a b | keykey a==keykey b = EQ |
42 | keyCompare what a b = error $ unlines ["Unable to merge "++what++":" | 42 | keyCompare what a b = error $ unlines ["Unable to merge "++what++":" |
43 | , if isKey a then fingerprint a else "" | 43 | , if isKey a then show $ fingerprint a else "" |
44 | , PP.ppShow a | 44 | , PP.ppShow a |
45 | , if isKey b then fingerprint b else "" | 45 | , if isKey b then show $ fingerprint b else "" |
46 | , PP.ppShow b | 46 | , PP.ppShow b |
47 | ] | 47 | ] |
48 | 48 | ||
diff --git a/lib/Transforms.hs b/lib/Transforms.hs index 9571e7e..e7097ba 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs | |||
@@ -177,7 +177,7 @@ findTag tag topk subkey subsigs = (xs',minsig,ys') | |||
177 | sig <- Just (packet . fst $ sig) | 177 | sig <- Just (packet . fst $ sig) |
178 | guard (isSignaturePacket sig) | 178 | guard (isSignaturePacket sig) |
179 | guard $ flip isSuffixOf | 179 | guard $ flip isSuffixOf |
180 | (fingerprint topk) | 180 | (show $ fingerprint topk) |
181 | . fromMaybe "%bad%" | 181 | . fromMaybe "%bad%" |
182 | . signature_issuer | 182 | . signature_issuer |
183 | $ sig | 183 | $ sig |
@@ -217,7 +217,7 @@ mkUsage tag = NotationDataPacket | |||
217 | 217 | ||
218 | 218 | ||
219 | smallpr :: Packet -> [Char] | 219 | smallpr :: Packet -> [Char] |
220 | smallpr k = drop 24 $ fingerprint k | 220 | smallpr k = drop 24 $ show $ fingerprint k |
221 | 221 | ||
222 | backsig :: SignatureSubpacket -> Maybe Packet | 222 | backsig :: SignatureSubpacket -> Maybe Packet |
223 | backsig (EmbeddedSignaturePacket s) = Just s | 223 | backsig (EmbeddedSignaturePacket s) = Just s |
@@ -298,7 +298,7 @@ getBindings pkts = (sigs,bindings) | |||
298 | b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs | 298 | b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs |
299 | i <- map signature_issuer (signatures_over b) | 299 | i <- map signature_issuer (signatures_over b) |
300 | i <- maybeToList i | 300 | i <- maybeToList i |
301 | who <- maybeToList $ find_key fingerprint (Message keys) i | 301 | who <- maybeToList $ find_key (show . fingerprint) (Message keys) i |
302 | let (code,claimants) = | 302 | let (code,claimants) = |
303 | case () of | 303 | case () of |
304 | _ | who == topkey b -> (1,[]) | 304 | _ | who == topkey b -> (1,[]) |
@@ -322,7 +322,7 @@ accBindings bs = as | |||
322 | bindingPair (_,p,_,_,_) = pub2 p | 322 | bindingPair (_,p,_,_,_) = pub2 p |
323 | where | 323 | where |
324 | pub2 (a,b) = (pub a, pub b) | 324 | pub2 (a,b) = (pub a, pub b) |
325 | pub a = fingerprint_material a | 325 | pub a = show $ fingerprint_material a |
326 | samePair a b = bindingPair a == bindingPair b | 326 | samePair a b = bindingPair a == bindingPair b |
327 | combine (ac,p,akind,ahashed,aclaimaints) | 327 | combine (ac,p,akind,ahashed,aclaimaints) |
328 | (bc,_,bkind,bhashed,bclaimaints) | 328 | (bc,_,bkind,bhashed,bclaimaints) |
@@ -363,7 +363,7 @@ showPacket :: Packet -> String | |||
363 | showPacket p | isKey p = (if is_subkey p | 363 | showPacket p | isKey p = (if is_subkey p |
364 | then showPacket0 p | 364 | then showPacket0 p |
365 | else ifSecret p "---Secret" "---Public") | 365 | else ifSecret p "---Secret" "---Public") |
366 | ++ " "++fingerprint p | 366 | ++ " "++show (fingerprint p) |
367 | ++ " "++show (key_algorithm p) | 367 | ++ " "++show (key_algorithm p) |
368 | ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" } | 368 | ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" } |
369 | | Just uid <- isUserID p = showPacket0 p ++ " " ++ show uid | 369 | | Just uid <- isUserID p = showPacket0 p ++ " " ++ show uid |
@@ -405,7 +405,7 @@ makeInducerSig topk wkun uid extras | |||
405 | subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] | 405 | subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] |
406 | tsign | 406 | tsign |
407 | ++ extras | 407 | ++ extras |
408 | subpackets_unh = [IssuerPacket (fingerprint wkun)] | 408 | subpackets_unh = [IssuerPacket (show $ fingerprint wkun)] |
409 | tsign = if keykey wkun == keykey topk | 409 | tsign = if keykey wkun == keykey topk |
410 | then [] -- tsign doesnt make sense for self-signatures | 410 | then [] -- tsign doesnt make sense for self-signatures |
411 | else [ TrustSignaturePacket 1 120 | 411 | else [ TrustSignaturePacket 1 120 |
@@ -540,7 +540,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do | |||
540 | let wk = packet top | 540 | let wk = packet top |
541 | wkun <- doDecrypt top | 541 | wkun <- doDecrypt top |
542 | try wkun $ \wkun -> do | 542 | try wkun $ \wkun -> do |
543 | let grip = fingerprint wk | 543 | let grip = show $ fingerprint wk |
544 | addOrigin new_sig = | 544 | addOrigin new_sig = |
545 | flip (maybe $ return FailedToMakeSignature) | 545 | flip (maybe $ return FailedToMakeSignature) |
546 | (new_sig >>= listToMaybe . signatures_over) | 546 | (new_sig >>= listToMaybe . signatures_over) |
@@ -563,7 +563,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do | |||
563 | -- , SignatureCreationTimePacket (fromIntegral timestamp) | 563 | -- , SignatureCreationTimePacket (fromIntegral timestamp) |
564 | isFlagsPacket (KeyFlagsPacket {}) = True | 564 | isFlagsPacket (KeyFlagsPacket {}) = True |
565 | isFlagsPacket _ = False | 565 | isFlagsPacket _ = False |
566 | subgrip = fingerprint (head parsedkey) | 566 | subgrip = show $ fingerprint (head parsedkey) |
567 | 567 | ||
568 | back_sig <- pgpSign (Message parsedkey) | 568 | back_sig <- pgpSign (Message parsedkey) |
569 | (SubkeySignature wk | 569 | (SubkeySignature wk |
@@ -575,7 +575,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do | |||
575 | then SHA256 | 575 | then SHA256 |
576 | else SHA1) | 576 | else SHA1) |
577 | subgrip | 577 | subgrip |
578 | let iss = IssuerPacket (fingerprint wk) | 578 | let iss = IssuerPacket (show $ fingerprint wk) |
579 | cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) | 579 | cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) |
580 | unhashed0 = maybe [iss] cons_iss back_sig | 580 | unhashed0 = maybe [iss] cons_iss back_sig |
581 | 581 | ||
@@ -619,7 +619,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do | |||
619 | (packet subkey_p) | 619 | (packet subkey_p) |
620 | [sig'] ) | 620 | [sig'] ) |
621 | SHA1 | 621 | SHA1 |
622 | (fingerprint wk) | 622 | (show $ fingerprint wk) |
623 | newsig <- addOrigin new_sig | 623 | newsig <- addOrigin new_sig |
624 | return $ fmap (,[]) newsig | 624 | return $ fmap (,[]) newsig |
625 | 625 | ||
@@ -676,7 +676,7 @@ performManipulations doDecrypt rt wk manip = do | |||
676 | new_sig <- maybeToList new_sig | 676 | new_sig <- maybeToList new_sig |
677 | guard (null $ selfsigs) | 677 | guard (null $ selfsigs) |
678 | signatures_over new_sig | 678 | signatures_over new_sig |
679 | sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) | 679 | sigr <- pgpSign (Message [wkun]) sigOver SHA1 (show $ fingerprint wkun) |
680 | let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) | 680 | let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) |
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 ) |
@@ -795,7 +795,7 @@ resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap subm | |||
795 | topk = keykey $ packet k -- key to master of key to be deleted | 795 | topk = keykey $ packet k -- key to master of key to be deleted |
796 | subk = do | 796 | subk = do |
797 | (k,sub) <- Map.toList submap | 797 | (k,sub) <- Map.toList submap |
798 | guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) | 798 | guard $ map toUpper fp == show (fingerprint $ packet $ subkeyMappedPacket sub) |
799 | return k | 799 | return k |
800 | 800 | ||
801 | -- (3 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] | 801 | -- (3 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] |