~technomancy/taverner

taverner/server.fnl -rw-r--r-- 5.3 KiB
a86534a4Phil Hagelberg When notifying of nick changes, send user as well. a month ago
                                                                                
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
(local socket (require :socket))
(local lume (require :lume))

(local commands (require :commands))
(local valid (require :valid))

(fn ppcall [f ...]
  (let [args [...]
        vals [(xpcall #(f (table.unpack args)) #(print $ (debug.traceback)))]]
    (if (. vals 1)
        (select 2 (table.unpack vals)))))

(fn parse-params [params out]
  (if (= params "") out
      (params:match "^:(.*)") (doto out (table.insert (params:sub 2)))
      (match (params:match "^([^ ]+) *(.*)")
        (param rest) (parse-params rest (doto out (table.insert param)))
        _ out)))

(fn parse [line]
  (match-try (line:match "^@([^ ]+) +(.*)") ; discard tags
    nil (line:match "^:([^ ]+) +(.*)") ; discard source
    nil (line:match "^([^ ]+) *(.*)")
    (cmd params) (values cmd (parse-params params []))
    (catch
     (_ rest) (parse rest))))

(fn disconnect [state cstate msg]
  (state.log "Disconnected" cstate.nick msg)
  (each [_ ch (pairs state.channels)]
    (when (ch.member? cstate.nick)
      (ch.part cstate.nick)))
  (tset state.clients cstate.conn nil)
  (cstate.conn:close))

(fn unknown-command [state cstate command-name]
  ;; Silence that irritating ascii bel character
  (state.log "Unknown command" cstate.nick (command-name:gsub "\a" ""))
  (state:send cstate :421 ":Unknown command" command-name))

(fn loop-client [state cstate]
  (coroutine.yield)
  (match-try (cstate.conn:receive :*l)
    line (parse line)
    (command-name params) (commands.get command-name)
    command (ppcall command state cstate (table.unpack params))
    (catch
     (_ :timeout) nil
     (_ :closed) (pcall disconnect state cstate "connection closed")
     (_ msg) (unknown-command state cstate msg)))
  (loop-client state cstate))

(fn introduce [state cstate]
  (fn send [cmd ...] (state:send cstate cmd ...))
  (state.log "Client identified as" cstate.nick cstate.user)

  (send :001 ":Welcome to Taverner" cstate.nick)
  (send :002 ":Your host is" state.name "running version" state.version)
  (send :003 ":This server was created at" state.started)
  (send :004 state.hostname (.. "taverner-" state.version) "bovkmst")
  (send :005 "NETWORK=nil :are supported on this server")
  ;; LUSERS                        adding extra nil here to shut up linter
  (send :251 "There are" (tostring (lume.count state.clients nil))
        "users and 0 services on one server.")
  (send :252 "0 :operators online")
  (send :253 "0 :unknown connections")
  (send :254 (tostring (lume.count state.channels nil)) ":channels formed")
  (send :255 ":I have" (tostring (lume.count state.clients nil))
        "clients and 0 servers")
  ;; MOTD
  (send :375 :- state.hostname "Message of the Day -")
  (send :372 :- state.motd)
  (send :376 ":End of /MOTD command.")
  (loop-client state cstate))

(fn start-client [state cstate]
  (match (cstate.conn:receive :*l)
    line (match (parse line)
           ("NICK" [nick]) (valid.set state cstate :nick nick)
           ("USER" [user]) (valid.set state cstate :user user)
           ("PASS" [pass]) (valid.set state cstate :pass pass)
           command-name (unknown-command state cstate command-name))
    (nil :closed) (pcall disconnect state cstate :closed))
  (coroutine.yield)
  (if (and cstate.nick cstate.user (or (not state.pass) cstate.pass))
      (introduce state cstate)
      ;; if you've been connected 5 minutes without identifying, disconnect
      (< 300 (- (os.time) cstate.connected-at))
      (pcall disconnect state cstate "Timed out identifying")
      (start-client state cstate)))

(fn accept [state conn]
  (conn:settimeout state.timeout)
  (let [cstate {: conn :connected-at (os.time)}]
    (state.log "Accepting connection!")
    (set cstate.coro (coroutine.create start-client))
    (coroutine.resume cstate.coro state cstate)
    (tset state.clients conn cstate)))

(fn loop [mod server state]
  ;; TODO: use select instead of the naive approach
  (socket.sleep state.timeout)
  (match (server:accept)
    conn (accept state conn)
    (nil :timeout) (each [k cstate (pairs state.clients)]
                     (match (coroutine.resume cstate.coro state)
                       (false err) (pcall disconnect state cstate err)))
    (nil err) (state.log "E:" err))
  (each [_ ch (pairs state.channels)]
    (ppcall ch.flush))
  (mod.loop mod server state))

(fn send [state {: conn : nick &as cstate} command-name ...]
  (let [msg (.. ":" state.name " " command-name " " (or nick :Unknown) " "
                (table.concat [...] " ") "\r\n")]
    (match (conn:send msg)
      (_ err) (pcall disconnect state cstate err))))

(fn connected? [state nick]
  (not (not (lume.match state.clients #(= nick $.nick)))))

(fn start [mod {: port : host : name :  motd : hostname : ops : plugins : pass}]
  (let [server (assert (socket.bind host port nil))
        state {:clients {} : send : name : motd : hostname : connected? : pass
               :log print :version "0.0.2-dev" :timeout 0.001 :channels []
               :start-time (os.time) :started (os.date) : accept : parse : ops}]
    (state.log "Listening on port" port)
    (server:settimeout state.timeout)
    (each [_ plugin-name (ipairs (or plugins []))]
      (let [plugin (require plugin-name)]
        (plugin.init state)))
    (set _G.state state) ; for the repl and only the repl
    (loop mod server state))) ; pass the module table for reload support

{: start : accept : loop : parse}