diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dprox.cabal b/dprox.cabal new file mode 100644 --- /dev/null +++ b/dprox.cabal @@ -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 +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 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -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 diff --git a/src/DomainRoute.hs b/src/DomainRoute.hs new file mode 100644 --- /dev/null +++ b/src/DomainRoute.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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