diff options
author | Julien Dessaux | 2011-09-10 00:10:00 +0200 |
---|---|---|
committer | Julien Dessaux | 2011-09-10 00:10:00 +0200 |
commit | 900c242551f624f4ab5b3ea79fd51611b47bd95e (patch) | |
tree | 215be6ae5c35f08eaa1be497b504abc0b28ee7c6 /Hsbot/Utils.hs | |
parent | Fixed compilation errors. Since I forgot to add the quote module to cabal the... (diff) | |
parent | Added score sorting for the duck module (diff) | |
download | hsbot-900c242551f624f4ab5b3ea79fd51611b47bd95e.tar.gz hsbot-900c242551f624f4ab5b3ea79fd51611b47bd95e.tar.bz2 hsbot-900c242551f624f4ab5b3ea79fd51611b47bd95e.zip |
Merge branch 'master' into quoteModule
Conflicts:
hsbot.cabal
Diffstat (limited to 'Hsbot/Utils.hs')
-rw-r--r-- | Hsbot/Utils.hs | 88 |
1 files changed, 32 insertions, 56 deletions
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 6eec5c4..2ea1a49 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -1,25 +1,21 @@ module Hsbot.Utils ( addThreadIdToQuitMVar , delThreadIdFromQuitMVar + , hasAccess , initTLSEnv - , readCertificate - , readPrivateKey , sendStr , setGlobalQuitMVar ) where import Control.Concurrent +import Control.Exception (IOException, catch) 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 Control.Monad.State +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.List as L +import qualified Network.IRC as IRC import Network.TLS +import Prelude hiding (catch) import System.IO import Hsbot.Types @@ -33,61 +29,41 @@ addThreadIdToQuitMVar thrId = do delThreadIdFromQuitMVar :: ThreadId -> Env IO () delThreadIdFromQuitMVar thrId = do threadIdsMv <- asks envThreadIdsMv - liftIO $ modifyMVar_ threadIdsMv (return . delete thrId) + liftIO $ modifyMVar_ threadIdsMv (return . L.delete thrId) setGlobalQuitMVar :: BotStatus -> Env IO () setGlobalQuitMVar status = do quitMv <- asks envQuitMv liftIO $ putMVar quitMv status +-- Access rights +hasAccess :: Maybe IRC.Prefix -> AccessRight -> Env IO Bool +hasAccess Nothing _ = return False +hasAccess (Just mask) right = do + asks envBotState >>= liftIO . readMVar >>= evalStateT (fmap (any accessMatch) (gets botAccess)) + where + accessMatch :: AccessList -> Bool + accessMatch (AccessList amask arights) + | mask == amask = or [Admin `L.elem` arights, right `L.elem` arights] + | otherwise = False + -- 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 :: BotEnv -> Handle -> Maybe TLSCtx -> String -> IO () +sendStr env _ (Just ctx) msg = sendData ctx (L.fromString $ msg ++ "\r\n") `catch` handleIOException env ("sendStr " ++ msg) +sendStr env handle Nothing msg = hPutStrLn handle (msg ++ "\r\n") `catch` handleIOException env ("sendStr " ++ msg) + +handleIOException :: BotEnv -> String -> IOException -> IO () +handleIOException env msg ioException = do + runReaderT (setGlobalQuitMVar $ BotRestart (show ioException, Just msg)) env + myId <- myThreadId + killThread myId + return () -- 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 } |