From ff07633fb8f81577ffec409cbf0a3c7361990f6c Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Wed, 13 Apr 2011 20:15:55 +0200
Subject: Began a big refactoring/rewriting (again)

---
 Hsbot/Utils.hs | 99 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 99 insertions(+)
 create mode 100644 Hsbot/Utils.hs

(limited to 'Hsbot/Utils.hs')

diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
new file mode 100644
index 0000000..785fb10
--- /dev/null
+++ b/Hsbot/Utils.hs
@@ -0,0 +1,99 @@
+module Hsbot.Utils
+    ( addThreadIdToQuitMVar
+    , delThreadIdFromQuitMVar
+    , first
+    , initTLSEnv
+    , readCertificate
+    , readPrivateKey
+    , sendStrToClient
+    , 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 Data.List
+import Network.TLS
+import System.IO
+
+import Hsbot.Config
+import Hsbot.Types
+
+-- utility functions
+addThreadIdToQuitMVar :: ThreadId -> Env IO ()
+addThreadIdToQuitMVar thrId = do
+    threadIdsMv <- asks envThreadIdsMv
+    liftIO $ modifyMVar_ threadIdsMv (\l -> return $ thrId:l)
+
+delThreadIdFromQuitMVar :: ThreadId -> Env IO ()
+delThreadIdFromQuitMVar thrId = do
+    threadIdsMv <- asks envThreadIdsMv
+    liftIO $ modifyMVar_ threadIdsMv (\l -> return $ delete thrId l)
+
+setGlobalQuitMVar :: BotStatus -> Env IO ()
+setGlobalQuitMVar status = do
+    quitMv <- asks envQuitMv
+    liftIO $ putMVar quitMv status
+
+first :: (a, b, c) -> a
+first (a, _, _) = a
+
+-- Helpers
+sendStrToClient :: Handle -> Maybe TLSCtx -> String -> IO ()
+sendStrToClient _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg]
+sendStrToClient handle Nothing msg = hPutStrLn handle msg
+
+-- TLS utils
+initTLSEnv :: TLSConfig -> IO (TLSParams)
+initTLSEnv ssl = do
+    let certFile = sslCert ssl
+        keyFile  = sslKey ssl
+        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 = case parsePEMCert content of
+            Nothing -> error ("no valid certificate section")
+            Just x  -> x
+    let 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
+
-- 
cgit v1.2.3