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