Fixed TLS client implementation
This commit is contained in:
parent
62a4220ce0
commit
b666e543d0
5 changed files with 18 additions and 70 deletions
|
@ -2,23 +2,14 @@ module Hsbot.Utils
|
|||
( addThreadIdToQuitMVar
|
||||
, delThreadIdFromQuitMVar
|
||||
, initTLSEnv
|
||||
, readCertificate
|
||||
, readPrivateKey
|
||||
, sendStr
|
||||
, setGlobalQuitMVar
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad.Reader
|
||||
import qualified Crypto.Cipher.RSA as RSA
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Certificate.KeyRSA as KeyRSA
|
||||
import Data.Certificate.PEM
|
||||
import Data.Certificate.X509
|
||||
import qualified Data.ByteString.Lazy.UTF8 as L
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Network.TLS
|
||||
import System.IO
|
||||
|
||||
|
@ -42,52 +33,14 @@ setGlobalQuitMVar status = do
|
|||
|
||||
-- Helpers
|
||||
sendStr :: Handle -> Maybe TLSCtx -> String -> IO ()
|
||||
sendStr _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg]
|
||||
sendStr handle Nothing msg = hPutStrLn handle msg
|
||||
sendStr _ (Just ctx) msg = sendData ctx . L.fromString $ msg ++ "\r\n"
|
||||
sendStr handle Nothing msg = hPutStrLn handle $ msg ++ "\r\n"
|
||||
|
||||
-- TLS utils
|
||||
initTLSEnv :: TLSConfig -> IO TLSParams
|
||||
initTLSEnv ssl = do
|
||||
let certFile = sslCert ssl
|
||||
keyFile = sslKey ssl
|
||||
versions = sslVersions ssl
|
||||
let versions = sslVersions ssl
|
||||
ciphers = sslCiphers ssl
|
||||
verify = sslVerify ssl
|
||||
-- TODO : exception on loading keys
|
||||
cert <- readCertificate certFile
|
||||
pk <- readPrivateKey keyFile
|
||||
return $ defaultParams { pConnectVersion = TLS12
|
||||
, pAllowedVersions = versions
|
||||
, pCiphers = ciphers
|
||||
, pWantClientCert = verify
|
||||
, pCertificates = [(cert, Just pk)] }
|
||||
|
||||
readCertificate :: FilePath -> IO X509
|
||||
readCertificate filepath = do
|
||||
content <- B.readFile filepath
|
||||
let certdata = fromMaybe (error "no valid certificate section") $ parsePEMCert content
|
||||
cert = case decodeCertificate $ L.fromChunks [certdata] of
|
||||
Left err -> error ("cannot decode certificate: " ++ err)
|
||||
Right x -> x
|
||||
return cert
|
||||
|
||||
readPrivateKey :: FilePath -> IO PrivateKey
|
||||
readPrivateKey filepath = do
|
||||
content <- B.readFile filepath
|
||||
let pkdata = case parsePEMKeyRSA content of
|
||||
Nothing -> error "no valid RSA key section"
|
||||
Just x -> L.fromChunks [x]
|
||||
let pk = case KeyRSA.decodePrivate pkdata of
|
||||
Left err -> error ("cannot decode key: " ++ err)
|
||||
Right x -> PrivRSA RSA.PrivateKey
|
||||
{ RSA.private_sz = fromIntegral $ KeyRSA.lenmodulus x
|
||||
, RSA.private_n = KeyRSA.modulus x
|
||||
, RSA.private_d = KeyRSA.private_exponant x
|
||||
, RSA.private_p = KeyRSA.p1 x
|
||||
, RSA.private_q = KeyRSA.p2 x
|
||||
, RSA.private_dP = KeyRSA.exp1 x
|
||||
, RSA.private_dQ = KeyRSA.exp2 x
|
||||
, RSA.private_qinv = KeyRSA.coef x
|
||||
}
|
||||
return pk
|
||||
return $ defaultParams { pAllowedVersions = versions
|
||||
, pCiphers = ciphers }
|
||||
|
||||
|
|
Reference in a new issue