diff options
Diffstat (limited to 'kiki.hs')
-rw-r--r-- | kiki.hs | 192 |
1 files changed, 10 insertions, 182 deletions
@@ -8,75 +8,51 @@ | |||
8 | {-# LANGUAGE CPP #-} | 8 | {-# LANGUAGE CPP #-} |
9 | module Main where | 9 | module Main where |
10 | 10 | ||
11 | import Debug.Trace | ||
12 | import GHC.Exts (Down(..)) | ||
13 | import GHC.IO.Exception ( ioException, IOErrorType(..) ) | ||
14 | import Data.IORef | 11 | import Data.IORef |
15 | import Data.Tuple | ||
16 | import Data.Binary | 12 | import Data.Binary |
17 | import Data.OpenPGP as OpenPGP | 13 | import Data.OpenPGP as OpenPGP |
18 | import qualified Data.ByteString.Lazy as L | 14 | import qualified Data.ByteString.Lazy as L |
19 | import qualified Data.ByteString.Lazy.Char8 as Char8 | 15 | import qualified Data.ByteString.Lazy.Char8 as Char8 |
20 | import qualified Data.ByteString as S | 16 | import qualified Data.ByteString as S |
21 | import qualified Data.ByteString.Char8 as S8 | ||
22 | import Control.Monad | 17 | import Control.Monad |
23 | import qualified Text.Show.Pretty as PP | 18 | -- import qualified Text.Show.Pretty as PP |
24 | import Text.PrettyPrint as PP hiding ((<>)) | 19 | -- import Text.PrettyPrint as PP hiding ((<>)) |
25 | import Data.List | 20 | import Data.List |
26 | import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign) | 21 | import Data.OpenPGP.Util (verify,fingerprint) |
27 | import Data.Ord | 22 | import Data.Ord |
28 | import Data.Maybe | 23 | import Data.Maybe |
29 | import Data.Bits | 24 | import Data.Bits |
30 | import qualified Data.Text as T | 25 | import qualified Data.Text as T |
31 | import Data.Text.Encoding | 26 | import Data.Text.Encoding |
32 | import qualified Codec.Binary.Base32 as Base32 | ||
33 | import qualified Codec.Binary.Base64 as Base64 | 27 | import qualified Codec.Binary.Base64 as Base64 |
34 | import qualified Crypto.Hash.SHA1 as SHA1 | ||
35 | import qualified Crypto.Hash.SHA256 as SHA256 | 28 | import qualified Crypto.Hash.SHA256 as SHA256 |
36 | import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 | 29 | import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 |
37 | import qualified Crypto.Types.PubKey.ECC as ECC | ||
38 | -- import qualified Crypto.Types.PubKey.ECDSA as ECDSA | 30 | -- import qualified Crypto.Types.PubKey.ECDSA as ECDSA |
39 | -- import qualified Crypto.PubKey.ECC.ECDSA as ECDSA | 31 | -- import qualified Crypto.PubKey.ECC.ECDSA as ECDSA |
40 | 32 | ||
41 | import Data.Char (toLower) | ||
42 | import qualified Crypto.PubKey.RSA as RSA | ||
43 | -- import Crypto.Random (newGenIO,SystemRandom) | 33 | -- import Crypto.Random (newGenIO,SystemRandom) |
44 | import Data.ASN1.Types | 34 | import Data.ASN1.Types |
45 | import Data.ASN1.Encoding | 35 | import Data.ASN1.Encoding |
46 | import Data.ASN1.BinaryEncoding | 36 | import Data.ASN1.BinaryEncoding |
47 | import Data.ASN1.BitArray | ||
48 | import qualified Data.Foldable as Foldable | ||
49 | import qualified Data.Sequence as Sequence | ||
50 | import Control.Applicative | 37 | import Control.Applicative |
51 | import System.Environment | 38 | import System.Environment |
52 | import System.Directory | ||
53 | import System.FilePath | ||
54 | import System.Exit | 39 | import System.Exit |
55 | import System.Process | 40 | import System.IO (hPutStrLn,stderr) |
56 | import System.Posix.IO (fdToHandle,fdRead) | 41 | #if ! MIN_VERSION_base(4,6,0) |
57 | import System.Posix.Files | 42 | import ControlMaybe ( handleIO_ ) |
58 | import System.Posix.Signals | 43 | #endif |
59 | import System.Posix.Types (EpochTime) | ||
60 | import System.Process.Internals (runGenProcess_,defaultSignal) | ||
61 | import System.IO (hPutStrLn,stderr,withFile,IOMode(..)) | ||
62 | import System.IO.Error | ||
63 | import ControlMaybe | ||
64 | import Data.Char | 44 | import Data.Char |
65 | import Control.Arrow (first,second) | 45 | import Control.Arrow (first,second) |
66 | import Data.Traversable hiding (mapM,forM,sequence) | 46 | -- import Data.Traversable hiding (mapM,forM,sequence) |
67 | import qualified Data.Traversable as Traversable (mapM,forM,sequence) | 47 | -- import qualified Data.Traversable as Traversable (mapM,forM,sequence) |
68 | -- import System.Console.CmdArgs | 48 | -- import System.Console.CmdArgs |
69 | -- import System.Posix.Time | 49 | -- import System.Posix.Time |
70 | import Data.Time.Clock.POSIX | ||
71 | import Data.Monoid ((<>)) | ||
72 | -- import Data.X509 | 50 | -- import Data.X509 |
73 | import qualified Data.Map as Map | 51 | import qualified Data.Map as Map |
74 | import DotLock | 52 | import DotLock |
75 | -- import Codec.Crypto.ECC.Base -- hecc package | 53 | -- import Codec.Crypto.ECC.Base -- hecc package |
76 | import Text.Printf | 54 | import Text.Printf |
77 | import qualified CryptoCoins as CryptoCoins | 55 | import qualified CryptoCoins as CryptoCoins |
78 | import qualified Hosts | ||
79 | import Network.Socket -- (SockAddr) | ||
80 | import LengthPrefixedBE | 56 | import LengthPrefixedBE |
81 | import Data.Binary.Put (putWord32be,runPut,putByteString) | 57 | import Data.Binary.Put (putWord32be,runPut,putByteString) |
82 | import Data.Binary.Get (runGet) | 58 | import Data.Binary.Get (runGet) |
@@ -360,8 +336,7 @@ modifyUID other = other | |||
360 | 336 | ||
361 | todo = error "unimplemented" | 337 | todo = error "unimplemented" |
362 | 338 | ||
363 | #if MIN_VERSION_base(4,6,0) | 339 | #if ! MIN_VERSION_base(4,6,0) |
364 | #else | ||
365 | lookupEnv var = | 340 | lookupEnv var = |
366 | handleIO_ (return Nothing) $ fmap Just (getEnv var) | 341 | handleIO_ (return Nothing) $ fmap Just (getEnv var) |
367 | #endif | 342 | #endif |
@@ -1047,17 +1022,6 @@ main = do | |||
1047 | guard $ take 1 bdmcb == "}" | 1022 | guard $ take 1 bdmcb == "}" |
1048 | let cmd = (drop 1 . reverse . drop 1) bdmcb | 1023 | let cmd = (drop 1 . reverse . drop 1) bdmcb |
1049 | Just (spec,file,cmd) | 1024 | Just (spec,file,cmd) |
1050 | btcpairs0 = | ||
1051 | flip map (maybe [] id $ Map.lookup "--bitcoin-keypairs" margs) $ \specfile -> do | ||
1052 | let (spec,efilecmd) = break (=='=') specfile | ||
1053 | (spec,protocnt) <- do | ||
1054 | return $ if take 1 efilecmd=="=" then (spec,drop 1 efilecmd) | ||
1055 | else ("",spec) | ||
1056 | let (proto,content) = break (==':') protocnt | ||
1057 | spec <- return $ if null spec then "bitcoin" else spec | ||
1058 | return $ | ||
1059 | if take 1 content =="=" then (spec,proto,drop 1 content) | ||
1060 | else (spec,"base58",proto) | ||
1061 | {- | 1025 | {- |
1062 | publics = | 1026 | publics = |
1063 | flip map (maybe [] id $ Map.lookup "--public" margs) $ \specfile -> do | 1027 | flip map (maybe [] id $ Map.lookup "--public" margs) $ \specfile -> do |
@@ -1069,28 +1033,6 @@ main = do | |||
1069 | keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs | 1033 | keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs |
1070 | wallets = maybe [] id $ Map.lookup "--wallets" margs | 1034 | wallets = maybe [] id $ Map.lookup "--wallets" margs |
1071 | passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs | 1035 | passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs |
1072 | decrypt wk = do | ||
1073 | -- warn $ "decryptKey "++fingerprint wk | ||
1074 | unkeys <- readIORef unkeysRef | ||
1075 | let kk = keykey wk | ||
1076 | flip (flip maybe $ return . Just) (Map.lookup kk unkeys) $ do | ||
1077 | let ret wkun = do writeIORef unkeysRef (Map.insert kk wkun unkeys) | ||
1078 | return (Just wkun) | ||
1079 | if symmetric_algorithm wk == Unencrypted then ret wk else do | ||
1080 | pw <- do | ||
1081 | pw <- readIORef pwRef | ||
1082 | flip (flip maybe return) pw $ do | ||
1083 | case passphrase_fd of | ||
1084 | Just fd -> do pwh <- fdToHandle (read fd) | ||
1085 | pw <- fmap trimCR $ S.hGetContents pwh | ||
1086 | writeIORef pwRef (Just pw) | ||
1087 | return pw | ||
1088 | Nothing -> return "" | ||
1089 | let wkun = do | ||
1090 | k <- decryptSecretKey pw wk | ||
1091 | guard (symmetric_algorithm k == Unencrypted) | ||
1092 | return k | ||
1093 | maybe (return Nothing) ret wkun | ||
1094 | 1036 | ||
1095 | when (not . null $ filter isNothing keypairs0) $ do | 1037 | when (not . null $ filter isNothing keypairs0) $ do |
1096 | warn "syntax error" | 1038 | warn "syntax error" |
@@ -1101,7 +1043,6 @@ main = do | |||
1101 | $ Map.lookup "--show-whose-key" margs | 1043 | $ Map.lookup "--show-whose-key" margs |
1102 | 1044 | ||
1103 | let keypairs = catMaybes keypairs0 | 1045 | let keypairs = catMaybes keypairs0 |
1104 | btcpairs = catMaybes btcpairs0 | ||
1105 | 1046 | ||
1106 | {- | 1047 | {- |
1107 | putStrLn $ "wallets = "++show wallets | 1048 | putStrLn $ "wallets = "++show wallets |
@@ -1110,22 +1051,6 @@ main = do | |||
1110 | putStrLn $ "publics = "++show publics | 1051 | putStrLn $ "publics = "++show publics |
1111 | -} | 1052 | -} |
1112 | 1053 | ||
1113 | let auto_sign_feature rt = do | ||
1114 | use_db <- | ||
1115 | flip (maybe $ return (rtKeyDB rt)) | ||
1116 | (lookup "--autosign" $ map (\(x:xs)->(x,xs)) sargs) | ||
1117 | $ \_ -> do | ||
1118 | let keys = map keyPacket $ Map.elems (rtKeyDB rt) | ||
1119 | wk = workingKey (rtGrip rt) (rtKeyDB rt) | ||
1120 | -- g <- newGenIO | ||
1121 | -- stamp <- now | ||
1122 | wkun <- flip (maybe $ return Nothing) wk $ \wk -> do | ||
1123 | wkun <- decrypt wk | ||
1124 | maybe (error $ "Bad passphrase?") (return . Just) wkun | ||
1125 | -- return . snd $ Map.mapAccum (signTorIds stamp wkun keys) g use_db | ||
1126 | Traversable.mapM (signTorIds wkun keys) (rtKeyDB rt) | ||
1127 | return use_db | ||
1128 | |||
1129 | let homespec = join . take 1 <$> Map.lookup "--homedir" margs | 1054 | let homespec = join . take 1 <$> Map.lookup "--homedir" margs |
1130 | passfd = fmap (FileDesc . read) passphrase_fd | 1055 | passfd = fmap (FileDesc . read) passphrase_fd |
1131 | pems = flip map keypairs | 1056 | pems = flip map keypairs |
@@ -1206,103 +1131,6 @@ main = do | |||
1206 | let torhash = maybe "" id $ derToBase32 <$> derRSA sub | 1131 | let torhash = maybe "" id $ derToBase32 <$> derRSA sub |
1207 | return (top,(torhash,sub)) | 1132 | return (top,(torhash,sub)) |
1208 | 1133 | ||
1209 | |||
1210 | signTorIds selfkey keys kd@(KeyData k ksigs umap submap) = do | ||
1211 | umap' <- Traversable.mapM signIfTor (Map.mapWithKey (,) umap) | ||
1212 | return (KeyData k ksigs umap' submap) :: IO KeyData | ||
1213 | where | ||
1214 | mkey = packet k | ||
1215 | signIfTor (str,ps) = | ||
1216 | if isTorID str | ||
1217 | then do | ||
1218 | let uidxs0 = map packet $ flattenUid "" True (str,ps) | ||
1219 | -- addition<- signSelfAuthTorKeys' selfkey g keys grip timestamp mkey uidxs0 | ||
1220 | additional <- signSelfAuthTorKeys' selfkey keys grip mkey uidxs0 | ||
1221 | let ps' = ( map ( (,tmap) . toMappedPacket om) additional | ||
1222 | ++ fst ps | ||
1223 | , Map.union om (snd ps) ) | ||
1224 | toMappedPacket om p = (mappedPacket "" p) {locations=om} | ||
1225 | om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket str | ||
1226 | tmap = Map.empty | ||
1227 | return ps' | ||
1228 | else return ps | ||
1229 | |||
1230 | torbindings = getTorKeys (map packet $ flattenTop "" True kd) | ||
1231 | isTorID str = and [ uid_topdomain parsed == "onion" | ||
1232 | , uid_realname parsed `elem` ["","Anonymous"] | ||
1233 | , uid_user parsed == "root" | ||
1234 | , fmap (match . fst) (lookup mkey torbindings) | ||
1235 | == Just True ] | ||
1236 | where parsed = parseUID str | ||
1237 | match = ( (==subdom) . take (fromIntegral len)) | ||
1238 | subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] | ||
1239 | subdom = Char8.unpack subdom0 | ||
1240 | len = T.length (uid_subdomain parsed) | ||
1241 | |||
1242 | |||
1243 | signSelfAuthTorKeys' selfkey keys grip mainpubkey (uid:xs') = do | ||
1244 | new_sig <- let wkun = fromJust selfkey | ||
1245 | tor_ov = makeInducerSig mainpubkey wkun uid flgs | ||
1246 | in pgpSign (Message [wkun]) | ||
1247 | tor_ov | ||
1248 | SHA1 | ||
1249 | (fingerprint wkun) | ||
1250 | return (additional new_sig) -- (uid:sigs,additional,xs'',g') | ||
1251 | where | ||
1252 | (sigs, _) = span isSignaturePacket xs' | ||
1253 | overs sig = signatures $ Message (keys++[mainpubkey,uid,sig]) | ||
1254 | vs :: [ ( Packet -- signature | ||
1255 | , Maybe SignatureOver -- Nothing means non-verified | ||
1256 | , Packet ) -- key who signed | ||
1257 | ] | ||
1258 | vs = do | ||
1259 | sig <- sigs | ||
1260 | o <- overs sig | ||
1261 | k <- keys | ||
1262 | let ov = verify (Message [k]) $ o | ||
1263 | take 1 $ signatures_over ov | ||
1264 | return (sig,Just ov,k) | ||
1265 | selfsigs = filter (\(sig,v,whosign) -> isJust (v >> selfkey >>= guard | ||
1266 | . (== keykey whosign) | ||
1267 | . keykey)) | ||
1268 | vs | ||
1269 | additional new_sig = do | ||
1270 | new_sig <- maybeToList new_sig | ||
1271 | guard $ {- trace (unlines $ [ "selfsigs = "++show (map ((\(_,_,k)->fingerprint k)) selfsigs) | ||
1272 | , " for mainkey = "++fingerprint mainpubkey] ) | ||
1273 | -} | ||
1274 | (null $ selfsigs) | ||
1275 | signatures_over new_sig | ||
1276 | {- | ||
1277 | modsig sig = sig { signature = map id (signature sig) } | ||
1278 | where plus1 (MPI x) = MPI (x+1) | ||
1279 | params newtop = public ++ map fst (key newtop) ++ "}" | ||
1280 | where | ||
1281 | public = case newtop of | ||
1282 | PublicKeyPacket {} -> "public{" | ||
1283 | SecretKeyPacket {} -> if L.null (encrypted_data newtop ) | ||
1284 | then "secret{" | ||
1285 | else "encrypted{" | ||
1286 | _ -> "??????{" | ||
1287 | traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey) | ||
1288 | ,"new_sig topkey:"++ (show . fingerprint $ newtop) | ||
1289 | ,"new_sig topkey params: "++ params newtop | ||
1290 | ,"new_sig user_id:"++ (show newuid) | ||
1291 | ,"new_sig |over| = " ++ (show . length $ new_sig) | ||
1292 | ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig) | ||
1293 | ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig) | ||
1294 | ,"new_sig type: " ++ (show . map signature_type $ new_sig) | ||
1295 | ,"new_sig signature:" ++ (show . concatMap signature $ new_sig) | ||
1296 | ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig) | ||
1297 | ,"issuer = " ++ show (map signature_issuer new_sig) | ||
1298 | ]) | ||
1299 | -} | ||
1300 | flgs = if keykey mainpubkey == keykey (fromJust selfkey) | ||
1301 | then keyFlags0 mainpubkey (map (\(x,_,_)->x) selfsigs) | ||
1302 | else [] | ||
1303 | |||
1304 | |||
1305 | |||
1306 | isSameKey a b = sort (key apub) == sort (key bpub) | 1134 | isSameKey a b = sort (key apub) == sort (key bpub) |
1307 | where | 1135 | where |
1308 | apub = secretToPublic a | 1136 | apub = secretToPublic a |