diff options
| -rw-r--r-- | .gitignore | 4 | ||||
| -rw-r--r-- | Config.hs | 20 | ||||
| -rw-r--r-- | Database.hs | 53 | ||||
| -rw-r--r-- | Makefile | 13 | ||||
| -rw-r--r-- | README.md | 22 | ||||
| -rw-r--r-- | loldns.cabal | 19 | ||||
| -rw-r--r-- | loldns.hs | 69 | ||||
| -rw-r--r-- | test.conf | 4 | ||||
| -rw-r--r-- | test.db | 22 |
9 files changed, 226 insertions, 0 deletions
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 <tv@krebsco.de> +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" + } @@ -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" + } + ] + } |