trade fsm

trade-call.lfe

(defmodule trade-call
  (export all))

(defun sync1 (pid)
  (! pid (self))
  (receive
    ('ack 'ok)))

(defun sync2 ()
  (receive
    (from (! from 'ack))))

(defun main-ab ()
  (let* ((s (self))
         (pid-client-a (spawn (lambda () (a s))))
         (pid-a (receive
                  (pid-a pid-a))))
    (spawn (lambda ()
             (b pid-a pid-client-a)))))

(defun a (parent)
  (let ((`#(ok ,pid) (trade-fsm:start-link "Carl")))
    (! parent pid)
    (io:format "Spawned Carl: ~p~n" `(,pid))
    ;;(sys:trace pid 'true)
    (timer:sleep 800)
    (trade-fsm:accept-trade pid)
    (timer:sleep 400)
    (io:format "~p~n" `(,(trade-fsm:ready pid)))
    (timer:sleep 1000)
    (trade-fsm:make-offer pid "horse")
    (trade-fsm:make-offer pid "sword")
    (timer:sleep 1000)
    (io:format "a synchronizing~n")
    (sync2)
    (trade-fsm:ready pid)
    (timer:sleep 200)
    (trade-fsm:ready pid)
    (timer:sleep 1000)))

(defun b (pid-a pid-client-a)
  (let ((`#(ok ,pid) (trade-fsm:start-link "Jim")))
    (io:format "Spawned Jim: ~p~n" `(,pid))
    ;;(sys:trace pid 'true)
    (timer:sleep 500)
    (trade-fsm:trade pid pid-a)
    (trade-fsm:make-offer pid "boots")
    (timer:sleep 200)
    (trade-fsm:retract-offer pid "boots")
    (timer:sleep 500)
    (trade-fsm:make-offer pid "shotgun")
    (timer:sleep 1000)
    (io:format "b synchronizing~n")
    (sync1 pid-client-a)
    (trade-fsm:make-offer pid "horse")
    (trade-fsm:ready pid)
    (timer:sleep 200)
    (timer:sleep 1000)))

trade-fsm.lfe

(defmodule trade-fsm
  (export all)
  (behavior 'gen_fsm))


(defun start (name)
  (gen_fsm:start (MODULE) `(,name) '()))

(defun start-link (name)
  (gen_fsm:start_link (MODULE) `(,name) '()))

(defun trade (own-pid other-pid)
  (gen_fsm:sync_send_event own-pid `#(negotiate ,other-pid) 30000))

(defun accept-trade (own-pid)
  (gen_fsm:sync_send_event own-pid 'accept-negotiate))

(defun make-offer (own-pid item)
  (gen_fsm:send_event own-pid `#(make-offer ,item)))

(defun retract-offer (own-pid item)
  (gen_fsm:send_event own-pid `#(retract-offer ,item)))

(defun ready (own-pid)
  (gen_fsm:sync_send_event own-pid 'ready 'infinity))

(defun cancel (own-pid)
  (gen_fsm:sync_send_all_state_event own-pid 'cancel))

;; FSM to FSM

(defun ask-negotiate (other-pid own-pid)
  (gen_fsm:send_event other-pid `#(ask-negotiate ,own-pid)))

(defun accept-negotiate (other-pid own-pid)
  (gen_fsm:send_event other-pid `#(accept-negotiate ,own-pid)))

(defun do-offer (other-pid item)
  (gen_fsm:send_event other-pid `#(do-offer ,item)))

(defun undo-offer (other-pid item)
  (gen_fsm:send_event other-pid `#(undo-offer ,item)))

(defun are-you-ready (other-pid)
  (gen_fsm:send_event other-pid 'are-you-ready))

(defun not-yet (other-pid)
  (gen_fsm:send_event other-pid 'not-yet))

(defun am-ready (other-pid)
  (gen_fsm:send_event other-pid 'ready!))

(defun ack-trans (other-pid)
  (gen_fsm:send_event other-pid 'ack))

(defun ask-commit (other-pid)
  (gen_fsm:sync_send_event other-pid 'ask-commit))

(defun do-commit (other-pid)
  (gen_fsm:sync_send_event other-pid 'do-commit))

(defun notify-cancel (other-pid)
  (gen_fsm:sync_send_all_state_event other-pid 'cancel))

(defrecord state
  (name '"")
  other
  (ownitems '())
  (otheritems '())
  monitor
  from)

(defmacro monitor% (pid)
  `(monitor 'process ,pid))

(defun init (name)
  `#(ok idle ,(make-state name name)))

(defun notice
  (((match-state name name) str args)
   (let ((fmt (string:join `("~s: " ,str "~n") "")))
     (io:format fmt (cons name args)))))

(defun unexpected (msg state)
  (io:format "WARN! ~p received unknown event ~p while in state ~p~n" `(,(self) ,msg ,state)))

(defun idle
  ((`#(ask-negotiate ,other-pid) (= (match-state) s))
   (notice s "~p asked for a trade negotiation" `(,other-pid))
   `#(next_state idle-wait ,(set-state s other other-pid monitor (monitor% other-pid))))
  ((event data)
   (unexpected event 'idle)
   `#(next_state idle ,data)))

(defun idle
  ((`#(negotiate ,other-pid) from (= (match-state) s))
   (ask-negotiate other-pid (self))
   (notice s "asking user ~p for a trade" `(,other-pid))
   `#(next_state idle-wait ,(set-state s other other-pid monitor (monitor% other-pid) from from)))
  ((event _from data)
   (unexpected event 'idle)
   `#(next_state idle ,data)))

;; idle-wait/2
(defun idle-wait
  ((`#(ask-negotiate ,other-pid) (= (match-state other _other-pid) s))
   (gen_fsm:reply (state-from s) 'ok)
   (notice s "starting negotiation" '())
   `#(next_state negotiate ,s))
  ((`#(accept-negotiate ,other-pid) (= (match-state other _other-pid) s))
   (gen_fsm:reply (state-from s) 'ok)
   (notice s "starting negotiation" '())
   `#(next_state negotiate ,s))
  ((event data)
   (unexpected event 'idle-wait)
   `#(next_state idle-wait ,data)))

;; idle-wait/3
(defun idle-wait
  (('accept-negotiate _from (= (match-state other other-pid) s))
   (accept-negotiate other-pid (self))
   (notice s "accepting negotiation" '())
   `#(reply ok negotiate ,s))
  ((event _from data)
   (unexpected event 'idle-wait)
   `#(next_state idle-wait ,data)))

(defun add (item items)
  (cons item items))

(defun remove (item items)
  (-- items `(,item)))

;; negotiate/2
(defun negotiate
  ((`#(make-offer ,item) (= (match-state ownitems own-items) s))
   (do-offer (state-other s) item)
   (notice s "offering ~p." `(,item))
   `#(next_state negotiate ,(set-state s ownitems (add item own-items))))

  ((`#(retract-offer ,item) (= (match-state ownitems own-items) s))
   (undo-offer (state-other s) item)
   (notice s "cancelling offer on ~p." `(,item))
   `#(next_state negotiate ,(set-state s ownitems (remove item own-items))))

  ((`#(do-offer ,item) (= (match-state otheritems other-items) s))
   (notice s "other player offering ~p" `(,item))
   `#(next_state negotiate ,(set-state s otheritems (add item other-items))))

  ((`#(undo-offer ,item) (= (match-state otheritems other-items) s))
   (notice s "other player cancelling offer on ~p" `(,item))
   `#(next_state negotiate ,(set-state s otheritems (remove item other-items))))

  (('are-you-ready (= (match-state other other-pid) s))
   (io:format "Other user ready to trade.~n")
   (notice s "Other user ready to transfer goods:~n You get ~p, The other side gets ~p" `(,(state-otheritems s) ,(state-ownitems s)))
   (not-yet other-pid)
   `#(next_state negotiate ,s))

  ((event data)
   (unexpected event 'negotiate)
   `#(next_state negotiate ,data)))

;; negotiate/3
(defun negotiate
  (('ready from (= (match-state other other-pid) s))
   (are-you-ready other-pid)
   (notice s "asking if ready, waiting" '())
   `#(next_state wait ,(set-state s from from)))
  ((event _from s)
   (unexpected event 'negotiate)
   `#(next_state negotiate ,s)))

;; wait/2
(defun wait
  ((`#(do-offer ,item) (= (match-state otheritems other-items) s))
   (gen_fsm:reply (state-from s) 'offer-changed)
   (notice s "other side offering ~p" `(,item))
   `#(next_state negotiate ,(set-state s otheritems (add item other-items))))

  ((`#(undo-offer ,item) (= (match-state otheritems other-items) s))
   (gen_fsm:reply (state-from s) 'offer-changed)
   (notice s "Other side cancelling offer of ~p" `(,item))
   `#(next_state negotiate ,(set-state s otheritems (remove item other-items))))

  (('are-you-ready (= (match-state) s))
   (am-ready (state-other s))
   (notice s "asked if ready, and I am. Waiting for same reply" '())
   `#(next_state wait ,s))

  (('not-yet (= (match-state) s))
   (notice s "Other not ready yet" '())
   `#(next_state wait ,s))

  (('ready! (= (match-state) s))
   (am-ready (state-other s))
   (ack-trans (state-other s))
   (gen_fsm:reply (state-from s) 'ok)
   (notice s "other side is ready. Moving to ready state" '())
   `#(next_state ready ,s))

  ((event data)
   (unexpected event 'wait)
   `#(next_state wait ,data)))

(defun priority
  ((own-pid other-pid) (when (> own-pid other-pid)) 'true)
  ((own-pid other-pid) (when (< own-pid other-pid)) 'false))

;; ready/2
(defun ready
  (('ack (= (match-state) s))
   (case (priority (self) (state-other s))
     ('true
      (try
          (progn
            (notice s "asking for commit" '())
            (ask-commit (state-other s))
            (notice s "ordering commit" '())
            (do-commit (state-other s))
            (notice s "committing..." ())
            (commit s)
            `#(stop normal ,s))
        (catch
          ((tuple class reason _)
           (progn
             (notice s "commit failed" '())
             `#(stop ,`#(class reason) ,s))))))
     ('false
      `#(next_state ready ,s))))

  ((event data)
   (unexpected event 'ready)
   `#(next_state ready ,data)))

;; ready/3
(defun ready
  (('ask-commit _from s)
   (notice s "replying to ask_commit" '())
   `#(reply ready-commit ready ,s))

  (('do-commit _from s)
   (notice s  "committing..." '())
   (commit s)
   `#(stop normal ok ,s))

  ((event _from data)
   (unexpected event 'ready)
   `#(next_state ready ,data)))

(defun commit
  (((= (match-state) s))
   (io:format "Transaction completed for ~s.Items sent are:~n~p,~n received are:~n~p.~n This operation should have some atomic save in a database.~n"
              `(,(state-name s) ,(state-ownitems s) ,(state-otheritems s)))))

;; handle_event/3
(defun handle_event
  (('cancel _state-name (= (match-state) s))
   (notice s "received cancel event" s)
   `#(stop other-cancelled ,s))

  ((event state-name data)
   (unexpected event state-name)
   `#(next_state ,state-name ,data)))

;;handle_sync_event/4
(defun handle_sync_event
  (('cancel _from _state-name (= (match-state) s))
   (notify-cancel (state-other s))
   (notice s "cancelling trade, sending cancel event" '())
   `#(stop cancelled ok ,s))

  ((event _from state-name data)
   (unexpected event state-name)
   `#(next_state ,state-name ,data)))

;; handle_info/3
(defun handle_info
  ((`#(DOWN ,ref process ,pid ,reason) _ (= (match-state) s))
   (notice s "Other side dead" '())
   `#(stop ,`#(other-down ,reason) ,s))

  ((info state-name data)
   (unexpected info state-name)
   `#(next_state ,state-name ,data)))

(defun code_change (_oldvsn state-name data _extra)
  `#(ok ,state-name ,data))

(defun terminate
  (('normal 'ready (= (match-state) s))
   (notice s "FSM leaving." '()))

  ((_reason _state-name _state-data)
   'ok))