more cleanup of module kiki.hs

1 files changed, 69 insertions, 231 deletions

diff --git a/kiki.hs b/kiki.hs
index 9bfbd2d..620d01e 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -6,81 +6,49 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE CPP #-}
-module Main where
+module Main ( main ) where
 
-import Data.IORef
-import Data.Binary
-import Data.OpenPGP as OpenPGP
-import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Lazy.Char8 as Char8
-import qualified Data.ByteString      as S
+import Control.Applicative
 import Control.Monad
--- import qualified Text.Show.Pretty as PP
--- import Text.PrettyPrint as PP hiding ((<>))
+import Data.ASN1.BinaryEncoding
+import Data.ASN1.Encoding
+import Data.ASN1.Types
+import Data.Binary
+import Data.Bits
+import Data.Char
+import Data.IORef
 import Data.List
-import Data.OpenPGP.Util (verify,fingerprint)
-import Data.Ord
 import Data.Maybe
-import Data.Bits
-import qualified Data.Text as T
+import Data.OpenPGP
+import Data.Ord
 import Data.Text.Encoding
-import qualified Codec.Binary.Base64 as Base64
-import qualified Crypto.Hash.SHA256 as SHA256
-import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
--- import qualified Crypto.Types.PubKey.ECDSA as ECDSA
--- import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
-
--- import Crypto.Random (newGenIO,SystemRandom)
-import Data.ASN1.Types
-import Data.ASN1.Encoding
-import Data.ASN1.BinaryEncoding
-import Control.Applicative
 import System.Environment
 import System.Exit
 import System.IO (hPutStrLn,stderr)
-import Data.Char
-import Control.Arrow (first,second)
--- import Data.Traversable hiding (mapM,forM,sequence)
--- import qualified Data.Traversable as Traversable (mapM,forM,sequence)
--- import System.Console.CmdArgs
--- import System.Posix.Time
--- import Data.X509
+import qualified Codec.Binary.Base64 as Base64
+import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
+import qualified Crypto.Hash.SHA256    as SHA256
+import qualified Data.ByteString      as S
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.Map as Map
-import DotLock
--- import Codec.Crypto.ECC.Base -- hecc package
--- import Text.Printf
-import qualified CryptoCoins 
-import LengthPrefixedBE
-import Data.Binary.Put (putWord32be,runPut,putByteString)
+import qualified Data.Text as T
+import Control.Arrow   (first,second)
 import Data.Binary.Get (runGet)
+import Data.Binary.Put (putWord32be,runPut,putByteString)
 
+import DotLock
+import LengthPrefixedBE
 import KeyRing
 import Base58
+import qualified CryptoCoins 
+import Data.OpenPGP.Util (verify,fingerprint)
 
 -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-}
 -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-}
 
--- instance Default S.ByteString where def = S.empty
-
 warn str = hPutStrLn stderr str
 
-
-
-{-
-RSAPrivateKey ::= SEQUENCE {
-  version           Version,
-  modulus           INTEGER,  -- n
-  publicExponent    INTEGER,  -- e
-  privateExponent   INTEGER,  -- d
-  prime1            INTEGER,  -- p
-  prime2            INTEGER,  -- q
-  exponent1         INTEGER,  -- d mod (p1) -- ?? d mod (p-1)
-  exponent2         INTEGER,  -- d mod (q-1)
-  coefficient       INTEGER,  -- (inverse of q) mod p
-  otherPrimeInfos   OtherPrimeInfos OPTIONAL
-}
--}
-
 sshrsa :: Integer -> Integer -> Char8.ByteString
 sshrsa e n = runPut $ do
     putWord32be 7
@@ -98,18 +66,6 @@ decode_sshrsa bs = do
             return $ RSAKey (MPI n) (MPI e)
     return rsakey
         
-
-
-{-
-getPackets :: IO [Packet]
-getPackets = do
-    input <- L.getContents
-    case decodeOrFail input of
-        Right (_,_,Message pkts) -> return pkts
-        Left  (_,_,_)            -> return []
--}
-
-
 isCertificationSig (CertificationSignature {}) = True
 isCertificationSig _                           = True
 
@@ -214,12 +170,6 @@ fpmatch grip key =
 
 listKeys pkts = listKeysFiltered [] pkts
 
-{-
-ecc_curve k = printf "%x" num :: String
- where unmpi (MPI num) = num
-       num =  maybe 0 unmpi $ lookup 'c' (key k)
--}
-
 listKeysFiltered grips pkts = do
     let (certs,bs) = getBindings pkts
         as = accBindings bs
@@ -304,9 +254,9 @@ listKeysFiltered grips pkts = do
     "master-key " ++ fingerprint top ++ "\n" ++ uid ++"  ...\n" ++ subkeys ++ "\n"
 
 
-
-
 {-
+ - modify a UID to test the verify function properly
+ - fails
 modifyUID (UserIDPacket str) = UserIDPacket str'
  where
     (fstname,rst) = break (==' ') str
@@ -316,11 +266,6 @@ modifyUID (UserIDPacket str) = UserIDPacket str'
 modifyUID other              = other
 -}
 
-
-
--- type TimeStamp = Word32
-
-
 readPublicKey :: Char8.ByteString -> RSAPublicKey
 readPublicKey bs = fromMaybe er $ do
     let (pre,bs1) = Char8.splitAt 7 bs
@@ -333,18 +278,8 @@ readPublicKey bs = fromMaybe er $ do
  where
     er = error "Unsupported key format"
 
-{-
-getPassphrase cmd =
-         case passphrase_fd cmd of
-                Just fd -> do pwh <- fdToHandle (toEnum fd)
-                              fmap trimCR $ S.hGetContents pwh
-                Nothing -> return ""
--}
-
-
-#define HOMEOPTION (def &= explicit &= name "homedir" &= typDir )
-
-
+-- | Returns the given list with its last element modified.
+toLast :: (x -> x) -> [x] -> [x]
 toLast f []  = []
 toLast f [x] = [f x]
 toLast f (x:xs) = x : toLast f xs
@@ -417,41 +352,6 @@ show_wip keyspec wkgrip db = do
     let nwb = maybe 0x80 CryptoCoins.secretByteFromName $ snd s
     putStrLn $ walletImportFormat nwb k
 
-
-{-
-applyCurve curve x = x*x*x + x*a + b where (a,b)=(geta curve,getb curve)
-
-secp256k1_oid = [1,3,132,0,10]
-secp256k1_curve = ECi l a b p r
- where
-    -- y² = x³ + 7 (mod p)
-    p = 0x0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F 
-    a = 0
-    b = 7
-    -- group order  (also order of base point G)
-    r = n
-    n = 0x0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 
-    -- cofactor
-    h = 1 
-    -- bit length
-    l = 256
-
-secp256k1_G = ECPa secp256k1_curve 
-                0x79BE667EF9DCBBAC55A06295CE870B07029BFCDB2DCE28D959F2815B16F81798
-                0x483ADA7726A3C4655DA4FBFC0E1108A8FD17B448A68554199C47D08FFB10D4B8 
-    {-
-    The base point G in compressed form is:
-
-        G = 02 79BE667E F9DCBBAC 55A06295 CE870B07 029BFCDB 2DCE28D9 59F2815B 16F81798 
-
-    and in uncompressed form is:
-
-        G = 04 79BE667E F9DCBBAC 55A06295 CE870B07 029BFCDB 2DCE28D9 59F2815B 16F81798
-               483ADA77 26A3C465 5DA4FBFC 0E1108A8 FD17B448 A6855419 9C47D08F FB10D4B8 
-    -}
--}
-
-
 cannonical_eckey x y = 0x4:pad32(numToBytes x) ++ pad32(numToBytes y) :: [Word8]
  where
   numToBytes n = reverse $ unfoldr getbyte n
@@ -473,22 +373,6 @@ bitcoinAddress network_id k = address
             hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $  pub
             address = base58_encode hash
 
--- gpg supported ECDSA curve: 2A8648CE3D030107
--- 2A 86 48 CE 3D 03 01 07 
--- 1,2,134,72,206,61,3,1,7
---  6*128+0x48 840
---  0x4e*128+0x3d 10045
--- 1.2.840.10045.3.1.7  --> NIST P-256
---
-    
-
-{-
-onionName :: KeyData -> (SockAddr,L.ByteString)
-onionName kd = (addr,name)
- where
-    (addr,(name:_,_)) = getHostnames kd
--}
-
 whoseKey :: RSAPublicKey -> KeyDB -> [KeyData]
 whoseKey rsakey db = filter matchkey (Map.elems db)
  where
@@ -510,6 +394,12 @@ whoseKey rsakey db = filter matchkey (Map.elems db)
         s2 <- signatures . Message $ [k,sub,subsig]
         signatures_over $ verify (Message [sub]) s2
 
+    isSameKey a b = sort (key apub) == sort (key bpub)
+     where
+        apub = secretToPublic a
+        bpub = secretToPublic b
+
+
 
 kiki_usage = putStr . unlines $
         ["kiki - a pgp key editing utility"
@@ -599,22 +489,40 @@ kiki_usage = putStr . unlines $
         ,"     --help     Shows this help screen."
         ]
 
+doAutosign rt kd@(KeyData k ksigs umap submap) = ops
+ where
+    ops = map (\u -> InducerSignature u []) us
+    us = filter torStyle $ Map.keys umap
+    torStyle str = and [ uid_topdomain parsed == "onion"
+                        , uid_realname parsed `elem` ["","Anonymous"]
+                        , uid_user parsed == "root"
+                        , fmap (match . fst) (lookup (packet k) torbindings)
+                            == Just True ]
+      where parsed = parseUID str
+            match =  (==subdom) . take (fromIntegral len)
+            subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
+            subdom = Char8.unpack subdom0
+            len = T.length (uid_subdomain parsed)
+            torbindings = getTorKeys (map packet $ flattenTop "" True kd)
+            getTorKeys pub = do
+                xs <- groupBindings pub
+                (_,(top,sub),us,_,_) <- xs
+                guard ("tor" `elem` us)
+                let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
+                return (top,(torhash,sub))
+
+            groupBindings pub = gs
+             where (_,bindings) = getBindings pub
+                   bindings' = accBindings bindings
+                   code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
+                   ownerkey (_,(a,_),_,_,_) = a
+                   sameMaster (ownerkey->a) (ownerkey->b)
+                        = fingerprint_material a==fingerprint_material b
+                   gs = groupBy sameMaster (sortBy (comparing code) bindings')
+
+
 main = do
     dotlock_init
-    {-
-    args <- cmdArgs $ modes
-        [ Cross_Merge HOMEOPTION
-              (def &= opt ("passphrase"::String)
-                &= typ "FD"
-                &= (help . concat)  ["file descriptor from "
-                                    ,"which to read passphrase"])
-              (def &= args &= typFile)
-            &= help "Merge multiple secret keyrings to stdout."
-        ]
-        &= program "kiki"
-        &= summary "kiki - a pgp key editing utility"
-    doCmd args
-    -}
     args_raw <- getArgs
     let (args,trail1) = break (=="--") args_raw
         trail = drop 1 trail1
@@ -671,20 +579,12 @@ main = do
                 guard $ take 1 bdmcb == "}"
                 let cmd = (drop 1 . reverse . drop 1) bdmcb
                 Just (spec,file,cmd)
-        {-
-        publics =
-            flip map (fromMaybe [] $ Map.lookup "--public" margs) $ \specfile -> do
-                let (spec,efile) = break (=='=') specfile
-                guard $ take 1 efile=="="
-                let file= drop 1 efile
-                Just (spec,file)
-        -}
         keyrings_ = fromMaybe [] $ Map.lookup "--keyrings" margs
         wallets   = fromMaybe [] $ Map.lookup "--wallets" margs
         passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
 
     when (any isNothing keypairs0) $ do
-        warn "syntax error"
+        warn "Syntax error in key pair specification"
         exitFailure
 
     input_key <- maybe (return Nothing)
@@ -692,15 +592,7 @@ main = do
                     $ Map.lookup "--show-whose-key" margs
 
     let keypairs = catMaybes keypairs0
-
-    {-
-    putStrLn $ "wallets = "++show wallets
-    putStrLn $ "keypairs = "++show keypairs
-    putStrLn $ "keyrings = "++show keyrings_
-    putStrLn $ "publics  = "++show publics
-    -}
-
-    let homespec = join . take 1 <$> Map.lookup "--homedir" margs
+        homespec = join . take 1 <$> Map.lookup "--homedir" margs
         passfd = fmap (FileDesc . read) passphrase_fd
         pems = flip map keypairs 
                 $ \(usage,path,cmd) ->
@@ -750,61 +642,7 @@ main = do
                 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs
 
             forM_ shargs $ \(cmd,args) -> cmd args (rtKeyDB rt)
-      e -> putStrLn $ errorString e
+      err -> putStrLn $ errorString err
 
     forM_ report $ \(fname,act) -> do
         putStrLn $ fname ++ ": " ++ reportString act
- where
-
-    doAutosign rt kd@(KeyData k ksigs umap submap) = ops
-     where
-        ops = map (\u -> InducerSignature u []) us
-        us = filter torStyle $ Map.keys umap
-        torbindings = getTorKeys (map packet $ flattenTop "" True kd)
-        torStyle str = and [ uid_topdomain parsed == "onion"
-                            , uid_realname parsed `elem` ["","Anonymous"]
-                            , uid_user parsed == "root"
-                            , fmap (match . fst) (lookup (packet k) torbindings)
-                                == Just True ]
-                      where parsed = parseUID str
-                            match =  (==subdom) . take (fromIntegral len)
-                            subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
-                            subdom = Char8.unpack subdom0
-                            len = T.length (uid_subdomain parsed)
-
-    getTorKeys pub = do
-        xs <- groupBindings pub
-        (_,(top,sub),us,_,_) <- xs
-        guard ("tor" `elem` us)
-        let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
-        return (top,(torhash,sub))
-
-isSameKey a b = sort (key apub) == sort (key bpub)
- where
-    apub = secretToPublic a
-    bpub = secretToPublic b
-
-
-
-groupBindings pub =
-        let (_,bindings) = getBindings pub
-            bindings' = accBindings bindings
-            code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
-            ownerkey (_,(a,_),_,_,_) = a
-            sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
-            -- matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True
-            -- matchgrip _ = False
-            gs = {- filter matchgrip $ -} groupBy sameMaster (sortBy (comparing code) bindings')
-        in gs
-
-
-
-{-
-makeTorUID g timestamp wkun keyflags topkey torkey = uid:signatures_over sig
- where
-    torhash sub = fromMaybe "" $ derToBase32 <$> derRSA sub
-    s = "Anonymous <root@" ++ take 16 (torhash torkey) ++ ".onion>"
-    uid = UserIDPacket s
-    sig = fst $ torsig g topkey wkun uid timestamp keyflags
--}
-