+ 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 ()