initial commitHEADv1.0.0ni/mastermaster

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"
+  }
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"
+      }
+    ]
+  }