module DDNS.Zone
    ( listZones
    , completeZoneName

    , getZone
    , putZone
    )
    where

import           Control.Monad
import           Control.Monad.Trans
import           Data.List
import           Database.HaskellDB as DB
import qualified DDNS.DB.Zones as Zones
import           Network.DNS.Message
import           System.Console.Haskeline


listZones :: Database -> IO [DomainName]
listZones db
    = do rows <- query db $ do t <- table Zones.zones
                               project (Zones.zone << t!Zones.zone)
         return $ map (read . (!Zones.zone)) rows

completeZoneName :: MonadIO m => Database -> CompletionFunc m
completeZoneName db
    = completeWord Nothing "" $ \ prefix ->
      do zones <- liftM (map show) $ liftIO $ listZones db
         return $ produceCands zones prefix
    where
      produceCands :: [String] -> String -> [Completion]
      produceCands zones prefix
          = let cands = filter (prefix `isPrefixOf`) zones
                comps = map mkComp cands
            in
              comps

      mkComp :: String -> Completion
      mkComp zn
          = Completion {
              replacement = zn
            , display     = zn
            , isFinished  = True
            }

getZone :: Database -> DomainName -> IO (Maybe SOAFields)
getZone db name
    = do rows <- query db $
                 do t <- table Zones.zones
                    restrict (t!Zones.zone .==. constant (show name))
                    return t
         case rows of
           [r] -> return $ Just SOAFields {
                     soaMasterNameServer   = read $ r!Zones.ns
                   , soaResponsibleMailbox = read $ r!Zones.owner
                   , soaSerialNumber       = fromIntegral $ r!Zones.serial
                   , soaRefreshInterval    = fromIntegral $ r!Zones.refresh
                   , soaRetryInterval      = fromIntegral $ r!Zones.retry
                   , soaExpirationLimit    = fromIntegral $ r!Zones.expire
                   , soaMinimumTTL         = fromIntegral $ r!Zones.minTTL
                   }
           _   -> return Nothing

putZone :: Database -> DomainName -> SOAFields -> IO ()
putZone db name soa
    = transaction db $
      do old <- getZone db name
         case old of
           Just old'
               -> if soaSerialNumber old' == soaSerialNumber soa - 1 then
                      -- Succeeded at optimistic locking
                      updateZone
                  else
                      fail "putZone: detected a conflict. please retry it."
           Nothing
               -> insertZone
    where
      updateZone
          = DB.update db Zones.zones
            (\ r -> r!Zones.zone .==. constant (show name))
            (\ _ -> Zones.ns      << constant (show $ soaMasterNameServer        soa) #
                    Zones.owner   << constant (show $ soaResponsibleMailbox      soa) #
                    Zones.serial  << constant (fromIntegral $ soaSerialNumber    soa) #
                    Zones.refresh << constant (fromIntegral $ soaRefreshInterval soa) #
                    Zones.retry   << constant (fromIntegral $ soaRetryInterval   soa) #
                    Zones.expire  << constant (fromIntegral $ soaExpirationLimit soa) #
                    Zones.minTTL  << constant (fromIntegral $ soaMinimumTTL      soa) )

      insertZone
          = DB.insert db Zones.zones
            ( Zones.zone    <<- show name                             #
              Zones.ns      <<- show (soaMasterNameServer        soa) #
              Zones.owner   <<- show (soaResponsibleMailbox      soa) #
              Zones.serial  <<- fromIntegral (soaSerialNumber    soa) #
              Zones.refresh <<- fromIntegral (soaRefreshInterval soa) #
              Zones.retry   <<- fromIntegral (soaRetryInterval   soa) #
              Zones.expire  <<- fromIntegral (soaExpirationLimit soa) #
              Zones.minTTL  <<- fromIntegral (soaMinimumTTL      soa) )