From 3911a1935535df6d65694339e7f7140714379b56 Mon Sep 17 00:00:00 2001 From: pb Date: Sun, 28 Mar 2010 10:42:32 +0000 Subject: git-svn-id: https://ssl.buetow.org/repos/hsbot/trunk@45 9f8f72e9-4bf4-416e-b76e-7d4203597157 --- HsBot/AI.hs | 6 ++ HsBot/Cmd.hs | 16 +++++ HsBot/Conf.hs | 28 ++++++++ HsBot/Env.hs | 19 ++++++ HsBot/HsBot.hs | 205 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ HsBot/IRC.hs | 96 ++++++++++++++++++++++++++ HsBot/Karma.hs | 21 ++++++ HsBot/Render.hs | 5 ++ HsBot/Start.hs | 51 ++++++++++++++ HsBot/State.hs | 32 +++++++++ HsBot/Tools.hs | 32 +++++++++ HsBot/User.hs | 28 ++++++++ Main.hs | 11 +++ 13 files changed, 550 insertions(+) create mode 100644 HsBot/AI.hs create mode 100644 HsBot/Cmd.hs create mode 100644 HsBot/Conf.hs create mode 100644 HsBot/Env.hs create mode 100644 HsBot/HsBot.hs create mode 100644 HsBot/IRC.hs create mode 100644 HsBot/Karma.hs create mode 100644 HsBot/Render.hs create mode 100644 HsBot/Start.hs create mode 100644 HsBot/State.hs create mode 100644 HsBot/Tools.hs create mode 100644 HsBot/User.hs create mode 100644 Main.hs diff --git a/HsBot/AI.hs b/HsBot/AI.hs new file mode 100644 index 0000000..9deaca4 --- /dev/null +++ b/HsBot/AI.hs @@ -0,0 +1,6 @@ +module HsBot.AI (aiRun) where + +import HsBot.Env + +aiRun :: String -> Env -> IO Env +aiRun str env = return (env) diff --git a/HsBot/Cmd.hs b/HsBot/Cmd.hs new file mode 100644 index 0000000..7de643e --- /dev/null +++ b/HsBot/Cmd.hs @@ -0,0 +1,16 @@ +module HsBot.Cmd where + +import HsBot.State + +data Cmd = Cmd String String (State -> IO ()) + +instance Show Cmd where + show (Cmd a b _) = a ++ " - " ++ b + +cmdGet :: String -> [Cmd] -> Maybe Cmd +cmdGet x commands = + let command = [ (Cmd a b c) | (Cmd a b c) <- commands, a == x ] + in if length command == 0 + then Nothing + else Just (head command) + diff --git a/HsBot/Conf.hs b/HsBot/Conf.hs new file mode 100644 index 0000000..2faed0b --- /dev/null +++ b/HsBot/Conf.hs @@ -0,0 +1,28 @@ +module HsBot.Conf where + +import qualified Data.Map as M + +type Conf = M.Map String String + +makeConf = M.fromList + [ ("name", "HsBot") + , ("version", "v0.0") + , ("databaseFile", "hsbot.db") + , ("maxMessageSize", "400") + , ("admin", "rantanplan") + , ("ircServer", "irc.german-elite.net") + , ("ircChannel", "#buetow.org") + , ("ircNick", "hotdog") + , ("ircPort", "6667") + , ("ircUser", "hsbot.haskell.eu") + ] + +get :: (Monad m) => String -> Conf -> m String +get = M.lookup + +getUnwrappedInt :: String -> Conf -> Int +getUnwrappedInt key conf = read (getUnwrapped key conf) :: Int + +getUnwrapped :: String -> Conf -> String +getUnwrapped key conf = do { val <- get key conf; val } + diff --git a/HsBot/Env.hs b/HsBot/Env.hs new file mode 100644 index 0000000..e8f6092 --- /dev/null +++ b/HsBot/Env.hs @@ -0,0 +1,19 @@ +module HsBot.Env where + +import HsBot.Conf +import HsBot.State + +type Dispatch = String -> (String -> IO ()) -> Env -> IO Env +data Env = DispatchEnv State Conf Dispatch | Env State Conf + +castEnv :: Env -> Env +castEnv (DispatchEnv state conf _) = Env state conf + +envGetInt :: String -> Env -> Int +envGetInt key (Env _ conf) = getUnwrappedInt key conf +envGetInt key env = envGetInt key (castEnv env) + +envGet :: String -> Env -> String +envGet key (Env _ conf) = getUnwrapped key conf +envGet key env = envGet key (castEnv env) + diff --git a/HsBot/HsBot.hs b/HsBot/HsBot.hs new file mode 100644 index 0000000..2c33a83 --- /dev/null +++ b/HsBot/HsBot.hs @@ -0,0 +1,205 @@ +--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..28fc9f0 --- /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.Tools +import HsBot.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/Karma.hs b/HsBot/Karma.hs new file mode 100644 index 0000000..939b782 --- /dev/null +++ b/HsBot/Karma.hs @@ -0,0 +1,21 @@ +module HsBot.Karma where + +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) + diff --git a/HsBot/Render.hs b/HsBot/Render.hs new file mode 100644 index 0000000..1dc78ba --- /dev/null +++ b/HsBot/Render.hs @@ -0,0 +1,5 @@ +module HsBot.Render where + +class Render a where + render :: a -> String + diff --git a/HsBot/Start.hs b/HsBot/Start.hs new file mode 100644 index 0000000..cf87404 --- /dev/null +++ b/HsBot/Start.hs @@ -0,0 +1,51 @@ +module HsBot.Start (start) where + +import System + +import HsBot.AI +import HsBot.Cmd +import HsBot.Conf +import HsBot.Env +import HsBot.IRC +import HsBot.State +import HsBot.Tools + +start :: IO () +start = do + let conf = makeConf + databaseFile <- get "databaseFile" conf + let state = stateLoad databaseFile + state' <- state -- Extract State from the IO Monad + ircStart (DispatchEnv state' conf dispatch) + +dispatch :: Dispatch +dispatch msg sendMessage env@(Env state conf) = dispatch' msg + where + dispatch' ('!':_) = + case cmdGet msg commands of + Just (Cmd _ _ cmdAction) -> do + cmdAction state + return (env) + Nothing -> return (env) + dispatch' _ = aiRun msg env + commands = [ + Cmd "!h" "Prints help" printHelp, + Cmd "!i" "Prints infos" printInfos, + Cmd "!p" "Prints current state" printState, + Cmd "!s" "Stores current state to file" storeState, + Cmd "!q" "quits" quit + ] + printHelp _ = printHelp' commands + where printHelp' = sendMessage . concat . showL + printInfos _ = do + sendMessage $ (envGet "name" env) + ++ " " ++ (envGet "version" env) + ++ " (try !h)" + printState = sendMessage . show + storeState state = do + sendMessage "Storing current state" + stateSave (envGet "databaseFile" env) state + quit state = do + sendMessage "Good bye" + stateSave (envGet "databaseFile" env) state + exitWith ExitSuccess diff --git a/HsBot/State.hs b/HsBot/State.hs new file mode 100644 index 0000000..93ca7ef --- /dev/null +++ b/HsBot/State.hs @@ -0,0 +1,32 @@ +module HsBot.State where + +import qualified Data.Map as M + +import List +import HsBot.User + +data State = State { + currentChannel :: String, + line :: String, + users :: [User] + } deriving (Show, Read) + +stateNumUsers :: State -> Int +stateNumUsers state = length $ users state + +stateSortedUsers :: State -> [User] +stateSortedUsers state = sort $ users state + +stateLoad :: String -> IO State +stateLoad databaseFile = do + file <- readFile databaseFile + return ( read file :: State ) + +stateSave :: String -> State -> IO () +stateSave databaseFile = writeFile databaseFile . show + +stateSaveIO :: String -> IO State -> IO () +stateSaveIO databaseFile state = do + state' <- state + writeFile databaseFile (show state') + diff --git a/HsBot/Tools.hs b/HsBot/Tools.hs new file mode 100644 index 0000000..6f66994 --- /dev/null +++ b/HsBot/Tools.hs @@ -0,0 +1,32 @@ +module HsBot.Tools where + +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 + +contains :: String -> Char -> Bool +contains str char = takeWhile (/= char) str /= str + +isMultiline :: String -> Bool +isMultiline str = contains str '\n' + +showL :: Show a => [a] -> [String] +showL = map (\x -> show x ++ "\n") + diff --git a/HsBot/User.hs b/HsBot/User.hs new file mode 100644 index 0000000..cd6d55f --- /dev/null +++ b/HsBot/User.hs @@ -0,0 +1,28 @@ +module HsBot.User where + +import List + +import HsBot.Karma +import HsBot.Render + +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) + +instance Render User where + render user = userName user ++ ": " ++ + (show $ userPts user) ++ "pts" + +userEquals :: User -> User -> Bool +userEquals x y = (userName x) == (userName y) + diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..87d765a --- /dev/null +++ b/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import HsBot.Start + +main :: IO () +main = start + +-- Shortcut +r :: IO () +r = main + -- cgit v1.2.3