blob: 2111aa0171d76565eda5811b35c300c166578570 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
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)
|
