dprox (empty) → 0.1.0
raw patch · 8 files changed
+578/−0 lines, 8 filesdep +attoparsecdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec, base, bytestring, containers, dns, hspec, iproute, network, optparse-applicative, streaming-commons, unix, unordered-containers
Files
- LICENSE +30/−0
- README.md +23/−0
- Setup.hs +2/−0
- dprox.cabal +80/−0
- src/Config.hs +166/−0
- src/DomainRoute.hs +77/−0
- src/Main.hs +148/−0
- test/Test.hs +52/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Bin Jin (c) 2019++All rights reserved.++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.++ * Neither the name of Author name here nor the names of other+ contributors may 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.
+ README.md view
@@ -0,0 +1,23 @@+## dprox++dprox is a lightweight DNS proxy server. It's written as a drop-in replacement+of dnsmasq to work with [dnsmasq-china-list](https://github.com/felixonmars/dnsmasq-china-list),+while improving the lookup performance over large domain list.++### Installation++Only Linux and macOS are supported. [stack](https://docs.haskellstack.org/en/stable/README/#how-to-install) is required to build `dprox`.++```sh+stack install+```++### Usage++Only a small subset of dnsmasq options are implemented, just barely enough to work with `dnsmasq-china-list`.++Use `dprox --help` to list those options. A [systemd unit file](https://github.com/bjin/dprox/blob/master/systemd/dprox.service) is also provided for Linux user.++### Known Issue++* `dprox` has fairly large memory footprint at the moment. Over 100MB for current `dnsmasq-china-list`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dprox.cabal view
@@ -0,0 +1,80 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 0f621c1a70a120599e9358ce5011984d7b1d62d9b9f16bd95f3c611c6dfa414c++name: dprox+version: 0.1.0+synopsis: a lightweight DNS proxy server+description: Please see the README on GitHub at <https://github.com/bjin/dprox#readme>+category: DNS+homepage: https://github.com/bjin/dprox#readme+bug-reports: https://github.com/bjin/dprox/issues+author: Bin Jin+maintainer: bjin@ctrl-d.org+copyright: 2019 Bin Jin+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/bjin/dprox++flag static+ description: Enable static build+ manual: True+ default: False++executable dprox+ main-is: Main.hs+ other-modules:+ Config+ DomainRoute+ hs-source-dirs:+ src+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ attoparsec+ , base >=4.7 && <5+ , bytestring+ , containers+ , dns >=3.0.4+ , iproute+ , network+ , optparse-applicative+ , streaming-commons+ , unix+ , unordered-containers+ if flag(static)+ ghc-options: -optl-static+ default-language: Haskell2010++test-suite dprox-test+ type: exitcode-stdio-1.0+ main-is: Test.hs+ other-modules:+ DomainRoute+ hs-source-dirs:+ src+ test+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ attoparsec+ , base >=4.7 && <5+ , bytestring+ , containers+ , dns >=3.0.4+ , hspec+ , iproute+ , network+ , optparse-applicative+ , streaming-commons+ , unix+ , unordered-containers+ default-language: Haskell2010
+ src/Config.hs view
@@ -0,0 +1,166 @@+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Copyright (C) 2019 Bin Jin. All Rights Reserved.+{-# LANGUAGE OverloadedStrings #-}+module Config+( GlobalConfig(..)+, Config(..)+, getConfig+, IP(..)+, PortNumber+) where++import Control.Exception (SomeException, handle)+import Control.Monad (when)+import Data.Attoparsec.ByteString ((<?>))+import qualified Data.Attoparsec.ByteString as P+import qualified Data.Attoparsec.ByteString.Char8 as P8+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.IP (IP (..))+import Data.Maybe (catMaybes)+import Data.Streaming.Network (HostPreference)+import Data.String (fromString)+import qualified Network.DNS as DNS+import Network.Socket (PortNumber)+import Options.Applicative+import Text.Read (readMaybe)++data GlobalConfig = GlobalConfig+ { setUser :: Maybe String+ , localPort :: Maybe PortNumber+ , listenAddress :: Maybe HostPreference+ } deriving (Eq, Show)++data Config = Server (Maybe DNS.Domain) IP (Maybe PortNumber)+ | Address DNS.Domain IP+ | BogusNX IP+ deriving (Eq, Show)++getConfig :: IO (GlobalConfig, [Config])+getConfig = do+ (globalConfigs, configFiles, confs) <- execParser opts+ confs' <- concat <$> mapM readConfigFromFile configFiles+ return (globalConfigs, confs' ++ confs)+ where+ opts = info ((,,) <$> globalOption <*> configFileOption <*> plainOption <**> helper)+ ( fullDesc <> progDesc "a simple DNS proxy server")++ readConfigFromFile file = handle handler (parseConfigFile <$> BS.readFile file)++ handler :: SomeException -> IO [Config]+ handler _ = return []++parseConfigFile :: BS.ByteString -> [Config]+parseConfigFile bs = case P.parseOnly parseFile bs of+ Left msg -> error msg+ Right r -> r+ where+ skipSpaceTab = P.skipWhile P8.isHorizontalSpace++ parseFile = catMaybes <$> P.many' parseLine++ parseLine = do+ eof <- P.atEnd+ when eof $ fail "eof reached"+ skipSpaceTab+ (Just <$> parseConfig) <|> skipLine++ parseConfig =+ parsePair "server" serverValue <|>+ parsePair "address" addressValue <|>+ parsePair "bogus-nxdomain" bogusNXValue++ parsePair optionName optionValue = do+ _ <- P8.string optionName+ skipSpaceTab+ _ <- P8.char '='+ skipSpaceTab+ res <- optionValue+ _ <- skipLine+ return res++ skipLine = do+ P.skipWhile (not . P8.isEndOfLine)+ P.skipWhile P8.isEndOfLine+ return Nothing++domain :: P.Parser DNS.Domain+domain = P8.takeWhile1 (P8.inClass "-.a-zA-Z0-9") <?> "domain name"++ip :: P.Parser IP+ip = (<?> "IP address") $ do+ ipstr <- BS8.unpack <$> P8.takeWhile1 (P8.inClass "0-9.:")+ case readMaybe ipstr of+ Nothing -> fail ("invalid IP address: " ++ ipstr)+ Just ipaddr -> return ipaddr++port :: P.Parser PortNumber+port = read . BS8.unpack <$> P.takeWhile1 P8.isDigit_w8 <?> "Port Number"++globalOption :: Parser GlobalConfig+globalOption = GlobalConfig <$> userOption+ <*> portOption+ <*> listenOption+ where+ userOption = optional $ strOption+ ( long "user"+ <> short 'u'+ <> metavar "uid"+ <> help "set user id")++ portOption = optional $ option auto+ ( long "port"+ <> short 'p'+ <> metavar "port"+ <> help "listen on this port instead of 53")++ listenOption = optional $ fromString <$> strOption+ ( long "listen-address"+ <> short 'a'+ <> metavar "ipaddr"+ <> help "Listen on the given IP address")++configFileOption :: Parser [FilePath]+configFileOption = many $ strOption+ ( long "conf-file"+ <> short 'C'+ <> metavar "path/to/dprox.conf"+ <> help "configure file to read")++plainOption :: Parser [Config]+plainOption = (++) <$> many server <*> ((++) <$> many address <*> many bogusnx)+ where+ server = option (attoparsecReader serverValue)+ ( long "server"+ <> short 'S'+ <> metavar "[/domain/]ip[#port]"+ <> help "remote dns server ip")++ address = option (attoparsecReader addressValue)+ ( long "address"+ <> short 'A'+ <> metavar "/domain/ip"+ <> help "specifiy ip for target domain")++ bogusnx = option (attoparsecReader bogusNXValue)+ ( long "bogus-nxdomain"+ <> short 'B'+ <> metavar "ip"+ <> help "specify ip for no such domain blacklist")++attoparsecReader :: P.Parser a -> ReadM a+attoparsecReader p = eitherReader (P.parseOnly (p <* P.endOfInput) . BS8.pack)++serverValue :: P.Parser Config+serverValue = do+ parsedDomain <- P.option Nothing (Just <$> (P8.char '/' *> domain <* P8.char '/'))+ parsedIP <- ip+ parsedPort <- P.option Nothing (Just <$> (P8.char '#' *> port))+ return (Server parsedDomain parsedIP parsedPort)++addressValue :: P.Parser Config+addressValue = Address <$> (P8.char '/' *> domain <* P8.char '/') <*> ip++bogusNXValue :: P.Parser Config+bogusNXValue = BogusNX <$> ip
+ src/DomainRoute.hs view
@@ -0,0 +1,77 @@+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Copyright (C) 2019 Bin Jin. All Rights Reserved.+{-# LANGUAGE RecordWildCards #-}+module DomainRoute+( DomainRoute+, newDomainRoute+, getDomainRouteExact+, getDomainRouteByPrefix+) where++import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Short as SBS+import Data.Function (on)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.List (groupBy, sortOn, span)+import qualified Network.DNS as DNS++type DomainComp = SBS.ShortByteString++data DomainRoute a = DomainRoute+ { currentNode :: Maybe a+ , children :: Maybe (HashMap DomainComp (DomainRoute a))+ } deriving (Eq, Show)++instance Functor DomainRoute where+ fmap f DomainRoute{..} = DomainRoute (fmap f currentNode) ((fmap.fmap.fmap) f children)++instance Foldable DomainRoute where+ foldMap f DomainRoute{..} = foldMap f currentNode `mappend` (foldMap.foldMap.foldMap) f children++newDomainRoute :: (a -> a -> a) -> [(DNS.Domain, a)] -> DomainRoute a+newDomainRoute merge servers = go sortedServers+ where+ fmapFst f (x, y) = (f x, y)+ sortedServers = sortOn fst $ map (fmapFst getDomainComponents) servers++ go [] = DomainRoute Nothing Nothing+ go lst = DomainRoute node childs+ where+ (prefix, suffix) = span (null . fst) lst+ grouped = groupBy ((==) `on` (head.fst)) suffix++ node = if null prefix then Nothing else Just (foldr1 merge (map snd prefix))+ subtrees = [ (comp, go subtree)+ | child <- grouped+ , let comp = head (fst (head child))+ , let subtree = map (fmapFst tail) child+ ]+ childs = if null subtrees then Nothing else Just (HashMap.fromList subtrees)++queryDomainRoute :: Bool -> DomainRoute a -> DNS.Domain -> Maybe a+queryDomainRoute allowPrefix dr domain = go dr comps+ where+ comps = getDomainComponents domain++ placePrefix _ b | not allowPrefix = b+ placePrefix a Nothing = a+ placePrefix _ b = b++ go DomainRoute{..} [] = currentNode+ go (DomainRoute node Nothing) _ = placePrefix node Nothing+ go (DomainRoute node (Just child)) (x:xs) = placePrefix node $ case HashMap.lookup x child of+ Nothing -> Nothing+ Just subtree -> go subtree xs++getDomainRouteExact :: DomainRoute a -> DNS.Domain -> Maybe a+getDomainRouteExact = queryDomainRoute False++getDomainRouteByPrefix :: DomainRoute a -> DNS.Domain -> Maybe a+getDomainRouteByPrefix = queryDomainRoute True++getDomainComponents :: DNS.Domain -> [DomainComp]+getDomainComponents domain = reverse $ filter (not . SBS.null) comps+ where+ comps = map SBS.toShort $ BS8.split '.' (DNS.normalizeCase domain)
+ src/Main.hs view
@@ -0,0 +1,148 @@+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Copyright (C) 2019 Bin Jin. All Rights Reserved.+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Main where++import Control.Concurrent (forkIO)+import Control.Exception (SomeException, handle)+import Control.Monad (forM, forever)+import Data.ByteString (ByteString)+import qualified Data.Foldable as F+import Data.Map ((!))+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import qualified Data.Set as S+import Data.Streaming.Network (bindPortUDP)+import qualified Network.DNS as DNS+import Network.Socket.ByteString (recvFrom, sendTo)+import System.Posix.User (UserEntry (..), getUserEntryForName,+ setUserID)++import Config+import DomainRoute++type Resolver = DNS.Domain -> DNS.TYPE -> IO (Either DNS.DNSError [DNS.RData])++processQuery :: Resolver -> DNS.Question -> IO [DNS.ResourceRecord]+processQuery resolver (DNS.Question qd qt) = handle handler $ do+ res <- resolver qd qt+ case res of+ Left _ -> return []+ Right r -> return (map wrapper r)+ where+ handler :: SomeException -> IO [DNS.ResourceRecord]+ handler _ = return []++ wrapper :: DNS.RData -> DNS.ResourceRecord+ wrapper rdata = DNS.ResourceRecord qd (getType rdata) DNS.classIN 233 rdata++ getType :: DNS.RData -> DNS.TYPE+ getType DNS.RD_A{} = DNS.A+ getType DNS.RD_NS{} = DNS.NS+ getType DNS.RD_CNAME{} = DNS.CNAME+ getType DNS.RD_SOA{} = DNS.SOA+ getType DNS.RD_NULL{} = DNS.NULL+ getType DNS.RD_PTR{} = DNS.PTR+ getType DNS.RD_MX{} = DNS.MX+ getType DNS.RD_TXT{} = DNS.TXT+ getType DNS.RD_AAAA{} = DNS.AAAA+ getType _ = qt++processDNS :: Resolver -> ByteString -> IO (Either DNS.DNSError ByteString)+processDNS resolver bs+ | Left e <- parse = return (Left e)+ | Right q <- parse = do+ rrs <- mapM (processQuery resolver) (DNS.question q)+ let hd = DNS.header DNS.defaultResponse+ resp = DNS.defaultResponse {+ DNS.header = hd { DNS.identifier = DNS.identifier (DNS.header q) },+ DNS.question = DNS.question q,+ DNS.answer = concat rrs+ }+ return (Right (DNS.encode resp))+ where+ parse = do+ q <- DNS.decode bs+ if DNS.qOrR (DNS.flags (DNS.header q)) == DNS.QR_Query then return q else Left DNS.FormatError++handleServer :: DomainRoute Resolver -> Resolver+handleServer route qd = resolver qd+ where+ resolver = fromMaybe (error "handleServer: internal error") (getDomainRouteByPrefix route qd)++handleAddress :: DomainRoute [IP] -> Resolver -> Resolver+handleAddress route resolver qd qt =+ if null ips then resolver qd qt else return (Right userDefined)+ where+ ips = fromMaybe [] $ getDomainRouteByPrefix route qd+ ipv4 = [DNS.RD_A ipv4addr | IPv4 ipv4addr <- ips]+ ipv6 = [DNS.RD_AAAA ipv6addr | IPv6 ipv6addr <- ips]++ userDefined | qt == DNS.A = ipv4+ | qt == DNS.AAAA = ipv6+ | otherwise = []++handleBogusNX :: S.Set IP -> Resolver -> Resolver+handleBogusNX blacklist resolver qd qt =+ fmap (filter (not . isBlacklisted)) <$> resolver qd qt+ where+ isBlacklisted (DNS.RD_A ipv4) = IPv4 ipv4 `S.member` blacklist+ isBlacklisted (DNS.RD_AAAA ipv6) = IPv6 ipv6 `S.member` blacklist+ isBlacklisted _ = False++setuid :: String -> IO ()+setuid user = getUserEntryForName user >>= setUserID . userID++main :: IO ()+main = do+ (GlobalConfig{..}, conf) <- getConfig+ let defaultPort = 53+ fallbackServer = Server Nothing "8.8.8.8" Nothing++ server = [ (fromMaybe "" mDomain, (ip, fromMaybe defaultPort mPort))+ | Server mDomain ip mPort <- fallbackServer : conf+ ]+ address = [(domain, [ip]) | Address domain ip <- conf]+ bogusnx = [ip | BogusNX ip <- conf]++ serverRoute = newDomainRoute (flip const) server+ serverAddressSet = S.fromList $ F.toList serverRoute++ addressRoute = newDomainRoute (++) address++ bogusnxSet = S.fromList bogusnx++ resolvConfs = [ (addr, rc)+ | addr@(host, port) <- S.toList serverAddressSet+ , let rsinfo = if port == defaultPort+ then DNS.RCHostName (show host)+ else DNS.RCHostPort (show host) port+ , let rc = DNS.defaultResolvConf {+ DNS.resolvCache = Just DNS.defaultCacheConf,+ DNS.resolvInfo = rsinfo+ }+ ]++ sock <- bindPortUDP (fromIntegral $ fromMaybe defaultPort localPort) (fromMaybe "*6" listenAddress)+ resolvSeeds <- forM resolvConfs $ \(k, v) -> do+ rs <- DNS.makeResolvSeed v+ return (k, rs)++ F.mapM_ setuid setUser++ let processWithResolver resolver = forever $ do+ (bs, addr) <- recvFrom sock (fromIntegral DNS.maxUdpSize)+ forkIO $ do+ resp <- processDNS resolver bs+ F.forM_ resp $ \resp' -> sendTo sock resp' addr++ createResolvers ((k,v):xs) m = DNS.withResolver v $ \rs ->+ createResolvers xs (M.insert k (DNS.lookup rs) m)+ createResolvers [] m = let serverRoute' = fmap (m!) serverRoute+ resolver = handleBogusNX bogusnxSet $+ handleAddress addressRoute $+ handleServer serverRoute'+ in processWithResolver resolver+ createResolvers resolvSeeds M.empty
+ test/Test.hs view
@@ -0,0 +1,52 @@+-- SPDX-License-Identifier: BSD-3-Clause+--+-- Copyright (C) 2019 Bin Jin. All Rights Reserved.+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Monad (forM_)+import qualified Data.ByteString.Char8 as BS8+import Data.Char (toUpper)+import Test.Hspec++import DomainRoute++main :: IO ()+main = hspec $ do+ let query = BS8.count '.'+ build ds = [(domain, query domain) | domain <- ds]+ domains = ["cn", "chn.net", "red.com", "black.com", "www.red.com", "a.b.c.d.red.com"]+ dr1 = newDomainRoute const (build domains)++ describe "newDomainRoute" $ do+ let dr2 = newDomainRoute const (build domains ++ build domains)+ dr3 = newDomainRoute (flip const) (map (fmap (+1)) (build domains) ++ build domains)+ dr4 = newDomainRoute const (build (map (BS8.map toUpper) domains))+ it "handles duplicated domains" $+ dr1 `shouldBe` dr2++ it "handles duplicated domains with correct merge" $+ dr1 `shouldBe` dr3++ it "handles domains without case sensibility" $+ dr1 `shouldBe` dr4++ describe "getDomainRouteExact" $ do+ it "handles positive samples" $ forM_ domains $ \domain ->+ getDomainRouteExact dr1 domain `shouldBe` Just (query domain)++ it "handles negative samples" $ forM_ ["", "net", "com", "www.black.com"] $ \domain ->+ getDomainRouteExact dr1 domain `shouldBe` Nothing++ describe "getDomainRouteByPrefix" $ do+ it "handles positive samples" $ forM_ domains $ \domain ->+ getDomainRouteByPrefix dr1 domain `shouldBe` Just (query domain)++ it "handles positive samples with some new prefix" $ forM_ domains $ \domain ->+ getDomainRouteByPrefix dr1 ("prefix." `BS8.append` domain) `shouldBe` Just (query domain)++ it "handles negative samples" $ forM_ ["", "net", "com", "chn2.net"] $ \domain ->+ getDomainRouteByPrefix dr1 domain `shouldBe` Nothing++ it "handles the longest match" $ forM_ [("c.d.red.com", query "red.com"), ("www.a.b.c.d.red.com", query "a.b.c.d.red.com")] $ \(domain, ans) ->+ getDomainRouteByPrefix dr1 domain `shouldBe` Just ans