Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 249 lines (221 sloc) 11.52 kb
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 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249
;;;; Demo Clojure IRC server
;;;; Limitations:
;;;; No server-server connect
;;;; Only partially implemented basic commands (channel and private messages)
;;;; no channel modes, no ops, no bans
;;;; Straightforward algorithms, no optimisation
;;;; User-id is lowercased nickname. It changes and it is exposed to user instead of nickname.
;;;;
;;;; Implemented by Vitaly "_Vi" Shukela; 2010; MIT License.

(ns irc
 (:import (java.io BufferedReader InputStreamReader OutputStreamWriter))
 (:use server.socket)
 (:use [clojure.string :only [split join upper-case lower-case trim blank?]])
 (:gen-class))

;; state
(def users (ref {}))
(def channels (ref {}))
(def channel-topics (ref {}))

;; print info to stdout (*out* is overridden)
(defn log [& args] (. java.lang.System/out println (apply str (interpose "|\t" args))))

;; server to client communication
(defn irc-reply [user code text & args] "Prints text like \":irc.clj 251 q :There are 2 users on the server\""
 (locking *out* (print (format ":irc.clj %s %s %s\r\n" code user (apply format text args)))))

(defn ^{:private true} ircmsg2-impl [from cmd msg]
 (locking *out* (print (format ":%s %s %s\r\n" from cmd msg)) (flush) ))

(defn irc-event "Print text like \":_Vi JOIN #qqq :User joined the channel\""
 ([from cmd solearg] (ircmsg2-impl from cmd (str ":" solearg)))
 ([from cmd arg & args] (ircmsg2-impl from cmd (str (join " " (cons arg (butlast args))) " :" (last args)))))

(defn greet [newuser] "Welcome message for user (after \"NICK\" command)"
 (irc-reply newuser "001" "Welcome to _Vi's Clojure IRC \"server\"")
 (irc-reply newuser "002" "I don't know what your host is")
 (irc-reply newuser "003" "I don't know when this server was created")
 (irc-reply newuser "004" "irc.clj 0.1 ")
 (irc-reply newuser "005" "PREFIX=(ov)@+ NETWORK=demo CHANTYPES=# : are supported by this demo")
 (irc-reply newuser "251" ":There are %d users on the server." (count (dosync @users)))
 (irc-reply newuser "254" "%d :channels formed" (count (dosync @channels)))
 (irc-reply newuser "375" "MoTH")
 (irc-reply newuser "376" "End of MoTH"))

(defmacro try-output-to [writer# & code]
 `(try
     (binding [*out* ~writer#]
      ~@code)
     (catch Exception e# (.printStackTrace e#))))

(defn broadcast [function] "Send message to all users. Argument is closure to execute."
 (doall (map #(try-output-to (get (second %1) :out)
           (function)) (dosync @users))))

(defn channel-multicast "Send message to all channel participants (except of ignore-user). Argument is closure to execute"
 ([channel function ignore-user]
  (doall (map #(when (not= %1 ignore-user)
        (try-output-to (get (get (dosync @users) %1) :out)
         (function)))
      channel)))
 ([channel function] (channel-multicast channel function nil)))



;; state update functions

(defn remove-user! [user-id]
 (dosync (alter users #(dissoc %1 user-id))))
(defn add-user! [user-id nick] "Add user. If already exists returns true"
 (dosync
  (if (contains? @users user-id)
   true
   (do (alter users #(conj %1 {user-id {:nick nick, :out *out*, :user-id user-id}})) false)
  )))
(defn change-nick-on-all-channels! [old-user-id new-user-id]
 (dosync (alter channels #(into {} (for [[k v] %1] [k (if (contains? v old-user-id) (conj (disj v old-user-id) new-user-id) v)])))))
(defn remove-user-from-channels [user-id]
  (dosync (alter channels #(into {} (for [[k v] %1] [k (disj v user-id)])))))
(defn join-channel! [user-id channel] "Create channel or add user to it"
 (dosync
  (alter channel-topics (fn [chs] (update-in chs [channel] #(if %1 %1 ""))))
  (alter channels (fn[chs] (update-in chs [channel] #(conj (set %1) user-id))))))
(defn part-channel! [user-id channel] "Remove user from channel. Returns false if channel does not exist"
 (dosync
  (if (contains? @channels channel)
   (do (alter channels (fn[chs] (update-in chs [channel] #(disj %1 user-id)))) true)
   false)))
(defn update-channel-topic! [channel new-topic] "Update topic on channel. Returns false if no such channel"
 (dosync
  (if (contains? @channels channel)
   (do (alter channel-topics (fn[chs] (update-in chs [channel] (fn[_]new-topic)))) true)
   false)))



(defn get-user-id [nick] (lower-case (trim nick)))



;; IRC command handlers

(defmulti command (fn [^String user command-name & args] command-name))
    (defmethod command "NICK"
     ([user _] (irc-reply user "431" ":No nickname given") user)
     ([user _ nick & args] (irc-reply user "431" ":Extra arguments for NICK") user)
     ([user _ nick]
       (if (re-find #"^[\]\[{}\\|_^a-zA-Z][\]\[{}\\|_^a-zA-Z0-9\-]{0,255}$" nick)
    (let [user-id (get-user-id nick)
     already-present (add-user! user-id nick)]
     (if already-present
      (do
       (irc-reply user "433" "%s :Nickname already in use." nick)
       user)
      (do
       (if (= user "*")
        (greet nick) ; if it is the first "NICK" command in this session then greet user
        (let [old-user-id (get-user-id user)] ; else it is renaming
         (remove-user! old-user-id)
         (broadcast #(irc-event user "NICK" nick))
         (change-nick-on-all-channels! old-user-id user-id)))
       nick)))
    (do
     (irc-reply user "432" "%s :Erroneous Nickname: Nickname should match [][{}\\|_^a-zA-Z][][{}\\|_^a-zA-Z0-9-]{0,255}" nick)
     user))))
    (defmethod command "PRIVMSG"
     ([user _ recepient message]
      (let [ruser-id (get-user-id recepient)]
       (if (= (first ruser-id) \#)
    (let [chs (dosync @channels)]
     (if (contains? chs ruser-id)
      (channel-multicast (get chs ruser-id) #(irc-event user "PRIVMSG" recepient message) (get-user-id user))
      (irc-reply user "401" "%s :No such nick/channel" recepient)))
    (let [usrs (dosync @users)]
     (if (contains? usrs ruser-id)
      (try-output-to (get (get usrs ruser-id) :out)
       (irc-event user "PRIVMSG" recepient message))
      (irc-reply user "401" "%s :No such nick/channel" recepient))))))
      ([user _] (irc-reply user "412" ":Not enought arguments for PRIVMSG"))
      ([user _ recepient] (irc-reply user "412" ":Not enought arguments for PRIVMSG"))
      ([user _ recepient message & args] (irc-reply user "412" ":Extra arguments for PRIVMSG")))
    (defmethod command "JOIN"
     ([user _ channel-name]
      (let [channel (get-user-id channel-name)]
       (if (re-find #"^#[\#\]\[{}\\|_^a-z0-9]{0,29}$" channel)
    (do
     (join-channel! (get-user-id user) channel)
     (let [chs (dosync @channels), ch (get chs channel)]
      (channel-multicast ch #(irc-event user "JOIN" channel "User joined the channel"))
      (irc-reply user "332" "%s :%s" channel (dosync (get @channel-topics channel)))
      ;(irc-reply user "333" "%s :none 0" channel)
      (irc-reply user "353" "@ %s :%s" channel (join " " ch))
      (irc-reply user "366" "%s :End of /NAMES list." channel)
      ))
    (irc-reply user "479" "%s :Illegal channel name" channel) )))
      ([user _] (irc-reply user "412" ":Not enought arguments for JOIN"))
      ([user _ channel & args] (irc-reply user "412" ":Extra arguments for JOIN")))
    (defmethod command "PART"
     ([user _ channel-name message]
       (let [channel (get-user-id channel-name), user-id (get-user-id user)]
    (if(part-channel! user-id channel)
     (broadcast #(irc-event user "PART" channel message))
     (irc-reply user "403" "%s :No such channel" channel))))
      ([user _] (irc-reply user "412" ":Not enought arguments for PART"))
      ([user _ channel message & args] (irc-reply user "412" ":Extra arguments for PART"))
      ([user _ channel] (command user "PART" channel "User have left this channel")))
    (defmethod command "TOPIC"
     ([user _ channel-name new-topic]
      (let [channel (get-user-id channel-name)]
       (if (update-channel-topic! channel new-topic)
    (broadcast #(irc-event user "TOPIC" channel new-topic))
    (irc-reply user "403" (format "%s :No such channel" channel)))))
      ([user _] (irc-reply user "412" ":Not enought arguments for TOPIC"))
      ([user _ channel] (irc-reply user "332" "%s :%s" channel (dosync (get @channel-topics channel))))
      ([user _ channel topic & args] (irc-reply user "412" ":Extra arguments for TOPIC")))
    (defmethod command :default [user cmd-name & args]
     (irc-reply user "421" "%s: Unknown command" cmd-name))
    (defmethod command "TEST" [user & args]
     (doall (map #(irc-reply user "421" "TEST :Parameter is \"%s\"" %) args)))
    (defmethod command "PING" [user _ & args]
      (println ":irc.clj PONG irc.lcj :irc.clj"))
    (defmethod command "LIST" [user _ & args]
     (doall (for [[k v] (dosync @channels)] (irc-reply user "322" (format "%s %d :%s" k (count v) (dosync (get @channel-topics k)))) ))
     (irc-reply user "323" ":End of /LIST"))
    (defmethod command "DEBUG" [user _ & args]
     (irc-reply user "000" (format ": Debug %s" (dosync [@users @channels @channel-topics]))))
    (defmethod command "USER" [user _ & args])
    (defmethod command "QUIT" [user _ & args])
    (defmethod command "MODE" [user _ & args])
    (defmethod command "" [user _ & args])

(defn unregister-user [user]
 (let [user-id (get-user-id user)]
  (remove-user! user-id)
  (broadcast #(irc-event user "QUIT" user "Connection closed"))
  (remove-user-from-channels user-id)))



(defn parse-irc-command-line [^String line] "Returns vector: command name and it's arguments, all strings. Sole empty string on empty input"
 (let [
  colon-search-result (re-find #"(.*):(.*)" line)
  ; the list of splittable parameters (including the command name) we need to split by ' ' and the final parameter after ':' (it may be nil)
  [splittable-parameters final-parameter-as-vector]
   (if colon-search-result
    #_"example: TOPIC #qqq :Qqq qq!" [(nth colon-search-result 1) [(nth colon-search-result 2)]]
    #_"example: TOPIC #qqq Qqq" [line nil]) ]
  (into (into [] (split (trim splittable-parameters) #"\s+")) final-parameter-as-vector)))

(defn execute-irc-command-line [user ^String line] "Returns nick (possibly updated by \"NICK\" command)"
 (let [[command-name-pre & args] (parse-irc-command-line line)
  command-name (upper-case command-name-pre)]
  (if (and (= user "*") (not (contains? #{"NICK" "DEBUG" "QUIT" "PING" ""} command-name)))
   (do (irc-reply user "451" ":You are not registered") user)
   (let [new-user (apply command user command-name args)]
    (case command-name
     "NICK" new-user
     "QUIT" (str "~" user)
     user)))))

(defn irc-server [port]
 (letfn [(irc [in out]
      (binding [*in* (BufferedReader. (InputStreamReader. in))
       *out* (OutputStreamWriter. out)]
       (irc-reply "*" "439" ":Supply your NICK to procceed")
       (flush)
       (loop [user "*"]
        (if (not= (first user) \~); User becomes "~User" on QUIT command
         (let [line (read-line)]
          (if line
           (do
        (log user line)
        (recur (try
            (let [user (execute-irc-command-line user line)]
             (flush)
             user)
            (catch Exception e (.printStackTrace e) (irc-reply user "400" ":Error") (flush) user))))
           (recur (str "~" user))))
         (unregister-user (#_"removes the first character" apply str (next user)))))))]
  (create-server port irc)))

(defn -main []
 (let [
   envport (System/getenv "IRC_PORT")
   port (if envport (Integer. envport) 6667)
   ]
 (log (str "IRC_PORT=" envport " ; using port " port))
 (irc-server port)))
Something went wrong with that request. Please try again.