bahnhof-dns: new application

* New executable `bahnhof-dns`, which serves TXT records over DNS
  at `*.ril100.` and `*.leitpunkt.`
* Extract definitions used by both executables into new Util module

(slightly amended by stuebinm)

1 files changed, 59 insertions, 0 deletions

diff --git a/app/BahnhofDNS.hs b/app/BahnhofDNS.hs
new file mode 100644
index 0000000..2111aa0
--- /dev/null
+++ b/app/BahnhofDNS.hs
@@ -0,0 +1,59 @@
+
+module Main where
+
+import           Data.ByteString
+import           Data.Text
+import           Data.Text.Encoding as TSE
+import           Network.DNS
+import           Network.Socket
+import           Util
+
+main :: IO ()
+main = do -- general structure like sample code at https://book.realworldhaskell.org/read/sockets-and-syslog.html (for UDP server)
+  staticData <- readData
+  addr : _ <- getAddrInfo (Just defaultHints { addrSocketType = Datagram, addrFamily = AF_INET6, addrFlags = [AI_PASSIVE] }) Nothing (Just "5300")
+  sckt <- openSocket addr
+  bind sckt (addrAddress addr)
+  putStrLn "Starting DNS server (listening on port 5300)"
+  procMessages staticData sckt
+  where
+    procMessages staticData sckt = do
+      (m,ad) <- receiveFrom sckt -- Network.DNS
+
+      sendTo sckt (response m) ad
+      procMessages staticData sckt
+      where
+        response m = encode $ case (question m) of
+          (Question qh TXT) : _ -> queryAnswer (uid m) qh
+          _                     -> m -- ping back question without answering it
+                                     -- no other way to generate empty responses without providing a question in this library?
+
+        queryAnswer oid qh = case maybeAnswer qh of
+          Just answer -> responseTXT   oid (Question qh TXT) (TSE.encodeUtf8 answer)
+          Nothing     -> responseEmpty oid (Question qh TXT)
+
+        uid msg = identifier (header msg)
+        maybeAnswer qh = case queryFromQuestionHead qh of
+          (q, "RIL100")    -> lookupCode (Ril100 q) (ril100map staticData)
+          (q, "LEITPUNKT") -> lookupName q (leitpunktMap staticData)
+                              >>= (`lookupCode` (ril100map staticData))
+          (_, _) -> Nothing
+
+queryFromQuestionHead :: ByteString -> (Text, String)
+queryFromQuestionHead q = case splt of
+  quest : questType : _ -- here we could add enforcement that we only query the intended namespace and not arbitrary subspaces (nsst.ril100.a.b.c.d.e.…)
+    -> (quest, Data.Text.unpack questType)
+  _                     -> (Data.Text.empty, "") -- side question: is a query without a dot even a legal DNS query?
+  where
+    splt = splitOn dot (toUpper $ TSE.decodeUtf8 q)
+    dot = Data.Text.pack "."
+
+responseEmpty :: Identifier -> Question -> DNSMessage
+responseEmpty idt q = makeResponse idt q []
+
+responseTXT :: Identifier -> Question -> ByteString -> DNSMessage
+responseTXT idt q txt = makeResponse idt q [ans]
+  where
+    dom = qname q
+    ans = ResourceRecord dom TXT classIN 604800 (RD_TXT txt)
+