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 ++ ".")