simple kitty-server

kitty-server2.lfe

(defmodule kitty-server2
  (export all))

(defrecord cat
  name
  (color 'green)
  description)

(defun start-link ()
  (my-server:start-link (MODULE) ()))

(defun order-cat (pid name color description)
  (my-server:call pid (tuple 'order name color description)))

(defun return-cat
  ((pid (= (match-cat) cat ))
   (my-server:cast pid (tuple 'return cat))))

(defun close-shop (pid)
  (my-server:call pid 'terminate))

(defun init
  (('()) ()))

(defun handle-call
  (((tuple 'order name color description) from cats)
   (if (=:= cats '())
     (progn
       (my-server:reply from (make-cat* name color description))
       cats)
     (progn
       (my-server:reply from (hd cats))
       (tl cats))))

  (('terminate from cats)
   (progn
     (my-server:reply from 'ok)
     (terminate cats))))

(defun handle-cast
  (((tuple 'return (= (match-cat) cat)) cats)
   (cons cat cats)))

(defun terminate (cats)
  (lc ((<- c cats)
       (io:format "~p was set free.~n" (list (cat-name c))))
    (exit 'normal)))

(defun make-cat* (name color description)
  (make-cat name name color color description description))

my-server.lfe

(defmodule my-server
  (export all))

(defun start (module initial-state)
  (spawn (lambda ()
           (init module initial-state))))

(defun start-link (module initial-state)
  (spawn_link (lambda ()
                (init module initial-state))))

(defun call (pid msg)
  (let ((ref (monitor 'process pid)))
    (! pid (tuple 'sync (self) ref msg))
    (receive
      ((tuple ref reply)
       (progn
         (demonitor ref '(flush))
         reply))
      ((tuple 'DOWN ref 'process pid reason)
       (error reason))
      (after 5000
        (error 'timeout)))))

(defun cast (pid msg)
  (! pid (tuple 'async msg))
  'ok)

(defun reply
  (((tuple pid ref) reply)
   (! pid (tuple ref reply))))

(defun init (module initial-state)
  (loop module (call module 'init initial-state)))

(defun loop (module state)
  (receive
    ((tuple 'async msg)
     (loop module (call module 'handle-cast msg state)))
    ((tuple 'sync pid ref msg)
     (loop module (call module 'handle-call msg (tuple pid ref) state)))))