1 files changed, 250 insertions, 4 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 5149da4..c6aa6a4 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -57,10 +57,13 @@ import qualified Data.Traversable as Traversable (mapM,forM,sequence)
 #if ! MIN_VERSION_base(4,6,0)
 import GHC.Exts ( Down(..) )
 #endif
+import Network.Socket -- (SockAddr)
+import qualified Data.ByteString.Lazy.Char8 as Char8
 
 
 
-import qualified CryptoCoins as CryptoCoins
+import qualified Hosts
+import qualified CryptoCoins
 import Base58
 import FunctorToMaybe
 import DotLock
@@ -95,6 +98,7 @@ type PassWordFile = InputFile
 data FileType = KeyRingFile (Maybe PassWordFile)
               | PEMFile UsageTag
               | WalletFile -- (Maybe UsageTag)
+              | Hosts
 
 -- | RefType is perhaps not a good name for this...
 --   It is sort of like a read/write flag, although
@@ -308,6 +312,7 @@ data KikiReportAction =
         | ExternallyGeneratedFile
         | UnableToExport KeyAlgorithm String
         | FailedFileWrite
+        | HostsDiff ByteString
  deriving Show
 
 data KikiResult a = KikiResult
@@ -683,9 +688,114 @@ importPEMKey doDecrypt db' tup = do
             try r $ \(db'',report) -> do
             return $ KikiSuccess (db'', report0 ++ report)
 
+
+mergeHostFiles :: KeyRingOperation -> KeyDB
+                -> FilePath
+                -> FilePath
+     -> IO
+          (KikiCondition
+             ( ( Map.Map [Char8.ByteString] KeyData
+               , ( [Hosts.Hosts]
+                 , [Hosts.Hosts]
+                 , Hosts.Hosts
+                 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))]
+                 , [SockAddr]))
+             , [(FilePath,KikiReportAction)]))
+mergeHostFiles krd db secring pubring = do
+    let hns = files ishosts
+        ishosts Hosts = True
+        ishosts _     = False
+        files istyp = do
+            (f,(rtyp,ftyp)) <- Map.toList (kFiles krd)
+            guard (istyp ftyp)
+            resolveInputFile secring pubring f
+
+    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
+
+    return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])
+
+writeHostsFiles
+  :: KeyRingOperation
+     -> [Char]
+     -> [Char]
+     -> ([Hosts.Hosts],
+         [Hosts.Hosts],
+         Hosts.Hosts,
+         [(SockAddr, (t1, [Char8.ByteString]))],
+         [SockAddr])
+     -> IO [(FilePath, KikiReportAction)]
+writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
+    let hns = files ishosts
+        ishosts Hosts = True
+        ishosts _     = False
+        files istyp = do
+            (f,(rtyp,ftyp)) <- Map.toList (kFiles krd)
+            guard (istyp ftyp)
+            resolveInputFile secring pubring f
+
+    -- 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
+
+    -- 4. for each host db H, union H with U and write it out as H'
+    --     only if there is a non-empty diff
+    rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do 
+        let h = h1 `Hosts.plus` u
+            d = Hosts.diff h0 h
+            rs = map ((fname,) . HostsDiff) d
+        when (not $ null d) $ L.writeFile fname $ Hosts.encode h
+        return rs
+    return $ concat rss
+
+
 buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet))
               -> FilePath -> FilePath -> Maybe String -> KeyRingOperation
-              -> IO (KikiCondition ((KeyDB,Maybe String,Maybe MappedPacket)
+              -> IO (KikiCondition ((KeyDB,Maybe String,Maybe MappedPacket,
+                                      ([Hosts.Hosts],
+                                             [Hosts.Hosts],
+                                             Hosts.Hosts,
+                                             [(SockAddr, ([ByteString], [ByteString]))],
+                                             [SockAddr]) )
                                    ,[(FilePath,KikiReportAction)]))
 buildKeyDB doDecrypt secring pubring grip0 keyring = do
     let
@@ -754,7 +864,10 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do
     db <- foldM (importPEMKey doDecrypt) (KikiSuccess (db,[])) imports
     try db $ \(db,reportPEMs) -> do
 
-    return $ KikiSuccess ( (db, grip, mwk), reportWallets ++ reportPEMs )
+    r <- mergeHostFiles keyring db secring pubring
+    try r $ \((db,hs),reportHosts) -> do
+
+    return $ KikiSuccess ( (db, grip, mwk, hs), reportWallets ++ reportPEMs )
 
 torhash key = maybe "" id $ derToBase32 <$> derRSA key
 
@@ -1372,7 +1485,7 @@ runKeyRing operation = do
 
         -- merge all keyrings, PEM files, and wallets
         bresult <- buildKeyDB decrypt secring pubring grip0 operation
-        try' bresult $ \((db,grip,wk),report_imports) -> do
+        try' bresult $ \((db,grip,wk,hs),report_imports) -> do
 
         externals_ret <- initializeMissingPEMFiles operation
                                                    secring pubring grip
@@ -1402,6 +1515,8 @@ runKeyRing operation = do
 
         r <- writePEMKeys decrypt (rtKeyDB rt) exports
         try' r $ \report_pems -> do
+        
+        import_hosts <- writeHostsFiles operation secring pubring hs
 
         return $ KikiResult (KikiSuccess rt)
                    $ concat [ report_imports
@@ -2005,6 +2120,137 @@ flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedP
 flattenUid fname ispub (str,(sigs,om)) =
     (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
 
+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
+
+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
+
+-- 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
+
+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
+
+backsig (EmbeddedSignaturePacket s) = Just s
+backsig _                           = Nothing
+
+socketFamily (SockAddrInet _ _)      = AF_INET
+socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
+socketFamily (SockAddrUnix _)        = AF_UNIX
+
+
+
+{-----------------------------------------------}
 
 
 {-