Split commands off

[blackboard-dns.git] / DDNS / Server / SignReq.hs

diff --git a/DDNS/Server/SignReq.hs b/DDNS/Server/SignReq.hs
new file mode 100644 (file)
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 ()