2 files changed, 215 insertions, 208 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 7073e43..39bff4c 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -8,9 +8,14 @@ import Control.Monad
 import Data.Maybe
 import Data.Char
 import Data.List
-import Control.Applicative ( (<$>) )
-import System.Directory    ( getHomeDirectory, doesFileExist )
-import Control.Arrow       ( first, second )
+import Data.OpenPGP
+import Control.Applicative    ( (<$>) )
+import System.Directory       ( getHomeDirectory, doesFileExist )
+import Control.Arrow          ( first, second )
+import Data.OpenPGP.Util      ( fingerprint )
+import Data.ByteString.Lazy   ( ByteString )
+import Text.Show.Pretty as PP ( ppShow )
+import qualified Data.Map as Map
 
 import DotLock
 
@@ -146,3 +151,210 @@ getHomeDir protohome = do
 lookupEnv var =
     handleIO_ (return Nothing) $ fmap Just (getEnv var)
 #endif
+
+isKey (PublicKeyPacket {}) = True
+isKey (SecretKeyPacket {}) = True
+isKey _                    = False
+
+isUserID (UserIDPacket {}) = True
+isUserID _                 = False
+
+isTrust (TrustPacket {}) = True
+isTrust _                = False
+
+
+data OriginFlags = OriginFlags {
+        originallyPublic :: Bool,
+        originalNum :: Int
+    }
+    deriving Show
+type OriginMap = Map.Map FilePath OriginFlags
+data MappedPacket = MappedPacket
+        { packet :: Packet
+        , usage_tag :: Maybe String
+        , locations :: OriginMap
+        }
+
+type TrustMap = Map.Map FilePath Packet
+type SigAndTrust = ( MappedPacket
+                   , TrustMap     ) -- trust packets
+
+type KeyKey = [ByteString]
+data SubKey = SubKey MappedPacket [SigAndTrust]
+data KeyData = KeyData MappedPacket    -- main key
+                       [SigAndTrust]  -- sigs on main key
+                       (Map.Map String ([SigAndTrust],OriginMap))  -- uids
+                       (Map.Map KeyKey SubKey)    -- subkeys
+
+type KeyDB = Map.Map KeyKey KeyData
+
+origin :: Packet -> Int -> OriginFlags
+origin p n = OriginFlags ispub n
+ where
+    ispub = case p of
+                    SecretKeyPacket {} -> False
+                    _                  -> True
+
+mappedPacket filename p = MappedPacket 
+    { packet = p
+    , usage_tag = Nothing
+    , locations = Map.singleton filename (origin p (-1))
+    }
+
+keykey key =
+    -- Note: The key's timestamp is included in it's fingerprint.
+    --       Therefore, the same key with a different timestamp is
+    --       considered distinct using this keykey implementation.
+    fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
+
+uidkey (UserIDPacket str) = str
+
+merge :: KeyDB -> FilePath -> Message -> KeyDB
+merge db filename (Message ps) = merge_ db filename qs
+ where
+    qs = scanPackets filename ps
+
+    scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+    scanPackets filename [] = []
+    scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
+     where
+        ret p = (p,Map.empty)
+        doit (top,sub,prev) p =
+            case p of
+                _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
+                _ | isKey p && is_subkey p       -> (top,p,ret p)
+                _ | isUserID p                   -> (top,p,ret p)
+                _ | isTrust p                    -> (top,sub,updateTrust top sub prev p)
+                _ | otherwise                    -> (top,sub,ret p)
+
+        updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
+        updateTrust (PublicKeyPacket {}) _   (pre,t) p = (pre,Map.insert filename p t) -- public
+        updateTrust _                    _   (pre,t) p = (pre,Map.insert filename p t) -- secret
+
+
+
+
+merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+                -> KeyDB
+merge_ db filename qs = foldl mergeit db (zip [0..] qs)
+ where
+    keycomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
+    keycomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
+    keycomp a b | keykey a==keykey b = EQ
+    keycomp a b = error $ unlines ["Unable to merge keys:"
+                                  , fingerprint a
+                                  , PP.ppShow a
+                                  , fingerprint b
+                                  , PP.ppShow b
+                                  ]
+
+    asMapped n p = let m = mappedPacket filename p
+                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
+    asSigAndTrust n (p,tm) = (asMapped n p,tm)
+    emptyUids = Map.empty
+    -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
+    mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
+    mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
+     where
+        -- NOTE:
+        --  if a keyring file has both a public key packet and a secret key packet
+        --  for the same key, then only one of them will survive, which ever is 
+        --  later in the file.
+        -- 
+        --  This is due to the use of statements like 
+        --      (Map.insert filename (origin p n) (locations key))
+        --
+        update v | isKey p && not (is_subkey p)
+          = case v of
+             Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
+             Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
+                     -> Just $ KeyData ( (asMapped n (minimumBy keycomp [packet key,p]))
+                                          { locations = Map.insert filename (origin p n) (locations key) } )
+                                       sigs
+                                       uids
+                                       subkeys
+             _       -> error . concat $ ["Unexpected master key merge error: "
+                                         ,show (fingerprint top, fingerprint p)]
+        update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
+          = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
+        update (Just (KeyData key sigs uids subkeys)) | isUserID p
+          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
+                                    subkeys
+        update (Just (KeyData key sigs uids subkeys))
+          = case sub of
+             MarkerPacket    -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
+             UserIDPacket {} -> Just $ KeyData key
+                                               sigs
+                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
+                                               subkeys
+             _  | isKey sub  -> Just $ KeyData key
+                                               sigs
+                                               uids
+                                               (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
+             _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
+        update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
+
+    mergeit _  (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
+
+    mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
+    mergeSubkey n p Nothing                  = Just $ SubKey (asMapped n p) []
+    mergeSubkey n p (Just (SubKey key sigs)) = Just $
+        SubKey ((asMapped n (minimumBy subcomp [packet key,p]))
+                 { locations = Map.insert filename (origin p n) (locations key) })
+               sigs
+     where
+        -- Compare master keys, LT is prefered for merging
+        -- Compare subkeys, LT is prefered for merging
+        subcomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
+        subcomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
+        subcomp a b | keykey a==keykey b = EQ
+        subcomp a b = error $ unlines ["Unable to merge subs:"
+                                      , fingerprint a
+                                      , PP.ppShow a
+                                      , fingerprint b
+                                      , PP.ppShow b
+                                      ]
+        subcomp_m a b = subcomp (packet a) (packet b)
+
+    mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
+    mergeUid n (UserIDPacket s,_) Nothing         = Just ([],Map.singleton filename (origin MarkerPacket n))
+    mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
+    mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
+
+    whatP (a,_) = concat . take 1 . words . show $ a
+
+
+    mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
+    mergeSig n sig sigs =
+      let (xs,ys) = break (isSameSig sig) sigs
+      in if null ys
+          then sigs++[first (asMapped n) sig]
+          else let y:ys'=ys
+               in xs ++ (mergeSameSig n sig y : ys')
+
+
+    isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
+        a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
+    isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
+
+    mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
+    mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket a && isSignaturePacket b =
+       ( m { packet = (b { unhashed_subpackets =
+                            foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) })
+           , locations = Map.insert filename (origin a n) locs }
+        , tb `Map.union` ta )
+
+     where
+        -- TODO: when merging items, we should delete invalidated origins
+        -- from the orgin map.
+        mergeItem ys x = if x `elem` ys then ys else ys++[x]
+
+    mergeSameSig n a b = b -- trace ("discarding dup "++show a) b
+
+    mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
+    mergeUidSig n sig Nothing     = Just ([asSigAndTrust n sig],Map.empty)
+
+    mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
+    mergeSubSig n sig Nothing = error $
+        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
+
diff --git a/kiki.hs b/kiki.hs
index 217f70f..47d9bdb 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -328,22 +328,12 @@ writePEM typ dta = pem
 
     -- 64 byte lines
 
-isKey (PublicKeyPacket {}) = True
-isKey (SecretKeyPacket {}) = True
-isKey _                    = False
-
-isUserID (UserIDPacket {}) = True
-isUserID _                 = False
-
 isEmbeddedSignature (EmbeddedSignaturePacket {}) = True
 isEmbeddedSignature _                            = False
 
 isCertificationSig (CertificationSignature {}) = True
 isCertificationSig _                           = True
 
-isTrust (TrustPacket {}) = True
-isTrust _                = False
-
 issuer (IssuerPacket issuer) = Just issuer
 issuer _                     = Nothing
 backsig (EmbeddedSignaturePacket s) = Just s
@@ -1008,203 +998,8 @@ is40digitHex xs = ys == xs && length ys==40
             | 'a' <= c && c <= 'f' = True
     ishex c = False
 
-scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
-scanPackets filename [] = []
-scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
- where
-    ret p = (p,Map.empty)
-    doit (top,sub,prev) p =
-        case p of
-            _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
-            _ | isKey p && is_subkey p       -> (top,p,ret p)
-            _ | isUserID p                   -> (top,p,ret p)
-            _ | isTrust p                    -> (top,sub,updateTrust top sub prev p)
-            _ | otherwise                    -> (top,sub,ret p)
-
-    updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
-    updateTrust (PublicKeyPacket {}) _   (pre,t) p = (pre,Map.insert filename p t) -- public
-    updateTrust _                    _   (pre,t) p = (pre,Map.insert filename p t) -- secret
-
-
-data OriginFlags = OriginFlags {
-        originallyPublic :: Bool,
-        originalNum :: Int
-    }
-    deriving Show
-origin :: Packet -> Int -> OriginFlags
-origin p n = OriginFlags ispub n
- where
-    ispub = case p of
-                    SecretKeyPacket {} -> False
-                    _                  -> True
-
-type OriginMap = Map.Map FilePath OriginFlags
-data MappedPacket = MappedPacket
-        { packet :: Packet
-        , usage_tag :: Maybe String
-        , locations :: OriginMap
-        }
-
-mappedPacket filename p = MappedPacket 
-    { packet = p
-    , usage_tag = Nothing
-    , locations = Map.singleton filename (origin p (-1))
-    }
-
-type TrustMap = Map.Map FilePath Packet
-type SigAndTrust = ( MappedPacket
-                   , TrustMap     ) -- trust packets
-
-type KeyKey = [Char8.ByteString]
-data SubKey = SubKey MappedPacket [SigAndTrust]
-data KeyData = KeyData MappedPacket    -- main key
-                       [SigAndTrust]  -- sigs on main key
-                       (Map.Map String ([SigAndTrust],OriginMap))  -- uids
-                       (Map.Map KeyKey SubKey)    -- subkeys
-
-type KeyDB = Map.Map KeyKey KeyData
-
 torhash key = maybe "" id $ derToBase32 <$> derRSA key
 
-keykey key =
-    -- Note: The key's timestamp is included in it's fingerprint.
-    --       Therefore, the same key with a different timestamp is
-    --       considered distinct using this keykey implementation.
-    fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
-
-
-
-uidkey (UserIDPacket str) = str
-
--- Compare master keys, LT is prefered for merging
-keycomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
-keycomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
-keycomp a b | keykey a==keykey b = EQ
-keycomp a b = error $ unlines ["Unable to merge keys:"
-                              , fingerprint a
-                              , PP.ppShow a
-                              , fingerprint b
-                              , PP.ppShow b
-                              ]
-
--- Compare subkeys, LT is prefered for merging
-subcomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
-subcomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
-subcomp a b | keykey a==keykey b = EQ
-subcomp a b = error $ unlines ["Unable to merge subs:"
-                              , fingerprint a
-                              , PP.ppShow a
-                              , fingerprint b
-                              , PP.ppShow b
-                              ]
-subcomp_m a b = subcomp (packet a) (packet b)
-
-merge :: KeyDB -> FilePath -> Message -> KeyDB
-merge db filename (Message ps) = merge_ db filename qs
- where
-    qs = scanPackets filename ps
-
-merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
-                -> KeyDB
-merge_ db filename qs = foldl mergeit db (zip [0..] qs)
- where
-    asMapped n p = let m = mappedPacket filename p
-                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
-    asSigAndTrust n (p,tm) = (asMapped n p,tm)
-    emptyUids = Map.empty
-    -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
-    mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
-    mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
-     where
-        -- NOTE:
-        --  if a keyring file has both a public key packet and a secret key packet
-        --  for the same key, then only one of them will survive, which ever is 
-        --  later in the file.
-        -- 
-        --  This is due to the use of statements like 
-        --      (Map.insert filename (origin p n) (locations key))
-        --
-        update v | isKey p && not (is_subkey p)
-          = case v of
-             Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
-             Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
-                     -> Just $ KeyData ( (asMapped n (minimumBy keycomp [packet key,p]))
-                                          { locations = Map.insert filename (origin p n) (locations key) } )
-                                       sigs
-                                       uids
-                                       subkeys
-             _       -> error . concat $ ["Unexpected master key merge error: "
-                                         ,show (fingerprint top, fingerprint p)]
-        update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
-          = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
-        update (Just (KeyData key sigs uids subkeys)) | isUserID p
-          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
-                                    subkeys
-        update (Just (KeyData key sigs uids subkeys))
-          = case sub of
-             MarkerPacket    -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
-             UserIDPacket {} -> Just $ KeyData key
-                                               sigs
-                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
-                                               subkeys
-             _  | isKey sub  -> Just $ KeyData key
-                                               sigs
-                                               uids
-                                               (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
-             _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
-        update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
-
-    mergeit _  (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
-
-    mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
-    mergeSubkey n p Nothing                  = Just $ SubKey (asMapped n p) []
-    mergeSubkey n p (Just (SubKey key sigs)) = Just $
-        SubKey ((asMapped n (minimumBy subcomp [packet key,p]))
-                 { locations = Map.insert filename (origin p n) (locations key) })
-               sigs
-
-    mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
-    mergeUid n (UserIDPacket s,_) Nothing         = Just ([],Map.singleton filename (origin MarkerPacket n))
-    mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
-    mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
-
-    whatP (a,_) = concat . take 1 . words . show $ a
-
-
-    mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
-    mergeSig n sig sigs =
-      let (xs,ys) = break (isSameSig sig) sigs
-      in if null ys
-          then sigs++[first (asMapped n) sig]
-          else let y:ys'=ys
-               in xs ++ (mergeSameSig n sig y : ys')
-
-
-    isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
-        a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
-    isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
-
-    mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
-    mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket a && isSignaturePacket b =
-       ( m { packet = (b { unhashed_subpackets =
-                            foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) })
-           , locations = Map.insert filename (origin a n) locs }
-        , tb `Map.union` ta )
-
-     where
-        -- TODO: when merging items, we should delete invalidated origins
-        -- from the orgin map.
-        mergeItem ys x = if x `elem` ys then ys else ys++[x]
-
-    mergeSameSig n a b = trace ("discarding dup "++show a) b
-
-    mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
-    mergeUidSig n sig Nothing     = Just ([asSigAndTrust n sig],Map.empty)
-
-    mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
-    mergeSubSig n sig Nothing = error $
-        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
-
 flattenKeys :: Bool -> KeyDB -> Message
 flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
  where