From b666e543d0ae03f79ca8b8527c099ca6320f27b0 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Mon, 11 Jul 2011 22:35:41 +0200 Subject: Fixed TLS client implementation --- Hsbot/Config.hs | 6 +----- Hsbot/Core.hs | 18 +++++++++--------- Hsbot/Types.hs | 2 -- Hsbot/Utils.hs | 59 ++++++--------------------------------------------------- hsbot.cabal | 3 ++- 5 files changed, 18 insertions(+), 70 deletions(-) diff --git a/Hsbot/Config.hs b/Hsbot/Config.hs index d51387b..8c85810 100644 --- a/Hsbot/Config.hs +++ b/Hsbot/Config.hs @@ -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 diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 9c72771..11c8732 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -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 () diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index c7331d3..7e340e3 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -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 diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 6eec5c4..e56e9f7 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -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 } diff --git a/hsbot.cabal b/hsbot.cabal index ef9be31..96b9647 100644 --- a/hsbot.cabal +++ b/hsbot.cabal @@ -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 -- cgit v1.2.3