summaryrefslogtreecommitdiff
path: root/KeyRing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'KeyRing.hs')
-rw-r--r--KeyRing.hs112
1 files changed, 54 insertions, 58 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index b0e24de..5149da4 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -99,7 +99,7 @@ data FileType = KeyRingFile (Maybe PassWordFile)
99-- | RefType is perhaps not a good name for this... 99-- | RefType is perhaps not a good name for this...
100-- It is sort of like a read/write flag, although 100-- It is sort of like a read/write flag, although
101-- semantically, it is indicating the intention of 101-- semantically, it is indicating the intention of
102-- an action and not just the access level of an 102-- an action and not just the access level of an
103-- object. 103-- object.
104data RefType = ConstRef 104data RefType = ConstRef
105 -- ^ merge into database but do not update 105 -- ^ merge into database but do not update
@@ -149,7 +149,7 @@ noManip _ _ = []
149data KeyRingOperation = KeyRingOperation 149data KeyRingOperation = KeyRingOperation
150 { kFiles :: Map.Map InputFile (RefType,FileType) 150 { kFiles :: Map.Map InputFile (RefType,FileType)
151 , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool) 151 , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool)
152 -- ^ 152 -- ^
153 -- Indicates what pgp master keys get written to which keyring files. 153 -- Indicates what pgp master keys get written to which keyring files.
154 -- Just True = import public key 154 -- Just True = import public key
155 -- Just False = import secret key 155 -- Just False = import secret key
@@ -488,7 +488,7 @@ keyFlags0 wkun uidsigs = concat
488 isfeatures _ = False 488 isfeatures _ = False
489 489
490 490
491matchSpec (KeyGrip grip) (_,KeyData p _ _ _) 491matchSpec (KeyGrip grip) (_,KeyData p _ _ _)
492 | matchpr grip (packet p)==grip = True 492 | matchpr grip (packet p)==grip = True
493 | otherwise = False 493 | otherwise = False
494 494
@@ -608,7 +608,7 @@ selectAll wantPublic (spec,mtag) db = do
608 y <- take 1 ys 608 y <- take 1 ys
609 case mtag of 609 case mtag of
610 Nothing -> return (y,Nothing) 610 Nothing -> return (y,Nothing)
611 Just tag -> 611 Just tag ->
612 let search ys1 = do 612 let search ys1 = do
613 let zs = snd $ seek_key (KeyTag y tag) ys1 613 let zs = snd $ seek_key (KeyTag y tag) ys1
614 z <- take 1 zs 614 z <- take 1 zs
@@ -664,12 +664,12 @@ cachedContents secring pubring fd = do
664 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs 664 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
665 665
666 get ref fd = do 666 get ref fd = do
667 pw <- readIORef ref 667 pw <- readIORef ref
668 flip (flip maybe return) pw $ do 668 flip (flip maybe return) pw $ do
669 pw <- fmap trimCR $ getContents fd 669 pw <- fmap trimCR $ getContents fd
670 writeIORef ref (Just pw) 670 writeIORef ref (Just pw)
671 return pw 671 return pw
672 672
673 getContents (FileDesc fd) = fdToHandle fd >>= S.hGetContents 673 getContents (FileDesc fd) = fdToHandle fd >>= S.hGetContents
674 getContents inp = do 674 getContents inp = do
675 let fname = resolveInputFile secring pubring inp 675 let fname = resolveInputFile secring pubring inp
@@ -677,7 +677,7 @@ cachedContents secring pubring fd = do
677 677
678importPEMKey doDecrypt db' tup = do 678importPEMKey doDecrypt db' tup = do
679 try db' $ \(db',report0) -> do 679 try db' $ \(db',report0) -> do
680 r <- doImport doDecrypt 680 r <- doImport doDecrypt
681 db' 681 db'
682 tup 682 tup
683 try r $ \(db'',report) -> do 683 try r $ \(db'',report) -> do
@@ -688,7 +688,7 @@ buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet))
688 -> IO (KikiCondition ((KeyDB,Maybe String,Maybe MappedPacket) 688 -> IO (KikiCondition ((KeyDB,Maybe String,Maybe MappedPacket)
689 ,[(FilePath,KikiReportAction)])) 689 ,[(FilePath,KikiReportAction)]))
690buildKeyDB doDecrypt secring pubring grip0 keyring = do 690buildKeyDB doDecrypt secring pubring grip0 keyring = do
691 let 691 let
692 692
693 files isring = do 693 files isring = do
694 (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring) 694 (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring)
@@ -701,7 +701,7 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do
701 701
702 importWalletKey wk db' (top,fname,sub,tag) = do 702 importWalletKey wk db' (top,fname,sub,tag) = do
703 try db' $ \(db',report0) -> do 703 try db' $ \(db',report0) -> do
704 r <- doImportG doDecrypt 704 r <- doImportG doDecrypt
705 db' 705 db'
706 (fmap keykey $ maybeToList wk) 706 (fmap keykey $ maybeToList wk)
707 tag 707 tag
@@ -715,7 +715,7 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do
715 ms <- mapM readp (files isring) 715 ms <- mapM readp (files isring)
716 let grip = grip0 `mplus` (fingerprint <$> fstkey) 716 let grip = grip0 `mplus` (fingerprint <$> fstkey)
717 where 717 where
718 fstkey = listToMaybe $ mapMaybe isSecringKey ms 718 fstkey = listToMaybe $ mapMaybe isSecringKey ms
719 where isSecringKey (fn,Message ps) 719 where isSecringKey (fn,Message ps)
720 | fn==secring = listToMaybe ps 720 | fn==secring = listToMaybe ps
721 isSecringKey _ = Nothing 721 isSecringKey _ = Nothing
@@ -774,7 +774,7 @@ readKeyFromFile False "PEM" fname = do
774 -- warn $ fname ++ ": reading ..." 774 -- warn $ fname ++ ": reading ..."
775 -- Note: The key's timestamp is included in it's fingerprint. 775 -- Note: The key's timestamp is included in it's fingerprint.
776 -- Therefore, we should attempt to preserve it. 776 -- Therefore, we should attempt to preserve it.
777 timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 777 timestamp <- handleIO_ (error $ fname++": modificaiton time?") $
778 modificationTime <$> getFileStatus fname 778 modificationTime <$> getFileStatus fname
779 input <- L.readFile fname 779 input <- L.readFile fname
780 let dta = extractPEM "RSA PRIVATE KEY" input 780 let dta = extractPEM "RSA PRIVATE KEY" input
@@ -855,7 +855,7 @@ doImportG doDecrypt db m0 tag fname key = do
855 ( (False,) . addOrigin ) 855 ( (False,) . addOrigin )
856 (Map.lookup subkk subs) 856 (Map.lookup subkk subs)
857 where 857 where
858 addOrigin (SubKey mp sigs) = 858 addOrigin (SubKey mp sigs) =
859 let mp' = mp 859 let mp' = mp
860 { locations = Map.insert fname 860 { locations = Map.insert fname
861 (origin (packet mp) (-1)) 861 (origin (packet mp) (-1))
@@ -892,7 +892,7 @@ doImportG doDecrypt db m0 tag fname key = do
892 $ \sig -> do 892 $ \sig -> do
893 let om = Map.singleton fname (origin sig (-1)) 893 let om = Map.singleton fname (origin sig (-1))
894 trust = Map.empty 894 trust = Map.empty
895 return $ KikiSuccess 895 return $ KikiSuccess
896 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} 896 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
897 , trust)],om) uids 897 , trust)],om) uids
898 , [] ) 898 , [] )
@@ -990,7 +990,7 @@ ifSecret (SecretKeyPacket {}) t f = t
990ifSecret _ t f = f 990ifSecret _ t f = f
991 991
992showPacket :: Packet -> String 992showPacket :: Packet -> String
993showPacket p | isKey p = (if is_subkey p 993showPacket p | isKey p = (if is_subkey p
994 then showPacket0 p 994 then showPacket0 p
995 else ifSecret p "----Secret-----" "----Public-----") 995 else ifSecret p "----Secret-----" "----Public-----")
996 ++ " "++show (key_algorithm p)++" "++fingerprint p 996 ++ " "++show (key_algorithm p)++" "++fingerprint p
@@ -1059,7 +1059,7 @@ writeRingKeys krd rt {- db wk secring pubring -} = do
1059 let (towrites,report) = (\f -> foldl f ([],[]) s) $ 1059 let (towrites,report) = (\f -> foldl f ([],[]) s) $
1060 \(ws,report) ((f,mutable),(new_packets,x)) -> 1060 \(ws,report) ((f,mutable),(new_packets,x)) ->
1061 if mutable 1061 if mutable
1062 then 1062 then
1063 let rs = flip map new_packets 1063 let rs = flip map new_packets
1064 $ \c -> (f, NewPacket $ showPacket (packet c)) 1064 $ \c -> (f, NewPacket $ showPacket (packet c))
1065 in (ws++[(f,x)],report++rs) 1065 in (ws++[(f,x)],report++rs)
@@ -1090,7 +1090,7 @@ subkeysForExport subspec (KeyData key _ _ subkeys) = do
1090 doSearch key tag (SubKey sub_mp sigtrusts) = 1090 doSearch key tag (SubKey sub_mp sigtrusts) =
1091 let (_,v,_) = findTag tag 1091 let (_,v,_) = findTag tag
1092 (packet key) 1092 (packet key)
1093 (packet sub_mp) 1093 (packet sub_mp)
1094 sigtrusts 1094 sigtrusts
1095 in fmap fst v==Just True 1095 in fmap fst v==Just True
1096 1096
@@ -1119,11 +1119,11 @@ rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
1119 -- Ideally, it would be better to compute (inverse q) mod p 1119 -- Ideally, it would be better to compute (inverse q) mod p
1120 -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg 1120 -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg
1121 -- (package constructive-algebra) 1121 -- (package constructive-algebra)
1122 coefficient <- lookup 'u' $ key pkt 1122 coefficient <- lookup 'u' $ key pkt
1123 1123
1124 let dmodp1 = MPI $ d `mod` (p - 1) 1124 let dmodp1 = MPI $ d `mod` (p - 1)
1125 dmodqminus1 = MPI $ d `mod` (q - 1) 1125 dmodqminus1 = MPI $ d `mod` (q - 1)
1126 return $ RSAPrivateKey 1126 return $ RSAPrivateKey
1127 { rsaN = n 1127 { rsaN = n
1128 , rsaE = e 1128 , rsaE = e
1129 , rsaD = MPI d 1129 , rsaD = MPI d
@@ -1222,8 +1222,8 @@ performManipulations ::
1222 (MappedPacket -> IO (KikiCondition Packet)) 1222 (MappedPacket -> IO (KikiCondition Packet))
1223 -> KeyRingOperation 1223 -> KeyRingOperation
1224 -> KeyRingRuntime 1224 -> KeyRingRuntime
1225 -> Maybe MappedPacket 1225 -> Maybe MappedPacket
1226 -> IO (KikiCondition (KeyDB,[(FilePath,KikiReportAction)])) 1226 -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)]))
1227performManipulations doDecrypt operation rt wk = do 1227performManipulations doDecrypt operation rt wk = do
1228 let db = rtKeyDB rt 1228 let db = rtKeyDB rt
1229 db <- let perform kd (InducerSignature uid subpaks) = do 1229 db <- let perform kd (InducerSignature uid subpaks) = do
@@ -1241,8 +1241,8 @@ performManipulations doDecrypt operation rt wk = do
1241 , om `Map.union` snd x ) 1241 , om `Map.union` snd x )
1242 om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid 1242 om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
1243 toMappedPacket om p = (mappedPacket "" p) {locations=om} 1243 toMappedPacket om p = (mappedPacket "" p) {locations=om}
1244 selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard 1244 selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
1245 . (== keykey whosign) 1245 . (== keykey whosign)
1246 . keykey)) vs 1246 . keykey)) vs
1247 keys = map keyPacket $ Map.elems (rtKeyDB rt) 1247 keys = map keyPacket $ Map.elems (rtKeyDB rt)
1248 overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig]) 1248 overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
@@ -1250,21 +1250,21 @@ performManipulations doDecrypt operation rt wk = do
1250 , Maybe SignatureOver -- Nothing means non-verified 1250 , Maybe SignatureOver -- Nothing means non-verified
1251 , Packet ) -- key who signed 1251 , Packet ) -- key who signed
1252 ] 1252 ]
1253 vs = do 1253 vs = do
1254 x <- maybeToList $ Map.lookup uid (rentryUids kd) 1254 x <- maybeToList $ Map.lookup uid (rentryUids kd)
1255 sig <- map (packet . fst) (fst x) 1255 sig <- map (packet . fst) (fst x)
1256 o <- overs sig 1256 o <- overs sig
1257 k <- keys 1257 k <- keys
1258 let ov = verify (Message [k]) $ o 1258 let ov = verify (Message [k]) $ o
1259 signatures_over ov 1259 signatures_over ov
1260 return (sig,Just ov,k) 1260 return (sig,Just ov,k)
1261 additional new_sig = do 1261 additional new_sig = do
1262 new_sig <- maybeToList new_sig 1262 new_sig <- maybeToList new_sig
1263 guard (null $ selfsigs) 1263 guard (null $ selfsigs)
1264 signatures_over new_sig 1264 signatures_over new_sig
1265 return kd { rentryUids = Map.adjust f uid (rentryUids kd) } 1265 return kd { rentryUids = Map.adjust f uid (rentryUids kd) }
1266 in Traversable.mapM (\kd -> foldM perform kd (kManip operation rt kd)) db 1266 in Traversable.mapM (\kd -> foldM perform kd (kManip operation rt kd)) db
1267 return $ KikiSuccess (db,[]) 1267 return $ KikiSuccess (rt { rtKeyDB = db },[])
1268 1268
1269 1269
1270initializeMissingPEMFiles :: 1270initializeMissingPEMFiles ::
@@ -1278,7 +1278,7 @@ initializeMissingPEMFiles ::
1278 , Maybe Initializer)]) 1278 , Maybe Initializer)])
1279 , [(FilePath,KikiReportAction)])) 1279 , [(FilePath,KikiReportAction)]))
1280initializeMissingPEMFiles operation secring pubring grip decrypt db = do 1280initializeMissingPEMFiles operation secring pubring grip decrypt db = do
1281 nonexistents <- 1281 nonexistents <-
1282 filterM (fmap not . doesFileExist . fst) 1282 filterM (fmap not . doesFileExist . fst)
1283 $ do (f,t) <- Map.toList (kFiles operation) 1283 $ do (f,t) <- Map.toList (kFiles operation)
1284 f <- resolveInputFile secring pubring f 1284 f <- resolveInputFile secring pubring f
@@ -1306,7 +1306,7 @@ initializeMissingPEMFiles operation secring pubring grip decrypt db = do
1306 1306
1307 ifnotnull (x:xs) f g = f x 1307 ifnotnull (x:xs) f g = f x
1308 ifnotnull _ f g = g 1308 ifnotnull _ f g = g
1309 1309
1310 ifnotnull ambiguous ambiguity $ do 1310 ifnotnull ambiguous ambiguity $ do
1311 1311
1312 -- create nonexistent files via external commands 1312 -- create nonexistent files via external commands
@@ -1378,6 +1378,7 @@ runKeyRing operation = do
1378 secring pubring grip 1378 secring pubring grip
1379 decrypt 1379 decrypt
1380 db 1380 db
1381 try' externals_ret $ \((db,exports),report_externals) -> do
1381 1382
1382 let rt = KeyRingRuntime 1383 let rt = KeyRingRuntime
1383 { rtPubring = pubring 1384 { rtPubring = pubring
@@ -1387,24 +1388,19 @@ runKeyRing operation = do
1387 , rtKeyDB = db 1388 , rtKeyDB = db
1388 } 1389 }
1389 1390
1390 try' externals_ret $ \((db,exports),report_externals) -> do 1391 r <- performManipulations decrypt
1391
1392
1393
1394 r <- performManipulations decrypt
1395 operation 1392 operation
1396 rt 1393 rt
1397 wk 1394 wk
1398 try' r $ \(db,report_manips) -> do 1395 try' r $ \(rt,report_manips) -> do
1399 rt <- return $ rt { rtKeyDB = db }
1400 1396
1401 r <- writeWalletKeys operation db (fmap packet wk) 1397 r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)
1402 try' r $ \report_wallets -> do 1398 try' r $ \report_wallets -> do
1403 1399
1404 r <- writeRingKeys operation rt -- db wk secring pubring 1400 r <- writeRingKeys operation rt -- db wk secring pubring
1405 try' r $ \report_rings -> do 1401 try' r $ \report_rings -> do
1406 1402
1407 r <- writePEMKeys decrypt db exports 1403 r <- writePEMKeys decrypt (rtKeyDB rt) exports
1408 try' r $ \report_pems -> do 1404 try' r $ \report_pems -> do
1409 1405
1410 return $ KikiResult (KikiSuccess rt) 1406 return $ KikiResult (KikiSuccess rt)
@@ -1452,7 +1448,7 @@ getHomeDir protohome = do
1452 let homegnupg = (++('/':(appdir home))) <$> homed 1448 let homegnupg = (++('/':(appdir home))) <$> homed
1453 let val = (opt `mplus` gnupghome `mplus` homegnupg) 1449 let val = (opt `mplus` gnupghome `mplus` homegnupg)
1454 return $ val 1450 return $ val
1455 1451
1456 -- TODO: rename this to getGrip 1452 -- TODO: rename this to getGrip
1457 getWorkingKey homedir = do 1453 getWorkingKey homedir = do
1458 let o = Nothing 1454 let o = Nothing
@@ -1516,10 +1512,10 @@ slurpWIPKeys stamp "" = ([],[])
1516slurpWIPKeys stamp cs = 1512slurpWIPKeys stamp cs =
1517 let (b58,xs) = Char8.span (\x -> elem x base58chars) cs 1513 let (b58,xs) = Char8.span (\x -> elem x base58chars) cs
1518 mb = decode_btc_key stamp (Char8.unpack b58) 1514 mb = decode_btc_key stamp (Char8.unpack b58)
1519 in if L.null b58 1515 in if L.null b58
1520 then let (ys,xs') = Char8.break (\x -> elem x base58chars) cs 1516 then let (ys,xs') = Char8.break (\x -> elem x base58chars) cs
1521 (ks,js) = slurpWIPKeys stamp xs' 1517 (ks,js) = slurpWIPKeys stamp xs'
1522 in (ks,ys:js) 1518 in (ks,ys:js)
1523 else let (ks,js) = slurpWIPKeys stamp xs 1519 else let (ks,js) = slurpWIPKeys stamp xs
1524 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb 1520 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
1525 1521
@@ -1548,7 +1544,7 @@ decode_btc_key timestamp str = do
1548 ,"y ="++show y 1544 ,"y ="++show y
1549 ,"y' ="++show y' 1545 ,"y' ="++show y'
1550 ,"y''="++show y'']) -} 1546 ,"y''="++show y'']) -}
1551 SecretKeyPacket 1547 SecretKeyPacket
1552 { version = 4 1548 { version = 4
1553 , timestamp = toEnum (fromEnum timestamp) 1549 , timestamp = toEnum (fromEnum timestamp)
1554 , key_algorithm = ECDSA 1550 , key_algorithm = ECDSA
@@ -1579,12 +1575,12 @@ rsaKeyFromPacket p@(SecretKeyPacket {}) = do
1579rsaKeyFromPacket _ = Nothing 1575rsaKeyFromPacket _ = Nothing
1580 1576
1581 1577
1582readPacketsFromWallet :: 1578readPacketsFromWallet ::
1583 Maybe Packet 1579 Maybe Packet
1584 -> FilePath 1580 -> FilePath
1585 -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] 1581 -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
1586readPacketsFromWallet wk fname = do 1582readPacketsFromWallet wk fname = do
1587 timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 1583 timestamp <- handleIO_ (error $ fname++": modificaiton time?") $
1588 modificationTime <$> getFileStatus fname 1584 modificationTime <$> getFileStatus fname
1589 input <- L.readFile fname 1585 input <- L.readFile fname
1590 let (ks,_) = slurpWIPKeys timestamp input 1586 let (ks,_) = slurpWIPKeys timestamp input
@@ -1673,7 +1669,7 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do
1673 let grip = fingerprint wk 1669 let grip = fingerprint wk
1674 addOrigin new_sig = do 1670 addOrigin new_sig = do
1675 flip (maybe $ return FailedToMakeSignature) 1671 flip (maybe $ return FailedToMakeSignature)
1676 (new_sig >>= listToMaybe . signatures_over) 1672 (new_sig >>= listToMaybe . signatures_over)
1677 $ \new_sig -> do 1673 $ \new_sig -> do
1678 let mp' = mappedPacket fname new_sig 1674 let mp' = mappedPacket fname new_sig
1679 return $ KikiSuccess (mp', Map.empty) 1675 return $ KikiSuccess (mp', Map.empty)
@@ -1797,7 +1793,7 @@ origin p n = OriginFlags ispub n
1797 SecretKeyPacket {} -> False 1793 SecretKeyPacket {} -> False
1798 _ -> True 1794 _ -> True
1799 1795
1800mappedPacket filename p = MappedPacket 1796mappedPacket filename p = MappedPacket
1801 { packet = p 1797 { packet = p
1802 , usage_tag = Nothing 1798 , usage_tag = Nothing
1803 , locations = Map.singleton filename (origin p (-1)) 1799 , locations = Map.singleton filename (origin p (-1))
@@ -1860,10 +1856,10 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
1860 where 1856 where
1861 -- NOTE: 1857 -- NOTE:
1862 -- if a keyring file has both a public key packet and a secret key packet 1858 -- if a keyring file has both a public key packet and a secret key packet
1863 -- for the same key, then only one of them will survive, which ever is 1859 -- for the same key, then only one of them will survive, which ever is
1864 -- later in the file. 1860 -- later in the file.
1865 -- 1861 --
1866 -- This is due to the use of statements like 1862 -- This is due to the use of statements like
1867 -- (Map.insert filename (origin p n) (locations key)) 1863 -- (Map.insert filename (origin p n) (locations key))
1868 -- 1864 --
1869 update v | isKey p && not (is_subkey p) 1865 update v | isKey p && not (is_subkey p)
@@ -1961,7 +1957,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
1961 "Unable to merge subkey signature: "++(words (show sig) >>= take 1) 1957 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
1962 1958
1963unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] 1959unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
1964unsig fname isPublic (sig,trustmap) = 1960unsig fname isPublic (sig,trustmap) =
1965 [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) 1961 [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
1966 where 1962 where
1967 f n _ = n==fname -- && trace ("fname=n="++show n) True 1963 f n _ = n==fname -- && trace ("fname=n="++show n) True
@@ -1990,7 +1986,7 @@ flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPubl
1990 1986
1991flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] 1987flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
1992flattenTop fname ispub (KeyData key sigs uids subkeys) = 1988flattenTop fname ispub (KeyData key sigs uids subkeys) =
1993 unk ispub key : 1989 unk ispub key :
1994 ( flattenAllUids fname ispub uids 1990 ( flattenAllUids fname ispub uids
1995 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) 1991 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
1996 1992
@@ -2006,11 +2002,11 @@ flattenAllUids fname ispub uids =
2006 concatSort fname head (flattenUid fname ispub) (Map.assocs uids) 2002 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
2007 2003
2008flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] 2004flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
2009flattenUid fname ispub (str,(sigs,om)) = 2005flattenUid fname ispub (str,(sigs,om)) =
2010 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs 2006 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
2011 2007
2012 2008
2013 2009
2014{- 2010{-
2015data Kiki a = 2011data Kiki a =
2016 SinglePass (KeyRingOperation -> KeyRingAction a) 2012 SinglePass (KeyRingOperation -> KeyRingAction a)
@@ -2031,14 +2027,14 @@ instance Functor Kiki where fmap f k = fmapWithRT (const f) k
2031 2027
2032instance Monad Kiki where 2028instance Monad Kiki where
2033 return x = SinglePass (const $ KeyRingAction x) 2029 return x = SinglePass (const $ KeyRingAction x)
2034 2030
2035 k >>= f = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k 2031 k >>= f = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k
2036 where (.:) = (.) . (.) 2032 where (.:) = (.) . (.)
2037 2033
2038eval :: KeyRingRuntime -> Kiki a -> KeyRingOperation -> a 2034eval :: KeyRingRuntime -> Kiki a -> KeyRingOperation -> a
2039eval rt (SinglePass f) kd = 2035eval rt (SinglePass f) kd =
2040 case f kd of KeyRingAction v -> v 2036 case f kd of KeyRingAction v -> v
2041 RunTimeAction g -> g rt 2037 RunTimeAction g -> g rt
2042eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd 2038eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd
2043 2039
2044eval' :: Kiki (KeyRingOperation -> a) -> Kiki a 2040eval' :: Kiki (KeyRingOperation -> a) -> Kiki a