Mercurial > lasercutter

     1 ;;  Copyright (c) Craig McDaniel, Jan 2009. All rights reserved.

     2 ;;  The use and distribution terms for this software are covered by the

     3 ;;  Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)

     4 ;;  which can be found in the file epl-v10.html at the root of this distribution.

     5 ;;  By using this software in any fashion, you are agreeing to be bound by

     6 ;;  the terms of this license.

     7 ;;  You must not remove this notice, or any other, from this software.

     8 

     9 ;;  Server socket library - includes REPL on socket

    10 

    11 (ns 

    12   ^{:author "Craig McDaniel",

    13      :doc "Server socket library - includes REPL on socket"}

    14   clojure.contrib.server-socket

    15   (:import (java.net InetAddress ServerSocket Socket SocketException)

    16            (java.io InputStreamReader OutputStream OutputStreamWriter PrintWriter)

    17            (clojure.lang LineNumberingPushbackReader))

    18   (:use [clojure.main :only (repl)]))

    19  

    20 (defn- on-thread [f]

    21   (doto (Thread. ^Runnable f) 

    22     (.start)))

    23 

    24 (defn- close-socket [^Socket s]

    25   (when-not (.isClosed s)    

    26     (doto s

    27       (.shutdownInput)

    28       (.shutdownOutput)

    29       (.close))))

    30 

    31 (defn- accept-fn [^Socket s connections fun]

    32   (let [ins (.getInputStream s)

    33         outs (.getOutputStream s)]

    34     (on-thread #(do

    35                   (dosync (commute connections conj s))

    36                   (try

    37                    (fun ins outs)

    38                    (catch SocketException e))

    39                   (close-socket s)

    40                   (dosync (commute connections disj s))))))

    41 

    42 (defstruct server-def :server-socket :connections)

    43 

    44 (defn- create-server-aux [fun ^ServerSocket ss]

    45   (let [connections (ref #{})]

    46     (on-thread #(when-not (.isClosed ss)

    47                   (try 

    48                    (accept-fn (.accept ss) connections fun)

    49                    (catch SocketException e))

    50                   (recur)))

    51     (struct-map server-def :server-socket ss :connections connections)))

    52  

    53 (defn create-server 

    54   "Creates a server socket on port. Upon accept, a new thread is

    55   created which calls:

    56 

    57   (fun input-stream output-stream)

    58 

    59   Optional arguments support specifying a listen backlog and binding

    60   to a specific endpoint."

    61   ([port fun backlog ^InetAddress bind-addr] 

    62      (create-server-aux fun (ServerSocket. port backlog bind-addr)))

    63   ([port fun backlog]

    64      (create-server-aux fun (ServerSocket. port backlog)))

    65   ([port fun]

    66      (create-server-aux fun (ServerSocket. port))))

    67 

    68 (defn close-server [server]

    69   (doseq [s @(:connections server)]

    70     (close-socket s))

    71   (dosync (ref-set (:connections server) #{}))

    72   (.close ^ServerSocket (:server-socket server)))

    73 

    74 (defn connection-count [server]

    75   (count @(:connections server)))

    76 

    77 ;;;; 

    78 ;;;; REPL on a socket

    79 ;;;; 

    80 

    81 (defn- socket-repl [ins outs]

    82   (binding [*in* (LineNumberingPushbackReader. (InputStreamReader. ins))

    83             *out* (OutputStreamWriter. outs)

    84             *err* (PrintWriter. ^OutputStream outs true)]

    85     (repl)))

    86 

    87 (defn create-repl-server 

    88   "create a repl on a socket"

    89   ([port backlog ^InetAddress bind-addr] 

    90      (create-server port socket-repl backlog bind-addr))

    91   ([port backlog] 

    92      (create-server port socket-repl backlog))

    93   ([port] 

    94      (create-server port socket-repl)))
author	Robert McIntyre <rlm@mit.edu>
date	Sat, 21 Aug 2010 06:25:44 -0400
parents
children