;;; A simple application that acts as a very primitive time server and
;;; client.
(import '(java.net BindException ServerSocket Socket)
'(java.lang.reflect InvocationTargetException)
'(java.util Date)
'(java.io InputStream OutputStream StringWriter)
'(java.util.concurrent Executors))
;;; Globals
(def DEFAULT-PORT 51345)
;; A structure defining the data in a unit test, as well as a global
;; list of all the tests.
(defstruct unit-test :name :description :function :after)
(def ALL-TESTS {})
;;; Testing functions
;; Unit test accessors
(def unit-test-name (accessor unit-test :name))
(def unit-test-description (accessor unit-test :description))
(def unit-test-function (accessor unit-test :function))
(def unit-test-after (accessor unit-test :after))
;; Add a new test structure to the list of unit tests, or replaces the
;; existing test of that name if it already exists.
(defn unit-tests-add [test]
(def ALL-TESTS
(assoc ALL-TESTS (unit-test-name test) test)))
;; Takes an unsorted and a sorted list of unit tests and moves / sorts
;; some of the tests in the unsorted list over to the sorted list
(defn unit-test-list-helper [unsorted sorted]
(let [nils (filter (comp not unit-test-after)
unsorted)
alls (filter (comp (appl eql? :all) unit-test-after)
unsorted)
others (filter (fn [t] (not-any? (fn [x] (eql? (unit-test-after t)
(unit-test-after x)))
(concat nils alls)))
unsorted)
in-sorted (fn [t] (some (fn [x] (eql? (unit-test-name x)
(unit-test-after t)))
(concat nils sorted)))]
(cond (first nils)
(list (concat alls
(filter (complement in-sorted)
others))
(concat nils
(filter in-sorted others)))
(== (count alls)
(count unsorted))
(list nil
(concat sorted alls))
:t
(list (concat alls
(filter (complement in-sorted)
others))
(concat sorted
(filter in-sorted others))))))
;; Returns a list of unit tests, sorted according to their :after
;; statement.
(defn unit-test-list
([]
(unit-test-list (vals ALL-TESTS) nil))
([unsorted sorted]
(if (not (first unsorted))
(map (fn [test] (list (unit-test-description test)
(unit-test-function test)))
sorted)
(let [helped-list (unit-test-list-helper unsorted sorted)
unsorted (first helped-list)
sorted (second helped-list)]
(recur unsorted sorted)))))
;; Run all the defined tests
(defn test-all []
(let [test-out (new StringWriter)]
(loop [test-list (unit-test-list)
failure false]
(let [test (first test-list)
test-list (rest test-list)]
(cond (not test)
(do (if failure
(println "---\nSome tests failed.")
(println "---\nAll tests passed."))
(list failure test-out))
:t
(let [test-result (time (binding [*out* test-out]
(eval (list (second test)))))]
(println "Testing" (first test) ":" test-result)
(recur test-list
(when (or (not test-result)
failure)
true))))))))
;; Define a testing function. Same syntax as defn, only with a
;; description string and a list of extras (may be empty)
(defmacro deftest [fname description extras & fdecl]
`(do (defn ~fname ~@fdecl)
(unit-tests-add (struct unit-test
:name (name '~fname)
:description ~description
:function ~fname
~@extras))
#'~fname))
;;; Utility functions
(defn current-time []
(str (new Date)))
;; Generate an array of bytes from a string, suitable for passing to a
;; write() method.
;;
;; Has a unit test.
(defn byte-arr-from-string [#^String str]
(. str (getBytes)))
(deftest test-byte-array-from-string "string->byte array conversion" ()
([]
(test-byte-array-from-string (current-time)))
([str]
(let [barr (byte-arr-from-string str)
bseq (map (comp char (appl aget barr))
(range (alength barr)))
chseq (map char str)]
(and (== (alength barr)
(count bseq)
(count chseq))
(some true?
(map eql?
bseq
chseq))))))
;; Takes a sequence of bytes (not a byte array, but a sequence) and
;; concatenates it into a string.
(defn string-from-byte-sequence [coll]
(reduce strcat
(map char coll)))
;; Gets the integer length of a string. Returns nil for "" and nil.
(defn #^Int length-of-string [#^String string]
(if string
(. string (length))
0))
;;; Listener functions
;;; These control the server
;; Make a new listener. Returns that listener or nil if no listener
;; can be created on that port.
;;
;; Has a unit test.
(defn #^ServerSocket listener-new
([]
(listener-new DEFAULT-PORT))
([port]
(try (new ServerSocket port)
(catch BindException except
(println "Address is already in use.")))))
(deftest test-listener-new "creating a listener" ()
([]
(test-listener-new DEFAULT-PORT))
([port]
(with-open listener (listener-new port)
(when listener
true))))
;; Logical predicates for whether a listener is open or closed.
;;
;; Have unit tests.
(defn #^Boolean listener-closed? [#^ServerSocket listener]
(. listener (isClosed)))
(def listener-open? (complement listener-closed?))
(deftest test-listener-predicates "listener open?/closed? predicates"
(:after "test-listener-new")
([]
(test-listener-predicates DEFAULT-PORT))
([port]
(let [listener (listener-new port)
tests (and (not (listener-closed? listener))
(listener-open? listener))]
(. listener (close))
(and tests
(not (listener-open? listener))
(listener-closed? listener)))))
;; Wait for a connection to a given listener the return the socket to
;; that connection.
;;
;; NOTE: This function is blocking.
(defn #^Socket listener-wait [#^ServerSocket listener]
(. listener (accept)))
;; Closes a given listener. Really only for use from the REPL or from
;; unit tests, as actual code should be using (with-open ...)
;;
;; Has a unit test.
(defn listener-close [#^ServerSocket listener]
(. listener (close)))
(deftest test-listener-close "closing a listener"
(:after "test-listener-predicates")
([]
(let [listener (listener-new DEFAULT-PORT)]
(and (listener-open? listener)
(not (listener-close listener))
(listener-closed? listener)))))
;; Takes a socket, sends the current time through it, closes the
;; socket's output and returns the socket.
(defn #^Socket listener-send [#^Socket lsocket]
(.. lsocket
(getOutputStream)
(write (byte-arr-from-string (current-time))))
(.. lsocket (getOutputStream) (close))
lsocket)
;; Launches the supplied listener and then loops, waiting for
;; connections.
;;
;; NOTE: Because it depends of (listener-wait ...), which is blocking,
;; this is qlso blocking.
(defn listener-run [listener port]
(loop [socket nil]
(if (listener-closed? listener)
listener
(do (when socket
(. (listener-send socket) (close)))
(recur (listener-wait listener))))))
;; Launches a listener as a background thread. Returns that listener.
(defn listener-run-in-background
([]
(listener-run-in-background DEFAULT-PORT))
([port]
(let [listener (listener-new port)
exec (. Executors (newSingleThreadExecutor))
run (appl listener-run listener port)]
(when listener
(. exec (submit run)))
listener)))
;;; Connection functions
;;; These control the client.
;; Makes a new connection to a listener. Times out in 5 seconds if no
;; connection is made.
;;
;; Has a unit test.
(defn connection-new
([]
(connection-new DEFAULT-PORT))
([port]
(connection-new "127.0.0.1" port))
([address port]
(try (doto (new Socket address port)
(setSoTimeout 5000))
(catch InvocationTargetException except
(println (strcat "Could not connect to "
address
" on port "
port))))))
(deftest test-connection-new "creating a connection"
(:after "test-listener-close")
([]
(let [listener (listener-run-in-background)
connection (connection-new)]
(and (connection-new)
(not (listener-close listener))
(not (connection-new))))))
;; Reads data from a supplied socket as an array of bytes. Stops on
;; timeout and when receiving the -1 end of stream byte.
(defn connection-read [#^Socket conn]
(let [instream (. conn (getInputStream))
reader (fn [] (try (. instream (read))
(catch InvocationTargetException except
-1)))]
(loop [bytes nil
current-byte (reader)]
(if (== current-byte -1)
bytes
(recur (concat bytes (list current-byte))
(reader))))))
;; Closes an open socket.
(defn connection-close [#^Socket conn]
(. conn (close)))
;; Opens a connection to a listener, reads out a byte sequence, then
;; returns that sequence as a string.
;;
;; Has a unit test.
(defn connection-run
([]
(connection-run DEFAULT-PORT))
([port]
(let [conn (connection-new port)
str (when conn
(string-from-byte-sequence (connection-read conn)))]
(when conn
(connection-close conn))
str)))
(deftest test-connection-run "running a complete connection"
(:after :all)
([]
(let [listener (listener-run-in-background)
result (connection-run)]
(and (listener-open? listener)
(not (listener-close listener))
(listener-closed? listener)
(<= 0 (length-of-string result))
(== 0 (length-of-string (connection-run)))))))
0 comments:
Post a Comment