From 561aa6d45ed2c7dc6cd177bab5c31f6d8fccde66 Mon Sep 17 00:00:00 2001 From: pb Date: Sun, 28 Mar 2010 10:34:23 +0000 Subject: git-svn-id: https://ssl.buetow.org/repos/hsbot/trunk@44 9f8f72e9-4bf4-416e-b76e-7d4203597157 --- AI.hs | 6 ---- Cmd.hs | 16 ----------- Conf.hs | 28 ------------------- Env.hs | 19 ------------- IRC.hs | 96 --------------------------------------------------------------- Karma.hs | 21 -------------- Main.hs | 55 ------------------------------------ Render.hs | 5 ---- State.hs | 32 --------------------- Tools.hs | 32 --------------------- User.hs | 28 ------------------- 11 files changed, 338 deletions(-) delete mode 100644 AI.hs delete mode 100644 Cmd.hs delete mode 100644 Conf.hs delete mode 100644 Env.hs delete mode 100644 IRC.hs delete mode 100644 Karma.hs delete mode 100644 Main.hs delete mode 100644 Render.hs delete mode 100644 State.hs delete mode 100644 Tools.hs delete mode 100644 User.hs diff --git a/AI.hs b/AI.hs deleted file mode 100644 index bcae182..0000000 --- a/AI.hs +++ /dev/null @@ -1,6 +0,0 @@ -module AI (aiRun) where - -import Env - -aiRun :: String -> Env -> IO Env -aiRun str env = return (env) diff --git a/Cmd.hs b/Cmd.hs deleted file mode 100644 index 3e85e86..0000000 --- a/Cmd.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Cmd where - -import 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/Conf.hs b/Conf.hs deleted file mode 100644 index 9db9c19..0000000 --- a/Conf.hs +++ /dev/null @@ -1,28 +0,0 @@ -module 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/Env.hs b/Env.hs deleted file mode 100644 index bb6a0b8..0000000 --- a/Env.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Env where - -import Conf -import 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/IRC.hs b/IRC.hs deleted file mode 100644 index d516e3f..0000000 --- a/IRC.hs +++ /dev/null @@ -1,96 +0,0 @@ -module IRC (ircStart) where - -import IO -import List -import Network -import System -import System.IO -import Text.Printf - -import Conf -import Env -import State -import Tools -import 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/Karma.hs b/Karma.hs deleted file mode 100644 index 9093936..0000000 --- a/Karma.hs +++ /dev/null @@ -1,21 +0,0 @@ -module 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/Main.hs b/Main.hs deleted file mode 100644 index 4bd88dc..0000000 --- a/Main.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Main where - -import System - -import AI -import Cmd -import Conf -import Env -import IRC -import State -import Tools - -main :: IO () -main = 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) - --- Shortcut -r :: IO () -r = main - -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/Render.hs b/Render.hs deleted file mode 100644 index 924040b..0000000 --- a/Render.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Render where - -class Render a where - render :: a -> String - diff --git a/State.hs b/State.hs deleted file mode 100644 index 8ab8e33..0000000 --- a/State.hs +++ /dev/null @@ -1,32 +0,0 @@ -module State where - -import qualified Data.Map as M - -import List -import 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/Tools.hs b/Tools.hs deleted file mode 100644 index e28d4f9..0000000 --- a/Tools.hs +++ /dev/null @@ -1,32 +0,0 @@ -module 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/User.hs b/User.hs deleted file mode 100644 index ba1a58c..0000000 --- a/User.hs +++ /dev/null @@ -1,28 +0,0 @@ -module User where - -import List - -import Karma -import 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) - -- cgit v1.2.3