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

1 files changed, 133 insertions, 2 deletions

diff --git a/IRC.hs b/IRC.hs
index 6897c71..25d2b34 100644
--- a/IRC.hs
+++ b/IRC.hs
@@ -1,10 +1,141 @@
 module IRC where
 
 import IO
-import System
-
 import List
 import Network
+import System
 import System.IO
 import Text.Printf
 
+import Conf
+import State
+import Tools
+import User
+
+load :: String -> IO State
+load databaseFile = do
+   file <- readFile databaseFile
+   return ( read file :: State )
+
+save :: State -> IO ()
+save = writeFile database . show
+
+saveIO :: IO State -> IO ()
+saveIO state = do
+   state' <- state
+   writeFile database (show state')
+
+makeIOState :: IO State
+makeIOState = return (makeState)
+
+-- Will be removed some day:
+makeState :: State
+makeState = State { channel = "", line = "", users = [ ], karmas = [ ] } 
+---
+
+data IrcMessage = IrcMessage {
+      raw :: String,
+      from :: String,
+      clean :: String,
+      isQuery :: Bool
+   } deriving Show
+
+ircWrite :: Handle -> String -> String -> IO ()
+ircWrite h s t = do
+   hPrintf h   "%s %s\r\n" s t
+   printf      "> %s %s\n" s t
+
+ircPrivmsg :: Handle -> IrcMessage -> State -> Conf -> String -> IO ()
+ircPrivmsg h msg state conf s = 
+      if isMultiline s then ircPrivmsg' (lines s) else ircPrivmsg' [s]
+   where
+      ircPrivmsg' [] = return ()
+      ircPrivmsg' (x:xs) =
+         let receiver = if (isQuery msg) then from msg else channel 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
+
+ircConnect :: State -> Conf -> IO ()
+ircConnect state conf = 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 state { channel = ircChannel } conf
+
+ircEvalLoop :: Handle -> State -> Conf -> IO ()
+ircEvalLoop h state 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 ircEval h msg state conf
+   where 
+      forever a = do a; forever a
+      from = drop 1 . takeWhile (/= '!') 
+      clean = drop 1 . dropWhile (/= ':') . drop 1
+      isQuery x = split x ' ' !! 2 == ircNick
+         where ircNick = do { ircNick <- get "ircNick" conf; ircNick } 
+      ping x = "PING :" `isPrefixOf` x
+      pong x = ircWrite h "PONG" (':' : drop 6 x)
+
+ircEval :: Handle -> IrcMessage -> State -> Conf -> IO ()
+ircEval h msg state conf = 
+   case isCommand (clean msg) of
+      Just xs -> dispatch h xs msg state conf
+      Nothing -> ircEvalServerMessage (clean msg)
+   where
+      isCommand ('!':xs) = Just xs
+      isCommand _ = Nothing
+      ircEvalServerMessage "+x" = do
+            ircChannel <- get "ircChannel" conf
+            ircWrite h "JOIN" ircChannel
+      ircEvalServerMessage _ = putStrLn $ show msg
+
+data Command = Command String String (State -> IO ()) 
+instance Show Command where 
+   show (Command a b _) = a ++ " - " ++ b
+
+dispatch :: Handle -> String -> IrcMessage -> State -> Conf -> IO ()
+dispatch h cmd msg state conf = do
+   getLambda ("!" ++ cmd) state -- Eval the specific lambda function of 'command'
+      where
+         commands = [      
+            Command "!h" "Prints help" 
+               (\_ -> do { printHelp commands } ),
+            Command "!i" "Prints infos" 
+               (\_ -> do { sendMessage $ name ++ " " ++ version ++ " (try !h)"} ),
+            Command "!p" "Prints stateiguration" 
+               (\x -> do { sendMessage $ show x } ),
+            Command "!s" "Saves stateiguration" 
+               (\x -> do { sendMessage "Saving current stateiguration"; save x; } ),
+            Command "!q" "quits"
+               (\x -> do { sendMessage "Good bye"; save x; exitWith ExitSuccess } ) 
+            ]
+         sendMessage = ircPrivmsg h msg state conf
+         printHelp = sendMessage . concat . showL 
+         getLambda x = let (Command _ _ c) = getCommand x in c
+         getDescr x = let (Command _ b _) = getCommand x in b
+         getCommand x = 
+               let command = [ (Command a b c) | (Command a b c) <- commands, a == x ]
+                in if length command == 0
+                     then getCommand "!i" 
+                     else head command
+