DDNS/Zone.hs

   1 module DDNS.Zone
   2     ( listZones
   3     , completeZoneName
   4
   5     , getZone
   6     , putZone
   7     )
   8     where
   9
  10 import           Control.Monad
  11 import           Control.Monad.Trans
  12 import           Data.List
  13 import           Database.HaskellDB as DB
  14 import qualified DDNS.DB.Zones as Zones
  15 import           Network.DNS.Message
  16 import           System.Console.Haskeline
  17
  18
  19 listZones :: Database -> IO [DomainName]
  20 listZones db
  21     = do rows <- query db $ do t <- table Zones.zones
  22                                project (Zones.zone << t!Zones.zone)
  23          return $ map (read . (!Zones.zone)) rows
  24
  25 completeZoneName :: MonadIO m => Database -> CompletionFunc m
  26 completeZoneName db
  27     = completeWord Nothing "" $ \ prefix ->
  28       do zones <- liftM (map show) $ liftIO $ listZones db
  29          return $ produceCands zones prefix
  30     where
  31       produceCands :: [String] -> String -> [Completion]
  32       produceCands zones prefix
  33           = let cands = filter (prefix `isPrefixOf`) zones
  34                 comps = map mkComp cands
  35             in
  36               comps
  37
  38       mkComp :: String -> Completion
  39       mkComp zn
  40           = Completion {
  41               replacement = zn
  42             , display     = zn
  43             , isFinished  = True
  44             }
  45
  46 getZone :: Database -> DomainName -> IO (Maybe SOAFields)
  47 getZone db name
  48     = do rows <- query db $
  49                  do t <- table Zones.zones
  50                     restrict (t!Zones.zone .==. constant (show name))
  51                     return t
  52          case rows of
  53            [r] -> return $ Just SOAFields {
  54                      soaMasterNameServer   = read $ r!Zones.ns
  55                    , soaResponsibleMailbox = read $ r!Zones.owner
  56                    , soaSerialNumber       = fromIntegral $ r!Zones.serial
  57                    , soaRefreshInterval    = fromIntegral $ r!Zones.refresh
  58                    , soaRetryInterval      = fromIntegral $ r!Zones.retry
  59                    , soaExpirationLimit    = fromIntegral $ r!Zones.expire
  60                    , soaMinimumTTL         = fromIntegral $ r!Zones.minTTL
  61                    }
  62            _   -> return Nothing
  63
  64 putZone :: Database -> DomainName -> SOAFields -> IO ()
  65 putZone db name soa
  66     = transaction db $
  67       do old <- getZone db name
  68          case old of
  69            Just old'
  70                -> if soaSerialNumber old' == soaSerialNumber soa - 1 then
  71                       -- Succeeded at optimistic locking
  72                       updateZone
  73                   else
  74                       fail "putZone: detected a conflict. please retry it."
  75            Nothing
  76                -> insertZone
  77     where
  78       updateZone
  79           = DB.update db Zones.zones
  80             (\ r -> r!Zones.zone .==. constant (show name))
  81             (\ _ -> Zones.ns      << constant (show $ soaMasterNameServer        soa) #
  82                     Zones.owner   << constant (show $ soaResponsibleMailbox      soa) #
  83                     Zones.serial  << constant (fromIntegral $ soaSerialNumber    soa) #
  84                     Zones.refresh << constant (fromIntegral $ soaRefreshInterval soa) #
  85                     Zones.retry   << constant (fromIntegral $ soaRetryInterval   soa) #
  86                     Zones.expire  << constant (fromIntegral $ soaExpirationLimit soa) #
  87                     Zones.minTTL  << constant (fromIntegral $ soaMinimumTTL      soa) )
  88
  89       insertZone
  90           = DB.insert db Zones.zones
  91             ( Zones.zone    <<- show name                             #
  92               Zones.ns      <<- show (soaMasterNameServer        soa) #
  93               Zones.owner   <<- show (soaResponsibleMailbox      soa) #
  94               Zones.serial  <<- fromIntegral (soaSerialNumber    soa) #
  95               Zones.refresh <<- fromIntegral (soaRefreshInterval soa) #
  96               Zones.retry   <<- fromIntegral (soaRetryInterval   soa) #
  97               Zones.expire  <<- fromIntegral (soaExpirationLimit soa) #
  98               Zones.minTTL  <<- fromIntegral (soaMinimumTTL      soa) )