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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
|
{-# LANGUAGE LambdaCase #-}
module KeyDB
( TrustMap
, SigAndTrust
, SubKey(..)
, KeyData(..)
, KeyDB
, KeyGrip(..)
, emptyKeyDB
, keyData
, kkData
, lookupKeyData
, lookupByGrip
, associatedKeys
, fingerprintGrip
, smallprGrip
, transmute
, transmuteAt
, alterKeyDB
, mergeKeyDB
, mapKeyDB
-- These probably don't belong here
, selectKey0
, flattenTop
, flattenAllUids
, flattenSub
, sortByHint
, flattenKeys
, flattenFiltered
, UidString(..)
, buildGripMap
) where
import Control.Monad
import Data.Binary
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Functor
import Data.List
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.OpenPGP
import Data.Ord
import Foreign.Storable
import Text.Read
import Data.List.Merge
import Data.OpenPGP.Util
import qualified IntMapClass as I
;import IntMapClass (IMap)
import KeyRing.Types
type TrustMap = Map.Map FilePath Packet
type SigAndTrust = ( MappedPacket
, TrustMap ) -- trust packets
data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
data UidString = UidString { unUidString :: String } deriving (Show, Eq, Ord)
-- | 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 UidString ([SigAndTrust],OriginMap)) -- uids
, keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys
} deriving Show
newtype KeyGrip = KeyInt Int
fingerprintGrip :: Fingerprint -> KeyGrip
fingerprintGrip (Fingerprint bs) =
-- case decode $ L.fromStrict $ S.drop (S.length bs - sizeOf (0::Int)) bs of
-- -- The above was removed because Int is encoded as 8 bytes even when we are
-- -- using 32-bit GHC.
-- Presumably, the extra 4 bytes will be truncated.
case decode $ L.fromStrict $ S.drop (S.length bs - 8) bs of
i -> KeyInt i
smallprGrip :: String -> Maybe KeyGrip
smallprGrip pr = KeyInt <$> readMaybe ("0x" ++ drop (length pr - 2 * sizeOf (0::Int)) pr)
data KeyDB = KeyDB
{ byKeyKey :: Map.Map KeyKey KeyData
, byGrip :: IMap KeyGrip [KeyKey]
} deriving Show
-- | TODO: This is an optimization to legacy (pre-KeyDB) code. Ultimately it
-- should be unneccessary.
buildGripMap :: [Packet] -> IMap KeyGrip [Packet]
buildGripMap ps = foldr go I.empty ps
where
go pkt m = I.alter (\case Just ks -> Just (pkt:ks)
Nothing -> Just [pkt])
(fingerprintGrip . fingerprint $ pkt)
m
emptyKeyDB :: KeyDB
emptyKeyDB = KeyDB { byKeyKey = Map.empty, byGrip = I.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)
lookupByGrip :: KeyGrip -> KeyDB -> [KeyData]
lookupByGrip k db = mapMaybe (`Map.lookup` byKeyKey db)
$ concat . maybeToList
$ I.lookup k (byGrip 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 }
-- Note: We currently leave deleted-keys in the byGrip map.
, concatMap snd $ Map.elems bkk )
mpGrip :: MappedPacket -> KeyGrip
mpGrip mp = fingerprintGrip $ fingerprint $ packet mp
associatedKeys :: KeyData -> [MappedPacket]
associatedKeys kd = keyMappedPacket kd : [ k | SubKey k _ <- Map.elems (keySubKeys kd) ]
alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB
alterKeyDB update kk db = db
{ byKeyKey = Map.alter update kk (byKeyKey db)
, byGrip = case Map.lookup kk (byKeyKey db) of
Just _ -> byGrip db
Nothing -> case update Nothing of
Just kd -> let go g m = I.alter (\case Nothing -> Just [kk]
Just kks -> Just $ mergeL [kk] kks)
g
m
in foldr go (byGrip db) $ map mpGrip $ associatedKeys kd
Nothing -> byGrip 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)
, byGrip = I.unionWith mergeL (byGrip db) (byGrip 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 -> (UidString,([SigAndTrust],OriginMap)) -> [MappedPacket]
flattenUid fname ispub (UidString 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 UidString ([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)
|
