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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Concurrent
import Control.Monad
import Data.Either
import Data.List
import Data.Foldable
import Network.DNS.Lookup
import Network.DNS.Resolver
import Network.DNS.Types
import Network.Whois
import System.Posix.Files
import qualified Data.ByteString.Char8 as T
import qualified Data.Map as M
import Control.Monad.Trans.Maybe
import System.Environment
-- config
config_dns1 = "1.1.1.1" -- cloudfare DNS
config_dns2 = "8.8.8.8" -- google DNS
config_sleep = 300000 -- thread sleep 300ms
config_tld = "tld.txt" -- top level domains to check
config_cache = "cache.txt" -- cache answers
-- check if given domain name has a whois entry
isDomainWhois :: String -> IO Bool
isDomainWhois x = check <$> whois x
where check (_,Nothing) = False
check _ = True
-- check if given domain has a dns entry (pass ResolvSeed as first argument)
isDomainDNS :: ResolvSeed -> String -> IO Bool
isDomainDNS rs domain = do a <- withResolver rs $ \resolver ->
lookupA resolver $ T.pack domain
return $ either (not.isNameError) (const True) a
where isNameError NameError = True
isNameError OperationRefused = error "operation refused"
isNameError TimeoutExpired = error "timeout"
-- isNameError ServerFailure = error "server failure"
isNameError _ = False
-- group our domain name checkers in an Array (dns1, dns2, whois)
isDomain :: IO [String-> IO Bool]
isDomain = sequence [
isDomainDNS <$> makeResolvSeed defaultResolvConf
{resolvInfo = RCHostName config_dns1}
,isDomainDNS <$> makeResolvSeed defaultResolvConf
{resolvInfo = RCHostName config_dns2}
-- ,return isDomainWhois
]
-- assure the domain name is free using all the funcs from the array
multiCheck :: [String -> IO Bool] -> String -> IO Bool
multiCheck funcs dom = do res <- runner $ map ($dom) funcs
return $ maybe False (const True) res
where runner=runMaybeT . asum . fmap (MaybeT . fmap guard)
-- load a Monoid from File (or init File with an empty Monoid)
loadFromFile :: forall a. (Show a, Monoid a,Read a) => FilePath -> IO a
loadFromFile cf = do fileExist cf >>= \x -> when (not x) $
writeFile cf (show (mempty::a))
read . T.unpack <$> T.readFile cf
-- wait until the length of the mvar array reaches given length,
-- so we now processing has finished.
waitFinished :: MVar [a] -> Int -> IO ()
waitFinished mvout l = readMVar mvout >>= \o -> when (length o /= l) $
do threadDelay config_sleep
-- putStrLn $ show (length o) ++ "/" ++ show l
waitFinished mvout l
-- given an array of testing functions a list of domains, output array
-- and cache map. check if domains are free. for now we just use first
-- function for checking! consider different approach
domainChecker :: [String -> IO Bool] -> MVar [String] -> MVar [(Bool,String)]
-> MVar (M.Map String Bool) -> IO ()
domainChecker chk mvin mvout cache =
nxtDom >>= \dom -> when (dom/="") $ do
c<-readMVar cache
(r,ch)<-case M.lookup dom c of
Just xx-> return (xx,True)
Nothing-> do x<-multiCheck chk dom
addCache x dom
return (x,False)
outDom r dom
putStrLn $ dom ++ " "
++ (if r then "[\ESC[31m\STXTaken\ESC[m\STX]" else "[\ESC[32m\STXFree\ESC[m\STX]")
++ (if ch then " (\ESC[34m\STXcache hit\ESC[m\STX)" else "")
domainChecker chk mvin mvout cache
where outDom res dom =modifyMVar mvout $ \d ->
return ((res,dom):d,())
nxtDom =modifyMVar mvin $ \d ->
if null d then return (d,"")
else return (tail d,head d)
addCache r dom =modifyMVar cache $ \d ->
return (M.insert dom r d,())
---------------------------------------------
-- main / entry
main :: IO()
--main = test
main = entry
-- testing/debugging
test :: IO ()
test = do
let dom="shememem.com"
rs <- makeResolvSeed defaultResolvConf {resolvInfo = RCHostName config_dns1}
a <- withResolver rs $ \resolver -> lookupA resolver $ T.pack dom
print a
x <- isDomainDNS rs dom
print x
entry :: IO ()
entry = do
(f:_)<-getArgs
dom <- readFile f
let domains=lines dom
mapM_ check domains
where check x = do chk <- isDomainWhois x
putStrLn $ x ++ " " ++ (if chk then "[\ESC[31m\STXTaken\ESC[m\STX]" else "[\ESC[32m\STXFree\ESC[m\STX]")
|
