summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-01-02 03:56:55 -0500
committerjoe <joe@jerkface.net>2014-01-02 03:56:55 -0500
commit81e29ffa385270cf0b104ebd72975921158ecb17 (patch)
tree367426cd34358e27713ef76cb8feb93ab0539800
parent6485ae8099e8d6292b37396b3f0e84900c470ffe (diff)
Experimental --hosts feature for import/export aliases from hosts file.
-rw-r--r--Hosts.hs93
-rw-r--r--kiki.cabal3
-rw-r--r--kiki.hs213
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
12 , encode 12 , encode
13 , decode 13 , decode
14 , diff 14 , diff
15 , plus
16 , filterAddrs
17 , namesForAddress
15 ) where 18 ) where
16 19
17import Data.Maybe 20import Data.Maybe
18import Data.Monoid ( (<>) ) 21import Data.Monoid ( (<>) )
19import Data.List (foldl') 22import Data.List as List (foldl', (\\) )
20import Data.Ord 23import Data.Ord
21import Data.Char (isSpace) 24import Data.Char (isSpace)
22import qualified Data.Map as Map 25import qualified Data.Map as Map
@@ -77,9 +80,9 @@ empty = Hosts { lineCount = 0
77 80
78parseHosts fname = do 81parseHosts fname = do
79 input <- L.readFile fname 82 input <- L.readFile fname
80 decode input 83 return $ decode input
81 84
82decode input = do 85decode input =
83 let ls = L.lines input 86 let ls = L.lines input
84 ans = map (\l->(parseLine l,l)) ls 87 ans = map (\l->(parseLine l,l)) ls
85 hosts = foldl' upd empty ans 88 hosts = foldl' upd empty ans
@@ -96,7 +99,7 @@ decode input = do
96 maybeInsert m x = maybe m 99 maybeInsert m x = maybe m
97 (\x->Map.insert x count m) 100 (\x->Map.insert x count m)
98 x 101 x
99 return hosts 102 in hosts
100 103
101 104
102hasName :: L.ByteString -> Hosts -> Bool 105hasName :: L.ByteString -> Hosts -> Bool
@@ -112,8 +115,20 @@ scrubName f line = line'
112 where oo = (.) . (.) 115 where oo = (.) . (.)
113 (a,ws') = splitAt 2 ws 116 (a,ws') = splitAt 2 ws
114 ws'' = f ws' 117 ws'' = f ws'
115 line' = if null ws'' then "# " <> line 118 line' = if null ws''
116 else L.concat (a ++ ws'') <> ign 119 then if length a==2 then "# " <> L.concat a <> ign
120 else line
121 else if length a==2
122 then L.concat (a ++ ws'') <> ign
123 else let vs = L.groupBy ( (==EQ) `oo` comparing isSpace) $ L.dropWhile isSpace
124 $ L.tail ign
125 where oo = (.) . (.)
126 (a',vs') = splitAt 2 vs
127 vs'' = L.concat vs'
128 vs''' = if L.take 1 vs'' `elem` ["#",""]
129 then vs''
130 else "# " <> vs''
131 in L.concat (a'++ws'') <> vs'''
117 132
118assignName addr name hosts = assignName0 False addr name hosts 133assignName addr name hosts = assignName0 False addr name hosts
119 134
@@ -128,23 +143,13 @@ assignName0 iscannon addr name hosts = hosts'
128 let hosts0 = -- remove name if it's present 143 let hosts0 = -- remove name if it's present
129 maybe hosts (removeName hosts) ns 144 maybe hosts (removeName hosts) ns
130 hosts1 = -- insert name, or add new line 145 hosts1 = -- insert name, or add new line
131 maybe (newLine hosts0) (appendName hosts0) a 146 maybe (newLine hosts0) (appendName iscannon name hosts0) a
132 in hosts1 147 in hosts1
133 removeName hosts nums = hosts 148 removeName hosts nums = hosts
134 { namenum = Map.delete name (namenum hosts) 149 { namenum = Map.delete name (namenum hosts)
135 , numline = foldl' scrub (numline hosts) nums 150 , numline = foldl' scrub (numline hosts) nums
136 } 151 }
137 where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m 152 where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m
138 appendName hosts num = hosts
139 { numline = Map.adjust (scrubName f) num (numline hosts)
140 , namenum = Map.alter (cons num) name (namenum hosts)
141 }
142 where f ws = if iscannon
143 then [name, " "] ++ ws
144 else let rs = reverse ws
145 (sp,rs') = span (L.any isSpace) rs
146 in reverse $ sp ++ [name," "] ++ rs'
147 cons v xs = Just $ maybe [v] (v:) xs
148 newLine hosts = hosts 153 newLine hosts = hosts
149 { lineCount = cnt 154 { lineCount = cnt
150 , numline = Map.insert cnt line $ numline hosts 155 , numline = Map.insert cnt line $ numline hosts
@@ -159,6 +164,17 @@ assignNewName addr name hosts =
159 if hasName name hosts then hosts 164 if hasName name hosts then hosts
160 else assignName0 True addr name hosts 165 else assignName0 True addr name hosts
161 166
167appendName iscannon name hosts num = hosts
168 { numline = Map.adjust (scrubName f) num (numline hosts)
169 , namenum = Map.alter (cons num) name (namenum hosts)
170 }
171 where f ws = if iscannon
172 then [name, " "] ++ ws
173 else let rs = reverse ws
174 (sp,rs') = span (L.any isSpace) rs
175 in reverse $ sp ++ [name," "] ++ rs'
176 cons v xs = Just $ maybe [v] (v:) xs
177
162-- Returns a list of bytestrings intended to show the 178-- Returns a list of bytestrings intended to show the
163-- differences between the two host databases. It is 179-- differences between the two host databases. It is
164-- assumed that no lines are deleted, only altered or 180-- assumed that no lines are deleted, only altered or
@@ -175,3 +191,46 @@ diff as bs = cs
175 [a,b] <- return $ map maybeToList [a,b] 191 [a,b] <- return $ map maybeToList [a,b]
176 fmap ("- " <>) a ++ fmap ("+ " <>) b 192 fmap ("- " <>) a ++ fmap ("+ " <>) b
177 193
194namesForAddress :: SockAddr -> Hosts -> [L.ByteString]
195namesForAddress addr hosts = snd $ _namesForAddress addr hosts
196
197_namesForAddress addr (Hosts {numline=numline, addrnum=addrnum}) = ns
198 where
199 ns = maybe (-1,[]) id $ do
200 n <- Map.lookup addr addrnum
201 line <- Map.lookup n numline
202 return (n, snd $ parseLine line)
203
204
205plus a b = Map.foldlWithKey' mergeAddr a (addrnum b)
206 where
207 mergeAddr a addr bnum = a'
208 where
209 (anum,ns) = _namesForAddress addr a
210 bs = maybe [] (List.\\ ns) $ do
211 line <- Map.lookup bnum (numline b)
212 return . snd $ parseLine line
213 a' = if anum/=(-1) then foldl' app a $ reverse bs
214 else newLine a
215 app a b = appendName True b a anum -- True to allow b to reassign cannonical name
216 newLine hosts = hosts
217 { lineCount = cnt
218 , numline = Map.insert cnt line $ numline hosts
219 , addrnum = Map.insert addr cnt $ addrnum hosts
220 , namenum = foldl' updnamenum (namenum hosts) bs
221 }
222 where cnt = lineCount hosts + 1
223 line = L.pack (inet_ntop addr) <> " " <> L.intercalate " " bs
224 cons v xs = Just $ maybe [v] (v:) xs
225 updnamenum m name = Map.alter (cons cnt) name m
226
227filterAddrs :: (SockAddr -> Bool) -> Hosts -> Hosts
228filterAddrs pred hosts = hosts'
229 where
230 als = Map.toList (addrnum hosts)
231 nl = foldl' f (numline hosts) als
232 f m (addr,num) = if pred addr
233 then m
234 else Map.adjust (scrubName $ const []) num m
235 lines = L.unlines . Map.elems $ nl
236 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
21 dataenc -any, text -any, pretty -any, pretty-show -any, 21 dataenc -any, text -any, pretty -any, pretty-show -any,
22 bytestring -any, openpgp (==0.6.1), binary -any, 22 bytestring -any, openpgp (==0.6.1), binary -any,
23 unix, time, crypto-api, cryptocipher (>=0.3.7), 23 unix, time, crypto-api, cryptocipher (>=0.3.7),
24 containers -any, process -any, filepath -any 24 containers -any, process -any, filepath -any,
25 network
25 ghc-options: -O2 26 ghc-options: -O2
26 c-sources: dotlock.c 27 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
75-- import Codec.Crypto.ECC.Base -- hecc package 75-- import Codec.Crypto.ECC.Base -- hecc package
76import Text.Printf 76import Text.Printf
77import qualified CryptoCoins as CryptoCoins 77import qualified CryptoCoins as CryptoCoins
78import qualified Hosts
79import Network.Socket -- (SockAddr)
78 80
79 81
80-- instance Default S.ByteString where def = S.empty 82-- instance Default S.ByteString where def = S.empty
@@ -1188,6 +1190,7 @@ flattenTop fname ispub (KeyData key sigs uids subkeys) =
1188 ( flattenAllUids fname ispub uids 1190 ( flattenAllUids fname ispub uids
1189 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) 1191 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
1190 1192
1193flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
1191flattenAllUids fname ispub uids = 1194flattenAllUids fname ispub uids =
1192 concatSort fname head (flattenUid fname ispub) (Map.assocs uids) 1195 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
1193 1196
@@ -1936,6 +1939,140 @@ signature_time ov = case if null cs then ds else cs of
1936 creationTime (SignatureCreationTimePacket t) = [t] 1939 creationTime (SignatureCreationTimePacket t) = [t]
1937 creationTime _ = [] 1940 creationTime _ = []
1938 1941
1942-- We return into IO in case we want to make a signature here.
1943setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
1944setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
1945 -- TODO: we are removing the origin from the UID OriginMap,
1946 -- when we should be removing origins from the locations
1947 -- field of the sig's MappedPacket records.
1948 -- Call getHostnames and compare to see if no-op.
1949 if not (pred addr) || names0 == names \\ onions
1950 then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
1951 , " file: "++show (map Char8.unpack names)
1952 , " pred: "++show (pred addr)]) -}
1953 (return kd)
1954 else do
1955 -- We should be sure to remove origins so that the data is written
1956 -- (but only if something changed).
1957 -- Filter all hostnames present in uids
1958 -- Write notations into first uid
1959 {-
1960 trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
1961 , " file: "++show (map Char8.unpack names) ]) $ do
1962 -}
1963 return $ KeyData topmp topsigs uids1 subs
1964 where
1965 topk = packet topmp
1966 addr = fingerdress topk
1967 names :: [Char8.ByteString]
1968 names = Hosts.namesForAddress addr hosts
1969 (_,(onions,names0)) = getHostnames kd
1970 notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions)
1971 isName (NotationDataPacket True "hostname@" _) = True
1972 isName _ = False
1973 uids0 = fmap zapIfHasName uids
1974 fstuid = head $ do
1975 p <- map packet $ flattenAllUids "" True uids
1976 guard $ isUserID p
1977 return $ uidkey p
1978 uids1 = Map.adjust addnames fstuid uids0
1979 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
1980 where
1981 (ss,ts) = splitAt 1 sigs
1982 f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
1983 else (sig, tm)
1984 where p' = (packet sig) { unhashed_subpackets=uh }
1985 uh = unhashed_subpackets (packet sig) ++ notations
1986 zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin
1987 else (sigs,om)
1988 where
1989 (bs, sigs') = unzip $ map unhash sigs
1990
1991 unhash (sig,tm) = ( not (null ns)
1992 , ( sig { packet = p', locations = Map.empty }
1993 , tm ) )
1994 where
1995 psig = packet sig
1996 p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
1997 else psig
1998 uh = unhashed_subpackets $ psig
1999 (ns,ps) = partition isName uh
2000
2001socketFamily (SockAddrInet _ _) = AF_INET
2002socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
2003socketFamily (SockAddrUnix _) = AF_UNIX
2004
2005
2006hasFingerDress :: KeyDB -> SockAddr -> Bool
2007hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
2008hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
2009 where
2010 (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
2011 g' = map toUpper g
2012
2013fingerdress :: Packet -> SockAddr
2014fingerdress topk = maybe zero id $ Hosts.inet_pton addr_str
2015 where
2016 zero = SockAddrInet 0 0
2017 addr_str = colons $ "fd" ++ (drop 10 $ map toLower $ fingerprint topk)
2018 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
2019 colons xs = xs
2020
2021
2022{-
2023onionName :: KeyData -> (SockAddr,L.ByteString)
2024onionName kd = (addr,name)
2025 where
2026 (addr,(name:_,_)) = getHostnames kd
2027-}
2028
2029getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
2030getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
2031 where
2032 othernames = do
2033 mp <- flattenAllUids "" True uids
2034 let p = packet mp
2035 guard $ isSignaturePacket p
2036 uh <- unhashed_subpackets p
2037 case uh of
2038 NotationDataPacket True "hostname@" v
2039 -> return $ Char8.pack v
2040 _ -> mzero
2041
2042 addr = fingerdress topk
2043 name = maybe "" id $ listToMaybe onames -- TODO: more than one tor key?
2044 topk = packet topmp
2045 torkeys = do
2046 SubKey k sigs <- Map.elems subs
2047 let subk = packet k
2048 let sigs' = do
2049 torsig <- filter (has_tag "tor") $ map (packet . fst) sigs
2050 sig <- (signatures $ Message [topk,subk,torsig])
2051 let v = verify (Message [topk]) sig
2052 -- Require parent's signature
2053 guard (not . null $ signatures_over v)
2054 let unhashed = unhashed_subpackets torsig
2055 subsigs = mapMaybe backsig unhashed
2056 -- This should consist only of 0x19 values
2057 -- subtypes = map signature_type subsigs
2058 sig' <- signatures . Message $ [topk,subk]++subsigs
2059 let v' = verify (Message [subk]) sig'
2060 -- Require subkey's signature
2061 guard . not . null $ signatures_over v'
2062 return torsig
2063 guard (not $ null sigs')
2064 return $ subk
2065 has_tag tag p = isSignaturePacket p
2066 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
2067 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
2068 subkeyPacket (SubKey k _ ) = k
2069 onames :: [L.ByteString]
2070 onames = map ( (<> ".onion")
2071 . Char8.pack
2072 . take 16
2073 . torhash )
2074 torkeys
2075
1939kiki_usage = do 2076kiki_usage = do
1940 putStr . unlines $ 2077 putStr . unlines $
1941 ["kiki - a pgp key editing utility" 2078 ["kiki - a pgp key editing utility"
@@ -2047,7 +2184,10 @@ main = do
2047 , ("--show-wip",1) 2184 , ("--show-wip",1)
2048 , ("--help",0) 2185 , ("--help",0)
2049 ] 2186 ]
2050 argspec = map fst sargspec ++ ["--keyrings","--keypairs","--wallets"] 2187 argspec = map fst sargspec ++ ["--keyrings"
2188 ,"--keypairs"
2189 ,"--wallets"
2190 ,"--hosts"]
2051 -- "--bitcoin-keypairs" 2191 -- "--bitcoin-keypairs"
2052 -- Disabled. We shouldn't accept private key 2192 -- Disabled. We shouldn't accept private key
2053 -- data on the command line. 2193 -- data on the command line.
@@ -2211,8 +2351,79 @@ main = do
2211 -- return . snd $ Map.mapAccum (signTorIds stamp wkun keys) g use_db 2351 -- return . snd $ Map.mapAccum (signTorIds stamp wkun keys) g use_db
2212 Traversable.mapM (signTorIds wkun keys) use_db 2352 Traversable.mapM (signTorIds wkun keys) use_db
2213 ret_db <- return $ fmap (const use_db) ret_db 2353 ret_db <- return $ fmap (const use_db) ret_db
2354
2355 ret_db <- flip (maybe $ return ret_db) ret_db $ \db -> do
2356 let hns = maybe [] id $ Map.lookup "--hosts" margs
2357 hostdbs0 <- mapM (fmap Hosts.decode . L.readFile) hns
2358
2359 let gpgnames = map getHostnames $ Map.elems db
2360 os = do
2361 (addr,(ns,_)) <- gpgnames
2362 n <- ns
2363 return (addr,n)
2364 setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
2365 -- we ensure .onion names are set properly
2366 hostdbs = map setOnions hostdbs0
2367 outgoing_names = do
2368 (addr,(_,gns)) <- gpgnames
2369 guard . not $ null gns
2370 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
2371 return addr
2372 -- putStrLn $ "hostdbs = " ++ show hostdbs
2373
2374 -- 1. let U = union all the host dbs
2375 -- preserving whitespace and comments of the first
2376 let u0 = foldl' Hosts.plus Hosts.empty hostdbs
2377 -- we filter U to be only finger-dresses
2378 u1 = Hosts.filterAddrs (hasFingerDress db) u0
2379
2380 let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
2381 {-
2382 putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}"
2383 putStrLn $ "--> " ++ show (nf (head hostdbs))
2384 putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
2385 putStrLn $ "--> " ++ show (nf u0)
2386 putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
2387 putStrLn $ "--> " ++ show (nf u1)
2388 -}
2389
2390 -- 2. replace gpg annotations with those in U
2391 -- forM use_db
2392 db' <- Traversable.mapM (setHostnames (\a -> not $ elem a outgoing_names) u1) db
2393
2394 -- 3. add hostnames from gpg for addresses not in U
2395 let u = foldl' f u1 ans
2396 ans = reverse $ do
2397 (addr,(_,ns)) <- gpgnames
2398 guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
2399 n <- ns
2400 return (addr,n)
2401 f h (addr,n) = Hosts.assignNewName addr n h
2402
2403 {-
2404 putStrLn $ "u = {\n" ++ show u ++ "}"
2405 putStrLn $ "--> " ++ show (nf u)
2406 -}
2407
2408 -- 4. for each host db H, union H with U and write it out as H'
2409 -- only if there is a non-empty diff
2410 forM_ (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do
2411 let h = h1 `Hosts.plus` u
2412 d = Hosts.diff h0 h
2413 fnamecolon = Char8.pack fname <> ": "
2414 {-
2415 putStrLn $ "h = {\n" ++ show h ++ "}"
2416 putStrLn $ "--> " ++ show (nf h)
2417 -}
2418 Char8.hPutStrLn stderr $ Char8.unlines (map (fnamecolon <>) d)
2419 when (not $ null d) $ L.writeFile fname $ Hosts.encode h
2420 return ()
2421
2422 return (Just db')
2214 2423
2215 flip (maybe $ return ()) ret_db . const $ do 2424 flip (maybe $ return ()) ret_db . const $ do
2425
2426
2216 -- On last pass, interpret --show-* commands. 2427 -- On last pass, interpret --show-* commands.
2217 let shspec = Map.fromList [("--show-wk", const $ show_wk secfile grip) 2428 let shspec = Map.fromList [("--show-wk", const $ show_wk secfile grip)
2218 ,("--show-all",const $ show_all) 2429 ,("--show-all",const $ show_all)