editzone

diff --git a/DDNS/Server.hs b/DDNS/Server.hs
index c1e85407ac6c7e84429f861becead021f5ad6db2..ef40f59a92acad678bf4901a46c10e8d83fb9ab0 100644 (file)
--- 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 44120ebaca7168248752e38defeae6496ea896a4..bd62568b014f732f7e5fb81a09c0368fc52bd8ba 100644 (file)
--- 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 b1b5687b674dece01e91071cbbfecf9c19e2481b..e0ef4035ec85e7ef1688afe17f8f6d35fcad8007 100644 (file)
--- 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 e5d4af519a3ef2ed485f958324366f1d1a76f839..c4207a3c6aec4ce60221fd80e6850b74763bbe06 100644 (file)
--- 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) )