summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2013-12-02 17:12:23 -0500
committerjoe <joe@jerkface.net>2013-12-02 17:12:23 -0500
commit21cb0d8df64e4fca45abdd39007059451a9528e0 (patch)
tree7054158e55215351b8d0c26d766096d2350e6ee9 /kiki.hs
parentf93e48b4ee5a2930ca19e8c324804ed4a314ae42 (diff)
Work in progress toward cross-merge interface.
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs203
1 files changed, 52 insertions, 151 deletions
diff --git a/kiki.hs b/kiki.hs
index c1e6aea..1ea014d 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -53,6 +53,11 @@ import System.Posix.Files
53import Data.Monoid ((<>)) 53import Data.Monoid ((<>))
54-- import Data.X509 54-- import Data.X509
55import qualified Data.Map as Map 55import qualified Data.Map as Map
56import DotLock
57import System.IO (hPutStrLn,stderr)
58
59
60warn str = hPutStrLn stderr str
56 61
57unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) 62unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
58 where p = break (==c) spec 63 where p = break (==c) spec
@@ -556,7 +561,21 @@ readPacketsFromFile fname = do
556 Right (_,_,msg ) -> msg 561 Right (_,_,msg ) -> msg
557 Left (_,_,_) -> Message [] 562 Left (_,_,_) -> Message []
558 563
559readPacketsFromFile' n = fmap (n,) (readPacketsFromFile n) 564lockFiles fs = do
565 let dolock f = do
566 lk <- dotlock_create f 0
567 let fail = return Nothing
568 dotake lk = do
569 e <- dotlock_take lk (-1)
570 if e==0 then return (Just lk)
571 else fail
572 v <- maybe fail dotake lk
573 return (v,f)
574 ls <- mapM dolock fs
575 let (lks, fails) = partition (isJust . fst) ls
576 return (map (\(lk,f)->(fromJust lk,f)) lks, map snd fails)
577
578unlockFiles lks = forM_ lks $ \lk -> dotlock_release lk
560 579
561parseOptionFile fname = do 580parseOptionFile fname = do
562 xs <- fmap lines (readFile fname) 581 xs <- fmap lines (readFile fname)
@@ -765,41 +784,6 @@ readKeyFromFile False "PEM" fname = do
765 } 784 }
766readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) 785readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt)
767 786
768data Arguments =
769 List { homedir :: Maybe FilePath }
770 | WorkingKey { homedir :: Maybe FilePath }
771 | AutoSign { homedir :: Maybe FilePath
772 , passphrase_fd :: Maybe Int
773 , input :: FilePath
774 , output :: FilePath}
775 | Public { homedir :: Maybe FilePath
776 , output :: FilePath}
777 | Add { homedir :: Maybe FilePath
778 , passphrase_fd :: Maybe Int
779 , key_usage :: String
780 , seckey :: String
781 , output :: FilePath }
782 | PemFP { homedir :: Maybe FilePath
783 , seckey :: String }
784 | CatPub { homedir :: Maybe FilePath
785 , catpub_args :: [String] }
786 | MergeSecrets
787 { homedir :: Maybe FilePath
788 , files :: [FilePath]
789 }
790 | Merge { homedir :: Maybe FilePath
791 , files :: [FilePath]
792 }
793 | DumpPackets { homedir :: Maybe FilePath
794 , marshal_test :: String
795 , files :: [FilePath] }
796 {-
797 | Decrypt { homedir :: Maybe FilePath
798 , passphrase_fd :: Maybe Int
799 , output :: FilePath }
800 -}
801 deriving (Show, Data, Typeable)
802
803getPassphrase cmd = 787getPassphrase cmd =
804 case passphrase_fd cmd of 788 case passphrase_fd cmd of
805 Just fd -> do pwh <- fdToHandle (toEnum fd) 789 Just fd -> do pwh <- fdToHandle (toEnum fd)
@@ -972,96 +956,27 @@ flattenKeys isPublic db = Message $ concatMap flattenTop (prefilter . Map.assocs
972 where isSecret (_,(KeyData (SecretKeyPacket {}) _ _ _)) = True 956 where isSecret (_,(KeyData (SecretKeyPacket {}) _ _ _)) = True
973 isSecret _ = False 957 isSecret _ = False
974 958
975{- 959writeOutKeyrings db = return () -- TODO
976merge db (Message ps) = scanl mergeit db qs
977 where
978 qs = scanPackets ps
979 mergeit db (top,sub,p) = todo
980 where
981 k = keykey top
982 v = maybe (merge1 (newrec top)) (merge2 sub p) $ Map.lookup k db
983
984 keykey key = fingerprint_material key -- TODO: smaller key?
985 960
986 newrec key | isKey key && not (is_subkey key) = 961data Arguments =
987 KeyData key [] Map.empty Map.empty 962 Cross_Merge { homedir :: Maybe FilePath
988 newrec _ = error "Unexpected packet." 963 , passphrase_fd :: Maybe Int
964 , files :: [FilePath]
965 }
966 deriving (Show, Data, Typeable)
989 967
990 merge1 rec db = Map.insert k rec db
991 968
992 merge2 sub p (KeyData mk sigs uids subkeys)
993 | isKey sub =
994 maybe todo todo $ Map.lookup skey subkeys
995 where
996 skey = keykey sub
997-}
998 969
999main = do 970main = do
971 dotlock_init
1000 args <- cmdArgs $ modes 972 args <- cmdArgs $ modes
1001 [ List HOMEOPTION 973 [ Cross_Merge HOMEOPTION
1002 &= help "List key pairs in the secret keyring."
1003 &= auto
1004 , WorkingKey HOMEOPTION
1005 &= help "Shows the current working key set that will be used to make signatures."
1006 , Public HOMEOPTION
1007 (def &= argPos 1 &= typFile )
1008 &= help "Extract public keys into the given file."
1009 , AutoSign HOMEOPTION
1010 (def &= opt ("passphrase"::String)
1011 &= typ "FD"
1012 &= (help . concat) ["file descriptor from "
1013 ,"which to read passphrase"])
1014 (def &= argPos 1 &= typFile )
1015 (def &=argPos 2 &= typFile)
1016 &= (help . concat)
1017 [ "Copies the first file to the second while adding"
1018 , " signatures for tor-style uids that match"
1019 , " cross-certified keys." ]
1020 {-
1021 , Decrypt HOMEOPTION
1022 (def &= opt ("passphrase"::String) 974 (def &= opt ("passphrase"::String)
1023 &= typ "FD" 975 &= typ "FD"
1024 &= (help . concat) ["file descriptor from " 976 &= (help . concat) ["file descriptor from "
1025 ,"which to read passphrase"]) 977 ,"which to read passphrase"])
1026 (def &= argPos 1 &= typFile )
1027 -- (def &= argPos 3 &= typ "PUBLIC-KEY")
1028 &= (help . concat)
1029 [ "Remove password protection from the working keyring"
1030 , " and save the result into the given file."]
1031 -}
1032 , CatPub HOMEOPTION
1033 (def &= args &= typ "KEYSPEC FILES")
1034 &= help "Extract a public subkey to stdout."
1035 , MergeSecrets HOMEOPTION
1036 (def &= args &= typFile) 978 (def &= args &= typFile)
1037 &= help "Merge multiple secret keyrings to stdout." 979 &= help "Merge multiple secret keyrings to stdout."
1038 , Merge HOMEOPTION
1039 (def &= args &= typFile)
1040 &= help "Merge multiple keyrings to stdout. Secrets are filtered."
1041 , DumpPackets HOMEOPTION
1042 (def &= opt ("n" ::String))
1043 (def &= args &= typFile)
1044 &= help "Output secret ring packets in ascii format for debugging."
1045 , Add HOMEOPTION
1046 (def &= opt ("passphrase"::String)
1047 &= typ "FD"
1048 &= (help . concat) ["file descriptor from "
1049 ,"which to read passphrase"])
1050 (def &= argPos 1 &= typ "USAGE")
1051 (def &= argPos 2 &= typ "PRIVATE-KEY")
1052 (def &= argPos 3 &= typFile)
1053 -- (def &= argPos 3 &= typ "PUBLIC-KEY")
1054 &= (help . concat)
1055 [ "Add a subkey."
1056 , " USAGE is the usage@ annotation of the subkey."
1057 , " Keys are specified as FMT:FILE where"
1058 , " FMT may be one of following: PEM."
1059 , " Results are written to the given file." ]
1060
1061 , PemFP HOMEOPTION
1062 (def &= argPos 1 &= typFile )
1063 &= (help . concat)
1064 [ "Display the fingerprint of a PEM key pair."]
1065 ] 980 ]
1066 &= program "kiki" 981 &= program "kiki"
1067 &= summary "kiki - a pgp key editing utility" 982 &= summary "kiki - a pgp key editing utility"
@@ -1086,9 +1001,10 @@ main = do
1086 homedir $ \homedir -> do 1001 homedir $ \homedir -> do
1087 -- putStrLn $ "homedir = " ++show homedir 1002 -- putStrLn $ "homedir = " ++show homedir
1088 let secring = homedir ++ "/" ++ "secring.gpg" 1003 let secring = homedir ++ "/" ++ "secring.gpg"
1004 pubring = homedir ++ "/" ++ "pubring.gpg"
1089 -- putStrLn $ "secring = " ++ show secring 1005 -- putStrLn $ "secring = " ++ show secring
1090 workingkey <- getWorkingKey homedir 1006 workingkey <- getWorkingKey homedir
1091 return (homedir,secring,workingkey) 1007 return (homedir,secring,pubring,workingkey)
1092 1008
1093 getWorkingKey homedir = do 1009 getWorkingKey homedir = do
1094 let o = Nothing 1010 let o = Nothing
@@ -1107,7 +1023,7 @@ main = do
1107 return $ lookup "default-key" config >>= listToMaybe 1023 return $ lookup "default-key" config >>= listToMaybe
1108 1024
1109 getPGPEnviron cmd = do 1025 getPGPEnviron cmd = do
1110 (homedir,secring,grip) <- getHomeDir cmd 1026 (homedir,secring,pubring,grip) <- getHomeDir cmd
1111 (Message sec) <- readPacketsFromFile secring 1027 (Message sec) <- readPacketsFromFile secring
1112 let (keys,_) = partition (\k -> case k of 1028 let (keys,_) = partition (\k -> case k of
1113 { SecretKeyPacket {} -> True 1029 { SecretKeyPacket {} -> True
@@ -1192,6 +1108,7 @@ main = do
1192 1108
1193 ys = uid:sigs'++xs'' 1109 ys = uid:sigs'++xs''
1194 1110
1111 {-
1195 doCmd cmd@(List {}) = do 1112 doCmd cmd@(List {}) = do
1196 (homedir,secring,grip) <- getHomeDir cmd 1113 (homedir,secring,grip) <- getHomeDir cmd
1197 (Message sec) <- readPacketsFromFile secring 1114 (Message sec) <- readPacketsFromFile secring
@@ -1268,28 +1185,6 @@ main = do
1268 bs = encode (Message pub) 1185 bs = encode (Message pub)
1269 L.writeFile (output cmd) bs 1186 L.writeFile (output cmd) bs
1270 1187
1271 {-
1272 doCmd cmd@(Decrypt {}) = do
1273 ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
1274 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
1275 , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
1276 ) <- getPGPEnviron cmd
1277 pw <- getPassphrase cmd
1278
1279 let sec' = map decrypt sec
1280 decrypt k@(SecretKeyPacket {}) = k -- TODO
1281
1282 L.writeFile (output cmd) (encode $ Message sec')
1283
1284 {-
1285 let wk = grip >>= find_key fingerprint (Message sec)
1286 case wk of
1287 Nothing -> error "No working key?"
1288 Just wk -> do
1289 putStrLn $ "wk = " ++ fingerprint wk
1290 -}
1291 -}
1292
1293 doCmd cmd@(DumpPackets {}) = do 1188 doCmd cmd@(DumpPackets {}) = do
1294 ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome 1189 ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
1295 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg 1190 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
@@ -1317,18 +1212,23 @@ main = do
1317 L.putStr (encode m) 1212 L.putStr (encode m)
1318 return () 1213 return ()
1319 1214
1320 doCmd cmd@(Merge {}) = do 1215 -}
1321 ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome 1216
1322 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg 1217 doCmd cmd@(Cross_Merge {}) = do
1323 , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" 1218 (homedir,secring,pubring,grip0) <- getHomeDir cmd
1324 ) <- getPGPEnviron cmd 1219 -- grip0 may be empty, in which case we should use the first key
1325 let db = merge Map.empty "%secring" (Message sec) 1220 (fsns,failed_locks) <- lockFiles (secring:pubring:files cmd)
1326 ms <- mapM readPacketsFromFile' (files cmd) 1221 forM_ failed_locks $ \f -> warn $ "Failed to lock: " ++ f
1327 let db' = foldl' (uncurry . merge) db ms 1222 let (lks,fs) = unzip fsns
1328 m = flattenKeys True db' 1223 forM_ fs $ \f -> warn $ "locked: " ++ f
1329 L.putStr (encode m) 1224 let readp n = fmap (n,) (readPacketsFromFile n)
1225 ms <- mapM readp fs
1226 let db = foldl' (uncurry . merge) Map.empty ms
1227 writeOutKeyrings db
1228 unlockFiles lks
1330 return () 1229 return ()
1331 1230
1231 {-
1332 doCmd cmd@(CatPub {}) = do 1232 doCmd cmd@(CatPub {}) = do
1333 let spec:files = catpub_args cmd 1233 let spec:files = catpub_args cmd
1334 let (topspec,subspec) = unprefix '/' spec 1234 let (topspec,subspec) = unprefix '/' spec
@@ -1458,6 +1358,7 @@ main = do
1458 -- let torhash sub = maybe "" id $ derToBase32 <$> derRSA sub 1358 -- let torhash sub = maybe "" id $ derToBase32 <$> derRSA sub
1459 putStrLn $ fingerprint (head seckey) -- ++ " " ++ torhash (head seckey) 1359 putStrLn $ fingerprint (head seckey) -- ++ " " ++ torhash (head seckey)
1460 1360
1361 -}
1461 1362
1462isSameKey a b = sort (key apub) == sort (key bpub) 1363isSameKey a b = sort (key apub) == sort (key bpub)
1463 where 1364 where