From 7a7302c5b86e89f3fc2fbc3476db731dfd6ed11b Mon Sep 17 00:00:00 2001 From: pb Date: Sun, 28 Mar 2010 11:04:15 +0000 Subject: git-svn-id: https://ssl.buetow.org/repos/hsbot/trunk@49 9f8f72e9-4bf4-416e-b76e-7d4203597157 --- HsBot/HsBot.hs | 205 ---------------------------------------------- HsBot/IRC.hs | 96 ++++++++++++++++++++++ HsBot/IRC/IRConnection.hs | 96 ---------------------- HsBot/Start.hs | 2 +- 4 files changed, 97 insertions(+), 302 deletions(-) delete mode 100644 HsBot/HsBot.hs create mode 100644 HsBot/IRC.hs delete mode 100644 HsBot/IRC/IRConnection.hs (limited to 'HsBot') diff --git a/HsBot/HsBot.hs b/HsBot/HsBot.hs deleted file mode 100644 index 2c33a83..0000000 --- a/HsBot/HsBot.hs +++ /dev/null @@ -1,205 +0,0 @@ ---module Main (main,matches) where -module HsBot.HsBot where - -import IO -import System - --- Start configuration - -version :: String -version = "0.0" - --- End configuration - -data Karma = Karma { karmaName :: String, minPts :: Int, minPerc :: Float } deriving (Show, Read) - -instance Eq Karma where x == y = (minPerc x) == (minPerc y) && (minPts x == minPts y) - -instance Ord Karma where - x > y | (minPerc x) > (minPerc y) = True - | otherwise = (minPts x) > (minPts y) - x < y | (minPerc x) < (minPerc y) = True - | otherwise = (minPts x) < (minPts y) - x >= y = not (x < y) - x <= y = not (x > y) - -data Conf = Conf { line :: String, loggs :: [String], maxLoggs :: Int, users :: [User], karmas :: [Karma] } deriving (Show, Read) - -data User = User { userName :: String, userPts :: Int } deriving (Show, Read) - -instance Eq User where x == y = (userPts x) == (userPts y) - -instance Ord User where - x < y = (userPts x) < (userPts y) - x > y = (userPts x) > (userPts y) - x >= y = not (x < y) - x <= y = not (x > y) - -class Render a where render :: a -> String - -instance Render User where - render user = userName user ++ ": " ++ - (userKarma user) ++ " (rank " ++ - (show $ userRank user) ++ "/" ++ - (show numUsers) ++ "; " ++ - (show $ userPts user) ++ "pts; " ++ - (show $ userPerc user) ++ "%)" - -loggMessage :: String -> Conf -> Conf -loggMessage 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 - -sortedUsers :: [User] -sortedUsers = sort $ users makeConf - -userEquals :: User -> User -> Bool -userEquals x y = (userName x) == (userName y) - -userRank :: User -> Int -userRank = userRank' 1 sortedUsers - where userRank' rank (x:xs) user - | userEquals x user = rank - | otherwise = userRank' (rank+1) xs user - -getUser :: String -> Conf -> User -getUser name = head . filter (\x -> userName x == name) . users - -userPerc :: User -> Float -userPerc user = - let rank = userRank user - userPerc' - | rank == 1 = 100 -- 1st always has 100% - | rank == numUsers = 0 -- back always has 0% - | otherwise = let userWeight = 100 / (fromIntegral numUsers) - in 100 - userWeight * (fromIntegral rank) - in userPerc' - -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) - in karmaName $ cands !! 0 -- Best posible karma - -addUserKarma :: Int -> User -> User -addUserKarma add user = user { userPts = userPts user + add } - --- Sorts a list -sort :: (Ord a) => [a] -> [a] -sort [] = [] -sort (x:xs) = sort (filter (>= x) xs) ++ [x] ++ sort (filter (< x) xs) - -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 - --- 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 - (list, "") -> list - (list, rest) -> list ++ (matches search rest) - where occ :: String -> String -> Maybe (String, String) - occ search str = o' "" search str - where o' pred [] str = Just (init . init $ reverse pred, str) - o' pred occ [] = Nothing - o' pred (m:occ) (s:str) - | otherwise = o' (s:pred) search str - extr extrF = extrF . filter (\x -> (x /= '-') && (x /= '+')) - extrL str -- extract left side - | null str || last str == ' ' = [] - | otherwise = [last $ split str ' '] - extrR str -- extract right side - | null str || str !! 0 == ' ' = [] - | otherwise = [split str ' ' !! 0] - m' (Just (a, b)) = ((extr extrL a) ++ (extr extrR b), b) - m' Nothing = ([], []) - -processInput :: Conf -> Conf -processInput conf = addAll --loggMessage "foo" conf - 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) - -help :: IO () -help = do - putStrLn "\t!h - Print help" - putStrLn "\t!l - Print loggs" - putStrLn "\t!p - Print current configuration" - putStrLn "\t!q - Quit" - -loop :: Conf -> IO () -loop conf = do - line <- getLine - case line of - "!h" -> do { help; loop conf } - "!l" -> do { printLoggs conf; loop conf } - "!p" -> do { putStrLn $ show conf; loop conf } - "!q" -> do { putStrLn "Good bye"; exitWith ExitSuccess } - _ -> do { putStrLn line; loop $ processInput $ conf { line = line } } - -main :: IO () -main = do - putStrLn $ "Welcome to " ++ version ++ " (Enter !h for help)" - loop makeConf - -makeTestConf :: Conf -makeTestConf = Conf { - line = "", - loggs = [], - maxLoggs = 10, - users = [ - User "thunder" 100, - User "otto" 1, - User "rantanplan" 3, - User "rantanplan2" 3, - User "icefox2" 11, - User "icefox" 10, - User "foobar" 5, - User "foobar1" 5, - User "foobar2" 5, - User "foobar3" 5, - User "foobar4" 5, - User "foobar5" 5, - User "foobar6" 5, - User "openfire" 2 - ], - karmas = [ - Karma "God" 20 90, - Karma "Guru" 10 80, - Karma "Nerd" 10 70, - Karma "Expert" 5 60, - Karma "Geek" 3 40, - Karma "Advanced" 0 20, - Karma "Cool dude" 0 0 - ] } - -makeConf :: Conf -makeConf = makeTestConf - diff --git a/HsBot/IRC.hs b/HsBot/IRC.hs new file mode 100644 index 0000000..7efb732 --- /dev/null +++ b/HsBot/IRC.hs @@ -0,0 +1,96 @@ +module HsBot.IRC (ircStart) where + +import IO +import List +import Network +import System +import System.IO +import Text.Printf + +import HsBot.Conf +import HsBot.Env +import HsBot.State +import HsBot.General.Tools +import HsBot.IRC.User + +data IrcMessage = IrcMessage { + raw :: String, + from :: String, + clean :: String, + isQuery :: Bool + } deriving Show + +ircWrite :: Handle -> String -> String -> IO () +ircWrite h s t = do + printf "> %s %s\n" s t + hPrintf h "%s %s\r\n" s t + +ircPrivMsg :: Handle -> IrcMessage -> Env -> String -> IO () +ircPrivMsg h msg env@(Env state _) s = do + ircPrivMsg' $ if isMultiline s then (lines s) else [s] + where + ircPrivMsg' [] = return () + ircPrivMsg' (x:xs) = + let maxMessageSize = + envGetInt "maxMessageSize" env + receiver = + if (isQuery msg) + then from msg + else currentChannel state + in if length x > maxMessageSize + then do + ircWrite h "PRIVMSG" (receiver ++ " :" + ++ (take maxMessageSize x) ++ "...") + ircWrite h "PRIVMSG" (receiver ++ " :" + ++ "...this message has been cut to " + ++ (show maxMessageSize) ++ " chars") + ircPrivMsg' xs + else do + ircWrite h "PRIVMSG" (receiver ++ " :" ++ x) + ircPrivMsg' xs + +ircStart :: Env -> IO () +ircStart (DispatchEnv state conf dispatch) = do + ircChannel <- get "ircChannel" conf + ircNick <- get "ircNick" conf + ircPort <- get "ircPort" conf + ircServer <- get "ircServer" conf + ircUser <- get "ircUser" conf + h <- connectTo ircServer (PortNumber $ fromIntegral (read ircPort :: Int)) + hSetBuffering h NoBuffering + ircWrite h "NICK" ircNick + ircWrite h "USER" $ ircNick ++ " 0 * :" ++ ircUser + ircEvalLoop h (DispatchEnv state { currentChannel = ircChannel } conf dispatch) + return () + +ircEvalLoop :: Handle -> Env -> IO () +ircEvalLoop h env = do + t <- hGetLine h + let s = init t + env' <- branch s + ircEvalLoop h env' + where + branch s + | ping s = do { pong s; return (env) } + | otherwise = ircEval h (msg s) env + ping x = "PING :" `isPrefixOf` x + pong x = ircWrite h "PONG" (':' : drop 6 x) + from = drop 1 . takeWhile (/= '!') + clean = drop 1 . dropWhile (/= ':') . drop 1 + isQuery x = split x ' ' !! 2 == (envGet "ircNick" env) + msg s = IrcMessage { + raw = s, from = from s, + clean = clean s, isQuery = isQuery s + } + +ircEval :: Handle -> IrcMessage -> Env -> IO Env +ircEval h msg env@(DispatchEnv state _ dispatch) = ircEval' (clean msg) + where + ircEval' "+x" = do + ircWrite h "JOIN" (currentChannel state) + return (env) + ircEval' cleanMsg = do + (Env s c) <- dispatch cleanMsg sendReplyMsg (castEnv env) + return (DispatchEnv s c dispatch) + sendReplyMsg = ircPrivMsg h msg (castEnv env) + diff --git a/HsBot/IRC/IRConnection.hs b/HsBot/IRC/IRConnection.hs deleted file mode 100644 index 610d333..0000000 --- a/HsBot/IRC/IRConnection.hs +++ /dev/null @@ -1,96 +0,0 @@ -module HsBot.IRC.IRConnection (ircStart) where - -import IO -import List -import Network -import System -import System.IO -import Text.Printf - -import HsBot.Conf -import HsBot.Env -import HsBot.State -import HsBot.General.Tools -import HsBot.IRC.User - -data IrcMessage = IrcMessage { - raw :: String, - from :: String, - clean :: String, - isQuery :: Bool - } deriving Show - -ircWrite :: Handle -> String -> String -> IO () -ircWrite h s t = do - printf "> %s %s\n" s t - hPrintf h "%s %s\r\n" s t - -ircPrivMsg :: Handle -> IrcMessage -> Env -> String -> IO () -ircPrivMsg h msg env@(Env state _) s = do - ircPrivMsg' $ if isMultiline s then (lines s) else [s] - where - ircPrivMsg' [] = return () - ircPrivMsg' (x:xs) = - let maxMessageSize = - envGetInt "maxMessageSize" env - receiver = - if (isQuery msg) - then from msg - else currentChannel state - in if length x > maxMessageSize - then do - ircWrite h "PRIVMSG" (receiver ++ " :" - ++ (take maxMessageSize x) ++ "...") - ircWrite h "PRIVMSG" (receiver ++ " :" - ++ "...this message has been cut to " - ++ (show maxMessageSize) ++ " chars") - ircPrivMsg' xs - else do - ircWrite h "PRIVMSG" (receiver ++ " :" ++ x) - ircPrivMsg' xs - -ircStart :: Env -> IO () -ircStart (DispatchEnv state conf dispatch) = do - ircChannel <- get "ircChannel" conf - ircNick <- get "ircNick" conf - ircPort <- get "ircPort" conf - ircServer <- get "ircServer" conf - ircUser <- get "ircUser" conf - h <- connectTo ircServer (PortNumber $ fromIntegral (read ircPort :: Int)) - hSetBuffering h NoBuffering - ircWrite h "NICK" ircNick - ircWrite h "USER" $ ircNick ++ " 0 * :" ++ ircUser - ircEvalLoop h (DispatchEnv state { currentChannel = ircChannel } conf dispatch) - return () - -ircEvalLoop :: Handle -> Env -> IO () -ircEvalLoop h env = do - t <- hGetLine h - let s = init t - env' <- branch s - ircEvalLoop h env' - where - branch s - | ping s = do { pong s; return (env) } - | otherwise = ircEval h (msg s) env - ping x = "PING :" `isPrefixOf` x - pong x = ircWrite h "PONG" (':' : drop 6 x) - from = drop 1 . takeWhile (/= '!') - clean = drop 1 . dropWhile (/= ':') . drop 1 - isQuery x = split x ' ' !! 2 == (envGet "ircNick" env) - msg s = IrcMessage { - raw = s, from = from s, - clean = clean s, isQuery = isQuery s - } - -ircEval :: Handle -> IrcMessage -> Env -> IO Env -ircEval h msg env@(DispatchEnv state _ dispatch) = ircEval' (clean msg) - where - ircEval' "+x" = do - ircWrite h "JOIN" (currentChannel state) - return (env) - ircEval' cleanMsg = do - (Env s c) <- dispatch cleanMsg sendReplyMsg (castEnv env) - return (DispatchEnv s c dispatch) - sendReplyMsg = ircPrivMsg h msg (castEnv env) - diff --git a/HsBot/Start.hs b/HsBot/Start.hs index 228092a..97466d8 100644 --- a/HsBot/Start.hs +++ b/HsBot/Start.hs @@ -5,7 +5,7 @@ import System import HsBot.Cmd import HsBot.Conf import HsBot.Env -import HsBot.IRC.IRConnection +import HsBot.IRC import HsBot.Logics import HsBot.State import HsBot.General.Tools -- cgit v1.2.3