diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/KeyDB.hs | 58 | ||||
-rw-r--r-- | lib/KeyRing.hs | 1 | ||||
-rw-r--r-- | lib/KeyRing/BuildKeyDB.hs | 1 | ||||
-rw-r--r-- | lib/KeyRing/Types.hs | 13 | ||||
-rw-r--r-- | lib/Kiki.hs | 1 | ||||
-rw-r--r-- | lib/Transforms.hs | 47 |
6 files changed, 82 insertions, 39 deletions
diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs new file mode 100644 index 0000000..f5a4357 --- /dev/null +++ b/lib/KeyDB.hs | |||
@@ -0,0 +1,58 @@ | |||
1 | module KeyDB | ||
2 | {- | ||
3 | ( TrustMap | ||
4 | , SigAndTrust | ||
5 | , SubKey(..) | ||
6 | , KeyData(..) | ||
7 | , KeyDB | ||
8 | , emptyKeyDB | ||
9 | , keyData | ||
10 | , transmute | ||
11 | ) -} where | ||
12 | |||
13 | import Control.Monad | ||
14 | import Data.Functor | ||
15 | import qualified Data.Map.Strict as Map | ||
16 | import Data.OpenPGP | ||
17 | |||
18 | import FunctorToMaybe | ||
19 | import KeyRing.Types | ||
20 | |||
21 | type TrustMap = Map.Map FilePath Packet | ||
22 | type SigAndTrust = ( MappedPacket | ||
23 | , TrustMap ) -- trust packets | ||
24 | data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show | ||
25 | |||
26 | -- | This is a GPG Identity which includes a master key and all its UIDs and | ||
27 | -- subkeys and associated signatures. | ||
28 | data KeyData = KeyData | ||
29 | { keyMappedPacket :: MappedPacket -- main key | ||
30 | , keySigAndTrusts :: [SigAndTrust] -- sigs on main key | ||
31 | , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids | ||
32 | , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys | ||
33 | } deriving Show | ||
34 | |||
35 | |||
36 | data KeyDB = KeyDB | ||
37 | { byKeyKey :: Map.Map KeyKey KeyData | ||
38 | } deriving Show | ||
39 | |||
40 | emptyKeyDB :: KeyDB | ||
41 | emptyKeyDB = KeyDB { byKeyKey = Map.empty } | ||
42 | |||
43 | keyData :: KeyDB -> [KeyData] | ||
44 | keyData db = Map.elems (byKeyKey db) | ||
45 | |||
46 | |||
47 | transmute :: (Monad m, Monad kiki, Traversable kiki) => | ||
48 | ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter | ||
49 | -> (KeyData -> [opcode]) -- ^ instructions | ||
50 | -> KeyDB -- ^ initial state | ||
51 | -> m (kiki (KeyDB, [info])) | ||
52 | transmute perform update db = do | ||
53 | let performAll kd = foldM (\kkd op -> join <$> mapM (`perform` op) kkd) | ||
54 | (pure (kd,[])) | ||
55 | (update kd) | ||
56 | r <- sequenceA <$> mapM performAll (byKeyKey db) | ||
57 | return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk } | ||
58 | , concatMap snd $ Map.elems bkk ) | ||
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 3b9afd7..1d52dd1 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs | |||
@@ -89,6 +89,7 @@ import KeyRing.BuildKeyDB (Hostnames(..), | |||
89 | usageFromFilter) | 89 | usageFromFilter) |
90 | 90 | ||
91 | import KeyRing.Types | 91 | import KeyRing.Types |
92 | import KeyDB | ||
92 | import PacketTranscoder | 93 | import PacketTranscoder |
93 | import Transforms | 94 | import Transforms |
94 | 95 | ||
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index 943578f..8af8198 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs | |||
@@ -72,6 +72,7 @@ import ScanningParser | |||
72 | import TimeUtil | 72 | import TimeUtil |
73 | 73 | ||
74 | import KeyRing.Types | 74 | import KeyRing.Types |
75 | import KeyDB | ||
75 | import Transforms | 76 | import Transforms |
76 | import PacketTranscoder | 77 | import PacketTranscoder |
77 | import GnuPGAgent | 78 | import GnuPGAgent |
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs index 0797dab..3c1f0a5 100644 --- a/lib/KeyRing/Types.hs +++ b/lib/KeyRing/Types.hs | |||
@@ -1,8 +1,10 @@ | |||
1 | {-# LANGUAGE DeriveFunctor #-} | 1 | {-# LANGUAGE DeriveFunctor #-} |
2 | {-# LANGUAGE PatternSynonyms #-} | 2 | {-# LANGUAGE DeriveTraversable #-} |
3 | {-# LANGUAGE PatternSynonyms #-} | ||
3 | module KeyRing.Types where | 4 | module KeyRing.Types where |
4 | 5 | ||
5 | import Data.Char (isLower,toLower) | 6 | import Data.Char (isLower,toLower) |
7 | import Data.Functor | ||
6 | import Data.List (groupBy,find) | 8 | import Data.List (groupBy,find) |
7 | import Data.Map as Map (Map) | 9 | import Data.Map as Map (Map) |
8 | import qualified Data.Map as Map | 10 | import qualified Data.Map as Map |
@@ -272,7 +274,7 @@ data KikiCondition a = KikiSuccess a | |||
272 | | NoWorkingKey | 274 | | NoWorkingKey |
273 | | AgentConnectionFailure | 275 | | AgentConnectionFailure |
274 | | OperationCanceled | 276 | | OperationCanceled |
275 | deriving ( Functor, Show ) | 277 | deriving ( Functor, Foldable, Traversable, Show ) |
276 | 278 | ||
277 | instance FunctorToMaybe KikiCondition where | 279 | instance FunctorToMaybe KikiCondition where |
278 | functorToMaybe (KikiSuccess a) = Just a | 280 | functorToMaybe (KikiSuccess a) = Just a |
@@ -287,6 +289,11 @@ instance Applicative KikiCondition where | |||
287 | Left err -> err | 289 | Left err -> err |
288 | Left err -> err | 290 | Left err -> err |
289 | 291 | ||
292 | instance Monad KikiCondition where | ||
293 | return = pure | ||
294 | KikiSuccess a >>= f = f a | ||
295 | kikiCondition >>= f = kikiCondition <&> error (show (const () <$> kikiCondition) ++ " >>= f") | ||
296 | |||
290 | uncamel :: String -> String | 297 | uncamel :: String -> String |
291 | uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args | 298 | uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args |
292 | where | 299 | where |
diff --git a/lib/Kiki.hs b/lib/Kiki.hs index 579640a..e5c4eb4 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs | |||
@@ -48,6 +48,7 @@ import CommandLine | |||
48 | import DotLock | 48 | import DotLock |
49 | import GnuPGAgent (Query (..)) | 49 | import GnuPGAgent (Query (..)) |
50 | import KeyRing hiding (pemFromPacket) | 50 | import KeyRing hiding (pemFromPacket) |
51 | import KeyDB | ||
51 | 52 | ||
52 | withAgent :: [PassphraseSpec] -> [PassphraseSpec] | 53 | withAgent :: [PassphraseSpec] -> [PassphraseSpec] |
53 | withAgent [] = [PassphraseAgent] | 54 | withAgent [] = [PassphraseAgent] |
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)) |