]> gitweb @ CieloNegro.org - blackboard-dns.git/blob - DDNS/Server/SignReq.hs
editzone
[blackboard-dns.git] / DDNS / Server / SignReq.hs
1 module DDNS.Server.SignReq
2     ( signReq
3     )
4     where
5
6 import           Control.Monad
7 import           Control.Monad.Trans
8 import           DDNS.Utils
9 import           Data.List
10 import           Data.Time.Clock
11 import           OpenSSL.EVP.PKey
12 import           OpenSSL.EVP.Verify
13 import           OpenSSL.PEM
14 import           OpenSSL.X509 as X509
15 import           OpenSSL.X509.Request as Req
16 import           System.Console.Haskeline
17 import           System.FilePath
18 import           System.IO
19
20 signReq :: KeyPair k => k -> X509 -> IO ()
21 signReq sKey sCert
22     = runInputT (setComplete completeFilename defaultSettings) $
23       do file <- getInputLine' "Which X.509 request do you want to sign?: "
24          liftIO $ do req <- readX509Req =<< readFile file
25                      key <- Req.getPublicKey req
26                      vst <- verifyX509Req req key
27                      unless (vst == VerifySuccess)
28                          $ fail "Invalid X.509 request"
29
30                      cert <- makeX509FromReq req sCert
31                      setSerialNumber cert 1 -- FIXME: This nasty behavior makes revocation-list unusable.
32                      setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
33                      setNotAfter     cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime
34                      signX509        cert sKey Nothing
35
36                      let certFile = file `replaceExtension` ".cert"
37                      withFile certFile WriteMode $ \ h ->
38                          writeX509 cert >>= hPutStr h
39                      putStrLn ("Wrote " ++ certFile)
40
41                      Just (_, fqdn) <- liftM (find ((== "CN") . fst)) $ X509.getSubjectName cert False
42                      putStrLn ("Now send " ++ certFile ++ " back to " ++ fqdn ++ ".")