From 80cd56e64d6c506d9ede50ac357ceec47df8393e Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 16 Apr 2014 03:43:49 -0400 Subject: fixes related to creating key files via external commands --- KeyRing.hs | 166 +++++++++++++++++++++++++++++++++++++++++++++++-------------- kiki.hs | 67 ------------------------- 2 files changed, 130 insertions(+), 103 deletions(-) diff --git a/KeyRing.hs b/KeyRing.hs index 8cd4bcb..c595d77 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -529,6 +529,70 @@ parseSpec grip spec = (topspec,subspec) filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] filterMatches spec ks = filter (matchSpec spec) ks +selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet +selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db + +selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet +selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db + +selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet +selectKey0 wantPublic (spec,mtag) db = do + let Message ps = flattenKeys wantPublic db + ys = snd $ seek_key spec ps + flip (maybe (listToMaybe ys)) mtag $ \tag -> do + let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys + zs = snd $ seek_key subspec ys1 + listToMaybe zs + +seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) +seek_key (KeyGrip grip) sec = (pre, subs) + where + (pre,subs) = break pred sec + pred p@(SecretKeyPacket {}) = matchpr grip p == grip + pred p@(PublicKeyPacket {}) = matchpr grip p == grip + pred _ = False + +seek_key (KeyTag key tag) ps = if null bs + then (ps,[]) + else if null qs + then let (as',bs') = seek_key (KeyTag key tag) (tail bs) + in (as ++ (head bs:as'), bs') + else (reverse (tail qs), head qs : reverse rs ++ bs) + where + (as,bs) = break (\p -> isSignaturePacket p + && has_tag tag p + && isJust (signature_issuer p) + && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) + ps + (rs,qs) = break isKey (reverse as) + + has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) + || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) + +seek_key (KeyUidMatch pat) ps = if null bs + then (ps,[]) + else if null qs + then let (as',bs') = seek_key (KeyUidMatch pat) (tail bs) + in (as ++ (head bs:as'), bs') + else (reverse (tail qs), head qs : reverse rs ++ bs) + where + (as,bs) = break (isInfixOf pat . uidStr) + ps + (rs,qs) = break isKey (reverse as) + + uidStr (UserIDPacket s) = s + uidStr _ = "" + + +importPEMKey db' tup = do + try db' $ \(db',report0) -> do + r <- doImport doDecrypt + db' + tup + try r $ \(db'',report) -> do + return $ KikiSuccess (db'', report0 ++ report) + where doDecrypt = todo + buildKeyDB :: FilePath -> FilePath -> Maybe String -> KeyRingData -> IO (KikiCondition ((KeyDB,Maybe String,Maybe Packet),[(FilePath,KikiReportAction)])) @@ -559,14 +623,6 @@ buildKeyDB secring pubring grip0 keyring = do try r $ \(db'',report) -> do return $ KikiSuccess (db'', report0 ++ report) - importPEMKey db' tup = do - try db' $ \(db',report0) -> do - r <- doImport doDecrypt - db' - tup - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) - doDecrypt = todo -- KeyRings (todo: KikiCondition reporting?) @@ -929,46 +985,71 @@ runKeyRing keyring = do if not $ null failed_locks then return $ KikiResult (FailedToLock failed_locks) [] else do + + let doDecrypt = todo + + -- merge all keyrings, PEM files, and wallets + bresult <- buildKeyDB secring pubring grip0 keyring + + try' bresult $ \((db,grip,wk),report_imports) -> do + + nonexistents <- + filterM (fmap not . doesFileExist . fst) + $ do (f,t) <- Map.toList (kFiles keyring) + f <- resolveInputFile secring pubring f + return (f,t) + + -- create nonexistent files via external commands - report_externals <- do + externals_ret <- do let cmds = do - (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring) + (fname,(rtyp,ftyp)) <- nonexistents cmd <- maybeToList (initializer rtyp) - (_,subspec) <- fmap (parseSpec "") $ getUsage ftyp - fname <- resolveInputFile secring pubring f - return (fname,maybe "" id subspec,cmd) - forM cmds $ \(fname,usage,cmd) -> do + (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip) + $ getUsage ftyp + let ms = map fst $ filterMatches topspec (Map.toList db) + guard $ isNothing $ selectPublicKey (topspec,subspec) db + return (fname,subspec,ms,cmd) + rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do e <- systemEnv [ ("file",fname) - , ("usage",usage) ] + , ("usage",maybe "" id subspec) ] cmd case e of - ExitFailure num -> return (fname,FailedExternal num) - ExitSuccess -> return (fname,ExternallyGeneratedFile) + ExitFailure num -> return (tup,FailedExternal num) + ExitSuccess -> return (tup,ExternallyGeneratedFile) - -- merge all keyrings, PEM files, and wallets - bresult <- buildKeyDB secring pubring grip0 keyring + v <- foldM importPEMKey (KikiSuccess (db,[])) $ do + (tup,r) <- rs + guard $ case r of + ExternallyGeneratedFile -> True + _ -> False + return tup - try' bresult $ \((db,grip,wk),report_imports) -> do - let a = KeyRingRuntime - { rtPubring = pubring - , rtSecring = secring - , rtGrip = grip - , rtKeyDB = db - } + try v $ \(db,import_rs) -> do + return $ KikiSuccess (db, map (\((f,_,_,_),r)->(f,r)) rs + ++ import_rs) - r <- writeWalletKeys keyring db wk - try' r $ \report_wallets -> do + try' externals_ret $ \(db,report_externals) -> do - r <- writeRingKeys keyring db wk secring pubring - try' r $ \report_rings -> do + r <- writeWalletKeys keyring db wk + try' r $ \report_wallets -> do - -- todo writePEMKeys + r <- writeRingKeys keyring db wk secring pubring + try' r $ \report_rings -> do - return $ KikiResult (KikiSuccess a) - $ concat [ report_externals - , report_imports - , report_wallets - , report_rings ] + -- todo writePEMKeys + + let rt = KeyRingRuntime + { rtPubring = pubring + , rtSecring = secring + , rtGrip = grip + , rtKeyDB = db + } + return $ KikiResult (KikiSuccess rt) + $ concat [ report_imports + , report_externals + , report_wallets + , report_rings ] forM_ lked $ \(Just lk, fname) -> dotlock_release lk @@ -1524,6 +1605,19 @@ sortByHint fname f = sortBy (comparing gethint) gethint = maybe defnum originalNum . Map.lookup fname . locations . f defnum = -1 +flattenKeys :: Bool -> KeyDB -> Message +flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) + where + prefilter = if isPublic then id else filter isSecret + where + isSecret (_,(KeyData + (MappedPacket { packet=(SecretKeyPacket {})}) + _ + _ + _)) = True + isSecret _ = False + + flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] flattenTop fname ispub (KeyData key sigs uids subkeys) = unk ispub key : diff --git a/kiki.hs b/kiki.hs index 1c6fa37..43d170c 100644 --- a/kiki.hs +++ b/kiki.hs @@ -650,19 +650,6 @@ getPassphrase cmd = #define HOMEOPTION (def &= explicit &= name "homedir" &= typDir ) -flattenKeys :: Bool -> KeyDB -> Message -flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) - where - prefilter = if isPublic then id else filter isSecret - where - isSecret (_,(KeyData - (MappedPacket { packet=(SecretKeyPacket {})}) - _ - _ - _)) = True - isSecret _ = False - - writeOutKeyrings :: Map.Map FilePath t -> KeyDB -> IO () writeOutKeyrings lkmap db = do let ks = Map.elems db @@ -1704,60 +1691,6 @@ isTopKey p@(SecretKeyPacket {}) | not (is_subkey p) = True isTopKey p@(PublicKeyPacket {}) | not (is_subkey p) = True isTopKey _ = False -selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db - -selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db - -selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectKey0 wantPublic (spec,mtag) db = do - let Message ps = flattenKeys wantPublic db - ys = snd $ seek_key spec ps - flip (maybe (listToMaybe ys)) mtag $ \tag -> do - let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys - zs = snd $ seek_key subspec ys1 - listToMaybe zs - -seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) -seek_key (KeyGrip grip) sec = (pre, subs) - where - (pre,subs) = break pred sec - pred p@(SecretKeyPacket {}) = matchpr grip p == grip - pred p@(PublicKeyPacket {}) = matchpr grip p == grip - pred _ = False - -seek_key (KeyTag key tag) ps = if null bs - then (ps,[]) - else if null qs - then let (as',bs') = seek_key (KeyTag key tag) (tail bs) - in (as ++ (head bs:as'), bs') - else (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (\p -> isSignaturePacket p - && has_tag tag p - && isJust (signature_issuer p) - && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) - ps - (rs,qs) = break isKey (reverse as) - - has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) - || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) - -seek_key (KeyUidMatch pat) ps = if null bs - then (ps,[]) - else if null qs - then let (as',bs') = seek_key (KeyUidMatch pat) (tail bs) - in (as ++ (head bs:as'), bs') - else (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (isInfixOf pat . uidStr) - ps - (rs,qs) = break isKey (reverse as) - - uidStr (UserIDPacket s) = s - uidStr _ = "" - groupTops ps = groupBy (\_ b -> not (isTopKey b)) ps -- cgit v1.2.3