blob: 1b06dc1cf82bf30acf4221a2f3f6a26349b8f4f9 (
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
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
module Main where
import Data.ByteString
import Data.Text
import Data.Text.Encoding as TSE
import Network.DNS
import Network.Socket
import Util
mkByteString :: String -> ByteString
mkByteString = TSE.encodeUtf8 . Data.Text.pack
ourName :: ByteString
ourName = mkByteString "ns.fynngodau.de."
servedName :: ByteString
servedName = mkByteString "bahnhof.fynngodau.de."
soa :: ResourceRecord
soa = ResourceRecord servedName SOA classIN 86400 $ RD_SOA
ourName -- mname
(mkByteString "ns@fynngodau.de") -- rname
2025122800 -- serial
86400 -- refresh
7200 -- retry
3600000 -- expire
3600 -- minttl
ns :: ResourceRecord
ns = ResourceRecord servedName NS classIN 86400 $ RD_NS ourName
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
-- putStrLn $ show (question m)
sendTo sckt (response m) ad
procMessages staticData sckt
where
response m = encode $ case (question m) of
(Question qh TXT) : _ -> queryAnswer (uid m) qh
(Question qh SOA) : _
| qh == servedName -> makeResponse (uid m) (Question servedName SOA) [soa]
| otherwise -> m
(Question qh NS ) : _
| qh == servedName -> makeResponse (uid m) (Question servedName NS ) [ns ]
| otherwise -> m
_ -> 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)
|
