editzone

[blackboard-dns.git] / DDNS / Zone.hs

diff --git a/DDNS/Zone.hs b/DDNS/Zone.hs
index aca51e9b4c8b7cfafe69ae90801e5d81b9a49ab4..c4207a3c6aec4ce60221fd80e6850b74763bbe06 100644 (file)
--- a/DDNS/Zone.hs
+++ b/DDNS/Zone.hs
@@ -1,13 +1,16 @@
 module DDNS.Zone
     ( listZones
     , 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
@@ -39,3 +42,57 @@ completeZoneName db
             , 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) )