summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/KeyDB.hs58
-rw-r--r--lib/KeyRing.hs1
-rw-r--r--lib/KeyRing/BuildKeyDB.hs1
-rw-r--r--lib/KeyRing/Types.hs13
-rw-r--r--lib/Kiki.hs1
-rw-r--r--lib/Transforms.hs47
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 @@
1module KeyDB
2 {-
3 ( TrustMap
4 , SigAndTrust
5 , SubKey(..)
6 , KeyData(..)
7 , KeyDB
8 , emptyKeyDB
9 , keyData
10 , transmute
11 ) -} where
12
13import Control.Monad
14import Data.Functor
15import qualified Data.Map.Strict as Map
16import Data.OpenPGP
17
18import FunctorToMaybe
19import KeyRing.Types
20
21type TrustMap = Map.Map FilePath Packet
22type SigAndTrust = ( MappedPacket
23 , TrustMap ) -- trust packets
24data 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.
28data 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
36data KeyDB = KeyDB
37 { byKeyKey :: Map.Map KeyKey KeyData
38 } deriving Show
39
40emptyKeyDB :: KeyDB
41emptyKeyDB = KeyDB { byKeyKey = Map.empty }
42
43keyData :: KeyDB -> [KeyData]
44keyData db = Map.elems (byKeyKey db)
45
46
47transmute :: (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]))
52transmute 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
91import KeyRing.Types 91import KeyRing.Types
92import KeyDB
92import PacketTranscoder 93import PacketTranscoder
93import Transforms 94import 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
72import TimeUtil 72import TimeUtil
73 73
74import KeyRing.Types 74import KeyRing.Types
75import KeyDB
75import Transforms 76import Transforms
76import PacketTranscoder 77import PacketTranscoder
77import GnuPGAgent 78import 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 #-}
3module KeyRing.Types where 4module KeyRing.Types where
4 5
5import Data.Char (isLower,toLower) 6import Data.Char (isLower,toLower)
7import Data.Functor
6import Data.List (groupBy,find) 8import Data.List (groupBy,find)
7import Data.Map as Map (Map) 9import Data.Map as Map (Map)
8import qualified Data.Map as Map 10import 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
277instance FunctorToMaybe KikiCondition where 279instance 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
292instance Monad KikiCondition where
293 return = pure
294 KikiSuccess a >>= f = f a
295 kikiCondition >>= f = kikiCondition <&> error (show (const () <$> kikiCondition) ++ " >>= f")
296
290uncamel :: String -> String 297uncamel :: String -> String
291uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args 298uncamel 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
48import DotLock 48import DotLock
49import GnuPGAgent (Query (..)) 49import GnuPGAgent (Query (..))
50import KeyRing hiding (pemFromPacket) 50import KeyRing hiding (pemFromPacket)
51import KeyDB
51 52
52withAgent :: [PassphraseSpec] -> [PassphraseSpec] 53withAgent :: [PassphraseSpec] -> [PassphraseSpec]
53withAgent [] = [PassphraseAgent] 54withAgent [] = [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
9import Control.Arrow 9import Control.Arrow
10import Control.Monad 10import Control.Monad
11import Data.Char 11import Data.Char
12import Data.Functor
12import Data.List 13import Data.List
13import Data.Maybe 14import Data.Maybe
14import Data.Ord 15import Data.Ord
15import Data.OpenPGP 16import Data.OpenPGP
16import Data.OpenPGP.Util 17import Data.OpenPGP.Util
17import Data.Word 18import Data.Word
19import KeyDB
18import KeyRing.Types 20import KeyRing.Types
19import FunctorToMaybe 21import FunctorToMaybe
20import GnuPGAgent ( key_nbits ) 22import GnuPGAgent ( key_nbits )
@@ -38,27 +40,6 @@ import qualified Data.Text as T ( Text, unpack, pack,
38import Data.Text.Encoding ( encodeUtf8 ) 40import Data.Text.Encoding ( encodeUtf8 )
39import Data.Bits ((.|.), (.&.), Bits) 41import Data.Bits ((.|.), (.&.), Bits)
40 42
41type TrustMap = Map.Map FilePath Packet
42type SigAndTrust = ( MappedPacket
43 , TrustMap ) -- trust packets
44data 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.
48data 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
55data KeyDB = KeyDB
56 { byKeyKey :: Map.Map KeyKey KeyData
57 } deriving Show
58
59emptyKeyDB :: KeyDB
60emptyKeyDB = KeyDB { byKeyKey = Map.empty }
61
62 43
63data KeyRingRuntime = KeyRingRuntime 44data 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.
767candidateSignerKeys :: KeyDB -> Packet -> [Packet] 748candidateSignerKeys :: KeyDB -> Packet -> [Packet]
768candidateSignerKeys db sig = map keyPacket $ Map.elems (byKeyKey db) 749candidateSignerKeys db sig = map keyPacket $ keyData db
769 750
770performManipulations :: 751performManipulations ::
771 (PacketDecrypter) 752 (PacketDecrypter)
@@ -775,18 +756,14 @@ performManipulations ::
775 -> IO (KikiCondition (KeyRingRuntime,KikiReport)) 756 -> IO (KikiCondition (KeyRingRuntime,KikiReport))
776performManipulations doDecrypt rt wk manip = do 757performManipulations 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))