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