summaryrefslogtreecommitdiff
path: root/lib/Hosts.hs
blob: 9d6ef92223d370fad412dc9e263b899e214875e3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings   #-}
#if ! MIN_VERSION_network(2,4,0)
{-# LANGUAGE StandaloneDeriving  #-}
#endif
module Hosts
    ( Hosts
    , assignName
    , assignName'
    , assignNewName
    , removeName
    , inet_pton
    , inet_ntop 
    , empty
    , hasName
    , hasAddr
    , encode
    , decode
    , diff
    , plus
    , filterAddrs
    , namesForAddress
    ) where

import Data.Maybe
import Data.Monoid ( (<>) )
import Data.List as List (foldl', (\\) )
import Data.Ord
import Data.Char (isSpace)
import qualified Data.Map as Map
import           Data.Map (Map)
import qualified Data.ByteString.Lazy.Char8 as L
import System.IO.Unsafe (unsafePerformIO)
import Control.Applicative ( (<$>), (<*>) )
import Control.Monad (mplus)
import Network.Socket
import ControlMaybe ( handleIO_ )

#if ! MIN_VERSION_network(2,4,0)
deriving instance Ord SockAddr
#endif

inet_pton :: String -> Maybe SockAddr
inet_pton p = n
 where
    n = unsafePerformIO $ do
            handleIO_ (return Nothing) $ do
            info <- getAddrInfo safe_hints (Just p) Nothing
            return $ fmap addrAddress $ listToMaybe info
    safe_hints = Just $ defaultHints { addrFlags=[AI_NUMERICHOST] }

inet_ntop :: SockAddr -> String
inet_ntop n = p
 where
    p = case show n of
            '[':xs ->  fst $ break (==']') xs
            xs     ->  fst $ break (==':') xs


data Hosts = Hosts
    { lineCount :: Int
    , numline :: Map Int L.ByteString
    , namenum :: Map L.ByteString [Int]
    , addrnum :: Map SockAddr Int
    }

instance Show Hosts where
    show = L.unpack . encode

encode :: Hosts -> L.ByteString
encode = L.unlines . map snd . Map.assocs . numline

parseLine :: L.ByteString -> (Maybe SockAddr, [L.ByteString])
parseLine s = (addr,names)
 where
    (addr0,names) = splitAt 1 $ L.words (uncom s)
    addr = do
        a <- fmap L.unpack $ listToMaybe addr0
        n <- inet_pton a
        return $ n -- inet_ntop n

    uncom s = fst $ L.break (=='#') s

empty :: Hosts
empty = Hosts { lineCount = 0
              , numline = Map.empty
              , addrnum = Map.empty
              , namenum = Map.empty
              }

{-
parseHosts fname = do
    input <- L.readFile fname
    return $ decode input
-}

decode :: L.ByteString -> Hosts
decode input = 
    let ls = L.lines input
        ans = map (\l->(parseLine l,l)) ls
        hosts = foldl' upd empty ans
        upd hosts ((addr,names),line) = hosts
            { lineCount = count
            , numline = Map.insert count line (numline hosts)
            , addrnum = maybeInsert (addrnum hosts) addr
            , namenum = foldl' (\m x->Map.alter (cons count) x m)
                               (namenum hosts)
                               names
            }
          where count = lineCount hosts + 1
                cons v xs = Just $ maybe [v] (v:) xs
                maybeInsert m x = maybe m
                                        (\x->Map.insert x count m)
                                        x
    in hosts


hasName :: L.ByteString -> Hosts -> Bool
hasName name hosts = Map.member name $ namenum hosts

hasAddr :: SockAddr -> Hosts -> Bool
hasAddr addr hosts = Map.member addr $ addrnum hosts

scrubName ::
  ([L.ByteString] -> [L.ByteString]) -> L.ByteString -> L.ByteString
scrubName f line = line'
 where
    (x,ign) = L.break (=='#') line
    ws  = L.groupBy ( (==EQ) `oo` comparing isSpace) x
                        where oo = (.) . (.)
    (a,ws') = splitAt 2 ws
    ws'' = f ws'
    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 :: SockAddr -> L.ByteString -> Hosts -> Hosts
assignName addr name hosts = assignName' False addr name hosts

chaddr :: Int -> SockAddr -> Hosts -> Hosts
chaddr n addr hosts =
    hosts { addrnum = Map.insert addr n (addrnum hosts)
          , numline = Map.adjust re n (numline hosts) }
 where
    re line = if length a==2
                then L.pack (inet_ntop addr) <> " " <> L.concat ws' <> ign
                else line
        where (x,ign) = L.break (=='#') line
              ws  = L.groupBy ( (==EQ) `oo` comparing isSpace) x
                                  where oo = (.) . (.)
              (a,ws') = splitAt 2 ws

isLonerName :: L.ByteString -> Bool
isLonerName line = length ws' <= 2
        where (x,_) = L.break (=='#') line
              ws  = L.groupBy ( (==EQ) `oo` comparing isSpace) x
                                  where oo = (.) . (.)
              (_,ws') = splitAt 2 ws

scrubTrailingEmpties :: Hosts -> Hosts
scrubTrailingEmpties hosts =
    hosts { lineCount = cnt'
          , numline = foldl' (flip Map.delete) (numline hosts) es
          }
 where
    cnt = lineCount hosts
    es = takeWhile (\n -> Map.lookup n (numline hosts) == Just "")
            $ [cnt,cnt-1..]
    cnt' = cnt - length es

cannonizeName :: L.ByteString -> L.ByteString -> L.ByteString
cannonizeName name line = scrubName f line
 where
    f ws = [name," "] ++ pre ++ drop 2 rst
      where
        (pre,rst) = break (==name) ws

removeName :: L.ByteString -> Hosts -> Hosts
removeName name hosts = hosts'
 where
    hosts' = scrubTrailingEmpties (maybe hosts (removeName0 name hosts) ns)
    ns = Map.lookup name (namenum hosts) 

        
removeName0 :: Foldable t =>
               L.ByteString -> Hosts -> t Int -> Hosts
removeName0 name 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

assignName' :: Bool -> SockAddr -> L.ByteString -> Hosts -> Hosts
assignName' iscannon addr name hosts = hosts'
 where
    ns = Map.lookup name (namenum hosts) 
    a = Map.lookup addr (addrnum hosts)
    canonize numline n = Map.adjust (cannonizeName name) n numline
    hosts' = do
        if (== Just True) $ elem <$> a <*> ns
         then if not iscannon then hosts -- address already has name, nothing to do
                              else hosts { numline = foldl' canonize (numline hosts) $ fromJust ns}
         else 
            let hosts0 = -- remove name if it's present
                         scrubTrailingEmpties $ maybe hosts (removeName0 name hosts) ns
                ns' = fmap (filter $
                                isLonerName
                                . fromJust
                                . (\n -> Map.lookup n (numline hosts)))
                            ns
                        >>= listToMaybe
                hosts1 = -- insert name, or add new line
                         maybe (maybe (newLine hosts0)
                                      (\n -> chaddr n addr $ appendName iscannon name hosts0 n)
                                      ns')
                               (appendName iscannon name hosts0)
                               a
            in hosts1
    newLine hosts = hosts
        { lineCount = cnt
        , numline = Map.insert cnt line $ numline hosts
        , addrnum = Map.insert addr cnt $ addrnum hosts
        , namenum = Map.alter (cons cnt) name $ namenum hosts
        }
        where cnt = lineCount hosts + 1
              line = L.pack (inet_ntop addr) <> " " <> name
              cons v xs = Just $ maybe [v] (v:) xs

assignNewName :: SockAddr -> L.ByteString -> Hosts -> Hosts
assignNewName addr name hosts = 
    if hasName name hosts then hosts
                          else assignName' True addr name hosts

appendName :: Bool -> L.ByteString -> Hosts -> Int -> 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
-- appended.
diff :: Hosts -> Hosts -> [L.ByteString]
diff as bs = cs
 where
    [as',bs'] = map (L.lines . Hosts.encode) [as,bs]
    ext xs = map Just xs ++ repeat Nothing
    ds = takeWhile (isJust . uncurry mplus) $ zip (ext as') (ext bs')
    es = filter (uncurry (/=)) ds
    cs = do
        (a,b) <- es
        [a,b] <- return $ map maybeToList [a,b]
        fmap ("- " <>) a ++ fmap ("+ " <>) b

namesForAddress :: SockAddr -> Hosts -> [L.ByteString]
namesForAddress addr hosts = snd $ _namesForAddress addr hosts

_namesForAddress :: SockAddr -> Hosts -> (Int, [L.ByteString])
_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 :: Hosts -> Hosts -> Hosts
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