summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-07-11 23:43:16 -0400
committerJoe Crayne <joe@jerkface.net>2019-07-11 23:43:16 -0400
commit352b340868f52d4749180c1ceb63e599170abada (patch)
tree34127970fff880afee59e55254433faf811e02ed /kiki.hs
parent365bdcd8d9f4a08aaae35fc27722d268f4af9041 (diff)
Promote KeyDB to a type.
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs33
1 files changed, 18 insertions, 15 deletions
diff --git a/kiki.hs b/kiki.hs
index b4512f3..a8f1bc6 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -231,19 +231,19 @@ partitionStaticArguments specs args = psa args
231 Just n -> first ((a:take n as):) $ psa (drop n as) 231 Just n -> first ((a:take n as):) $ psa (drop n as)
232 232
233show_wk :: FilePath 233show_wk :: FilePath
234 -> Maybe [Char] -> Map.Map KeyKey KeyData -> IO () 234 -> Maybe [Char] -> KeyDB -> IO ()
235show_wk secring_file grip db = do 235show_wk secring_file grip db = do
236 -- printf "show_wk(%s,%s,%s)\n" (show secring_file) (show grip) (show db) 236 -- printf "show_wk(%s,%s,%s)\n" (show secring_file) (show grip) (show db)
237 let sec_db = Map.filter gripmatch db 237 let sec_db = Map.filter gripmatch (byKeyKey db)
238 gripmatch (KeyData p _ _ _) = 238 gripmatch (KeyData p _ _ _) =
239 Map.member secring_file (locations p) 239 Map.member secring_file (locations p)
240 || Map.member "&secret" (locations p) 240 || Map.member "&secret" (locations p)
241 Message sec = flattenKeys False sec_db 241 Message sec = flattenKeys False sec_db
242 putStrLn $ listKeysFiltered (maybeToList grip) sec 242 putStrLn $ listKeysFiltered (maybeToList grip) sec
243 243
244debug_dump :: FilePath -> p -> Map.Map KeyKey KeyData -> IO () 244debug_dump :: FilePath -> p -> KeyDB -> IO ()
245debug_dump secring_file grip db = do 245debug_dump secring_file grip db = do
246 let sec_db = Map.filter gripmatch db 246 let sec_db = Map.filter gripmatch (byKeyKey db)
247 gripmatch (KeyData p _ _ _) = 247 gripmatch (KeyData p _ _ _) =
248 Map.member secring_file (locations p) 248 Map.member secring_file (locations p)
249 || Map.member "&secret" (locations p) 249 || Map.member "&secret" (locations p)
@@ -252,19 +252,20 @@ debug_dump secring_file grip db = do
252 252
253show_all :: KeyDB -> IO () 253show_all :: KeyDB -> IO ()
254show_all db = do 254show_all db = do
255 let Message packets = flattenKeys True db 255 let Message packets = flattenKeys True (byKeyKey db)
256 putStrLn $ listKeys packets 256 putStrLn $ listKeys packets
257 257
258show_packets :: (Eq a, IsString a) => 258show_packets :: (Eq a, IsString a) =>
259 [a] -> KeyDB -> IO () 259 [a] -> KeyDB -> IO ()
260show_packets puborsec db = do 260show_packets puborsec db = do
261 let Message packets = flattenKeys (case puborsec of { "sec":_ -> False; _ -> True }) db 261 let Message packets = flattenKeys (case puborsec of { "sec":_ -> False; _ -> True })
262 (byKeyKey db)
262 forM_ packets $ putStrLn . showPacket 263 forM_ packets $ putStrLn . showPacket
263 264
264show_whose_key :: Maybe RSAPublicKey -> KeyDB -> IO () 265show_whose_key :: Maybe RSAPublicKey -> KeyDB -> IO ()
265show_whose_key input_key db = 266show_whose_key input_key db =
266 flip (maybe $ return ()) input_key $ \input_key -> do 267 flip (maybe $ return ()) input_key $ \input_key -> do
267 let ks = whoseKey input_key db 268 let ks = whoseKey input_key (byKeyKey db)
268 case ks of 269 case ks of
269 [KeyData k _ uids _] -> do 270 [KeyData k _ uids _] -> do
270 putStrLn $ fingerprint (packet k) 271 putStrLn $ fingerprint (packet k)
@@ -299,11 +300,11 @@ dnsPresentationFromPacket k = do
299 ,qq 300 ,qq
300 ] 301 ]
301 302
302show_id :: String -> p -> Map.Map KeyKey KeyData -> IO () 303show_id :: String -> p -> KeyDB -> IO ()
303show_id keyspec wkgrip db = do 304show_id keyspec wkgrip db = do
304 let s = parseSpec "" keyspec 305 let s = parseSpec "" keyspec
305 let ps = do 306 let ps = do
306 (_,k) <- filterMatches (fst s) (Map.toList db) 307 (_,k) <- filterMatches (fst s) (Map.toList $ byKeyKey db)
307 mp <- flattenTop "" True k 308 mp <- flattenTop "" True k
308 return $ packet mp 309 return $ packet mp
309 -- putStrLn $ "show key " ++ show s 310 -- putStrLn $ "show key " ++ show s
@@ -440,7 +441,7 @@ bitcoinAddress network_id k = address
440#endif 441#endif
441 address = base58_encode hsh 442 address = base58_encode hsh
442 443
443whoseKey :: RSAPublicKey -> KeyDB -> [KeyData] 444whoseKey :: RSAPublicKey -> Map.Map KeyKey KeyData -> [KeyData]
444whoseKey rsakey db = filter matchkey (Map.elems db) 445whoseKey rsakey db = filter matchkey (Map.elems db)
445 where 446 where
446 matchkey (KeyData k _ _ subs) = 447 matchkey (KeyData k _ _ subs) =
@@ -1678,7 +1679,7 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1678 where 1679 where
1679 ipsecs = do 1680 ipsecs = do
1680 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt) 1681 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt)
1681 let kd = (rtKeyDB rt Map.! kk) 1682 let kd = (byKeyKey (rtKeyDB rt) Map.! kk)
1682 Hostnames addr onames ns _ = getHostnames kd 1683 Hostnames addr onames ns _ = getHostnames kd
1683 oname <- onames 1684 oname <- onames
1684 return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs) 1685 return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs)
@@ -1689,14 +1690,16 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1689 1690
1690 secrets_kd = case fst . parseSpec "" <$> (++"/") <$> spec of 1691 secrets_kd = case fst . parseSpec "" <$> (++"/") <$> spec of
1691 _ | spec == Just "-" || spec == Just "" 1692 _ | spec == Just "-" || spec == Just ""
1692 -> maybeToList (rtWorkingKey rt) >>= return . (Map.!) (rtKeyDB rt) . keykey 1693 -> maybeToList (rtWorkingKey rt)
1694 >>= return . (Map.!) (byKeyKey $ rtKeyDB rt) . keykey
1693 Just topspec 1695 Just topspec
1694 -> map snd $ filterMatches topspec $ Map.toList $ rtKeyDB rt 1696 -> map snd $ filterMatches topspec $ Map.toList $ byKeyKey $ rtKeyDB rt
1695 w -> [] 1697 w -> []
1696 1698
1697 lookupSecret tag kd = maybeToList $ selectSecretKey (KeyGrip "",Just tag) m 1699 lookupSecret tag kd = maybeToList $ selectSecretKey (KeyGrip "",Just tag) m
1698 where 1700 where
1699 m = Map.singleton (keykey $ keyPacket kd) kd 1701 m = KeyDB { byKeyKey = Map.singleton (keykey $ keyPacket kd) kd
1702 }
1700 1703
1701 dir :: FilePath -> FilePath 1704 dir :: FilePath -> FilePath
1702 dir d = d -- TODO: prepend prefix path? 1705 dir d = d -- TODO: prepend prefix path?
@@ -1766,7 +1769,7 @@ tarC (sargs,margs) = do
1766 knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey) 1769 knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey)
1767 where 1770 where
1768 ns = onames ++ others 1771 ns = onames ++ others
1769 Hostnames _ onames others _ = getHostnames $ rtKeyDB rt Map.! kk 1772 Hostnames _ onames others _ = getHostnames $ byKeyKey (rtKeyDB rt) Map.! kk
1770 1773
1771 build_secret :: Num t => KeyRingRuntime -> Packet -> (t, Either (IO (Maybe Char8.ByteString)) b) 1774 build_secret :: Num t => KeyRingRuntime -> Packet -> (t, Either (IO (Maybe Char8.ByteString)) b)
1772 build_secret rt k = ( fromIntegral $ timestamp k 1775 build_secret rt k = ( fromIntegral $ timestamp k