Switched fingerprint to wrapped ByteString + some module shuffling.

11 files changed, 113 insertions, 94 deletions

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]