added irc functionality

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

3 files changed, 146 insertions, 81 deletions

diff --git a/HsBot.hs b/HsBot.hs
index eaf5f83..f766df5 100644
--- a/HsBot.hs
+++ b/HsBot.hs
@@ -6,12 +6,14 @@ module Main where
 import IO
 import System
 
+import List
+import Network
+import System.IO
+import Text.Printf
+
 -- Static configurations
 
-version :: String
 version = "v0.0"
-
-database :: String
 database = "hsbot.db"
 
 -- logfile :: String
@@ -36,13 +38,28 @@ 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,
       line :: String, 
       loggs :: [String], 
       maxLoggs :: Int, 
       users :: [User], 
-      karmas :: [Karma] } 
-   deriving (Show, Read)
+      karmas :: [Karma] 
+   } deriving (Show, Read)
 
 data User = User { 
       userName :: String,
@@ -68,8 +85,8 @@ instance Render User where
 		(show $ userPts user) ++ "pts; " ++ 
 		(show $ userPerc user) ++ "%)"
 
-loggMessage :: String -> Conf -> Conf
-loggMessage message conf = 
+loggIrcMessage :: String -> Conf -> Conf
+loggIrcMessage message conf = 
    let l = message : (loggs conf)
        l' | (length l) > (maxLoggs conf) = init l
 		    | otherwise = l
@@ -119,9 +136,9 @@ 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)
+--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 = 
@@ -141,6 +158,9 @@ split (c:cs) delim
    	| 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
@@ -163,7 +183,7 @@ matches search string = uniq $ case m' $ occ search string of
 	    m' Nothing = ([], [])
 
 processInput :: Conf -> Conf
-processInput conf = addAll --loggMessage "foo" conf
+processInput conf = addAll --loggIrcMessage "foo" conf
 	where add :: [User] -> [User]
 	      add [] = []
 	      add (u:[]) = addUserKarma 1 u : []
@@ -172,28 +192,36 @@ processInput conf = addAll --loggMessage "foo" conf
 	      plus = matches "++" (line conf)
 	      minus = matches "--" (line conf)
 
-loop :: IO Conf -> IO ()
-loop conf = 
-   let loop' :: Conf -> IO ()
-       loop' conf = do
-          line <- readInput 
-          getLambda line conf -- Executing the specific lambda function of 'commands'
-       printHelp = putStr . foldr (++) "" . map (\(a,b,_) -> "\t" ++ a ++ " - " ++ b ++ "\n") 
-       getLambda x = let (_, _, c) = getCommand x in c
-       getDescr x = let (_, b, _) = getCommand x in b
-       getCommand x = 
-         let command = [ (a, b, c) | (a, b, c) <- commands, a == x ]
-          in if length command == 0
-               then getCommand "!h" -- If there is no such command print out the help
-               else head command
-         where commands = [      
-          	("!h", "Prints help ", (\x -> do { printHelp commands; loop' x } ) ),
-          	("!l", "Prints loggs", (\x -> do { printLoggs x; loop' x } ) ),
-          	("!p", "Prints configuration", (\x -> do { putStrLn $ show x; loop' x } ) ),
-          	("!s", "Saves configuration", (\x -> do { putStrLn "Saving current xiguration"; save x; loop' x } ) ),
-          	("!q", "Quits", (\x -> do { putStrLn "Good bye"; save x; exitWith ExitSuccess } ) )]
-    in do conf' <- conf -- Extract Conf from the IO Monad and run loop' with pure input
-          loop' conf'
+data Command = Command String String (Conf -> IO ()) 
+
+instance Show Command where
+   show (Command a b _) = "\t" ++ a ++ " - " ++ b ++ "\n"
+
+loop :: Conf -> IO ()
+loop conf = do
+   line <- readInput 
+   getLambda line conf -- Eval the specific lambda function of 'isCommands'
+      where
+         isCommands = [      
+            Command "!h" "Prints help" 
+               (\x -> do { printHelp isCommands; loop x } ),
+            Command "!l" "Prints loggs" 
+               (\x -> do { printLoggs x; loop x } ),
+            Command "!p" "Prints configuration" 
+               (\x -> do { putStrLn $ show x; loop x } ),
+            Command "!s" "Saves configuration" 
+               (\x -> do { putStrLn "Saving current configuration"; save x; loop x } ),
+            Command "!q" "quits"
+               (\x -> do { putStrLn "Good bye"; save x; exitWith ExitSuccess } ) 
+            ]
+         printHelp = putStr . foldr (++) "" . map show
+         getLambda x = let (Command _ _ c) = getCommand x in c
+         getDescr x = let (Command _ b _) = getCommand x in b
+         getCommand x = 
+               let isCommand = [ (Command a b c) | (Command a b c) <- isCommands, a == x ]
+                in if length isCommand == 0
+                     then getCommand "!h" -- If there is no such isCommand print out the help
+                     else head isCommand
 
 -- Will be connected to IRC input in future instead of getLine
 readInput :: IO String
@@ -201,8 +229,16 @@ readInput = getLine
 
 main :: IO ()	
 main = do
-	putStrLn $ "Welcome to HsBot " ++ version ++ " (Enter !h for help)"
-	loop load
+   putStrLn $ "Welcome to HsBot " ++ version ++ " (Enter !h for help)"
+   let conf = load
+   conf' <- conf -- Extract Conf from the IO Monad 
+   connect conf'
+   --loop conf' -- and run loop with 'pure' input
+
+load :: IO Conf
+load = do
+   file <- readFile database
+   return ( read file :: Conf )
 
 save :: Conf -> IO ()
 save = writeFile database . show
@@ -212,45 +248,81 @@ saveIO conf = do
    conf' <- conf
    writeFile database (show conf')
 
-load :: IO Conf
-load = do
-   file <- readFile database
-   return ( read file :: Conf )
+makeIOConf :: IO Conf
+makeIOConf = return (makeConf)
 
-makeTestConf :: Conf
-makeTestConf = Conf {
+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
+
+write :: Handle -> String -> String -> IO ()
+write h s t = do
+   hPrintf h   "%s %s\r\n" s t
+   printf      "> %s %s\n" s t
+
+listen :: Handle -> Conf -> IO ()
+listen h conf = forever $ do
+      t <- hGetLine h
+      let s = init t
+      if ping s 
+         then pong s 
+         else let msg = IrcMessage { 
+                  raw = s,
+                  from = from s, 
+                  clean = clean s, 
+                  isQuery = isQuery s }
+               in eval h msg 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)
+
+isCommand :: String -> Maybe String
+isCommand ('!':xs) = Just xs
+isCommand _ = Nothing
+
+eval :: Handle -> IrcMessage -> Conf-> IO ()
+eval h msg conf = 
+   case isCommand (clean msg) of
+      Just xs -> evalCommand h xs msg conf
+      Nothing -> evalServerMessage (clean msg)
+   where
+      evalServerMessage "+x" = write h "JOIN" (channel $ irc conf)
+      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?") 
+      | otherwise = privmsg h "No such command!" 
+   where
+      privmsg h s = 
+         let receiver = if (isQuery msg) 
+                           then from msg 
+                           else channel $ irc conf
+          in write h "PRIVMSG" (receiver ++ " :" ++ s)
+
+-- 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 = [
-		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
-
-makeIOConf :: IO Conf
-makeIOConf = return (makeConf)
-
+	users = [ ],
+	karmas = [ ]
+} 
diff --git a/Main.hs b/Main.hs
deleted file mode 100644
index 8333078..0000000
--- a/Main.hs
+++ /dev/null
@@ -1,7 +0,0 @@
--- Karmabot By Paul C. Buetow
-
-module Main (main) where
-
-import HsBot
-
-main = start
diff --git a/hsbot.db b/hsbot.db
index 884103e..45a0a3c 100644
--- a/hsbot.db
+++ b/hsbot.db
@@ -1 +1 @@
-Conf {line = "!w\DELs", loggs = [], maxLoggs = 10, users = [User {userName = "thunder", userPts = 103},User {userName = "otto", userPts = 4},User {userName = "rantanplan", userPts = 102},User {userName = "rantanplan2", userPts = 6},User {userName = "icefox2", userPts = 14},User {userName = "icefox", userPts = 13},User {userName = "foobar", userPts = 8},User {userName = "foobar1", userPts = 8},User {userName = "foobar2", userPts = 8},User {userName = "foobar3", userPts = 8},User {userName = "foobar4", userPts = 8},User {userName = "foobar5", userPts = 8},User {userName = "foobar6", userPts = 8},User {userName = "openfire", userPts = 5}], karmas = [Karma {karmaName = "God", minPts = 20, minPerc = 90.0},Karma {karmaName = "Guru", minPts = 10, minPerc = 80.0},Karma {karmaName = "Nerd", minPts = 10, minPerc = 70.0},Karma {karmaName = "Expert", minPts = 5, minPerc = 60.0},Karma {karmaName = "Geek", minPts = 3, minPerc = 40.0},Karma {karmaName = "Advanced", minPts = 0, minPerc = 20.0},Karma {karmaName = "Cool dude", minPts = 0, minPerc = 0.0}]}
\ No newline at end of file
+Conf {irc = IrcConnection {server = "irc.german-elite.net", port = 6667, channel = "#buetow.org", nick = "hsbot"}, line = "!w\DELs", loggs = [], maxLoggs = 10, users = [User {userName = "thunder", userPts = 103},User {userName = "otto", userPts = 4},User {userName = "rantanplan", userPts = 102},User {userName = "rantanplan2", userPts = 6},User {userName = "icefox2", userPts = 14},User {userName = "icefox", userPts = 13},User {userName = "foobar", userPts = 8},User {userName = "foobar1", userPts = 8},User {userName = "foobar2", userPts = 8},User {userName = "foobar3", userPts = 8},User {userName = "foobar4", userPts = 8},User {userName = "foobar5", userPts = 8},User {userName = "foobar6", userPts = 8},User {userName = "openfire", userPts = 5}], karmas = [Karma {karmaName = "God", minPts = 20, minPerc = 90.0},Karma {karmaName = "Guru", minPts = 10, minPerc = 80.0},Karma {karmaName = "Nerd", minPts = 10, minPerc = 70.0},Karma {karmaName = "Expert", minPts = 5, minPerc = 60.0},Karma {karmaName = "Geek", minPts = 3, minPerc = 40.0},Karma {karmaName = "Advanced", minPts = 0, minPerc = 20.0},Karma {karmaName = "Cool dude", minPts = 0, minPerc = 0.0}]}