diff options
Diffstat (limited to 'HsBot.hs')
| -rw-r--r-- | HsBot.hs | 258 |
1 files changed, 106 insertions, 152 deletions
@@ -1,7 +1,7 @@ -- HsBot - The Karmabot By Paul Buetow --module Main (main,matches) where -module Main where +module HsBot where import IO import System @@ -11,23 +11,25 @@ import Network import System.IO import Text.Printf --- Static configurations +import Tools +import Conf +import State +-- Static stateigurations (will be moved to Conf.hs) + +name = "hsbot" version = "v0.0" database = "hsbot.db" maxMessageSize = 400 adminsitrator = "rantanplan" --- logfile :: String --- logfile = "hsbot.log" - --- End of static configurations +-- End of static stateigurations data Karma = Karma { karmaName :: String, minPts :: Int, - minPerc :: Float } - deriving (Show, Read) + minPerc :: Float + } deriving (Show, Read) instance Eq Karma where x == y = (minPerc x) == (minPerc y) && (minPts x == minPts y) @@ -40,33 +42,17 @@ instance Ord Karma where x >= y = not (x < y) x <= y = not (x > y) -data IrcConnection = IrcConnection { - server :: String, - port :: Int, - channel :: String, - nick :: String - } deriving (Show, Read) - -data IrcMessage = IrcMessage { - raw :: String, - from :: String, - clean :: String, - isQuery :: Bool - } deriving Show - -data Conf = Conf { - irc :: IrcConnection, +data State = State { + channel :: String, line :: String, - loggs :: [String], - maxLoggs :: Int, users :: [User], karmas :: [Karma] } deriving (Show, Read) data User = User { userName :: String, - userPts :: Int } - deriving (Show, Read) + userPts :: Int + } deriving (Show, Read) instance Eq User where x == y = (userPts x) == (userPts y) @@ -87,23 +73,11 @@ instance Render User where (show $ userPts user) ++ "pts; " ++ (show $ userPerc user) ++ "%)" -loggIrcMessage :: String -> Conf -> Conf -loggIrcMessage message conf = - let l = message : (loggs conf) - l' | (length l) > (maxLoggs conf) = init l - | otherwise = l - in conf { loggs = l' } - -printLoggs :: Conf -> IO () -printLoggs conf = printLoggs' $ reverse (loggs conf) - where printLoggs' [] = return () - printLoggs' (l:logg) = do { putStrLn l; printLoggs' logg } - numUsers :: Int -numUsers = length $ users makeConf +numUsers = length $ users makeState sortedUsers :: [User] -sortedUsers = sort $ users makeConf +sortedUsers = sort $ users makeState userEquals :: User -> User -> Bool userEquals x y = (userName x) == (userName y) @@ -114,7 +88,7 @@ userRank = userRank' 1 sortedUsers | userEquals x user = rank | otherwise = userRank' (rank+1) xs user -getUser :: String -> Conf -> User +getUser :: String -> State -> User getUser name = head . filter (\x -> userName x == name) . users userPerc :: User -> Float @@ -131,33 +105,13 @@ userPerc user = userKarma :: User -> String userKarma user = userKarma' (userPts user) (userPerc user) where userKarma' pts perc = - let cands = sort $ filter (\x -> minPts x <= pts && minPerc x <= perc) (karmas makeConf) + let cands = sort $ filter (\x -> minPts x <= pts && minPerc x <= perc) + (karmas makeState) in karmaName $ cands !! 0 -- Best posible karma addUserKarma :: Int -> User -> User addUserKarma add user = user { userPts = userPts user + add } -uniq :: (Eq a) => [a] -> [a] -uniq list = - let r = u' list 0 - u' [] _ = [] - u' (x:list) n - | member x r n = u' list n - | otherwise = x:(u' list (n + 1)) - member e list 0 = False - member y (x:list) n = x == y || member y list (n - 1) - in r - -split :: String -> Char -> [String] -split [] delim = [""] -split (c:cs) delim - | c == delim = "" : rest - | otherwise = (c : head rest) : tail rest - where rest = split cs delim - -empty :: String -> Bool -empty str = length str == 0 - -- Returns a list of all strings to increase or decrease the karma of matches :: String -> String -> [String] matches search string = uniq $ case m' $ occ search string of @@ -179,66 +133,81 @@ matches search string = uniq $ case m' $ occ search string of m' (Just (a, b)) = ((extr extrL a) ++ (extr extrR b), b) m' Nothing = ([], []) -processInput :: Conf -> Conf -processInput conf = addAll --loggIrcMessage "foo" conf +processInput :: State -> State +processInput state = addAll where add :: [User] -> [User] add [] = [] add (u:[]) = addUserKarma 1 u : [] add (u:us) = addUserKarma 1 u : (add us) - addAll = conf { users = add (users conf) } - plus = matches "++" (line conf) - minus = matches "--" (line conf) + addAll = state { users = add (users state) } + plus = matches "++" (line state) + minus = matches "--" (line state) -data Command = Command String String (Conf -> IO ()) - -instance Show Command where - show (Command a b _) = "\t" ++ a ++ " - " ++ b ++ "\n" - -main :: IO () -main = do - let conf = load - conf' <- conf -- Extract Conf from the IO Monad - connect conf' - -load :: IO Conf +load :: IO State load = do file <- readFile database - return ( read file :: Conf ) + return ( read file :: State ) -save :: Conf -> IO () +save :: State -> IO () save = writeFile database . show -saveIO :: IO Conf -> IO () -saveIO conf = do - conf' <- conf - writeFile database (show conf') +saveIO :: IO State -> IO () +saveIO state = do + state' <- state + writeFile database (show state') -makeIOConf :: IO Conf -makeIOConf = return (makeConf) +makeIOState :: IO State +makeIOState = return (makeState) -connect conf = do - let con = irc conf - h <- connectTo (server con) (PortNumber (fromIntegral (port con))) - hSetBuffering h NoBuffering - write h "NICK" (nick con) - write h "USER" ((nick con) ++ " 0 * :hsbot.haskell.eu") - listen h conf +-- Will be removed some day: +makeState :: State +makeState = State { channel = "", line = "", users = [ ], karmas = [ ] } +--- + +data IrcMessage = IrcMessage { + raw :: String, + from :: String, + clean :: String, + isQuery :: Bool + } deriving Show write :: Handle -> String -> String -> IO () write h s t = do hPrintf h "%s %s\r\n" s t printf "> %s %s\n" s t -privmsg :: Handle -> String -> IrcMessage -> Conf -> IO () -privmsg h s msg conf = - let receiver = if (isQuery msg) then from msg else channel $ irc conf - in if length s > maxMessageSize - then do write h "PRIVMSG" (receiver ++ " :" ++ (take maxMessageSize s) ++ "...") - write h "PRIVMSG" (receiver ++ " :" ++ "...this message has been cut to " ++ (show maxMessageSize) ++ " chars") - else write h "PRIVMSG" (receiver ++ " :" ++ s) +privmsg :: Handle -> IrcMessage -> State -> Conf -> String -> IO () +privmsg h msg state conf s = + if isMultiline s then privmsg' (lines s) else privmsg' [s] + where + privmsg' [] = return () + privmsg' (x:xs) = + let receiver = if (isQuery msg) then from msg else channel state + in if length x > maxMessageSize + then do write h "PRIVMSG" (receiver ++ " :" + ++ (take maxMessageSize x) ++ "...") + write h "PRIVMSG" (receiver ++ " :" + ++ "...this message has been cut to " + ++ (show maxMessageSize) ++ " chars") + privmsg' xs + else do write h "PRIVMSG" (receiver ++ " :" ++ x) + privmsg' xs + +connect :: State -> Conf -> IO () +connect state conf = do + ircNick <- get "ircNick" conf + ircChannel <- get "ircChannel" conf + ircServer <- get "ircServer" conf + ircPort <- get "ircPort" conf + let state' = state { channel = ircChannel } + h <- connectTo ircServer (PortNumber (fromIntegral 6667)) + hSetBuffering h NoBuffering + write h "NICK" ircNick + write h "USER" (ircNick ++ " 0 * :hsbot.haskell.eu") + listen h state' conf -listen :: Handle -> Conf -> IO () -listen h conf = forever $ do +listen :: Handle -> State -> Conf -> IO () +listen h state conf = forever $ do t <- hGetLine h let s = init t if ping s @@ -248,71 +217,56 @@ listen h conf = forever $ do from = from s, clean = clean s, isQuery = isQuery s } - in eval h msg conf + in eval h msg state conf where forever a = do a; forever a - from = drop 1 . takeWhile (/= '!') - clean = drop 1 . dropWhile (/= ':') . drop 1 - isQuery x = split x ' ' !! 2 == (nick $ irc conf) - ping x = "PING :" `isPrefixOf` x - pong x = write h "PONG" (':' : drop 6 x) - -eval :: Handle -> IrcMessage -> Conf-> IO () -eval h msg conf = + from = drop 1 . takeWhile (/= '!') + clean = drop 1 . dropWhile (/= ':') . drop 1 + isQuery x = split x ' ' !! 2 == ircNick + where ircNick = do { ircNick <- get "ircNick" conf; ircNick } + ping x = "PING :" `isPrefixOf` x + pong x = write h "PONG" (':' : drop 6 x) + +eval :: Handle -> IrcMessage -> State -> Conf -> IO () +eval h msg state conf = case isCommand (clean msg) of - Just xs -> evalCommand h xs msg conf + Just xs -> dispatch h xs msg state conf Nothing -> evalServerMessage (clean msg) where isCommand ('!':xs) = Just xs isCommand _ = Nothing - evalServerMessage "+x" = write h "JOIN" (channel $ irc conf) + evalServerMessage "+x" = do + ircChannel <- get "ircChannel" conf + write h "JOIN" ircChannel evalServerMessage _ = putStrLn $ show msg -evalCommand :: Handle -> String -> IrcMessage -> Conf-> IO () -evalCommand h cmd msg conf - | cmd == "hello" = privmsg h ("Hi " ++ (from msg) ++ ", what's up?") msg conf - | otherwise = dispatch h cmd msg conf +data Command = Command String String (State -> IO ()) +instance Show Command where + show (Command a b _) = a ++ " - " ++ b -dispatch :: Handle -> String -> IrcMessage -> Conf-> IO () -dispatch h cmd msg conf = do - getLambda ("!" ++ cmd) conf -- Eval the specific lambda function of 'command' +dispatch :: Handle -> String -> IrcMessage -> State -> Conf -> IO () +dispatch h cmd msg state conf = do + getLambda ("!" ++ cmd) state -- Eval the specific lambda function of 'command' where commands = [ Command "!h" "Prints help" - (\x -> do { printHelp commands } ), - Command "!l" "Prints loggs" - (\x -> do { printLoggs x } ), - Command "!p" "Prints configuration" - (\x -> do { privmsg h (show x) msg conf } ), - Command "!s" "Saves configuration" - (\x -> do { putStrLn "Saving current configuration"; save x; } ), + (\_ -> do { printHelp commands } ), + Command "!i" "Prints infos" + (\_ -> do { sendMessage $ name ++ " " ++ version ++ " (try !h)"} ), + Command "!p" "Prints stateiguration" + (\x -> do { sendMessage $ show x } ), + Command "!s" "Saves stateiguration" + (\x -> do { sendMessage "Saving current stateiguration"; save x; } ), Command "!q" "quits" - (\x -> do { putStrLn "Good bye"; save x; exitWith ExitSuccess } ) + (\x -> do { sendMessage "Good bye"; save x; exitWith ExitSuccess } ) ] - printHelp = putStr . foldr (++) "" . map show + sendMessage = privmsg h msg state conf + printHelp = sendMessage . concat . showL getLambda x = let (Command _ _ c) = getCommand x in c getDescr x = let (Command _ b _) = getCommand x in b getCommand x = let command = [ (Command a b c) | (Command a b c) <- commands, a == x ] in if length command == 0 - then getCommand "!h" -- If there is no such command print out the help + then getCommand "!i" else head command --- Will be removed some day: -makeConf :: Conf -makeConf = makeDefaultConf - -makeDefaultConf :: Conf -makeDefaultConf = Conf { - irc = IrcConnection { - server = "", - port = 6667, - channel = [], - nick = "" - }, - line = "", - loggs = [], - maxLoggs = 10, - users = [ ], - karmas = [ ] -} |