signreq

[blackboard-dns.git] / ServerMain.hs

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 ->