Add the Reversible class.
[dead/harbl.git] / harbl / src / Network / DNS / RBL.hs
1 {-# LANGUAGE DoAndIfThenElse #-}
2
3 module Network.DNS.RBL (
4 Host,
5 Site,
6 host,
7 listing_message,
8 lookup_rbl,
9 sites )
10 where
11
12 import Data.ByteString.Char8 ( append, pack )
13 import Data.IP ( IPv4 )
14 import Data.List ( intercalate )
15 import Data.Maybe ( catMaybes )
16 import Network.DNS (
17 Domain,
18 DNSError,
19 Resolver,
20 defaultResolvConf,
21 lookupA,
22 makeResolvSeed,
23 withResolver )
24
25 import Network.DNS.RBL.Host ( Host(..), host )
26 import Network.DNS.RBL.IPv4Pattern ( addresses )
27 import Network.DNS.RBL.Pretty ( Pretty(..) )
28 import Network.DNS.RBL.Reversible ( Reversible(..) )
29 import Network.DNS.RBL.Site ( Site(..), sites )
30
31
32
33 -- | In most applications, you will want to know /why/ a host is
34 -- blacklisted. This type stores those details: the host itself, the
35 -- site on which the host was listed, and the return codes that we
36 -- got back from the blacklist.
37 data ListingDetails = ListingDetails Host Site [IPv4]
38
39
40 -- | Create a nice \"error\" message from a host and the details of
41 -- why it was listed.
42 --
43 listing_message :: ListingDetails -> String
44 listing_message (ListingDetails h (Site d _ w) codes) =
45 "host " ++ (pretty_show h) ++ " " ++
46 "listed on " ++ (pretty_show d) ++ " " ++
47 "with return code(s) " ++ return_codes ++ " " ++
48 "having weight " ++ (pretty_show w)
49 where
50 return_codes :: String
51 return_codes = intercalate "," (map show codes)
52
53
54 -- | Make the given 'Host' relative (if it was absolute), and reverse
55 -- its labels. This is done in order to look it up in the DNS in
56 -- standard reverse lookup form. For example, if we wanted to look
57 -- up @192.168.0.1@ on @rbl.example.com@, we would want to look up
58 -- the name @1.0.168.192.rbl.example.com@.
59 --
60 reverse_host :: Host -> Domain
61 reverse_host h =
62 pack $ case (backwards h) of
63 (HostRelative _) -> pretty_show h
64 (HostAbsolute d) -> pretty_show d
65
66
67
68 -- | This code is stolen from 'Network.DNS.lookupRDNS', which I'm
69 -- pretty sure I wrote anyway.
70 --
71 dnslookup :: Resolver -> Host -> Host -> IO (Either DNSError [IPv4])
72 dnslookup rlv rbl h = lookupA rlv dom
73 where
74 suffix = pack $ "." ++ (pretty_show rbl)
75 dom = (reverse_host h) `append` suffix
76
77
78 -- | See 'lookup_single'. The \"prime\" version here takes an
79 -- additional @resolver@ argument for performance reasons.
80 --
81 lookup_single' :: Resolver
82 -> Host
83 -> Site
84 -> IO (Maybe ListingDetails)
85 lookup_single' resolver h site@(Site d p _) = do
86 response <- dnslookup resolver d h
87 case response of
88 Left _ -> return Nothing -- Not listed, no error to report
89 Right ipv4s ->
90 case p of
91 -- No pattern given, but we got a hit.
92 Nothing -> return $ Just (ListingDetails h site ipv4s)
93 Just pat -> do
94 let ipv4_strings = map show ipv4s
95 let codes = addresses pat
96 let hits = map (`elem` codes) ipv4_strings
97 if or hits -- if any of the returned addresses match the pattern
98 then return $ Just (ListingDetails h site ipv4s)
99 else return Nothing
100
101
102 lookup_rbl :: [Site] -> Host -> IO [ListingDetails]
103 lookup_rbl rbl_sites h = do
104 rs <- makeResolvSeed defaultResolvConf
105 withResolver rs $ \resolver -> do
106 results <- mapM (lookup_single' resolver h) rbl_sites
107 return $ catMaybes results