summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--kiki.cabal2
-rw-r--r--kiki.hs116
2 files changed, 74 insertions, 44 deletions
diff --git a/kiki.cabal b/kiki.cabal
index fbf9470..0a517f0 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -20,6 +20,6 @@ Executable kiki
20 dataenc -any, text -any, pretty -any, pretty-show -any, 20 dataenc -any, text -any, pretty -any, pretty-show -any,
21 bytestring -any, openpgp (==0.6.1), binary -any, 21 bytestring -any, openpgp (==0.6.1), binary -any,
22 unix, time, crypto-api, cryptocipher (>=0.3.7), 22 unix, time, crypto-api, cryptocipher (>=0.3.7),
23 containers -any 23 containers -any, process -any, filepath -any
24 ghc-options: -O2 24 ghc-options: -O2
25 c-sources: dotlock.c 25 c-sources: dotlock.c
diff --git a/kiki.hs b/kiki.hs
index e6e0630..54cacc3 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -11,6 +11,7 @@ module Main where
11import Debug.Trace 11import Debug.Trace
12import GHC.Exts (Down(..)) 12import GHC.Exts (Down(..))
13import GHC.IO.Exception ( ioException, IOErrorType(..) ) 13import GHC.IO.Exception ( ioException, IOErrorType(..) )
14import Data.IORef
14import Data.Tuple 15import Data.Tuple
15import Data.Binary 16import Data.Binary
16import Data.OpenPGP 17import Data.OpenPGP
@@ -41,6 +42,7 @@ import Data.ASN1.BitArray
41import Control.Applicative 42import Control.Applicative
42import System.Environment 43import System.Environment
43import System.Directory 44import System.Directory
45import System.FilePath
44import System.Exit 46import System.Exit
45import System.Process 47import System.Process
46import System.Posix.IO (fdToHandle,fdRead) 48import System.Posix.IO (fdToHandle,fdRead)
@@ -602,6 +604,7 @@ expandPath path [] = []
602 604
603readPacketsFromFile :: FilePath -> IO Message 605readPacketsFromFile :: FilePath -> IO Message
604readPacketsFromFile fname = do 606readPacketsFromFile fname = do
607 -- warn $ fname ++ ": reading..."
605 input <- L.readFile fname 608 input <- L.readFile fname
606 return $ 609 return $
607 case decodeOrFail input of 610 case decodeOrFail input of
@@ -807,15 +810,24 @@ writeKeyToFile False "PEM" fname packet = do
807 dta = Base64.encode (L.unpack bs) 810 dta = Base64.encode (L.unpack bs)
808 output = writePEM "RSA PRIVATE KEY" dta 811 output = writePEM "RSA PRIVATE KEY" dta
809 stamp = toEnum . fromEnum $ timestamp packet 812 stamp = toEnum . fromEnum $ timestamp packet
810 writeFile fname output 813 createDirectoryIfMissing True (takeDirectory fname)
811 -- Note: The key's timestamp is included in it's fingerprint. 814 handleIO_ (warn $ fname ++ ": write failure") $ do
812 -- Therefore, we should attempt to preserve it. 815 saved_mask <- setFileCreationMask 0o077
813 setFileTimes fname stamp stamp 816 writeFile fname output
817 -- Note: The key's timestamp is included in it's fingerprint.
818 -- Therefore, we should attempt to preserve it.
819 setFileTimes fname stamp stamp
820 setFileCreationMask saved_mask
821 return ()
822 -- warn $ fname++ ": wrote"
823 return ()
814 824
815readKeyFromFile False "PEM" fname = do 825readKeyFromFile False "PEM" fname = do
826 -- warn $ fname ++ ": reading ..."
816 -- Note: The key's timestamp is included in it's fingerprint. 827 -- Note: The key's timestamp is included in it's fingerprint.
817 -- Therefore, we should attempt to preserve it. 828 -- Therefore, we should attempt to preserve it.
818 timestamp <- modificationTime <$> getFileStatus fname 829 timestamp <- handleIO_ (error $ fname++": modificaiton time?") $
830 modificationTime <$> getFileStatus fname
819 input <- L.readFile fname 831 input <- L.readFile fname
820 let dta = extractPEM "RSA PRIVATE KEY" input 832 let dta = extractPEM "RSA PRIVATE KEY" input
821 -- Char8.putStrLn $ "dta = " <> dta 833 -- Char8.putStrLn $ "dta = " <> dta
@@ -1125,8 +1137,8 @@ writeOutKeyrings lkmap db = do
1125 d@(KeyData p _ _ _) <- filter (fromfile f) (sortByHint f keyPacket ks) 1137 d@(KeyData p _ _ _) <- filter (fromfile f) (sortByHint f keyPacket ks)
1126 n <- maybeToList $ Map.lookup f (locations p) 1138 n <- maybeToList $ Map.lookup f (locations p)
1127 flattenTop f (originallyPublic n) d 1139 flattenTop f (originallyPublic n) d
1128 changes = filter notnew x 1140 changes = filter isnew x
1129 where notnew p = isNothing (Map.lookup f $ locations p) 1141 where isnew p = isNothing (Map.lookup f $ locations p)
1130 {- 1142 {-
1131 trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++ 1143 trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++
1132 ( "CHANGES: " : map ((" "++) . showPacket . packet) changes)) $ do 1144 ( "CHANGES: " : map ((" "++) . showPacket . packet) changes)) $ do
@@ -1166,17 +1178,17 @@ cross_merge keyrings f = do
1166 where isSecringKey (fn,Message ps) 1178 where isSecringKey (fn,Message ps)
1167 | fn==sec_n = listToMaybe ps 1179 | fn==sec_n = listToMaybe ps
1168 isSecringKey _ = Nothing 1180 isSecringKey _ = Nothing
1169 -- unlockFiles fsns ----------- 1181 -- unlockFiles fsns ----------- Originally, I did this to enable altering the gpg keyrings
1170 ------------------------------- 1182 ------------------------------- from external tools.
1171 db' <- f (sec_n,fstkey) db 1183 (db',_) <- f (sec_n,fstkey) db
1172 -- lk <- relock --------------- 1184 -- lk <- relock --------------- The design is not quite safe, so it is disabled for now.
1173 let lk = (fsns,failed_locks) -- 1185 let lk = (fsns,failed_locks) --
1174 ------------------------------- 1186 -------------------------------
1175 maybe (if n==0 then pass 1 lk else return (lk,db)) 1187 maybe (if n==0 then pass 1 lk else return (lk,db))
1176 (return . (lk,)) 1188 (return . (lk,))
1177 db' 1189 db'
1178 ((fsns,failed_locks),db) <- pass 0 (fsns,failed_locks) 1190 ((fsns,failed_locks),db) <- pass 0 (fsns,failed_locks)
1179 let lkmap = Map.fromList (map swap fsns) 1191 let lkmap = Map.fromList $ map swap fsns
1180 writeOutKeyrings lkmap db 1192 writeOutKeyrings lkmap db
1181 unlockFiles fsns 1193 unlockFiles fsns
1182 return () 1194 return ()
@@ -1281,7 +1293,7 @@ systemEnv vars cmd = do
1281 _ <- installHandler sigQUIT old_quit Nothing 1293 _ <- installHandler sigQUIT old_quit Nothing
1282 return r 1294 return r
1283 1295
1284doExport doDecrypt db (fname,subspec,ms,cmd) = 1296doExport doDecrypt (db,use_db) (fname,subspec,ms,cmd) =
1285 case ms of 1297 case ms of
1286 [_] -> export 1298 [_] -> export
1287 (_:_) -> ambiguous 1299 (_:_) -> ambiguous
@@ -1291,20 +1303,23 @@ doExport doDecrypt db (fname,subspec,ms,cmd) =
1291 shcmd = do 1303 shcmd = do
1292 let noop warning = do 1304 let noop warning = do
1293 warn warning 1305 warn warning
1294 return db 1306 return (db,use_db)
1295 if null cmd then noop (fname ++ ": missing.") else do 1307 if null cmd then noop (fname ++ ": missing.") else do
1296 let vars = [ ("file",fname) 1308 let vars = [ ("file",fname)
1297 , ("usage",maybe "" id subspec) ] 1309 , ("usage",maybe "" id subspec) ]
1298 e <- systemEnv vars cmd 1310 e <- systemEnv vars cmd
1299 case e of 1311 case e of
1300 ExitFailure num -> noop $ fname ++ ": failed external (code="++show num++")" 1312 ExitFailure num -> noop $ fname ++ ": failed external (code="++show num++")"
1301 ExitSuccess -> return Nothing -- need another pass 1313 ExitSuccess -> do
1314 warn $ fname ++ ": generated"
1315 return (Nothing,use_db) -- need another pass
1302 export = do 1316 export = do
1303 let [(kk,KeyData key sigs uids subkeys)] = ms 1317 let [kk] = ms
1318 Just (KeyData key sigs uids subkeys) = Map.lookup kk use_db
1304 p = flip (maybe (Just $ packet key)) subspec $ \tag -> do 1319 p = flip (maybe (Just $ packet key)) subspec $ \tag -> do
1305 let subs = Map.elems subkeys 1320 let subs = Map.elems subkeys
1306 doSearch (SubKey sub_mp sigtrusts) = 1321 doSearch (SubKey sub_mp sigtrusts) =
1307 let (_,v,_) = searchSubkeys tag 1322 let (_,v,_) = findTag tag
1308 (packet key) 1323 (packet key)
1309 (packet sub_mp) 1324 (packet sub_mp)
1310 sigtrusts 1325 sigtrusts
@@ -1316,11 +1331,11 @@ doExport doDecrypt db (fname,subspec,ms,cmd) =
1316 flip (maybe shcmd) p $ \p -> do 1331 flip (maybe shcmd) p $ \p -> do
1317 pun <- doDecrypt p 1332 pun <- doDecrypt p
1318 flip (maybe $ error "Bad passphrase?") pun $ \pun -> do 1333 flip (maybe $ error "Bad passphrase?") pun $ \pun -> do
1319 warn $ "writing "++fname
1320 writeKeyToFile False "PEM" fname pun 1334 writeKeyToFile False "PEM" fname pun
1321 return db 1335 warn $ fname ++ ": exported"
1336 return (db,use_db)
1322 1337
1323searchSubkeys tag wk subkey subsigs = (xs',minsig,ys') 1338findTag tag wk subkey subsigs = (xs',minsig,ys')
1324 where 1339 where
1325 vs = map (\sig -> 1340 vs = map (\sig ->
1326 (sig, do 1341 (sig, do
@@ -1337,7 +1352,7 @@ searchSubkeys tag wk subkey subsigs = (xs',minsig,ys')
1337 subsigs 1352 subsigs
1338 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs 1353 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
1339 xs' = map fst xs 1354 xs' = map fst xs
1340 ys' = map fst (drop 1 ys) 1355 ys' = map fst $ if isNothing minsig then ys else drop 1 ys
1341 minsig = do 1356 minsig = do
1342 (sig,ov) <- listToMaybe ys 1357 (sig,ov) <- listToMaybe ys
1343 ov 1358 ov
@@ -1360,7 +1375,8 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
1360 let (m0,tailms) = splitAt 1 ms 1375 let (m0,tailms) = splitAt 1 ms
1361 when (not (null tailms) || null m0) 1376 when (not (null tailms) || null m0)
1362 $ error "Key specification is ambiguous." 1377 $ error "Key specification is ambiguous."
1363 let (kk,KeyData top topsigs uids subs) = head m0 1378 let kk = head m0
1379 Just (KeyData top topsigs uids subs) = Map.lookup kk db
1364 let subkk = keykey key 1380 let subkk = keykey key
1365 (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1)))) 1381 (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1))))
1366 []) 1382 [])
@@ -1368,15 +1384,15 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
1368 (Map.lookup subkk subs) 1384 (Map.lookup subkk subs)
1369 let SubKey subkey_p subsigs = subkey 1385 let SubKey subkey_p subsigs = subkey
1370 wk = packet top 1386 wk = packet top
1371 (xs',minsig,ys') = searchSubkeys tag wk key subsigs 1387 (xs',minsig,ys') = findTag tag wk key subsigs
1372 doInsert mbsig db = do 1388 doInsert mbsig db = do
1373 sig' <- makeSig doDecrypt top fname subkey_p tag mbsig 1389 sig' <- makeSig doDecrypt top fname subkey_p tag mbsig
1374 warn $ fname ++ ": yield SignaturePacket" 1390 warn $ fname ++ ": yield SignaturePacket"
1375 let subs' = Map.insert subkk 1391 let subs' = Map.insert subkk
1376 (SubKey subkey_p $ xs'++[sig']++ys') 1392 (SubKey subkey_p $ xs'++[sig']++ys')
1377 subs 1393 subs
1378 return $ Map.insert kk (KeyData top topsigs uids subs') db 1394 return $ Map.insert kk (KeyData top topsigs uids subs') db
1379 when is_new (warn $ fname ++ ": yield SecretKeyPacket "++fingerprint key) 1395 when is_new (warn $ fname ++ ": yield SecretKeyPacket "++show (fmap fst minsig,fingerprint key))
1380 case minsig of 1396 case minsig of
1381 Nothing -> doInsert Nothing db -- we need to create a new sig 1397 Nothing -> doInsert Nothing db -- we need to create a new sig
1382 Just (True,sig) -> return db -- we can deduce is_new == False 1398 Just (True,sig) -> return db -- we can deduce is_new == False
@@ -1529,6 +1545,8 @@ main = do
1529 $ args' 1545 $ args'
1530 appendArgs xs = Just . maybe xs (++xs) 1546 appendArgs xs = Just . maybe xs (++xs)
1531 -- putStrLn $ "margs = " ++ show (Map.assocs margs) 1547 -- putStrLn $ "margs = " ++ show (Map.assocs margs)
1548 unkeysRef <- newIORef Map.empty
1549 pwRef <- newIORef Nothing
1532 let keypairs0 = 1550 let keypairs0 =
1533 flip map (maybe [] id $ Map.lookup "--keypairs" margs) $ \specfile -> do 1551 flip map (maybe [] id $ Map.lookup "--keypairs" margs) $ \specfile -> do
1534 let (spec,efilecmd) = break (=='=') specfile 1552 let (spec,efilecmd) = break (=='=') specfile
@@ -1550,19 +1568,27 @@ main = do
1550 keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs 1568 keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs
1551 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs 1569 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
1552 decrypt wk = do 1570 decrypt wk = do
1553 -- TODO: memoize? 1571 -- warn $ "decryptKey "++fingerprint wk
1554 pw <- case passphrase_fd of 1572 unkeys <- readIORef unkeysRef
1573 let kk = keykey wk
1574 flip (flip maybe $ return . Just) (Map.lookup kk unkeys) $ do
1575 let ret wkun = do writeIORef unkeysRef (Map.insert kk wkun unkeys)
1576 return (Just wkun)
1577 if symmetric_algorithm wk == Unencrypted then ret wk else do
1578 pw <- do
1579 pw <- readIORef pwRef
1580 flip (flip maybe return) pw $ do
1581 case passphrase_fd of
1555 Just fd -> do pwh <- fdToHandle (read fd) 1582 Just fd -> do pwh <- fdToHandle (read fd)
1556 fmap trimCR $ S.hGetContents pwh 1583 pw <- fmap trimCR $ S.hGetContents pwh
1584 writeIORef pwRef (Just pw)
1585 return pw
1557 Nothing -> return "" 1586 Nothing -> return ""
1558 let wkun = 1587 let wkun = do
1559 if symmetric_algorithm wk == Unencrypted 1588 k <- decryptSecretKey pw wk
1560 then Just wk 1589 guard (symmetric_algorithm k == Unencrypted)
1561 else do 1590 return k
1562 k <- decryptSecretKey pw wk 1591 maybe (return Nothing) ret wkun
1563 guard (symmetric_algorithm k == Unencrypted)
1564 return k
1565 return wkun
1566 1592
1567 when (not . null $ filter isNothing keypairs0) $ do 1593 when (not . null $ filter isNothing keypairs0) $ do
1568 warn "syntax error" 1594 warn "syntax error"
@@ -1601,19 +1627,23 @@ main = do
1601 } 1627 }
1602 dont_have (KeyData p _ _ _) = not . Map.member pubring 1628 dont_have (KeyData p _ _ _) = not . Map.member pubring
1603 $ locations p 1629 $ locations p
1604 use_db <- get_use_db 1630 use_db0 <- get_use_db
1605 1631
1606 let pkeypairs = maybe [] id $ do 1632 let pkeypairs = maybe [] id $ do
1607 g <- grip 1633 g <- grip
1608 return $ map (\(spec,f,cmd)-> (parseSpec g spec,f,cmd)) keypairs 1634 return $ map (\(spec,f,cmd)-> (parseSpec g spec,f,cmd)) keypairs
1609 fs <- forM pkeypairs $ \((topspec,subspec),f,cmd) -> do 1635 fs <- forM pkeypairs $ \((topspec,subspec),f,cmd) -> do
1610 let ms = filterMatches topspec (Map.toList db) 1636 -- Note that it's important to discard the KeyData objects
1637 -- returned by filterMatches and retain only the keys.
1638 -- Otherwise, the iterations within the foldM would not be
1639 -- able to alter them by returning a modified KeyDB.
1640 let ms = map fst $ filterMatches topspec (Map.toList db)
1611 f_found <- doesFileExist f 1641 f_found <- doesFileExist f
1612 return (f_found,(f,subspec,ms,cmd)) 1642 return (f_found,(f,subspec,ms,cmd))
1613 1643
1614 let (imports,exports) = partition fst fs 1644 let (imports,exports) = partition fst fs
1615 use_db <- foldM (doImport decrypt) use_db (map snd imports) 1645 use_db <- foldM (doImport decrypt) use_db0 (map snd imports)
1616 ret_db <- foldM (doExport decrypt) (Just use_db) (map snd exports) 1646 (ret_db,_) <- foldM (doExport decrypt) (Just use_db,use_db) (map snd exports)
1617 1647
1618 flip (maybe $ return ()) ret_db . const $ do 1648 flip (maybe $ return ()) ret_db . const $ do
1619 -- On last pass, interpret --show-* commands. 1649 -- On last pass, interpret --show-* commands.
@@ -1623,7 +1653,7 @@ main = do
1623 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs 1653 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs
1624 1654
1625 forM_ shargs $ \(cmd,args) -> cmd args use_db 1655 forM_ shargs $ \(cmd,args) -> cmd args use_db
1626 return $ ret_db 1656 return $ (ret_db,use_db)
1627 1657
1628 return() 1658 return()
1629 where 1659 where
@@ -1863,7 +1893,7 @@ main = do
1863 doCmd cmd@(Cross_Merge {}) = do 1893 doCmd cmd@(Cross_Merge {}) = do
1864 (homedir,secring,pubring,grip0) <- getHomeDir (homedir cmd) 1894 (homedir,secring,pubring,grip0) <- getHomeDir (homedir cmd)
1865 -- grip0 may be empty, in which case we should use the first key 1895 -- grip0 may be empty, in which case we should use the first key
1866 cross_merge (secring:pubring:files cmd) $ \_ db -> return $ Just db 1896 cross_merge (secring:pubring:files cmd) $ \_ db -> return $ (Just db,db)
1867 1897
1868 {- 1898 {-
1869 doCmd cmd@(CatPub {}) = do 1899 doCmd cmd@(CatPub {}) = do