From 1a61b1e32ba8931e7919642376198f813c962a77 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 9 Nov 2013 18:58:23 -0500 Subject: Merging functionality (mergesecrets command) --- kiki.hs | 190 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 189 insertions(+), 1 deletion(-) diff --git a/kiki.hs b/kiki.hs index 33f8428..b55510f 100644 --- a/kiki.hs +++ b/kiki.hs @@ -44,7 +44,7 @@ import System.Exit import ControlMaybe import Data.Char import Control.Arrow (second) -import Data.Traversable +import Data.Traversable hiding (mapM) import System.Console.CmdArgs -- import System.Posix.Time import Data.Time.Clock.POSIX @@ -52,6 +52,7 @@ import System.Posix.IO (fdToHandle,fdRead) import System.Posix.Files import Data.Monoid ((<>)) -- import Data.X509 +import qualified Data.Map as Map unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) where p = break (==c) spec @@ -773,6 +774,12 @@ data Arguments = , seckey :: String } | CatPub { homedir :: Maybe FilePath , catpub_args :: [String] } + | MergeSecrets + { homedir :: Maybe FilePath + , files :: [FilePath] + } + | DumpPackets { homedir :: Maybe FilePath + , marshal_test :: String } {- | Decrypt { homedir :: Maybe FilePath , passphrase_fd :: Maybe Int @@ -802,6 +809,160 @@ is40digitHex xs = ys == xs && length ys==40 | 'a' <= c && c <= 'f' = True ishex c = False +scanPackets [] = [] +scanPackets (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,MarkerPacket) p) ps + where + doit (top,sub,_) p = + case p of + _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,p) + _ | isKey p && is_subkey p -> (top,p,p) + _ | isUserID p -> (top,p,p) + _ | otherwise -> (top,sub,p) + + + +type KeyKey = [Char8.ByteString] +data SubKey = SubKey Packet [Packet] +data KeyData = KeyData Packet -- main key + [Packet] -- sigs on main key + (Map.Map String [Packet]) -- uids + (Map.Map KeyKey SubKey) -- subkeys + +type KeyDB = Map.Map KeyKey KeyData + +keykey key = fingerprint_material key -- 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 | a==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 | a==b = EQ +subcomp a b = error $ unlines ["Unable to merge subs:" + , fingerprint a + , PP.ppShow a + , fingerprint b + , PP.ppShow b + ] + +merge :: Map.Map KeyKey KeyData -> Message -> Map.Map KeyKey KeyData +merge db (Message ps) = foldl mergeit db qs + where + qs = scanPackets ps + mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets + mergeit db (top,sub,p) | isKey top = Map.alter update (keykey top) db + where + update v | isKey p && not (is_subkey p) + = case v of + Nothing -> Just $ KeyData p [] Map.empty Map.empty + Just (KeyData key sigs uids subkeys) | keykey key == keykey p + -> Just $ KeyData (minimumBy keycomp [key,p]) 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 p) (keykey p) subkeys) + update (Just (KeyData key sigs uids subkeys)) | isUserID p + = Just $ KeyData key sigs (Map.alter (mergeUid p) (uidkey p) uids) subkeys + update (Just (KeyData key sigs uids subkeys)) + = case sub of + MarkerPacket -> Just $ KeyData key (mergeSig p sigs) uids subkeys + UserIDPacket {} -> Just $ KeyData key + sigs + (Map.alter (mergeUidSig p) (uidkey sub) uids) + subkeys + _ | isKey sub -> Just $ KeyData key + sigs + uids + (Map.alter (mergeSubSig p) (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 p Nothing = Just $ SubKey p [] + mergeSubkey p (Just (SubKey key sigs)) = Just $ + SubKey (minimumBy subcomp [key,p]) sigs + + mergeUid (UserIDPacket s) Nothing = Just [] + mergeUid (UserIDPacket s) (Just sigs) = Just sigs + mergeUid p _ = error $ "Unable to merge into UID record: " ++whatP p + + whatP = concat . take 1 . words . show + + + mergeSig sig sigs = + let (xs,ys) = break (isSameSig sig) sigs + in if null ys + then sigs++[sig] + else let y:ys'=ys + in xs ++ (mergeSameSig sig y : ys') + + + isSameSig a b | isSignaturePacket a && isSignaturePacket b = + a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } + isSameSig a b = a==b + + mergeSameSig a b | isSignaturePacket a && isSignaturePacket b = + b { unhashed_subpackets = + foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) + } + where + mergeItem ys x = if x `elem` ys then ys else ys++[x] + + mergeSameSig a b = trace ("discarding dup "++show a) b + + mergeUidSig sig (Just sigs) = Just $ mergeSig sig sigs + mergeUidSig sig Nothing = Just [sig] + + mergeSubSig sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig sig sigs) + mergeSubSig sig Nothing = error $ + "Unable to merge subkey signature: "++(words (show sig) >>= take 1) + +flattenKeys :: Map.Map KeyKey KeyData -> Message +flattenKeys db = Message $ concatMap flattenTop (Map.assocs db) + where + flattenTop (_,(KeyData key sigs uids subkeys)) = + key : ( concatMap flattenUid (Map.assocs uids) + ++ concatMap flattenSub (Map.assocs subkeys)) + + flattenUid (str,sigs) = UserIDPacket str : sigs + + flattenSub (_,SubKey key sigs) = key:sigs + +{- +merge db (Message ps) = scanl mergeit db qs + where + qs = scanPackets ps + mergeit db (top,sub,p) = todo + where + k = keykey top + v = maybe (merge1 (newrec top)) (merge2 sub p) $ Map.lookup k db + + keykey key = fingerprint_material key -- TODO: smaller key? + + newrec key | isKey key && not (is_subkey key) = + KeyData key [] Map.empty Map.empty + newrec _ = error "Unexpected packet." + + merge1 rec db = Map.insert k rec db + + merge2 sub p (KeyData mk sigs uids subkeys) + | isKey sub = + maybe todo todo $ Map.lookup skey subkeys + where + skey = keykey sub +-} + main = do args <- cmdArgs $ modes [ List HOMEOPTION @@ -838,6 +999,12 @@ main = do , CatPub HOMEOPTION (def &= args &= typ "KEYSPEC FILES") &= help "Extract a public subkey to stdout." + , MergeSecrets HOMEOPTION + (def &= args &= typFile) + &= help "Merge multiple keyrings to stdout." + , DumpPackets HOMEOPTION + (def &= opt ("n" ::String)) + &= help "Output secret ring packets in ascii format for debugging." , Add HOMEOPTION (def &= opt ("passphrase"::String) &= typ "FD" @@ -1083,6 +1250,27 @@ main = do -} -} + doCmd cmd@(DumpPackets {}) = do + ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome + , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg + , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" + ) <- getPGPEnviron cmd + if map toLower (marshal_test cmd) `elem` ["y","yes"] + then L.putStr $ encode (Message sec) + else putStrLn $ PP.ppShow sec + + doCmd cmd@(MergeSecrets {}) = do + ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome + , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg + , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" + ) <- getPGPEnviron cmd + let db = merge Map.empty (Message sec) + ms <- mapM readPacketsFromFile (files cmd) + let db' = foldl' merge db ms + m = flattenKeys db' + L.putStr (encode m) + return () + doCmd cmd@(CatPub {}) = do let spec:files = catpub_args cmd let (topspec,subspec) = unprefix '/' spec -- cgit v1.2.3