{-# LANGUAGE ForeignFunctionInterface #-}
module OpenSSL.CreateKey(createKey, promptPassword, readKeyPair, readCertificate) where

import Control.Monad
import Data.Time
import Foreign.C
import OpenSSL.EVP.Cipher
import OpenSSL.EVP.PKey
import OpenSSL.PEM
import OpenSSL.RSA
import OpenSSL.X509
import System.Directory
import System.IO
import System.Posix

createKey :: String            -- ^ Key name
          -> FilePath          -- ^ Base filepath
          -> Maybe SomeKeyPair -- ^ Key for signing the certificate, otherwise self-signed
          -> PemPasswordSupply -- ^ Method for writing private key file
          -> IO (X509, SomeKeyPair)
createKey name bfp mkey gk = do
    cfile <- return (bfp++".public.cert")
    sfile <- return (bfp++".secret.key")
    e1 <- doesFileExist cfile
    e2 <- doesFileExist sfile
    when (e1 || e2) $ fail "Key exists already!"
    let list = [("CN",name)]
    pkey  <- generateRSAKey 2048 65537 Nothing
    cert  <- newX509
    setVersion cert 2
    setSerialNumber cert 1
    setIssuerName  cert list
    setSubjectName cert list
    setNotBefore cert =<< liftM (addUTCTime (-1)) getCurrentTime
    setNotAfter  cert =<< liftM (addUTCTime (365 * 24 * 60 * 60)) getCurrentTime
    setPublicKey cert pkey
    case mkey of
      Nothing -> signX509 cert pkey Nothing
      Just kp -> signX509 cert kp   Nothing
    Just ciph <- getCipherByName "AES256"
    sdata <- writePKCS8PrivateKey pkey (Just (ciph, gk))
    cdata <- writeX509 cert
    writeFile sfile sdata
    setFileMode sfile 0o400
    writeFile cfile cdata
    setFileMode cfile 0o400
    return (cert, fromKeyPair pkey)

-- | Read Key
readKeyPair :: FilePath -> PemPasswordSupply -> IO (X509, SomeKeyPair)
readKeyPair fp pps = do
  cfile <- return (fp++".public.cert")
  sfile <- return (fp++".secret.key")
  mcert <- readX509 =<< readFile cfile
  key <- (flip readPrivateKey pps =<< readFile sfile)
  return (mcert, key)

readCertificate :: FilePath -> IO X509
readCertificate fp = do
  readX509 =<< readFile (fp++".public.cert")

promptPassword :: PemPasswordSupply
promptPassword = PwCallback ppc

ppc :: Int -> PemPasswordRWState -> IO [Char]
ppc mlen PwRead = take mlen `fmap` getPass "Password: "
ppc mlen PwWrite= take mlen `fmap` loop
    where loop = do c1 <- getPass "Password: "
                    c2 <- getPass "Confirm password: "
                    if (c1 == c2) then return c1 else do
                    hPutStrLn stderr "Passwords do not match!"
                    loop
getPass :: String -> IO String
getPass p = withCString p (\cs -> peekCString =<< getpass cs)
foreign import ccall safe getpass :: CString -> IO CString