From 1abf9ad51c79257c0bce8e134fdd48a2ff0ef373 Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 6 Jun 2009 14:31:11 +0900 Subject: [PATCH] Code cleanup --- DDNS/Client/MakeReq.hs | 7 +++---- DDNS/Server.hs | 7 +++---- DDNS/Server/EditZone.hs | 14 +++++--------- DDNS/Server/SignReq.hs | 10 +++------- DDNS/Utils.hs | 19 +++++++++++++++++++ DDNS/Zone.hs | 20 ++++++++++++++++++++ 6 files changed, 53 insertions(+), 24 deletions(-) diff --git a/DDNS/Client/MakeReq.hs b/DDNS/Client/MakeReq.hs index b9baa49..5714044 100644 --- a/DDNS/Client/MakeReq.hs +++ b/DDNS/Client/MakeReq.hs @@ -18,10 +18,9 @@ makeReq :: IO () makeReq = do fqdn <- runInputT defaultSettings $ do defaultFqdn <- liftM uNodeName $ liftIO uname - fqdn <- getInputLine ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ") - case trim fqdn of - Just s -> return s - _ -> return defaultFqdn + getInputLineWithDefault + ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ") + defaultFqdn putStrLn "Generating RSA keypair..." key <- generateRSAKey 1024 3 Nothing diff --git a/DDNS/Server.hs b/DDNS/Server.hs index aedeadd..c1e8540 100644 --- a/DDNS/Server.hs +++ b/DDNS/Server.hs @@ -38,10 +38,9 @@ ensureWeHaveKeypair lsdir else do fqdn <- runInputT defaultSettings $ do defaultFqdn <- liftM uNodeName $ liftIO uname - fqdn <- getInputLine ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ") - case trim fqdn of - Just s -> return s - _ -> return defaultFqdn + getInputLineWithDefault + ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ") + defaultFqdn putStrLn "Generating RSA keypair..." key <- generateRSAKey 1024 3 Nothing diff --git a/DDNS/Server/EditZone.hs b/DDNS/Server/EditZone.hs index 510d415..44120eb 100644 --- a/DDNS/Server/EditZone.hs +++ b/DDNS/Server/EditZone.hs @@ -4,7 +4,6 @@ module DDNS.Server.EditZone where import Control.Monad -import Control.Monad.Trans import DDNS.Utils import DDNS.Zone import Database.HaskellDB @@ -12,11 +11,8 @@ import System.Console.Haskeline editZone :: Database -> IO () editZone db - = runInputT (setComplete (completeZoneName db) defaultSettings) $ - do zoneNameStr <- getInputLine "Which zone do you want to edit (or create?): " - case trim zoneNameStr of - Just zoneNameStr' - -> liftIO $ - do --let zone = read zoneNameStr' - fail zoneNameStr' - _ -> return () + = 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 diff --git a/DDNS/Server/SignReq.hs b/DDNS/Server/SignReq.hs index cfc4826..6bcfeff 100644 --- a/DDNS/Server/SignReq.hs +++ b/DDNS/Server/SignReq.hs @@ -20,11 +20,8 @@ import System.IO signReq :: KeyPair k => k -> X509 -> IO () signReq sKey sCert = runInputT (setComplete completeFilename defaultSettings) $ - do file <- getInputLine "Which X.509 request do you want to sign?: " - case trim file of - Just file' - -> liftIO $ - do req <- readX509Req =<< readFile file' + do file <- getInputLine' "Which X.509 request do you want to sign?: " + liftIO $ do req <- readX509Req =<< readFile file key <- Req.getPublicKey req vst <- verifyX509Req req key unless (vst == VerifySuccess) @@ -36,11 +33,10 @@ signReq sKey sCert setNotAfter cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime signX509 cert sKey Nothing - let certFile = file' `replaceExtension` ".cert" + let certFile = file `replaceExtension` ".cert" withFile certFile WriteMode $ \ h -> writeX509 cert >>= hPutStr h putStrLn ("Wrote " ++ certFile) Just (_, fqdn) <- liftM (find ((== "CN") . fst)) $ X509.getSubjectName cert False putStrLn ("Now send " ++ certFile ++ " back to " ++ fqdn ++ ".") - _ -> return () diff --git a/DDNS/Utils.hs b/DDNS/Utils.hs index 9c32824..b1b5687 100644 --- a/DDNS/Utils.hs +++ b/DDNS/Utils.hs @@ -1,8 +1,13 @@ module DDNS.Utils ( trim + , getInputLine' + , getInputLineWithDefault ) where +import System.Console.Haskeline + + trim :: Maybe String -> Maybe String trim Nothing = Nothing trim (Just xs) = case trimTail $ trimHead xs of @@ -14,3 +19,17 @@ trim (Just xs) = case trimTail $ trimHead xs of trimHead ys = ys trimTail = reverse . trimHead . reverse + +getInputLine' :: MonadException m => String -> InputT m String +getInputLine' prompt + = do ret <- getInputLine prompt + case trim ret of + Just ret' -> return ret' + Nothing -> fail "No input" + +getInputLineWithDefault :: MonadException m => String -> String -> InputT m String +getInputLineWithDefault prompt defaultStr + = do ret <- getInputLine prompt + case trim ret of + Just ret' -> return ret' + Nothing -> return defaultStr diff --git a/DDNS/Zone.hs b/DDNS/Zone.hs index aca51e9..e5d4af5 100644 --- a/DDNS/Zone.hs +++ b/DDNS/Zone.hs @@ -1,6 +1,8 @@ module DDNS.Zone ( listZones , completeZoneName + + , getZone ) where @@ -39,3 +41,21 @@ 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 \ No newline at end of file -- 2.40.0