module Network.DNS.Named
    ( ZoneFinder(..)
    , Zone(..)

    , runNamed

    , defaultRootZone
    )
    where

import           Control.Concurrent
import           Control.Exception
import           Control.Monad
import           Data.Binary
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import           Data.Maybe
import           Network.Socket
import qualified Network.Socket.ByteString as NB
import           Network.DNS.Message
import           Network.DNS.Named.Config
import           System.Posix.Signals


class ZoneFinder a where
    findZone :: a -> DomainName -> IO Zone

instance ZoneFinder (DomainName -> Zone) where
    findZone = (return .)

instance ZoneFinder (DomainName -> IO Zone) where
    findZone = id

instance ZoneFinder (DomainName -> Maybe Zone) where
    findZone = ((return . fromMaybe defaultRootZone) .)

instance ZoneFinder (DomainName -> IO (Maybe Zone)) where
    findZone = (fmap (fromMaybe defaultRootZone) .)


data Zone
    = Zone {
        zoneName :: !DomainName
      }

defaultRootZone :: Zone
defaultRootZone = error "FIXME: defaultRootZone is not implemented yet"


runNamed :: ZoneFinder zf => Config -> zf -> IO ()
runNamed cnf zf
    = withSocketsDo $
      do installHandler sigPIPE Ignore Nothing
         _tcpListenerTID <- forkIO $ tcpListen
         udpListen
    where
      udpListen :: IO ()
      udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
                     so <- socket AF_INET Datagram defaultProtocol
                     print cnf
                     bindSocket so $ cnfServerAddress cnf
                     udpLoop so

      udpLoop :: Socket -> IO ()
      udpLoop so
          = do (packet, cameFrom) <- NB.recvFrom so 512
               _handlerTID <- forkIO $ udpHandler so packet cameFrom
               udpLoop so

      tcpListen :: IO ()
      tcpListen = putStrLn "FIXME: tcpListen is not implemented yet."

      udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
      udpHandler so packet cameFrom
          = do msg   <- evaluate $ unpackMessage packet
               msg'  <- handleMessage msg
                        `onException`
                        NB.sendTo so (packMessage $ makeServerFailure msg) cameFrom
               _sent <- NB.sendTo so (packMessage $ msg'                 ) cameFrom
               return ()

      handleMessage :: Message -> IO Message
      handleMessage msg
          = fail (show msg) -- FIXME


packMessage :: Message -> BS.ByteString
packMessage = BS.concat . LBS.toChunks . encode

unpackMessage :: BS.ByteString -> Message
unpackMessage = decode . LBS.fromChunks . return


makeServerFailure :: Message -> Message
makeServerFailure msg
    = let header = msgHeader msg
          msg'   = msg {
                     msgHeader = header {
                                   hdMessageType           = Response
                                 , hdIsAuthoritativeAnswer = False
                                 , hdIsTruncated           = False
                                 , hdIsRecursionAvailable  = False
                                 , hdResponseCode          = ServerFailure
                                 }
                   }
      in
        msg'