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          case trim file of
  25            Just file'
  26                -> liftIO $
  27                   do req <- readX509Req =<< readFile file'
  28                      key <- Req.getPublicKey req
  29                      vst <- verifyX509Req req key
  30                      unless (vst == VerifySuccess)
  31                          $ fail "Invalid X.509 request"
  32
  33                      cert <- makeX509FromReq req sCert
  34                      setSerialNumber cert 1 -- FIXME: This nasty behavior makes revocation-list unusable.
  35                      setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
  36                      setNotAfter     cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime
  37                      signX509        cert sKey Nothing
  38
  39                      let certFile = file' `replaceExtension` ".cert"
  40                      withFile certFile WriteMode $ \ h ->
  41                          writeX509 cert >>= hPutStr h
  42                      putStrLn ("Wrote " ++ certFile)
  43
  44                      Just (_, fqdn) <- liftM (find ((== "CN") . fst)) $ X509.getSubjectName cert False
  45                      putStrLn ("Now send " ++ certFile ++ " back to " ++ fqdn ++ ".")
  46            _   -> return ()