diff options
Diffstat (limited to 'lib/Transforms.hs')
-rw-r--r-- | lib/Transforms.hs | 47 |
1 files changed, 11 insertions, 36 deletions
diff --git a/lib/Transforms.hs b/lib/Transforms.hs index 3e13b1a..0a3a9a6 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs | |||
@@ -9,12 +9,14 @@ import Control.Applicative | |||
9 | import Control.Arrow | 9 | import Control.Arrow |
10 | import Control.Monad | 10 | import Control.Monad |
11 | import Data.Char | 11 | import Data.Char |
12 | import Data.Functor | ||
12 | import Data.List | 13 | import Data.List |
13 | import Data.Maybe | 14 | import Data.Maybe |
14 | import Data.Ord | 15 | import Data.Ord |
15 | import Data.OpenPGP | 16 | import Data.OpenPGP |
16 | import Data.OpenPGP.Util | 17 | import Data.OpenPGP.Util |
17 | import Data.Word | 18 | import Data.Word |
19 | import KeyDB | ||
18 | import KeyRing.Types | 20 | import KeyRing.Types |
19 | import FunctorToMaybe | 21 | import FunctorToMaybe |
20 | import GnuPGAgent ( key_nbits ) | 22 | import GnuPGAgent ( key_nbits ) |
@@ -38,27 +40,6 @@ import qualified Data.Text as T ( Text, unpack, pack, | |||
38 | import Data.Text.Encoding ( encodeUtf8 ) | 40 | import Data.Text.Encoding ( encodeUtf8 ) |
39 | import Data.Bits ((.|.), (.&.), Bits) | 41 | import Data.Bits ((.|.), (.&.), Bits) |
40 | 42 | ||
41 | type TrustMap = Map.Map FilePath Packet | ||
42 | type SigAndTrust = ( MappedPacket | ||
43 | , TrustMap ) -- trust packets | ||
44 | data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show | ||
45 | |||
46 | -- | This is a GPG Identity which includes a master key and all its UIDs and | ||
47 | -- subkeys and associated signatures. | ||
48 | data KeyData = KeyData | ||
49 | { keyMappedPacket :: MappedPacket -- main key | ||
50 | , keySigAndTrusts :: [SigAndTrust] -- sigs on main key | ||
51 | , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids | ||
52 | , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys | ||
53 | } deriving Show | ||
54 | |||
55 | data KeyDB = KeyDB | ||
56 | { byKeyKey :: Map.Map KeyKey KeyData | ||
57 | } deriving Show | ||
58 | |||
59 | emptyKeyDB :: KeyDB | ||
60 | emptyKeyDB = KeyDB { byKeyKey = Map.empty } | ||
61 | |||
62 | 43 | ||
63 | data KeyRingRuntime = KeyRingRuntime | 44 | data KeyRingRuntime = KeyRingRuntime |
64 | { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' | 45 | { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' |
@@ -765,7 +746,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do | |||
765 | 746 | ||
766 | -- TODO: Use fingerprint to narrow candidates. | 747 | -- TODO: Use fingerprint to narrow candidates. |
767 | candidateSignerKeys :: KeyDB -> Packet -> [Packet] | 748 | candidateSignerKeys :: KeyDB -> Packet -> [Packet] |
768 | candidateSignerKeys db sig = map keyPacket $ Map.elems (byKeyKey db) | 749 | candidateSignerKeys db sig = map keyPacket $ keyData db |
769 | 750 | ||
770 | performManipulations :: | 751 | performManipulations :: |
771 | (PacketDecrypter) | 752 | (PacketDecrypter) |
@@ -775,18 +756,14 @@ performManipulations :: | |||
775 | -> IO (KikiCondition (KeyRingRuntime,KikiReport)) | 756 | -> IO (KikiCondition (KeyRingRuntime,KikiReport)) |
776 | performManipulations doDecrypt rt wk manip = do | 757 | performManipulations doDecrypt rt wk manip = do |
777 | let db = rtKeyDB rt | 758 | let db = rtKeyDB rt |
778 | performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd | 759 | r <- transmute perform (manip rt) db |
779 | r <- Traversable.mapM performAll (byKeyKey db) | 760 | return $ r <&> \(db,rs) -> (rt { rtKeyDB = db }, rs) |
780 | try (sequenceA r) $ \db -> do | ||
781 | return $ KikiSuccess ( rt { rtKeyDB = (rtKeyDB rt) { byKeyKey = fmap fst db } } | ||
782 | , concatMap snd $ Map.elems db) | ||
783 | where | 761 | where |
784 | perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) | 762 | perform :: (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) |
785 | perform kd (InducerSignature uid subpaks) = do | 763 | perform (kd,report) (InducerSignature uid subpaks) = do |
786 | try kd $ \(kd,report) -> do | ||
787 | flip (maybe $ return NoWorkingKey) wk $ \wk' -> do | 764 | flip (maybe $ return NoWorkingKey) wk $ \wk' -> do |
788 | wkun' <- doDecrypt wk' | 765 | wkun' <- doDecrypt wk' |
789 | try wkun' $ \wkun -> do | 766 | try wkun' $ \wkun -> do |
790 | let flgs = if keykey (keyPacket kd) == keykey wkun | 767 | let flgs = if keykey (keyPacket kd) == keykey wkun |
791 | then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs) | 768 | then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs) |
792 | else [] | 769 | else [] |
@@ -799,7 +776,7 @@ performManipulations doDecrypt rt wk manip = do | |||
799 | selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard | 776 | selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard |
800 | . (== keykey whosign) | 777 | . (== keykey whosign) |
801 | . keykey)) vs | 778 | . keykey)) vs |
802 | keys = map keyPacket $ Map.elems (byKeyKey $ rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig | 779 | keys = map keyPacket $ keyData (rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig |
803 | overs sig = signatures $ Message (keys ++ [keyPacket kd,UserIDPacket uid,sig]) | 780 | overs sig = signatures $ Message (keys ++ [keyPacket kd,UserIDPacket uid,sig]) |
804 | vs :: [ ( Packet -- signature | 781 | vs :: [ ( Packet -- signature |
805 | , Maybe SignatureOver -- Nothing means non-verified | 782 | , Maybe SignatureOver -- Nothing means non-verified |
@@ -825,8 +802,7 @@ performManipulations doDecrypt rt wk manip = do | |||
825 | -- XXX: Shouldn't this signature generation show up in the KikiReport ? | 802 | -- XXX: Shouldn't this signature generation show up in the KikiReport ? |
826 | return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report ) | 803 | return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report ) |
827 | 804 | ||
828 | perform kd (SubKeyDeletion topk subk) = do | 805 | perform (kd,report) (SubKeyDeletion topk subk) = do |
829 | try kd $ \(kd,report) -> do | ||
830 | let kk = keykey $ packet $ keyMappedPacket kd | 806 | let kk = keykey $ packet $ keyMappedPacket kd |
831 | kd' | kk /= topk = kd | 807 | kd' | kk /= topk = kd |
832 | | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd } | 808 | | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd } |
@@ -839,8 +815,7 @@ performManipulations doDecrypt rt wk manip = do | |||
839 | return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ]) | 815 | return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ]) |
840 | 816 | ||
841 | -- perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) | 817 | -- perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) |
842 | perform kd (SubKeyRenaming srctag dsttag) = do | 818 | perform (kd,report) (SubKeyRenaming srctag dsttag) = do |
843 | try kd $ \(kd,report) -> do | ||
844 | flip (maybe $ return NoWorkingKey) wk $ \wk' -> do | 819 | flip (maybe $ return NoWorkingKey) wk $ \wk' -> do |
845 | subkeys' <- traverse (freshenOne wk') (keySubKeys kd) | 820 | subkeys' <- traverse (freshenOne wk') (keySubKeys kd) |
846 | let _ = subkeys' :: Map.Map KeyKey (KikiCondition (SubKey, KikiReport)) | 821 | let _ = subkeys' :: Map.Map KeyKey (KikiCondition (SubKey, KikiReport)) |