Work on autosign functionality

1 files changed, 164 insertions, 9 deletions

diff --git a/keys.hs b/keys.hs
index b5d1986..6fdd408 100644
--- a/keys.hs
+++ b/keys.hs
@@ -27,6 +27,7 @@ import qualified Codec.Binary.Base32 as Base32
 import qualified Crypto.Hash.SHA1 as SHA1
 import Data.Char (toLower)
 import qualified Crypto.PubKey.RSA as RSA
+import Crypto.Random (newGenIO,SystemRandom)
 import Data.ASN1.Types
 import Data.ASN1.Encoding
 import Data.ASN1.BinaryEncoding
@@ -138,15 +139,23 @@ disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
     group2 []       = []
     -}
 
+verifyBindingsEx :: [Packet] -> ([SignatureOver], [SignatureOver]) -- ^ (binding signatures, other signatures)
+verifyBindingsEx pkts = bicat . unzip $ do
+        let (keys,_) = partition isKey pkts
+        keys <- disjoint_fp keys
+        return $ verifyBindings keys pkts
+ where
+    bicat (xs,ys) = (concat xs,concat ys)
+
 getBindings ::
   [Packet]
   -> 
     ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets
                                    --   that were used for the verifications
     , [(Word8,
-       (Packet, Packet),
-       [String],
-       [SignatureSubpacket],
+       (Packet, Packet), -- (topkey,subkey)
+       [String],         -- usage flags
+       [SignatureSubpacket], -- hashed data
        [Packet])] -- ^ binding signatures
     )
 getBindings pkts = (sigs,bindings)
@@ -169,6 +178,8 @@ getBindings pkts = (sigs,bindings)
                 kind = guard (code==1) >> hashed >>= maybeToList . usage
             return (code,(topkey b,subkey b), kind, hashed,claimants)
 
+-- Returned data is simmilar to getBindings but the Word8 codes
+-- are ORed together.
 accBindings ::
   Bits t =>
   [(t, (Packet, Packet), [a], [a1], [a2])]
@@ -194,6 +205,7 @@ data UserIDRecord = UserIDRecord {
     uid_subdomain :: T.Text,
     uid_topdomain :: T.Text
 }
+ deriving Show
 
 isBracket '<' = True
 isBracket '>' = True
@@ -295,7 +307,7 @@ listKeysFiltered grip pkts = do
 
 data PGPKeyFlags =
     Special
-    | Vouch
+    | Vouch -- Signkey
     | Sign
     | VouchSign
     | Communication
@@ -315,7 +327,7 @@ data PGPKeyFlags =
 usageString flgs = 
  case flgs of
     Special -> "special"
-    Vouch -> "vouch"
+    Vouch -> "vouch" -- signkey
     Sign -> "sign"
     VouchSign -> "vouch-sign"
     Communication -> "communication"
@@ -506,7 +518,6 @@ cmd = required . pos 0 Nothing $ posInfo
 a <:> b = flip const <$> a <*> b
 infixr 2 <:>
 
-
 selectAction cmd actions = actions !! fromEnum cmd
 
 cmdInfo :: ArgVal cmd => 
@@ -607,6 +618,81 @@ main = do
                         where topair (x:xs) = (x,xs)
         return $ lookup "default-key" config >>= listToMaybe
 
+    getPGPEnviron cmd = do
+        (homedir,secring,grip) <- getHomeDir cmd
+        (Message sec) <- readPacketsFromFile secring
+        let (keys,_) = partition (\k -> case k of 
+                                   { SecretKeyPacket {} -> True 
+                                   ; _                  -> False })
+                                 sec
+        return (homedir,sec, grip `mplus` fmap fingerprint (listToMaybe keys))
+
+    getTorKeys pub = do
+        xs <- groupBindings pub
+        (_,(top,sub),us,_,_) <- xs
+        guard ("tor" `elem` us)
+        let torhash = maybe "" id $ derToBase32 <$> derRSA sub
+        return (top,(torhash,sub))
+
+    uidScan pub = scanl (\(mkey,u) w -> 
+                             case () of
+                              _ | isMaster w -> (w,u)
+                              _ | isUserID w -> (mkey,w)
+                              _ | otherwise  -> (mkey,u) 
+                            )
+                          (w0,w0)
+                          ws
+                        where 
+                            w0:ws = pub
+                            isMaster k@(PublicKeyPacket {}) = not $ is_subkey k
+                            isMaster _ = False
+
+    signSelfAuthTorKeys g sec grip xs = ys
+     where
+        keys = filter isKey sec
+        selfkey = find_key fingerprint (Message keys) (fromJust grip)
+        mainpubkey = fst (head xs)
+        uid:xs' = map snd xs
+        (sigs, xs'') = span isSignaturePacket xs'
+        overs sig = signatures $ Message (keys++[uid,sig])
+        vs :: [ ( Packet -- signature
+                , Maybe SignatureOver) -- Nothing means non-verified
+              ]
+        vs = do
+            sig <- sigs
+            let vs = overs sig >>= return . verify (Message keys)
+                ws = filter (not . null . signatures_over) vs
+                ws' = if null ws then [Nothing] else map Just ws
+            v <- ws'
+            return (sig,v)
+        has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs
+        sigs' = if has_self
+                    then sigs
+                    -- else sigs  ++ (filter isSignaturePacket $ signatures_over new_sig)
+                    -- else trace ("new_sig = "++ show (filter isSignaturePacket $ signatures_over new_sig)) sigs
+                    -- else trace ("selfkey "++ show (fmap fingerprint selfkey)) sigs
+                    else trace (traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ signatures_over new_sig
+                    -- else trace (traceSig (mainpubkey) (uid) ([last sigs])) sigs ++ signatures_over new_sig
+        traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey)
+                                        ,"new_sig topkey:"++ (show . fingerprint $ newtop)
+                                        ,"new_sig user_id:"++ (show newuid)
+                                        ,"new_sig |over| = " ++ (show . length $ new_sig)
+                                        ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig)
+                                        ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig)
+                                        ,"new_sig type: " ++ (show . map signature_type $ new_sig)
+                                        -- ,"new_sig signature:" ++ (show . concatMap signature $ new_sig)
+                                        ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig)
+                                        ])
+        new_sig = fst $ sign (Message (maybeToList selfkey)) 
+                             (CertificationSignature mainpubkey
+                                                     uid
+                                                     []) --fromJust selfkey, uid])
+                             SHA1
+                             (fromJust grip)
+                             timestamp
+                             g
+        timestamp = trace "TODO: timestamp" 23420 
+        ys = uid:sigs'++xs''
 
     doCmd cmd@(List {}) = do
         (homedir,secring,grip) <- getHomeDir cmd
@@ -620,10 +706,79 @@ main = do
         return ()
 
     doCmd cmd@(AutoSign {}) = do
-        (homedir,secring,grip) <- getHomeDir cmd
-        (Message sec) <- readPacketsFromFile secring
+        ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
+          , sec   -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
+          , grip  -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
+          ) <- getPGPEnviron cmd
+        putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip)
         (Message pub) <- readPacketsFromFile (input cmd)
-        putStrLn $ "Inspecting packets..."
         putStrLn $ listKeys pub
+        -- forM_ (zip [1..] pub) $ \(i,k) -> do
+        --     putStrLn $ show i ++ ": " ++ show k
+        let torbindings = getTorKeys pub
+            keyed = uidScan pub
+            marked = zipWith doit keyed pub
+            doit (mkey,u) packet = (isTorID packet, (mkey,u,packet))
+                where
+                    isTorID (UserIDPacket str) = 
+                        and [ uid_topdomain parsed == "onion"
+                            , uid_realname parsed `elem` ["","Anonymous"]
+                            , uid_user parsed == "root" 
+                            , fmap (match . fst) (lookup mkey 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)
+
+                    isTorID _                  = False
+
+        g <- newGenIO
+        let xs:xss = groupBy (\_ (b,_)->not b) marked
+            pub' = map (snd . cleanup) xs 
+                    ++ concatMap (signSelfAuthTorKeys (g::SystemRandom) sec grip)
+                                 (map (map cleanup) xss)
+            cleanup (_,(topkey,_,pkt)) = (topkey,pkt)
+        putStrLn $ "-------- signed ------> "
+        putStrLn $ listKeys (sec++pub')
+        {-
+        putStrLn $ "------------------- forM_ (zip [1..] marked) $ \\(i,(flag,(_,u,p)))"
+        forM_ (zip [1..] marked) $ \(i,(flag,(_,u,p))) -> do
+            putStrLn $ show i ++ ": " ++ show (flag, p)
+        let marked2 = groupBy (\_ (b,_)->b) (map (\(b,(k,u,v))->(b,(fingerprint k,u,v))) marked)
+        putStrLn $ "------------------- marked2 ..."
+        forM_ marked2 $ \v -> do
+            putStrLn $ show v
+        -}
+        {-
+        putStrLn $ "TOR ID = " ++ show (cursor uidz)
+        putStrLn $ "parsed = " ++ show parsed
+        -- forM_ (zip [1..] sec) $ \(i,k) -> do
+        --    putStrLn $ show i ++ ": " ++ show k
+        putStrLn $ "tor bindings = " ++ show torbindings
+        putStrLn $ "should_sign = " ++ show should_sign
+        -}
+        putStrLn $ "-------------------"
+        -- extract all tor keys into base32 hash keyed map
+        --   use 'signatures' to get signed keys only
+        -- zipperSpan to tor-style UserIDPacket
+        -- zipperSpan to SignaturePacket with usage@=tor
+        -- check the back sig
+        -- If it's good, then 
+        --  VOUCH for this UID:
+        --    add a new SignaturePacket after the last SignaturePacket
+        --    for the tor-style UserIDPacket
         return ()
 
+groupBindings pub = 
+        let (sigs,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
+