Source file Irc_server.ml
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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
let name = "tiny"
type user = { mutable nick : string option; mutable registered : bool; mutable user_given : bool }
type t = {
server : Server.t;
users : (int, user) Hashtbl.t;
mutable channels : (string * int list) list;
}
let create (caps : < Cap.network ; .. >) ?(bind = "127.0.0.1") ?(port = 6667) () : t * int =
let server, port = Server.listen caps ~bind ~port () in
({ server; users = Hashtbl.create 16; channels = [] }, port)
let wait (t : t) (timeout : float) : unit = Server.wait t.server timeout
let nicks (t : t) : string list =
Hashtbl.fold (fun _ u acc -> match u.nick with Some n when u.registered -> n :: acc | _ -> acc) t.users [] |> List.sort compare
let nick_of_id (t : t) (id : int) : string =
match Hashtbl.find_opt t.users id with Some { nick = Some n; _ } -> n | _ -> "*"
let channels (t : t) : (string * string list) list = List.map (fun (c, ids) -> (c, List.map (nick_of_id t) ids)) t.channels
let send (t : t) (id : int) (m : Irc.message) : unit = Server.send t.server id (Irc.print m)
let reply (t : t) (id : int) (code : string) (params : string list) : unit =
send t id (Irc.msg ~prefix:name code (nick_of_id t id :: params))
let prefix (t : t) (id : int) : string =
let n = nick_of_id t id in
Printf.sprintf "%s!%s@%s" n n name
let members (t : t) (channel : string) : int list = Option.value (List.assoc_opt channel t.channels) ~default:[]
let neighbours (t : t) ~(self : bool) (id : int) : int list =
List.concat_map (fun (_, ids) -> if List.mem id ids then ids else []) t.channels
|> List.sort_uniq compare
|> List.filter (fun o -> self || o <> id)
let find_nick (t : t) (nick : string) : int option =
Hashtbl.fold
(fun id u acc -> if u.nick <> None && String.lowercase_ascii (Option.get u.nick) = String.lowercase_ascii nick then Some id else acc)
t.users None
let names (t : t) (id : int) (channel : string) : unit =
reply t id "353" [ "="; channel; String.concat " " (List.map (nick_of_id t) (members t channel)) ];
reply t id "366" [ channel; "End of NAMES list" ]
let part (t : t) (id : int) (channel : string) (reason : string) : unit =
if List.mem id (members t channel) then begin
List.iter (fun o -> send t o (Irc.msg ~prefix:(prefix t id) "PART" [ channel; reason ])) (members t channel);
t.channels <-
List.filter_map
(fun (c, ids) -> if c = channel then (match List.filter (( <> ) id) ids with [] -> None | ids -> Some (c, ids)) else Some (c, ids))
t.channels
end
let quit (t : t) (id : int) (reason : string) : unit =
List.iter (fun o -> send t o (Irc.msg ~prefix:(prefix t id) "QUIT" [ reason ])) (neighbours t ~self:false id);
t.channels <-
List.filter_map (fun (c, ids) -> match List.filter (( <> ) id) ids with [] -> None | ids -> Some (c, ids)) t.channels;
Hashtbl.remove t.users id
let command (t : t) (id : int) (u : user) (m : Irc.message) : unit =
match (m.command, m.params) with
| "NICK", nick :: _ -> (
match find_nick t nick with
| Some other when other <> id -> reply t id "433" [ nick; "Nickname is already in use" ]
| _ ->
let before = prefix t id in
if u.registered then
List.iter (fun o -> send t o (Irc.msg ~prefix:before "NICK" [ nick ])) (neighbours t ~self:true id);
u.nick <- Some nick;
if u.user_given && not u.registered then begin
u.registered <- true;
reply t id "001" [ Printf.sprintf "Welcome to TinyIRC, %s" nick ]
end)
| "USER", _ :: _ ->
u.user_given <- true;
if u.nick <> None && not u.registered then begin
u.registered <- true;
reply t id "001" [ Printf.sprintf "Welcome to TinyIRC, %s" (nick_of_id t id) ]
end
| "PING", token :: _ -> send t id (Irc.msg ~prefix:name "PONG" [ name; token ])
| "QUIT", params ->
quit t id (match params with r :: _ -> r | [] -> "Quit");
Server.close t.server id
| _, _ when not u.registered -> reply t id "451" [ "You have not registered" ]
| "JOIN", channels :: _ ->
List.iter
(fun channel ->
if String.length channel > 1 && channel.[0] = '#' && not (List.mem id (members t channel)) then begin
t.channels <-
(if List.mem_assoc channel t.channels then List.map (fun (c, ids) -> if c = channel then (c, ids @ [ id ]) else (c, ids)) t.channels
else t.channels @ [ (channel, [ id ]) ]);
List.iter (fun o -> send t o (Irc.msg ~prefix:(prefix t id) "JOIN" [ channel ])) (members t channel);
names t id channel
end)
(String.split_on_char ',' channels)
| "PART", channels :: rest ->
List.iter (fun c -> part t id c (match rest with r :: _ -> r | [] -> "")) (String.split_on_char ',' channels)
| "NAMES", channel :: _ -> names t id channel
| "PRIVMSG", [ target; text ] ->
if String.length target > 0 && target.[0] = '#' then
if List.mem id (members t target) then
List.iter (fun o -> if o <> id then send t o (Irc.msg ~prefix:(prefix t id) "PRIVMSG" [ target; text ])) (members t target)
else reply t id "404" [ target; "Cannot send to channel" ]
else (
match find_nick t target with
| Some other -> send t other (Irc.msg ~prefix:(prefix t id) "PRIVMSG" [ target; text ])
| None -> reply t id "401" [ target; "No such nick/channel" ])
| command, _ -> reply t id "421" [ command; "Unknown command" ]
let step (t : t) : unit =
List.iter
(fun (e : Server.event) ->
match e with
| Joined id -> Hashtbl.replace t.users id { nick = None; registered = false; user_given = false }
| Message (id, payload) -> (
match Hashtbl.find_opt t.users id with
| None -> ()
| Some u ->
String.split_on_char '\n' payload
|> List.filter (fun l -> String.trim l <> "")
|> List.iter (fun line -> match Irc.parse line with Ok m -> command t id u m | Error _ -> ()))
| Left id -> if Hashtbl.mem t.users id then quit t id "Connection closed")
(Server.step t.server);
Server.flush t.server