summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-04-15 17:35:11 -0400
committerjoe <joe@jerkface.net>2014-04-15 17:35:11 -0400
commite94ff6c6c0f1157c0dc738f7aedeefabc99cd947 (patch)
tree81b31bc96342a21ec850429649a877f334eb17f6
parent1435653a92cf5db9e861dafc430b7f0d2b64e51a (diff)
more progress on writeRingKeys
-rw-r--r--KeyRing.hs62
-rw-r--r--kiki.hs12
2 files changed, 47 insertions, 27 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index d3c4c24..eda19d1 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -3,6 +3,7 @@
3{-# LANGUAGE ViewPatterns #-} 3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE ExistentialQuantification #-} 4{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE OverloadedStrings #-} 5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE DeriveFunctor #-}
6module KeyRing where 7module KeyRing where
7 8
8import System.Environment 9import System.Environment
@@ -173,13 +174,8 @@ data KikiCondition a = KikiSuccess a
173 | BadPassphrase 174 | BadPassphrase
174 | FailedToMakeSignature 175 | FailedToMakeSignature
175 | CantFindHome 176 | CantFindHome
177 deriving ( Functor, Show )
176 178
177#define TRIVIAL(OP) fmap _ (OP) = OP
178instance Functor KikiCondition where
179 fmap f (KikiSuccess a) = KikiSuccess (f a)
180 TRIVIAL( FailedToLock x )
181 TRIVIAL( BadPassphrase )
182 TRIVIAL( FailedToMakeSignature )
183instance FunctorToMaybe KikiCondition where 179instance FunctorToMaybe KikiCondition where
184 functorToMaybe (KikiSuccess a) = Just a 180 functorToMaybe (KikiSuccess a) = Just a
185 functorToMaybe _ = Nothing 181 functorToMaybe _ = Nothing
@@ -493,11 +489,11 @@ derRSA rsa = do
493 k <- rsaKeyFromPacket rsa 489 k <- rsaKeyFromPacket rsa
494 return $ encodeASN1 DER (toASN1 k []) 490 return $ encodeASN1 DER (toASN1 k [])
495 491
496try :: KikiCondition a -> (a -> IO (KikiCondition b)) -> IO (KikiCondition b) 492try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
497try wkun body = 493try x body =
498 case functorToEither wkun of 494 case functorToEither x of
499 Left e -> return e 495 Left e -> return e
500 Right wkun -> body wkun 496 Right x -> body x
501 497
502doImportG 498doImportG
503 :: Ord k => 499 :: Ord k =>
@@ -648,15 +644,41 @@ writeWalletKeys krd db wk = do
648 report <- foldM writeWallet [] (files isMutableWallet) 644 report <- foldM writeWallet [] (files isMutableWallet)
649 return $ KikiSuccess report 645 return $ KikiSuccess report
650 646
651writeRingKeys :: KeyRingData -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)]) 647ifSecret (SecretKeyPacket {}) t f = t
652writeRingKeys krd db wk = do 648ifSecret _ t f = f
649
650showPacket :: Packet -> String
651showPacket p | isKey p = (if is_subkey p
652 then showPacket0 p
653 else ifSecret p "----Secret-----" "----Public-----")
654 ++ " "++show (key_algorithm p)++" "++fingerprint p
655 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
656 | otherwise = showPacket0 p
657showPacket0 p = concat . take 1 $ words (show p)
658
659
660writeRingKeys :: KeyRingData -> KeyDB -> Maybe Packet
661 -> FilePath -> FilePath
662 -> IO (KikiCondition [(FilePath,KikiReportAction)])
663writeRingKeys krd db wk secring pubring = do
653 let ks = Map.elems db 664 let ks = Map.elems db
665 {-
654 fs = Map.keys (foldr unionfiles Map.empty ks) 666 fs = Map.keys (foldr unionfiles Map.empty ks)
655 where unionfiles (KeyData p _ _ _) m = 667 where unionfiles (KeyData p _ _ _) m =
656 Map.union m (locations p) 668 Map.union m (locations p)
669 -}
670 isring (KeyRingFile {}) = True
671 isring _ = False
672 isMutable (MutableRef {}) = True
673 isMutable _ = False
674 fs = do
675 (f,(rtyp,ftyp)) <- Map.toList (kFiles krd)
676 guard (isring ftyp)
677 n <- resolveInputFile secring pubring f
678 return (n,isMutable rtyp)
657 fromfile f (KeyData p _ _ _) = Map.member f $ locations p 679 fromfile f (KeyData p _ _ _) = Map.member f $ locations p
658 let s = do 680 let s = do
659 f <- fs 681 (f,mutable) <- fs
660 let x = do 682 let x = do
661 d@(KeyData p _ _ _) <- filter (fromfile f) (sortByHint f keyMappedPacket ks) 683 d@(KeyData p _ _ _) <- filter (fromfile f) (sortByHint f keyMappedPacket ks)
662 n <- maybeToList $ Map.lookup f (locations p) 684 n <- maybeToList $ Map.lookup f (locations p)
@@ -667,7 +689,17 @@ writeRingKeys krd db wk = do
667 trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++ 689 trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++
668 ( "CHANGES: " : map ((" "++) . showPacket . packet) changes)) $ do 690 ( "CHANGES: " : map ((" "++) . showPacket . packet) changes)) $ do
669 -} 691 -}
670 return (f,(changes,x)) 692 guard (not $ null changes)
693 return ((f,mutable),(changes,x))
694 let (towrites,report) = (\f -> foldl f ([],[]) s) $
695 \(ws,report) ((f,mutable),(changes,x)) ->
696 if mutable
697 then
698 let rs = flip map changes $ \c -> (f, NewPacket $ showPacket (packet c))
699 in (ws++[(f,x)],report++rs)
700 else
701 let rs = flip map changes $ \c -> (f,MissingPacket (showPacket (packet c)))
702 in (ws,report++rs)
671 todo -- porting from kiki.hs writeOutKeyrings 703 todo -- porting from kiki.hs writeOutKeyrings
672 return $ KikiSuccess [] 704 return $ KikiSuccess []
673 705
@@ -705,7 +737,7 @@ runKeyRing keyring op = do
705 } 737 }
706 r <- writeWalletKeys keyring db wk 738 r <- writeWalletKeys keyring db wk
707 try' r $ \report2 -> do 739 try' r $ \report2 -> do
708 r <- writeRingKeys keyring db wk 740 r <- writeRingKeys keyring db wk secring pubring
709 try' r $ \report3 -> do 741 try' r $ \report3 -> do
710 return $ KikiResult (KikiSuccess a) (report1 ++ report3) 742 return $ KikiResult (KikiSuccess a) (report1 ++ report3)
711 Left err -> return $ KikiResult err [] 743 Left err -> return $ KikiResult err []
diff --git a/kiki.hs b/kiki.hs
index 41e6e6b..66e3e4f 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -766,18 +766,6 @@ flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPubl
766 isSecret _ = False 766 isSecret _ = False
767 767
768 768
769ifSecret (SecretKeyPacket {}) t f = t
770ifSecret _ t f = f
771
772showPacket :: Packet -> String
773showPacket p | isKey p = (if is_subkey p
774 then showPacket0 p
775 else ifSecret p "----Secret-----" "----Public-----")
776 ++ " "++show (key_algorithm p)++" "++fingerprint p
777 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
778 | otherwise = showPacket0 p
779showPacket0 p = concat . take 1 $ words (show p)
780
781writeOutKeyrings :: Map.Map FilePath t -> KeyDB -> IO () 769writeOutKeyrings :: Map.Map FilePath t -> KeyDB -> IO ()
782writeOutKeyrings lkmap db = do 770writeOutKeyrings lkmap db = do
783 let ks = Map.elems db 771 let ks = Map.elems db