summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs140
1 files changed, 125 insertions, 15 deletions
diff --git a/kiki.hs b/kiki.hs
index d590cd4..2194059 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -8,6 +8,7 @@
8module Main where 8module Main where
9 9
10import Debug.Trace 10import Debug.Trace
11import GHC.Exts (Down(..))
11import Data.Binary 12import Data.Binary
12import Data.OpenPGP 13import Data.OpenPGP
13import qualified Data.ByteString.Lazy as L 14import qualified Data.ByteString.Lazy as L
@@ -222,6 +223,10 @@ verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersig
222 let sigover = signatures_over sub 223 let sigover = signatures_over sub
223 unhashed = sigover >>= unhashed_subpackets 224 unhashed = sigover >>= unhashed_subpackets
224 subsigs = mapMaybe backsig unhashed 225 subsigs = mapMaybe backsig unhashed
226 -- This should consist only of 0x19 values
227 -- subtypes = map signature_type subsigs
228 -- trace ("subtypes = "++show subtypes) (return ())
229 -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
225 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) 230 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
226 let v = verify (Message [subkey sub]) sig 231 let v = verify (Message [subkey sub]) sig
227 guard (not . null $ signatures_over v) 232 guard (not . null $ signatures_over v)
@@ -905,7 +910,11 @@ main = do
905 then sigs 910 then sigs
906 {- 911 {-
907 else trace ( "key params: "++params (fromJust selfkey)++"\n" 912 else trace ( "key params: "++params (fromJust selfkey)++"\n"
908 ++traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ map modsig (signatures_over new_sig) 913 ++traceSig (topkey new_sig)
914 (user_id new_sig)
915 (signatures_over new_sig))
916 sigs
917 ++ {- map modsig -} (signatures_over new_sig)
909 -} 918 -}
910 else sigs ++ signatures_over new_sig 919 else sigs ++ signatures_over new_sig
911 modsig sig = sig { signature = map id (signature sig) } 920 modsig sig = sig { signature = map id (signature sig) }
@@ -1072,9 +1081,119 @@ main = do
1072 let pkf = fingerprint (head parsedkey) 1081 let pkf = fingerprint (head parsedkey)
1073 (prepk,pks) = seek_key pkf subkeys' 1082 (prepk,pks) = seek_key pkf subkeys'
1074 1083
1075 if not (null pks) then putStrLn "Key already present." 1084 if not (null pks)
1076 else do 1085 then existingKey (prepk,pks) remainder wkun wk parsedkey (key_usage cmd) pre uids subkeys (output cmd) grip
1086 else newKey wkun wk parsedkey (key_usage cmd) pre uids subkeys (output cmd) grip
1077 1087
1088 doCmd cmd@(PemFP {}) = do
1089 let parseKeySpec hint spec = case break (==':') spec of
1090 (fmt,_:file) -> (fmt,file)
1091 (file,"") -> (guessKeyFormat hint ("ssh-host"), file)
1092 (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd
1093 Message seckey <- readKeyFromFile False secfmt secfile
1094 -- Message pubkey <- readKeyFromFile True pubfmt pubfile
1095 putStrLn $ fingerprint (head seckey)
1096
1097
1098isSameKey a b = sort (key apub) == sort (key bpub)
1099 where
1100 apub = secretToPublic a
1101 bpub = secretToPublic b
1102
1103existingKey (prepk,pks) remainder wkun wk parsedkey tag pre uids subkeys output_file grip = do
1104 -- putStrLn "Key already present."
1105 let pk:trail = pks
1106 (trailsigs,trail') = span isSignaturePacket trail
1107 (mysigs,notmines) = partition (endsWith grip . maybe "%bad%" id . signature_issuer)
1108 trailsigs
1109 endsWith big small = drop (length big - length small) big == small
1110 vs = map (\sig ->
1111 (sig, map (verify (Message [wk]))
1112 (signatures $ Message [wk,pk,sig])))
1113 mysigs
1114 (verified,unverified) = partition (not . null . snd) vs
1115 sorted = sortBy (comparing (Down . signature_time . head . snd)) verified
1116 -- Note: format allows for signatures of type 0x28 Subkey revocation signature.
1117 case sorted of
1118 [] -> do
1119 putStrLn "Adding valid signature to existing key..."
1120 newKey wkun wk [pk] tag pre uids (trail++prepk++remainder) output_file grip
1121 (sig,ov):vs -> do
1122 -- TODO: update sig to contain usage@ = tag
1123 let hs = filter (\p->isNotation p && notation_name p=="usage@") (hashed_subpackets sig)
1124 ks = map notation_value hs
1125 isNotation (NotationDataPacket {}) = True
1126 isNotation _ = False
1127 noop = do
1128 -- Nothing to do
1129 let sec' = pre ++ [wk] ++ uids ++ subkeys
1130 putStrLn $ tag ++ " key already present."
1131 L.writeFile output_file (encode (Message sec'))
1132 if tag `elem` ks
1133 then noop
1134 else do
1135 g <- newGenIO
1136 timestamp <- now
1137 let isCreation (SignatureCreationTimePacket {}) = True
1138 isCreation _ = False
1139 isExpiration (SignatureExpirationTimePacket {}) = True
1140 isExpiration _ = False
1141 (cs,ps) = partition isCreation (hashed_subpackets sig)
1142 (es,qs) = partition isExpiration ps
1143 stamp = listToMaybe . sortBy (comparing Down) $
1144 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
1145 exp = listToMaybe $ sort $
1146 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
1147 expires = liftA2 (+) stamp exp
1148 if fmap ( (< timestamp) . fromIntegral) expires == Just True then do
1149 putStrLn $ "Unable to update expired signature"
1150 noop
1151 else do
1152 let new_sig = fst $ sign (Message [wkun])
1153 (SubkeySignature wk
1154 (head parsedkey)
1155 [sig'] )
1156 SHA1
1157 grip
1158 timestamp
1159 (g::SystemRandom)
1160 times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
1161 $ maybeToList $ do
1162 e <- expires
1163 return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
1164 notation = NotationDataPacket
1165 { notation_name = "usage@"
1166 , notation_value = tag
1167 , human_readable = True }
1168 sig' = sig { hashed_subpackets = times ++ [notation] ++ qs }
1169
1170 -- noop let sec' = pre ++ [wk] ++ uids ++ subkeys
1171 sec' = pre
1172 ++ [wk]
1173 ++ uids
1174 ++ prepk
1175 ++ [pk]
1176 ++ signatures_over new_sig
1177 ++ map fst vs
1178 ++ map fst unverified
1179 ++ notmines
1180 ++ trail'
1181 ++ remainder
1182 putStrLn $ "Adding usage@="++tag
1183 L.writeFile output_file (encode (Message sec'))
1184 where
1185 signature_time ov = case if null cs then ds else cs of
1186 [] -> minBound
1187 xs -> last (sort xs)
1188 where
1189 ps = signatures_over ov
1190 ss = filter isSignaturePacket ps
1191 cs = concatMap (concatMap creationTime . hashed_subpackets) ss
1192 ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
1193 creationTime (SignatureCreationTimePacket t) = [t]
1194 creationTime _ = []
1195
1196newKey wkun wk parsedkey tag pre uids subkeys output_file grip = do
1078 g <- newGenIO 1197 g <- newGenIO
1079 timestamp <- now 1198 timestamp <- now
1080 1199
@@ -1113,8 +1232,9 @@ main = do
1113 , NotationDataPacket 1232 , NotationDataPacket
1114 { human_readable = True 1233 { human_readable = True
1115 , notation_name = "usage@" 1234 , notation_name = "usage@"
1116 , notation_value = key_usage cmd 1235 , notation_value = tag
1117 } 1236 }
1237 , SignatureCreationTimePacket (fromIntegral timestamp)
1118 ] 1238 ]
1119 1239
1120 subgrip = fingerprint (head parsedkey) 1240 subgrip = fingerprint (head parsedkey)
@@ -1133,7 +1253,7 @@ main = do
1133 let sec' = pre ++ [wk] ++ uids ++ parsedkey ++ signatures_over new_sig ++ subkeys 1253 let sec' = pre ++ [wk] ++ uids ++ parsedkey ++ signatures_over new_sig ++ subkeys
1134 putStrLn $ listKeys sec' 1254 putStrLn $ listKeys sec'
1135 1255
1136 L.writeFile (output cmd) (encode (Message sec')) 1256 L.writeFile output_file (encode (Message sec'))
1137 1257
1138 {- 1258 {-
1139 let backsigs = do 1259 let backsigs = do
@@ -1150,16 +1270,6 @@ main = do
1150 1270
1151 return () 1271 return ()
1152 1272
1153 doCmd cmd@(PemFP {}) = do
1154 let parseKeySpec hint spec = case break (==':') spec of
1155 (fmt,_:file) -> (fmt,file)
1156 (file,"") -> (guessKeyFormat hint ("ssh-host"), file)
1157 (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd
1158 Message seckey <- readKeyFromFile False secfmt secfile
1159 -- Message pubkey <- readKeyFromFile True pubfmt pubfile
1160 putStrLn $ fingerprint (head seckey)
1161
1162
1163 1273
1164 1274
1165groupBindings pub = 1275groupBindings pub =