summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2013-12-04 17:24:04 -0500
committerjoe <joe@jerkface.net>2013-12-04 17:24:04 -0500
commit0319f5ac37d0d76ad7c0d7d37b9f66a46ee053c8 (patch)
treeabd973155e83f28bec4560a4c408353e9a5f16f6 /kiki.hs
parentc14cc300045989074ad433af96a36c0d86fc9e5b (diff)
Changed command line syntax.
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs145
1 files changed, 127 insertions, 18 deletions
diff --git a/kiki.hs b/kiki.hs
index d7a802b..7b35ec4 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -43,8 +43,8 @@ import System.Directory
43import System.Exit 43import System.Exit
44import ControlMaybe 44import ControlMaybe
45import Data.Char 45import Data.Char
46import Control.Arrow (second) 46import Control.Arrow (first,second)
47import Data.Traversable hiding (mapM) 47import Data.Traversable hiding (mapM,forM)
48import System.Console.CmdArgs 48import System.Console.CmdArgs
49-- import System.Posix.Time 49-- import System.Posix.Time
50import Data.Time.Clock.POSIX 50import Data.Time.Clock.POSIX
@@ -953,7 +953,6 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
953 mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust] 953 mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
954 mergeSig n sig sigs = 954 mergeSig n sig sigs =
955 let (xs,ys) = break (isSameSig sig) sigs 955 let (xs,ys) = break (isSameSig sig) sigs
956 first f (x,y) = (f x,y)
957 in if null ys 956 in if null ys
958 then sigs++[first (asMapped n) sig] 957 then sigs++[first (asMapped n) sig]
959 else let y:ys'=ys 958 else let y:ys'=ys
@@ -1080,6 +1079,36 @@ writeOutKeyrings lkmap db = do
1080 -- warn $ "writing "++f 1079 -- warn $ "writing "++f
1081 L.writeFile f (encode m) 1080 L.writeFile f (encode m)
1082 1081
1082cross_merge keyrings f = do
1083 let relock = do
1084 (fsns,failed_locks) <- lockFiles keyrings
1085 forM_ failed_locks $ \f -> warn $ "Failed to lock: " ++ f
1086 return (fsns,failed_locks)
1087 sec_n:_ = keyrings
1088 (fsns,failed_locks) <- relock
1089 -- let (lks,fs) = unzip fsns
1090 -- forM_ fs $ \f -> warn $ "locked: " ++ f
1091 let readp n = fmap (n,) (readPacketsFromFile n)
1092 let pass n (fsns,failed_locks) = do
1093 ms <- mapM readp (map snd fsns++failed_locks)
1094 let db = foldl' (uncurry . merge) Map.empty ms
1095 fstkey = listToMaybe $ mapMaybe isSecringKey ms
1096 where isSecringKey (fn,Message ps)
1097 | fn==sec_n = listToMaybe ps
1098 isSecringKey _ = Nothing
1099 unlockFiles fsns
1100 db' <- f (sec_n,fstkey) db
1101 lk <- relock
1102 maybe (if n==0 then pass 1 lk else return (lk,db))
1103 (return . (lk,))
1104 db'
1105 ((fsns,failed_locks),db) <- pass 0 (fsns,failed_locks)
1106 let lkmap = Map.fromList (map swap fsns)
1107 writeOutKeyrings lkmap db
1108 unlockFiles fsns
1109 return ()
1110
1111
1083data Arguments = 1112data Arguments =
1084 Cross_Merge { homedir :: Maybe FilePath 1113 Cross_Merge { homedir :: Maybe FilePath
1085 , passphrase_fd :: Maybe Int 1114 , passphrase_fd :: Maybe Int
@@ -1087,10 +1116,33 @@ data Arguments =
1087 } 1116 }
1088 deriving (Show, Data, Typeable) 1117 deriving (Show, Data, Typeable)
1089 1118
1119toLast f [] = []
1120toLast f [x] = [f x]
1121toLast f (x:xs) = x : toLast f xs
1090 1122
1123partitionStaticArguments specs args = psa args
1124 where
1125 smap = Map.fromList specs
1126 psa [] = ([],[])
1127 psa (a:as) =
1128 case Map.lookup a smap of
1129 Nothing -> second (a:) $ psa as
1130 Just n -> first ((a:take n as):) $ psa (drop n as)
1131
1132show_wk secring_file grip db = do
1133 let sec_db = Map.filter gripmatch db
1134 gripmatch (KeyData p _ _ _) =
1135 Map.member secring_file (locations p)
1136 Message sec = flattenKeys False sec_db
1137 putStrLn $ listKeysFiltered (maybeToList grip) sec
1138
1139show_all db = do
1140 let Message packets = flattenKeys True db
1141 putStrLn $ listKeys packets
1091 1142
1092main = do 1143main = do
1093 dotlock_init 1144 dotlock_init
1145 {-
1094 args <- cmdArgs $ modes 1146 args <- cmdArgs $ modes
1095 [ Cross_Merge HOMEOPTION 1147 [ Cross_Merge HOMEOPTION
1096 (def &= opt ("passphrase"::String) 1148 (def &= opt ("passphrase"::String)
@@ -1103,6 +1155,72 @@ main = do
1103 &= program "kiki" 1155 &= program "kiki"
1104 &= summary "kiki - a pgp key editing utility" 1156 &= summary "kiki - a pgp key editing utility"
1105 doCmd args 1157 doCmd args
1158 -}
1159 args_raw <- getArgs
1160 let (args,trail1) = break (=="--") args_raw
1161 trail = drop 1 trail1
1162 (sargs,margs) =
1163 (sargs, foldl' (\m (k:xs)->Map.alter (appendArgs xs) k m)
1164 Map.empty
1165 gargs)
1166 where (sargs,vargs) = partitionStaticArguments
1167 [ ("--homedir",1)
1168 , ("--passphrase-fd",1)
1169 , ("--import",0)
1170 , ("--autosign",0)
1171 , ("--show-wk",0)
1172 , ("--show-all",0)
1173 ]
1174 args
1175 args' = if map (take 1) (take 1 vargs) == ["-"]
1176 then vargs
1177 else "--keyrings":vargs
1178 gargs = (sargs ++)
1179 . toLast (++trail)
1180 . groupBy (\_ s-> take 1 s /= "-")
1181 $ args'
1182 appendArgs xs = Just . maybe xs (++xs)
1183 -- putStrLn $ "margs = " ++ show (Map.assocs margs)
1184 let keypairs =
1185 flip map (maybe [] id $ Map.lookup "--keypairs" margs) $ \specfile -> do
1186 let (spec,efilecmd) = break (=='=') specfile
1187 guard $ take 1 efilecmd=="="
1188 let filecmd = drop 1 efilecmd
1189 let (file,bcmdb0) = break (=='{') filecmd
1190 bcmdb = if null bcmdb0 then "{}" else bcmdb0
1191 guard $ take 1 bcmdb=="{"
1192 let bdmcb = (dropWhile isSpace . reverse) bcmdb
1193 guard $ take 1 bdmcb == "}"
1194 let cmd = (drop 1 . reverse . drop 1) bdmcb
1195 Just (spec,file,cmd)
1196 publics =
1197 flip map (maybe [] id $ Map.lookup "--public" margs) $ \specfile -> do
1198 let (spec,efile) = break (=='=') specfile
1199 guard $ take 1 efile=="="
1200 let file= drop 1 efile
1201 Just (spec,file)
1202 keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs
1203 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
1204
1205 (homedir,secring,pubring,grip0) <- getHomeDir ( concat <$> Map.lookup "--homedir" margs)
1206
1207 let keyrings = secring:pubring:keyrings_
1208
1209 {-
1210 putStrLn $ "keypairs = "++show keypairs
1211 putStrLn $ "publics = "++show publics
1212 putStrLn $ "keyrings = "++show keyrings
1213 -}
1214
1215 cross_merge keyrings $ \(secfile,fstkey) db -> do
1216 let grip = grip0 `mplus` (fingerprint <$> fstkey)
1217 let shspec = Map.fromList [("--show-wk", show_wk secfile grip)
1218 ,("--show-all",show_all )]
1219 shargs = mapMaybe (\x -> listToMaybe x >>= \x ->Map.lookup x shspec) sargs
1220 forM_ shargs $ \cmd -> cmd db
1221 return . Just $ db
1222
1223 return()
1106 where 1224 where
1107 envhomedir opt = do 1225 envhomedir opt = do
1108 gnupghome <- lookupEnv homevar >>= 1226 gnupghome <- lookupEnv homevar >>=
@@ -1117,8 +1235,8 @@ main = do
1117 appdir = ".gnupg" 1235 appdir = ".gnupg"
1118 optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] 1236 optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
1119 1237
1120 getHomeDir cmd = do 1238 getHomeDir protohome = do
1121 homedir <- envhomedir (homedir cmd) 1239 homedir <- envhomedir protohome
1122 flip (maybe (error "Could not determine home directory.")) 1240 flip (maybe (error "Could not determine home directory."))
1123 homedir $ \homedir -> do 1241 homedir $ \homedir -> do
1124 -- putStrLn $ "homedir = " ++show homedir 1242 -- putStrLn $ "homedir = " ++show homedir
@@ -1128,6 +1246,7 @@ main = do
1128 workingkey <- getWorkingKey homedir 1246 workingkey <- getWorkingKey homedir
1129 return (homedir,secring,pubring,workingkey) 1247 return (homedir,secring,pubring,workingkey)
1130 1248
1249 -- TODO: rename this to getGrip
1131 getWorkingKey homedir = do 1250 getWorkingKey homedir = do
1132 let o = Nothing 1251 let o = Nothing
1133 h = Just homedir 1252 h = Just homedir
@@ -1145,7 +1264,7 @@ main = do
1145 return $ lookup "default-key" config >>= listToMaybe 1264 return $ lookup "default-key" config >>= listToMaybe
1146 1265
1147 getPGPEnviron cmd = do 1266 getPGPEnviron cmd = do
1148 (homedir,secring,pubring,grip) <- getHomeDir cmd 1267 (homedir,secring,pubring,grip) <- getHomeDir (homedir cmd)
1149 (Message sec) <- readPacketsFromFile secring 1268 (Message sec) <- readPacketsFromFile secring
1150 let (keys,_) = partition (\k -> case k of 1269 let (keys,_) = partition (\k -> case k of
1151 { SecretKeyPacket {} -> True 1270 { SecretKeyPacket {} -> True
@@ -1337,19 +1456,9 @@ main = do
1337 -} 1456 -}
1338 1457
1339 doCmd cmd@(Cross_Merge {}) = do 1458 doCmd cmd@(Cross_Merge {}) = do
1340 (homedir,secring,pubring,grip0) <- getHomeDir cmd 1459 (homedir,secring,pubring,grip0) <- getHomeDir (homedir cmd)
1341 -- grip0 may be empty, in which case we should use the first key 1460 -- grip0 may be empty, in which case we should use the first key
1342 (fsns,failed_locks) <- lockFiles (secring:pubring:files cmd) 1461 cross_merge (secring:pubring:files cmd) $ \_ db -> return $ Just db
1343 forM_ failed_locks $ \f -> warn $ "Failed to lock: " ++ f
1344 let (lks,fs) = unzip fsns
1345 -- forM_ fs $ \f -> warn $ "locked: " ++ f
1346 let readp n = fmap (n,) (readPacketsFromFile n)
1347 ms <- mapM readp (fs++failed_locks)
1348 let db = foldl' (uncurry . merge) Map.empty ms
1349 let lkmap = Map.fromList (map swap fsns)
1350 writeOutKeyrings lkmap db
1351 unlockFiles fsns
1352 return ()
1353 1462
1354 {- 1463 {-
1355 doCmd cmd@(CatPub {}) = do 1464 doCmd cmd@(CatPub {}) = do