module Network.DNSRBL(dorbls,dorblf,asanequery,sanequery) where
import ADNS (HostName,HostAddress,initResolver,Resolver,InitFlag(..),queryA)
import ADNS.Endian (readWord32)
import Control.Concurrent.Chan ( Chan, newChan, writeChan, readChan )
import Control.Monad ( replicateM )
import Control.Concurrent ( forkIO )
import Data.List (sort,group)
import Data.Bits
import Data.Word
import qualified Data.Map as M
data RBL = RBL { namexp :: [HostAddress] -> [(String,Bool)],
server :: String }
irbls :: [RBL]
irbls = [(RBL (parsefromlist [("SBL","127.0.0.2"),
("CBL","127.0.0.4"),
("NJBL","127.0.0.5"),
("PBLI","127.0.0.10"),
("PBLS","127.0.0.11")] )
"zen.spamhaus.org"
),
(RBL (parsefromlist [("INTERSERVE","127.0.0.2")] )
"rbl.interserver.net"
),
(RBL (parsefromlist [("KARMASPHEREBAD","127.0.0.2")] )
"karmasphere.email-sender.dnsbl.karmasphere.com"),
(RBL (parsefromlist [("AHBLOR","127.0.0.2"),
("AHBLOP","127.0.0.3"),
("AHBSPAM","127.0.0.4"),
("AHBPSSLB","127.0.0.5"),
("AHBFSPAM","127.0.0.6"),
("AHBSSUP","127.0.0.7"),
("AHBSSUPI","127.0.0.8"),
("AHBEUNM","127.0.0.9"),
("AHBSOS","127.0.0.10"),
("AHBRFCFAIL","127.0.0.11"),
("AHB5EFAIL","127.0.0.12"),
("AHBORFCFAIL","127.0.0.13"),
("AHBCDDOS","127.0.0.14"),
("AHBCRELAY","127.0.0.15"),
("AHBCSC","127.0.0.16"),
("AHBWORM","127.0.0.17"),
("AHBVIRUS","127.0.0.18"),
("AHBOP2","127.0.0.19"),
("AHBBSPAM","127.0.0.20"),
("AHBMISC","127.0.0.127")] ) "dnsbl.ahbl.org")]
nrbls :: [RBL]
nrbls = [(RBL (parsefromlist [("AHRHSBL","127.0.0.2")] ) "rhsbl.ahbl.org"),
(RBL (parsefrommask [("SURBLSPAMCOP",2),
("SURBLBS",4),
("SURBLPH",8),
("SURBLOB",16),
("SURBLAB",32),
("SURBLJP",64)] ) "multi.surbl.org"),
(RBL (parsefromlist [("EXDSNBL2","127.0.0.2"),
("EXDNSBL3","127.0.0.3")]) "ex.dnsbl.org")]
parsefrommask :: [(String,Word)] -> [HostAddress] -> [(String,Bool)]
parsefrommask il has = (map (\x -> (fst x,(foldr (||) False (map (matchmask (snd x)) has)))) il)
matchmask :: Word -> HostAddress -> Bool
matchmask mask ha = ((.&.) b4 mask) == mask
where
(b1,b2,b3,b4) = readWord32 ha
parsefromlist :: [(String,String)] -> [HostAddress] -> [(String,Bool)]
parsefromlist il has = (map (\x -> (fst x,(foldr (||) False (map (== (snd x)) hass)))) il)
where
hass = map toPR has
toRR :: HostAddress -> String
toRR ha = shows b4 . ('.':) .
shows b3 . ('.':) .
shows b2 . ('.':) .
shows b1 $ ""
where
(b1,b2,b3,b4) = readWord32 ha
toPR :: HostAddress -> String
toPR ha = shows b1 . ('.':).
shows b2 . ('.':).
shows b3 . ('.':).
shows b4 $ ""
where
(b1,b2,b3,b4) = readWord32 ha
myqueryA :: Resolver -> HostName -> IO [HostAddress]
myqueryA resolver host = queryA resolver host >>=(\a -> case a of
(Just b) -> return b
_ -> return [] )
rstrs :: String -> [HostAddress] -> [(RBL,String)]
rstrs host ips = (namerstrs host )++(concatMap iprstrs ips)
namerstrs :: HostName -> [(RBL,String)]
namerstrs host = zip nrbls (map (\rbl -> (host++"."++(server rbl) )) nrbls )
iprstrs :: HostAddress -> [(RBL,String)]
iprstrs host = zip irbls (map (\rbl -> ((toRR host)++"."++(server rbl) )) irbls )
ismatch :: ([HostAddress]->[(String,Bool)]) -> [HostAddress] -> [(String, Bool)]
ismatch func haddr = func haddr
rrtsb :: RBL -> [HostAddress] -> [(String,Bool)]
rrtsb rbl res = ismatch (namexp rbl) res
dowork :: Resolver -> Chan [(String,Bool)] -> (RBL, HostName) -> IO ()
dowork resolver channel query=do
a <- (myqueryA resolver (snd query) )
writeChan channel (rrtsb (fst query) a)
dorbls :: String -> IO [(String,Bool)]
dorbls host = initResolver [NoErrPrint, NoServerWarn] $ \resolver -> do
hostip <- (myqueryA resolver host )
results <- (dorblf host hostip resolver)
return results
dorblf :: String -> [HostAddress] -> Resolver -> IO [(String,Bool)]
dorblf host ips resolver = do
rrChannel <- newChan :: IO (Chan [(String,Bool)])
mapM_ (\h -> forkIO (dowork resolver rrChannel h)) queries
s <- replicateM (length queries) (readChan rrChannel )
return (concat s)
where
queries = (rstrs host ips)
sanequery :: String -> IO [(String,Bool)]
sanequery host = do
results <- dorbls host
return (map (\x-> ((fst (head x)),(foldl (\y z -> y || (snd z)) False x) ) )
(group (sort (results))) )
asanequery :: String -> [HostAddress] -> Resolver -> IO [(String,Bool)]
asanequery host ipl resolver = do
results <- dorblf host ipl resolver
return (map (\x-> ((fst (head x)),(foldl (\y z -> y || (snd z)) False x) ) )
(group (sort (results))) )