diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * The names of its contributors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/DNSRBL.hs b/Network/DNSRBL.hs new file mode 100644 --- /dev/null +++ b/Network/DNSRBL.hs @@ -0,0 +1,142 @@ +{- | + Module : Network.DNSRBL + Copyright : (c) 2008 Holden Karau + License : LGPL + + Maintainer : holden@pigscanfly.ca + Stability : provisional + Portability : portable + + Anynchronously lookup a host on multiple DSNRBLs. +-} +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) +-- |A 'RBL' data type contains the information about a real time blacklist. +-- The names are the names of the different black lists +-- and are paired with the expected result +-- The server is the server which does the resolution +-- ip is true if the RBL support lookups on IP addresses (i.e. 127.0.0.1) +-- name is true if the RBL lookups names (i.e. foo.com) +data RBL = RBL { namexp :: [(String,String)], + server :: String, + ip :: Bool, + name :: Bool} deriving Show +-- |'rbls' is the list of real time black lists used +rbls :: [RBL] +rbls = (RBL [("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" + True + False):(RBL [("INTERSERVE","127.0.0.2")] + "rbl.interserver.net" + True + False):[] + +-- | 'toRR' convers a HostAddress to a string in reverse +-- (i.e. 127.0.0.1 printed as 1.0.0.127) +toRR :: HostAddress -> String +toRR ha = shows b4 . ('.':) . + shows b3 . ('.':) . + shows b2 . ('.':) . + shows b1 $ "" + where + (b1,b2,b3,b4) = readWord32 ha +-- | 'toPR' converts a HostAddress to a string +toPR :: HostAddress -> String +toPR ha = shows b1 . ('.':). + shows b2 . ('.':). + shows b3 . ('.':). + shows b4 $ "" + where + (b1,b2,b3,b4) = readWord32 ha + +-- |Wrap queryA and return the result +-- or in the event of an error an empty list +myqueryA :: Resolver -> HostName -> IO [HostAddress] +myqueryA resolver host = queryA resolver host >>=(\a -> case a of + (Just b) -> return b + _ -> return [] ) + + +-- |Get the lookup strings host name in all the RBLs +-- (resolving its IP address for the IP based RBLS) +rstrs :: String -> [HostAddress] -> [(RBL,String)] +rstrs host ips = (namerstrs host )++(concatMap iprstrs ips) + +-- |Get the lookup strings for name based RBLs + +namerstrs :: HostName -> [(RBL,String)] +namerstrs host = zip (filter name rbls) (map (\rbl -> (host++"."++(server rbl) )) (filter name rbls) ) + +-- Get the lookup string for the ip based RBLs +iprstrs :: HostAddress -> [(RBL,String)] +iprstrs host = zip (filter ip rbls) (map (\rbl -> ((toRR host)++"."++(server rbl) )) (filter ip rbls) ) + +-- |Is match compares a HostAddress and a String and sees if they are a match +ismatch :: String -> HostAddress -> Bool +ismatch str haddr = ((toPR haddr) == str) + +-- |Takes and RBL and a HostAddress list and return a list of strings +-- (where the string is the name of the RBL) & the bool is where it is listed or not +rrtsb :: RBL -> [HostAddress] -> [(String,Bool)] +rrtsb rbl res = (map (\x -> ((fst x), foldr (||) False (map (ismatch (snd x)) res))) (namexp rbl) ) + +-- | dowork does the semi-heavy lifting +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' is a friendly wrapper around +-- dorblf which only requires a hostname +dorbls :: String -> IO [(String,Bool)] +dorbls host = initResolver [NoErrPrint, NoServerWarn] $ \resolver -> do + hostip <- (myqueryA resolver host ) + results <- (dorblf host hostip resolver) + return results +-- |'dorblf' returns a list of (String,Bool) where +-- the string is the RBL name and Bool is if it was found or not +-- Note: There may be multiple instances of the same string +-- with different Bool values since one hostname may resolve to multiple IPs +-- some of which may match and some of which may not match +dorblf :: String -> [HostAddress] -> Resolver -> IO [(String,Bool)] +dorblf host ips resolver = do + rrChannel <- newChan :: IO (Chan [(String,Bool)]) + --results <- getChanContents rrChannel + mapM_ (\h -> forkIO (dowork resolver rrChannel h)) queries + --wait (length queries) results 0 + --return results + s <- replicateM (length queries) (readChan rrChannel ) + return (concat s) + where + queries = (rstrs host ips) + + + +-- | 'sanquery' is a Wrapper of "dorbls" which has only one instance +-- of each RBL and +-- if any of the elements were found in the RBL (name, any of the IPs) +-- it is true, otherwise it is false +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' is a wrapper of dorblf which has only one instance of RBL and +-- if any of the elements were found in the RBL (name, any of the IPs) +-- if it is true otherwise it is false. +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))) ) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,31 @@ +Real Time DNS BlackList Lookup +========================================= + +:Latest Release: dnsrbl-0.1.tgz + +Synopsis +-------- + A parallel real time DNS BlackList lookup. Because no-one likes spammers. + + +Documentation +------------- + + `Reference Documentation`_ + Haddock-generated reference of all exported functions. + +See Also +-------- + The internet :P + +Copyleft +-------- + + Copyright (c) 2008 Holden Karau . All rights + reserved. This software is released under ``_. + +----------------------------------------------------------------- + +`[Homepage] `_ + +.. _Reference Documentation: docs/index.html diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,15 @@ +#!/usr/bin/env runhaskell +>import Distribution.Simple +>import Distribution.Simple +>import Distribution.PackageDescription(PackageDescription,dataFiles) +>import Distribution.Simple.LocalBuildInfo(LocalBuildInfo,srcPref) +>import System.Cmd(system) +>import Distribution.Simple.LocalBuildInfo +>import System.IO(FilePath) + +>main :: IO () +>main = defaultMainWithHooks (simpleUserHooks {runTests = runzeTests}) + +>runzeTests:: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () +>runzeTests a b pd lb = system ( "runhaskell ./tests/dnsrbltest.hs") >> return() + diff --git a/dnsrbl.cabal b/dnsrbl.cabal new file mode 100644 --- /dev/null +++ b/dnsrbl.cabal @@ -0,0 +1,16 @@ +Name: dnsrbl +Version: 0.0.1 +Author: Holden Karau +Maintainer: Holden +License: BSD3 +License-File: LICENSE +Homepage: http://www.pigscanfly.ca/~holden/dnsrbl/ +Synopsis: Asynchronous DNS RBL lookup +Description: Asynchronous DNS RBL lookup +Category: Network +Build-Depends: base, network, containers, hsdns, HUnit +Exposed-Modules: Network.DNSRBL +GHC-Options: -Wall -threaded +Data-Files: README, prologue.txt +Build-Type: Simple +extra-source-files: tests/dnsrbltest.hs diff --git a/prologue.txt b/prologue.txt new file mode 100644 --- /dev/null +++ b/prologue.txt @@ -0,0 +1,1 @@ +Anynchronously lookup a given domain/ip on multiple DSNRBLs diff --git a/tests/dnsrbltest.hs b/tests/dnsrbltest.hs new file mode 100644 --- /dev/null +++ b/tests/dnsrbltest.hs @@ -0,0 +1,12 @@ +import Test.HUnit +import Network.DNSRBL +import List (sort) + +test1 = TestCase(do + x <- (sanequery "pigscanfly.ca") + (assertEqual "pigscanflycashouldbeclean" + [("CBL",True),("INTERSERVE",False),("NJBL",False),("PBLI",False),("PBLS",False),("SBL",False)] + (sort x) )) +tests = TestList [TestLabel "firsttest" test1] + +main = runTestTT tests