Experimental --hosts feature for import/export aliases from hosts file.

3 files changed, 290 insertions, 19 deletions

diff --git a/Hosts.hs b/Hosts.hs
index 669fd09..e53d441 100644
--- a/Hosts.hs
+++ b/Hosts.hs
@@ -12,11 +12,14 @@ module Hosts
     , encode
     , decode
     , diff
+    , plus
+    , filterAddrs
+    , namesForAddress
     ) where
 
 import Data.Maybe
 import Data.Monoid ( (<>) )
-import Data.List (foldl')
+import Data.List as List (foldl', (\\) )
 import Data.Ord
 import Data.Char (isSpace)
 import qualified Data.Map as Map
@@ -77,9 +80,9 @@ empty = Hosts { lineCount = 0
 
 parseHosts fname = do
     input <- L.readFile fname
-    decode input
+    return $ decode input
 
-decode input = do
+decode input = 
     let ls = L.lines input
         ans = map (\l->(parseLine l,l)) ls
         hosts = foldl' upd empty ans
@@ -96,7 +99,7 @@ decode input = do
                 maybeInsert m x = maybe m
                                         (\x->Map.insert x count m)
                                         x
-    return hosts
+    in hosts
 
 
 hasName :: L.ByteString -> Hosts -> Bool
@@ -112,8 +115,20 @@ scrubName f line = line'
                         where oo = (.) . (.)
     (a,ws') = splitAt 2 ws
     ws'' = f ws'
-    line' = if null ws'' then "# " <> line
-                         else L.concat (a ++ ws'') <> ign
+    line' = if null ws'' 
+                then if length a==2 then "# " <> L.concat a <> ign
+                                    else line
+                else if length a==2 
+                    then L.concat (a ++ ws'') <> ign
+                    else let vs  = L.groupBy ( (==EQ) `oo` comparing isSpace) $ L.dropWhile isSpace
+                                                                              $ L.tail ign
+                                                 where oo = (.) . (.)
+                             (a',vs') = splitAt 2 vs
+                             vs'' = L.concat vs'
+                             vs''' = if L.take 1 vs'' `elem` ["#",""] 
+                                        then vs''
+                                        else "# " <> vs''
+                         in L.concat (a'++ws'') <> vs'''
 
 assignName addr name hosts = assignName0 False addr name hosts
 
@@ -128,23 +143,13 @@ assignName0 iscannon addr name hosts = hosts'
             let hosts0 = -- remove name if it's present
                          maybe hosts (removeName hosts) ns
                 hosts1 = -- insert name, or add new line
-                         maybe (newLine hosts0) (appendName hosts0) a
+                         maybe (newLine hosts0) (appendName iscannon name hosts0) a
             in hosts1
     removeName hosts nums = hosts 
         { namenum = Map.delete name (namenum hosts)
         , numline = foldl' scrub (numline hosts) nums
         }
         where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m
-    appendName hosts num = hosts
-        { numline = Map.adjust (scrubName f) num (numline hosts)
-        , namenum = Map.alter (cons num) name (namenum hosts)
-        }
-        where f ws = if iscannon 
-                      then [name, " "] ++ ws
-                      else let rs       = reverse ws
-                               (sp,rs') = span (L.any isSpace) rs
-                           in reverse $ sp ++ [name," "] ++ rs'
-              cons v xs = Just $ maybe [v] (v:) xs
     newLine hosts = hosts
         { lineCount = cnt
         , numline = Map.insert cnt line $ numline hosts
@@ -159,6 +164,17 @@ assignNewName addr name hosts =
     if hasName name hosts then hosts
                           else assignName0 True addr name hosts
 
+appendName iscannon name hosts num = hosts
+        { numline = Map.adjust (scrubName f) num (numline hosts)
+        , namenum = Map.alter (cons num) name (namenum hosts)
+        }
+        where f ws = if iscannon 
+                      then [name, " "] ++ ws
+                      else let rs       = reverse ws
+                               (sp,rs') = span (L.any isSpace) rs
+                           in reverse $ sp ++ [name," "] ++ rs'
+              cons v xs = Just $ maybe [v] (v:) xs
+
 -- Returns a list of bytestrings intended to show the
 -- differences between the two host databases.  It is
 -- assumed that no lines are deleted, only altered or
@@ -175,3 +191,46 @@ diff as bs = cs
         [a,b] <- return $ map maybeToList [a,b]
         fmap ("- " <>) a ++ fmap ("+ " <>) b
 
+namesForAddress :: SockAddr -> Hosts -> [L.ByteString]
+namesForAddress addr hosts = snd $ _namesForAddress addr hosts
+
+_namesForAddress addr (Hosts {numline=numline, addrnum=addrnum}) = ns
+ where
+    ns = maybe (-1,[]) id $ do
+        n <- Map.lookup addr addrnum
+        line <- Map.lookup n numline
+        return (n, snd $ parseLine line)
+
+
+plus a b = Map.foldlWithKey' mergeAddr a (addrnum b)
+ where
+    mergeAddr a addr bnum = a'
+     where
+        (anum,ns) = _namesForAddress addr a
+        bs = maybe [] (List.\\ ns) $ do
+                 line <- Map.lookup bnum (numline b)
+                 return . snd $ parseLine line
+        a' = if anum/=(-1) then foldl' app a $ reverse bs
+                           else newLine a
+        app a b = appendName True b a anum -- True to allow b to reassign cannonical name
+        newLine hosts = hosts
+            { lineCount = cnt
+            , numline = Map.insert cnt line $ numline hosts
+            , addrnum = Map.insert addr cnt $ addrnum hosts
+            , namenum = foldl' updnamenum (namenum hosts) bs
+            }
+            where cnt = lineCount hosts + 1
+                  line = L.pack (inet_ntop addr) <> " " <> L.intercalate " " bs
+                  cons v xs = Just $ maybe [v] (v:) xs
+                  updnamenum m name = Map.alter (cons cnt) name m
+
+filterAddrs :: (SockAddr -> Bool) -> Hosts -> Hosts
+filterAddrs pred hosts = hosts'
+ where
+    als = Map.toList (addrnum hosts)
+    nl  = foldl' f (numline hosts) als
+    f m (addr,num) = if pred addr
+                        then m
+                        else Map.adjust (scrubName $ const []) num m
+    lines = L.unlines . Map.elems $ nl
+    hosts' = decode lines
diff --git a/kiki.cabal b/kiki.cabal
index 7bd661e..de75d14 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -21,6 +21,7 @@ Executable kiki
                      dataenc -any, text -any, pretty -any, pretty-show -any,
                      bytestring -any, openpgp (==0.6.1), binary -any,
                      unix, time, crypto-api, cryptocipher (>=0.3.7),
-                     containers -any, process -any, filepath -any
+                     containers -any, process -any, filepath -any,
+                     network
     ghc-options:     -O2
     c-sources: dotlock.c
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)