summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs97
1 files changed, 58 insertions, 39 deletions
diff --git a/kiki.hs b/kiki.hs
index b8d5f14..d64cd0f 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1286,7 +1286,7 @@ kiki "show" args = do
1286 1286
1287kiki "merge" [] = do 1287kiki "merge" [] = do
1288 putStr . unlines $ 1288 putStr . unlines $
1289 [ "kiki merge [ --passphrase-fd=FD ... ]" 1289 [ "kiki merge [ ( --passphrase-fd=FD | --agent | --show-key=SPEC ) ... ]"
1290 , " ( --home[=HOMEDIR]" 1290 , " ( --home[=HOMEDIR]"
1291 , " | --type=(keyring|pem|wallet|hosts|dns)" 1291 , " | --type=(keyring|pem|wallet|hosts|dns)"
1292 , " | --access=[auto|secret|public]" 1292 , " | --access=[auto|secret|public]"
@@ -1306,6 +1306,9 @@ kiki "merge" [] = do
1306 , "" 1306 , ""
1307 , " --agent Use gpg-agent." 1307 , " --agent Use gpg-agent."
1308 , "" 1308 , ""
1309 , " --show-key=SPEC After files have been written, show information for the"
1310 , " key identified by SPEC."
1311 , ""
1309 , " FILE A path to a key file to read or update." 1312 , " FILE A path to a key file to read or update."
1310 , "" 1313 , ""
1311 , "MODIFIERS" 1314 , "MODIFIERS"
@@ -1335,12 +1338,14 @@ kiki "merge" args = do
1335 hPutStrLn stderr $ ppShow op 1338 hPutStrLn stderr $ ppShow op
1336 KikiResult rt report <- runKeyRing (mbAgent op) 1339 KikiResult rt report <- runKeyRing (mbAgent op)
1337 case rt of 1340 case rt of
1338 KikiSuccess rt -> return () 1341 KikiSuccess rt -> do let db = rtKeyDB rt
1342 forM_ keyspecs $ \keyspec -> do
1343 show_id keyspec (error "show_id wkgrip") db
1339 err -> putStrLn $ errorString err 1344 err -> putStrLn $ errorString err
1340 forM_ report $ \(fname,act) -> do 1345 forM_ report $ \(fname,act) -> do
1341 putStrLn $ fname ++ ": " ++ reportString act 1346 putStrLn $ fname ++ ": " ++ reportString act
1342 where 1347 where
1343 (_,(_,op)) = foldl' buildOp (True,(flow0,noop)) args' 1348 (_,((_,keyspecs),op)) = foldl' buildOp (True,((flow0,[]),noop)) args'
1344 (args',mbAgent) = case break (=="--agent") args of 1349 (args',mbAgent) = case break (=="--agent") args of
1345 (as,[]) -> (args, id) 1350 (as,[]) -> (args, id)
1346 (as,_:bs) -> ( as++bs 1351 (as,_:bs) -> ( as++bs
@@ -1395,29 +1400,37 @@ kiki "merge" args = do
1395 m <- filter ("match=" `isPrefixOf`) goods 1400 m <- filter ("match=" `isPrefixOf`) goods
1396 return $ drop 6 m 1401 return $ drop 6 m
1397 1402
1398 doFile :: StreamInfo -> KeyRingOperation -> FilePath -> (StreamInfo,KeyRingOperation) 1403 doFile :: (StreamInfo,[String]) -> KeyRingOperation
1399 doFile flow op fname = 1404 -> FilePath
1400 ( flow0 { typ = typ flow } -- everything resets except for --type 1405 -> ((StreamInfo,[String]),KeyRingOperation)
1406 doFile (flow,specs) op fname =
1407 ( (,) flow0 { typ = typ flow } specs -- everything resets except for --type
1401 , op { opFiles= Map.insert (ArgFile fname) flow (opFiles op) }) 1408 , op { opFiles= Map.insert (ArgFile fname) flow (opFiles op) })
1402 1409
1403 doDelete :: String -> StreamInfo -> KeyRingOperation -> (StreamInfo,KeyRingOperation) 1410 doDelete :: String -> (StreamInfo,[String]) -> KeyRingOperation -> ((StreamInfo,[String]),KeyRingOperation)
1404 doDelete fp flow op = ( flow 1411 doDelete fp flow op = ( flow
1405 , op { opTransforms = opTransforms op ++ [DeleteSubkeyByFingerprint fp] } ) 1412 , op { opTransforms = opTransforms op ++ [DeleteSubkeyByFingerprint fp] } )
1406 1413
1407 doDeleteUsage :: String -> StreamInfo -> KeyRingOperation -> (StreamInfo,KeyRingOperation) 1414 doDeleteUsage :: String -> (StreamInfo,[String])
1415 -> KeyRingOperation
1416 -> ((StreamInfo,[String]),KeyRingOperation)
1408 doDeleteUsage tag flow op = ( flow 1417 doDeleteUsage tag flow op = ( flow
1409 , op { opTransforms = opTransforms op ++ [DeleteSubkeyByUsage tag] } ) 1418 , op { opTransforms = opTransforms op ++ [DeleteSubkeyByUsage tag] } )
1410 1419
1411 doAutosign :: Bool -> StreamInfo -> KeyRingOperation -> (StreamInfo,KeyRingOperation) 1420 doAutosign :: Bool -> (StreamInfo,[String])
1412 doAutosign True flow op = 1421 -> KeyRingOperation
1422 -> ((StreamInfo,[String]),KeyRingOperation)
1423 doAutosign True (flow,specs) op =
1413 if Map.null (opFiles op) 1424 if Map.null (opFiles op)
1414 then (flow, op { opTransforms = opTransforms op ++ [Autosign] }) 1425 then ((,) flow specs, op { opTransforms = opTransforms op ++ [Autosign] })
1415 else (flow { transforms = transforms flow ++ [Autosign] }, op) 1426 else ((,) flow { transforms = transforms flow ++ [Autosign] } specs, op)
1416 doAutosign False flow op = 1427 doAutosign False (flow,specs) op =
1417 ( flow { transforms = filter (/=Autosign) (transforms flow) } 1428 ( (,) flow { transforms = filter (/=Autosign) (transforms flow) } specs
1418 , op { opTransforms = filter (/=Autosign) (opTransforms op) } ) 1429 , op { opTransforms = filter (/=Autosign) (opTransforms op) } )
1419 1430
1420 doPassphrase :: StreamInfo -> KeyRingOperation -> String -> (StreamInfo,KeyRingOperation) 1431 doPassphrase :: (StreamInfo,[String]) -> KeyRingOperation
1432 -> String
1433 -> ((StreamInfo,[String]),KeyRingOperation)
1421 doPassphrase flow op pass = 1434 doPassphrase flow op pass =
1422 if Map.null (opFiles op) 1435 if Map.null (opFiles op)
1423 then ( flow 1436 then ( flow
@@ -1427,8 +1440,11 @@ kiki "merge" args = do
1427 where 1440 where
1428 pfd = FileDesc (read pass) 1441 pfd = FileDesc (read pass)
1429 1442
1443 buildOp :: (Bool,((StreamInfo,[String]),KeyRingOperation))
1444 -> String
1445 -> (Bool,((StreamInfo,[String]),KeyRingOperation))
1430 buildOp (False,(flow,op)) fname = (False,doFile flow op fname) 1446 buildOp (False,(flow,op)) fname = (False,doFile flow op fname)
1431 buildOp (True,(flow,op)) arg@(splitArg->parsed) = 1447 buildOp (True,(flow@(si,specs),op)) arg@(splitArg->parsed) =
1432 case parsed of 1448 case parsed of
1433 Left ("",Nothing) -> (False,(flow,op)) 1449 Left ("",Nothing) -> (False,(flow,op))
1434 _ -> (True,) dispatch 1450 _ -> (True,) dispatch
@@ -1447,37 +1463,38 @@ kiki "merge" args = do
1447 Left ("autosign",Just "false")-> doAutosign False flow op 1463 Left ("autosign",Just "false")-> doAutosign False flow op
1448 Left ("passphrase-fd",Just pass) -> doPassphrase flow op pass 1464 Left ("passphrase-fd",Just pass) -> doPassphrase flow op pass
1449 Left ("create",Nothing) -> 1465 Left ("create",Nothing) ->
1450 ( flow { initializer = Internal (GenRSA (4096 `div` 8)) } 1466 ( (,) si { initializer = Internal (GenRSA (4096 `div` 8)) } specs
1451 , op ) 1467 , op )
1452 Left ("create",Just cmd) 1468 Left ("create",Just cmd)
1453 | "cmd:" `isPrefixOf` cmd 1469 | "cmd:" `isPrefixOf` cmd
1454 -> ( flow { initializer = case drop 4 cmd of 1470 -> ( (,) si { initializer = case drop 4 cmd of
1455 [] -> NoCreate 1471 [] -> NoCreate
1456 extern -> External extern } 1472 extern -> External extern } specs
1457 , op ) 1473 , op )
1458 Left ("create",Just cmd) 1474 Left ("create",Just cmd)
1459 | "rsa:" `isPrefixOf` cmd 1475 | "rsa:" `isPrefixOf` cmd
1460 -> ( flow { initializer = case drop 4 cmd of 1476 -> ( (,) si { initializer = case drop 4 cmd of
1461 [] -> NoCreate 1477 [] -> NoCreate
1462 bits -> 1478 bits ->
1463 case takeWhile isDigit bits of 1479 case takeWhile isDigit bits of
1464 [] -> NoCreate 1480 [] -> NoCreate
1465 digits -> Internal (GenRSA (read digits `div` 8)) } 1481 digits -> Internal (GenRSA (read digits `div` 8)) }
1482 specs
1466 , op ) 1483 , op )
1467 Left ("type",Just "keyring") -> ( flow { typ = KeyRingFile } , op ) 1484 Left ("type",Just "keyring") -> ( (,) si { typ = KeyRingFile } specs, op )
1468 Left ("type",Just "pem" ) -> ( flow { typ = PEMFile } , op ) 1485 Left ("type",Just "pem" ) -> ( (,) si { typ = PEMFile } specs, op )
1469 Left ("type",Just "wallet" ) -> ( flow { typ = WalletFile } , op ) 1486 Left ("type",Just "wallet" ) -> ( (,) si { typ = WalletFile } specs, op )
1470 Left ("type",Just "hosts" ) -> ( flow { typ = Hosts } , op ) 1487 Left ("type",Just "hosts" ) -> ( (,) si { typ = Hosts } specs, op )
1471 Left ("type",Just "dns" ) -> ( flow { typ = DNSPresentation } , op ) 1488 Left ("type",Just "dns" ) -> ( (,) si { typ = DNSPresentation } specs, op )
1472 Left ("access",Just "public") -> ( flow { access = Pub }, op ) 1489 Left ("access",Just "public") -> ( (,) si { access = Pub } specs, op )
1473 Left ("access",Just "secret") -> ( flow { access = Sec }, op ) 1490 Left ("access",Just "secret") -> ( (,) si { access = Sec } specs, op )
1474 Left ("access",Just "auto") -> ( flow { access = AutoAccess }, op ) 1491 Left ("access",Just "auto") -> ( (,) si { access = AutoAccess } specs, op )
1475 Left ("home",mb) -> 1492 Left ("home",mb) ->
1476 ( flow 1493 ( flow
1477 , op { opFiles = Map.insert HomePub (flow { typ=KeyRingFile 1494 , op { opFiles = Map.insert HomePub (si { typ=KeyRingFile
1478 , access=Pub }) 1495 , access=Pub })
1479 $ Map.insert HomeSec (flow { typ=KeyRingFile 1496 $ Map.insert HomeSec (si { typ=KeyRingFile
1480 , access=Sec }) 1497 , access=Sec })
1481 $ opFiles op 1498 $ opFiles op
1482 , opHome = opHome op `mplus` mb 1499 , opHome = opHome op `mplus` mb
1483 } 1500 }
@@ -1485,9 +1502,11 @@ kiki "merge" args = do
1485 Left ("flow",Just flowspec) -> 1502 Left ("flow",Just flowspec) ->
1486 case parseFlow flowspec of 1503 case parseFlow flowspec of
1487 Just ( (spil,fil), mtch ) -> 1504 Just ( (spil,fil), mtch ) ->
1488 ( updateFlow fil spil mtch flow 1505 ( (,) (updateFlow fil spil mtch si) specs
1489 , op ) 1506 , op )
1490 Nothing -> error "Valid flow words are: spill,fill,sync,signed,subkeys or match=KEYSPEC" 1507 Nothing -> error "Valid flow words are: spill,fill,sync,signed,subkeys or match=KEYSPEC"
1508 Left ("show-key",Just keyspec) -> ( (,) si (keyspec:specs)
1509 , op )
1491 Left (option,_) -> error $ "Unrecognized option: " ++ option 1510 Left (option,_) -> error $ "Unrecognized option: " ++ option
1492 1511
1493kiki "init" args | "--help" `elem` args = do 1512kiki "init" args | "--help" `elem` args = do
@@ -1718,7 +1737,7 @@ tarC (sargs,margs) = do
1718-- 1737--
1719-- single leading hyphen, quits program with "Unrecognized option" error 1738-- single leading hyphen, quits program with "Unrecognized option" error
1720-- 1739--
1721-- Otherwise, Left (key-value pair) is returend by parsing 1740-- Otherwise, Left (key-value pair) is returned by parsing
1722-- a string of the form --key=value. 1741-- a string of the form --key=value.
1723splitArg :: String -> Either (String,Maybe String) String 1742splitArg :: String -> Either (String,Maybe String) String
1724splitArg arg = 1743splitArg arg =