From d63a423abbfa2789024ddec4d3585d154610c958 Mon Sep 17 00:00:00 2001 From: tv Date: Fri, 4 Nov 2016 23:42:34 +0100 Subject: initial commit --- .gitignore | 4 ++++ Config.hs | 20 ++++++++++++++++++ Database.hs | 53 ++++++++++++++++++++++++++++++++++++++++++++++ Makefile | 13 ++++++++++++ README.md | 22 +++++++++++++++++++ loldns.cabal | 19 +++++++++++++++++ loldns.hs | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ test.conf | 4 ++++ test.db | 22 +++++++++++++++++++ 9 files changed, 226 insertions(+) create mode 100644 .gitignore create mode 100644 Config.hs create mode 100644 Database.hs create mode 100644 Makefile create mode 100644 README.md create mode 100644 loldns.cabal create mode 100644 loldns.hs create mode 100644 test.conf create mode 100644 test.db diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..fb7155a --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +*.hi +*.o +/result +/shell.nix diff --git a/Config.hs b/Config.hs new file mode 100644 index 0000000..1fb02a6 --- /dev/null +++ b/Config.hs @@ -0,0 +1,20 @@ +module Config + ( Config(..) + , readFile + ) + where + +import Prelude hiding (readFile) +import qualified Prelude (readFile) + +import Network.Socket + +data Config = Config + { bufSize :: Int + , port :: ServiceName + } + deriving (Read,Show) + +readFile :: FilePath -> IO Config +readFile path = + read <$> Prelude.readFile path diff --git a/Database.hs b/Database.hs new file mode 100644 index 0000000..87670c4 --- /dev/null +++ b/Database.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Database + ( Database(..) + , lookup + , readFile + ) + where + +import Prelude hiding (lookup,readFile) +import qualified Prelude (readFile) + +import Data.Data +import Data.IxSet.Typed +import Network.DNS.Types + +deriving instance Data OData +deriving instance Data Question +deriving instance Data RData +deriving instance Data ResourceRecord +deriving instance Data TYPE +deriving instance Ord Question +deriving instance Ord ResourceRecord +deriving instance Ord TYPE +deriving instance Read OData +deriving instance Read Question +deriving instance Read RData +deriving instance Read ResourceRecord + +type ResourceRecordIxs = '[Domain, TYPE] +type IxResourceRecord = IxSet ResourceRecordIxs ResourceRecord +data Database = Database + { recordSet :: IxResourceRecord + } + deriving (Read,Show) + +instance Indexable ResourceRecordIxs ResourceRecord where + indices = ixList + (ixGen (Proxy :: Proxy Domain)) + (ixGen (Proxy :: Proxy TYPE)) + +lookup :: Question -> Database -> [ResourceRecord] +lookup Question{..} (Database ix) = + toList (ix @= qname @= qtype) + +readFile :: FilePath -> IO Database +readFile path = + read <$> Prelude.readFile path diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..1411d73 --- /dev/null +++ b/Makefile @@ -0,0 +1,13 @@ +.PHONY: _default +_default: ghci + +.PHONY: ghci +ghci: shell.nix + nix-shell --command 'exec ghci -Wall -fobject-code' + +.PHONY: result +result: shell.nix + nix-build ./shell.nix + +shell.nix: $(wildcard *.cabal) + cabal2nix --shell . > $@ diff --git a/README.md b/README.md new file mode 100644 index 0000000..ed6c873 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +loldns +====== + +loldns is a toy DNS server. + +Dependencies +------------ + +- [Nix](http://nixos.org/nix/) +- [cabal2nix](https://github.com/NixOS/cabal2nix) +- [GNU Make](https://www.gnu.org/software/make/) :) + +# Run DNS server + + make result + result/bin/loldns test.conf test.db + +# Run DNS server in GHCi + + make ghci + :l loldns + withArgs ["test.conf","test.db"] main diff --git a/loldns.cabal b/loldns.cabal new file mode 100644 index 0000000..bd6c821 --- /dev/null +++ b/loldns.cabal @@ -0,0 +1,19 @@ +name: loldns +version: 1.0.0 +license: MIT +author: tv +maintainer: tv@krebsco.de +build-type: Simple +cabal-version: >=1.10 + +executable loldns + main-is: loldns.hs + build-depends: + base, + bytestring, + dns, + iproute, + ixset-typed, + network + default-language: Haskell2010 + ghc-options: -O2 -Wall -threaded diff --git a/loldns.hs b/loldns.hs new file mode 100644 index 0000000..81a1aa8 --- /dev/null +++ b/loldns.hs @@ -0,0 +1,69 @@ +module Main (main) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.Maybe +import Network.DNS.Decode +import Network.DNS.Encode +import Network.DNS.Types +import Network.Socket.ByteString (recvFrom,sendAllTo) +import Network.Socket hiding (recvFrom) +import System.Environment +import qualified Data.ByteString.Lazy as LBS + +import Database (Database) + +import qualified Config +import qualified Database + + +main :: IO () +main = do + [confPath,dbPath] <- getArgs + c <- Config.readFile "test.conf" + db <- Database.readFile "test.db" + addrinfos <- + getAddrInfo + (Just (defaultHints { addrFlags = [AI_PASSIVE] })) + Nothing + (Just (Config.port c)) + addrinfo <- maybe (fail "no addr info") return (listToMaybe addrinfos) + bracket + (socket (addrFamily addrinfo) Datagram defaultProtocol) + (close) + $ \sock -> do + bind sock (addrAddress addrinfo) + forever $ do + (s, addr) <- recvFrom sock (Config.bufSize c) + forkIO $ do + either + (putStrLn . ("decode error: " ++)) + (\req -> do + let res = handleRequest db req + sendAllTo sock (LBS.toStrict (encode res)) addr) + (decode (LBS.fromStrict s)) + +handleRequest :: Database -> DNSMessage -> DNSMessage +handleRequest db DNSMessage{question=qs,header=DNSHeader{identifier=i}} = + DNSMessage + { header = DNSHeader + { identifier = i + , flags = DNSFlags + { qOrR = QR_Response + , opcode = OP_STD + , authAnswer = True + , trunCation = False + , recDesired = True + , recAvailable = False + , rcode = if length as == 0 then NameErr else NoErr + , authenData = False + } + } + , question = qs + , answer = as + , authority = [] + , additional = [] + } + where + as = concatMap (flip Database.lookup db) qs diff --git a/test.conf b/test.conf new file mode 100644 index 0000000..f38627f --- /dev/null +++ b/test.conf @@ -0,0 +1,4 @@ +Config + { bufSize = 512 + , port = "20053" + } diff --git a/test.db b/test.db new file mode 100644 index 0000000..59a72ee --- /dev/null +++ b/test.db @@ -0,0 +1,22 @@ +Database + { recordSet = fromList + [ ResourceRecord + { rrname = "test.lol.local." + , rrtype = A + , rrttl = 300 + , rdata = RD_A 127.2.0.1 + } + , ResourceRecord + { rrname = "test.lol.local." + , rrtype = A + , rrttl = 300 + , rdata = RD_A 127.2.0.2 + } + , ResourceRecord + { rrname = "test.lol.local." + , rrtype = TXT + , rrttl = 300 + , rdata = RD_TXT "test" + } + ] + } -- cgit v1.2.3