Fixed TLS client implementation
This commit is contained in:
Julien Dessaux
parent
62a4220ce0
commit
b666e543d0
5 changed files with 18 additions and 70 deletions
|
|
@ -24,12 +24,8 @@ defaultConfig = Config
|
|||
defaultTLSConfig :: TLSConfig
|
||||
defaultTLSConfig = TLSConfig
|
||||
{ sslOn = True
|
||||
, sslCert = ""
|
||||
, sslKey = ""
|
||||
, sslVersions = [SSL3, TLS10, TLS11, TLS12]
|
||||
, sslCiphers = [ cipher_null_MD5
|
||||
, cipher_null_SHA1
|
||||
, cipher_AES128_SHA1
|
||||
, sslCiphers = [ cipher_AES128_SHA1
|
||||
, cipher_AES256_SHA1
|
||||
, cipher_RC4_128_MD5
|
||||
, cipher_RC4_128_SHA1
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@ import Control.Concurrent
|
|||
import Control.Exception (IOException, catch)
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Lazy.UTF8 as L
|
||||
import qualified Data.Map as M
|
||||
import Network
|
||||
import qualified Network.IRC as IRC
|
||||
|
|
@ -33,15 +32,16 @@ initHsbot config = do
|
|||
port = configPort config
|
||||
infoM "Hsbot.Core" $ "Connecting to " ++ hostname -- ++ ":" ++ port
|
||||
connhdl <- connectTo hostname port
|
||||
hSetBuffering connhdl LineBuffering
|
||||
hSetBuffering connhdl NoBuffering
|
||||
hSetEncoding connhdl utf8
|
||||
(tls, tlsCtx) <- if sslOn $ configTLS config
|
||||
then (do
|
||||
infoM "Hsbot.Core" "TLS init"
|
||||
infoM "Hsbot.Core" "Initializing TLS communication"
|
||||
tlsenv <- initTLSEnv (configTLS config)
|
||||
randomGen <- newGenIO :: IO SystemRandom
|
||||
sCtx <- client tlsenv randomGen connhdl
|
||||
handshake sCtx
|
||||
success <- handshake sCtx
|
||||
unless success $ errorM "Hsbot.Core" "TLS handshake failed" -- TODO: do some usefull error handling
|
||||
return (Just tlsenv, Just sCtx))
|
||||
else return (Nothing, Nothing)
|
||||
return BotEnv { envBotState = botState
|
||||
|
|
@ -103,7 +103,7 @@ runHsbot = do
|
|||
|
||||
botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
|
||||
botReader _ (Just ctx) chan _ = forever $
|
||||
fmap L.toChunks (recvData ctx) >>= mapM_ (handleIncomingStr chan . C.unpack) -- TODO exceptions
|
||||
fmap L.toString (recvData ctx) >>= handleIncomingStr chan -- TODO exceptions
|
||||
botReader handle Nothing chan fatherThreadId = forever $
|
||||
hGetLine handle `catch` handleIOException >>= handleIncomingStr chan
|
||||
where
|
||||
|
|
@ -118,9 +118,9 @@ handleIncomingStr :: Chan Message -> String -> IO ()
|
|||
handleIncomingStr chan str =
|
||||
case IRC.decode str of
|
||||
Just msg -> do
|
||||
debugM "Ircd.Reader" $ "<-- " ++ show msg
|
||||
debugM "Hsbot.Reader" $ "<-- " ++ show msg
|
||||
writeChan chan $ IncomingMsg msg
|
||||
Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control
|
||||
Nothing -> return ()
|
||||
|
||||
botLoop :: Env IO ()
|
||||
botLoop = forever $ do
|
||||
|
|
@ -134,7 +134,7 @@ botLoop = forever $ do
|
|||
env <- ask
|
||||
let connhdl = envHandle env
|
||||
tlsCtx = envTLSCtx env
|
||||
liftIO $ debugM "Ircd.Reader" $ "--> " ++ show outMsg
|
||||
liftIO $ debugM "Hsbot.Loop" $ "--> " ++ show outMsg
|
||||
liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg
|
||||
|
||||
terminateHsbot :: Env IO ()
|
||||
|
|
|
|||
|
|
@ -79,8 +79,6 @@ data Config = Config
|
|||
|
||||
data TLSConfig = TLSConfig
|
||||
{ sslOn :: Bool
|
||||
, sslCert :: String
|
||||
, sslKey :: String
|
||||
, sslVersions :: [Network.TLS.Version]
|
||||
, sslCiphers :: [Network.TLS.Cipher]
|
||||
, sslVerify :: Bool
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
||||
|
|
|
|||
|
|
@ -42,8 +42,9 @@ Library
|
|||
network,
|
||||
random,
|
||||
safecopy,
|
||||
tls >= 0.6.1,
|
||||
tls >= 0.7.1,
|
||||
tls-extra >= 0.2.0,
|
||||
utf8-string,
|
||||
xdg-basedir
|
||||
|
||||
|
||||
|
|
|
|||
Reference in a new issue