From 3674500cd498050a48d69d1d30a6139ba3ba88f5 Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 6 Jun 2009 11:01:40 +0900 Subject: [PATCH] signreq --- .gitignore | 7 +++- ClientMain.hs | 5 ++- GNUmakefile | 4 +- ServerMain.hs | 95 +++++++++++++++++++++++++++++++++++++++++++- blackboard-dns.cabal | 4 +- 5 files changed, 106 insertions(+), 9 deletions(-) diff --git a/.gitignore b/.gitignore index e38f235..cebefa2 100644 --- a/.gitignore +++ b/.gitignore @@ -8,4 +8,9 @@ data/GenDBModules *.cache *.log *.status -*.buildinfo \ No newline at end of file +*.buildinfo + +*.cert +*.req +*.key +*.pub diff --git a/ClientMain.hs b/ClientMain.hs index b3090b3..b96b430 100644 --- a/ClientMain.hs +++ b/ClientMain.hs @@ -56,7 +56,7 @@ makeReq Just s@(_:_) -> return s _ -> return defaultFqdn - putStrLn "Generating keypair..." + putStrLn "Generating RSA keypair..." key <- generateRSAKey 1024 3 Nothing let pubFile = fqdn ++ ".pub" @@ -67,13 +67,14 @@ makeReq let keyFile = fqdn ++ ".key" withFile keyFile WriteMode $ \ h -> writePKCS8PrivateKey key Nothing >>= hPutStr h - setFileMode keyFile (ownerReadMode `unionFileModes` ownerWriteMode) + 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 diff --git a/GNUmakefile b/GNUmakefile index b3350fe..1d9b6f8 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,5 +1,5 @@ -#RUN_COMMAND = ./dist/build/bbdns-server/bbdns-server -RUN_COMMAND = ./dist/build/bbdns-client/bbdns-client makereq +RUN_COMMAND = ./dist/build/bbdns-server/bbdns-server --localstatedir . signreq +#RUN_COMMAND = ./dist/build/bbdns-client/bbdns-client makereq include cabal-package.mk diff --git a/ServerMain.hs b/ServerMain.hs index 5f0db30..1e62fe7 100644 --- a/ServerMain.hs +++ b/ServerMain.hs @@ -2,6 +2,9 @@ module Main where import Control.Monad +import Control.Monad.Trans +import Data.List +import Data.Time.Clock {- import DDNS.DBInfo import qualified Database.HDBC as RAW @@ -9,7 +12,20 @@ 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 @@ -67,11 +83,86 @@ arginfo = [ Arg { ] main :: IO () -main = do m <- parseArgsIO ArgsComplete arginfo +main = withOpenSSL $ + do m <- parseArgsIO ArgsComplete arginfo when (gotArg m Help) $ usageError m "" - usageError m "" + 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 -> diff --git a/blackboard-dns.cabal b/blackboard-dns.cabal index 5e955b3..14afaa7 100644 --- a/blackboard-dns.cabal +++ b/blackboard-dns.cabal @@ -18,8 +18,8 @@ Extra-Source-Files: Executable bbdns-server Build-Depends: - HDBC, HDBC-sqlite3, base, haskelldb, haskelldb-hdbc-sqlite3, - parseargs + HDBC, HDBC-sqlite3, base, directory, filepath, haskelldb, + haskelldb-hdbc-sqlite3, parseargs, time Other-Modules: DDNS.DB -- 2.40.0