From c54b35e665f2a8ec2fff484de99fd59b0454dcff Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 15 Jul 2019 18:45:45 -0400 Subject: Switched fingerprint to wrapped ByteString + some module shuffling. --- kiki.cabal | 3 +- kiki.hs | 14 ++++----- lib/CommandLine.hs | 65 +-------------------------------------- lib/Data/List/Merge.hs | 78 +++++++++++++++++++++++++++++++++++++++++++++++ lib/GnuPGAgent.hs | 5 ++- lib/KeyRing.hs | 4 +-- lib/KeyRing/BuildKeyDB.hs | 6 ++-- lib/KeyRing/Types.hs | 2 +- lib/Kiki.hs | 2 +- lib/PacketTranscoder.hs | 4 +-- lib/Transforms.hs | 24 +++++++-------- 11 files changed, 113 insertions(+), 94 deletions(-) create mode 100644 lib/Data/List/Merge.hs diff --git a/kiki.cabal b/kiki.cabal index dc3e1fd..ffb2bf4 100644 --- a/kiki.cabal +++ b/kiki.cabal @@ -83,7 +83,8 @@ library PacketTranscoder, Transforms, Data.OpenPGP.Util, - Text.XXD + Text.XXD, + Data.List.Merge Build-Depends: base >= 4.8.0.0, openpgp-asciiarmor, asn1-encoding, diff --git a/kiki.hs b/kiki.hs index 7d825d3..0b884ae 100644 --- a/kiki.hs +++ b/kiki.hs @@ -72,7 +72,7 @@ isCertificationSig _ = True fpmatch :: Maybe [Char] -> Packet -> Bool fpmatch grip key = (==) Nothing - (fmap (backend (fingerprint key)) grip >>= guard . not) + (fmap (backend (show $ fingerprint key)) grip >>= guard . not) where backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys) @@ -105,11 +105,11 @@ listKeysFiltered grips pkts = do matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True matchgrip _ = False gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as) - singles = filter (\k -> fingerprint k `notElem` map fingerprint parents) masterkeys -- \\ parents + singles = filter (\k -> show (fingerprint k) `notElem` map (show . fingerprint) parents) masterkeys -- \\ parents where parents = do subs@((_,(top,_),_,_,_):_) <- gs return top - showsigs claimants = map (\k -> " " ++ "^ signed: " ++ fingerprint k) claimants + showsigs claimants = map (\k -> " " ++ "^ signed: " ++ show (fingerprint k)) claimants subs0 <- map Left gs ++ map Right singles let (top,subs) = case subs0 of Left subs1@((_,(top0,_),_,_,_):_) -> (top0,subs1) Right top0 -> (top0,[]) @@ -133,7 +133,7 @@ listKeysFiltered grips pkts = do , ar , formkind , " " - , fingerprint sub + , show $ fingerprint sub , kcipher sub -- , " " ++ (torhash sub) -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub)) @@ -179,7 +179,7 @@ listKeysFiltered grips pkts = do listToMaybe $ filter match torkeys unlines $ (" " ++ ar ++ "@" ++ " " ++ uid_full parsed) : showsigs secondary -- (_,sigs) = unzip certs - "master-key " ++ fingerprint top ++ kcipher top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" + "master-key " ++ show (fingerprint top) ++ kcipher top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" {- @@ -258,7 +258,7 @@ show_whose_key input_key db = let ks = whoseKey input_key db case ks of [KeyData k _ uids _] -> do - putStrLn $ fingerprint (packet k) + putStrLn $ show $ fingerprint (packet k) mapM_ putStrLn $ unUidString <$> Map.keys uids (_:_) -> error "ambiguous" [] -> return () @@ -1762,7 +1762,7 @@ tarC (sargs,margs) = do case r of KikiSuccess p -> return $ Just p _ -> do - hPutStrLn stderr $ "Failed to decrypt "++fingerprint k++"." + hPutStrLn stderr $ "Failed to decrypt "++show (fingerprint k) ++ "." return Nothing -- | -- 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) import qualified Numeric.Interval as I import Numeric.Interval.Bounded import SuperOrd +import Data.List.Merge -- trace :: String -> a -> a -- trace _ x = x @@ -120,51 +121,6 @@ packBits bs = sum $ zipWith (\b n -> if b then n else 0) bs $ iterate (*2) 1 -} --- | mergeData --- --- > mergeData compare [1,3,5] [2,2,4,6] ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)] --- --- Given a comparison function and two sorted lists, 'mergeData' will return --- a RLE compressed (run-length encoded) list of the comparison results --- encountered while merging the lists. --- --- This data is enough information to perform the merge without doing the --- comparisons or to reverse a merged list back to two sorted lists. --- --- When one list is exausted, the length of the remaining list is returned as --- a run-length for LT or GT depending on whether the left list or the right --- list has elements. -mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)] -mergeData comp (x:xs) (y:ys) - | comp x y == LT = case mergeData comp xs (y:ys) of - (n,LT):ys -> let n'=n+1 in n' `seq` (n',LT):ys - ys -> (1,LT):ys - | comp x y == EQ = case mergeData comp xs ys of - (n,EQ):ys -> let n'=n+1 in n' `seq` (n',EQ):ys - ys -> (1,EQ):ys - | comp x y == GT = case mergeData comp (x:xs) ys of - (n,GT):ys -> let n'=n+1 in n' `seq` (n',GT):ys - ys -> (1,GT):ys -mergeData comp [] [] = [] -mergeData comp [] ys = (length ys, GT) : [] -mergeData comp xs [] = (length xs, LT) : [] - -mergeLists :: [(Int,Ordering)] -> (a -> a -> a) -> [a] -> [a] -> [a] -mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys - where - (ls,xs') = splitAt n xs -mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys' - where - (les,xs') = splitAt n xs - (res,ys') = splitAt n ys - es = zipWith f les res -mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys' - where - (gs,ys') = splitAt n ys -mergeLists [] f [] ys = ys -mergeLists [] f xs [] = xs -mergeLists [] f xs ys = error "xs ++ ys" - {- computeMask :: Int -> Ordering -> Ordering -> [(Int,Ordering)] -> Integer computeMask k w t [] = 0 @@ -207,21 +163,6 @@ mergeIntegers [] f !x !0 = x mergeIntegers [] f !x !y = error "x .|. y" -} -splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a]) -splitLists ((n,LT):os) xs = (ls ++ lls, rrs) - where - (ls,xs') = splitAt n xs - (lls,rrs) = splitLists os xs' -splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs) - where - (es,xs') = splitAt n xs - (lls,rrs) = splitLists os xs' -splitLists ((n,GT):os) xs = (lls, rs ++ rrs) - where - (rs,xs') = splitAt n xs - (lls,rrs) = splitLists os xs' -splitLists [] xs = (xs,xs) - {- mergeBy :: Show a => (a -> a -> Ordering) -> [a] -> [a] -> ( (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer @@ -452,10 +393,6 @@ removeIntersection [] ys = ([],ys) removeIntersection xs [] = (xs,[]) --- ordinary sorted list merge. -mergeL :: Ord a => [a] -> [a] -> [a] -mergeL as bs = mergeLists (mergeData compare as bs) const as bs - -- | runArgs -- -- (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 @@ +module Data.List.Merge where + +-- | Ordinary Ord-based sorted list merge. +-- +-- TODO: verify fusion. +mergeL :: Ord a => [a] -> [a] -> [a] +mergeL as bs = mergeLists (mergeData compare as bs) const as bs + +-- | Merge lists based on pre-computed comparison results. Use 'mergeData' to +-- perform the comparisons. +mergeLists :: [(Int,Ordering)] -- ^ comparison results. + -> (a -> a -> a) -- ^ combining function applied when 'EQ' is encountered. + -> [a] -- ^ sorted list + -> [a] -- ^ sorted list + -> [a] -- ^ merged sorted list +mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys + where + (ls,xs') = splitAt n xs +mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys' + where + (les,xs') = splitAt n xs + (res,ys') = splitAt n ys + es = zipWith f les res +mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys' + where + (gs,ys') = splitAt n ys +mergeLists [] _ [] ys = ys +mergeLists [] _ xs [] = xs +mergeLists [] _ _ _ = error "mergeLists: insufficient data." -- xs ++ ys + +-- | Inverse to 'mergeLists': given a list of comparison results, partition a +-- list into the parts necessary for 'mergeLists' to recreate it. +splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a]) +splitLists ((n,LT):os) xs = (ls ++ lls, rrs) + where + (ls,xs') = splitAt n xs + (lls,rrs) = splitLists os xs' +splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs) + where + (es,xs') = splitAt n xs + (lls,rrs) = splitLists os xs' +splitLists ((n,GT):os) xs = (lls, rs ++ rrs) + where + (rs,xs') = splitAt n xs + (lls,rrs) = splitLists os xs' +splitLists [] xs = (xs,xs) + + +-- | mergeData +-- +-- > mergeData compare [1,3,5] [2,2,4,6] ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)] +-- +-- Given a comparison function and two sorted lists, 'mergeData' will return +-- a RLE compressed (run-length encoded) list of the comparison results +-- encountered while merging the lists. +-- +-- This data is enough information to perform the merge without doing the +-- comparisons or to reverse a merged list back to two sorted lists. +-- +-- When one list is exhausted, the length of the remaining list is returned +-- as a run-length for LT or GT depending on whether the left list or the +-- right list has elements. +mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)] +mergeData comp (x:xs) (y:ys) + | comp x y == LT = case mergeData comp xs (y:ys) of + (n,LT):zs -> let n'=n+1 in n' `seq` (n',LT):zs + zs -> (1,LT):zs + | comp x y == EQ = case mergeData comp xs ys of + (n,EQ):zs -> let n'=n+1 in n' `seq` (n',EQ):zs + zs -> (1,EQ):zs + | otherwise = case mergeData comp (x:xs) ys of + (n,GT):zs -> let n'=n+1 in n' `seq` (n',GT):zs + zs -> (1,GT):zs +mergeData _ [] [] = [] +mergeData _ [] ys = (length ys, GT) : [] +mergeData _ xs [] = (length xs, LT) : [] + + 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 import Data.Char import Data.Maybe import Data.OpenPGP -import Data.OpenPGP.Util +import qualified Data.OpenPGP.Util + ;import Data.OpenPGP.Util hiding (fingerprint) import Data.Word import Network.Socket import System.Directory @@ -35,6 +36,8 @@ import ProcessUtils import Control.Monad.Fix import Control.Concurrent (threadDelay) +fingerprint = show . Data.OpenPGP.Util.fingerprint + data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } 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 writeStamped (InputFileContext "" "") fname stamp output setFileCreationMask saved_mask return [(fname, ExportedSubkey)] - Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)] + Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ show $ fingerprint packet)] writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do case key_algorithm packet of @@ -922,7 +922,7 @@ writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do writeStamped (InputFileContext "" "") fname stamp output setFileCreationMask saved_mask return [(fname, ExportedSubkey)] - algo -> return [(fname, UnableToExport algo $ fingerprint packet)] + algo -> return [(fname, UnableToExport algo $ show $ fingerprint packet)] writePEMKeys :: (PacketDecrypter) -> 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 ringPackets <- Map.traverseWithKey readp ringMap let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) - let grip = grip0 `mplus` (fingerprint <$> fstkey) + let grip = grip0 `mplus` (show . fingerprint <$> fstkey) where fstkey = do (_,Message ps) <- Map.lookup HomeSec ringPackets @@ -691,7 +691,7 @@ insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = sig_ov <- pgpSign (Message [wkun]) tor_ov SHA1 - (fingerprint wkun) + (show $ fingerprint wkun) flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) (sig_ov >>= listToMaybe . signatures_over) $ \sig -> do @@ -1216,7 +1216,7 @@ fingerdress :: Packet -> SockAddr fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str where zero = SockAddrInet 0 0 - addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk) + addr_str = colons $ "fd" ++ drop 10 (map toLower $ show $ fingerprint topk) colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs colons xs = xs 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 -- matchpr fp = Data.List.Extra.takeEnd (length fp) -- matchpr :: String -> Packet -> String -matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp +matchpr fp k = reverse $ zipWith const (reverse (show $ fingerprint k)) fp 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 getMyIdentity rt = do wk <- rtWorkingKey rt Hostnames wkaddr _ _ _ <- getHostnames <$> lookupKeyData (keykey wk) (rtKeyDB rt) - return $ MyIdentity wkaddr (fingerprint wk) + return $ MyIdentity wkaddr (show $ fingerprint wk) refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () 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 keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT keyCompare what a b | keykey a==keykey b = EQ keyCompare what a b = error $ unlines ["Unable to merge "++what++":" - , if isKey a then fingerprint a else "" + , if isKey a then show $ fingerprint a else "" , PP.ppShow a - , if isKey b then fingerprint b else "" + , if isKey b then show $ fingerprint b else "" , PP.ppShow b ] 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') sig <- Just (packet . fst $ sig) guard (isSignaturePacket sig) guard $ flip isSuffixOf - (fingerprint topk) + (show $ fingerprint topk) . fromMaybe "%bad%" . signature_issuer $ sig @@ -217,7 +217,7 @@ mkUsage tag = NotationDataPacket smallpr :: Packet -> [Char] -smallpr k = drop 24 $ fingerprint k +smallpr k = drop 24 $ show $ fingerprint k backsig :: SignatureSubpacket -> Maybe Packet backsig (EmbeddedSignaturePacket s) = Just s @@ -298,7 +298,7 @@ getBindings pkts = (sigs,bindings) b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs i <- map signature_issuer (signatures_over b) i <- maybeToList i - who <- maybeToList $ find_key fingerprint (Message keys) i + who <- maybeToList $ find_key (show . fingerprint) (Message keys) i let (code,claimants) = case () of _ | who == topkey b -> (1,[]) @@ -322,7 +322,7 @@ accBindings bs = as bindingPair (_,p,_,_,_) = pub2 p where pub2 (a,b) = (pub a, pub b) - pub a = fingerprint_material a + pub a = show $ fingerprint_material a samePair a b = bindingPair a == bindingPair b combine (ac,p,akind,ahashed,aclaimaints) (bc,_,bkind,bhashed,bclaimaints) @@ -363,7 +363,7 @@ showPacket :: Packet -> String showPacket p | isKey p = (if is_subkey p then showPacket0 p else ifSecret p "---Secret" "---Public") - ++ " "++fingerprint p + ++ " "++show (fingerprint p) ++ " "++show (key_algorithm p) ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" } | Just uid <- isUserID p = showPacket0 p ++ " " ++ show uid @@ -405,7 +405,7 @@ makeInducerSig topk wkun uid extras subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] tsign ++ extras - subpackets_unh = [IssuerPacket (fingerprint wkun)] + subpackets_unh = [IssuerPacket (show $ fingerprint wkun)] tsign = if keykey wkun == keykey topk then [] -- tsign doesnt make sense for self-signatures else [ TrustSignaturePacket 1 120 @@ -540,7 +540,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do let wk = packet top wkun <- doDecrypt top try wkun $ \wkun -> do - let grip = fingerprint wk + let grip = show $ fingerprint wk addOrigin new_sig = flip (maybe $ return FailedToMakeSignature) (new_sig >>= listToMaybe . signatures_over) @@ -563,7 +563,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do -- , SignatureCreationTimePacket (fromIntegral timestamp) isFlagsPacket (KeyFlagsPacket {}) = True isFlagsPacket _ = False - subgrip = fingerprint (head parsedkey) + subgrip = show $ fingerprint (head parsedkey) back_sig <- pgpSign (Message parsedkey) (SubkeySignature wk @@ -575,7 +575,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do then SHA256 else SHA1) subgrip - let iss = IssuerPacket (fingerprint wk) + let iss = IssuerPacket (show $ fingerprint wk) cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) unhashed0 = maybe [iss] cons_iss back_sig @@ -619,7 +619,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do (packet subkey_p) [sig'] ) SHA1 - (fingerprint wk) + (show $ fingerprint wk) newsig <- addOrigin new_sig return $ fmap (,[]) newsig @@ -676,7 +676,7 @@ performManipulations doDecrypt rt wk manip = do new_sig <- maybeToList new_sig guard (null $ selfsigs) signatures_over new_sig - sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) + sigr <- pgpSign (Message [wkun]) sigOver SHA1 (show $ fingerprint wkun) let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x , om `Map.union` snd x ) @@ -795,7 +795,7 @@ resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap subm topk = keykey $ packet k -- key to master of key to be deleted subk = do (k,sub) <- Map.toList submap - guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) + guard $ map toUpper fp == show (fingerprint $ packet $ subkeyMappedPacket sub) return k -- (3 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] -- cgit v1.2.3