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
-> FilePath
-> Maybe SomeKeyPair
-> PemPasswordSupply
-> 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)
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