summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-04-21 19:49:41 -0400
committerjoe <joe@jerkface.net>2014-04-21 19:49:41 -0400
commite75916e1370bc772ba4cf643f0ac0ecae0300d1c (patch)
treecc7b8b4fd4eb65346a2cd80605deb6766bef1788
parent755aaab873a88970b0a268c1588277fcfd8002f3 (diff)
removed unused imports and binds from kiki.hs
-rw-r--r--kiki.hs192
1 files changed, 10 insertions, 182 deletions
diff --git a/kiki.hs b/kiki.hs
index d1d8bb3..532c2ab 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -8,75 +8,51 @@
8{-# LANGUAGE CPP #-} 8{-# LANGUAGE CPP #-}
9module Main where 9module Main where
10 10
11import Debug.Trace
12import GHC.Exts (Down(..))
13import GHC.IO.Exception ( ioException, IOErrorType(..) )
14import Data.IORef 11import Data.IORef
15import Data.Tuple
16import Data.Binary 12import Data.Binary
17import Data.OpenPGP as OpenPGP 13import Data.OpenPGP as OpenPGP
18import qualified Data.ByteString.Lazy as L 14import qualified Data.ByteString.Lazy as L
19import qualified Data.ByteString.Lazy.Char8 as Char8 15import qualified Data.ByteString.Lazy.Char8 as Char8
20import qualified Data.ByteString as S 16import qualified Data.ByteString as S
21import qualified Data.ByteString.Char8 as S8
22import Control.Monad 17import Control.Monad
23import qualified Text.Show.Pretty as PP 18-- import qualified Text.Show.Pretty as PP
24import Text.PrettyPrint as PP hiding ((<>)) 19-- import Text.PrettyPrint as PP hiding ((<>))
25import Data.List 20import Data.List
26import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign) 21import Data.OpenPGP.Util (verify,fingerprint)
27import Data.Ord 22import Data.Ord
28import Data.Maybe 23import Data.Maybe
29import Data.Bits 24import Data.Bits
30import qualified Data.Text as T 25import qualified Data.Text as T
31import Data.Text.Encoding 26import Data.Text.Encoding
32import qualified Codec.Binary.Base32 as Base32
33import qualified Codec.Binary.Base64 as Base64 27import qualified Codec.Binary.Base64 as Base64
34import qualified Crypto.Hash.SHA1 as SHA1
35import qualified Crypto.Hash.SHA256 as SHA256 28import qualified Crypto.Hash.SHA256 as SHA256
36import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 29import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
37import 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
41import Data.Char (toLower)
42import qualified Crypto.PubKey.RSA as RSA
43-- import Crypto.Random (newGenIO,SystemRandom) 33-- import Crypto.Random (newGenIO,SystemRandom)
44import Data.ASN1.Types 34import Data.ASN1.Types
45import Data.ASN1.Encoding 35import Data.ASN1.Encoding
46import Data.ASN1.BinaryEncoding 36import Data.ASN1.BinaryEncoding
47import Data.ASN1.BitArray
48import qualified Data.Foldable as Foldable
49import qualified Data.Sequence as Sequence
50import Control.Applicative 37import Control.Applicative
51import System.Environment 38import System.Environment
52import System.Directory
53import System.FilePath
54import System.Exit 39import System.Exit
55import System.Process 40import System.IO (hPutStrLn,stderr)
56import System.Posix.IO (fdToHandle,fdRead) 41#if ! MIN_VERSION_base(4,6,0)
57import System.Posix.Files 42import ControlMaybe ( handleIO_ )
58import System.Posix.Signals 43#endif
59import System.Posix.Types (EpochTime)
60import System.Process.Internals (runGenProcess_,defaultSignal)
61import System.IO (hPutStrLn,stderr,withFile,IOMode(..))
62import System.IO.Error
63import ControlMaybe
64import Data.Char 44import Data.Char
65import Control.Arrow (first,second) 45import Control.Arrow (first,second)
66import Data.Traversable hiding (mapM,forM,sequence) 46-- import Data.Traversable hiding (mapM,forM,sequence)
67import 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
70import Data.Time.Clock.POSIX
71import Data.Monoid ((<>))
72-- import Data.X509 50-- import Data.X509
73import qualified Data.Map as Map 51import qualified Data.Map as Map
74import DotLock 52import DotLock
75-- import Codec.Crypto.ECC.Base -- hecc package 53-- import Codec.Crypto.ECC.Base -- hecc package
76import Text.Printf 54import Text.Printf
77import qualified CryptoCoins as CryptoCoins 55import qualified CryptoCoins as CryptoCoins
78import qualified Hosts
79import Network.Socket -- (SockAddr)
80import LengthPrefixedBE 56import LengthPrefixedBE
81import Data.Binary.Put (putWord32be,runPut,putByteString) 57import Data.Binary.Put (putWord32be,runPut,putByteString)
82import Data.Binary.Get (runGet) 58import Data.Binary.Get (runGet)
@@ -360,8 +336,7 @@ modifyUID other = other
360 336
361todo = error "unimplemented" 337todo = error "unimplemented"
362 338
363#if MIN_VERSION_base(4,6,0) 339#if ! MIN_VERSION_base(4,6,0)
364#else
365lookupEnv var = 340lookupEnv 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
1306isSameKey a b = sort (key apub) == sort (key bpub) 1134isSameKey a b = sort (key apub) == sort (key bpub)
1307 where 1135 where
1308 apub = secretToPublic a 1136 apub = secretToPublic a