signreq

diff --git a/.gitignore b/.gitignore
index e38f235a0008c6f8145505f4c70f4024699446b8..cebefa213df153a9b432dd82ed3ce00cacf7f411 100644 (file)
--- 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 b3090b39a7cb1dd3c7787fccf02c952df511646f..b96b430275439d3a2b1cc52784b195af52e8e23e 100644 (file)
--- 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 b3350fe21e340b44af0743cfe87d92d9104e170c..1d9b6f899b67b62f95d13676b1b7ceb2d22c1ca3 100644 (file)
--- 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 5f0db3001bc24fdb162e4e260ed755ccf0bb896f..1e62fe731101a2f3cb94695fb99d0ce4f0b1c110 100644 (file)
--- 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 5e955b34b81ae056f9c517edf9a3e76a38ed04d1..14afaa7dde80d9cfdac58cd316da3adeb7044534 100644 (file)
--- 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