1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
module KeyDB
( TrustMap
, SigAndTrust
, SubKey(..)
, KeyData(..)
, KeyDB
, emptyKeyDB
, keyData
, kkData
, lookupKeyData
, transmute
, transmuteAt
, alterKeyDB
, mergeKeyDB
, mapKeyDB
-- These probably don't belong here
, selectKey0
, flattenTop
, flattenAllUids
, flattenSub
, sortByHint
, flattenKeys
, flattenFiltered
) where
import Control.Monad
import Data.Functor
import Data.List
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.OpenPGP
import Data.Ord
import KeyRing.Types
type TrustMap = Map.Map FilePath Packet
type SigAndTrust = ( MappedPacket
, TrustMap ) -- trust packets
data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
-- | This is a GPG Identity which includes a master key and all its UIDs and
-- subkeys and associated signatures.
data KeyData = KeyData
{ keyMappedPacket :: MappedPacket -- main key
, keySigAndTrusts :: [SigAndTrust] -- sigs on main key
, keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids
, keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys
} deriving Show
data KeyDB = KeyDB
{ byKeyKey :: Map.Map KeyKey KeyData
} deriving Show
emptyKeyDB :: KeyDB
emptyKeyDB = KeyDB { byKeyKey = Map.empty }
keyData :: KeyDB -> [KeyData]
keyData db = Map.elems (byKeyKey db)
kkData :: KeyDB -> [(KeyKey, KeyData)]
kkData db = Map.toList (byKeyKey db)
lookupKeyData :: KeyKey -> KeyDB -> Maybe KeyData
lookupKeyData kk db = Map.lookup kk (byKeyKey db)
transmute :: (Monad m, Monad kiki, Traversable kiki) =>
((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter
-> (KeyData -> [opcode]) -- ^ instructions
-> KeyDB -- ^ initial state
-> m (kiki (KeyDB, [info]))
transmute perform update db = do
let performAll kd = foldM (\kkd op -> join <$> mapM (`perform` op) kkd)
(pure (kd,[]))
(update kd)
r <- sequenceA <$> mapM performAll (byKeyKey db)
return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk }
, concatMap snd $ Map.elems bkk )
alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB
alterKeyDB update kk db = db { byKeyKey = Map.alter update kk (byKeyKey db) }
transmuteAt :: ( Monad m
, Functor kiki
) => (Maybe KeyData -> m (kiki (KeyData,[info]))) -> KeyKey -> KeyDB -> m (kiki (KeyDB,[info]))
transmuteAt go kk db = do
kdr <- go (Map.lookup kk $ byKeyKey db)
return $ kdr <&> \(kd',rrs) -> ( alterKeyDB (const $ Just kd') kk db
, rrs )
mergeKeyDB :: (KeyData -> KeyData -> KeyData) -> KeyDB -> KeyDB -> KeyDB
mergeKeyDB mergeKeyData db dbtrans =
KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) }
mapKeyDB :: Monad m => (KeyData -> m KeyData) -> KeyDB -> m KeyDB
mapKeyDB f db = fmap (\m -> db { byKeyKey = m }) $ mapM f (byKeyKey db)
selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
selectKey0 wantPublic (spec,mtag) db = do
let Message ps = flattenKeys wantPublic $ byKeyKey db
ys = snd $ seek_key spec ps
flip (maybe (listToMaybe ys)) mtag $ \tag -> do
case ys of
y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
[] -> Nothing
flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message
flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd)
(prefilter . Map.assocs $ db)
where
prefilter = if isPublic then id else filter isSecret
where
isSecret (_,(KeyData
(MappedPacket { packet=(SecretKeyPacket {})})
_
_
_)) = True
isSecret _ = False
flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
flattenUid fname ispub (str,(sigs,om)) =
(mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
flattenAllUids fname ispub uids =
concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
flattenTop fname ispub (KeyData key sigs uids subkeys) =
unk ispub key :
( flattenAllUids fname ispub uids
++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
sortByHint fname f = sortBy (comparing gethint)
where
gethint = maybe defnum originalNum . Map.lookup fname . locations . f
defnum = -1
concatSort ::
FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
concatSort fname getp f = concat . sortByHint fname getp . map f
unk :: Bool -> MappedPacket -> MappedPacket
unk isPublic = if isPublic then toPacket secretToPublic else id
where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
unsig fname isPublic (sig,trustmap) =
sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
where
f n _ = n==fname -- && trace ("fname=n="++show n) True
asMapped n p = let m = mappedPacket fname p
in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
flattenFiltered :: Bool -> (KeyData -> Bool) -> KeyDB -> Message
flattenFiltered wantPublic pred db = flattenKeys wantPublic $ Map.filter pred (byKeyKey db)
|
