summaryrefslogtreecommitdiff
path: root/lib/KeyRing
diff options
context:
space:
mode:
Diffstat (limited to 'lib/KeyRing')
-rw-r--r--lib/KeyRing/BuildKeyDB.hs1402
-rw-r--r--lib/KeyRing/Types.hs394
2 files changed, 691 insertions, 1105 deletions
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 1c2a5aa..6de217b 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -2,13 +2,21 @@
2{-# LANGUAGE DeriveFunctor #-} 2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DoAndIfThenElse #-} 3{-# LANGUAGE DoAndIfThenElse #-}
4{-# LANGUAGE ForeignFunctionInterface #-} 4{-# LANGUAGE ForeignFunctionInterface #-}
5{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PatternGuards #-} 7{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE TupleSections #-} 8{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE ViewPatterns #-} 9{-# LANGUAGE ViewPatterns #-}
9module KeyRing.BuildKeyDB where 10module KeyRing.BuildKeyDB where
10import qualified Codec.Binary.Base32 as Base32 11
11import qualified Codec.Binary.Base64 as Base64 12#if defined(VERSION_memory)
13import Data.ByteArray.Encoding
14import qualified Data.ByteString.Char8 as S8
15import qualified Data.ByteString as S
16#elif defined(VERSION_dataenc)
17import qualified Codec.Binary.Base32 as Base32
18import qualified Codec.Binary.Base64 as Base64
19#endif
12import Control.Applicative (liftA2) 20import Control.Applicative (liftA2)
13import Control.Arrow (first, second) 21import Control.Arrow (first, second)
14import Control.Exception (catch) 22import Control.Exception (catch)
@@ -17,7 +25,9 @@ import ControlMaybe (handleIO_)
17import Data.ASN1.BinaryEncoding (DER (..)) 25import Data.ASN1.BinaryEncoding (DER (..))
18import Data.ASN1.Encoding (decodeASN1, encodeASN1) 26import Data.ASN1.Encoding (decodeASN1, encodeASN1)
19 27
20import Data.ASN1.Types (fromASN1, toASN1) 28import Data.ASN1.Types (ASN1 (BitString, End, IntVal, Null, OID, Start),
29 ASN1ConstructionType (Sequence), ASN1Object,
30 fromASN1, toASN1)
21import Data.Binary 31import Data.Binary
22import Data.Bits ((.&.), (.|.)) 32import Data.Bits ((.&.), (.|.))
23import Data.Bits (Bits) 33import Data.Bits (Bits)
@@ -101,6 +111,9 @@ import ScanningParser
101import TimeUtil 111import TimeUtil
102 112
103import KeyRing.Types 113import KeyRing.Types
114import Transforms
115import PacketTranscoder
116import GnuPGAgent
104 117
105-- | buildKeyDB 118-- | buildKeyDB
106-- 119--
@@ -116,16 +129,15 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
116 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], 129 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))],
117 {- outgoing_names -}[SockAddr]) 130 {- outgoing_names -}[SockAddr])
118 ,{- accs -} Map.Map InputFile Access 131 ,{- accs -} Map.Map InputFile Access
119 ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) 132 ,{- doDecrypt -} PacketTranscoder
120 ,{- unspilled -} Map.Map InputFile Message 133 ,{- unspilled -} Map.Map InputFile Message
121 ) 134 )
122 ,{- report_imports -} [(FilePath,KikiReportAction)])) 135 ,{- report_imports -} [(FilePath,KikiReportAction)]))
123buildKeyDB ctx grip0 keyring = do 136buildKeyDB ctx grip0 keyring = do
124 let 137 let files istyp = do
125 files istyp = do
126 (f,stream) <- Map.toList (opFiles keyring) 138 (f,stream) <- Map.toList (opFiles keyring)
127 guard (istyp $ typ stream) 139 guard (istyp $ typ stream)
128 resolveInputFile ctx f 140 return f -- resolveInputFile ctx f
129 141
130 ringMap0 = Map.filter (isring . typ) $ opFiles keyring 142 ringMap0 = Map.filter (isring . typ) $ opFiles keyring
131 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0 143 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
@@ -145,10 +157,10 @@ buildKeyDB ctx grip0 keyring = do
145 _ -> AutoAccess 157 _ -> AutoAccess
146 acc -> acc 158 acc -> acc
147 159
148 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) 160 readw wk n = fmap (n,) (readPacketsFromWallet wk n)
149 161
150 -- KeyRings (todo: KikiCondition reporting?) 162 -- KeyRings (todo: KikiCondition reporting?)
151 (spilled,mwk,grip,accs,keys,unspilled) <- do 163 (spilled,mwk,grip,accs,keyqs,unspilled) <- do
152#if MIN_VERSION_containers(0,5,0) 164#if MIN_VERSION_containers(0,5,0)
153 ringPackets <- Map.traverseWithKey readp ringMap 165 ringPackets <- Map.traverseWithKey readp ringMap
154#else 166#else
@@ -164,39 +176,25 @@ buildKeyDB ctx grip0 keyring = do
164 176
165 -- | spilled 177 -- | spilled
166 -- ring packets with info available for export 178 -- ring packets with info available for export
167 -- | unspilled 179 -- | unspilled
168 -- the rest 180 -- the rest
169 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets 181 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
170 182
171 -- | keys 183 -- | keys
172 -- process ringPackets, and get a map of fingerprint info to 184 -- process ringPackets, and get a map of fingerprint info to
173 -- to a packet, remembering it's original file, access. 185 -- to a packet, remembering it's original file, access.
174 keys :: Map.Map KeyKey MappedPacket 186 keys :: Map.Map KeyKey (OriginMapped Query)
175 keys = Map.foldl slurpkeys Map.empty
176 $ Map.mapWithKey filterSecrets ringPackets
177 where
178 filterSecrets f (_,Message ps) =
179 filter (isSecretKey . packet)
180 $ zipWith (mappedPacketWithHint fname) ps [1..]
181 where fname = resolveForReport (Just ctx) f
182 slurpkeys m ps = m `Map.union` Map.fromList ps'
183 where ps' = zip (map (keykey . packet) ps) ps
184 -- | mwk
185 -- first master key matching the provided grip
186 -- (the m is for "MappedPacket", wk for working key)
187 mwk :: Maybe MappedPacket 187 mwk :: Maybe MappedPacket
188 mwk = listToMaybe $ do 188 (mwk, keys) = keyQueries grip ringPackets
189 fp <- maybeToList grip 189
190 let matchfp mp = not (is_subkey p) && matchpr fp p == fp
191 where p = packet mp
192 Map.elems $ Map.filter matchfp keys
193 -- | accs 190 -- | accs
194 -- file access(Sec | Pub) lookup table 191 -- file access(Sec | Pub) lookup table
195 accs :: Map.Map InputFile Access 192 accs :: Map.Map InputFile Access
196 accs = fmap (access . fst) ringPackets 193 accs = fmap (access . fst) ringPackets
197 return (spilled,mwk,grip,accs,keys,fmap snd unspilled) 194 return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
198 195
199 doDecrypt <- makeMemoizingDecrypter keyring ctx keys 196 transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs)
197 let doDecrypt = transcode (Unencrypted,S2K 100 "")
200 198
201 let wk = fmap packet mwk 199 let wk = fmap packet mwk
202 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx 200 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
@@ -205,10 +203,10 @@ buildKeyDB ctx grip0 keyring = do
205 , rtWorkingKey = wk 203 , rtWorkingKey = wk
206 , rtRingAccess = accs 204 , rtRingAccess = accs
207 , rtKeyDB = Map.empty 205 , rtKeyDB = Map.empty
208 , rtPassphrases = doDecrypt 206 , rtPassphrases = transcode
209 } 207 }
210 -- autosigns and deletes 208 -- autosigns and deletes
211 transformed0 <- do 209 transformed0 <-
212 let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) 210 let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB))
213 trans f (info,ps) = do 211 trans f (info,ps) = do
214 let manip = combineTransforms (transforms info) 212 let manip = combineTransforms (transforms info)
@@ -216,87 +214,84 @@ buildKeyDB ctx grip0 keyring = do
216 acc = Just Sec /= Map.lookup f accs 214 acc = Just Sec /= Map.lookup f accs
217 r <- performManipulations doDecrypt rt1 mwk manip 215 r <- performManipulations doDecrypt rt1 mwk manip
218 try r $ \(rt2,report) -> do 216 try r $ \(rt2,report) -> do
219 return $ KikiSuccess (report,rtKeyDB rt2) 217 return $ KikiSuccess (report,rtKeyDB rt2)
218 -- XXX: Unspilled keys are not obtainable from rtKeyDB.
219 -- If the working key is marked non spillable, then how
220 -- would we look up it's UID and such?
220#if MIN_VERSION_containers(0,5,0) 221#if MIN_VERSION_containers(0,5,0)
221 fmap sequenceA $ Map.traverseWithKey trans spilled 222 in fmap sequenceA $ Map.traverseWithKey trans spilled
222#else 223#else
223 fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled 224 in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
224#endif 225#endif
225 try transformed0 $ \transformed -> do 226 try transformed0 $ \transformed -> do
226 let -- | db_rings - all keyrings combined into one 227 let -- | db_rings - all keyrings combined into one
227 db_rings :: Map.Map KeyKey KeyData 228 db_rings :: Map.Map KeyKey KeyData
228 db_rings = Map.foldlWithKey' mergeIt Map.empty transformed 229 db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
229 where 230 where
230 mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans 231 mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans
231 -- | reportTrans 232 -- | reportTrans
232 -- events, indexed by file 233 -- events, indexed by file
233 reportTrans :: [(FilePath, KikiReportAction)] 234 reportTrans :: [(FilePath, KikiReportAction)]
234 reportTrans = concat $ Map.elems $ fmap fst transformed 235 reportTrans = concat $ Map.elems $ fmap fst transformed
235 236
236 -- Wallets 237 -- Wallets
237 let importWalletKey wk db' (top,fname,sub,tag) = do 238 let importWalletKey wk db' (top,fname,sub,tag) = do
238 try db' $ \(db',report0) -> do 239 try db' $ \(db',report0) -> do
239 r <- doImportG doDecrypt 240 r <- doImportG transcode
240 db' 241 db'
241 (fmap keykey $ maybeToList wk) 242 (fmap keykey $ maybeToList wk)
242 [mkUsage tag] 243 [mkUsage tag]
243 fname 244 fname
244 sub 245 sub
245 try r $ \(db'',report) -> do 246 try r $ \(db'',report) -> do
246 return $ KikiSuccess (db'', report0 ++ report) 247 return $ KikiSuccess (db'', report0 ++ report)
247 248
248 wms <- mapM (readw wk) (files iswallet) 249 wms <- mapM (readw wk) (files iswallet)
249 let wallet_keys = do 250 let wallet_keys = do
250 maybeToList wk 251 maybeToList wk
251 (fname,xs) <- wms 252 (fname,xs) <- wms
252 (_,sub,(_,m)) <- xs 253 (_,sub,(_,m)) <- xs
253 (tag,top) <- Map.toList m 254 (tag,top) <- Map.toList m
254 return (top,fname,sub,tag) 255 return (top,fname,sub,tag)
255 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys 256
256 try db $ \(db,reportWallets) -> do 257 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
257 258 try db $ \(db,reportWallets) -> do
258 -- PEM files 259
259 let pems = do 260 -- PEM files
260 (n,stream) <- Map.toList $ opFiles keyring 261 let pems = do
261 grip <- maybeToList grip 262 (n,stream) <- Map.toList $ opFiles keyring
262 n <- resolveInputFile ctx n 263 grip <- maybeToList grip
263 guard $ spillable stream && isSecretKeyFile (typ stream) 264 guard $ spillable stream && isSecretKeyFile (typ stream)
264 let us = mapMaybe usageFromFilter [fill stream,spill stream] 265 let us = mapMaybe usageFromFilter [fill stream,spill stream]
265 usage <- take 1 us 266 usage <- take 1 us
266 guard $ all (==usage) $ drop 1 us 267 guard $ all (==usage) $ drop 1 us
267 -- TODO: KikiCondition reporting for spill/fill usage mismatch? 268 -- TODO: KikiCondition reporting for spill/fill usage mismatch?
268 -- TODO: parseSpec3 269 -- TODO: parseSpec3
269 let (topspec,subspec) = parseSpec grip usage 270 let (topspec,subspec) = parseSpec grip usage
270 ms = map fst $ filterMatches topspec (Map.toList db) 271 ms = map fst $ filterMatches topspec (Map.toList db)
271 cmd = initializer stream 272 cmd = initializer stream
272 return (n,subspec,ms,stream, cmd) 273 return (n,subspec,ms,stream, cmd)
273 274
274 imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems 275 imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n
275 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports 276 _ -> return True)
276 try db $ \(db,reportPEMs) -> do 277 pems
277 278 db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports
278 -- generate keys 279 try db $ \(db,reportPEMs) -> do
279 let gens = mapMaybe g $ Map.toList genMap 280
280 where g (Generate _ params,v) = Just (params,v) 281 -- generate keys
281 g _ = Nothing 282 let gens = mapMaybe g $ Map.toList genMap
282 283 where g (Generate _ params,v) = Just (params,v)
283 db <- generateInternals doDecrypt mwk db gens 284 g _ = Nothing
284 try db $ \(db,reportGens) -> do 285
285 286 db <- generateInternals transcode mwk db gens
286 r <- mergeHostFiles keyring db ctx 287 try db $ \(db,reportGens) -> do
287 try r $ \((db,hs),reportHosts) -> do 288
288 289 r <- mergeHostFiles keyring db ctx
289 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) 290 try r $ \((db,hs),reportHosts) -> do
290 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) 291
291 292 return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled)
292 293 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
293resolveInputFile :: InputFileContext -> InputFile -> [FilePath] 294
294resolveInputFile ctx = resolve
295 where
296 resolve HomeSec = return (homesecPath ctx)
297 resolve HomePub = return (homepubPath ctx)
298 resolve (ArgFile f) = return f
299 resolve _ = []
300 295
301isring :: FileType -> Bool 296isring :: FileType -> Bool
302isring (KeyRingFile {}) = True 297isring (KeyRingFile {}) = True
@@ -327,11 +322,12 @@ readPacketsFromWallet wk fname = do
327 timestamp <- getInputFileTime ctx fname 322 timestamp <- getInputFileTime ctx fname
328 input <- readInputFileL ctx fname 323 input <- readInputFileL ctx fname
329 let (ks,_) = slurpWIPKeys timestamp input 324 let (ks,_) = slurpWIPKeys timestamp input
325 {-
330 unless (null ks) $ do 326 unless (null ks) $ do
331 -- decrypt wk 327 -- decrypt wk
332 -- create sigs 328 -- create sigs
333 -- return key/sig pairs 329 -- return key/sig pairs
334 return () 330 return () -}
335 return $ do 331 return $ do
336 wk <- maybeToList wk 332 wk <- maybeToList wk
337 guard (not $ null ks) 333 guard (not $ null ks)
@@ -344,120 +340,11 @@ spillable :: StreamInfo -> Bool
344spillable (spill -> KF_None) = False 340spillable (spill -> KF_None) = False
345spillable _ = True 341spillable _ = True
346 342
347isSecretKey :: Packet -> Bool
348isSecretKey (SecretKeyPacket {}) = True
349isSecretKey _ = False
350
351mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
352mappedPacketWithHint filename p hint = MappedPacket
353 { packet = p
354 , locations = Map.singleton filename (origin p hint)
355 }
356
357resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
358resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
359 where str = case (fdr,fdw) of
360 (0,1) -> "-"
361 _ -> "&pipe" ++ show (fdr,fdw)
362resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
363 where str = "&" ++ show fd
364resolveForReport mctx f = concat $ resolveInputFile ctx f
365 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
366
367keykey :: Packet -> KeyKey
368keykey key =
369 -- Note: The key's timestamp is normally included in it's fingerprint.
370 -- This is undesirable for kiki because it causes the same
371 -- key to be imported multiple times and show as apparently
372 -- distinct keys with different fingerprints.
373 -- Thus, we will remove the timestamp.
374 fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
375
376-- matchpr computes the fingerprint of the given key truncated to
377-- be the same lenght as the given fingerprint for comparison.
378--
379-- matchpr fp = Data.List.Extra.takeEnd (length fp)
380--
381matchpr :: String -> Packet -> String
382matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
383
384makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
385 -> Map.Map KeyKey MappedPacket
386 -> IO (MappedPacket -> IO (KikiCondition Packet))
387makeMemoizingDecrypter operation ctx keys =
388 if null chains then do
389 -- (*) Notice we do not pass ctx to resolveForReport.
390 -- This is because the merge function does not currently use a context
391 -- and the pws map keys must match the MappedPacket locations.
392 -- TODO: Perhaps these should both be of type InputFile rather than
393 -- FilePath?
394 -- pws :: Map.Map FilePath (IO S.ByteString)
395 {-
396 pws <-
397 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
398 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
399 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
400 -}
401 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
402 pws2 <-
403 Traversable.mapM (cachedContents prompt ctx)
404 $ Map.fromList $ mapMaybe
405 (\spec -> (,passSpecPassFile spec) `fmap` do
406 guard $ isNothing $ passSpecKeySpec spec
407 passSpecRingFile spec)
408 passspecs
409 defpw <- do
410 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
411 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
412 && isNothing (passSpecKeySpec sp))
413 $ opPassphrases operation
414 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
415 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
416 else let PassphraseMemoizer f = head chains
417 in return f
418 where
419 (chains,passspecs) = partition isChain $ opPassphrases operation
420 where isChain (PassphraseMemoizer {}) = True
421 isChain _ = False
422 doDecrypt :: IORef (Map.Map KeyKey Packet)
423 -> Map.Map FilePath (IO S.ByteString)
424 -> Maybe (IO S.ByteString)
425 -> MappedPacket
426 -> IO (KikiCondition Packet)
427 doDecrypt unkeysRef pws defpw mp0 = do
428 unkeys <- readIORef unkeysRef
429 let mp = fromMaybe mp0 $ do
430 k <- Map.lookup kk keys
431 return $ mergeKeyPacket "decrypt" mp0 k
432 wk = packet mp0
433 kk = keykey wk
434 fs = Map.keys $ locations mp
435
436 decryptIt [] = return BadPassphrase
437 decryptIt (getpw:getpws) = do
438 -- TODO: This function should use mergeKeyPacket to
439 -- combine the packet with it's unspilled version before
440 -- attempting to decrypt it.
441 pw <- getpw
442 let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
443 case symmetric_algorithm wkun of
444 Unencrypted -> do
445 writeIORef unkeysRef (Map.insert kk wkun unkeys)
446 return $ KikiSuccess wkun
447 _ -> decryptIt getpws
448
449 getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
450
451 case symmetric_algorithm wk of
452 Unencrypted -> return (KikiSuccess wk)
453 _ -> maybe (decryptIt getpws)
454 (return . KikiSuccess)
455 $ Map.lookup kk unkeys
456 343
457-- | combineTransforms 344-- | combineTransforms
458-- remove rundant transforms, and compile the rest to PacketUpdate(s) 345-- remove redundant transforms, and compile the rest to PacketUpdate(s)
459-- 346--
460-- eqivalent to: 347-- equivalent to:
461-- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd 348-- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd
462combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] 349combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
463combineTransforms trans rt kd = updates 350combineTransforms trans rt kd = updates
@@ -490,108 +377,6 @@ merge db inputfile (Message ps) = merge_ db filename qs
490 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public 377 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public
491 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret 378 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret
492 379
493performManipulations ::
494 (MappedPacket -> IO (KikiCondition Packet))
495 -> KeyRingRuntime
496 -> Maybe MappedPacket
497 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
498 -> IO (KikiCondition (KeyRingRuntime,KikiReport))
499performManipulations doDecrypt rt wk manip = do
500 let db = rtKeyDB rt
501 performAll kd = foldM perform (KikiSuccess (kd, [])) $ manip rt kd
502 r <- Traversable.mapM performAll db
503 try (sequenceA r) $ \db -> do
504 return $
505 KikiSuccess (rt {rtKeyDB = fmap fst db}, concatMap snd $ Map.elems db)
506 where
507 perform
508 :: KikiCondition (KeyData, KikiReport)
509 -> PacketUpdate
510 -> IO (KikiCondition (KeyData, KikiReport))
511 perform kd (InducerSignature uid subpaks) = do
512 try kd $ \(kd, report) -> do
513 flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
514 wkun' <- doDecrypt wk'
515 try wkun' $ \wkun -> do
516 let flgs =
517 if keykey (keyPacket kd) == keykey wkun
518 then keyFlags0
519 (keyPacket kd)
520 (map (\(x, _, _) -> x) selfsigs)
521 else []
522 sigOver =
523 makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) $
524 flgs ++ subpaks
525 om = Map.singleton "--autosign" (origin p (-1))
526 where
527 p = UserIDPacket uid
528 toMappedPacket om p = (mappedPacket "" p) {locations = om}
529 selfsigs =
530 filter
531 (\(sig, v, whosign) ->
532 isJust
533 (v >> Just wkun >>=
534 guard . (== keykey whosign) . keykey))
535 vs
536 keys = map keyPacket $ Map.elems (rtKeyDB rt)
537 overs sig =
538 signatures $
539 Message (keys ++ [keyPacket kd, UserIDPacket uid, sig])
540 vs
541 :: [(Packet -- signature
542 , Maybe SignatureOver -- Nothing means non-verified
543 , Packet -- key who signed
544 )]
545 vs = do
546 x <- maybeToList $ Map.lookup uid (keyUids kd)
547 sig <- map (packet . fst) (fst x)
548 o <- overs sig
549 k <- keys
550 let ov = verify (Message [k]) $ o
551 signatures_over ov
552 return (sig, Just ov, k)
553 additional new_sig = do
554 new_sig <- maybeToList new_sig
555 guard (null $ selfsigs)
556 signatures_over new_sig
557 sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
558 let f :: ([SigAndTrust], OriginMap) -> ([SigAndTrust], OriginMap)
559 f x =
560 ( map ((, Map.empty) . toMappedPacket om) (additional sigr) ++
561 fst x
562 , om `Map.union` snd x)
563 -- XXX: Shouldn't this signature generation show up in the KikiReport ?
564 return $
565 KikiSuccess $
566 (kd {keyUids = Map.adjust f uid (keyUids kd)}, report)
567 perform kd (SubKeyDeletion topk subk) = do
568 try kd $ \(kd, report) -> do
569 let kk = keykey $ packet $ keyMappedPacket kd
570 kd'
571 | kk /= topk = kd
572 | otherwise =
573 kd {keySubKeys = Map.filterWithKey pred $ keySubKeys kd}
574 pred k _ = k /= subk
575 ps =
576 concat $
577 maybeToList $ do
578 SubKey mp sigs <- Map.lookup subk (keySubKeys kd)
579 return $
580 packet mp :
581 concatMap (\(p, ts) -> packet p : Map.elems ts) sigs
582 ctx = InputFileContext (rtSecring rt) (rtPubring rt)
583 rings = [HomeSec, HomePub] >>= resolveInputFile ctx
584 return $
585 KikiSuccess
586 ( kd'
587 , report ++
588 [(f, DeletedPacket $ showPacket p) | f <- rings, p <- ps])
589
590try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
591try x body =
592 case functorToEither x of
593 Left e -> return e
594 Right x -> body x
595 380
596mergeKeyData :: KeyData -> KeyData -> KeyData 381mergeKeyData :: KeyData -> KeyData -> KeyData
597mergeKeyData (KeyData atop asigs auids asubs) 382mergeKeyData (KeyData atop asigs auids asubs)
@@ -620,40 +405,19 @@ mergeKeyData (KeyData atop asigs auids asubs)
620 mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm) 405 mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm)
621 406
622doImportG 407doImportG
623 :: (MappedPacket -> IO (KikiCondition Packet)) 408 :: PacketTranscoder
624 -> Map.Map KeyKey KeyData 409 -> Map.Map KeyKey KeyData
625 -> [KeyKey] -- m0, only head is used 410 -> [KeyKey] -- m0, only head is used
626 -> [SignatureSubpacket] -- tags 411 -> [SignatureSubpacket] -- tags
627 -> FilePath 412 -> InputFile
628 -> Packet 413 -> Packet
629 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 414 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
630doImportG doDecrypt db m0 tags fname key = do 415doImportG transcode db m0 tags fname key = do
631 let kk = head m0 416 let kk = head m0
632 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db 417 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
633 kdr <- insertSubkey doDecrypt kk kd tags fname key 418 kdr <- insertSubkey transcode kk kd tags fname key
634 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) 419 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
635 420
636mkUsage :: String -> SignatureSubpacket
637mkUsage tag
638 | Just flags <- lookup tag specials =
639 KeyFlagsPacket
640 { certify_keys = fromEnum flags .&. 0x1 /= 0
641 , sign_data = fromEnum flags .&. 0x2 /= 0
642 , encrypt_communication = fromEnum flags .&. 0x4 /= 0
643 , encrypt_storage = fromEnum flags .&. 0x8 /= 0
644 , split_key = False
645 , authentication = False
646 , group_key = False
647 }
648 where
649 flagsets = [Special .. VouchSignEncrypt]
650 specials = map (\f -> (usageString f, f)) flagsets
651
652mkUsage tag = NotationDataPacket
653 { human_readable = True
654 , notation_name = "usage@"
655 , notation_value = tag
656 }
657 421
658iswallet :: FileType -> Bool 422iswallet :: FileType -> Bool
659iswallet (WalletFile {}) = True 423iswallet (WalletFile {}) = True
@@ -749,32 +513,32 @@ filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
749filterMatches spec ks = filter (matchSpec spec . snd) ks 513filterMatches spec ks = filter (matchSpec spec . snd) ks
750 514
751importSecretKey :: 515importSecretKey ::
752 (MappedPacket -> IO (KikiCondition Packet)) 516 (PacketTranscoder)
753 -> KikiCondition 517 -> KikiCondition
754 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) 518 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
755 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 519 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
756 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 520 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
757importSecretKey doDecrypt db' tup = do 521importSecretKey transcode db' tup = do
758 try db' $ \(db',report0) -> do 522 try db' $ \(db',report0) -> do
759 r <- doImport doDecrypt 523 r <- doImport transcode
760 db' 524 db'
761 tup 525 tup
762 try r $ \(db'',report) -> do 526 try r $ \(db'',report) -> do
763 return $ KikiSuccess (db'', report0 ++ report) 527 return $ KikiSuccess (db'', report0 ++ report)
764 528
765generateInternals :: 529generateInternals ::
766 (MappedPacket -> IO (KikiCondition Packet)) 530 PacketTranscoder
767 -> Maybe MappedPacket 531 -> Maybe MappedPacket
768 -> Map.Map KeyKey KeyData 532 -> Map.Map KeyKey KeyData
769 -> [(GenerateKeyParams,StreamInfo)] 533 -> [(GenerateKeyParams,StreamInfo)]
770 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 534 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
771generateInternals doDecrypt mwk db gens = do 535generateInternals transcode mwk db gens = do
772 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of 536 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
773 Just kd0 -> do 537 Just kd0 -> do
774 kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens 538 kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
775 try kd $ \(kd,reportGens) -> do 539 try kd $ \(kd,reportGens) -> do
776 let kk = keykey $ packet $ fromJust mwk 540 let kk = keykey $ packet $ fromJust mwk
777 return $ KikiSuccess (Map.insert kk kd db,reportGens) 541 return $ KikiSuccess (Map.insert kk kd db,reportGens)
778 Nothing -> return $ KikiSuccess (db,[]) 542 Nothing -> return $ KikiSuccess (db,[])
779 543
780mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext 544mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
@@ -875,89 +639,6 @@ slurpWIPKeys stamp cs =
875 else let (ks,js) = slurpWIPKeys stamp xs 639 else let (ks,js) = slurpWIPKeys stamp xs
876 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb 640 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
877 641
878origin :: Packet -> Int -> OriginFlags
879origin p n = OriginFlags ispub n
880 where
881 ispub = case p of
882 SecretKeyPacket {} -> False
883 _ -> True
884
885cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
886cachedContents maybePrompt ctx fd = do
887 ref <- newIORef Nothing
888 return $ get maybePrompt ref fd
889 where
890 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
891
892 get maybePrompt ref fd = do
893 pw <- readIORef ref
894 flip (flip maybe return) pw $ do
895 if fd == FileDesc 0 then case maybePrompt of
896 Just prompt -> S.hPutStr stderr prompt
897 Nothing -> return ()
898 else return ()
899 pw <- fmap trimCR $ readInputFileS ctx fd
900 writeIORef ref (Just pw)
901 return pw
902
903mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
904mergeKeyPacket what key p =
905 key { packet = minimumBy (keyCompare what) [packet key,packet p]
906 , locations = Map.union (locations key) (locations p)
907 }
908
909-- | resolveTransform
910resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
911resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
912 where
913 ops = map (\u -> InducerSignature u []) us
914 us = filter torStyle $ Map.keys umap
915 torStyle str = and [ uid_topdomain parsed == "onion"
916 , uid_realname parsed `elem` ["","Anonymous"]
917 , uid_user parsed == "root"
918 , fmap (match . fst) (lookup (packet k) torbindings)
919 == Just True ]
920 where parsed = parseUID str
921 match = (==subdom) . take (fromIntegral len)
922 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
923 subdom = Char8.unpack subdom0
924 len = T.length (uid_subdomain parsed)
925 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
926 getTorKeys pub = do
927 xs <- groupBindings pub
928 (_,(top,sub),us,_,_) <- xs
929 guard ("tor" `elem` us)
930 let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
931 return (top,(torhash,sub))
932
933 groupBindings pub = gs
934 where (_,bindings) = getBindings pub
935 bindings' = accBindings bindings
936 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
937 ownerkey (_,(a,_),_,_,_) = a
938 sameMaster (ownerkey->a) (ownerkey->b)
939 = fingerprint_material a==fingerprint_material b
940 gs = groupBy sameMaster (sortBy (comparing code) bindings')
941
942
943-- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
944resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
945 where
946 topk = keykey $ packet k -- key to master of key to be deleted
947 subk = do
948 (k,sub) <- Map.toList submap
949 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
950 return k
951
952-- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
953resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
954 where
955 topk = keykey $ packet k -- key to master of key to be deleted
956 subk = do
957 (k,SubKey p sigs) <- Map.toList submap
958 take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
959 return k
960
961merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] 642merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
962 -> KeyDB 643 -> KeyDB
963merge_ db filename qs = foldl mergeit db (zip [0..] qs) 644merge_ db filename qs = foldl mergeit db (zip [0..] qs)
@@ -972,140 +653,38 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
972 653
973 whatP (a,_) = concat . take 1 . words . show $ a 654 whatP (a,_) = concat . take 1 . words . show $ a
974 655
975isKey :: Packet -> Bool
976isKey (PublicKeyPacket {}) = True
977isKey (SecretKeyPacket {}) = True
978isKey _ = False
979
980isUserID :: Packet -> Bool
981isUserID (UserIDPacket {}) = True
982isUserID _ = False
983
984isTrust :: Packet -> Bool
985isTrust (TrustPacket {}) = True
986isTrust _ = False
987 656
988keyPacket :: KeyData -> Packet 657-- insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)]))
989keyPacket (KeyData k _ _ _) = packet k 658insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do
990 659 let topcipher = symmetric_algorithm $ packet top
991keyFlags0 :: t -> [Packet] -> [SignatureSubpacket] 660 tops2k = s2k $ packet top
992keyFlags0 wkun uidsigs = concat 661 doDecrypt = transcode (Unencrypted,S2K 100 "")
993 [ keyflags 662 fname = resolveForReport Nothing inputfile
994 , preferredsym 663 subkk = keykey key0
995 , preferredhash 664 istor = do
996 , preferredcomp 665 guard ("tor" `elem` mapMaybe usage tags)
997 , features ] 666 return $ torUIDFromKey key0
998 667 addOrigin (SubKey mp sigs) =
999 where
1000 subs = concatMap hashed_subpackets uidsigs
1001 keyflags = filterOr isflags subs $
1002 KeyFlagsPacket { certify_keys = True
1003 , sign_data = True
1004 , encrypt_communication = False
1005 , encrypt_storage = False
1006 , split_key = False
1007 , authentication = False
1008 , group_key = False
1009 }
1010 preferredsym = filterOr ispreferedsym subs $
1011 PreferredSymmetricAlgorithmsPacket
1012 [ AES256
1013 , AES192
1014 , AES128
1015 , CAST5
1016 , TripleDES
1017 ]
1018 preferredhash = filterOr ispreferedhash subs $
1019 PreferredHashAlgorithmsPacket
1020 [ SHA256
1021 , SHA1
1022 , SHA384
1023 , SHA512
1024 , SHA224
1025 ]
1026 preferredcomp = filterOr ispreferedcomp subs $
1027 PreferredCompressionAlgorithmsPacket
1028 [ ZLIB
1029 , BZip2
1030 , ZIP
1031 ]
1032 features = filterOr isfeatures subs $
1033 FeaturesPacket { supports_mdc = True
1034 }
1035
1036 filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
1037
1038 isflags (KeyFlagsPacket {}) = True
1039 isflags _ = False
1040 ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
1041 ispreferedsym _ = False
1042 ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
1043 ispreferedhash _ = False
1044 ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
1045 ispreferedcomp _ = False
1046 isfeatures (FeaturesPacket {}) = True
1047 isfeatures _ = False
1048
1049makeInducerSig
1050 :: Packet
1051 -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
1052-- torsig g topk wkun uid timestamp extras = todo
1053makeInducerSig topk wkun uid extras
1054 = CertificationSignature (secretToPublic topk)
1055 uid
1056 (sigpackets 0x13
1057 subpackets
1058 subpackets_unh)
1059 where
1060 subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
1061 tsign
1062 ++ extras
1063 subpackets_unh = [IssuerPacket (fingerprint wkun)]
1064 tsign = if keykey wkun == keykey topk
1065 then [] -- tsign doesnt make sense for self-signatures
1066 else [ TrustSignaturePacket 1 120
1067 , RegularExpressionPacket regex]
1068 -- <[^>]+[@.]asdf\.nowhere>$
1069 regex = "<[^>]+[@.]"++hostname++">$"
1070 -- regex = username ++ "@" ++ hostname
1071 -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
1072 hostname = subdomain' pu ++ "\\." ++ topdomain' pu
1073 pu = parseUID uidstr where UserIDPacket uidstr = uid
1074 subdomain' = escape . T.unpack . uid_subdomain
1075 topdomain' = escape . T.unpack . uid_topdomain
1076 escape s = concatMap echar s
1077 where
1078 echar '|' = "\\|"
1079 echar '*' = "\\*"
1080 echar '+' = "\\+"
1081 echar '?' = "\\?"
1082 echar '.' = "\\."
1083 echar '^' = "\\^"
1084 echar '$' = "\\$"
1085 echar '\\' = "\\\\"
1086 echar '[' = "\\["
1087 echar ']' = "\\]"
1088 echar c = [c]
1089
1090insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)]))
1091insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
1092 let subkk = keykey key
1093 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
1094 [])
1095 ( (False,) . addOrigin )
1096 (Map.lookup subkk subs)
1097 where
1098 addOrigin (SubKey mp sigs) =
1099 let mp' = mp 668 let mp' = mp
1100 { locations = Map.insert fname 669 { locations = Map.insert fname
1101 (origin (packet mp) (-1)) 670 (origin (packet mp) (-1))
1102 (locations mp) } 671 (locations mp) }
1103 in SubKey mp' sigs 672 in SubKey mp' sigs
1104 subs' = Map.insert subkk subkey subs
1105 673
1106 istor = do 674 subkey_result <- do
1107 guard ("tor" `elem` mapMaybe usage tags) 675 case Map.lookup subkk subs of
1108 return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>" 676 Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing)
677 Nothing -> do
678 wkun' <- doDecrypt top
679 try wkun' $ \wkun -> do
680 key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0
681 try key' $ \key -> do
682 return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key))
683
684
685 try subkey_result $ \(is_new,subkey,decrypted) -> do
686
687 let subs' = Map.insert subkk subkey subs
1109 688
1110 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do 689 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
1111 let has_torid = do 690 let has_torid = do
@@ -1115,72 +694,58 @@ insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
1115 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) 694 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
1116 signatures_over $ verify (Message [packet top]) s 695 signatures_over $ verify (Message [packet top]) s
1117 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do 696 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
1118 wkun <- doDecrypt top 697
1119 698 let keyflags = keyFlags (error "dummy argument (insertSubkey)") (map packet $ flattenAllUids fname True uids)
1120 try wkun $ \wkun -> do 699 uid = UserIDPacket idstr
1121 700 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
1122 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) 701 tor_ov = makeInducerSig (packet top) (packet top) uid keyflags
1123 uid = UserIDPacket idstr 702 wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted
1124 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags 703 try wkun' $ \wkun -> do
1125 tor_ov = makeInducerSig (packet top) wkun uid keyflags 704 sig_ov <- pgpSign (Message [wkun])
1126 sig_ov <- pgpSign (Message [wkun]) 705 tor_ov
1127 tor_ov 706 SHA1
1128 SHA1 707 (fingerprint wkun)
1129 (fingerprint wkun) 708 flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)]))
1130 flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) 709 (sig_ov >>= listToMaybe . signatures_over)
1131 (sig_ov >>= listToMaybe . signatures_over) 710 $ \sig -> do
1132 $ \sig -> do 711 let om = Map.singleton fname (origin sig (-1))
1133 let om = Map.singleton fname (origin sig (-1)) 712 trust = Map.empty
1134 trust = Map.empty 713 return $ KikiSuccess
1135 return $ KikiSuccess 714 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
1136 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} 715 , trust)],om) uids
1137 , trust)],om) uids 716 , [] )
1138 , [] )
1139 717
1140 try uids' $ \(uids',report) -> do 718 try uids' $ \(uids',report) -> do
1141 719
1142 let SubKey subkey_p subsigs = subkey 720 let SubKey subkey_p subsigs = subkey
1143 wk = packet top 721 wk = packet top
1144 (xs',minsig,ys') = findTag tags wk key subsigs 722 (xs',minsig,ys') = findTag tags wk key0 subsigs
1145 doInsert mbsig = do 723 doInsert mbsig = do
1146 -- NEW SUBKEY BINDING SIGNATURE 724 -- NEW SUBKEY BINDING SIGNATURE
1147 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig 725 -- XXX: Here I assume that key0 is the unencrypted version
1148 try sig' $ \(sig',report) -> do 726 -- of subkey_p. TODO: Check this assumption.
1149 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] 727 sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} tags mbsig
1150 let subs' = Map.insert subkk 728 try sig' $ \(sig',report) -> do
1151 (SubKey subkey_p $ xs'++[sig']++ys') 729 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
1152 subs 730 let subs' = Map.insert subkk
1153 return $ KikiSuccess ( KeyData top topsigs uids' subs' 731 (SubKey subkey_p $ xs'++[sig']++ys')
1154 , report ) 732 subs
1155 733 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1156 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) 734 , report )
1157 else id 735
1158 s = show (fmap fst minsig,fingerprint key) 736 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
1159 in return (f report) 737 else id
1160 738 s = show (fmap fst minsig,fingerprint key0)
1161 case minsig of 739 in return (f report)
1162 Nothing -> doInsert Nothing -- we need to create a new sig 740
1163 Just (True,sig) -> -- we can deduce is_new == False 741 case minsig of
1164 -- we may need to add a tor id 742 Nothing -> doInsert Nothing -- we need to create a new sig
1165 return $ KikiSuccess ( KeyData top topsigs uids' subs' 743 Just (True,sig) -> -- we can deduce is_new == False
1166 , report ) 744 -- we may need to add a tor id
1167 Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag 745 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1168 746 , report )
1169mappedPacket :: FilePath -> Packet -> MappedPacket 747 Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag
1170mappedPacket filename p = MappedPacket 748
1171 { packet = p
1172 , locations = Map.singleton filename (origin p (-1))
1173 }
1174
1175showPacket :: Packet -> String
1176showPacket p | isKey p = (if is_subkey p
1177 then showPacket0 p
1178 else ifSecret p "----Secret-----" "----Public-----")
1179 ++ " "++show (key_algorithm p)++" "++fingerprint p
1180 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
1181 | otherwise = showPacket0 p
1182showPacket0 :: Show a => a -> [Char]
1183showPacket0 p = concat . take 1 $ words (show p)
1184 749
1185mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust] 750mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust]
1186mergeSig sig sigs = 751mergeSig sig sigs =
@@ -1207,26 +772,6 @@ mergeSig sig sigs =
1207 772
1208 mergeSameSig a b = b -- trace ("discarding dup "++show a) b 773 mergeSameSig a b = b -- trace ("discarding dup "++show a) b
1209 774
1210usageString :: PGPKeyFlags -> String
1211usageString flgs =
1212 case flgs of
1213 Special -> "special"
1214 Vouch -> "vouch" -- signkey
1215 Sign -> "sign"
1216 VouchSign -> "vouch-sign"
1217 Communication -> "communication"
1218 VouchCommunication -> "vouch-communication"
1219 SignCommunication -> "sign-communication"
1220 VouchSignCommunication -> "vouch-sign-communication"
1221 Storage -> "storage"
1222 VouchStorage -> "vouch-storage"
1223 SignStorage -> "sign-storage"
1224 VouchSignStorage -> "vouch-sign-storage"
1225 Encrypt -> "encrypt"
1226 VouchEncrypt -> "vouch-encrypt"
1227 SignEncrypt -> "sign-encrypt"
1228 VouchSignEncrypt -> "vouch-sign-encrypt"
1229
1230parseSingleSpec :: String -> SingleKeySpec 775parseSingleSpec :: String -> SingleKeySpec
1231parseSingleSpec "*" = AnyMatch 776parseSingleSpec "*" = AnyMatch
1232parseSingleSpec "-" = WorkingKeyMatch 777parseSingleSpec "-" = WorkingKeyMatch
@@ -1270,66 +815,66 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
1270 us = filter (isInfixOf pat) $ Map.keys uids 815 us = filter (isInfixOf pat) $ Map.keys uids
1271 816
1272doImport 817doImport
1273 :: (MappedPacket -> IO (KikiCondition Packet)) 818 :: PacketTranscoder
1274 -> Map.Map KeyKey KeyData 819 -> Map.Map KeyKey KeyData
1275 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 820 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
1276 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 821 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
1277doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do 822doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
1278 flip (maybe $ return CannotImportMasterKey) 823 flip (maybe $ return CannotImportMasterKey)
1279 subspec $ \tag -> do 824 subspec $ \tag -> do
1280 (certs,keys) <- case typ of 825 (certs,keys) <- case typ of
1281 PEMFile -> do 826 PEMFile -> do
1282 ps <- readSecretPEMFile (ArgFile fname) 827 ps <- readSecretPEMFile fname
1283 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) 828 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
1284 = partition (isJust . spemCert) ps 829 = partition (isJust . spemCert) ps
1285 return (certs,keys) 830 return (certs,keys)
1286 DNSPresentation -> do 831 DNSPresentation -> do
1287 p <- readSecretDNSFile (ArgFile fname) 832 p <- readSecretDNSFile fname
1288 return ([],[p]) 833 return ([],[p])
1289 -- TODO Probably we need to move to a new design where signature 834 -- TODO Probably we need to move to a new design where signature
1290 -- packets are merged into the database in one phase with null 835 -- packets are merged into the database in one phase with null
1291 -- signatures, and then the signatures are made in the next phase. 836 -- signatures, and then the signatures are made in the next phase.
1292 -- This would let us merge annotations (like certificates) from 837 -- This would let us merge annotations (like certificates) from
1293 -- seperate files. 838 -- seperate files.
1294 foldM (importKey tag certs) (KikiSuccess (db,[])) keys 839 foldM (importKey tag certs) (KikiSuccess (db,[])) keys
1295 where 840 where
1296 importKey tag certs prior key = do 841 importKey tag certs prior key = do
1297 try prior $ \(db,report) -> do 842 try prior $ \(db,report) -> do
1298 let (m0,tailms) = splitAt 1 ms 843 let (m0,tailms) = splitAt 1 ms
1299 if (not (null tailms) || null m0) 844 if (not (null tailms) || null m0)
1300 then return $ AmbiguousKeySpec fname 845 then return $ AmbiguousKeySpec (resolveForReport Nothing fname)
1301 else do 846 else do
1302 let kk = keykey key 847 let kk = keykey key
1303 cs = filter (\c -> kk==keykey (pcertKey c)) certs 848 cs = filter (\c -> kk==keykey (pcertKey c)) certs
1304 blobs = map mkCertNotation $ nub $ map pcertBlob cs 849 blobs = map mkCertNotation $ nub $ map pcertBlob cs
1305 mkCertNotation bs = NotationDataPacket 850 mkCertNotation bs = NotationDataPacket
1306 { human_readable = False 851 { human_readable = False
1307 , notation_name = "x509cert@" 852 , notation_name = "x509cert@"
1308 , notation_value = Char8.unpack bs } 853 , notation_value = Char8.unpack bs }
1309 datedKey = key { timestamp = fromTime $ minimum dates } 854 datedKey = key { timestamp = fromTime $ minimum dates }
1310 dates = fromTime (timestamp key) : map pcertTimestamp certs 855 dates = fromTime (timestamp key) : map pcertTimestamp certs
1311 r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey 856 r <- doImportG transcode db m0 (mkUsage tag:blobs) fname datedKey
1312 try r $ \(db',report') -> do 857 try r $ \(db',report') -> do
1313 return $ KikiSuccess (db',report++report') 858 return $ KikiSuccess (db',report++report')
1314 859
1315generateSubkey :: 860generateSubkey ::
1316 (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[ 861 PacketTranscoder
1317 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db 862 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
1318 -> (GenerateKeyParams, StreamInfo) 863 -> (GenerateKeyParams, StreamInfo)
1319 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) 864 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
1320generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do 865generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1321 try kd' $ \(kd,report0) -> do 866 try kd' $ \(kd,report0) -> do
1322 let subs = do 867 let subs = do
1323 SubKey p sigs <- Map.elems $ keySubKeys kd 868 SubKey p sigs <- Map.elems $ keySubKeys kd
1324 filter (has_tag tag) $ map (packet . fst) sigs 869 filter (has_tag tag) $ map (packet . fst) sigs
1325 if null subs 870 if null subs
1326 then do 871 then do
1327 newkey <- generateKey genparam 872 newkey <- generateKey genparam
1328 kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey 873 kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey
1329 try kdr $ \(newkd,report) -> do 874 try kdr $ \(newkd,report) -> do
1330 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) 875 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
1331 else do 876 else do
1332 return $ KikiSuccess (kd,report0) 877 return $ KikiSuccess (kd,report0)
1333generateSubkey _ kd _ = return kd 878generateSubkey _ kd _ = return kd
1334 879
1335-- | 880-- |
@@ -1496,12 +1041,6 @@ secp256k1_id = 0x2b8104000a
1496 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 1041 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23
1497-} 1042-}
1498 1043
1499readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
1500readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents
1501readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
1502readInputFileS ctx inp = do
1503 let fname = resolveInputFile ctx inp
1504 fmap S.concat $ mapM S.readFile fname
1505 1044
1506keyCompare :: String -> Packet -> Packet -> Ordering 1045keyCompare :: String -> Packet -> Packet -> Ordering
1507keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT 1046keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
@@ -1514,101 +1053,6 @@ keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
1514 , PP.ppShow b 1053 , PP.ppShow b
1515 ] 1054 ]
1516 1055
1517parseUID :: String -> UserIDRecord
1518parseUID str = UserIDRecord {
1519 uid_full = str,
1520 uid_realname = realname,
1521 uid_user = user,
1522 uid_subdomain = subdomain,
1523 uid_topdomain = topdomain
1524 }
1525 where
1526 text = T.pack str
1527 (T.strip-> realname, T.dropAround isBracket-> email)
1528 = T.break (=='<') text
1529 (user, T.drop 1-> hostname) = T.break (=='@') email
1530 ( T.reverse -> topdomain,
1531 T.reverse . T.drop 1 -> subdomain)
1532 = T.break (=='.') . T.reverse $ hostname
1533
1534flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
1535flattenTop fname ispub (KeyData key sigs uids subkeys) =
1536 unk ispub key :
1537 ( flattenAllUids fname ispub uids
1538 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
1539
1540derToBase32 :: ByteString -> String
1541#if !defined(VERSION_cryptonite)
1542derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
1543#else
1544derToBase32 = map toLower . Base32.encode . S.unpack . sha1
1545 where
1546 sha1 :: L.ByteString -> S.ByteString
1547 sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
1548#endif
1549
1550derRSA :: Packet -> Maybe ByteString
1551derRSA rsa = do
1552 k <- rsaKeyFromPacket rsa
1553 return $ encodeASN1 DER (toASN1 k [])
1554
1555getBindings ::
1556 [Packet]
1557 ->
1558 ( [([Packet],[SignatureOver])] -- other signatures with key sets
1559 -- that were used for the verifications
1560 , [(Word8,
1561 (Packet, Packet), -- (topkey,subkey)
1562 [String], -- usage flags
1563 [SignatureSubpacket], -- hashed data
1564 [Packet])] -- binding signatures
1565 )
1566getBindings pkts = (sigs,bindings)
1567 where
1568 (sigs,concat->bindings) = unzip $ do
1569 let (keys,_) = partition isKey pkts
1570 keys <- disjoint_fp keys
1571 let (bs,sigs) = verifyBindings keys pkts
1572 return . ((keys,sigs),) $ do
1573 b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
1574 i <- map signature_issuer (signatures_over b)
1575 i <- maybeToList i
1576 who <- maybeToList $ find_key fingerprint (Message keys) i
1577 let (code,claimants) =
1578 case () of
1579 _ | who == topkey b -> (1,[])
1580 _ | who == subkey b -> (2,[])
1581 _ -> (0,[who])
1582 let hashed = signatures_over b >>= hashed_subpackets
1583 kind = guard (code==1) >> hashed >>= maybeToList . usage
1584 return (code,(topkey b,subkey b), kind, hashed,claimants)
1585
1586-- Returned data is simmilar to getBindings but the Word8 codes
1587-- are ORed together.
1588accBindings ::
1589 Bits t =>
1590 [(t, (Packet, Packet), [a], [a1], [a2])]
1591 -> [(t, (Packet, Packet), [a], [a1], [a2])]
1592accBindings bs = as
1593 where
1594 gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
1595 as = map (foldl1 combine) gs
1596 bindingPair (_,p,_,_,_) = pub2 p
1597 where
1598 pub2 (a,b) = (pub a, pub b)
1599 pub a = fingerprint_material a
1600 samePair a b = bindingPair a == bindingPair b
1601 combine (ac,p,akind,ahashed,aclaimaints)
1602 (bc,_,bkind,bhashed,bclaimaints)
1603 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
1604
1605subkeyMappedPacket :: SubKey -> MappedPacket
1606subkeyMappedPacket (SubKey k _ ) = k
1607
1608has_tag :: String -> Packet -> Bool
1609has_tag tag p = isSignaturePacket p
1610 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
1611 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
1612 1056
1613dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData 1057dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData
1614dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) 1058dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
@@ -1689,200 +1133,55 @@ secretToPublic pkt@(SecretKeyPacket {}) =
1689 } 1133 }
1690secretToPublic pkt = pkt 1134secretToPublic pkt = pkt
1691 1135
1692sigpackets ::
1693 Monad m =>
1694 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
1695sigpackets typ hashed unhashed = return $
1696 signaturePacket
1697 4 -- version
1698 typ -- 0x18 subkey binding sig, or 0x19 back-signature
1699 RSA
1700 SHA1
1701 hashed
1702 unhashed
1703 0 -- Word16 -- Left 16 bits of the signed hash value
1704 [] -- [MPI]
1705
1706usage :: SignatureSubpacket -> Maybe String
1707usage (NotationDataPacket
1708 { human_readable = True
1709 , notation_name = "usage@"
1710 , notation_value = u
1711 }) = Just u
1712usage _ = Nothing
1713
1714torhash :: Packet -> String
1715torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
1716
1717keyFlags :: t -> [Packet] -> [SignatureSubpacket]
1718keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
1719
1720flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
1721flattenAllUids fname ispub uids =
1722 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
1723
1724-- | Given list of subpackets, a master key, one of its subkeys and a
1725-- list of signatures on that subkey, yields:
1726--
1727-- * preceding list of signatures
1728--
1729-- * The most recent valid signature made by the master key along with a
1730-- flag that indicates whether or not all of the supplied subpackets occur in
1731-- it or, if no valid signature from the working key is present, Nothing.
1732--
1733-- * following list of signatures
1734--
1735findTag ::
1736 [SignatureSubpacket]
1737 -> Packet
1738 -> Packet
1739 -> [(MappedPacket, b)]
1740 -> ([(MappedPacket, b)],
1741 Maybe (Bool, (MappedPacket, b)),
1742 [(MappedPacket, b)])
1743findTag tag topk subkey subsigs = (xs',minsig,ys')
1744 where
1745 vs = map (\sig ->
1746 (sig, do
1747 sig <- Just (packet . fst $ sig)
1748 guard (isSignaturePacket sig)
1749 guard $ flip isSuffixOf
1750 (fingerprint topk)
1751 . fromMaybe "%bad%"
1752 . signature_issuer
1753 $ sig
1754 listToMaybe $
1755 map (signature_time . verify (Message [topk]))
1756 (signatures $ Message [topk,subkey,sig])))
1757 subsigs
1758 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
1759 xs' = map fst xs
1760 ys' = map fst $ if isNothing minsig then ys else drop 1 ys
1761 minsig = do
1762 (sig,ov) <- listToMaybe ys
1763 ov
1764 let hshed = hashed_subpackets $ packet $ fst sig
1765 return ( null $ tag \\ hshed, sig)
1766
1767makeSig ::
1768 (MappedPacket -> IO (KikiCondition Packet))
1769 -> MappedPacket
1770 -> [Char]
1771 -> MappedPacket
1772 -> [SignatureSubpacket]
1773 -> Maybe (MappedPacket, Map.Map k a)
1774 -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
1775makeSig doDecrypt top fname subkey_p tags mbsig = do
1776 let wk = packet top
1777 wkun <- doDecrypt top
1778 try wkun $ \wkun -> do
1779 let grip = fingerprint wk
1780 addOrigin new_sig =
1781 flip
1782 (maybe $ return FailedToMakeSignature)
1783 (new_sig >>= listToMaybe . signatures_over) $ \new_sig -> do
1784 let mp' = mappedPacket fname new_sig
1785 return $ KikiSuccess (mp', Map.empty)
1786 parsedkey = [packet subkey_p]
1787 hashed0
1788 | any isFlagsPacket tags = tags
1789 | otherwise =
1790 KeyFlagsPacket
1791 { certify_keys = False
1792 , sign_data = False
1793 , encrypt_communication = False
1794 , encrypt_storage = False
1795 , split_key = False
1796 , authentication = True
1797 , group_key = False
1798 } :
1799 tags
1800 -- implicitly added:
1801 -- , SignatureCreationTimePacket (fromIntegral timestamp)
1802 isFlagsPacket (KeyFlagsPacket {}) = True
1803 isFlagsPacket _ = False
1804 subgrip = fingerprint (head parsedkey)
1805 back_sig <-
1806 pgpSign
1807 (Message parsedkey)
1808 (SubkeySignature
1809 wk
1810 (head parsedkey)
1811 (sigpackets 0x19 hashed0 [IssuerPacket subgrip]))
1812 (if key_algorithm (head parsedkey) == ECDSA
1813 then SHA256
1814 else SHA1)
1815 subgrip
1816 let iss = IssuerPacket (fingerprint wk)
1817 cons_iss back_sig =
1818 iss : map EmbeddedSignaturePacket (signatures_over back_sig)
1819 unhashed0 = maybe [iss] cons_iss back_sig
1820 new_sig <-
1821 pgpSign
1822 (Message [wkun])
1823 (SubkeySignature wk (head parsedkey) (sigpackets 0x18 hashed0 unhashed0))
1824 SHA1
1825 grip
1826 let newSig = do
1827 r <- addOrigin new_sig
1828 return $ fmap (, []) r
1829 flip (maybe newSig) mbsig $ \(mp, trustmap) -> do
1830 let sig = packet mp
1831 isCreation (SignatureCreationTimePacket {}) = True
1832 isCreation _ = False
1833 isExpiration (SignatureExpirationTimePacket {}) = True
1834 isExpiration _ = False
1835 (cs, ps) = partition isCreation (hashed_subpackets sig)
1836 (es, qs) = partition isExpiration ps
1837 stamp = listToMaybe . sortBy (comparing Down) $ map unwrap cs
1838 where
1839 unwrap (SignatureCreationTimePacket x) = x
1840 exp = listToMaybe $ sort $ map unwrap es
1841 where
1842 unwrap (SignatureExpirationTimePacket x) = x
1843 expires = liftA2 (+) stamp exp
1844 timestamp <- now
1845 if fmap ((< timestamp) . fromIntegral) expires == Just True
1846 then return $
1847 KikiSuccess ((mp, trustmap), [UnableToUpdateExpiredSignature])
1848 else do
1849 let times =
1850 (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $
1851 maybeToList $ do
1852 e <- expires
1853 return $
1854 SignatureExpirationTimePacket (e - fromIntegral timestamp)
1855 sig' = sig {hashed_subpackets = times ++ (qs `union` tags)}
1856 new_sig <-
1857 pgpSign
1858 (Message [wkun])
1859 (SubkeySignature wk (packet subkey_p) [sig'])
1860 SHA1
1861 (fingerprint wk)
1862 newsig <- addOrigin new_sig
1863 return $ fmap (, []) newsig
1864 1136
1865ifSecret :: Packet -> t -> t -> t 1137ifSecret :: Packet -> t -> t -> t
1866ifSecret (SecretKeyPacket {}) t f = t 1138ifSecret (SecretKeyPacket {}) t f = t
1867ifSecret _ t f = f 1139ifSecret _ t f = f
1868 1140
1869uidkey :: Packet -> String 1141instance ASN1Object RSAPrivateKey where
1870uidkey (UserIDPacket str) = str 1142 toASN1 rsa@(RSAPrivateKey {})
1871 1143 = \xs -> Start Sequence
1872keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags 1144 : IntVal 0
1873keyflags flgs@(KeyFlagsPacket {}) = 1145 : mpiVal rsaN
1874 Just . toEnum $ 1146 : mpiVal rsaE
1875 ( bit 0x1 certify_keys 1147 : mpiVal rsaD
1876 .|. bit 0x2 sign_data 1148 : mpiVal rsaP
1877 .|. bit 0x4 encrypt_communication 1149 : mpiVal rsaQ
1878 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags 1150 : mpiVal rsaDmodP1
1879 -- other flags: 1151 : mpiVal rsaDmodQminus1
1880 -- split_key 1152 : mpiVal rsaCoefficient
1881 -- authentication (ssh-client) 1153 : End Sequence
1882 -- group_key 1154 : xs
1883 where 1155 where mpiVal f = IntVal x where MPI x = f rsa
1884 bit v f = if f flgs then v else 0 1156
1885keyflags _ = Nothing 1157 fromASN1 ( Start Sequence
1158 : IntVal _ -- version
1159 : IntVal n
1160 : IntVal e
1161 : IntVal d
1162 : IntVal p
1163 : IntVal q
1164 : IntVal dmodp1
1165 : IntVal dmodqminus1
1166 : IntVal coefficient
1167 : ys) =
1168 Right ( privkey, tail $ dropWhile notend ys)
1169 where
1170 notend (End Sequence) = False
1171 notend _ = True
1172 privkey = RSAPrivateKey
1173 { rsaN = MPI n
1174 , rsaE = MPI e
1175 , rsaD = MPI d
1176 , rsaP = MPI p
1177 , rsaQ = MPI q
1178 , rsaDmodP1 = MPI dmodp1
1179 , rsaDmodQminus1 = MPI dmodqminus1
1180 , rsaCoefficient = MPI coefficient
1181 }
1182 fromASN1 _ =
1183 Left "fromASN1: RSAPrivateKey: unexpected format"
1184
1886 1185
1887readSecretPEMFile :: InputFile -> IO [SecretPEMData] 1186readSecretPEMFile :: InputFile -> IO [SecretPEMData]
1888readSecretPEMFile fname = do 1187readSecretPEMFile fname = do
@@ -1912,6 +1211,7 @@ readSecretPEMFile fname = do
1912 mergeDate (tm,_) (Right mb) = (tm,mb) 1211 mergeDate (tm,_) (Right mb) = (tm,mb)
1913 return $ dta 1212 return $ dta
1914 1213
1214
1915readSecretDNSFile :: InputFile -> IO Packet 1215readSecretDNSFile :: InputFile -> IO Packet
1916readSecretDNSFile fname = do 1216readSecretDNSFile fname = do
1917 let ctx = InputFileContext "" "" 1217 let ctx = InputFileContext "" ""
@@ -1992,97 +1292,6 @@ socketFamily (SockAddrUnix _) = AF_UNIX
1992selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet 1292selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1993selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db 1293selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
1994 1294
1995isBracket :: Char -> Bool
1996isBracket '<' = True
1997isBracket '>' = True
1998isBracket _ = False
1999
2000unk :: Bool -> MappedPacket -> MappedPacket
2001unk isPublic = if isPublic then toPacket secretToPublic else id
2002 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
2003
2004concatSort ::
2005 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
2006concatSort fname getp f = concat . sortByHint fname getp . map f
2007
2008flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
2009flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
2010
2011rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
2012rsaKeyFromPacket p | isKey p = do
2013 n <- lookup 'n' $ key p
2014 e <- lookup 'e' $ key p
2015 return $ RSAKey n e
2016
2017rsaKeyFromPacket _ = Nothing
2018
2019disjoint_fp :: [Packet] -> [[Packet]]
2020disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
2021 where
2022 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
2023 samepr a b = smallpr a == smallpr b
2024
2025 {-
2026 -- useful for testing
2027 group2 :: [a] -> [[a]]
2028 group2 (x:y:ys) = [x,y]:group2 ys
2029 group2 [x] = [[x]]
2030 group2 [] = []
2031 -}
2032
2033verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver])
2034verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
2035 where
2036 verified = do
2037 sig <- signatures (Message nonkeys)
2038 let v = verify (Message keys) sig
2039 guard (not . null $ signatures_over v)
2040 return v
2041 (top,othersigs) = partition isSubkeySignature verified
2042 embedded = do
2043 sub <- top
2044 let sigover = signatures_over sub
2045 unhashed = sigover >>= unhashed_subpackets
2046 subsigs = mapMaybe backsig unhashed
2047 -- This should consist only of 0x19 values
2048 -- subtypes = map signature_type subsigs
2049 -- trace ("subtypes = "++show subtypes) (return ())
2050 -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
2051 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
2052 let v = verify (Message [subkey sub]) sig
2053 guard (not . null $ signatures_over v)
2054 return v
2055
2056flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
2057flattenUid fname ispub (str,(sigs,om)) =
2058 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
2059
2060-- | Get the time stamp of a signature.
2061--
2062-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
2063-- the hashed section. TODO: change this?
2064--
2065signature_time :: SignatureOver -> Word32
2066signature_time ov = case (if null cs then ds else cs) of
2067 [] -> minBound
2068 xs -> maximum xs
2069 where
2070 ps = signatures_over ov
2071 ss = filter isSignaturePacket ps
2072 cs = concatMap (concatMap creationTime . hashed_subpackets) ss
2073 ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
2074 creationTime (SignatureCreationTimePacket t) = [t]
2075 creationTime _ = []
2076
2077splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
2078splitAtMinBy comp xs = minimumBy comp' xxs
2079 where
2080 xxs = zip (inits xs) (tails xs)
2081 comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
2082 compM (Just a) (Just b) = comp a b
2083 compM Nothing mb = GT
2084 compM _ _ = LT
2085
2086parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert 1295parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert
2087parseCertBlob comp bs = do 1296parseCertBlob comp bs = do
2088 asn1 <- either (const Nothing) Just 1297 asn1 <- either (const Nothing) Just
@@ -2171,15 +1380,18 @@ extractRSAKeyFields kvs = do
2171 , rsaCoefficient = u } 1380 , rsaCoefficient = u }
2172 where 1381 where
2173 parseField blob = MPI <$> m 1382 parseField blob = MPI <$> m
1383#if defined(VERSION_memory)
1384 where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob)
1385 bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
1386 where
1387 nlen = S.length bs
1388#elif defined(VERSION_dataenc)
2174 where m = bigendian <$> Base64.decode (Char8.unpack blob) 1389 where m = bigendian <$> Base64.decode (Char8.unpack blob)
2175
2176 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs 1390 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
2177 where 1391 where
2178 nlen = length bs 1392 nlen = length bs
1393#endif
2179 1394
2180backsig :: SignatureSubpacket -> Maybe Packet
2181backsig (EmbeddedSignaturePacket s) = Just s
2182backsig _ = Nothing
2183 1395
2184selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet 1396selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
2185selectKey0 wantPublic (spec,mtag) db = do 1397selectKey0 wantPublic (spec,mtag) db = do
@@ -2190,27 +1402,7 @@ selectKey0 wantPublic (spec,mtag) db = do
2190 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 1402 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
2191 [] -> Nothing 1403 [] -> Nothing
2192 1404
2193sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] 1405-- TODO: Data.ByteString.Lazy now exports this.
2194sortByHint fname f = sortBy (comparing gethint)
2195 where
2196 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
2197 defnum = -1
2198
2199unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
2200unsig fname isPublic (sig,trustmap) =
2201 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
2202 where
2203 f n _ = n==fname -- && trace ("fname=n="++show n) True
2204 asMapped n p = let m = mappedPacket fname p
2205 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
2206
2207smallpr :: Packet -> [Char]
2208smallpr k = drop 24 $ fingerprint k
2209
2210isSubkeySignature :: SignatureOver -> Bool
2211isSubkeySignature (SubkeySignature {}) = True
2212isSubkeySignature _ = False
2213
2214toStrict :: L.ByteString -> S.ByteString 1406toStrict :: L.ByteString -> S.ByteString
2215toStrict = foldr1 (<>) . L.toChunks 1407toStrict = foldr1 (<>) . L.toChunks
2216 1408
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs
new file mode 100644
index 0000000..2383140
--- /dev/null
+++ b/lib/KeyRing/Types.hs
@@ -0,0 +1,394 @@
1{-# LANGUAGE DeriveFunctor #-}
2module KeyRing.Types where
3
4import Data.Char (isLower,toLower)
5import Data.List (groupBy)
6import Data.Map as Map (Map)
7import qualified Data.Map as Map
8import Data.OpenPGP
9import Data.OpenPGP.Util
10import Data.Time.Clock
11import FunctorToMaybe
12import qualified Data.ByteString.Lazy as L
13import qualified System.Posix.Types as Posix
14
15-- | This type describes an idempotent transformation (merge or import) on a
16-- set of GnuPG keyrings and other key files.
17data KeyRingOperation = KeyRingOperation
18 { opFiles :: Map InputFile StreamInfo
19 -- ^ Indicates files to be read or updated.
20 , opPassphrases :: [PassphraseSpec]
21 -- ^ Indicates files or file descriptors where passphrases can be found.
22 , opTransforms :: [Transform]
23 -- ^ Transformations to be performed on the key pool after all files have
24 -- been read and before any have been written.
25 , opHome :: Maybe FilePath
26 -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub'
27 -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted
28 -- and if that is not set, it falls back to $HOME/.gnupg.
29 }
30 deriving (Eq,Show)
31
32data InputFile = HomeSec
33 -- ^ A file named secring.gpg located in the home directory.
34 -- See 'opHome'.
35 | HomePub
36 -- ^ A file named pubring.gpg located in the home directory.
37 -- See 'opHome'.
38 | ArgFile FilePath
39 -- ^ Contents will be read or written from the specified path.
40 | FileDesc Posix.Fd
41 -- ^ Contents will be read or written from the specified file
42 -- descriptor.
43 | Pipe Posix.Fd Posix.Fd
44 -- ^ Contents will be read from the first descriptor and updated
45 -- content will be writen to the second. Note: Don't use Pipe
46 -- for 'Wallet' files. (TODO: Wallet support)
47 | Generate Int GenerateKeyParams
48 -- ^ New key packets will be generated if there is no
49 -- matching content already in the key pool. The integer is
50 -- a unique id number so that multiple generations can be
51 -- inserted into 'opFiles'
52 deriving (Eq,Ord,Show)
53
54-- | This type describes how 'runKeyRing' will treat a file.
55data StreamInfo = StreamInfo
56 { access :: Access
57 -- ^ Indicates whether the file is allowed to contain secret information.
58 , typ :: FileType
59 -- ^ Indicates the format and content type of the file.
60 , fill :: KeyFilter
61 -- ^ This filter controls what packets will be inserted into a file.
62 , spill :: KeyFilter
63 --
64 -- ^ Use this to indicate whether or not a file's contents should be
65 -- available for updating other files. Note that although its type is
66 -- 'KeyFilter', it is usually interpretted as a boolean flag. Details
67 -- depend on 'typ' and are as follows:
68 --
69 -- 'KeyRingFile':
70 --
71 -- * 'KF_None' - The file's contents will not be shared.
72 --
73 -- * otherwise - The file's contents will be shared.
74 --
75 -- 'PEMFile':
76 --
77 -- * 'KF_None' - The file's contents will not be shared.
78 --
79 -- * 'KF_Match' - The file's key will be shared with the specified owner
80 -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be
81 -- equal to this value; changing the usage or owner of a key is not
82 -- supported via the fill/spill mechanism.
83 --
84 -- * otherwise - Unspecified. Do not use.
85 --
86 -- 'WalletFile':
87 --
88 -- * The 'spill' setting is ignored and the file's contents are shared.
89 -- (TODO)
90 --
91 -- 'Hosts':
92 --
93 -- * The 'spill' setting is ignored and the file's contents are shared.
94 -- (TODO)
95 --
96 , initializer :: Initializer
97 -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set,
98 -- then it is interpretted as a shell command that may be used to create
99 -- the key if it does not exist.
100 , transforms :: [Transform]
101 -- ^ Per-file transformations that occur before the contents of a file are
102 -- spilled into the common pool.
103 }
104 deriving (Eq,Show)
105
106
107-- | This type is used to indicate where to obtain passphrases.
108data PassphraseSpec = PassphraseSpec
109 { passSpecRingFile :: Maybe FilePath
110 -- ^ If not Nothing, the passphrase is to be used for packets
111 -- from this file.
112 , passSpecKeySpec :: Maybe String
113 -- ^ Non-Nothing value reserved for future use.
114 -- (TODO: Use this to implement per-key passphrase associations).
115 , passSpecPassFile :: InputFile
116 -- ^ The passphrase will be read from this file or file descriptor.
117 }
118 -- | Use this to carry pasphrases from a previous run.
119 | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder }
120 | PassphraseAgent
121
122instance Show PassphraseSpec where
123 show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
124 show (PassphraseMemoizer _) = "PassphraseMemoizer"
125instance Eq PassphraseSpec where
126 PassphraseSpec a b c == PassphraseSpec d e f
127 = and [a==d,b==e,c==f]
128 _ == _
129 = False
130
131-- Ord instance for PassphraseSpec generally orders by generality with the most
132-- general being greatest and the least general being least. The one exception
133-- is the 'PassphraseMemoizer' which is considered least of all even though it
134-- is very general. This is so an existing memoizer will be tried first, and
135-- if there is none, one will be created that tries the others in order of
136-- increasing generality. Key-specialization is considered less general than
137-- file-specialization.
138instance Ord PassphraseSpec where
139 compare (PassphraseMemoizer _) (PassphraseMemoizer _) = EQ
140 compare PassphraseAgent PassphraseAgent = EQ
141 compare (PassphraseMemoizer _) _ = LT
142 compare (PassphraseSpec a b c) (PassphraseSpec d e f)
143 | fmap (const ()) a == fmap (const ()) d
144 && fmap (const ()) b == fmap (const ()) e = compare (a,b,c) (d,e,f)
145 compare (PassphraseSpec (Just _) (Just _) _) _ = LT
146 compare (PassphraseSpec Nothing (Just _) _) _ = LT
147 compare (PassphraseSpec (Just _) _ _) _ = LT
148 compare PassphraseAgent _ = GT
149
150data Transform =
151 Autosign
152 -- ^ This operation will make signatures for any tor-style UID
153 -- that matches a tor subkey and thus can be authenticated without
154 -- requring the judgement of a human user.
155 --
156 -- A tor-style UID is one of the following form:
157 --
158 -- > Anonymous <root@HOSTNAME.onion>
159 | DeleteSubkeyByFingerprint String
160 -- ^ Delete the subkey specified by the given fingerprint and any
161 -- associated signatures on that key.
162 | DeleteSubkeyByUsage String
163 -- ^ Delete the subkey specified by the given usage tag and any
164 -- associated signatures on that key.
165 | RenameSubkeys String String
166 -- ^ Replace all subkey signatures matching the first usage tag with
167 -- fresh signatures that match the second usage tag.
168 deriving (Eq,Ord,Show)
169
170-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
171-- to contain secret or public PGP key packets. Note that it is not supported
172-- to mix both in the same file and that the secret key packets include all of
173-- the information contained in their corresponding public key packets.
174data Access = AutoAccess -- ^ secret or public as appropriate based on existing content.
175 -- (see 'rtRingAccess')
176 | Sec -- ^ secret information
177 | Pub -- ^ public information
178 deriving (Eq,Ord,Show)
179
180data FileType = KeyRingFile
181 | PEMFile
182 | WalletFile
183 | DNSPresentation
184 | Hosts
185 | SshFile
186 deriving (Eq,Ord,Enum,Show)
187
188-- type UsageTag = String
189data Initializer = NoCreate | Internal GenerateKeyParams | External String | WarnMissing String
190 deriving (Eq,Ord,Show)
191
192
193
194type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet)
195type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet)
196
197-- | Note that the documentation here is intended for when this value is
198-- assigned to 'fill'. For other usage, see 'spill'.
199data KeyFilter = KF_None -- ^ No keys will be imported.
200 | KF_Match String -- ^ Only the key that matches the spec will be imported.
201 | KF_Subkeys -- ^ Subkeys will be imported if their owner key is
202 -- already in the ring. TODO: Even if their signatures
203 -- are bad?
204 | KF_Authentic -- ^ Keys are imported if they belong to an authenticated
205 -- identity (signed or self-authenticating).
206 | KF_All -- ^ All keys will be imported.
207 deriving (Eq,Ord,Show)
208
209-- | The position and acces a packet had before the operation
210data OriginFlags = OriginFlags
211 { originallyPublic :: Bool
212 -- ^ false if SecretKeyPacket
213 , originalNum :: Int
214 -- ^ packets are numbered, starting from 1..
215 } deriving Show
216
217type OriginMap = Map FilePath OriginFlags
218
219type MappedPacket = OriginMapped Packet
220data OriginMapped a = MappedPacket
221 { packet :: a
222 , locations :: OriginMap
223 } deriving Show
224instance Functor OriginMapped where
225 fmap f (MappedPacket x ls) = MappedPacket (f x) ls
226
227origin :: Packet -> Int -> OriginFlags
228origin p n = OriginFlags ispub n
229 where
230 ispub = case p of
231 SecretKeyPacket {} -> False
232 _ -> True
233
234mappedPacket :: FilePath -> Packet -> MappedPacket
235mappedPacket filename p = MappedPacket
236 { packet = p
237 , locations = Map.singleton filename (origin p (-1))
238 }
239
240mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
241mappedPacketWithHint filename p hint = MappedPacket
242 { packet = p
243 , locations = Map.singleton filename (origin p hint)
244 }
245
246
247-- | This type is used to indicate success or failure
248-- and in the case of success, return the computed object.
249-- The 'FunctorToMaybe' class is implemented to facilitate
250-- branching on failture.
251data KikiCondition a = KikiSuccess a
252 | FailedToLock [FilePath]
253 | BadPassphrase
254 | FailedToMakeSignature
255 | CantFindHome
256 | AmbiguousKeySpec FilePath
257 | CannotImportMasterKey
258 | NoWorkingKey
259 | AgentConnectionFailure
260 | OperationCanceled
261 deriving ( Functor, Show )
262
263instance FunctorToMaybe KikiCondition where
264 functorToMaybe (KikiSuccess a) = Just a
265 functorToMaybe _ = Nothing
266
267instance Applicative KikiCondition where
268 pure a = KikiSuccess a
269 f <*> a =
270 case functorToEither f of
271 Right f -> case functorToEither a of
272 Right a -> pure (f a)
273 Left err -> err
274 Left err -> err
275
276uncamel :: String -> String
277uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
278 where
279 (.:) = fmap . fmap
280 ( firstWord ,
281 otherWords ) = splitAt 1 ws
282 ws = camel >>= groupBy (\_ c -> isLower c)
283 ( camel, args) = splitAt 1 $ words str
284
285errorString :: KikiCondition a -> String
286errorString (KikiSuccess {}) = "success"
287errorString e = uncamel . show $ fmap (const ()) e
288
289
290
291data InputFileContext = InputFileContext
292 { homesecPath :: FilePath
293 , homepubPath :: FilePath
294 }
295
296
297-- | The 'KeyKey'-type is used to store the information of a key
298-- which is used for finger-printing and as a lookup key into
299-- maps. This type may be changed to an actual fingerprint in
300-- in the future.
301type KeyKey = [L.ByteString]
302
303keykey :: Packet -> KeyKey
304keykey key =
305 -- Note: The key's timestamp is normally included in it's fingerprint.
306 -- This is undesirable for kiki because it causes the same
307 -- key to be imported multiple times and show as apparently
308 -- distinct keys with different fingerprints.
309 -- Thus, we will remove the timestamp.
310 fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
311
312isKey :: Packet -> Bool
313isKey (PublicKeyPacket {}) = True
314isKey (SecretKeyPacket {}) = True
315isKey _ = False
316
317isSecretKey :: Packet -> Bool
318isSecretKey (SecretKeyPacket {}) = True
319isSecretKey _ = False
320
321
322isUserID :: Packet -> Bool
323isUserID (UserIDPacket {}) = True
324isUserID _ = False
325
326isTrust :: Packet -> Bool
327isTrust (TrustPacket {}) = True
328isTrust _ = False
329
330-- matchpr computes the fingerprint of the given key truncated to
331-- be the same lenght as the given fingerprint for comparison.
332--
333-- matchpr fp = Data.List.Extra.takeEnd (length fp)
334--
335matchpr :: String -> Packet -> String
336matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
337
338
339
340
341data KeySpec =
342 KeyGrip String -- fp:
343 | KeyTag Packet String -- fp:????/t:
344 | KeyUidMatch String -- u:
345 deriving Show
346
347{-
348RSAPrivateKey ::= SEQUENCE {
349 version Version,
350 modulus INTEGER, -- n
351 publicExponent INTEGER, -- e
352 privateExponent INTEGER, -- d
353 prime1 INTEGER, -- p
354 prime2 INTEGER, -- q
355 exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1)
356 exponent2 INTEGER, -- d mod (q-1)
357 coefficient INTEGER, -- (inverse of q) mod p
358 otherPrimeInfos OtherPrimeInfos OPTIONAL
359 }
360-}
361data RSAPrivateKey = RSAPrivateKey
362 { rsaN :: MPI
363 , rsaE :: MPI
364 , rsaD :: MPI
365 , rsaP :: MPI
366 , rsaQ :: MPI
367 , rsaDmodP1 :: MPI
368 , rsaDmodQminus1 :: MPI
369 , rsaCoefficient :: MPI
370 }
371 deriving Show
372
373data ParsedCert = ParsedCert
374 { pcertKey :: Packet
375 , pcertTimestamp :: UTCTime
376 , pcertBlob :: L.ByteString
377 }
378 deriving (Show,Eq)
379
380data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
381 deriving (Eq,Ord,Enum,Show,Read)
382
383data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
384 deriving (Show,Eq)
385
386data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum)
387
388data SingleKeySpec = FingerprintMatch String
389 | SubstringMatch (Maybe MatchingField) String
390 | EmptyMatch
391 | AnyMatch
392 | WorkingKeyMatch
393 deriving (Show,Eq,Ord)
394
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 10:15:59 +0000