blob: 0a30efa113c5aeb584785981a1e9e5494587ae44 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
module Lib
( runBirch
) where
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 Realname = String
-- Toplevel program
runBirch :: String -> N.PortNumber -> String -> [String] -> IO ()
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
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
connectTo host port = do
addr : _ <- N.getAddrInfo Nothing (Just host) (Just (show port))
sock <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr)
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 :: String -> String -> Net ()
write cmd args = do
h <- asks botSocket
let msg = cmd ++ " " ++ args ++ "\r\n"
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 :: Net ()
listen = forever $ do
h <- asks botSocket
line <- liftIO $ hGetLine h
liftIO $ putStrLn line
let s = init line
if isPing s then pong s else eval (clean s)
where
forever :: Net () -> Net ()
forever a = do a; forever a
clean :: String -> String
clean = drop 1 . dropWhile (/= ':') . drop 1
isPing :: String -> Bool
isPing x = "PING :" `isPrefixOf` x
pong :: String -> Net ()
pong x = write "PONG" (':' : drop 6 x)
-- Dispatch a command
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 :: String -> Net ()
privmsg msg = write "PRIVMSG" ("#nais-testing" ++ " :" ++ msg)
-- Register with the server
register :: Nick -> Realname -> Net ()
register nick realname = do
sendNICK nick
sendUSER nick realname
-- Send NICK command
sendNICK :: Nick -> Net ()
sendNICK = write "NICK"
-- Send USER command
sendUSER :: Nick -> Realname -> Net ()
sendUSER nick realname = write "USER" (nick ++ " 0 * :" ++ realname)
|
