summaryrefslogtreecommitdiff
path: root/lib/KeyDB.hs
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-07-13 21:18:22 -0400
committerJoe Crayne <joe@jerkface.net>2019-07-13 21:18:22 -0400
commit3f29bdc88a068ec3eab91a8bac12757e3a106ceb (patch)
tree09507dcfed5524694a2280fd11fb607023f7ce8b /lib/KeyDB.hs
parentcc6775a52107f5425d668a4831f475d05dc113b5 (diff)
Finished encapsulation of KeyDB.
Diffstat (limited to 'lib/KeyDB.hs')
-rw-r--r--lib/KeyDB.hs110
1 files changed, 107 insertions, 3 deletions
diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs
index f5a4357..1f0849c 100644
--- a/lib/KeyDB.hs
+++ b/lib/KeyDB.hs
@@ -1,5 +1,4 @@
1module KeyDB 1module KeyDB
2 {-
3 ( TrustMap 2 ( TrustMap
4 , SigAndTrust 3 , SigAndTrust
5 , SubKey(..) 4 , SubKey(..)
@@ -7,15 +6,31 @@ module KeyDB
7 , KeyDB 6 , KeyDB
8 , emptyKeyDB 7 , emptyKeyDB
9 , keyData 8 , keyData
9 , kkData
10 , lookupKeyData
10 , transmute 11 , transmute
11 ) -} where 12 , transmuteAt
13 , alterKeyDB
14 , mergeKeyDB
15 , mapKeyDB
16 -- These probably don't belong here
17 , selectKey0
18 , flattenTop
19 , flattenAllUids
20 , flattenSub
21 , sortByHint
22 , flattenKeys
23 , flattenFiltered
24 ) where
12 25
13import Control.Monad 26import Control.Monad
14import Data.Functor 27import Data.Functor
28import Data.List
15import qualified Data.Map.Strict as Map 29import qualified Data.Map.Strict as Map
30import Data.Maybe
16import Data.OpenPGP 31import Data.OpenPGP
32import Data.Ord
17 33
18import FunctorToMaybe
19import KeyRing.Types 34import KeyRing.Types
20 35
21type TrustMap = Map.Map FilePath Packet 36type TrustMap = Map.Map FilePath Packet
@@ -43,6 +58,11 @@ emptyKeyDB = KeyDB { byKeyKey = Map.empty }
43keyData :: KeyDB -> [KeyData] 58keyData :: KeyDB -> [KeyData]
44keyData db = Map.elems (byKeyKey db) 59keyData db = Map.elems (byKeyKey db)
45 60
61kkData :: KeyDB -> [(KeyKey, KeyData)]
62kkData db = Map.toList (byKeyKey db)
63
64lookupKeyData :: KeyKey -> KeyDB -> Maybe KeyData
65lookupKeyData kk db = Map.lookup kk (byKeyKey db)
46 66
47transmute :: (Monad m, Monad kiki, Traversable kiki) => 67transmute :: (Monad m, Monad kiki, Traversable kiki) =>
48 ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter 68 ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter
@@ -56,3 +76,87 @@ transmute perform update db = do
56 r <- sequenceA <$> mapM performAll (byKeyKey db) 76 r <- sequenceA <$> mapM performAll (byKeyKey db)
57 return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk } 77 return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk }
58 , concatMap snd $ Map.elems bkk ) 78 , concatMap snd $ Map.elems bkk )
79
80alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB
81alterKeyDB update kk db = db { byKeyKey = Map.alter update kk (byKeyKey db) }
82
83transmuteAt :: ( Monad m
84 , Functor kiki
85 ) => (Maybe KeyData -> m (kiki (KeyData,[info]))) -> KeyKey -> KeyDB -> m (kiki (KeyDB,[info]))
86transmuteAt go kk db = do
87 kdr <- go (Map.lookup kk $ byKeyKey db)
88 return $ kdr <&> \(kd',rrs) -> ( alterKeyDB (const $ Just kd') kk db
89 , rrs )
90
91mergeKeyDB :: (KeyData -> KeyData -> KeyData) -> KeyDB -> KeyDB -> KeyDB
92mergeKeyDB mergeKeyData db dbtrans =
93 KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) }
94
95mapKeyDB :: Monad m => (KeyData -> m KeyData) -> KeyDB -> m KeyDB
96mapKeyDB f db = fmap (\m -> db { byKeyKey = m }) $ mapM f (byKeyKey db)
97
98selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
99selectKey0 wantPublic (spec,mtag) db = do
100 let Message ps = flattenKeys wantPublic $ byKeyKey db
101 ys = snd $ seek_key spec ps
102 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
103 case ys of
104 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
105 [] -> Nothing
106
107
108flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message
109flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd)
110 (prefilter . Map.assocs $ db)
111 where
112 prefilter = if isPublic then id else filter isSecret
113 where
114 isSecret (_,(KeyData
115 (MappedPacket { packet=(SecretKeyPacket {})})
116 _
117 _
118 _)) = True
119 isSecret _ = False
120
121flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
122flattenUid fname ispub (str,(sigs,om)) =
123 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
124
125flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
126flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
127
128flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
129flattenAllUids fname ispub uids =
130 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
131
132flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
133flattenTop fname ispub (KeyData key sigs uids subkeys) =
134 unk ispub key :
135 ( flattenAllUids fname ispub uids
136 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
137
138sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
139sortByHint fname f = sortBy (comparing gethint)
140 where
141 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
142 defnum = -1
143
144concatSort ::
145 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
146concatSort fname getp f = concat . sortByHint fname getp . map f
147
148unk :: Bool -> MappedPacket -> MappedPacket
149unk isPublic = if isPublic then toPacket secretToPublic else id
150 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
151
152
153unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
154unsig fname isPublic (sig,trustmap) =
155 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
156 where
157 f n _ = n==fname -- && trace ("fname=n="++show n) True
158 asMapped n p = let m = mappedPacket fname p
159 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
160
161flattenFiltered :: Bool -> (KeyData -> Bool) -> KeyDB -> Message
162flattenFiltered wantPublic pred db = flattenKeys wantPublic $ Map.filter pred (byKeyKey db)