diff options
| -rw-r--r-- | src/Lib.hs | 90 |
1 files changed, 54 insertions, 36 deletions
@@ -5,28 +5,37 @@ module Lib import System.IO -- base import qualified Network.Socket as N -- network import Control.Monad.Trans.Reader -- transformers +import Control.Monad.IO.Class import Data.List import System.Exit +import Control.Exception data Bot = Bot { botSocket :: Handle } type Net = ReaderT Bot IO type Nick = String -type User = String type Realname = String -- Toplevel program runBirch :: String -> N.PortNumber -> String -> [String] -> IO () -runBirch myServer myPort myNick myChannels = do +runBirch myServer myPort myNick myChannels = bracket + (connect myServer myPort) + disconnect + loop + where + disconnect = hClose . botSocket + loop st = runReaderT (run myNick "tutorial bot") st + + +connect :: String -> N.PortNumber -> IO Bot +connect myServer myPort = notify $ do h <- connectTo myServer myPort - register h myNick "tutorial bot" - line <- hGetLine h - putStrLn line - let s = init line - if isPing s then pong h s else eval h (clean s) --- map (write h "JOIN") myChannels - write h "JOIN" (head myChannels) - listen h + return (Bot h) + where + notify a = bracket_ + (putStrLn ("Connecting to " ++ myServer ++ " ...") >> hFlush stdout) + (putStrLn "done.") + a -- Connect to a server given its name and port number connectTo :: N.HostName -> N.PortNumber -> IO Handle @@ -36,22 +45,30 @@ connectTo host port = do N.connect sock (N.addrAddress addr) N.socketToHandle sock ReadWriteMode +-- Join a channel, and start processing commands +run :: Nick -> Realname -> Net () +run myNick myRealname = do + register myNick myRealname + listen + -- Send a message to a handle -write :: Handle -> String -> String -> IO () -write h cmd args = do +write :: String -> String -> Net () +write cmd args = do + h <- asks botSocket let msg = cmd ++ " " ++ args ++ "\r\n" - hPutStr h msg -- Send message on the wire - putStr ("> " ++ msg) -- Show sent message on the command line + liftIO $ hPutStr h msg -- Send message on the wire + liftIO $ putStr ("> " ++ msg) -- Show sent message on the command line -- Process each line from the server -listen :: Handle -> IO () -listen h = forever $ do - line <- hGetLine h - putStrLn line +listen :: Net () +listen = forever $ do + h <- asks botSocket + line <- liftIO $ hGetLine h + liftIO $ putStrLn line let s = init line - if isPing s then pong h s else eval h (clean s) + if isPing s then pong s else eval (clean s) where - forever :: IO () -> IO () + forever :: Net () -> Net () forever a = do a; forever a clean :: String -> String @@ -60,29 +77,30 @@ clean = drop 1 . dropWhile (/= ':') . drop 1 isPing :: String -> Bool isPing x = "PING :" `isPrefixOf` x -pong :: Handle -> String -> IO () -pong h x = write h "PONG" (':' : drop 6 x) +pong :: String -> Net () +pong x = write "PONG" (':' : drop 6 x) -- Dispatch a command -eval :: Handle -> String -> IO () -eval h "!quit" = write h "QUIT" ":Exiting" >> exitSuccess -eval h x | "!id " `isPrefixOf` x = privmsg h (drop 4 x) -eval _ _ = return () -- ignore everything else +eval :: String -> Net () +eval "!quit" = write "QUIT" ":Exiting" >> liftIO exitSuccess +eval x + | "!id " `isPrefixOf` x = privmsg (drop 4 x) +eval _ = return () -- ignore everything else -- Send a privmsg to a channel -privmsg :: Handle -> String -> IO () -privmsg h s = write h "PRIVMSG" ("#nais-testing" ++ " :" ++ s) +privmsg :: String -> Net () +privmsg msg = write "PRIVMSG" ("#nais-testing" ++ " :" ++ msg) -- Register with the server -register :: Handle -> Nick -> Realname -> IO () -register h nick realname = do - sendNICK h nick - sendUSER h nick realname +register :: Nick -> Realname -> Net () +register nick realname = do + sendNICK nick + sendUSER nick realname -- Send NICK command -sendNICK :: Handle -> Nick -> IO () -sendNICK h nick = write h "NICK" nick +sendNICK :: Nick -> Net () +sendNICK = write "NICK" -- Send USER command -sendUSER :: Handle -> Nick -> Realname -> IO () -sendUSER h nick realname = write h "USER" (nick ++ " 0 * :" ++ realname) +sendUSER :: Nick -> Realname -> Net () +sendUSER nick realname = write "USER" (nick ++ " 0 * :" ++ realname) |