diff options
Diffstat (limited to 'lib/Hosts.hs')
-rw-r--r-- | lib/Hosts.hs | 314 |
1 files changed, 314 insertions, 0 deletions
diff --git a/lib/Hosts.hs b/lib/Hosts.hs new file mode 100644 index 0000000..5f09de1 --- /dev/null +++ b/lib/Hosts.hs | |||
@@ -0,0 +1,314 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE ScopedTypeVariables #-} | ||
3 | {-# LANGUAGE OverloadedStrings #-} | ||
4 | #if ! MIN_VERSION_network(2,4,0) | ||
5 | {-# LANGUAGE StandaloneDeriving #-} | ||
6 | #endif | ||
7 | module Hosts | ||
8 | ( Hosts | ||
9 | , assignName | ||
10 | , assignName' | ||
11 | , assignNewName | ||
12 | , removeName | ||
13 | , inet_pton | ||
14 | , inet_ntop | ||
15 | , empty | ||
16 | , hasName | ||
17 | , hasAddr | ||
18 | , encode | ||
19 | , decode | ||
20 | , diff | ||
21 | , plus | ||
22 | , filterAddrs | ||
23 | , namesForAddress | ||
24 | ) where | ||
25 | |||
26 | import Data.Maybe | ||
27 | import Data.Monoid ( (<>) ) | ||
28 | import Data.List as List (foldl', (\\) ) | ||
29 | import Data.Ord | ||
30 | import Data.Char (isSpace) | ||
31 | import qualified Data.Map as Map | ||
32 | import Data.Map (Map) | ||
33 | import qualified Data.ByteString.Lazy.Char8 as L | ||
34 | import System.IO.Unsafe (unsafePerformIO) | ||
35 | import Control.Applicative ( (<$>), (<*>) ) | ||
36 | import Control.Monad (mplus) | ||
37 | import Network.Socket | ||
38 | import ControlMaybe ( handleIO_ ) | ||
39 | |||
40 | #if ! MIN_VERSION_network(2,4,0) | ||
41 | deriving instance Ord SockAddr | ||
42 | #endif | ||
43 | |||
44 | inet_pton :: String -> Maybe SockAddr | ||
45 | inet_pton p = n | ||
46 | where | ||
47 | n = unsafePerformIO $ do | ||
48 | handleIO_ (return Nothing) $ do | ||
49 | info <- getAddrInfo safe_hints (Just p) Nothing | ||
50 | return $ fmap addrAddress $ listToMaybe info | ||
51 | safe_hints = Just $ defaultHints { addrFlags=[AI_NUMERICHOST] } | ||
52 | |||
53 | inet_ntop :: SockAddr -> String | ||
54 | inet_ntop n = p | ||
55 | where | ||
56 | p = case show n of | ||
57 | '[':xs -> fst $ break (==']') xs | ||
58 | xs -> fst $ break (==':') xs | ||
59 | |||
60 | |||
61 | data Hosts = Hosts | ||
62 | { lineCount :: Int | ||
63 | , numline :: Map Int L.ByteString | ||
64 | , namenum :: Map L.ByteString [Int] | ||
65 | , addrnum :: Map SockAddr Int | ||
66 | } | ||
67 | |||
68 | instance Show Hosts where | ||
69 | show = L.unpack . encode | ||
70 | |||
71 | encode :: Hosts -> L.ByteString | ||
72 | encode = L.unlines . map snd . Map.assocs . numline | ||
73 | |||
74 | parseLine :: L.ByteString -> (Maybe SockAddr, [L.ByteString]) | ||
75 | parseLine s = (addr,names) | ||
76 | where | ||
77 | (addr0,names) = splitAt 1 $ L.words (uncom s) | ||
78 | addr = do | ||
79 | a <- fmap L.unpack $ listToMaybe addr0 | ||
80 | n <- inet_pton a | ||
81 | return $ n -- inet_ntop n | ||
82 | |||
83 | uncom s = fst $ L.break (=='#') s | ||
84 | |||
85 | empty :: Hosts | ||
86 | empty = Hosts { lineCount = 0 | ||
87 | , numline = Map.empty | ||
88 | , addrnum = Map.empty | ||
89 | , namenum = Map.empty | ||
90 | } | ||
91 | |||
92 | {- | ||
93 | parseHosts fname = do | ||
94 | input <- L.readFile fname | ||
95 | return $ decode input | ||
96 | -} | ||
97 | |||
98 | decode :: L.ByteString -> Hosts | ||
99 | decode input = | ||
100 | let ls = L.lines input | ||
101 | ans = map (\l->(parseLine l,l)) ls | ||
102 | hosts = foldl' upd empty ans | ||
103 | upd hosts ((addr,names),line) = hosts | ||
104 | { lineCount = count | ||
105 | , numline = Map.insert count line (numline hosts) | ||
106 | , addrnum = maybeInsert (addrnum hosts) addr | ||
107 | , namenum = foldl' (\m x->Map.alter (cons count) x m) | ||
108 | (namenum hosts) | ||
109 | names | ||
110 | } | ||
111 | where count = lineCount hosts + 1 | ||
112 | cons v xs = Just $ maybe [v] (v:) xs | ||
113 | maybeInsert m x = maybe m | ||
114 | (\x->Map.insert x count m) | ||
115 | x | ||
116 | in hosts | ||
117 | |||
118 | |||
119 | hasName :: L.ByteString -> Hosts -> Bool | ||
120 | hasName name hosts = Map.member name $ namenum hosts | ||
121 | |||
122 | hasAddr :: SockAddr -> Hosts -> Bool | ||
123 | hasAddr addr hosts = Map.member addr $ addrnum hosts | ||
124 | |||
125 | scrubName :: | ||
126 | ([L.ByteString] -> [L.ByteString]) -> L.ByteString -> L.ByteString | ||
127 | scrubName f line = line' | ||
128 | where | ||
129 | (x,ign) = L.break (=='#') line | ||
130 | ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x | ||
131 | where oo = (.) . (.) | ||
132 | (a,ws') = splitAt 2 ws | ||
133 | ws'' = f ws' | ||
134 | line' = if null ws'' | ||
135 | then if length a==2 then "" -- "# " <> L.concat a <> ign | ||
136 | else line | ||
137 | else if length a==2 | ||
138 | then L.concat (a ++ ws'') <> ign | ||
139 | else let vs = L.groupBy ( (==EQ) `oo` comparing isSpace) $ L.dropWhile isSpace | ||
140 | $ L.tail ign | ||
141 | where oo = (.) . (.) | ||
142 | (a',vs') = splitAt 2 vs | ||
143 | vs'' = L.concat vs' | ||
144 | vs''' = if L.take 1 vs'' `elem` ["#",""] | ||
145 | then vs'' | ||
146 | else "# " <> vs'' | ||
147 | in L.concat (a'++ws'') <> vs''' | ||
148 | |||
149 | assignName :: SockAddr -> L.ByteString -> Hosts -> Hosts | ||
150 | assignName addr name hosts = assignName' False addr name hosts | ||
151 | |||
152 | chaddr :: Int -> SockAddr -> Hosts -> Hosts | ||
153 | chaddr n addr hosts = | ||
154 | hosts { addrnum = Map.insert addr n (addrnum hosts) | ||
155 | , numline = Map.adjust re n (numline hosts) } | ||
156 | where | ||
157 | re line = if length a==2 | ||
158 | then L.pack (inet_ntop addr) <> " " <> L.concat ws' <> ign | ||
159 | else line | ||
160 | where (x,ign) = L.break (=='#') line | ||
161 | ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x | ||
162 | where oo = (.) . (.) | ||
163 | (a,ws') = splitAt 2 ws | ||
164 | |||
165 | isLonerName line = length ws' <= 2 | ||
166 | where (x,_) = L.break (=='#') line | ||
167 | ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x | ||
168 | where oo = (.) . (.) | ||
169 | (_,ws') = splitAt 2 ws | ||
170 | |||
171 | scrubTrailingEmpties :: Hosts -> Hosts | ||
172 | scrubTrailingEmpties hosts = | ||
173 | hosts { lineCount = cnt' | ||
174 | , numline = foldl' (flip Map.delete) (numline hosts) es | ||
175 | } | ||
176 | where | ||
177 | cnt = lineCount hosts | ||
178 | es = takeWhile (\n -> Map.lookup n (numline hosts) == Just "") | ||
179 | $ [cnt,cnt-1..] | ||
180 | cnt' = cnt - length es | ||
181 | |||
182 | cannonizeName :: L.ByteString -> L.ByteString -> L.ByteString | ||
183 | cannonizeName name line = scrubName f line | ||
184 | where | ||
185 | f ws = [name," "] ++ pre ++ drop 2 rst | ||
186 | where | ||
187 | (pre,rst) = break (==name) ws | ||
188 | |||
189 | removeName name hosts = hosts' | ||
190 | where | ||
191 | hosts' = scrubTrailingEmpties (maybe hosts (removeName0 name hosts) ns) | ||
192 | ns = Map.lookup name (namenum hosts) | ||
193 | |||
194 | |||
195 | removeName0 name hosts nums = hosts | ||
196 | { namenum = Map.delete name (namenum hosts) | ||
197 | , numline = foldl' scrub (numline hosts) nums | ||
198 | } | ||
199 | where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m | ||
200 | |||
201 | assignName' :: Bool -> SockAddr -> L.ByteString -> Hosts -> Hosts | ||
202 | assignName' iscannon addr name hosts = hosts' | ||
203 | where | ||
204 | ns = Map.lookup name (namenum hosts) | ||
205 | a = Map.lookup addr (addrnum hosts) | ||
206 | canonize numline n = Map.adjust (cannonizeName name) n numline | ||
207 | hosts' = do | ||
208 | if (== Just True) $ elem <$> a <*> ns | ||
209 | then if not iscannon then hosts -- address already has name, nothing to do | ||
210 | else hosts { numline = foldl' canonize (numline hosts) $ fromJust ns} | ||
211 | else | ||
212 | let hosts0 = -- remove name if it's present | ||
213 | scrubTrailingEmpties $ maybe hosts (removeName0 name hosts) ns | ||
214 | ns' = fmap (filter $ | ||
215 | isLonerName | ||
216 | . fromJust | ||
217 | . (\n -> Map.lookup n (numline hosts))) | ||
218 | ns | ||
219 | >>= listToMaybe | ||
220 | hosts1 = -- insert name, or add new line | ||
221 | maybe (maybe (newLine hosts0) | ||
222 | (\n -> chaddr n addr $ appendName iscannon name hosts0 n) | ||
223 | ns') | ||
224 | (appendName iscannon name hosts0) | ||
225 | a | ||
226 | in hosts1 | ||
227 | newLine hosts = hosts | ||
228 | { lineCount = cnt | ||
229 | , numline = Map.insert cnt line $ numline hosts | ||
230 | , addrnum = Map.insert addr cnt $ addrnum hosts | ||
231 | , namenum = Map.alter (cons cnt) name $ namenum hosts | ||
232 | } | ||
233 | where cnt = lineCount hosts + 1 | ||
234 | line = L.pack (inet_ntop addr) <> " " <> name | ||
235 | cons v xs = Just $ maybe [v] (v:) xs | ||
236 | |||
237 | assignNewName :: SockAddr -> L.ByteString -> Hosts -> Hosts | ||
238 | assignNewName addr name hosts = | ||
239 | if hasName name hosts then hosts | ||
240 | else assignName' True addr name hosts | ||
241 | |||
242 | appendName :: Bool -> L.ByteString -> Hosts -> Int -> Hosts | ||
243 | appendName iscannon name hosts num = hosts | ||
244 | { numline = Map.adjust (scrubName f) num (numline hosts) | ||
245 | , namenum = Map.alter (cons num) name (namenum hosts) | ||
246 | } | ||
247 | where f ws = if iscannon | ||
248 | then [name, " "] ++ ws | ||
249 | else let rs = reverse ws | ||
250 | (sp,rs') = span (L.any isSpace) rs | ||
251 | in reverse $ sp ++ [name," "] ++ rs' | ||
252 | cons v xs = Just $ maybe [v] (v:) xs | ||
253 | |||
254 | -- Returns a list of bytestrings intended to show the | ||
255 | -- differences between the two host databases. It is | ||
256 | -- assumed that no lines are deleted, only altered or | ||
257 | -- appended. | ||
258 | diff :: Hosts -> Hosts -> [L.ByteString] | ||
259 | diff as bs = cs | ||
260 | where | ||
261 | [as',bs'] = map (L.lines . Hosts.encode) [as,bs] | ||
262 | ext xs = map Just xs ++ repeat Nothing | ||
263 | ds = takeWhile (isJust . uncurry mplus) $ zip (ext as') (ext bs') | ||
264 | es = filter (uncurry (/=)) ds | ||
265 | cs = do | ||
266 | (a,b) <- es | ||
267 | [a,b] <- return $ map maybeToList [a,b] | ||
268 | fmap ("- " <>) a ++ fmap ("+ " <>) b | ||
269 | |||
270 | namesForAddress :: SockAddr -> Hosts -> [L.ByteString] | ||
271 | namesForAddress addr hosts = snd $ _namesForAddress addr hosts | ||
272 | |||
273 | _namesForAddress :: SockAddr -> Hosts -> (Int, [L.ByteString]) | ||
274 | _namesForAddress addr (Hosts {numline=numline, addrnum=addrnum}) = ns | ||
275 | where | ||
276 | ns = maybe (-1,[]) id $ do | ||
277 | n <- Map.lookup addr addrnum | ||
278 | line <- Map.lookup n numline | ||
279 | return (n, snd $ parseLine line) | ||
280 | |||
281 | |||
282 | plus :: Hosts -> Hosts -> Hosts | ||
283 | plus a b = Map.foldlWithKey' mergeAddr a (addrnum b) | ||
284 | where | ||
285 | mergeAddr a addr bnum = a' | ||
286 | where | ||
287 | (anum,ns) = _namesForAddress addr a | ||
288 | bs = maybe [] (List.\\ ns) $ do | ||
289 | line <- Map.lookup bnum (numline b) | ||
290 | return . snd $ parseLine line | ||
291 | a' = if anum/=(-1) then foldl' app a $ reverse bs | ||
292 | else newLine a | ||
293 | app a b = appendName True b a anum -- True to allow b to reassign cannonical name | ||
294 | newLine hosts = hosts | ||
295 | { lineCount = cnt | ||
296 | , numline = Map.insert cnt line $ numline hosts | ||
297 | , addrnum = Map.insert addr cnt $ addrnum hosts | ||
298 | , namenum = foldl' updnamenum (namenum hosts) bs | ||
299 | } | ||
300 | where cnt = lineCount hosts + 1 | ||
301 | line = L.pack (inet_ntop addr) <> " " <> L.intercalate " " bs | ||
302 | cons v xs = Just $ maybe [v] (v:) xs | ||
303 | updnamenum m name = Map.alter (cons cnt) name m | ||
304 | |||
305 | filterAddrs :: (SockAddr -> Bool) -> Hosts -> Hosts | ||
306 | filterAddrs pred hosts = hosts' | ||
307 | where | ||
308 | als = Map.toList (addrnum hosts) | ||
309 | nl = foldl' f (numline hosts) als | ||
310 | f m (addr,num) = if pred addr | ||
311 | then m | ||
312 | else Map.adjust (scrubName $ const []) num m | ||
313 | lines = L.unlines . Map.elems $ nl | ||
314 | hosts' = decode lines | ||