summaryrefslogtreecommitdiff
path: root/Hsbot
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--Hsbot.hs4
-rw-r--r--Hsbot/Core.hs32
-rw-r--r--Hsbot/Message.hs4
-rw-r--r--Hsbot/Plugin/Ping.hs2
-rw-r--r--Hsbot/Types.hs2
-rw-r--r--Hsbot/Utils.hs15
6 files changed, 29 insertions, 30 deletions
diff --git a/Hsbot.hs b/Hsbot.hs
index 76e1ba6..c02b2e5 100644
--- a/Hsbot.hs
+++ b/Hsbot.hs
@@ -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 } }
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-23 15:21:15 +0000