adyxax/hsbot
Archived
1
0
Fork 0
Code Issues Activity

Code cleaning.

Browse source
This commit is contained in:
Julien Dessaux 2011-05-01 15:56:53 +02:00
parent c497b24700
commit bf36db5488
6 changed files with 29 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Hsbot.hs
View file

@ -22,7 +22,7 @@ startHsbot config = do
-- main stuff -- main stuff
infoM "Hsbot" "Bot core starting" infoM "Hsbot" "Bot core starting"
status <- runReaderT runHsbot hsbotEnv status <- runReaderT runHsbot hsbotEnv
infoM "Hsbot" $ "Bot core exited with status " ++ (show status) infoM "Hsbot" $ "Bot core exited with status " ++ show status
-- Handling exit signal -- Handling exit signal
case status of case status of
BotContinue -> startHsbot config -- TODO do something not so dumb about starting over BotContinue -> startHsbot config -- TODO do something not so dumb about starting over
@ -34,5 +34,5 @@ hsbot :: Config -> IO ()
hsbot = Dyre.wrapMain $ Dyre.defaultParams hsbot = Dyre.wrapMain $ Dyre.defaultParams
{ Dyre.projectName = "hsbot" { Dyre.projectName = "hsbot"
, Dyre.realMain = startHsbot , Dyre.realMain = startHsbot
, Dyre.showError = (\config err -> config { configErrors = Just err }) } , Dyre.showError = \config err -> config { configErrors = Just err } }

32
Hsbot/Core.hs
View file

@ -23,7 +23,7 @@ import Hsbot.Plugin
import Hsbot.Types import Hsbot.Types
import Hsbot.Utils import Hsbot.Utils
initHsbot :: Config -> IO (BotEnv) initHsbot :: Config -> IO BotEnv
initHsbot config = do initHsbot config = do
chan <- newChan :: IO (Chan Message) chan <- newChan :: IO (Chan Message)
threadIdsMv <- newMVar [] threadIdsMv <- newMVar []
@ -34,15 +34,15 @@ initHsbot config = do
connhdl <- connectTo hostname port connhdl <- connectTo hostname port
hSetBuffering connhdl LineBuffering hSetBuffering connhdl LineBuffering
hSetEncoding connhdl utf8 hSetEncoding connhdl utf8
(tls, tlsCtx) <- case sslOn $ configTLS config of (tls, tlsCtx) <- if sslOn $ configTLS config
True -> do then (do
infoM "Hsbot.Core" "TLS init" infoM "Hsbot.Core" "TLS init"
tlsenv <- initTLSEnv (configTLS config) tlsenv <- initTLSEnv (configTLS config)
randomGen <- makeSRandomGen >>= either (fail . show) (return . id) randomGen <- makeSRandomGen >>= either (fail . show) (return . id)
sCtx <- client tlsenv randomGen connhdl sCtx <- client tlsenv randomGen connhdl
handshake sCtx handshake sCtx
return (Just tlsenv, Just sCtx) return (Just tlsenv, Just sCtx))
False -> return (Nothing, Nothing) else return (Nothing, Nothing)
return BotEnv { envHandle = connhdl return BotEnv { envHandle = connhdl
, envChan = chan , envChan = chan
, envQuitMv = quitMv , envQuitMv = quitMv
@ -51,7 +51,7 @@ initHsbot config = do
, envTLS = tls , envTLS = tls
, envTLSCtx = tlsCtx } , envTLSCtx = tlsCtx }
runHsbot :: Env IO (BotStatus) runHsbot :: Env IO BotStatus
runHsbot = do runHsbot = do
let bot = BotState { botPlugins = M.empty let bot = BotState { botPlugins = M.empty
, botHooks = [] , botHooks = []
@ -59,7 +59,7 @@ runHsbot = do
, botNickname = [] } , botNickname = [] }
evalStateT trueRunHsbot bot evalStateT trueRunHsbot bot
where where
trueRunHsbot :: Bot (Env IO) (BotStatus) trueRunHsbot :: Bot (Env IO) BotStatus
trueRunHsbot = do trueRunHsbot = do
-- First we say hello -- First we say hello
env <- lift ask env <- lift ask
@ -73,12 +73,12 @@ runHsbot = do
liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config) liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
-- Next we spawn the reader thread -- Next we spawn the reader thread
liftIO $ debugM "Hsbot.Core" $ "Spawning reader thread" liftIO $ debugM "Hsbot.Core" "Spawning reader thread"
myOwnThreadId <- liftIO $ myThreadId myOwnThreadId <- liftIO myThreadId
chan <- lift $ asks envChan chan <- lift $ asks envChan
(liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= lift . addThreadIdToQuitMVar (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= lift . addThreadIdToQuitMVar
-- Then we spawn all plugins -- Then we spawn all plugins
(lift $ asks envConfig) >>= mapM_ loadPlugin . configPlugins lift (asks envConfig) >>= mapM_ loadPlugin . configPlugins
-- Finally we spawn the main bot loop -- Finally we spawn the main bot loop
bot <- get bot <- get
finalStateMVar <- liftIO newEmptyMVar finalStateMVar <- liftIO newEmptyMVar
@ -94,11 +94,11 @@ runHsbot = do
botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO () botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
botReader _ (Just ctx) chan _ = forever $ 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 $ botReader handle Nothing chan fatherThreadId = forever $
(hGetLine handle) `catch` handleIOException >>= handleIncomingStr chan hGetLine handle `catch` handleIOException >>= handleIncomingStr chan
where where
handleIOException :: IOException -> IO (String) handleIOException :: IOException -> IO String
handleIOException ioException = do handleIOException ioException = do
throwTo fatherThreadId ioException throwTo fatherThreadId ioException
myId <- myThreadId myId <- myThreadId
@ -106,10 +106,10 @@ botReader handle Nothing chan fatherThreadId = forever $
return "" return ""
handleIncomingStr :: Chan Message -> String -> IO () handleIncomingStr :: Chan Message -> String -> IO ()
handleIncomingStr chan str = do handleIncomingStr chan str =
case IRC.decode str of case IRC.decode str of
Just msg -> do Just msg -> do
debugM "Ircd.Reader" $ "<-- " ++ (show msg) debugM "Ircd.Reader" $ "<-- " ++ show msg
writeChan chan $ IncomingMsg msg writeChan chan $ IncomingMsg msg
Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control
@ -125,7 +125,7 @@ botLoop = forever $ do
env <- lift ask env <- lift ask
let connhdl = envHandle env let connhdl = envHandle env
tlsCtx = envTLSCtx env tlsCtx = envTLSCtx env
liftIO $ debugM "Ircd.Reader" $ "--> " ++ (show outMsg) liftIO $ debugM "Ircd.Reader" $ "--> " ++ show outMsg
liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg
terminateHsbot :: Env IO () terminateHsbot :: Env IO ()

4
Hsbot/Message.hs
View file

@ -11,8 +11,8 @@ import qualified Network.IRC as IRC
import Hsbot.Types import Hsbot.Types
-- Plugin Utils -- Plugin Utils
readMsg :: Plugin (Env IO) (Message) readMsg :: Plugin (Env IO) Message
readMsg = gets pluginChan >>= liftIO . readChan >>= return readMsg = gets pluginChan >>= liftIO . readChan
writeMsg :: Message -> Plugin (Env IO) () writeMsg :: Message -> Plugin (Env IO) ()
writeMsg msg = gets pluginMaster >>= liftIO . flip writeChan msg writeMsg msg = gets pluginMaster >>= liftIO . flip writeChan msg

2
Hsbot/Plugin/Ping.hs
View file

@ -24,7 +24,7 @@ thePing = forever $ do
where where
eval :: Message -> Plugin (Env IO) () eval :: Message -> Plugin (Env IO) ()
eval (IncomingMsg msg) 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 () | otherwise = return ()
eval _ = return () eval _ = return ()

2
Hsbot/Types.hs
View file

@ -27,7 +27,7 @@ type Env = ReaderT BotEnv
data BotEnv = BotEnv data BotEnv = BotEnv
{ envHandle :: Handle { envHandle :: Handle
, envChan :: Chan Message , envChan :: Chan Message
, envQuitMv :: MVar (BotStatus) , envQuitMv :: MVar BotStatus
, envThreadIdsMv :: MVar [ThreadId] , envThreadIdsMv :: MVar [ThreadId]
, envConfig :: Config , envConfig :: Config
, envTLS :: Maybe TLSParams , envTLS :: Maybe TLSParams

15
Hsbot/Utils.hs
View file

@ -19,6 +19,7 @@ import qualified Data.Certificate.KeyRSA as KeyRSA
import Data.Certificate.PEM import Data.Certificate.PEM
import Data.Certificate.X509 import Data.Certificate.X509
import Data.List import Data.List
import Data.Maybe
import Network.TLS import Network.TLS
import System.IO import System.IO
@ -33,7 +34,7 @@ addThreadIdToQuitMVar thrId = do
delThreadIdFromQuitMVar :: ThreadId -> Env IO () delThreadIdFromQuitMVar :: ThreadId -> Env IO ()
delThreadIdFromQuitMVar thrId = do delThreadIdFromQuitMVar thrId = do
threadIdsMv <- asks envThreadIdsMv threadIdsMv <- asks envThreadIdsMv
liftIO $ modifyMVar_ threadIdsMv (\l -> return $ delete thrId l) liftIO $ modifyMVar_ threadIdsMv (return . delete thrId)
setGlobalQuitMVar :: BotStatus -> Env IO () setGlobalQuitMVar :: BotStatus -> Env IO ()
setGlobalQuitMVar status = do 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 sendStr handle Nothing msg = hPutStrLn handle msg
-- TLS utils -- TLS utils
initTLSEnv :: TLSConfig -> IO (TLSParams) initTLSEnv :: TLSConfig -> IO TLSParams
initTLSEnv ssl = do initTLSEnv ssl = do
let certFile = sslCert ssl let certFile = sslCert ssl
keyFile = sslKey ssl keyFile = sslKey ssl
@ -68,10 +69,8 @@ initTLSEnv ssl = do
readCertificate :: FilePath -> IO X509 readCertificate :: FilePath -> IO X509
readCertificate filepath = do readCertificate filepath = do
content <- B.readFile filepath content <- B.readFile filepath
let certdata = case parsePEMCert content of let certdata = fromMaybe (error "no valid certificate section") $ parsePEMCert content
Nothing -> error ("no valid certificate section") cert = case decodeCertificate $ L.fromChunks [certdata] of
Just x -> x
let cert = case decodeCertificate $ L.fromChunks [certdata] of
Left err -> error ("cannot decode certificate: " ++ err) Left err -> error ("cannot decode certificate: " ++ err)
Right x -> x Right x -> x
return cert return cert
@ -80,11 +79,11 @@ readPrivateKey :: FilePath -> IO PrivateKey
readPrivateKey filepath = do readPrivateKey filepath = do
content <- B.readFile filepath content <- B.readFile filepath
let pkdata = case parsePEMKeyRSA content of 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] Just x -> L.fromChunks [x]
let pk = case KeyRSA.decodePrivate pkdata of let pk = case KeyRSA.decodePrivate pkdata of
Left err -> error ("cannot decode key: " ++ err) 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_sz = fromIntegral $ KeyRSA.lenmodulus x
, RSA.private_n = KeyRSA.modulus x , RSA.private_n = KeyRSA.modulus x
, RSA.private_d = KeyRSA.private_exponant x , RSA.private_d = KeyRSA.private_exponant x