5 import System.IO -- base
6 import qualified Network.Socket as N -- network
7 import Control.Monad.Trans.Reader -- transformers
8 import Control.Monad.IO.Class
11 import Control.Exception
13 data Bot = Bot { botSocket :: Handle }
14 type Net = ReaderT Bot IO
17 type Realname = String
20 runBirch :: String -> N.PortNumber -> String -> [String] -> IO ()
21 runBirch myServer myPort myNick myChannels = bracket
22 (connect myServer myPort)
26 disconnect = hClose . botSocket
27 loop st = runReaderT (run myNick "tutorial bot") st
30 connect :: String -> N.PortNumber -> IO Bot
31 connect myServer myPort = notify $ do
32 h <- connectTo myServer myPort
36 (putStrLn ("Connecting to " ++ myServer ++ " ...") >> hFlush stdout)
40 -- Connect to a server given its name and port number
41 connectTo :: N.HostName -> N.PortNumber -> IO Handle
42 connectTo host port = do
43 addr : _ <- N.getAddrInfo Nothing (Just host) (Just (show port))
44 sock <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr)
45 N.connect sock (N.addrAddress addr)
46 N.socketToHandle sock ReadWriteMode
48 -- Join a channel, and start processing commands
49 run :: Nick -> Realname -> Net ()
50 run myNick myRealname = do
51 register myNick myRealname
54 -- Send a message to a handle
55 write :: String -> String -> Net ()
58 let msg = cmd ++ " " ++ args ++ "\r\n"
59 liftIO $ hPutStr h msg -- Send message on the wire
60 liftIO $ putStr ("> " ++ msg) -- Show sent message on the command line
62 -- Process each line from the server
66 line <- liftIO $ hGetLine h
67 liftIO $ putStrLn line
69 if isPing s then pong s else eval (clean s)
71 forever :: Net () -> Net ()
72 forever a = do a; forever a
74 clean :: String -> String
75 clean = drop 1 . dropWhile (/= ':') . drop 1
77 isPing :: String -> Bool
78 isPing x = "PING :" `isPrefixOf` x
80 pong :: String -> Net ()
81 pong x = write "PONG" (':' : drop 6 x)
84 eval :: String -> Net ()
85 eval "!quit" = write "QUIT" ":Exiting" >> liftIO exitSuccess
87 | "!id " `isPrefixOf` x = privmsg (drop 4 x)
88 eval _ = return () -- ignore everything else
90 -- Send a privmsg to a channel
91 privmsg :: String -> Net ()
92 privmsg msg = write "PRIVMSG" ("#nais-testing" ++ " :" ++ msg)
94 -- Register with the server
95 register :: Nick -> Realname -> Net ()
96 register nick realname = do
98 sendUSER nick realname
101 sendNICK :: Nick -> Net ()
102 sendNICK = write "NICK"
105 sendUSER :: Nick -> Realname -> Net ()
106 sendUSER nick realname = write "USER" (nick ++ " 0 * :" ++ realname)