summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Hosts.hs163
1 files changed, 163 insertions, 0 deletions
diff --git a/Hosts.hs b/Hosts.hs
new file mode 100644
index 0000000..4f8788f
--- /dev/null
+++ b/Hosts.hs
@@ -0,0 +1,163 @@
1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Hosts
4 ( Hosts
5 , assignName
6 , assignNewName
7 , inet_pton
8 , inet_ntop
9 , empty
10 , hasName
11 , hasAddr
12 ) where
13
14import Data.Maybe
15import Data.Monoid ( (<>) )
16import Data.List (foldl')
17import Data.Ord
18import Data.Char (isSpace)
19import qualified Data.Map as Map
20import Data.Map (Map)
21import qualified Data.ByteString.Lazy.Char8 as L
22import System.IO.Unsafe (unsafePerformIO)
23import Control.Exception as Exception (IOException(..),catch)
24import Control.Applicative ( (<$>), (<*>) )
25import Network.Socket
26
27handleIO_ h a = Exception.catch a (\(_ :: IOException) -> h)
28
29inet_pton :: String -> Maybe SockAddr
30inet_pton p = n
31 where
32 n = unsafePerformIO $ do
33 handleIO_ (return Nothing) $ do
34 info <- getAddrInfo safe_hints (Just p) Nothing
35 return $ fmap addrAddress $ listToMaybe info
36 safe_hints = Just $ defaultHints { addrFlags=[AI_NUMERICHOST] }
37
38inet_ntop :: SockAddr -> String
39inet_ntop n = p
40 where
41 p = case show n of
42 '[':xs -> fst $ break (==']') xs
43 xs -> fst $ break (==':') xs
44
45
46data Hosts = Hosts
47 { lineCount :: Int
48 , numline :: Map Int L.ByteString
49 , namenum :: Map L.ByteString [Int]
50 , addrnum :: Map SockAddr Int
51 }
52
53instance Show Hosts where
54 show hosts = L.unpack . L.unlines . map snd . Map.assocs $ numline hosts
55
56parseLine s = (addr,names)
57 where
58 (addr0,names) = splitAt 1 $ L.words (uncom s)
59 addr = do
60 a <- fmap L.unpack $ listToMaybe addr0
61 n <- inet_pton a
62 return $ n -- inet_ntop n
63
64 uncom s = fst $ L.break (=='#') s
65
66empty = Hosts { lineCount = 0
67 , numline = Map.empty
68 , addrnum = Map.empty
69 , namenum = Map.empty
70 }
71
72parseHosts fname = do
73 input <- L.readFile fname
74 let ls = L.lines input
75 ans = map (\l->(parseLine l,l)) ls
76 hosts = foldl' upd empty ans
77 upd hosts ((addr,names),line) = hosts
78 { lineCount = count
79 , numline = Map.insert count line (numline hosts)
80 , addrnum = maybeInsert (addrnum hosts) addr
81 , namenum = foldl' (\m x->Map.alter (cons count) x m)
82 (namenum hosts)
83 names
84 }
85 where count = lineCount hosts + 1
86 cons v xs = Just $ maybe [v] (v:) xs
87 maybeInsert m x = maybe m
88 (\x->Map.insert x count m)
89 x
90 return hosts
91
92
93hasName :: L.ByteString -> Hosts -> Bool
94hasName name hosts = Map.member name $ namenum hosts
95
96hasAddr :: SockAddr -> Hosts -> Bool
97hasAddr addr hosts = Map.member addr $ addrnum hosts
98
99scrubName f line = line'
100 where
101 (x,ign) = L.break (=='#') line
102 ws = L.groupBy ( (==EQ) `oo` comparing isSpace) x
103 where oo = (.) . (.)
104 (a,ws') = splitAt 2 ws
105 ws'' = f ws'
106 line' = if null ws'' then "# " <> line
107 else L.concat (a ++ ws'') <> ign
108
109assignName addr name hosts = assignName0 False addr name hosts
110
111assignName0 iscannon addr name hosts = hosts'
112 where
113 ns = Map.lookup name (namenum hosts)
114 a = Map.lookup addr (addrnum hosts)
115 hosts' = do
116 if (== Just True) $ elem <$> a <*> ns
117 then hosts -- address already has name, nothing to do
118 else
119 let hosts0 = -- remove name if it's present
120 maybe hosts (removeName hosts) ns
121 hosts1 = -- insert name, or add new line
122 maybe (newLine hosts0) (appendName hosts0) a
123 in hosts1
124 removeName hosts nums = hosts
125 { namenum = Map.delete name (namenum hosts)
126 , numline = foldl' scrub (numline hosts) nums
127 }
128 where scrub m num = Map.adjust (scrubName $ filter (/=name)) num m
129 appendName hosts num = hosts
130 { numline = Map.adjust (scrubName f) num (numline hosts)
131 , namenum = Map.alter (cons num) name (namenum hosts)
132 }
133 where f ws = if iscannon
134 then [name, " "] ++ ws
135 else let rs = reverse ws
136 (sp,rs') = span (L.any isSpace) rs
137 in reverse $ sp ++ [name," "] ++ rs'
138 cons v xs = Just $ maybe [v] (v:) xs
139 newLine hosts = hosts
140 { lineCount = cnt
141 , numline = Map.insert cnt line $ numline hosts
142 , addrnum = Map.insert addr cnt $ addrnum hosts
143 , namenum = Map.alter (cons cnt) name $ namenum hosts
144 }
145 where cnt = lineCount hosts + 1
146 line = L.pack (inet_ntop addr) <> " " <> name
147 cons v xs = Just $ maybe [v] (v:) xs
148
149assignNewName addr name hosts =
150 if hasName name hosts then hosts
151 else assignName0 True addr name hosts
152
153{-
154main = do
155 args <- getArgs
156 let fname = args !! 0
157 p <- parseHosts fname
158 let addr = (fromJust $ inet_pton "fdee:0abe:1f80:31c7:d1af:bce0:0f6c:91d2")
159 p' = assignName addr "bigshift" p
160 p'' = assignNewName addr "poopy" p'
161 putStr $ show p''
162 return ()
163-}