1 files changed, 212 insertions, 1 deletions

diff --git a/kiki.hs b/kiki.hs
index 0ecfa1c..2433d4e 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -75,6 +75,8 @@ import DotLock
 -- import Codec.Crypto.ECC.Base -- hecc package
 import Text.Printf
 import qualified CryptoCoins as CryptoCoins
+import qualified Hosts
+import Network.Socket -- (SockAddr)
 
 
 -- instance Default S.ByteString where def = S.empty
@@ -1188,6 +1190,7 @@ flattenTop fname ispub (KeyData key sigs uids subkeys) =
             ( flattenAllUids fname ispub uids
              ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
 
+flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
 flattenAllUids fname ispub uids =
     concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
 
@@ -1936,6 +1939,140 @@ signature_time ov = case if null cs then ds else cs of
             creationTime (SignatureCreationTimePacket t) = [t]
             creationTime _                               = []
 
+-- We return into IO in case we want to make a signature here.
+setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
+setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
+    -- TODO: we are removing the origin from the UID OriginMap,
+    --       when we should be removing origins from the locations
+    --       field of the sig's MappedPacket records.
+    -- Call getHostnames and compare to see if no-op.
+    if not (pred addr) || names0 == names \\ onions 
+        then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
+                             , "                   file: "++show (map Char8.unpack names)
+                             , "                   pred: "++show (pred addr)]) -}
+                    (return kd)
+        else do
+    -- We should be sure to remove origins so that the data is written
+    --   (but only if something changed).
+    -- Filter all hostnames present in uids
+    -- Write notations into first uid
+    {-
+    trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
+                   , "                    file: "++show (map Char8.unpack names) ]) $ do
+    -}
+    return $ KeyData topmp topsigs uids1 subs
+ where
+    topk = packet topmp
+    addr = fingerdress topk
+    names :: [Char8.ByteString]
+    names = Hosts.namesForAddress addr hosts
+    (_,(onions,names0)) = getHostnames kd
+    notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions)
+    isName (NotationDataPacket True "hostname@" _) = True
+    isName _ = False
+    uids0 = fmap zapIfHasName uids
+    fstuid = head $ do
+        p <- map packet $ flattenAllUids "" True uids
+        guard $ isUserID p
+        return $ uidkey p
+    uids1 = Map.adjust addnames fstuid uids0
+    addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
+     where
+        (ss,ts) = splitAt 1 sigs
+        f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
+                                                       else (sig, tm)
+         where p' = (packet sig) { unhashed_subpackets=uh }
+               uh = unhashed_subpackets (packet sig) ++ notations
+    zapIfHasName (sigs,om) = if or bs then (sigs',om)  -- XXX: removed om=Map.empty to preserve UserID origin
+                                      else (sigs,om)
+     where
+        (bs, sigs') = unzip $ map unhash sigs
+
+        unhash (sig,tm) = ( not (null ns)
+                          , ( sig { packet = p', locations = Map.empty }
+                            , tm ) )
+         where
+            psig = packet sig
+            p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
+                                           else psig
+            uh = unhashed_subpackets $ psig
+            (ns,ps) = partition isName uh
+
+socketFamily (SockAddrInet _ _)      = AF_INET
+socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
+socketFamily (SockAddrUnix _)        = AF_UNIX
+
+
+hasFingerDress :: KeyDB -> SockAddr -> Bool
+hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
+hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
+ where
+    (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
+    g' = map toUpper g
+
+fingerdress :: Packet -> SockAddr
+fingerdress topk = maybe zero id $ Hosts.inet_pton addr_str
+ where
+    zero = SockAddrInet 0 0
+    addr_str = colons $  "fd" ++ (drop 10 $ map toLower $ fingerprint topk)
+    colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
+    colons xs                 = xs
+
+
+{-
+onionName :: KeyData -> (SockAddr,L.ByteString)
+onionName kd = (addr,name)
+ where
+    (addr,(name:_,_)) = getHostnames kd
+-}
+
+getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
+getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
+ where
+    othernames = do
+        mp <- flattenAllUids "" True uids
+        let p = packet mp
+        guard $ isSignaturePacket p
+        uh <- unhashed_subpackets p
+        case uh of
+            NotationDataPacket True "hostname@" v
+              -> return $ Char8.pack v
+            _ -> mzero
+
+    addr = fingerdress topk
+    name = maybe "" id $ listToMaybe onames -- TODO: more than one tor key?
+    topk = packet topmp
+    torkeys = do
+        SubKey k sigs <- Map.elems subs
+        let subk = packet k
+        let sigs' = do
+                torsig <- filter (has_tag "tor") $ map (packet . fst) sigs
+                sig <- (signatures $ Message [topk,subk,torsig])
+                let v = verify (Message [topk]) sig
+                -- Require parent's signature
+                guard (not . null $ signatures_over v)
+                let unhashed = unhashed_subpackets torsig
+                    subsigs = mapMaybe backsig unhashed
+                    -- This should consist only of 0x19 values
+                    -- subtypes = map signature_type subsigs
+                sig' <- signatures . Message $ [topk,subk]++subsigs
+                let v' = verify (Message [subk]) sig'
+                -- Require subkey's signature
+                guard . not . null $ signatures_over v'
+                return torsig
+        guard (not $ null sigs')
+        return $ subk
+    has_tag tag p = isSignaturePacket p
+                    && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
+                          , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
+    subkeyPacket (SubKey k _ ) = k
+    onames :: [L.ByteString]
+    onames = map ( (<> ".onion")
+                 . Char8.pack
+                 . take 16
+                 . torhash )
+                 torkeys
+
 kiki_usage = do
     putStr . unlines $
         ["kiki - a pgp key editing utility"
@@ -2047,7 +2184,10 @@ main = do
                                      , ("--show-wip",1)
                                      , ("--help",0)
                                      ]
-                          argspec = map fst sargspec ++ ["--keyrings","--keypairs","--wallets"] 
+                          argspec = map fst sargspec ++ ["--keyrings"
+                                                        ,"--keypairs"
+                                                        ,"--wallets"
+                                                        ,"--hosts"] 
                                         -- "--bitcoin-keypairs"
                                         -- Disabled.  We shouldn't accept private key
                                         -- data on the command line.
@@ -2211,8 +2351,79 @@ main = do
                 -- return . snd $ Map.mapAccum (signTorIds stamp wkun keys) g use_db
                 Traversable.mapM (signTorIds wkun keys) use_db
         ret_db <- return $ fmap (const use_db) ret_db
+            
+        ret_db <- flip (maybe $ return ret_db) ret_db $ \db -> do
+            let hns = maybe [] id $ Map.lookup "--hosts" margs
+            hostdbs0 <- mapM (fmap Hosts.decode . L.readFile) hns
+
+            let gpgnames = map getHostnames $ Map.elems db
+                os = do
+                    (addr,(ns,_)) <- gpgnames
+                    n <- ns
+                    return (addr,n)
+                setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
+                -- we ensure .onion names are set properly
+                hostdbs = map setOnions hostdbs0
+                outgoing_names = do
+                    (addr,(_,gns)) <- gpgnames
+                    guard . not $ null gns
+                    guard $ all (null . Hosts.namesForAddress addr) hostdbs0
+                    return addr
+            -- putStrLn $ "hostdbs = " ++ show hostdbs
+
+            -- 1. let U = union all the host dbs 
+            --     preserving whitespace and comments of the first
+            let u0 = foldl' Hosts.plus Hosts.empty hostdbs
+                -- we filter U to be only finger-dresses
+                u1 = Hosts.filterAddrs (hasFingerDress db) u0
+
+            let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
+            {-
+            putStrLn $ "_  = {\n" ++ show (head hostdbs) ++ "}"
+            putStrLn $ "--> " ++ show (nf (head hostdbs))
+            putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
+            putStrLn $ "--> " ++ show (nf u0)
+            putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
+            putStrLn $ "--> " ++ show (nf u1)
+            -}
+            
+            -- 2. replace gpg annotations with those in U
+            -- forM use_db
+            db' <- Traversable.mapM (setHostnames (\a -> not $ elem a outgoing_names) u1) db
+
+            -- 3. add hostnames from gpg for addresses not in U
+            let u = foldl' f u1 ans
+                ans = reverse $ do
+                    (addr,(_,ns)) <- gpgnames
+                    guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
+                    n <- ns
+                    return (addr,n)
+                f h (addr,n) = Hosts.assignNewName addr n h
+
+            {-
+            putStrLn $ "u = {\n" ++ show u ++ "}"
+            putStrLn $ "--> " ++ show (nf u)
+            -}
+
+            -- 4. for each host db H, union H with U and write it out as H'
+            --     only if there is a non-empty diff
+            forM_ (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do 
+                let h = h1 `Hosts.plus` u
+                    d = Hosts.diff h0 h
+                    fnamecolon = Char8.pack fname <> ": "
+                {-
+                putStrLn $ "h = {\n" ++ show h ++ "}"
+                putStrLn $ "--> " ++ show (nf h)
+                -}
+                Char8.hPutStrLn stderr $ Char8.unlines (map (fnamecolon <>) d)
+                when (not $ null d) $ L.writeFile fname $ Hosts.encode h
+                return ()
+
+            return (Just db')
 
         flip (maybe $ return ()) ret_db . const $ do
+
+            
             -- On last pass, interpret --show-* commands.
             let shspec = Map.fromList [("--show-wk", const $ show_wk secfile grip)
                                       ,("--show-all",const $ show_all)