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

-- | name that the nameserver will run on
ourName :: ByteString
ourName = mkByteString "ns.fynngodau.de."

-- |
-- Nothing to bind anywhere (*:53)
-- recommended: set to your public IP address if running in parallel to a proper local resolver
bindAddress :: Maybe String
bindAddress = Just "2003:a:1525:3967::2"

bindPort :: String
bindPort = "53"

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
-- CONFIGURE UP TO HERE --

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, addrFlags = [AI_PASSIVE] }) bindAddress (Just bindPort)
  sckt <- openSocket addr
  bind sckt (addrAddress addr)
  putStrLn $ "Starting DNS server (listening on port " ++ bindPort ++ ")"
  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)