From 22ba80d23ad59661c90bd5a77305b16c417b153b Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 6 Jun 2009 15:53:59 +0900 Subject: [PATCH] editzone --- DDNS/Server.hs | 2 +- DDNS/Server/EditZone.hs | 49 ++++++++++++++++++++++++++++++++++++----- DDNS/Utils.hs | 14 ++++++++++++ DDNS/Zone.hs | 41 ++++++++++++++++++++++++++++++++-- 4 files changed, 98 insertions(+), 8 deletions(-) diff --git a/DDNS/Server.hs b/DDNS/Server.hs index c1e8540..ef40f59 100644 --- a/DDNS/Server.hs +++ b/DDNS/Server.hs @@ -39,7 +39,7 @@ ensureWeHaveKeypair lsdir do fqdn <- runInputT defaultSettings $ do defaultFqdn <- liftM uNodeName $ liftIO uname getInputLineWithDefault - ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ") + ("What is the server FQDN? (default: " ++ defaultFqdn ++ "): ") defaultFqdn putStrLn "Generating RSA keypair..." diff --git a/DDNS/Server/EditZone.hs b/DDNS/Server/EditZone.hs index 44120eb..bd62568 100644 --- a/DDNS/Server/EditZone.hs +++ b/DDNS/Server/EditZone.hs @@ -3,16 +3,55 @@ module DDNS.Server.EditZone ) where -import Control.Monad import DDNS.Utils import DDNS.Zone import Database.HaskellDB +import Data.Maybe +import Network.DNS.Message import System.Console.Haskeline editZone :: Database -> IO () editZone db = do zone <- runInputT (setComplete (completeZoneName db) defaultSettings) $ - do name <- getInputLine' "Which zone do you want to edit (or create?): " - return $ read name - soa <- getZone db zone - print soa + readInputLine' "Which zone do you want to edit (or create?): " + soa <- getZone db zone + ns <- let d = fromMaybe (read $ "ns." ++ show zone) $ fmap soaMasterNameServer soa + in runInputT defaultSettings $ + readInputLineWithDefault + ("Which host is the master name server? (default: " ++ show d ++ "): ") + d + mail <- let d = fromMaybe (read $ "root." ++ show ns) $ fmap soaResponsibleMailbox soa + in runInputT defaultSettings $ + readInputLineWithDefault + ("Which is the mailbox of responsibility? (default: " ++ show d ++ "): ") + d + refr <- let d = fromIntegral $ fromMaybe 3600 $ fmap soaRefreshInterval soa + in runInputT defaultSettings $ + readInputLineWithDefault + ("How many seconds should refresh interval be? (default: " ++ show d ++ "): ") + d + retr <- let d = fromIntegral $ fromMaybe 900 $ fmap soaRetryInterval soa + in runInputT defaultSettings $ + readInputLineWithDefault + ("How many seconds should retry interval be? (default: " ++ show d ++ "): ") + d + expi <- let d = fromIntegral $ fromMaybe 604800 $ fmap soaExpirationLimit soa + in runInputT defaultSettings $ + readInputLineWithDefault + ("How many seconds should expiration limit be? (default: " ++ show d ++ "): ") + d + mint <- let d = fromIntegral $ fromMaybe 3600 $ fmap soaExpirationLimit soa + in runInputT defaultSettings $ + readInputLineWithDefault + ("How many seconds should minimum TTL be? (default: " ++ show d ++ "): ") + d + let soa' = SOAFields { + soaMasterNameServer = ns + , soaResponsibleMailbox = mail + , soaSerialNumber = fromMaybe 0 $ fmap ((+1) . soaSerialNumber) soa + , soaRefreshInterval = refr + , soaRetryInterval = retr + , soaExpirationLimit = expi + , soaMinimumTTL = mint + } + putZone db zone soa' diff --git a/DDNS/Utils.hs b/DDNS/Utils.hs index b1b5687..e0ef403 100644 --- a/DDNS/Utils.hs +++ b/DDNS/Utils.hs @@ -2,9 +2,12 @@ module DDNS.Utils ( trim , getInputLine' , getInputLineWithDefault + , readInputLine' + , readInputLineWithDefault ) where +import Control.Monad import System.Console.Haskeline @@ -33,3 +36,14 @@ getInputLineWithDefault prompt defaultStr case trim ret of Just ret' -> return ret' Nothing -> return defaultStr + + +readInputLine' :: (MonadException m, Read r) => String -> InputT m r +readInputLine' = liftM read . getInputLine' + +readInputLineWithDefault :: (MonadException m, Read r) => String -> r -> InputT m r +readInputLineWithDefault prompt defaultValue + = do ret <- getInputLine prompt + case trim ret of + Just ret' -> return $ read ret' + Nothing -> return defaultValue \ No newline at end of file diff --git a/DDNS/Zone.hs b/DDNS/Zone.hs index e5d4af5..c4207a3 100644 --- a/DDNS/Zone.hs +++ b/DDNS/Zone.hs @@ -3,13 +3,14 @@ module DDNS.Zone , completeZoneName , getZone + , putZone ) where import Control.Monad import Control.Monad.Trans import Data.List -import Database.HaskellDB +import Database.HaskellDB as DB import qualified DDNS.DB.Zones as Zones import Network.DNS.Message import System.Console.Haskeline @@ -58,4 +59,40 @@ getZone db name , soaExpirationLimit = fromIntegral $ r!Zones.expire , soaMinimumTTL = fromIntegral $ r!Zones.minTTL } - _ -> return Nothing \ No newline at end of file + _ -> 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) ) -- 2.40.0