git-svn-id: https://ssl.buetow.org/repos/hsbot/trunk@45 9f8f72e9-4bf4-416e-b76e-7d4203597157

13 files changed, 550 insertions, 0 deletions

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
+