From bf36db548891057ccdcfb5b4c9366296fc26d7dd Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Sun, 1 May 2011 15:56:53 +0200 Subject: Code cleaning. --- Hsbot/Core.hs | 32 ++++++++++++++++---------------- Hsbot/Message.hs | 4 ++-- Hsbot/Plugin/Ping.hs | 2 +- Hsbot/Types.hs | 2 +- Hsbot/Utils.hs | 15 +++++++-------- 5 files changed, 27 insertions(+), 28 deletions(-) (limited to 'Hsbot') diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 1f017ce..529e6cb 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -23,7 +23,7 @@ import Hsbot.Plugin import Hsbot.Types import Hsbot.Utils -initHsbot :: Config -> IO (BotEnv) +initHsbot :: Config -> IO BotEnv initHsbot config = do chan <- newChan :: IO (Chan Message) threadIdsMv <- newMVar [] @@ -34,15 +34,15 @@ initHsbot config = do connhdl <- connectTo hostname port hSetBuffering connhdl LineBuffering hSetEncoding connhdl utf8 - (tls, tlsCtx) <- case sslOn $ configTLS config of - True -> do + (tls, tlsCtx) <- if sslOn $ configTLS config + then (do infoM "Hsbot.Core" "TLS init" tlsenv <- initTLSEnv (configTLS config) randomGen <- makeSRandomGen >>= either (fail . show) (return . id) sCtx <- client tlsenv randomGen connhdl handshake sCtx - return (Just tlsenv, Just sCtx) - False -> return (Nothing, Nothing) + return (Just tlsenv, Just sCtx)) + else return (Nothing, Nothing) return BotEnv { envHandle = connhdl , envChan = chan , envQuitMv = quitMv @@ -51,7 +51,7 @@ initHsbot config = do , envTLS = tls , envTLSCtx = tlsCtx } -runHsbot :: Env IO (BotStatus) +runHsbot :: Env IO BotStatus runHsbot = do let bot = BotState { botPlugins = M.empty , botHooks = [] @@ -59,7 +59,7 @@ runHsbot = do , botNickname = [] } evalStateT trueRunHsbot bot where - trueRunHsbot :: Bot (Env IO) (BotStatus) + trueRunHsbot :: Bot (Env IO) BotStatus trueRunHsbot = do -- First we say hello env <- lift ask @@ -73,12 +73,12 @@ runHsbot = do liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config) mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels -- Next we spawn the reader thread - liftIO $ debugM "Hsbot.Core" $ "Spawning reader thread" - myOwnThreadId <- liftIO $ myThreadId + liftIO $ debugM "Hsbot.Core" "Spawning reader thread" + myOwnThreadId <- liftIO myThreadId chan <- lift $ asks envChan (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= lift . addThreadIdToQuitMVar -- Then we spawn all plugins - (lift $ asks envConfig) >>= mapM_ loadPlugin . configPlugins + lift (asks envConfig) >>= mapM_ loadPlugin . configPlugins -- Finally we spawn the main bot loop bot <- get finalStateMVar <- liftIO newEmptyMVar @@ -94,11 +94,11 @@ runHsbot = do botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO () botReader _ (Just ctx) chan _ = forever $ - recvData ctx >>= return . L.toChunks >>= mapM_ (handleIncomingStr chan . C.unpack) -- TODO exceptions + fmap L.toChunks (recvData ctx) >>= mapM_ (handleIncomingStr chan . C.unpack) -- TODO exceptions botReader handle Nothing chan fatherThreadId = forever $ - (hGetLine handle) `catch` handleIOException >>= handleIncomingStr chan + hGetLine handle `catch` handleIOException >>= handleIncomingStr chan where - handleIOException :: IOException -> IO (String) + handleIOException :: IOException -> IO String handleIOException ioException = do throwTo fatherThreadId ioException myId <- myThreadId @@ -106,10 +106,10 @@ botReader handle Nothing chan fatherThreadId = forever $ return "" handleIncomingStr :: Chan Message -> String -> IO () -handleIncomingStr chan str = do +handleIncomingStr chan str = case IRC.decode str of Just msg -> do - debugM "Ircd.Reader" $ "<-- " ++ (show msg) + debugM "Ircd.Reader" $ "<-- " ++ show msg writeChan chan $ IncomingMsg msg Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control @@ -125,7 +125,7 @@ botLoop = forever $ do env <- lift ask let connhdl = envHandle env tlsCtx = envTLSCtx env - liftIO $ debugM "Ircd.Reader" $ "--> " ++ (show outMsg) + liftIO $ debugM "Ircd.Reader" $ "--> " ++ show outMsg liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg terminateHsbot :: Env IO () diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs index 133ff92..1382098 100644 --- a/Hsbot/Message.hs +++ b/Hsbot/Message.hs @@ -11,8 +11,8 @@ import qualified Network.IRC as IRC import Hsbot.Types -- Plugin Utils -readMsg :: Plugin (Env IO) (Message) -readMsg = gets pluginChan >>= liftIO . readChan >>= return +readMsg :: Plugin (Env IO) Message +readMsg = gets pluginChan >>= liftIO . readChan writeMsg :: Message -> Plugin (Env IO) () writeMsg msg = gets pluginMaster >>= liftIO . flip writeChan msg diff --git a/Hsbot/Plugin/Ping.hs b/Hsbot/Plugin/Ping.hs index d399ab8..179bcb3 100644 --- a/Hsbot/Plugin/Ping.hs +++ b/Hsbot/Plugin/Ping.hs @@ -24,7 +24,7 @@ thePing = forever $ do where eval :: Message -> Plugin (Env IO) () eval (IncomingMsg msg) - | (IRC.msg_command msg) == "PING" = writeMsg . OutgoingMsg . IRC.Message Nothing "PONG" $ IRC.msg_params msg + | IRC.msg_command msg == "PING" = writeMsg . OutgoingMsg . IRC.Message Nothing "PONG" $ IRC.msg_params msg | otherwise = return () eval _ = return () diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index 3e00fb2..b667286 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -27,7 +27,7 @@ type Env = ReaderT BotEnv data BotEnv = BotEnv { envHandle :: Handle , envChan :: Chan Message - , envQuitMv :: MVar (BotStatus) + , envQuitMv :: MVar BotStatus , envThreadIdsMv :: MVar [ThreadId] , envConfig :: Config , envTLS :: Maybe TLSParams diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 0b32fa6..b41fa52 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -19,6 +19,7 @@ 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 @@ -33,7 +34,7 @@ addThreadIdToQuitMVar thrId = do delThreadIdFromQuitMVar :: ThreadId -> Env IO () delThreadIdFromQuitMVar thrId = do threadIdsMv <- asks envThreadIdsMv - liftIO $ modifyMVar_ threadIdsMv (\l -> return $ delete thrId l) + liftIO $ modifyMVar_ threadIdsMv (return . delete thrId) setGlobalQuitMVar :: BotStatus -> Env IO () setGlobalQuitMVar status = do @@ -49,7 +50,7 @@ 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 :: TLSConfig -> IO TLSParams initTLSEnv ssl = do let certFile = sslCert ssl keyFile = sslKey ssl @@ -68,10 +69,8 @@ initTLSEnv ssl = do 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 + 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 @@ -80,11 +79,11 @@ readPrivateKey :: FilePath -> IO PrivateKey readPrivateKey filepath = do content <- B.readFile filepath let pkdata = case parsePEMKeyRSA content of - Nothing -> error ("no valid RSA key section") + 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 + 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 -- cgit v1.2.3