summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-07-13 21:18:22 -0400
committerJoe Crayne <joe@jerkface.net>2019-07-13 21:18:22 -0400
commit3f29bdc88a068ec3eab91a8bac12757e3a106ceb (patch)
tree09507dcfed5524694a2280fd11fb607023f7ce8b
parentcc6775a52107f5425d668a4831f475d05dc113b5 (diff)
Finished encapsulation of KeyDB.
Diffstat
-rw-r--r--kiki.hs40
-rw-r--r--lib/KeyDB.hs110
-rw-r--r--lib/KeyRing.hs22
-rw-r--r--lib/KeyRing/BuildKeyDB.hs109
-rw-r--r--lib/KeyRing/Types.hs125
-rw-r--r--lib/Kiki.hs4
-rw-r--r--lib/PacketTranscoder.hs2
-rw-r--r--lib/Transforms.hs135
8 files changed, 293 insertions, 254 deletions
diff --git a/kiki.hs b/kiki.hs
index 2379e74..b3cc880 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -225,38 +225,37 @@ show_wk :: FilePath
225 -> Maybe [Char] -> KeyDB -> IO () 225 -> Maybe [Char] -> KeyDB -> IO ()
226show_wk secring_file grip db = do 226show_wk secring_file grip db = do
227 -- printf "show_wk(%s,%s,%s)\n" (show secring_file) (show grip) (show db) 227 -- printf "show_wk(%s,%s,%s)\n" (show secring_file) (show grip) (show db)
228 let sec_db = Map.filter gripmatch (byKeyKey db) 228 let gripmatch (KeyData p _ _ _) =
229 gripmatch (KeyData p _ _ _) =
230 Map.member secring_file (locations p) 229 Map.member secring_file (locations p)
231 || Map.member "&secret" (locations p) 230 || Map.member "&secret" (locations p)
232 Message sec = flattenKeys False sec_db 231 Message sec = flattenFiltered False gripmatch db
233 putStrLn $ listKeysFiltered (maybeToList grip) sec 232 putStrLn $ listKeysFiltered (maybeToList grip) sec
234 233
235debug_dump :: FilePath -> p -> KeyDB -> IO () 234debug_dump :: FilePath -> p -> KeyDB -> IO ()
236debug_dump secring_file grip db = do 235debug_dump secring_file grip db = do
237 let sec_db = Map.filter gripmatch (byKeyKey db) 236 let gripmatch (KeyData p _ _ _) =
238 gripmatch (KeyData p _ _ _) =
239 Map.member secring_file (locations p) 237 Map.member secring_file (locations p)
240 || Map.member "&secret" (locations p) 238 || Map.member "&secret" (locations p)
241 Message sec = flattenKeys False sec_db 239 Message sec = flattenFiltered False gripmatch db
242 mapM_ print sec 240 mapM_ print sec
243 241
244show_all :: KeyDB -> IO () 242show_all :: KeyDB -> IO ()
245show_all db = do 243show_all db = do
246 let Message packets = flattenKeys True (byKeyKey db) 244 let Message packets = flattenFiltered True (const True) db
247 putStrLn $ listKeys packets 245 putStrLn $ listKeys packets
248 246
249show_packets :: (Eq a, IsString a) => 247show_packets :: (Eq a, IsString a) =>
250 [a] -> KeyDB -> IO () 248 [a] -> KeyDB -> IO ()
251show_packets puborsec db = do 249show_packets puborsec db = do
252 let Message packets = flattenKeys (case puborsec of { "sec":_ -> False; _ -> True }) 250 let Message packets = flattenFiltered (case puborsec of { "sec":_ -> False; _ -> True })
253 (byKeyKey db) 251 (const True)
252 db
254 forM_ packets $ putStrLn . showPacket 253 forM_ packets $ putStrLn . showPacket
255 254
256show_whose_key :: Maybe RSAPublicKey -> KeyDB -> IO () 255show_whose_key :: Maybe RSAPublicKey -> KeyDB -> IO ()
257show_whose_key input_key db = 256show_whose_key input_key db =
258 flip (maybe $ return ()) input_key $ \input_key -> do 257 flip (maybe $ return ()) input_key $ \input_key -> do
259 let ks = whoseKey input_key (byKeyKey db) 258 let ks = whoseKey input_key db
260 case ks of 259 case ks of
261 [KeyData k _ uids _] -> do 260 [KeyData k _ uids _] -> do
262 putStrLn $ fingerprint (packet k) 261 putStrLn $ fingerprint (packet k)
@@ -291,7 +290,7 @@ show_id :: String -> p -> KeyDB -> IO ()
291show_id keyspec wkgrip db = do 290show_id keyspec wkgrip db = do
292 let s = parseSpec "" keyspec 291 let s = parseSpec "" keyspec
293 let ps = do 292 let ps = do
294 (_,k) <- filterMatches (fst s) (Map.toList $ byKeyKey db) 293 (_,k) <- filterMatches (fst s) (kkData db)
295 mp <- flattenTop "" True k 294 mp <- flattenTop "" True k
296 return $ packet mp 295 return $ packet mp
297 -- putStrLn $ "show key " ++ show s 296 -- putStrLn $ "show key " ++ show s
@@ -416,8 +415,8 @@ bitcoinAddress network_id k = address
416 ripemd160 x = convert (Crypto.Hash.hash x :: Digest RIPEMD160) :: S.ByteString 415 ripemd160 x = convert (Crypto.Hash.hash x :: Digest RIPEMD160) :: S.ByteString
417 address = base58_encode hsh 416 address = base58_encode hsh
418 417
419whoseKey :: RSAPublicKey -> Map.Map KeyKey KeyData -> [KeyData] 418whoseKey :: RSAPublicKey -> KeyDB -> [KeyData]
420whoseKey rsakey db = filter matchkey (Map.elems db) 419whoseKey rsakey db = filter matchkey (keyData db)
421 where 420 where
422 matchkey (KeyData k _ _ subs) = 421 matchkey (KeyData k _ _ subs) =
423 any (ismatch k) $ Map.elems subs 422 any (ismatch k) $ Map.elems subs
@@ -1656,7 +1655,7 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1656 where 1655 where
1657 ipsecs = do 1656 ipsecs = do
1658 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt) 1657 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt)
1659 let kd = (byKeyKey (rtKeyDB rt) Map.! kk) 1658 let kd = fromJust $ lookupKeyData kk (rtKeyDB rt)
1660 Hostnames addr onames ns _ = getHostnames kd 1659 Hostnames addr onames ns _ = getHostnames kd
1661 oname <- onames 1660 oname <- onames
1662 return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs) 1661 return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs)
@@ -1668,15 +1667,14 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1668 secrets_kd = case fst . parseSpec "" <$> (++"/") <$> spec of 1667 secrets_kd = case fst . parseSpec "" <$> (++"/") <$> spec of
1669 _ | spec == Just "-" || spec == Just "" 1668 _ | spec == Just "-" || spec == Just ""
1670 -> maybeToList (rtWorkingKey rt) 1669 -> maybeToList (rtWorkingKey rt)
1671 >>= return . (Map.!) (byKeyKey $ rtKeyDB rt) . keykey 1670 >>= return . fromJust . (`lookupKeyData` rtKeyDB rt) . keykey
1672 Just topspec 1671 Just topspec
1673 -> map snd $ filterMatches topspec $ Map.toList $ byKeyKey $ rtKeyDB rt 1672 -> map snd $ filterMatches topspec $ kkData $ rtKeyDB rt
1674 w -> [] 1673 w -> []
1675 1674
1676 lookupSecret tag kd = maybeToList $ selectSecretKey (KeyGrip "",Just tag) m 1675 lookupSecret tag kd = take 1 $ snd $ (\(y:ys) -> seek_key (KeyTag y tag) ys)
1677 where 1676 $ snd $ seek_key (KeyGrip "")
1678 m = KeyDB { byKeyKey = Map.singleton (keykey $ keyPacket kd) kd 1677 $ map packet $ flattenTop "" False kd
1679 }
1680 1678
1681 dir :: FilePath -> FilePath 1679 dir :: FilePath -> FilePath
1682 dir d = d -- TODO: prepend prefix path? 1680 dir d = d -- TODO: prepend prefix path?
@@ -1746,7 +1744,7 @@ tarC (sargs,margs) = do
1746 knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey) 1744 knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey)
1747 where 1745 where
1748 ns = onames ++ others 1746 ns = onames ++ others
1749 Hostnames _ onames others _ = getHostnames $ byKeyKey (rtKeyDB rt) Map.! kk 1747 Hostnames _ onames others _ = getHostnames $ fromJust $ lookupKeyData kk (rtKeyDB rt)
1750 1748
1751 build_secret :: Num t => KeyRingRuntime -> Packet -> (t, Either (IO (Maybe Char8.ByteString)) b) 1749 build_secret :: Num t => KeyRingRuntime -> Packet -> (t, Either (IO (Maybe Char8.ByteString)) b)
1752 build_secret rt k = ( fromIntegral $ timestamp k 1750 build_secret rt k = ( fromIntegral $ timestamp k
diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs
index f5a4357..1f0849c 100644
--- a/lib/KeyDB.hs
+++ b/lib/KeyDB.hs
@@ -1,5 +1,4 @@
1module KeyDB 1module KeyDB
2 {-
3 ( TrustMap 2 ( TrustMap
4 , SigAndTrust 3 , SigAndTrust
5 , SubKey(..) 4 , SubKey(..)
@@ -7,15 +6,31 @@ module KeyDB
7 , KeyDB 6 , KeyDB
8 , emptyKeyDB 7 , emptyKeyDB
9 , keyData 8 , keyData
9 , kkData
10 , lookupKeyData
10 , transmute 11 , transmute
11 ) -} where 12 , transmuteAt
13 , alterKeyDB
14 , mergeKeyDB
15 , mapKeyDB
16 -- These probably don't belong here
17 , selectKey0
18 , flattenTop
19 , flattenAllUids
20 , flattenSub
21 , sortByHint
22 , flattenKeys
23 , flattenFiltered
24 ) where
12 25
13import Control.Monad 26import Control.Monad
14import Data.Functor 27import Data.Functor
28import Data.List
15import qualified Data.Map.Strict as Map 29import qualified Data.Map.Strict as Map
30import Data.Maybe
16import Data.OpenPGP 31import Data.OpenPGP
32import Data.Ord
17 33
18import FunctorToMaybe
19import KeyRing.Types 34import KeyRing.Types
20 35
21type TrustMap = Map.Map FilePath Packet 36type TrustMap = Map.Map FilePath Packet
@@ -43,6 +58,11 @@ emptyKeyDB = KeyDB { byKeyKey = Map.empty }
43keyData :: KeyDB -> [KeyData] 58keyData :: KeyDB -> [KeyData]
44keyData db = Map.elems (byKeyKey db) 59keyData db = Map.elems (byKeyKey db)
45 60
61kkData :: KeyDB -> [(KeyKey, KeyData)]
62kkData db = Map.toList (byKeyKey db)
63
64lookupKeyData :: KeyKey -> KeyDB -> Maybe KeyData
65lookupKeyData kk db = Map.lookup kk (byKeyKey db)
46 66
47transmute :: (Monad m, Monad kiki, Traversable kiki) => 67transmute :: (Monad m, Monad kiki, Traversable kiki) =>
48 ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter 68 ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter
@@ -56,3 +76,87 @@ transmute perform update db = do
56 r <- sequenceA <$> mapM performAll (byKeyKey db) 76 r <- sequenceA <$> mapM performAll (byKeyKey db)
57 return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk } 77 return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk }
58 , concatMap snd $ Map.elems bkk ) 78 , concatMap snd $ Map.elems bkk )
79
80alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB
81alterKeyDB update kk db = db { byKeyKey = Map.alter update kk (byKeyKey db) }
82
83transmuteAt :: ( Monad m
84 , Functor kiki
85 ) => (Maybe KeyData -> m (kiki (KeyData,[info]))) -> KeyKey -> KeyDB -> m (kiki (KeyDB,[info]))
86transmuteAt go kk db = do
87 kdr <- go (Map.lookup kk $ byKeyKey db)
88 return $ kdr <&> \(kd',rrs) -> ( alterKeyDB (const $ Just kd') kk db
89 , rrs )
90
91mergeKeyDB :: (KeyData -> KeyData -> KeyData) -> KeyDB -> KeyDB -> KeyDB
92mergeKeyDB mergeKeyData db dbtrans =
93 KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) }
94
95mapKeyDB :: Monad m => (KeyData -> m KeyData) -> KeyDB -> m KeyDB
96mapKeyDB f db = fmap (\m -> db { byKeyKey = m }) $ mapM f (byKeyKey db)
97
98selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
99selectKey0 wantPublic (spec,mtag) db = do
100 let Message ps = flattenKeys wantPublic $ byKeyKey db
101 ys = snd $ seek_key spec ps
102 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
103 case ys of
104 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
105 [] -> Nothing
106
107
108flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message
109flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd)
110 (prefilter . Map.assocs $ db)
111 where
112 prefilter = if isPublic then id else filter isSecret
113 where
114 isSecret (_,(KeyData
115 (MappedPacket { packet=(SecretKeyPacket {})})
116 _
117 _
118 _)) = True
119 isSecret _ = False
120
121flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
122flattenUid fname ispub (str,(sigs,om)) =
123 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
124
125flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
126flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
127
128flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
129flattenAllUids fname ispub uids =
130 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
131
132flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
133flattenTop fname ispub (KeyData key sigs uids subkeys) =
134 unk ispub key :
135 ( flattenAllUids fname ispub uids
136 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
137
138sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
139sortByHint fname f = sortBy (comparing gethint)
140 where
141 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
142 defnum = -1
143
144concatSort ::
145 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
146concatSort fname getp f = concat . sortByHint fname getp . map f
147
148unk :: Bool -> MappedPacket -> MappedPacket
149unk isPublic = if isPublic then toPacket secretToPublic else id
150 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
151
152
153unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
154unsig fname isPublic (sig,trustmap) =
155 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
156 where
157 f n _ = n==fname -- && trace ("fname=n="++show n) True
158 asMapped n p = let m = mappedPacket fname p
159 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
160
161flattenFiltered :: Bool -> (KeyData -> Bool) -> KeyDB -> Message
162flattenFiltered wantPublic pred db = flattenKeys wantPublic $ Map.filter pred (byKeyKey db)
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 1d52dd1..b946e54 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -73,7 +73,7 @@ import KeyRing.BuildKeyDB (Hostnames(..),
73 buildKeyDB, 73 buildKeyDB,
74 combineTransforms, 74 combineTransforms,
75 filterMatches, 75 filterMatches,
76 fingerdress, flattenKeys, 76 fingerdress,
77 generateInternals, 77 generateInternals,
78 getHostnames, getSubkeys, 78 getHostnames, getSubkeys,
79 importSecretKey, 79 importSecretKey,
@@ -84,8 +84,8 @@ import KeyRing.BuildKeyDB (Hostnames(..),
84 parseSingleSpec, 84 parseSingleSpec,
85 parseSpec, readInputFileL, 85 parseSpec, readInputFileL,
86 readSecretPEMFile, 86 readSecretPEMFile,
87 secp256k1_id, seek_key, 87 secp256k1_id,
88 selectKey0, selectPublicKey, 88 selectPublicKey,
89 usageFromFilter) 89 usageFromFilter)
90 90
91import KeyRing.Types 91import KeyRing.Types
@@ -412,10 +412,10 @@ selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Pa
412selectPublicKeyAndSigs (spec,mtag) db = 412selectPublicKeyAndSigs (spec,mtag) db =
413 case mtag of 413 case mtag of
414 Nothing -> do 414 Nothing -> do
415 (kk,r) <- Map.toList $ fmap (findbyspec spec) (byKeyKey db) 415 (kk,r) <- fmap (second $ findbyspec spec) (kkData db)
416 (sub,sigs) <- r 416 (sub,sigs) <- r
417 return (kk,sub,sigs) 417 return (kk,sub,sigs)
418 Just tag -> Map.toList (Map.filter (matchSpec spec) (byKeyKey db)) >>= findsubs tag 418 Just tag -> filterMatches spec (kkData db) >>= findsubs tag
419 where 419 where
420 topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) 420 topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
421 421
@@ -600,7 +600,7 @@ coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPack
600coinKeysOwnedBy db wk = do 600coinKeysOwnedBy db wk = do
601 wk <- maybeToList wk 601 wk <- maybeToList wk
602 let kk = keykey wk 602 let kk = keykey wk
603 KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk (byKeyKey db) 603 KeyData top topsigs uids subs <- maybeToList $ lookupKeyData kk db
604 (subkk,SubKey mp sigs) <- Map.toList subs 604 (subkk,SubKey mp sigs) <- Map.toList subs
605 let sub = packet mp 605 let sub = packet mp
606 guard $ isCryptoCoinKey sub 606 guard $ isCryptoCoinKey sub
@@ -664,7 +664,7 @@ guardAuthentic rt keydata = guard (isauth rt keydata)
664 664
665isauth :: KeyRingRuntime -> KeyData -> Bool 665isauth :: KeyRingRuntime -> KeyData -> Bool
666isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk 666isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
667 where wk = workingKey (rtGrip rt) (byKeyKey $ rtKeyDB rt) 667 where wk = workingKey (rtGrip rt) (rtKeyDB rt)
668 dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt) 668 dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt)
669 $ locations p 669 $ locations p
670 has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids 670 has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids
@@ -676,7 +676,7 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
676 676
677 workingKey grip use_db = listToMaybe $ do 677 workingKey grip use_db = listToMaybe $ do
678 fp <- maybeToList grip 678 fp <- maybeToList grip
679 elm <- Map.elems use_db 679 elm <- keyData use_db
680 guard $ matchSpec (KeyGrip fp) elm 680 guard $ matchSpec (KeyGrip fp) elm
681 return $ keyPacket elm 681 return $ keyPacket elm
682 682
@@ -731,7 +731,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
731 (error $ f ++ ": write public or secret key to file?") 731 (error $ f ++ ": write public or secret key to file?")
732 importByExistingMaster kd@(KeyData p _ _ _) = 732 importByExistingMaster kd@(KeyData p _ _ _) =
733 fmap originallyPublic $ Map.lookup f $ locations p 733 fmap originallyPublic $ Map.lookup f $ locations p
734 d <- sortByHint f keyMappedPacket (Map.elems $ byKeyKey db') 734 d <- sortByHint f keyMappedPacket (keyData db')
735 acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) 735 acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
736 only_public <- maybeToList $ wantedForFill acc (fill stream) d 736 only_public <- maybeToList $ wantedForFill acc (fill stream) d
737 guard $ only_public || isSecretKey (keyPacket d) 737 guard $ only_public || isSecretKey (keyPacket d)
@@ -984,7 +984,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
984 -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db 984 -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db
985 -- ms = filterMatches topspec $ Map.toList db 985 -- ms = filterMatches topspec $ Map.toList db
986 ns = do 986 ns = do
987 (kk,kd) <- filterMatches topspec $ Map.toList $ byKeyKey db 987 (kk,kd) <- filterMatches topspec $ kkData db
988 return (kk , subkeysForExport subspec kd) 988 return (kk , subkeysForExport subspec kd)
989 return (fname,subspec,ns,stream) 989 return (fname,subspec,ns,stream)
990 (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) 990 (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
@@ -1032,7 +1032,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
1032 usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream] 1032 usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream]
1033 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage 1033 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
1034 guard $ null $ do 1034 guard $ null $ do
1035 (kk,kd) <- filterMatches topspec $ Map.toList $ byKeyKey db 1035 (kk,kd) <- filterMatches topspec $ kkData db
1036 subkeysForExport subspec kd 1036 subkeysForExport subspec kd
1037 return (f,stream) 1037 return (f,stream)
1038 where 1038 where
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 8af8198..cd1bae9 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -185,8 +185,7 @@ buildKeyDB ctx grip0 keyring = do
185 db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed 185 db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed
186 where 186 where
187 mergeIt db f (_,dbtrans) 187 mergeIt db f (_,dbtrans)
188 = KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) 188 = mergeKeyDB mergeKeyData db dbtrans
189 }
190 -- | reportTrans 189 -- | reportTrans
191 -- events, indexed by file 190 -- events, indexed by file
192 reportTrans :: [(FilePath, KikiReportAction)] 191 reportTrans :: [(FilePath, KikiReportAction)]
@@ -226,7 +225,7 @@ buildKeyDB ctx grip0 keyring = do
226 -- TODO: KikiCondition reporting for spill/fill usage mismatch? 225 -- TODO: KikiCondition reporting for spill/fill usage mismatch?
227 -- TODO: parseSpec3 226 -- TODO: parseSpec3
228 let (topspec,subspec) = parseSpec grip usage 227 let (topspec,subspec) = parseSpec grip usage
229 ms = map fst $ filterMatches topspec (Map.toList $ byKeyKey db) 228 ms = map fst $ filterMatches topspec (kkData db)
230 cmd = initializer stream 229 cmd = initializer stream
231 return (n,subspec,ms,stream, cmd) 230 return (n,subspec,ms,stream, cmd)
232 231
@@ -338,7 +337,7 @@ scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret Ma
338 case p of 337 case p of
339 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) 338 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
340 _ | isKey p && is_subkey p -> (top,p,ret p) 339 _ | isKey p && is_subkey p -> (top,p,ret p)
341 _ | isUserID p -> (top,p,ret p) 340 _ | isJust (isUserID p) -> (top,p,ret p)
342 _ | isTrust p -> (top,sub,updateTrust top sub prev p) 341 _ | isTrust p -> (top,sub,updateTrust top sub prev p)
343 _ -> (top,sub,ret p) 342 _ -> (top,sub,ret p)
344 343
@@ -385,10 +384,14 @@ doImportG
385 -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)])) 384 -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)]))
386doImportG transcode db m0 tags fname key = do 385doImportG transcode db m0 tags fname key = do
387 let kk = head m0 386 let kk = head m0
388 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db) 387 {-
388 let Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db)
389 kdr <- insertSubkey transcode kk kd tags fname key 389 kdr <- insertSubkey transcode kk kd tags fname key
390 try kdr $ \(kd',rrs) -> return $ KikiSuccess ( db { byKeyKey = Map.insert kk kd' (byKeyKey db) } 390 try kdr $ \(kd',rrs) -> return $ KikiSuccess ( alterKeyDB (const $ Just kd') kk db
391 , rrs) 391 , rrs )
392 -}
393 let go (Just kd@(KeyData top topsigs uids subs)) = insertSubkey transcode kk kd tags fname key
394 transmuteAt go kk db
392 395
393 396
394iswallet :: FileType -> Bool 397iswallet :: FileType -> Bool
@@ -487,7 +490,7 @@ outgoing_names db hostdbs0 = IPsToWriteToHostsFile $ do
487 guard $ all (null . Hosts.namesForAddress addr) hostdbs0 490 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
488 return addr 491 return addr
489 where 492 where
490 gpgnames = map getHostnames $ Map.elems $ byKeyKey db 493 gpgnames = map getHostnames $ keyData db
491 494
492filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] 495filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
493filterMatches spec ks = filter (matchSpec spec . snd) ks 496filterMatches spec ks = filter (matchSpec spec . snd) ks
@@ -513,14 +516,13 @@ generateInternals ::
513 -> [(GenerateKeyParams,StreamInfo)] 516 -> [(GenerateKeyParams,StreamInfo)]
514 -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) 517 -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
515generateInternals transcode mwk db gens = do 518generateInternals transcode mwk db gens = do
516 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) (byKeyKey db) of 519 case mwk of
517 Just kd0 -> do
518 kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
519 try kd $ \(kd,reportGens) -> do
520 let kk = keykey $ packet $ fromJust mwk
521 return $ KikiSuccess ( KeyDB { byKeyKey = Map.insert kk kd (byKeyKey db) }
522 , reportGens )
523 Nothing -> return $ KikiSuccess (db,[]) 520 Nothing -> return $ KikiSuccess (db,[])
521 Just mpkt -> do
522 let kk = keykey (packet mpkt)
523 transmuteAt (go kk) kk db
524 where
525 go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
524 526
525mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext 527mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
526 -> IO 528 -> IO
@@ -549,7 +551,7 @@ mergeHostFiles krd db ctx = do
549 551
550 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns 552 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
551 553
552 let gpgnames = map getHostnames $ Map.elems (byKeyKey db) 554 let gpgnames = map getHostnames $ keyData db
553 os = do 555 os = do
554 Hostnames addr ns _ _ <- gpgnames 556 Hostnames addr ns _ _ <- gpgnames
555 n <- ns 557 n <- ns
@@ -578,8 +580,7 @@ mergeHostFiles krd db ctx = do
578 580
579 -- 2. replace gpg annotations with those in U 581 -- 2. replace gpg annotations with those in U
580 -- forM use_db 582 -- forM use_db
581 db' <- Traversable.mapM (setHostnames addrs u1) (byKeyKey db) 583 db' <- mapKeyDB (setHostnames addrs u1) db
582 <&> \m -> db { byKeyKey = m }
583 584
584 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[]) 585 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[])
585 586
@@ -625,7 +626,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
625 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets 626 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
626 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB 627 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
627 mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) 628 mergeit db adding@(n,(top,sub,ptt@(p,trustmap)))
628 | isKey top = db { byKeyKey = Map.alter update (keykey top) (byKeyKey db) } 629 | isKey top = alterKeyDB update (keykey top) db
629 where 630 where
630 update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty 631 update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
631 update (Just kd) = dbInsertPacket kd filename adding 632 update (Just kd) = dbInsertPacket kd filename adding
@@ -947,8 +948,7 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops
947 uids0 = fmap zapIfHasName uids 948 uids0 = fmap zapIfHasName uids
948 fstuid = head $ do 949 fstuid = head $ do
949 p <- map packet $ flattenAllUids "" True uids 950 p <- map packet $ flattenAllUids "" True uids
950 guard $ isUserID p 951 maybeToList $ isUserID p
951 return $ uidkey p
952 uids1 = Map.adjust addnames fstuid uids0 952 uids1 = Map.adjust addnames fstuid uids0
953 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin 953 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
954 where 954 where
@@ -1068,15 +1068,15 @@ dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
1068 ,show (fingerprint top, fingerprint p)] 1068 ,show (fingerprint top, fingerprint p)]
1069 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p 1069 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
1070 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) 1070 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
1071 update (Just (KeyData key sigs uids subkeys)) | isUserID p 1071 update (Just (KeyData key sigs uids subkeys)) | Just uid <- isUserID p
1072 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) 1072 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) uid uids)
1073 subkeys 1073 subkeys
1074 update (Just (KeyData key sigs uids subkeys)) 1074 update (Just (KeyData key sigs uids subkeys))
1075 = case sub of 1075 = case sub of
1076 MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys 1076 MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys
1077 UserIDPacket {} -> Just $ KeyData key 1077 UserIDPacket uid-> Just $ KeyData key
1078 sigs 1078 sigs
1079 (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) 1079 (Map.alter (mergeUidSig n ptt) uid uids)
1080 subkeys 1080 subkeys
1081 _ | isKey sub -> Just $ KeyData key 1081 _ | isKey sub -> Just $ KeyData key
1082 sigs 1082 sigs
@@ -1351,15 +1351,6 @@ extractRSAKeyFields kvs = do
1351 nlen = S.length bs 1351 nlen = S.length bs
1352 1352
1353 1353
1354selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1355selectKey0 wantPublic (spec,mtag) db = do
1356 let Message ps = flattenKeys wantPublic $ byKeyKey db
1357 ys = snd $ seek_key spec ps
1358 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
1359 case ys of
1360 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
1361 [] -> Nothing
1362
1363-- TODO: Data.ByteString.Lazy now exports this. 1354-- TODO: Data.ByteString.Lazy now exports this.
1364toStrict :: L.ByteString -> S.ByteString 1355toStrict :: L.ByteString -> S.ByteString
1365toStrict = foldr1 (<>) . L.toChunks 1356toStrict = foldr1 (<>) . L.toChunks
@@ -1374,53 +1365,3 @@ packetFromPublicRSAKey notBefore n e =
1374 , v3_days_of_validity = Nothing 1365 , v3_days_of_validity = Nothing
1375 } 1366 }
1376 1367
1377flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message
1378flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd)
1379 (prefilter . Map.assocs $ db)
1380 where
1381 prefilter = if isPublic then id else filter isSecret
1382 where
1383 isSecret (_,(KeyData
1384 (MappedPacket { packet=(SecretKeyPacket {})})
1385 _
1386 _
1387 _)) = True
1388 isSecret _ = False
1389
1390seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
1391seek_key (KeyGrip grip) sec = (pre, subs)
1392 where
1393 (pre,subs) = break pred sec
1394 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
1395 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
1396 pred _ = False
1397
1398seek_key (KeyTag key tag) ps
1399 | null bs = (ps, [])
1400 | null qs =
1401 let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
1402 (as ++ (head bs : as'), bs')
1403 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
1404 where
1405 (as,bs) = break (\p -> isSignaturePacket p
1406 && has_tag tag p
1407 && isJust (signature_issuer p)
1408 && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
1409 ps
1410 (rs,qs) = break isKey (reverse as)
1411
1412 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
1413 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
1414
1415seek_key (KeyUidMatch pat) ps
1416 | null bs = (ps, [])
1417 | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
1418 (as ++ (head bs : as'), bs')
1419 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
1420 where
1421 (as,bs) = break (isInfixOf pat . uidStr) ps
1422 (rs,qs) = break isKey (reverse as)
1423
1424 uidStr (UserIDPacket s) = s
1425 uidStr _ = ""
1426
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs
index 3c1f0a5..4a0b34e 100644
--- a/lib/KeyRing/Types.hs
+++ b/lib/KeyRing/Types.hs
@@ -3,12 +3,13 @@
3{-# LANGUAGE PatternSynonyms #-} 3{-# LANGUAGE PatternSynonyms #-}
4module KeyRing.Types where 4module KeyRing.Types where
5 5
6import Data.Bits
6import Data.Char (isLower,toLower) 7import Data.Char (isLower,toLower)
7import Data.Functor 8import Data.Functor
8import Data.List (groupBy,find) 9import Data.List (groupBy,find,isInfixOf)
9import Data.Map as Map (Map) 10import Data.Map as Map (Map)
10import qualified Data.Map as Map 11import qualified Data.Map as Map
11import Data.Maybe (maybeToList) 12import Data.Maybe (maybeToList,isJust,fromJust,mapMaybe)
12import Data.OpenPGP 13import Data.OpenPGP
13import Data.OpenPGP.Util 14import Data.OpenPGP.Util
14import Data.Time.Clock 15import Data.Time.Clock
@@ -335,9 +336,9 @@ isSecretKey (SecretKeyPacket {}) = True
335isSecretKey _ = False 336isSecretKey _ = False
336 337
337 338
338isUserID :: Packet -> Bool 339isUserID :: Packet -> Maybe String
339isUserID (UserIDPacket {}) = True 340isUserID (UserIDPacket str) = Just str
340isUserID _ = False 341isUserID _ = Nothing
341 342
342isTrust :: Packet -> Bool 343isTrust :: Packet -> Bool
343isTrust (TrustPacket {}) = True 344isTrust (TrustPacket {}) = True
@@ -408,3 +409,117 @@ data SingleKeySpec = FingerprintMatch String
408 | WorkingKeyMatch 409 | WorkingKeyMatch
409 deriving (Show,Eq,Ord) 410 deriving (Show,Eq,Ord)
410 411
412secretToPublic :: Packet -> Packet
413secretToPublic pkt@(SecretKeyPacket {}) =
414 PublicKeyPacket { version = version pkt
415 , timestamp = timestamp pkt
416 , key_algorithm = key_algorithm pkt
417 -- , ecc_curve = ecc_curve pkt
418 , key = let seckey = key pkt
419 pubs = public_key_fields (key_algorithm pkt)
420 in filter (\(k,v) -> k `elem` pubs) seckey
421 , is_subkey = is_subkey pkt
422 , v3_days_of_validity = Nothing
423 }
424secretToPublic pkt = pkt
425
426seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
427seek_key (KeyGrip grip) sec = (pre, subs)
428 where
429 (pre,subs) = break pred sec
430 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
431 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
432 pred _ = False
433
434seek_key (KeyTag key tag) ps
435 | null bs = (ps, [])
436 | null qs =
437 let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
438 (as ++ (head bs : as'), bs')
439 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
440 where
441 (as,bs) = break (\p -> isSignaturePacket p
442 && has_tag tag p
443 && isJust (signature_issuer p)
444 && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
445 ps
446 (rs,qs) = break isKey (reverse as)
447
448 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
449 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
450
451seek_key (KeyUidMatch pat) ps
452 | null bs = (ps, [])
453 | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
454 (as ++ (head bs : as'), bs')
455 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
456 where
457 (as,bs) = break (isInfixOf pat . uidStr) ps
458 (rs,qs) = break isKey (reverse as)
459
460 uidStr (UserIDPacket s) = s
461 uidStr _ = ""
462
463usageString :: PGPKeyFlags -> String
464usageString flgs =
465 case flgs of
466 Special -> "special"
467 Vouch -> "vouch" -- signkey
468 Sign -> "sign"
469 VouchSign -> "vouch-sign"
470 Communication -> "communication"
471 VouchCommunication -> "vouch-communication"
472 SignCommunication -> "sign-communication"
473 VouchSignCommunication -> "vouch-sign-communication"
474 Storage -> "storage"
475 VouchStorage -> "vouch-storage"
476 SignStorage -> "sign-storage"
477 VouchSignStorage -> "vouch-sign-storage"
478 Encrypt -> "encrypt"
479 VouchEncrypt -> "vouch-encrypt"
480 SignEncrypt -> "sign-encrypt"
481 VouchSignEncrypt -> "vouch-sign-encrypt"
482
483usage :: SignatureSubpacket -> Maybe String
484usage (NotationDataPacket
485 { human_readable = True
486 , notation_name = "usage@"
487 , notation_value = u
488 }) = Just u
489usage _ = Nothing
490
491data PGPKeyFlags =
492 Special
493 | Vouch -- 0001 C -- Signkey
494 | Sign -- 0010 S
495 | VouchSign -- 0011
496 | Communication -- 0100 E
497 | VouchCommunication -- 0101
498 | SignCommunication -- 0110
499 | VouchSignCommunication -- 0111
500 | Storage -- 1000 E
501 | VouchStorage -- 1001
502 | SignStorage -- 1010
503 | VouchSignStorage -- 1011
504 | Encrypt -- 1100 E
505 | VouchEncrypt -- 1101
506 | SignEncrypt -- 1110
507 | VouchSignEncrypt -- 1111
508 deriving (Eq,Show,Read,Enum)
509
510-- XXX keyFlags and keyflags are different functions.
511keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
512keyflags flgs@(KeyFlagsPacket {}) =
513 Just . toEnum $
514 ( bit 0x1 certify_keys
515 .|. bit 0x2 sign_data
516 .|. bit 0x4 encrypt_communication
517 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
518 -- other flags:
519 -- split_key
520 -- authentication (ssh-client)
521 -- group_key
522 where
523 bit v f = if f flgs then v else 0
524keyflags _ = Nothing
525
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index e5c4eb4..e919b88 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -496,7 +496,7 @@ installIpsecConf fw MyIdentity{myGpgAddress} cs = do
496getMyIdentity :: KeyRingRuntime -> Maybe MyIdentity 496getMyIdentity :: KeyRingRuntime -> Maybe MyIdentity
497getMyIdentity rt = do 497getMyIdentity rt = do
498 wk <- rtWorkingKey rt 498 wk <- rtWorkingKey rt
499 Hostnames wkaddr _ _ _ <- Just $ getHostnames (byKeyKey (rtKeyDB rt) Map.! keykey wk) 499 Hostnames wkaddr _ _ _ <- getHostnames <$> lookupKeyData (keykey wk) (rtKeyDB rt)
500 return $ MyIdentity wkaddr (fingerprint wk) 500 return $ MyIdentity wkaddr (fingerprint wk)
501 501
502refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () 502refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO ()
@@ -543,7 +543,7 @@ newtype UidHostname = UidHostname Char8.ByteString
543newtype ResolvableHostname = ResolvableHostname Char8.ByteString 543newtype ResolvableHostname = ResolvableHostname Char8.ByteString
544 544
545listPeers :: KeyRingRuntime -> [Peer] 545listPeers :: KeyRingRuntime -> [Peer]
546listPeers rt = map (uncurry Peer) . filter notme . mapMaybe namedContact . Map.elems . byKeyKey . rtKeyDB $ rt 546listPeers rt = map (uncurry Peer) . filter notme . mapMaybe namedContact . keyData . rtKeyDB $ rt
547 where 547 where
548 kk = keykey (fromJust $ rtWorkingKey rt) 548 kk = keykey (fromJust $ rtWorkingKey rt)
549 notme (_,kd) = keykey (keyPacket kd) /= kk 549 notme (_,kd) = keykey (keyPacket kd) /= kk
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs
index 730a221..16d1db5 100644
--- a/lib/PacketTranscoder.hs
+++ b/lib/PacketTranscoder.hs
@@ -332,6 +332,6 @@ keyQueries grip ringPackets = (mwk, fmap makeQuery keys)
332 combineKeyKey (master1,mp,um) (master2,mp2,um2) = (master1 `mplus` master2,mp,Map.unionWith (++) um um2) 332 combineKeyKey (master1,mp,um) (master2,mp2,um2) = (master1 `mplus` master2,mp,Map.unionWith (++) um um2)
333 uidmap ps = um2 333 uidmap ps = um2
334 where 334 where
335 ugs = dropWhile (not . isUserID . packet .head) $ groupBy (const $ not . isUserID . packet) ps 335 ugs = dropWhile (isNothing . isUserID . packet .head) $ groupBy (const $ isNothing . isUserID . packet) ps
336 um2 = Map.fromList 336 um2 = Map.fromList
337 $ map (\(MappedPacket (UserIDPacket s) _:sigs)->(s,takeWhile isSignaturePacket $ map packet sigs)) ugs 337 $ map (\(MappedPacket (UserIDPacket s) _:sigs)->(s,takeWhile isSignaturePacket $ map packet sigs)) ugs
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 0a3a9a6..edc18bb 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -22,7 +22,6 @@ import FunctorToMaybe
22import GnuPGAgent ( key_nbits ) 22import GnuPGAgent ( key_nbits )
23import PacketTranscoder 23import PacketTranscoder
24import TimeUtil 24import TimeUtil
25import qualified Data.Traversable as Traversable
26import qualified Data.ByteString as S 25import qualified Data.ByteString as S
27import qualified Data.ByteString.Lazy as L 26import qualified Data.ByteString.Lazy as L
28import qualified Data.ByteString.Lazy.Char8 as Char8 27import qualified Data.ByteString.Lazy.Char8 as Char8
@@ -120,25 +119,6 @@ data UserIDRecord = UserIDRecord {
120} 119}
121 deriving Show 120 deriving Show
122 121
123data PGPKeyFlags =
124 Special
125 | Vouch -- 0001 C -- Signkey
126 | Sign -- 0010 S
127 | VouchSign -- 0011
128 | Communication -- 0100 E
129 | VouchCommunication -- 0101
130 | SignCommunication -- 0110
131 | VouchSignCommunication -- 0111
132 | Storage -- 1000 E
133 | VouchStorage -- 1001
134 | SignStorage -- 1010
135 | VouchSignStorage -- 1011
136 | Encrypt -- 1100 E
137 | VouchEncrypt -- 1101
138 | SignEncrypt -- 1110
139 | VouchSignEncrypt -- 1111
140 deriving (Eq,Show,Read,Enum)
141
142 122
143 123
144-- Functions 124-- Functions
@@ -235,18 +215,6 @@ mkUsage tag = NotationDataPacket
235 } 215 }
236 216
237 217
238unk :: Bool -> MappedPacket -> MappedPacket
239unk isPublic = if isPublic then toPacket secretToPublic else id
240 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
241
242
243unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
244unsig fname isPublic (sig,trustmap) =
245 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
246 where
247 f n _ = n==fname -- && trace ("fname=n="++show n) True
248 asMapped n p = let m = mappedPacket fname p
249 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
250 218
251smallpr :: Packet -> [Char] 219smallpr :: Packet -> [Char]
252smallpr k = drop 24 $ fingerprint k 220smallpr k = drop 24 $ fingerprint k
@@ -360,34 +328,6 @@ accBindings bs = as
360 (bc,_,bkind,bhashed,bclaimaints) 328 (bc,_,bkind,bhashed,bclaimaints)
361 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) 329 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
362 330
363sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
364sortByHint fname f = sortBy (comparing gethint)
365 where
366 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
367 defnum = -1
368
369concatSort ::
370 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
371concatSort fname getp f = concat . sortByHint fname getp . map f
372
373flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
374flattenUid fname ispub (str,(sigs,om)) =
375 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
376
377flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
378flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
379
380flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
381flattenAllUids fname ispub uids =
382 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
383
384flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
385flattenTop fname ispub (KeyData key sigs uids subkeys) =
386 unk ispub key :
387 ( flattenAllUids fname ispub uids
388 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
389
390
391sigpackets :: 331sigpackets ::
392 Monad m => 332 Monad m =>
393 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet 333 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
@@ -407,72 +347,11 @@ sigpackets typ hashed unhashed = return $
407keyFlags :: t -> [Packet] -> [SignatureSubpacket] 347keyFlags :: t -> [Packet] -> [SignatureSubpacket]
408keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) 348keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
409 349
410-- XXX keyFlags and keyflags are different functions. 350
411keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags 351
412keyflags flgs@(KeyFlagsPacket {}) = 352
413 Just . toEnum $ 353
414 ( bit 0x1 certify_keys 354
415 .|. bit 0x2 sign_data
416 .|. bit 0x4 encrypt_communication
417 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
418 -- other flags:
419 -- split_key
420 -- authentication (ssh-client)
421 -- group_key
422 where
423 bit v f = if f flgs then v else 0
424keyflags _ = Nothing
425
426
427
428secretToPublic :: Packet -> Packet
429secretToPublic pkt@(SecretKeyPacket {}) =
430 PublicKeyPacket { version = version pkt
431 , timestamp = timestamp pkt
432 , key_algorithm = key_algorithm pkt
433 -- , ecc_curve = ecc_curve pkt
434 , key = let seckey = key pkt
435 pubs = public_key_fields (key_algorithm pkt)
436 in filter (\(k,v) -> k `elem` pubs) seckey
437 , is_subkey = is_subkey pkt
438 , v3_days_of_validity = Nothing
439 }
440secretToPublic pkt = pkt
441
442
443
444uidkey :: Packet -> String
445uidkey (UserIDPacket str) = str
446
447usageString :: PGPKeyFlags -> String
448usageString flgs =
449 case flgs of
450 Special -> "special"
451 Vouch -> "vouch" -- signkey
452 Sign -> "sign"
453 VouchSign -> "vouch-sign"
454 Communication -> "communication"
455 VouchCommunication -> "vouch-communication"
456 SignCommunication -> "sign-communication"
457 VouchSignCommunication -> "vouch-sign-communication"
458 Storage -> "storage"
459 VouchStorage -> "vouch-storage"
460 SignStorage -> "sign-storage"
461 VouchSignStorage -> "vouch-sign-storage"
462 Encrypt -> "encrypt"
463 VouchEncrypt -> "vouch-encrypt"
464 SignEncrypt -> "sign-encrypt"
465 VouchSignEncrypt -> "vouch-sign-encrypt"
466
467
468
469usage :: SignatureSubpacket -> Maybe String
470usage (NotationDataPacket
471 { human_readable = True
472 , notation_name = "usage@"
473 , notation_value = u
474 }) = Just u
475usage _ = Nothing
476 355
477 356
478ifSecret :: Packet -> t -> t -> t 357ifSecret :: Packet -> t -> t -> t
@@ -487,7 +366,7 @@ showPacket p | isKey p = (if is_subkey p
487 ++ " "++fingerprint p 366 ++ " "++fingerprint p
488 ++ " "++show (key_algorithm p) 367 ++ " "++show (key_algorithm p)
489 ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" } 368 ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" }
490 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) 369 | Just uid <- isUserID p = showPacket0 p ++ " " ++ show uid
491 -- isSignaturePacket p = showPacket0 p ++ maybe "" ((++) (" ^ signed"++sigusage p++": ")) (signature_issuer p) 370 -- isSignaturePacket p = showPacket0 p ++ maybe "" ((++) (" ^ signed"++sigusage p++": ")) (signature_issuer p)
492 | isSignaturePacket p = showPacket0 p ++ maybe "" (" ^ signed: "++) (signature_issuer p) ++ sigusage p 371 | isSignaturePacket p = showPacket0 p ++ maybe "" (" ^ signed: "++) (signature_issuer p) ++ sigusage p
493 | otherwise = showPacket0 p 372 | otherwise = showPacket0 p
@@ -721,8 +600,10 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
721 (es,qs) = partition isExpiration ps 600 (es,qs) = partition isExpiration ps
722 stamp = listToMaybe . sortBy (comparing Down) $ 601 stamp = listToMaybe . sortBy (comparing Down) $
723 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x 602 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
603 unwrap _ = error "isCreation fail"
724 exp = listToMaybe $ sort $ 604 exp = listToMaybe $ sort $
725 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x 605 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
606 unwrap _ = error "isExpiration fail"
726 expires = liftA2 (+) stamp exp 607 expires = liftA2 (+) stamp exp
727 timestamp <- now 608 timestamp <- now
728 if fmap ( (< timestamp) . fromIntegral) expires == Just True then 609 if fmap ( (< timestamp) . fromIntegral) expires == Just True then
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-29 09:11:48 +0000