From 20021ec127c5574db472d88ff47cbf7e656969f4 Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 6 Jun 2009 13:32:14 +0900 Subject: [PATCH] Split commands off --- .gitignore | 1 + ClientMain.hs | 45 +--------------- DDNS/Client/MakeReq.hs | 49 +++++++++++++++++ DDNS/Server.hs | 82 ++++++++++++++++++++++++++++ DDNS/Server/EditZone.hs | 22 ++++++++ DDNS/Server/SignReq.hs | 46 ++++++++++++++++ DDNS/Utils.hs | 16 ++++++ DDNS/Zone.hs | 41 ++++++++++++++ GNUmakefile | 2 +- ServerMain.hs | 115 +++++----------------------------------- blackboard-dns.cabal | 9 +++- 11 files changed, 279 insertions(+), 149 deletions(-) create mode 100644 DDNS/Client/MakeReq.hs create mode 100644 DDNS/Server.hs create mode 100644 DDNS/Server/EditZone.hs create mode 100644 DDNS/Server/SignReq.hs create mode 100644 DDNS/Utils.hs create mode 100644 DDNS/Zone.hs diff --git a/.gitignore b/.gitignore index cebefa2..a48ef1e 100644 --- a/.gitignore +++ b/.gitignore @@ -14,3 +14,4 @@ data/GenDBModules *.req *.key *.pub +*.db diff --git a/ClientMain.hs b/ClientMain.hs index b96b430..e979b95 100644 --- a/ClientMain.hs +++ b/ClientMain.hs @@ -1,17 +1,9 @@ module Main where import Control.Monad -import Control.Monad.Trans +import DDNS.Client.MakeReq import OpenSSL -import OpenSSL.PEM -import OpenSSL.RSA -import OpenSSL.X509.Request -import System.Console.Haskeline import System.Console.ParseArgs -import System.IO -import System.Posix.Files -import System.Posix.Uname - data Options = Help @@ -45,38 +37,3 @@ main = withOpenSSL $ "makereq" -> makeReq _ -> usageError m "" - - -makeReq :: IO () -makeReq - = do fqdn <- runInputT defaultSettings $ - do defaultFqdn <- liftM uNodeName $ liftIO uname - fqdn <- getInputLine ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ") - case fqdn of - Just s@(_:_) -> return s - _ -> return defaultFqdn - - putStrLn "Generating RSA keypair..." - key <- generateRSAKey 1024 3 Nothing - - let pubFile = fqdn ++ ".pub" - withFile pubFile WriteMode $ \ h -> - writePublicKey key >>= hPutStr h - putStrLn ("Wrote " ++ pubFile) - - let keyFile = fqdn ++ ".key" - withFile keyFile WriteMode $ \ h -> - writePKCS8PrivateKey key Nothing >>= hPutStr h - setFileMode keyFile ownerReadMode - putStrLn ("Wrote " ++ keyFile ++ " (with no encryption)") - - req <- newX509Req - setVersion req 2 - setSubjectName req [("CN", fqdn)] - setPublicKey req key - signX509Req req key Nothing - let reqFile = fqdn ++ ".req" - withFile reqFile WriteMode $ \ h -> - writeX509Req req ReqNewFormat >>= hPutStr h - putStrLn ("Wrote " ++ reqFile) - putStrLn ("Now send " ++ reqFile ++ " to the server operator and tell him/her to sign it.") \ No newline at end of file diff --git a/DDNS/Client/MakeReq.hs b/DDNS/Client/MakeReq.hs new file mode 100644 index 0000000..b9baa49 --- /dev/null +++ b/DDNS/Client/MakeReq.hs @@ -0,0 +1,49 @@ +module DDNS.Client.MakeReq + ( makeReq + ) + where + +import Control.Monad +import Control.Monad.Trans +import DDNS.Utils +import OpenSSL.PEM +import OpenSSL.RSA +import OpenSSL.X509.Request +import System.Console.Haskeline +import System.IO +import System.Posix.Files +import System.Posix.Uname + +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 + + putStrLn "Generating RSA keypair..." + key <- generateRSAKey 1024 3 Nothing + + let pubFile = fqdn ++ ".pub" + withFile pubFile WriteMode $ \ h -> + writePublicKey key >>= hPutStr h + putStrLn ("Wrote " ++ pubFile) + + let keyFile = fqdn ++ ".key" + withFile keyFile WriteMode $ \ h -> + writePKCS8PrivateKey key Nothing >>= hPutStr h + setFileMode keyFile ownerReadMode + putStrLn ("Wrote " ++ keyFile ++ " (with no encryption)") + + req <- newX509Req + setVersion req 2 + setSubjectName req [("CN", fqdn)] + setPublicKey req key + signX509Req req key Nothing + let reqFile = fqdn ++ ".req" + withFile reqFile WriteMode $ \ h -> + writeX509Req req ReqNewFormat >>= hPutStr h + putStrLn ("Wrote " ++ reqFile) + putStrLn ("Now send " ++ reqFile ++ " to the server operator and tell him/her to sign it.") diff --git a/DDNS/Server.hs b/DDNS/Server.hs new file mode 100644 index 0000000..aedeadd --- /dev/null +++ b/DDNS/Server.hs @@ -0,0 +1,82 @@ +module DDNS.Server + ( ensureWeHaveKeypair + , ensureWeHaveDB + ) + where + +import Control.Monad +import Control.Monad.Trans +import DDNS.DBInfo +import DDNS.Utils +import Data.Time.Clock +import qualified Database.HDBC as RAW +import qualified Database.HDBC.Sqlite3 as RAW +import Database.HaskellDB +import Database.HaskellDB.DBSpec +import Database.HaskellDB.HDBC.SQLite3 +import OpenSSL.EVP.PKey +import OpenSSL.PEM +import OpenSSL.RSA +import OpenSSL.X509 as X509 +import System.Console.Haskeline +import System.Directory +import System.FilePath +import System.IO +import System.Posix.Files +import System.Posix.Uname + +ensureWeHaveKeypair :: FilePath -> IO (SomeKeyPair, X509) +ensureWeHaveKeypair lsdir + = do let keyFile = lsdir "server.key" + certFile = lsdir "server.cert" + keyExi <- doesFileExist keyFile + cerExi <- doesFileExist certFile + if keyExi && cerExi then + do key <- flip readPrivateKey PwNone =<< readFile keyFile + cert <- readX509 =<< readFile certFile + return (key, cert) + 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 + + putStrLn "Generating RSA keypair..." + key <- generateRSAKey 1024 3 Nothing + withFile keyFile WriteMode $ \ h -> + writePKCS8PrivateKey key Nothing >>= hPutStr h + setFileMode keyFile ownerReadMode + putStrLn ("Wrote " ++ keyFile) + + cert <- newX509 + X509.setVersion cert 2 + X509.setSerialNumber cert 1 + X509.setIssuerName cert [("CN", fqdn)] + X509.setSubjectName cert [("CN", fqdn)] + X509.setNotBefore cert =<< liftM (addUTCTime (-1)) getCurrentTime + X509.setNotAfter cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime + X509.setPublicKey cert key + X509.signX509 cert key Nothing + withFile certFile WriteMode $ \ h -> + writeX509 cert >>= hPutStr h + putStrLn ("Wrote " ++ certFile) + + return (fromKeyPair key, cert) + +type WithDB a = (Database -> IO a) -> IO a + +ensureWeHaveDB :: FilePath -> IO (WithDB a) +ensureWeHaveDB lsdir + = do let dbFile = lsdir "server.db" + dbExist <- doesFileExist dbFile + unless dbExist $ + do sqliteConnect dbFile $ \ db -> + dbSpecToDatabase db dbinfo + + rawCon <- RAW.connectSqlite3 dbFile + mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations + RAW.commit rawCon + RAW.disconnect rawCon + return $ sqliteConnect dbFile diff --git a/DDNS/Server/EditZone.hs b/DDNS/Server/EditZone.hs new file mode 100644 index 0000000..510d415 --- /dev/null +++ b/DDNS/Server/EditZone.hs @@ -0,0 +1,22 @@ +module DDNS.Server.EditZone + ( editZone + ) + where + +import Control.Monad +import Control.Monad.Trans +import DDNS.Utils +import DDNS.Zone +import Database.HaskellDB +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 () diff --git a/DDNS/Server/SignReq.hs b/DDNS/Server/SignReq.hs new file mode 100644 index 0000000..cfc4826 --- /dev/null +++ b/DDNS/Server/SignReq.hs @@ -0,0 +1,46 @@ +module DDNS.Server.SignReq + ( signReq + ) + where + +import Control.Monad +import Control.Monad.Trans +import DDNS.Utils +import Data.List +import Data.Time.Clock +import OpenSSL.EVP.PKey +import OpenSSL.EVP.Verify +import OpenSSL.PEM +import OpenSSL.X509 as X509 +import OpenSSL.X509.Request as Req +import System.Console.Haskeline +import System.FilePath +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' + key <- Req.getPublicKey req + vst <- verifyX509Req req key + unless (vst == VerifySuccess) + $ fail "Invalid X.509 request" + + cert <- makeX509FromReq req sCert + setSerialNumber cert 1 -- FIXME: This nasty behavior makes revocation-list unusable. + setNotBefore cert =<< liftM (addUTCTime (-1)) getCurrentTime + setNotAfter cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime + signX509 cert sKey Nothing + + 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 new file mode 100644 index 0000000..9c32824 --- /dev/null +++ b/DDNS/Utils.hs @@ -0,0 +1,16 @@ +module DDNS.Utils + ( trim + ) + where + +trim :: Maybe String -> Maybe String +trim Nothing = Nothing +trim (Just xs) = case trimTail $ trimHead xs of + "" -> Nothing + ys -> Just ys + where + trimHead [] = [] + trimHead (' ':ys) = trimHead ys + trimHead ys = ys + + trimTail = reverse . trimHead . reverse diff --git a/DDNS/Zone.hs b/DDNS/Zone.hs new file mode 100644 index 0000000..aca51e9 --- /dev/null +++ b/DDNS/Zone.hs @@ -0,0 +1,41 @@ +module DDNS.Zone + ( listZones + , completeZoneName + ) + where + +import Control.Monad +import Control.Monad.Trans +import Data.List +import Database.HaskellDB +import qualified DDNS.DB.Zones as Zones +import Network.DNS.Message +import System.Console.Haskeline + + +listZones :: Database -> IO [DomainName] +listZones db + = do rows <- query db $ do t <- table Zones.zones + project (Zones.zone << t!Zones.zone) + return $ map (read . (!Zones.zone)) rows + +completeZoneName :: MonadIO m => Database -> CompletionFunc m +completeZoneName db + = completeWord Nothing "" $ \ prefix -> + do zones <- liftM (map show) $ liftIO $ listZones db + return $ produceCands zones prefix + where + produceCands :: [String] -> String -> [Completion] + produceCands zones prefix + = let cands = filter (prefix `isPrefixOf`) zones + comps = map mkComp cands + in + comps + + mkComp :: String -> Completion + mkComp zn + = Completion { + replacement = zn + , display = zn + , isFinished = True + } diff --git a/GNUmakefile b/GNUmakefile index 1d9b6f8..6c7f474 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,4 +1,4 @@ -RUN_COMMAND = ./dist/build/bbdns-server/bbdns-server --localstatedir . signreq +RUN_COMMAND = ./dist/build/bbdns-server/bbdns-server --localstatedir . editzone #RUN_COMMAND = ./dist/build/bbdns-client/bbdns-client makereq include cabal-package.mk diff --git a/ServerMain.hs b/ServerMain.hs index 1e62fe7..d0a6b8d 100644 --- a/ServerMain.hs +++ b/ServerMain.hs @@ -2,30 +2,13 @@ module Main where import Control.Monad -import Control.Monad.Trans +import DDNS.Server +import DDNS.Server.EditZone +import DDNS.Server.SignReq import Data.List -import Data.Time.Clock -{- -import DDNS.DBInfo -import qualified Database.HDBC as RAW -import qualified Database.HDBC.Sqlite3 as RAW -import Database.HaskellDB.DBSpec -import Database.HaskellDB.HDBC.SQLite3 --} import OpenSSL -import OpenSSL.EVP.PKey -import OpenSSL.EVP.Verify -import OpenSSL.PEM -import OpenSSL.RSA -import OpenSSL.X509 as X509 -import OpenSSL.X509.Request as Req -import System.Console.Haskeline import System.Console.ParseArgs -import System.Directory -import System.FilePath import System.IO -import System.Posix.Files -import System.Posix.Uname data Options = Help @@ -90,86 +73,12 @@ main = withOpenSSL $ let lsdir = getRequiredArg m LSDir (key, cert) <- ensureWeHaveKeypair lsdir - - case getRequiredArg m Command of - "signreq" - -> signReq key cert - _ -> usageError m "" - -ensureWeHaveKeypair :: FilePath -> IO (SomeKeyPair, X509) -ensureWeHaveKeypair lsdir - = do let keyFile = lsdir "server.key" - certFile = lsdir "server.cert" - keyExi <- doesFileExist keyFile - cerExi <- doesFileExist certFile - if keyExi && cerExi then - do key <- flip readPrivateKey PwNone =<< readFile keyFile - cert <- readX509 =<< readFile certFile - return (key, cert) - else - do fqdn <- runInputT defaultSettings $ - do defaultFqdn <- liftM uNodeName $ liftIO uname - fqdn <- getInputLine ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ") - case fqdn of - Just s@(_:_) -> return s - _ -> return defaultFqdn - - putStrLn "Generating RSA keypair..." - key <- generateRSAKey 1024 3 Nothing - withFile keyFile WriteMode $ \ h -> - writePKCS8PrivateKey key Nothing >>= hPutStr h - setFileMode keyFile ownerReadMode - putStrLn ("Wrote " ++ keyFile) - - cert <- newX509 - X509.setVersion cert 2 - X509.setSerialNumber cert 1 - X509.setIssuerName cert [("CN", fqdn)] - X509.setSubjectName cert [("CN", fqdn)] - X509.setNotBefore cert =<< liftM (addUTCTime (-1)) getCurrentTime - X509.setNotAfter cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime - X509.setPublicKey cert key - X509.signX509 cert key Nothing - withFile certFile WriteMode $ \ h -> - writeX509 cert >>= hPutStr h - putStrLn ("Wrote " ++ certFile) - - return (fromKeyPair key, cert) - -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 file of - Just file'@(_:_) - -> liftIO $ - do req <- readX509Req =<< readFile file' - key <- Req.getPublicKey req - vst <- verifyX509Req req key - unless (vst == VerifySuccess) - $ fail "Invalid X.509 request" - - cert <- makeX509FromReq req sCert - setSerialNumber cert 1 -- FIXME: This nasty behavior makes revocation-list unusable. - setNotBefore cert =<< liftM (addUTCTime (-1)) getCurrentTime - setNotAfter cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime - signX509 cert sKey Nothing - - 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 () - -{- -main = do sqliteConnect "ddns.db" $ \ db -> - dbSpecToDatabase db dbinfo - - rawCon <- RAW.connectSqlite3 "ddns.db" - mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations - RAW.commit rawCon - RAW.disconnect rawCon --} \ No newline at end of file + withDB <- ensureWeHaveDB lsdir + + withDB $ \ db -> + case getRequiredArg m Command of + "signreq" + -> signReq key cert + "editzone" + -> editZone db + _ -> usageError m "" diff --git a/blackboard-dns.cabal b/blackboard-dns.cabal index 14afaa7..975e541 100644 --- a/blackboard-dns.cabal +++ b/blackboard-dns.cabal @@ -18,7 +18,7 @@ Extra-Source-Files: Executable bbdns-server Build-Depends: - HDBC, HDBC-sqlite3, base, directory, filepath, haskelldb, + HDBC, HDBC-sqlite3, base, directory, dns, filepath, haskelldb, haskelldb-hdbc-sqlite3, parseargs, time Other-Modules: @@ -26,6 +26,11 @@ Executable bbdns-server DDNS.DB.Records DDNS.DB.Zones DDNS.DBInfo + DDNS.Server + DDNS.Server.EditZone + DDNS.Server.SignReq + DDNS.Utils + DDNS.Zone Main-Is: ServerMain.hs @@ -39,6 +44,8 @@ Executable bbdns-client unix Other-Modules: + DDNS.Client.MakeReq + DDNS.Utils System.Posix.Uname Main-Is: -- 2.40.0