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
infoM "Hsbot" "Bot core starting"
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
case status of
BotContinue -> startHsbot config -- TODO do something not so dumb about starting over
@ -34,5 +34,5 @@ hsbot :: Config -> IO ()
hsbot = Dyre.wrapMain $ Dyre.defaultParams
{ Dyre.projectName = "hsbot"
, 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.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 ()

4
Hsbot/Message.hs
View file

@ -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

2
Hsbot/Plugin/Ping.hs
View file

@ -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 ()

2
Hsbot/Types.hs
View file

@ -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

15
Hsbot/Utils.hs
View file

@ -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