93 lines
3.1 KiB
Haskell
93 lines
3.1 KiB
Haskell
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 Data.List
|
|
import Data.Maybe
|
|
import Network.TLS
|
|
import System.IO
|
|
|
|
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 (return . delete thrId)
|
|
|
|
setGlobalQuitMVar :: BotStatus -> Env IO ()
|
|
setGlobalQuitMVar status = do
|
|
quitMv <- asks envQuitMv
|
|
liftIO $ putMVar quitMv status
|
|
|
|
-- 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
|
|
|
|
-- 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 = 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
|
|
|