Fixed TLS client implementation

4 files changed, 16 insertions, 69 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 }