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

2 files changed, 124 insertions, 0 deletions

diff --git a/HsBot/IRC/Connection.hs b/HsBot/IRC/Connection.hs
new file mode 100644
index 0000000..c4fa7a9
--- /dev/null
+++ b/HsBot/IRC/Connection.hs
@@ -0,0 +1,96 @@
+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.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/User.hs b/HsBot/IRC/User.hs
new file mode 100644
index 0000000..cd6d55f
--- /dev/null
+++ b/HsBot/IRC/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)
+