diff --git a/README.md b/README.md index 53d221c..fb25c9c 100644 --- a/README.md +++ b/README.md @@ -61,12 +61,16 @@ is removed, every other message stays where it was. [[:reply ref v] v] ; ref already bound: matches its value [[:add n] :when (pos? n) (add n)] ; a guard; one that throws is false [[x x] :same] ; a repeated name must match equal values + [[:args h & t] (run h t)] ; a list tail, Erlang's [H|T] + [{:op :put :at [x y]} (put x y)] ; a map holding these keys, as #{k := V} [msg (log msg)] ; binds the whole message [:after 1000 :timeout]) ; ms, 0 polls, nil or :infinity waits forever ``` As in Erlang, a symbol bound where the `receive` is written is not a binder: it matches the value it holds. That is how a reply is matched to its request. +A map pattern's keys are values or bound names, never binders. A tuple +pattern matches any sequential message, a list as well as a vector. ### State @@ -109,7 +113,15 @@ Inside any actor, `(act/state)`, `(act/set-state! v)` and - A ref (`make-ref`) carries the node that made it. Wherever a timeout is taken, `nil` and `:infinity` both wait forever. - `register!` fails if the name is taken or the actor already has one, and a - name is released when its actor exits. + name is released when its actor exits. A name `[:via registry nm]` goes + through any `ensemble.registry/Registry`, and `[:global nm]` through + `ensemble.global`, wherever a name is taken. +- `!` also sends to an alias (`alias!`), while the alias is active. +- `process-info` gives a local actor's registered name, status + (`:running`, `:waiting`, `:hibernating`, `:passivated`), message queue + and its length, links, monitors, monitored-by, trap-exit flag, initial + call and ancestors; `processes` lists the node's live actors. On a pid of + another node, `process-info` and `alive?` are a badarg, as in Erlang. `join` and `exit-reason` wait for an actor from outside the actor world, such as a test or the REPL. @@ -165,13 +177,23 @@ such as a test or the REPL. without one. In gen_statem, `:hibernate` is a transition action, `:hibernate-after` is a start option there too, and a hibernating machine still gets its timeouts. +- `:name` may be `[:via registry nm]` or `[:global nm]`, and `call!` and + `cast!` take the same names. `multi-call` calls a locally registered name + on several nodes at once and answers `[replies bad-nodes]`; `abcast` + casts to it on each. +- `enter-loop` makes the calling actor a server without `init`, as + `gen_server:enter_loop`. +- A server implementing `FormatStatus` decides how its state shows in + `sys/get-status` and in terminate reports, to leave a secret out. ## gen_statem -`ensemble.gen-statem` is OTP's gen_statem in handle_event_function mode. One -callback, `(handle-event this type content state data)`, sees every event: -`[:call from]`, `:cast`, `:info`, `:timeout`, `:state-timeout`, -`[:generic-timeout name]`, `:internal` and `:enter`. +`ensemble.gen-statem` is OTP's gen_statem. In handle_event_function mode +one callback, `(handle-event this type content state data)`, sees every +event: `[:call from]`, `:cast`, `:info`, `:timeout`, `:state-timeout`, +`[:generic-timeout name]`, `:internal` and `:enter`. A machine that also +implements `StateFunctions` runs in state_functions mode: `(state-functions +this)` maps each state to a fn of `type content data`. ```clojure (require '[ensemble.gen-statem :as sm]) @@ -188,8 +210,9 @@ callback, `(handle-event this type content state data)`, sees every event: (terminate [_ _ _ _] nil)) ``` -Results are `:next-state`, `:keep-state`, `:keep-state-and-data`, `:stop` -and `:stop-and-reply`. Actions are `:postpone`, `:next-event`, `:reply`, +Results are `:next-state`, `:keep-state`, `:keep-state-and-data`, +`:repeat-state`, `:repeat-state-and-data` (which run the enter call again), +`:stop` and `:stop-and-reply`. Actions are `:postpone`, `:next-event`, `:reply`, `:timeout` (or a bare time), `:state-timeout`, `:generic-timeout` and `:hibernate`. One action may stand alone where a list goes, as `[:keep-state-and-data [:reply from v]]`. A bad return stops the machine @@ -198,7 +221,11 @@ of these with `[:bad-action-from-state-function a]`, the reasons OTP gives. A postponed event is retried after the next state change. Inserted events run before everything else. A state timeout is cancelled by a state change, and the event timeout -by any event. `{:state-enter true}` turns on enter calls. Clients use +by any event. Every timeout takes `:cancel` (`[:state-timeout :cancel]`) +and `:update` (`[:generic-timeout name :update content]`, which keeps the +running timer's deadline), and an options map `{:abs true}` makes its time +a monotonic deadline. `{:state-enter true}` turns on enter calls, and +`enter-loop` makes the calling actor a machine. Clients use `gs/call!`, `gs/cast!` and `gs/stop!`, since a gen-statem speaks the same protocol as a gen-server. @@ -219,6 +246,19 @@ old one's `h-terminate` runs, and `(f what-it-returned)` is the new one. `call!` talks to one handler (`:bad-module` if there is none), and `delete-handler!` returns what `h-terminate` returned. +## sys + +`ensemble.sys` looks into a running gen-server or gen-statem, and so into +a supervisor or a gen-event manager, through system messages it answers +between its own: `get-state`, `replace-state!`, `get-status`, `suspend!` +and `resume!` (a suspended process takes only system messages), +`statistics`, `trace!` (each message it takes is reported) and +`terminate!`. A gen-statem's state there is `[state data]`. + +As proc_lib does, every actor records its initial call (`spawn`'s +`:initial-call`, which the behaviours set to `[module :init]`) and its +ancestors, and a crash report carries both. + ## Supervisors ```clojure @@ -268,6 +308,20 @@ old one's `h-terminate` runs, and `(f what-it-returned)` is the new one. dependencies to be running, `ensure-all-started!` starts them first, and `stop!` stops the tree, then runs `:stop`. +- `:env` is the application's configuration: `get-env`, `get-all-env`, + `set-env!` and `unset-env!`. A value set before a reload is kept. + `get-key` reads the loaded spec. +- `:start-phases` `[[phase args] ...]` run in order after `:start`, each as + `(start-phase phase :normal args)`; one that doesn't answer `:ok` stops + the tree and fails the start. +- `:prep-stop` runs before the tree stops, and `:stop` gets what it + returns. +- `:optional-applications` may be absent: one not loaded is skipped. + `:included-applications` must be loaded, and can't be started on their + own while their includer runs. +- `ensure-all-started!` stops what it started, the last first, when a + later start fails, as OTP 26's does. + If the tree exits on its own, the type decides what happens next. A `:temporary` application is only recorded (see `exits`). A `:permanent` one, or a `:transient` one that exited abnormally, stops every other application, @@ -286,8 +340,6 @@ installs another handler. ## Timers -## Timers - ```clojure (require '[ensemble.timer :as timer]) @@ -345,16 +397,78 @@ process or on another machine. - `spawn-on` starts a fn named by a symbol on the other node, as `spawn(Node, M, F, A)` does, if that node allows it: `start!`'s `:spawn` option is a set of namespaces or a predicate on the symbol, and without - it a node starts nothing for a peer, since peers aren't authenticated - yet. -- Connections come from a `Transport`. The loopback transport joins nodes - in one VM, but each frame is still printed and read back as EDN, so what - crosses is exactly what a wire would carry. A socket transport plugs in - through the same protocol. + it a node starts nothing for a peer. +- `monitor-nodes!` sends the calling actor `[:nodeup n]` and `[:nodedown + n]` for every connection of its node, as `net_kernel:monitor_nodes`. + `act/nodes` lists the connected nodes. `stop!` takes a node down. - A node name is a keyword that reads back as itself, like `:shop.host`. Erlang's `shop@host` doesn't work here: `@` ends a token in Clojure's reader, and edn rejects it. +The layers, bottom up: + +- **Transport** (`ensemble.transport`): a byte stream between two nodes, + `Transport` (`-listen`, `-connect`), `Listener` and `Conn` (`-start`, + `-write`, `-close`). That is all a transport library implements, for TCP, + TLS or anything else; it resolves node names to addresses however it + likes. The loopback transport joins nodes in one VM, and `{:chunk n}` + splits its stream the way a network might. +- **Framing and codec**: a frame is its length, four bytes big-endian, + then its payload, which a `Codec` (`ensemble.codec`, EDN by default, + `start!`'s `:codec`) turns into a value. A frame larger than `start!`'s + `:max-frame` (64 MB by default) drops the connection, as does one that + doesn't decode. +- **Envelope**: each frame after the handshake is `[op hdr body]`. `hdr` + holds the operation's own fields (the pids it names, a ref, a name) and + `body` the data it carries, a message or an exit reason. Pids and + throwables in the body are tagged and data that looks like a tag is + escaped, so a message arrives exactly as it was sent. Sending something + the wire can't carry (a record, an atom, a fn) throws at the sender; a + throwable arrives as an `ex-info` with its message and data. +- **Handshake**: a connection is used only after the handshake, Erlang's + shape: the connecting node sends its name and creation, the other answers + with a status (`:nok` for a name it won't take, `:alive` when it's + connected to that run of the node already, and of two nodes connecting + to each other at once only one connection survives) and a challenge, and each end proves it holds + the cookie by signing the other's challenge with HMAC-SHA256. `start!`'s + `:cookie` sets it (by default nodes in one VM share a cookie drawn at + startup), or `:auth` takes any `ensemble.node/Auth`. A connection that + hasn't shaken hands within `:handshake-timeout` is closed, and a node + that restarts is let in, its earlier run going down first. +- **Creation**: each start of a node draws a creation number that its pids + and refs carry, so a pid of an earlier run names no process, though its + id may be in use again. + +### Services + +```clojure +(require '[ensemble.rpc :as rpc] '[ensemble.global :as global] '[ensemble.pg :as pg]) + +(rpc/call :shop.b `my.ns/total [order] 5000) ; erpc:call +(rpc/multicall [:shop.a :shop.b] `my.ns/stats []) +(global/register-name :leader (act/self)) ; :yes or :no +(gs/call! [:global :leader] :status) +(pg/join :workers (act/self)) +(pg/get-members :workers) ; on every node +``` + +- `ensemble.rpc` is erpc: `call` runs a fn in a process of its own on the + node (one its `:spawn` option allows) and answers its value, or throws + with `:noconnection`, `:timeout` (the process is then killed), + `[:exception e]` or `[:exit reason]`. `cast` doesn't wait, and + `multicall` asks several nodes at once. +- `ensemble.global` is global: one name table over every connected node. + Registering locks the name on each node, checks no node has it, and sets + it everywhere. A name goes when its process exits or its node goes + down. When nodes connect they merge tables, and a name both hold keeps + the process whose pid sorts first, killing the other, as global's + default resolve does. `[:global nm]` works wherever a name does. +- `ensemble.pg` is pg: process groups over every connected node, joined + from the member's own node, kept eventually consistent as pg's are. + `join`, `leave`, `get-members`, `get-local-members`, `which-groups`, and + `monitor`, which sends `[ref :join group pids]` and `[ref :leave group + pids]`. + ## Where this differs from Erlang - **Exit signals land wherever the process is**, through jolt's fiber @@ -366,9 +480,13 @@ process or on another machine. bookkeeping of a dying process -- telling its links and monitors -- runs masked, so a late signal cannot tear it. - **Passivation is an extension.** Erlang's hibernation stays in memory. -- **Distribution has only the loopback transport so far**, with no - cookies and no global name registry. There is also no hot code loading, no `sys` suspend/resume, and no - reductions (jolt preempts fibers on a timer instead). +- **Distribution ships only the loopback transport**; a network transport + is a library implementing `ensemble.transport`. The cookie handshake + signs with HMAC-SHA256 rather than Erlang's MD5 digest, and the frames + are EDN, not the external term format, so ensemble nodes do not talk to + Erlang nodes. global and pg have the default scope only. +- There is no hot code loading, and no reductions (jolt preempts fibers on + a timer instead). - **Reasons** are any value, and a crash's reason is the throwable itself rather than `{Exception, Stacktrace}`. - **Names** may be keywords, symbols or strings, all normalised to a keyword. @@ -388,20 +506,21 @@ written from the Erlang/OTP documentation: | `ensemble.timers` | when timers fire and in what order, what a cancel answers, which timers an exit ends | `timers_spec` | | `ensemble.request` | which message answers an asynchronous request, alone or in a collection | `request_spec` | | `ensemble.life` | a process's life: running, hibernated, on disk, exited | `life_spec` | -| `ensemble.dist` | where a send goes, what a pid in a message is on arrival, what a lost connection does | `dist_spec` | +| `ensemble.dist` | where a send goes, what a pid in a message is on arrival, what a lost connection does, every step of the handshake, the frame header | `dist_spec` | | `ensemble.callback` | what a gen_server's init and callback returns mean, and their actions | `callback_spec` | | `ensemble.statem` | gen_statem init and results, actions, postpone order, timeouts | `statem_spec` | -Every spec requires proof (`{:require :proved}`): 312 of their 322 laws -are proved, 201 of them for every input -- among them that a selective +Every spec requires proof (`{:require :proved}`): 342 of their 356 laws +are proved, 223 of them for every input -- among them that a selective receive is the manual's, message by message and clause by clause, that a restart plan is the supervisor docs', that a child spec is refused for the reason `check_childspecs` gives, that a lost connection breaks exactly the links and monitors across it, and that no gen_statem event is lost -or duplicated, over mailboxes, children and queues of any length. The 10 -left to testing each say why: they recurse over patterns of any depth, -over a callback's list of actions, or walk a message of any shape for the -pids in it. `test/ensemble/order_proof.clj` and +or duplicated, over mailboxes, children and queues of any length, and +that two nodes come up only when both hold the cookie. The 14 left to +testing each say why: they recurse over patterns of any depth, over a +callback's list of actions, walk a message of any shape for the pids in +it, or shift bits, which the prover doesn't model. `test/ensemble/order_proof.clj` and `timers_proof.clj` hold the lemmas about clojure.core the proofs cite. A law over `Any` covers values without NaN; one over `Any!` takes NaN in diff --git a/src/ensemble/actor.clj b/src/ensemble/actor.clj index e6b6537..6d57e9c 100644 --- a/src/ensemble/actor.clj +++ b/src/ensemble/actor.clj @@ -43,6 +43,7 @@ [ensemble.life :as life] [ensemble.logger :as logger] [ensemble.process :as proc] + [ensemble.registry :as reg] [ensemble.pattern :as pattern] [ensemble.select :as select] [ensemble.signal :as sig])) @@ -71,7 +72,9 @@ (defn remote? "True when x is a handle on a process of another node." [x] - (and (record? x) (proc/process? x))) + ;; implementing Process itself: every map satisfies it, local actors + ;; being maps + (and (record? x) (instance? ensemble.process.Process x))) (defn pid? "True when x is a process handle, local or remote (Erlang's is_pid)." @@ -99,6 +102,29 @@ [f] (reset! remote-resolver f)) +(defonce ^:private peers-fn + ;; set by ensemble.node: the nodes the current node is connected to + (atom (fn [] []))) + +(defn set-peers-fn! + "Install how nodes finds the current node's peers." + [f] + (reset! peers-fn f)) + +(defn nodes + "The nodes the current node is connected to, as Erlang's nodes/0." + [] + (vec (@peers-fn))) + +(defonce ^:private creation-fn + ;; set by ensemble.node: the creation number of a node's current run + (atom (fn [_] 0))) + +(defn set-creation-fn! + "Install how make-ref learns its node's creation." + [f] + (reset! creation-fn f)) + (defmethod print-method ::actor [x ^java.io.Writer w] (.write w (str "#"))) @@ -113,9 +139,11 @@ (defn make-ref "A unique reference (Erlang's make_ref), for tagging a request so its reply can be told apart from every other message. It carries the node that made - it, so refs from two runtimes never collide." + it, and that node's creation, so refs from two runtimes, or two runs of + one node, never collide." [] - {::ref (swap! counter inc) ::node (node)}) + (let [n (node)] + {::ref (swap! counter inc) ::node n ::creation (@creation-fn n)})) (defn ref-node "The node a ref was made on." @@ -148,15 +176,21 @@ (not= ::closed coll)) (defn alive? - "True until the actor has exited (Erlang's is_process_alive)." + "True until the local actor has exited (Erlang's is_process_alive). A + process of another node is a badarg, as in Erlang." [actor] - (open? @(::links actor))) + (if (actor? actor) + (open? @(::links actor)) + (throw (ex-info "alive? takes a local process" {:reason :badarg :process actor})))) (defn whereis - "The live actor registered under nm on this node, or nil." + "The live actor registered under nm on this node, or nil. nm may be a + name in another registry, [:via r name]." [nm] - (let [a (get-in @registry [(node) (norm-name nm)])] - (when (and a (alive? a)) a))) + (if (or (reg/via? nm) (reg/global? nm)) + (let [[_ r n] (reg/named nm)] (reg/whereis-name r n)) + (let [a (get-in @registry [(node) (norm-name nm)])] + (when (and a (alive? a)) a)))) (defn register! "Register actor under nm, so ! and whereis accept the name. As in Erlang it @@ -197,12 +231,15 @@ (vec (keep (fn [[k v]] (when (alive? v) k)) (get @registry (node))))) (defn resolve-dest - "A process handle from a handle, a name registered on this node, or a - name on another, [:At name node]. Sending to a name nobody holds - throws, as Erlang's Name ! Msg does." + "A process handle from a handle, a name registered on this node, a name + on another, [:At name node], or a name in a registry, [:via r name]. + Sending to a name nobody holds throws, as Erlang's Name ! Msg does." [dest] (cond (pid? dest) dest + (or (reg/via? dest) (reg/global? dest)) + (or (whereis dest) + (throw (ex-info "no process registered under name" {:reason :badarg :name dest}))) (and (vector? dest) (= :At (first dest))) (if (= (nth dest 2) (node)) (resolve-dest (second dest)) @@ -237,13 +274,19 @@ (swap! (::inbox actor) conj msg) (ring! actor [:Mail]))) +(declare send-alias!) + +(defn- alias-ref? [x] (and (map? x) (contains? x ::owner))) + (defn ! "Send msg to dest, a process (on this node or another), a registered - name, or [:At name node]. Never blocks. Returns msg. A message to a - dead process is silently dropped; a message to a name nobody holds - throws." + name, [:At name node], or an alias (see alias!). Never blocks. Returns + msg. A message to a dead process, or to an alias no longer active, is + silently dropped; a message to a name nobody holds throws." [dest msg] - (proc/-deliver (resolve-dest dest) msg) + (if (alias-ref? dest) + (send-alias! dest msg) + (proc/-deliver (resolve-dest dest) msg)) msg) ;; exit signals --------------------------------------------------------- @@ -430,9 +473,15 @@ monitor." [dest] (let [me (self) - obj (when-not (pid? dest) (name-object dest)) + ;; a registry's name is looked up, as gen_server does before it + ;; monitors: the DOWN names the process + dest (reg/named dest) + dest (if (reg/via? dest) (or (whereis dest) dest) dest) + obj (when-not (or (pid? dest) (reg/via? dest)) (name-object dest)) + obj (if (reg/via? dest) dest obj) actor (if obj (try (resolve-dest dest) (catch Throwable _ nil)) dest) - ref (make-ref) + ;; the watcher's pid, for the target's process-info :monitored-by + ref (assoc (make-ref) ::by (::pid me)) watching (::monitoring me) who (or obj actor)] (if (nil? actor) @@ -531,6 +580,9 @@ (let [[links _] (swap-vals! (::links me) (constantly ::closed)) [mons _] (swap-vals! (::monitors me) (constantly ::closed))] (swap! registry update (::node me) (fn [r] (into {} (remove (fn [[_ v]] (= v me))) r))) + (when-let [[_ r n] (:via @(::origin me))] + (when-not (and (satisfies? reg/Watches r) (reg/watches-its-processes? r)) + (try (reg/unregister-name r n) (catch Throwable _ nil)))) (doseq [[ref target] @(::monitoring me) :when (watched? target)] (proc/-drop-monitor target ref)) (swap! procs dissoc (::pid me)) (doseq [other links] @@ -578,8 +630,9 @@ ;; a throw the body did not catch is a crash, and is reported, ;; as the emulator reports an uncaught error; an exit is not (when (and (not killed) (instance? Throwable reason)) - (logger/report! {:level :error :kind :crash-report :pid me - :name (registered-name me) :reason reason})) + (logger/report! (merge {:level :error :kind :crash-report :pid me + :name (registered-name me) :reason reason} + @(::origin me)))) (settle! me reason) (deliver (::done me) (if (sig/normal? reason) @@ -746,6 +799,9 @@ ::resume (atom nil) ::refused (atom nil) ::fiber (atom nil) + ::waiting (atom false) + ;; proc_lib's: {:initial-call x :ancestors [parent ...]} + ::origin (atom {}) ::trapping (atom false)} {:type ::actor})) @@ -754,10 +810,17 @@ :normal when f returns, with reason when f calls (exit! reason), and with the throwable when f throws. Options: - :name register the actor under this name before it runs + :name register the actor under this name before it runs; a + name [:via r nm] is registered with registry r instead, + and released there when the actor exits :link link it to the current actor before it runs (spawn_link) :trap start it trapping exits :state the actor's initial state (see state) + :initial-call what it was started to run, for process-info and + crash reports, as proc_lib records {M, F, A} + + As proc_lib does, it records its ancestors: the spawning actor, then + that one's ancestors. A link or name set here is in place before the body's first step, so an immediate crash cannot slip past it." @@ -766,10 +829,25 @@ (let [parent (self) me (new-actor (swap! counter inc) (node)) go (promise)] + (reset! (::origin me) {:initial-call (:initial-call opts) + :ancestors (if parent (into [parent] (:ancestors @(::origin parent))) [])}) (when trap (reset! (::trapping me) true)) (reset! (::state me) (:state opts)) - (when name (register! name me)) + ;; in the process table before its name is registered: a registry may + ;; reach for it, a monitor from another node among others (swap! procs assoc (::pid me) me) + (try + (if (reg/via? (reg/named name)) + (let [[_ r n :as via] (reg/named name)] + (if (reg/register-name r n me) + (swap! (::origin me) assoc :via via) + (throw (ex-info "name already registered" {:reason :badarg :name name})))) + (when name (register! name me))) + (catch Throwable e + ;; it never runs: anything that reached for it sees it gone + (settle! me :noproc) + (deliver (::done me) [:err e :noproc]) + (throw e))) (when (and link parent) (swap! (::links me) conj parent) (swap! (::links parent) (fn [ls] (if (open? ls) (conj ls me) ls)))) @@ -812,6 +890,58 @@ [f & args] (apply swap! (::state (self)) f args)) +;; introspection -------------------------------------------------------- + +(defn- status-of [actor] + (case @(::lifecycle actor) + [:Hibernated] :hibernating + [:Passivated] :passivated + (if @(::waiting actor) :waiting :running))) + +(def ^:private info-keys + [:registered-name :status :message-queue-len :messages :links :monitors + :monitored-by :trap-exit :initial-call :ancestors]) + +(defn- info-item [actor k] + (case k + :registered-name (registered-name actor) + :status (status-of actor) + :messages (into @(::saved actor) (remove signal?) @(::inbox actor)) + :message-queue-len (+ (count @(::saved actor)) (count (remove signal? @(::inbox actor)))) + :links (let [ls @(::links actor)] (if (open? ls) ls #{})) + :monitors (vec (for [[_ t] @(::monitoring actor) :when (watched? t)] [:process t])) + :monitored-by (let [ms @(::monitors actor)] + (if (open? ms) + (vec (keep (fn [r] (when-let [w (get @procs (::by r))] + (when (= (::node w) (::node r)) w))) + (keys ms))) + [])) + :trap-exit @(::trapping actor) + :initial-call (:initial-call @(::origin actor)) + :ancestors (:ancestors @(::origin actor) []) + (throw (ex-info "not a process-info item" {:reason :badarg :item k})))) + +(defn process-info + "What is known of a live local actor, as Erlang's process_info: a map of + :registered-name, :status (:running, :waiting in a receive, :hibernating + or :passivated), :message-queue-len, :messages, :links, :monitors (each + [:process p]), :monitored-by (the local actors monitoring it) and + :trap-exit, and proc_lib's :initial-call and :ancestors; with k, that + item alone. nil once the actor has exited. A + process on another node is a badarg, as in Erlang." + ([actor] (process-info actor nil)) + ([actor k] + (let [actor (resolve-dest actor)] + (when-not (actor? actor) + (throw (ex-info "process-info takes a local process" {:reason :badarg :process actor}))) + (when (alive? actor) + (if k (info-item actor k) (into {} (map (fn [k] [k (info-item actor k)])) info-keys)))))) + +(defn processes + "The live actors of this node, as Erlang's processes/0." + [] + (filterv #(and (= (node) (::node %)) (alive? %)) (vals @procs))) + ;; receive -------------------------------------------------------------- (defn always @@ -819,6 +949,33 @@ [_ _] true) +;; a map pattern looks a key up in the message, and a sorted map whose keys +;; cannot be compared with it throws there: such a clause does not match, +;; and the actor is not crashed by what someone sent it + +(defn- clause-of + "select/clause-of, a clause whose match throws ClassCastException + counting as one that does not match." + [pats ok? msg] + (try (select/clause-of pats ok? msg) + (catch ClassCastException _ + (or (some (fn [k] + (let [r (try (select/clause-of [(nth pats k)] (fn [_ env] (ok? k env)) msg) + (catch ClassCastException _ [:Miss]))] + (when (= :Hit (first r)) [:Hit k (nth r 2)]))) + (range (count pats))) + [:Miss])))) + +(defn- scan-each + "select/scan, through clause-of: for a mailbox where it threw." + [msgs pats ok? start] + (let [n (count msgs)] + (loop [i start] + (if (< i n) + (let [r (clause-of pats ok? (nth msgs i))] + (if (= :Hit (first r)) (let [[_ k env] r] [:Take i k env]) (recur (inc i)))) + [:None i])))) + (defn- take-new! "Take messages off me's queue, oldest first, until one satisfies a clause: [clause-index msg env] for it, or nil once the queue is empty. Each one @@ -834,12 +991,18 @@ (if (signal? m) ::signal (do (swap! inbox pop) - (let [r (select/clause-of pats ok? m)] + (let [r (clause-of pats ok? m)] (if (= :Hit (first r)) (let [[_ k env] r] [k m env]) (do (swap! (::saved me) conj m) (recur)))))))))))) +(defn- waiting! + "Park me in (wait), marked as waiting for a message the while." + [me wait] + (reset! (::waiting me) true) + (try (wait) (finally (reset! (::waiting me) false)))) + (defn receive-match "Block until a message matches one of the compiled patterns pats whose guard (ok? clause-index bindings) accepts it. Returns [clause-index msg env], or @@ -853,7 +1016,8 @@ (loop [start 0] (drain-signals! me) (let [saved @(::saved me) - r (select/scan saved pats ok? start)] + r (try (select/scan saved pats ok? start) + (catch ClassCastException _ (scan-each saved pats ok? start)))] (if (= :Take (first r)) (let [[_ i k env] r] ;; an emptied subvec is let go, not kept to grow on @@ -869,9 +1033,9 @@ (if deadline (let [left (- deadline (now-ms))] (if (pos? left) - (do (a/alts!! [(::bell me) (a/timeout left)]) (recur scanned)) + (do (waiting! me #(a/alts!! [(::bell me) (a/timeout left)])) (recur scanned)) [:timeout])) - (do (a/ :ok :type :temporary | :transient | :permanent (:temporary)} start! runs :start and has an application master monitor the tree it - returns. stop! stops the tree (as a supervisor stops: children in reverse - order) and then runs :stop. If the tree exits by itself the application + returns, then runs the start phases; one that does not answer :ok stops + the tree and fails the start. stop! runs :prep-stop, stops the tree (as + a supervisor stops: children in reverse order) and then runs :stop. If the tree exits by itself the application has stopped, and its type decides the rest, as OTP's does: a :temporary application is only reported; a :permanent one, or a :transient one that exited abnormally, takes every other running application down with it -- OTP would stop the node." (:require [ensemble.actor :as act :refer [receive]] [ensemble.gen-server :as gs] + [ensemble.logger :as logger] [ensemble.signal :as sig])) (defonce ^:private loaded (atom {})) @@ -27,30 +39,83 @@ (defonce ^:private exit-log (atom [])) +(defonce ^:private envs + ;; name -> {key value}: each application's configuration + (atom {})) + (defonce ^:private started-order ;; the names of the running applications, in the order they started (atom [])) (defn load! - "Register an application spec. Returns its name." + "Register an application spec. Its :env is the application's + configuration, under any value set-env! has given a key already. + Returns its name." [spec] - (swap! loaded assoc (:name spec) spec) + (let [old (:env (get @loaded (:name spec))) + ;; the values a spec loaded before gave, as opposed to set-env!'s + set-by-hand (fn [env] (into {} (remove (fn [[k v]] (and (contains? old k) (= v (get old k))))) env))] + (swap! loaded assoc (:name spec) spec) + (swap! envs update (:name spec) #(merge (:env spec) (set-by-hand %)))) (:name spec)) +(defn get-key + "The value of key k in the loaded spec of application name." + [name k] + (get-in @loaded [name k])) + +(defn get-env + "Application name's configuration value for k, or default (nil)." + ([name k] (get-env name k nil)) + ([name k default] (get-in @envs [name k] default))) + +(defn get-all-env + "Application name's whole configuration, a map." + [name] + (get @envs name {})) + +(defn set-env! + "Set application name's configuration value for k. Returns :ok." + [name k v] + (swap! envs assoc-in [name k] v) + :ok) + +(defn unset-env! + "Remove k from application name's configuration. Returns :ok." + [name k] + (swap! envs update name dissoc k) + :ok) + (defn- fail [reason] (throw (ex-info (str "application: " (pr-str reason)) {:reason reason}))) +(defn- required + "The dependencies of spec that must run first: its :applications, + less the optional ones that are not loaded." + [spec] + (let [optional (set (:optional-applications spec))] + (remove #(and (contains? optional %) (not (contains? @loaded %))) (:applications spec)))) + +(defn- includer + "The running application that includes name, or nil." + [name] + (some (fn [[n a]] (when (and (map? a) (some #{name} (:included-applications (:spec a)))) n)) + @running)) + (declare stop-all!) (defn- master - "The application master: monitor the tree; when it exits without stop!, - forget the application and act on its type." + "The application master: once told ::go, monitor the tree; when it exits + without stop!, forget the application and act on its type." [name top kind] (act/spawn (fn [] + ;; start! records the application before it says go, so a tree dead + ;; already is not mistaken for one still starting + (receive [::go nil]) (let [ref (act/monitor! top)] (receive [[:DOWN ref :process _ reason] - (when (get @running name) + (when (= top (:top (get @running name))) (swap! running dissoc name) (swap! started-order (fn [o] (filterv #(not= name %) o))) (swap! exit-log conj [name reason]) @@ -59,13 +124,28 @@ (stop-all!)))] [::stop (act/demonitor! ref {:flush true})]))))) +(declare stop!) + +(defn- run-phases! + "Run spec's start phases in order; throws for the first that does not + answer :ok." + [spec] + (doseq [[phase args] (:start-phases spec)] + (let [r ((:start-phase spec) phase :normal args)] + (when-not (= :ok r) (fail [:bad-start-phase phase r]))))) + (defn start! - "Start the loaded application name. Its :applications must be running. - Throws if it is already running, not loaded, a dependency is not running, - or its :start throws. Returns :ok." + "Start the loaded application name. Its :applications must be running, + less any optional one that is not loaded, and its included applications + loaded. Throws if it is already running, not loaded, included by a + running application, a dependency is not running, or its :start or a + start phase fails. Returns :ok." [name] (let [spec (or (get @loaded name) (fail [:not-loaded name]))] - (doseq [dep (:applications spec)] + (when-let [by (includer name)] (fail [:included name by])) + (doseq [inc (:included-applications spec)] + (when-not (contains? @loaded inc) (fail [:not-loaded inc]))) + (doseq [dep (required spec)] (when-not (contains? @running dep) (fail [:not-started dep]))) ;; claim the name first, so two starts of one application cannot both run (let [[before _] (swap-vals! running (fn [r] (if (contains? r name) r (assoc r name ::starting))))] @@ -76,45 +156,70 @@ (swap! running dissoc name) (fail [:bad-return r])) (swap! started-order (fn [o] (conj (filterv #(not= name %) o) name))) - (swap! running assoc name {:spec spec :top top :state state - :master (master name top (:type spec :temporary))}) + (let [m (master name top (:type spec :temporary))] + (swap! running assoc name {:spec spec :top top :state state :master m}) + (act/! m ::go)) + (try (run-phases! spec) + (catch Throwable e (stop! name) (throw e))) :ok))) (defn ensure-all-started! "Start name and, first, every application it depends on, transitively, - that is not already running. Returns the names started, in order." + that is not already running. Returns the names started, in order. If + one fails to start, those it started are stopped again, the last first, + and it throws, as OTP 26's does." [name] ;; depth first: an application goes after everything it depends on (let [ordered (loop [todo [name], out [], steps 0] (if-let [n (first todo)] (let [spec (or (get @loaded n) (fail [:not-loaded n])) - deps (remove (set out) (:applications spec))] + deps (remove (set out) (required spec))] (when (> steps 10000) (fail [:circular-dependencies name])) (if (seq deps) (recur (concat deps todo) out (inc steps)) (recur (rest todo) (if (some #{n} out) out (conj out n)) (inc steps)))) out))] - (vec (for [n ordered :when (not (contains? @running n))] - (do (start! n) n))))) + (loop [todo (remove #(contains? @running %) ordered), started []] + (if-let [n (first todo)] + (do (try (start! n) + (catch Throwable e + (doseq [s (rseq started)] (stop! s)) + (throw e))) + (recur (rest todo) (conj started n))) + started)))) (defn stop! - "Stop the running application name: stop its tree, then run :stop on its - state. Returns :ok, or nil if it is not running." + "Stop the running application name: run :prep-stop on its state, stop + its tree, then run :stop on what :prep-stop returned. Returns :ok, or + nil if it is not running." [name] - (when-let [{:keys [spec top state master]} (let [a (get @running name)] (when (map? a) a))] - (swap! running dissoc name) - (swap! started-order (fn [o] (filterv #(not= name %) o))) - (act/! master ::stop) - (when (act/alive? top) - (try (gs/stop! top :shutdown) (catch Throwable _ (act/exit! top :kill)))) - (when-let [stop (:stop spec)] (stop state)) - :ok)) + ;; claimed first, so of two stops only one runs the callbacks + (let [[before _] (swap-vals! running (fn [r] (if (map? (get r name)) (dissoc r name) r))) + a (get before name)] + (when (map? a) + (let [{:keys [spec top state master]} a] + (swap! started-order (fn [o] (filterv #(not= name %) o))) + ;; the master stops watching, so the tree's exit is not a crash + (act/! master ::stop) + ;; a prep-stop that throws does not keep the tree up: it stops, :stop + ;; gets the state prep-stop was given, and then stop! throws + (let [[state failed] (if-let [prep (:prep-stop spec)] + (try [(prep state)] (catch Throwable e [state e])) + [state])] + (when (act/alive? top) + (try (gs/stop! top :shutdown) (catch Throwable _ (act/exit! top :kill)))) + (when-let [stop (:stop spec)] (stop state)) + (when failed (throw failed)) + :ok))))) (defn- stop-all! "Stop every running application, the last started first, as OTP stops them with the node: an application stops before those it depends on." [] - (doseq [n (rseq @started-order)] (stop! n))) + (doseq [n (rseq @started-order)] + (try (stop! n) + (catch Throwable e + (logger/report! {:level :error :kind :application-stop-failed :application n :reason e}))))) (defn which-applications "The names of the running applications, in the order they started." diff --git a/src/ensemble/codec.clj b/src/ensemble/codec.clj new file mode 100644 index 0000000..6f6dcd0 --- /dev/null +++ b/src/ensemble/codec.clj @@ -0,0 +1,18 @@ +(ns ensemble.codec + "How a frame's value becomes bytes and back. ensemble.node hands a codec + plain data -- each process and throwable in it already written as tagged + data -- so a codec need only carry keywords, symbols, strings, numbers, + characters, booleans, nil, uuids, instants, vectors, lists, maps and + sets. EDN is the default; a library may supply a faster one." + (:require [clojure.edn :as edn])) + +(defprotocol Codec + (-encode [c v] "v as a byte array.") + (-decode [c bs] "The value the byte array bs holds.")) + +(defrecord Edn [] + Codec + (-encode [_ v] (.getBytes ^String (pr-str v) "UTF-8")) + (-decode [_ bs] (edn/read-string (String. ^bytes bs "UTF-8")))) + +(defn edn "The EDN codec." [] (->Edn)) diff --git a/src/ensemble/digest.clj b/src/ensemble/digest.clj new file mode 100644 index 0000000..b4d32b3 --- /dev/null +++ b/src/ensemble/digest.clj @@ -0,0 +1,101 @@ +(ns ensemble.digest + "SHA-256 (FIPS 180-4) and HMAC-SHA256 (RFC 2104), for the distribution + handshake's cookie challenge. The runtime has no message digest of its + own, so these are written out here. + + A message is a sequence of bytes, each an integer; a signed byte (from a + byte array) is taken as the unsigned value it stands for. A digest is a + vector of 32 integers from 0 to 255.") + +(def ^:private mask 0xFFFFFFFF) + +(def ^:private k + [0x428a2f98 0x71374491 0xb5c0fbcf 0xe9b5dba5 0x3956c25b 0x59f111f1 0x923f82a4 0xab1c5ed5 + 0xd807aa98 0x12835b01 0x243185be 0x550c7dc3 0x72be5d74 0x80deb1fe 0x9bdc06a7 0xc19bf174 + 0xe49b69c1 0xefbe4786 0x0fc19dc6 0x240ca1cc 0x2de92c6f 0x4a7484aa 0x5cb0a9dc 0x76f988da + 0x983e5152 0xa831c66d 0xb00327c8 0xbf597fc7 0xc6e00bf3 0xd5a79147 0x06ca6351 0x14292967 + 0x27b70a85 0x2e1b2138 0x4d2c6dfc 0x53380d13 0x650a7354 0x766a0abb 0x81c2c92e 0x92722c85 + 0xa2bfe8a1 0xa81a664b 0xc24b8b70 0xc76c51a3 0xd192e819 0xd6990624 0xf40e3585 0x106aa070 + 0x19a4c116 0x1e376c08 0x2748774c 0x34b0bcb5 0x391c0cb3 0x4ed8aa4a 0x5b9cca4f 0x682e6ff3 + 0x748f82ee 0x78a5636f 0x84c87814 0x8cc70208 0x90befffa 0xa4506ceb 0xbef9a3f7 0xc67178f2]) + +(def ^:private h0 + [0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a 0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19]) + +(defn- rotr + "x, a 32-bit word, rotated right by n." + [x n] + (bit-or (unsigned-bit-shift-right x n) + ;; the low n bits, moved to the top: masked first, so the shift + ;; stays within 32 bits + (bit-shift-left (bit-and x (dec (bit-shift-left 1 n))) (- 32 n)))) + +(defn- add [& xs] (bit-and (reduce + xs) mask)) + +(defn- padded + "The message with SHA-256's padding: a 1 bit, zeros, and its length in + bits as 8 bytes, to a multiple of 64 bytes." + [bs] + (let [n (count bs) + zeros (mod (- 55 n) 64) + bits (* 8 n)] + (-> (transient (vec bs)) + (conj! 0x80) + (as-> v (reduce conj! v (repeat zeros 0))) + (as-> v (reduce conj! v (for [i (range 7 -1 -1)] (bit-and (unsigned-bit-shift-right bits (* 8 i)) 0xff)))) + persistent!))) + +(defn- schedule + "The 64 words of the message schedule for one 64-byte block." + [block] + (let [w (mapv (fn [i] (bit-or (bit-shift-left (nth block (* 4 i)) 24) + (bit-shift-left (nth block (+ 1 (* 4 i))) 16) + (bit-shift-left (nth block (+ 2 (* 4 i))) 8) + (nth block (+ 3 (* 4 i))))) + (range 16))] + (loop [w (transient w), t 16] + (if (= t 64) + (persistent! w) + (let [x (nth w (- t 15)) + y (nth w (- t 2)) + s0 (bit-xor (rotr x 7) (rotr x 18) (unsigned-bit-shift-right x 3)) + s1 (bit-xor (rotr y 17) (rotr y 19) (unsigned-bit-shift-right y 10))] + (recur (conj! w (add (nth w (- t 16)) s0 (nth w (- t 7)) s1)) (inc t))))))) + +(defn- compress + "The hash state after one block." + [hs block] + (let [w (schedule block)] + (loop [i 0, [a b c d e f g h] hs] + (if (= i 64) + (mapv add hs [a b c d e f g h]) + (let [s1 (bit-xor (rotr e 6) (rotr e 11) (rotr e 25)) + ch (bit-xor (bit-and e f) (bit-and (bit-xor e mask) g)) + t1 (add h s1 ch (nth k i) (nth w i)) + s0 (bit-xor (rotr a 2) (rotr a 13) (rotr a 22)) + maj (bit-xor (bit-and a b) (bit-and a c) (bit-and b c)) + t2 (add s0 maj)] + (recur (inc i) [(add t1 t2) a b c (add d t1) e f g])))))) + +(defn- unsigned [bs] (map #(bit-and % 0xff) bs)) + +(defn sha-256 + "The SHA-256 digest of the bytes bs." + [bs] + (let [m (padded (unsigned bs)) + hs (reduce compress h0 (map #(subvec m % (+ % 64)) (range 0 (count m) 64)))] + (vec (for [x hs, i [24 16 8 0]] (bit-and (unsigned-bit-shift-right x i) 0xff))))) + +(defn hmac-sha-256 + "The HMAC-SHA256 of the bytes msg under the bytes key." + [key msg] + (let [key (vec (unsigned key)) + key (if (> (count key) 64) (sha-256 key) key) + key (into key (repeat (- 64 (count key)) 0)) + pad (fn [b] (mapv #(bit-xor % b) key))] + (sha-256 (concat (pad 0x5c) (sha-256 (concat (pad 0x36) (unsigned msg))))))) + +(defn hex + "A digest as lowercase hex." + [bs] + (apply str (map #(let [s (Integer/toHexString (bit-and % 0xff))] (if (= 1 (count s)) (str "0" s) s)) bs))) diff --git a/src/ensemble/dist.clj b/src/ensemble/dist.clj index 23fe4a1..45ffe3f 100644 --- a/src/ensemble/dist.clj +++ b/src/ensemble/dist.clj @@ -4,28 +4,38 @@ connection does to the links and monitors that cross it. ensemble.node makes every one of them through these. - A pid on the wire is [:Pid node id]; a destination is a pid, [:Name nm] - or [:At nm node], Erlang's {Name, Node}." - (:require [clojure.walk :as walk])) + A pid is [:Pid node id creation], creation the number its node drew + when it started, so a pid of an earlier run of a node names no process + of the run after it; a destination is a pid, [:Name nm] or [:At nm + node], Erlang's {Name, Node}. + + Before two nodes exchange anything else they shake hands, and the + handshake's every decision is here too; so is how a frame's length is + written on the wire." + ) (defn route - "Where a send to dest goes from node self: [:Here id], [:There node id], - [:Named nm] or [:NamedThere node nm]." - [self dest] + "Where a send to dest goes from node self, now in its run creation: + [:Here id], [:Gone] for a pid of an earlier run of self, [:There node id + creation], [:Named nm] or [:NamedThere node nm]." + [self creation dest] (case (first dest) - :Pid (let [[_ n id] dest] (if (= n self) [:Here id] [:There n id])) + :Pid (let [[_ n id cr] dest] + (if (= n self) + (if (= cr creation) [:Here id] [:Gone]) + [:There n id cr])) :Name (let [[_ nm] dest] [:Named nm]) :At (let [[_ nm n] dest] (if (= n self) [:Named nm] [:NamedThere n nm])))) -(defn- own-pid? [self x] - (and (vector? x) (= 3 (count x)) (= :Pid (first x)) (= self (second x)))) - (defn arrive - "A message as node self receives it: each [:Pid self id] inside -- in a - vector, a map, a set, at any depth -- is this node's own process again, - [:Local id]; every other value is as it came." - [self v] - (walk/postwalk (fn [x] (if (own-pid? self x) [:Local (nth x 2)] x)) v)) + "What a pid that arrives at node self, in its run creation, is there: a + pid of self's current run is its own process again, [:Local id]; any + other, a pid of an earlier run among them, stays as it came." + [self creation pid] + (case (first pid) + :Pid (let [[_ n id cr] pid] + (if (and (= n self) (= cr creation)) [:Local id] pid)) + pid)) (defn on-nodedown "What losing node n does here, given the links and monitors from local @@ -35,12 +45,123 @@ order; entries for other nodes do nothing." [n links mons nmons] (vec (concat - (keep (fn [l] (let [[_ me pn pid] l] - (when (= pn n) [:Signal me [:Pid pn pid] :noconnection]))) + (keep (fn [l] (let [[_ me pn pid cr] l] + (when (= pn n) [:Signal me [:Pid pn pid cr] :noconnection]))) links) - (keep (fn [m] (let [[_ me ref pn pid] m] - (when (= pn n) [:Deliver me [:DOWN ref :process [:Pid pn pid] :noconnection]]))) + (keep (fn [m] (let [[_ me ref pn pid cr] m] + (when (= pn n) [:Deliver me [:DOWN ref :process [:Pid pn pid cr] :noconnection]]))) mons) (keep (fn [x] (let [[_ me mn] x] (when (= mn n) [:Deliver me [:nodedown mn]]))) nmons)))) + +;; --- the handshake ---------------------------------------------------------- +;; Erlang's, with the cookie digest left to a signer the node supplies: +;; +;; A -> B [:name A creation] +;; B -> A [:status s], and if s is :ok, [:challenge B creation cB] +;; A -> B [:reply cA (sign cB)] +;; B -> A [:ack (sign cA)] +;; +;; Each step takes this end's state, the frame read, and ctx: {:up-creation +;; f :pending? f :fresh c :sign f} -- the creation of the run of a peer +;; this node is connected to (nil when it is not), whether it is connecting +;; to a peer; a fresh challenge, should this step need one; and how to sign +;; a challenge with the cookie. It answers [:Next hs frames], +;; [:Up hs frames] once the peer is proved, or [:Fail reason frames]: the +;; frames to send either way. + +(defn- sorts-higher? + "Does node name a sort above node name b?" + [a b] + (pos? (compare (str a) (str b)))) + +(defn name-status + "What node self answers peer, in its run creation, with: :nok for its + own name, or a peer it is connecting to itself while its own name sorts + higher (that connection is kept instead); :alive when it is connected to + that run of peer already; :ok -- also when the connection it has is to + an earlier run of peer, which this one replaces." + [self peer creation up-creation pending?] + (cond + (= self peer) :nok + (= creation up-creation) :alive + (some? up-creation) :ok + (and pending? (sorts-higher? self peer)) :nok + :else :ok)) + +(defn on-up + "What node self does with a connection to a peer that has just come up, + given the one it has already: nil, or {:creation c :initiator node}, + initiator the node that opened it. :install it when there is none; + :replace-down when the one there is to an earlier run of the peer, which + goes down first; when both are to the same run, both ends keep the one + the higher-named node opened, so they agree: :replace or :drop." + [self existing new] + (cond + (nil? existing) :install + (not= (:creation existing) (:creation new)) :replace-down + (and (not= (:initiator existing) (:initiator new)) + (sorts-higher? (:initiator new) (:initiator existing))) :replace + :else :drop)) + +(defn open-handshake + "Start a handshake from node self, in its run creation, to node peer." + [self creation peer] + [:Next {:role :initiator :self self :creation creation :peer peer :phase :status} + [[:name self creation]]]) + +(defn accept-handshake + "The state of node self, in its run creation, waiting for a peer's name." + [self creation] + {:role :acceptor :self self :creation creation :phase :name}) + +(defn handshake + "One step of the handshake: hs read frame, in ctx (see above)." + [hs frame ctx] + (let [tag (when (vector? frame) (first frame)) + phase (:phase hs) + sign (:sign ctx)] + (cond + (and (= :name phase) (= :name tag)) + (let [[_ peer cr] frame + st (name-status (:self hs) peer cr ((:up-creation ctx) peer) ((:pending? ctx) peer))] + (if (= :ok st) + [:Next (assoc hs :phase :reply :peer peer :peer-creation cr :mine (:fresh ctx)) + [[:status :ok] [:challenge (:self hs) (:creation hs) (:fresh ctx)]]] + [:Fail [:refused st] [[:status st]]])) + (and (= :status phase) (= :status tag)) + (if (= :ok (second frame)) + [:Next (assoc hs :phase :challenge) []] + [:Fail [:refused (second frame)] []]) + (and (= :challenge phase) (= :challenge tag)) + (let [[_ nm cr c] frame] + (if (= nm (:peer hs)) + [:Next (assoc hs :phase :ack :peer-creation cr :mine (:fresh ctx)) + [[:reply (:fresh ctx) (sign c)]]] + [:Fail [:wrong-node nm] []])) + (and (= :reply phase) (= :reply tag)) + (let [[_ c digest] frame] + (if (= digest (sign (:mine hs))) + [:Up (assoc hs :phase :up) [[:ack (sign c)]]] + [:Fail :bad-cookie []])) + (and (= :ack phase) (= :ack tag)) + (if (= (second frame) (sign (:mine hs))) + [:Up (assoc hs :phase :up) []] + [:Fail :bad-cookie []]) + :else [:Fail [:unexpected frame] []]))) + +;; --- framing ---------------------------------------------------------------- + +(defn length-header + "A frame's length n as the four bytes before its payload, big-endian." + [n] + [(bit-and (bit-shift-right n 24) 255) + (bit-and (bit-shift-right n 16) 255) + (bit-and (bit-shift-right n 8) 255) + (bit-and n 255)]) + +(defn header-length + "The length four header bytes give." + [[a b c d]] + (+ (* a 16777216) (* b 65536) (* c 256) d)) diff --git a/src/ensemble/gen_event.clj b/src/ensemble/gen_event.clj index dbb1781..562e958 100644 --- a/src/ensemble/gen_event.clj +++ b/src/ensemble/gen_event.clj @@ -20,7 +20,8 @@ if the handler is removed for any reason but delete-handler!, that actor receives [:gen-event-EXIT id reason]." (:require [ensemble.actor :as act] - [ensemble.gen-server :as gs])) + [ensemble.gen-server :as gs] + [ensemble.logger :as logger])) (defprotocol Handler (h-init [this] "Return the handler's initial state.") @@ -38,19 +39,27 @@ (defn- hdel [hs id] (filterv #(not= id (:id %)) hs)) +(defn- release-owner + "Unlink owner once hs holds no handler of its, unless the two were linked + before its first handler came (a start-link parent, say)." + [hs owner linked-before?] + (when (and owner (not linked-before?) (not (some #(= owner (:owner %)) hs))) + (act/unlink! owner))) + (defn- remove-handler "Remove h for reason: run its terminate (a throw there is ignored, as in - OTP) and tell a supervising actor, unless it asked for the removal itself. - An owner left with no handler of its own is unlinked. Returns [handlers - terminate-result]." - [hs h reason tell?] - (let [r (try (h-terminate (:handler h) reason (:st h)) (catch Throwable e [:error e])) - hs* (hdel hs (:id h))] - (when-let [owner (:owner h)] - (when tell? (act/! owner [:gen-event-EXIT (:id h) reason])) - (when-not (some #(= owner (:owner %)) hs*) - (act/unlink! owner))) - [hs* r])) + OTP) and tell a supervising actor, unless it asked for the removal itself + -- told, when given, is what it hears instead of reason. An owner left + with no handler of its own is unlinked, unless release? is false. + Returns [handlers terminate-result]." + ([hs h reason tell?] (remove-handler hs h reason tell? reason true)) + ([hs h reason tell? told release?] + (let [r (try (h-terminate (:handler h) reason (:st h)) (catch Throwable e [:error e])) + hs* (hdel hs (:id h))] + (when-let [owner (:owner h)] + (when tell? (act/! owner [:gen-event-EXIT (:id h) told])) + (when release? (release-owner hs* owner (:linked-before h)))) + [hs* r]))) (defn- add "Add handler under id, at position at (the end when nil), supervised by @@ -60,7 +69,11 @@ [[:error :already-added] hs] (let [r (try [:ok (h-init handler)] (catch Throwable e [:error (act/reason-of e)]))] (if (= :ok (first r)) - (let [entry {:id id :handler handler :st (second r) :owner owner} + (let [linked-before (when owner + (if-let [same (first (filter #(= owner (:owner %)) hs))] + (:linked-before same) + (contains? (act/process-info (act/self) :links) owner))) + entry {:id id :handler handler :st (second r) :owner owner :linked-before linked-before} at (or at (count hs))] (when owner (act/link! owner)) [[:ok nil] (vec (concat (take at hs) [entry] (drop at hs)))]) @@ -69,14 +82,24 @@ (defn- swap "Replace handler h with one made by (f terminate-result) under new-id, as OTP's swap_handler: h's terminate runs with reason, and what it returns - is the new handler's start. The new one is supervised by owner." + is the new handler's start. The new one is supervised by owner. A + supervising actor of h's hears [:gen-event-EXIT id [:swapped new-id + owner]], as OTP's does." [hs h reason new-id f owner] (let [at (count (take-while #(not= (:id h) (:id %)) hs)) - [hs* res] (remove-handler hs h reason false) - handler (try (f res) (catch Throwable e e))] - (if (instance? Throwable handler) - [[:error (act/reason-of handler)] hs*] - (add hs* new-id handler owner at)))) + old-owner (:owner h) + [hs* res] (remove-handler hs h reason (some? old-owner) [:swapped new-id owner] false) + handler (try (f res) (catch Throwable e e)) + [r hs**] (if (instance? Throwable handler) + [[:error (act/reason-of handler)] hs*] + (add hs* new-id handler owner at)) + ;; the same owner keeps what it had: the link is h's, not from before + hs** (if (and owner (= owner old-owner)) + (mapv #(if (= owner (:owner %)) (assoc % :linked-before (:linked-before h)) %) hs**) + hs**)] + ;; unlinked only now, so swapping to the same owner keeps the link + (release-owner hs** old-owner (:linked-before h)) + [r hs**])) (defn- run-handler "Run (f) for handler h, a callback that answers as h-handle-event does, @@ -90,8 +113,12 @@ (or (= 2 (count r)) (= :hibernate (nth r 2)))) [(mapv #(if (= (:id h) (:id %)) (assoc % :st (second r)) %) hs) (= 3 (count r))] (and (vector? r) (= :swap-handler (first r)) (= 5 (count r))) - (let [[_ reason st new-id f] r] - [(second (swap hs (assoc h :st st) reason new-id f (:owner h))) false]) + (let [[_ reason st new-id f] r + [res hs*] (swap hs (assoc h :st st) reason new-id f (:owner h))] + (when-not (= :ok (first res)) + (logger/report! {:level :error :kind :gen-event-swap-failed :manager (act/self) + :handler (:id h) :new-handler new-id :reason (second res)})) + [hs* false]) (and (vector? r) (= ::crash (first r))) [(first (remove-handler hs h [:error (act/reason-of (second r))] true)) false] :else [(first (remove-handler hs h [:error [:bad-return-value r]] true)) false]))) diff --git a/src/ensemble/gen_server.clj b/src/ensemble/gen_server.clj index c7ee04e..df83c39 100644 --- a/src/ensemble/gen_server.clj +++ b/src/ensemble/gen_server.clj @@ -44,6 +44,17 @@ (handle-continue [this c state] "Run for a returned [:continue c], before another message; return a tagged vector.") (terminate [this reason state] "Run once as the server stops, with the reason.")) +(defprotocol FormatStatus + (format-status [this status] + "Optional, as OTP's format_status/1: take a map of what a status or a + report shows -- :state, and in a report :message and :reason -- and + return it as it should be shown, a secret left out, say.")) + +(defn formatted + "status as behaviour b would have it shown." + [b status] + (if (satisfies? FormatStatus b) (try (format-status b status) (catch Throwable _ status)) status)) + (def ^:dynamic *call-timeout* "How long call! waits for a reply by default, in ms (OTP's default)." 5000) @@ -62,10 +73,10 @@ (act/send-alias! (:alias from) [(:alias from) reply])) reply) -(defn- call-from-actor [srv request timeout-ms] +(defn- call-from-actor [tag srv request timeout-ms] (let [ref (act/monitor! srv) alias (act/alias!)] - (act/! srv [::call {:alias alias} request]) + (act/! srv [tag {:alias alias} request]) (let [r (receive [[alias reply] [:ok reply]] [[:DOWN ref :process _ reason] [:down reason]] @@ -76,16 +87,33 @@ (second r) (throw (failure (second r) request)))))) -(defn- call-from-outside [srv request timeout-ms] +(defn- call-from-outside [tag srv request timeout-ms] (let [p (promise) hook (act/on-exit! srv (fn [reason] (deliver p [:down reason])))] - (act/! srv [::call {:promise p} request]) + (act/! srv [tag {:promise p} request]) (let [r (if timeout-ms (deref p timeout-ms [:down :timeout]) @p)] (act/cancel-exit! srv hook) (if (= :reply (first r)) (second r) (throw (failure (second r) request)))))) +(defn- request! + "Send [tag from request] to srv and wait for the reply, as call! does." + [tag srv request timeout-ms] + (let [timeout-ms (act/timeout-ms timeout-ms) + target (try (act/resolve-dest srv) + (catch Throwable _ (throw (failure :noproc request))))] + (cond + (= target (act/self)) (throw (failure :calling-self request)) + (act/self) (call-from-actor tag target request timeout-ms) + ;; a reply from another node comes to an actor's alias: a promise + ;; cannot cross, so a short-lived actor makes the call + (act/remote? target) (let [p (promise)] + (act/spawn (fn [] (deliver p (try [:ok (call-from-actor tag target request timeout-ms)] + (catch Throwable e [:err e]))))) + (let [[k v] @p] (if (= :ok k) v (throw v)))) + :else (call-from-outside tag target request timeout-ms)))) + (defn call! "Send request to the server srv (an actor or a registered name) and wait for its reply, up to timeout-ms (default *call-timeout*; nil or :infinity @@ -93,20 +121,59 @@ Throws if the server is not running, exits before replying, or the timeout elapses; the ex-data :reason says which." ([srv request] (call! srv request *call-timeout*)) - ([srv request timeout-ms] - (let [timeout-ms (act/timeout-ms timeout-ms) - target (try (act/resolve-dest srv) - (catch Throwable _ (throw (failure :noproc request))))] - (cond - (= target (act/self)) (throw (failure :calling-self request)) - (act/self) (call-from-actor target request timeout-ms) - ;; a reply from another node comes to an actor's alias: a promise - ;; cannot cross, so a short-lived actor makes the call - (act/remote? target) (let [p (promise)] - (act/spawn (fn [] (deliver p (try [:ok (call-from-actor target request timeout-ms)] - (catch Throwable e [:err e]))))) - (let [[k v] @p] (if (= :ok k) v (throw v)))) - :else (call-from-outside target request timeout-ms))))) + ([srv request timeout-ms] (request! ::call srv request timeout-ms))) + +(defn system-call! + "Send a system message, as sys does, to a behaviour's process and wait + for its answer. See ensemble.sys." + [srv request timeout-ms] + (request! ::system srv request timeout-ms)) + +;; --- system messages ------------------------------------------------------------ +;; A behaviour's process answers sys's requests between its own messages. +;; What it keeps for them, dbg, is {:suspended bool :trace bool :stats +;; {:start-time ms :messages-in n} or nil}. + +(def no-debug {:suspended false :trace false :stats nil}) + +(defn handle-system + "Answer the system request req from from, in a behaviour whose state as + sys sees it is st and whose status (status dbg) describes. Returns [dbg + st]: what the process keeps from now on. A state replace-state makes + that valid? refuses is an error, and the state is left." + ([dbg req from st status] (handle-system dbg req from st status any?)) + ([dbg req from st status valid?] + (let [answer (fn [v] (reply! from v)) + [tag arg] (if (vector? req) req [req])] + (case tag + :get-state (do (answer [:ok st]) [dbg st]) + :replace-state (let [r (try (let [new (arg st)] + (if (valid? new) [:ok new] [:error [:bad-state new]])) + (catch Throwable e [:error e]))] + (answer r) + [dbg (if (= :ok (first r)) (second r) st)]) + :get-status (do (answer [:ok (status dbg)]) [dbg st]) + :suspend (do (answer [:ok :ok]) [(assoc dbg :suspended true) st]) + :resume (do (answer [:ok :ok]) [(assoc dbg :suspended false) st]) + :trace (do (answer [:ok :ok]) [(assoc dbg :trace (boolean arg)) st]) + :statistics (case arg + true (do (answer [:ok :ok]) + [(assoc dbg :stats {:start-time (System/currentTimeMillis) :messages-in 0}) st]) + false (do (answer [:ok :ok]) [(assoc dbg :stats nil) st]) + (do (answer [:ok (if-let [s (:stats dbg)] + (assoc s :current-time (System/currentTimeMillis)) + :no-statistics)]) + [dbg st])) + (do (answer [:error [:unknown-system-msg req]]) [dbg st]))))) + +(defn observed + "dbg once the process has taken event, an ordinary message: counted, and + reported while tracing." + [dbg event] + (when (:trace dbg) + (logger/report! {:level :debug :kind :sys-trace :pid (act/self) + :name (act/registered-name (act/self)) :event event})) + (if (:stats dbg) (update-in dbg [:stats :messages-in] inc) dbg)) ;; --- asynchronous calls ------------------------------------------------------ @@ -201,6 +268,35 @@ (try (act/! srv [::cast request]) (catch Throwable _ nil)) :ok) +(defn multi-call + "Call the server registered as nm on each of nodes (default: this node + and every node it is connected to) at once, as gen_server:multi_call, + waiting up to timeout-ms (default :infinity) for all. Returns [replies + bad-nodes]: replies as [[node reply] ...], and the nodes whose server + was not there, failed, or did not answer in time." + ([nm request] (multi-call (into [(act/node)] (act/nodes)) nm request :infinity)) + ([nodes nm request] (multi-call nodes nm request :infinity)) + ([nodes nm request timeout-ms] + (let [here (act/node) + asks (mapv (fn [n] + (let [p (promise)] + (binding [act/*node* here] + (act/spawn (fn [] (deliver p (try [:ok (call! [:At nm n] request timeout-ms)] + (catch Throwable _ [:bad])))))) + [n p])) + nodes) + rs (mapv (fn [[n p]] [n @p]) asks)] + [(vec (for [[n [k v]] rs :when (= :ok k)] [n v])) + (vec (for [[n [k]] rs :when (= :bad k)] n))]))) + +(defn abcast + "Cast request to the server registered as nm on each of nodes (default: + this node and its peers), as gen_server:abcast. Returns :abcast." + ([nm request] (abcast (into [(act/node)] (act/nodes)) nm request)) + ([nodes nm request] + (doseq [n nodes] (cast! [:At nm n] request)) + :abcast)) + (defn- last-message "The message a server was handling as it stopped, as a report shows it." [m] @@ -210,11 +306,12 @@ (defn- report-terminate! "Report a server stopping with reason after m, unless the stop is orderly." - [reason m state] + [server reason m state] (when-not (sig/shutdown? reason) - (logger/report! {:level :error :kind :gen-server-terminate :server (act/self) - :name (act/registered-name (act/self)) :last-message (last-message m) - :state state :reason reason}))) + (let [shown (formatted server {:state state :message (last-message m) :reason reason})] + (logger/report! {:level :error :kind :gen-server-terminate :server (act/self) + :name (act/registered-name (act/self)) :last-message (:message shown) + :state (:state shown) :reason (:reason shown)})))) (defn- finish "Run terminate with reason and exit with it, reporting an abnormal stop @@ -223,7 +320,7 @@ [server reason state m] (let [reason (try (terminate server reason state) reason (catch Throwable e (act/reason-of e)))] - (report-terminate! reason m state) + (report-terminate! server reason m state) (act/exit! reason))) (defn- crash-reason [e] (act/reason-of e)) @@ -241,49 +338,77 @@ :info (cb/interpret :other (handle-info server (nth m 1) st))) (catch Throwable e [:Crash (crash-reason e)]))) +(defn system-message + "While suspended, the next message a behaviour may take: a system + message, a stop, or its parent's exit, as [:system from req], [:stop + reason] or [:parent reason]." + [parent] + (receive + [[::system from req] [:system from req]] + [[::stop reason] [:stop reason]] + [[:EXIT from reason] :when (and (some? parent) (= from parent)) [:parent reason]])) + (defn- next-message "What the server handles next, once a callback asked for [:Wait t] or [:Cont c]: a pending continue before anything in the mailbox, else the next message, or [:timeout] when t elapses first. With no t and a - hibernate-after, [:idle] when that long passes with no message." - [parent next hibernate-after] - (case (first next) - :Cont [:continue (second next)] + hibernate-after, [:idle] when that long passes with no message. A + suspended server takes only system-message's." + [parent next hibernate-after suspended?] + (cond + suspended? (system-message parent) + (= :Cont (first next)) [:continue (second next)] + :else (let [t (second next)] (receive [[::call from request] [:call from request]] [[::cast request] [:cast request]] [[::stop reason] [:stop reason]] + [[::system from req] [:system from req]] [[:EXIT from reason] :when (and (some? parent) (= from parent)) [:parent reason]] [:after (or t hibernate-after) (if t [:timeout] [:idle])] [msg [:info msg]])))) +(defn- status-of + "What sys/get-status shows of a server." + [server parent st dbg] + {:pid (act/self) :name (act/registered-name (act/self)) :module (type server) + :status (if (:suspended dbg) :suspended :running) :parent parent + :state (:state (formatted server {:state st}))}) + (defn- run-loop "Serve until the server stops. A :hibernate action, or idle ms with no message, hibernates the process: its stack goes, and the next message runs this again. idle is {:after ms :disk? bool}; with :disk? an idle - server is passivated, kept on disk until its next message." - [server parent st next idle] - (loop [st st, next next] - (when (= :Hibernate (first next)) - (act/hibernate! run-loop server parent st [:Wait nil] idle)) - (let [m (next-message parent next (:after idle))] - (case (first m) - :idle (if (:disk? idle) - (act/passivate! run-loop server parent st [:Wait nil] idle) - (act/hibernate! run-loop server parent st [:Wait nil] idle)) - :stop (finish server (second m) st m) - :parent (finish server (second m) st [:EXIT parent (second m)]) - (let [step (dispatch server st m)] - (case (first step) - :Reply (do (reply! (second m) (nth step 1)) - (recur (nth step 2) (nth step 3))) - :NoReply (recur (nth step 1) (nth step 2)) - :Stop (let [[_ reason reply? reply st*] step] - (when reply? (reply! (second m) reply)) - (finish server reason st* m)) - :Bad (finish server [:bad-return-value (nth step 1)] st m) - :Crash (finish server (nth step 1) st m))))))) + server is passivated, kept on disk until its next message. dbg is what + it keeps for system messages." + ([server parent st next idle] (run-loop server parent st next idle no-debug)) + ([server parent st next idle dbg] + (loop [st st, next next, dbg dbg] + (when (= :Hibernate (first next)) + (act/hibernate! run-loop server parent st [:Wait nil] idle dbg)) + (let [m (next-message parent next (:after idle) (:suspended dbg))] + (case (first m) + :idle (if (:disk? idle) + (act/passivate! run-loop server parent st [:Wait nil] idle dbg) + (act/hibernate! run-loop server parent st [:Wait nil] idle dbg)) + :stop (finish server (second m) st m) + :parent (finish server (second m) st [:EXIT parent (second m)]) + :system (let [[_ from req] m + [dbg st] (handle-system dbg req from st #(status-of server parent st %))] + ;; a pending continue or timeout is kept across a system message + (recur st next dbg)) + (let [dbg (observed dbg (last-message m)) + step (dispatch server st m)] + (case (first step) + :Reply (do (reply! (second m) (nth step 1)) + (recur (nth step 2) (nth step 3) dbg)) + :NoReply (recur (nth step 1) (nth step 2) dbg) + :Stop (let [[_ reason reply? reply st*] step] + (when reply? (reply! (second m) reply)) + (finish server reason st* m)) + :Bad (finish server [:bad-return-value (nth step 1)] st m) + :Crash (finish server (nth step 1) st m)))))))) (defn- run [server parent ack idle] (let [r (try (cb/interpret-init (init server)) @@ -299,6 +424,21 @@ :Ignore (quit! [:ignore] :normal) :Fail (let [[_ why exit] r] (quit! [:error why] exit))))) +(defn enter-loop + "Make the calling actor server, with state, as gen_server:enter_loop: + init is not called. action is one init could return with its state (a + timeout, :hibernate or [:continue c]). opts: :name, which the actor must + already be registered under (else it exits :process-not-registered), + :hibernate-after, and :parent, the actor whose exit stops it. Never + returns." + ([server opts state] (enter-loop server opts state nil)) + ([server {:keys [name parent hibernate-after]} state action] + (when (and name (not= (act/self) (act/whereis name))) + (act/exit! :process-not-registered)) + (let [r (cb/interpret-init (if (some? action) [:ok state action] [:ok state]))] + (when-not (= :Start (first r)) (act/exit! [:bad-return-value action])) + (run-loop server parent state (nth r 2) (when hibernate-after {:after hibernate-after :disk? false}))))) + (defn await-init "What a behaviour's start answers once its process srv has run init, which delivers [:ok], [:ignore] or [:error reason] to ack: srv, :ignore, or a @@ -314,10 +454,21 @@ (case (first r) :ok srv :ignore :ignore - :timeout (do (when (act/self) (act/unlink! srv)) + :timeout (do (when (act/self) + (act/unlink! srv) + ;; an init that died as the wait ran out may have sent its + ;; exit already: a trapping starter does not keep it + (when (act/process-info (act/self) :trap-exit) + (receive [[:EXIT srv _] nil] [:after 0 nil]))) (act/exit! srv :kill) (act/exit-reason srv) - (throw (ex-info (str what " init timed out") {:reason :timeout}))) + ;; and the start fails with what it died of, not :timeout + (let [late (deref ack 0 nil)] + (if (= :error (first late)) + (throw (ex-info (str what " init failed: " (pr-str (second late))) + {:reason (second late)} + (when (instance? Throwable (second late)) (second late)))) + (throw (ex-info (str what " init timed out") {:reason :timeout}))))) (throw (ex-info (str what " init failed: " (pr-str (second r))) {:reason (second r)} (when (instance? Throwable (second r)) (second r))))))) @@ -329,7 +480,7 @@ (act/spawn (fn [] (run server parent ack (cond passivate-after {:after passivate-after :disk? true} hibernate-after {:after hibernate-after :disk? false}))) - {:name name :link link? :trap trap}) + {:name name :link link? :trap trap :initial-call [(type server) :init]}) (catch Throwable e (if-let [holder (and name (act/whereis name))] (throw (ex-info "gen-server already started" diff --git a/src/ensemble/gen_statem.clj b/src/ensemble/gen_statem.clj index 0d1976e..ec2cc81 100644 --- a/src/ensemble/gen_statem.clj +++ b/src/ensemble/gen_statem.clj @@ -1,6 +1,5 @@ (ns ensemble.gen-statem - "The OTP gen_statem behaviour, in handle_event_function mode: one callback - receives every event with the current state and data. + "The OTP gen_statem behaviour. A machine is a record implementing Machine: @@ -9,6 +8,13 @@ (handle-event this type content state data) -> a result (terminate this reason state data) + That is handle_event_function mode: one callback receives every event. A + machine that also implements StateFunctions runs in state_functions mode + instead: (state-functions this) returns a map from each state to its fn, + called as (f type content data), and handle-event is not called. An + event in a state with no fn stops the machine with + [:undefined-state-function state]. + An event's type is [:call from], :cast, :info, :timeout (the event timeout), :state-timeout, [:generic-timeout name], :internal (from a :next-event action) or :enter. Results and actions are gen_statem's; see @@ -18,7 +24,8 @@ With {:state-enter true}, the machine is also called with type :enter, content the old state, on its first state and after every state change. - Clients use ensemble.gen-server's call!, cast! and stop!: a gen-statem + Clients use ensemble.gen-server's call!, cast! and stop!, and + ensemble.sys, whose state of a machine is [state data]: a gen-statem speaks the same protocol, so a call's reply, a dead machine's :noproc and a timeout behave exactly as for a gen-server. Answer a call with a [:reply from value] action or with reply!." @@ -34,19 +41,32 @@ (handle-event [this type content state data] "Return a gen_statem result.") (terminate [this reason state data] "Run once as the machine stops.")) +(defprotocol StateFunctions + (state-functions [this] "A map from each state to its fn, (f type content data) -> a result.")) + +(defn- callback + "Run the machine's callback for an event in state." + [m type content state data] + (if (satisfies? StateFunctions m) + (if-let [f (get (state-functions m) state)] + (f type content data) + (act/exit! [:undefined-state-function state])) + (handle-event m type content state data))) + (def reply! gs/reply!) (defn- now [] (act/now-ms)) (defn- arm "Timers as {key [deadline content]} from the pure timers {key [ms content]} - of this transition: a timer an action set starts now, one the transition - left alone keeps its deadline." - [touched pure deadlines] - (into {} (for [[k v] pure] - [k (if (and (not (contains? touched k)) (contains? deadlines k)) - (get deadlines k) - [(+ (now) (first v)) (second v)])]))) + of this transition: a timer the transition started runs from now, or to + its [:abs t] deadline; any other keeps its deadline, with the content an + update gave it." + [started pure deadlines] + (into {} (for [[k [ms content]] pure] + [k (if (and (not (contains? started k)) (contains? deadlines k)) + [(first (get deadlines k)) content] + [(if (vector? ms) (second ms) (+ (now) ms)) content])]))) (defn- finish "Run terminate with reason and exit with it, reporting an abnormal stop @@ -55,17 +75,17 @@ (let [reason (try (terminate m reason (:state st) (:data st)) reason (catch Throwable e (act/reason-of e)))] (when-not (sig/shutdown? reason) - (let [[type content] event] + (let [[type content] event + shown (gs/formatted m {:state (:state st) :data (:data st) :reason reason + :message [(if (vector? type) (first type) type) content]})] (logger/report! {:level :error :kind :gen-statem-terminate :server (act/self) :name (act/registered-name (act/self)) - :last-event [(if (vector? type) (first type) type) content] - :state (:state st) :data (:data st) :reason reason}))) + :last-event (:message shown) + :state (:state shown) :data (:data shown) :reason (:reason shown)}))) (act/exit! reason))) -(defn- next-event-of - "Wait for the next external event, or the earliest timer. Returns - [event st]; a timer that fires is removed. With idle ms and no timer - due sooner, [[:idle] st] when that long passes with no event." +(defn- next-unsuspended + "next-event-of, for a machine that is not suspended." [parent st idle] (let [[k [deadline content]] (first (sort-by (comp first val) (:deadlines st))) timer-wait (when k (max 0 (- deadline (now)))) @@ -75,28 +95,39 @@ [[::gs/call from request] [:event [[:call from] request]]] [[::gs/cast request] [:event [:cast request]]] [[::gs/stop reason] [:stop reason]] + [[::gs/system from req] [:system from req]] [[:EXIT from reason] :when (and (some? parent) (= from parent)) [:stop reason]] [[::wake] [:wake]] [:after wait (if idle? [:idle] [:timer k content])] [msg [:event [:info msg]]])] (case (first m) ;; the timer that woke a hibernating machine for its next timeout - :wake (recur parent st idle) + :wake (next-unsuspended parent st idle) :idle [m st] :stop [m st] + :system [m st] :event [m st] :timer (let [[_ k content] m type (if (vector? k) [:generic-timeout (second k)] ({:event :timeout :state :state-timeout} k))] [[:event [type content]] (-> st (update :timers dissoc k) (update :deadlines dissoc k))])))) +(defn- next-event-of + "Wait for the next external event, or the earliest timer. Returns + [event st]; a timer that fires is removed. With idle ms and no timer + due sooner, [[:idle] st] when that long passes with no event." + [parent st idle] + (if (:suspended (:dbg st)) + [(gs/system-message parent) st] + (next-unsuspended parent st idle))) + (defn transition! "Handle one event: run the callback, then do what ensemble.statem says of its result -- send the replies, move the queues, arm the timers, run the enter call on a state change. Returns the machine's next st, or exits." [m opts st event kind] (let [[type content] event - ret (try (handle-event m type content (:state st) (:data st)) + ret (try (callback m type content (:state st) (:data st)) (catch Throwable e [::crash (act/reason-of e)])) r (if (and (vector? ret) (= ::crash (first ret))) ret (sm/result-of kind ret (:state st) (:data st)))] (case (first r) @@ -105,21 +136,30 @@ :Stop (let [[_ reason replies data] r] (doseq [[from v] (map rest replies)] (reply! from v)) (finish m reason (assoc st :data data) event)) - :Transition - (let [[_ state data actions] r + (:Transition :Repeat) + (let [[tag state data actions] r [_ postpone? inserted replies timeouts] (sm/actions-of actions) changed? (not= state (:state st)) [_ postponed queue] (if (= :enter kind) [:Queues (:postponed st) (:queue st)] (sm/next-queues changed? postpone? event (:postponed st) inserted (:queue st))) - timers (sm/next-timers changed? (:timers st) timeouts) + enter? (= :enter kind) + timers (if enter? + (sm/enter-timers (:timers st) timeouts) + (sm/next-timers changed? (:timers st) timeouts)) ;; the event timeout only runs while nothing is waiting to be handled timers (if (seq queue) (dissoc timers :event) timers) st* (assoc st :state state :data data :postponed postponed :queue queue - :timers timers :deadlines (arm (set (map first timeouts)) timers (:deadlines st)) + :timers timers + :deadlines (arm (if enter? + (sm/enter-restarted (:timers st) timeouts) + (sm/restarted changed? (:timers st) timeouts)) + timers (:deadlines st)) :hibernate (sm/hibernate? actions))] (doseq [[from v] replies] (reply! from v)) - (if (and changed? (:state-enter opts)) + ;; a repeat runs the enter call again as if the state were new; one + ;; from an enter call is a keep, as OTP's is + (if (and (or changed? (and (= :Repeat tag) (not enter?))) (:state-enter opts)) (transition! m opts st* [:enter (:state st)] :enter) st*))))) @@ -128,11 +168,30 @@ (defn- hibernate! "Hibernate before waiting for the next event: the stack goes, and the next message -- or a timer set to the earliest timeout, which a - hibernating machine must still see -- runs the loop again." + hibernating machine must still see -- runs the loop again. The wake + timer of an earlier hibernation is cancelled, so idle cycles do not pile + them up." [m opts parent st] - (when-let [deadline (first (sort (map first (vals (:deadlines st)))))] - (timer/send-after (max 0 (- deadline (now))) (act/self) [::wake])) - (act/hibernate! run-loop m opts parent (dissoc st :hibernate))) + (when-let [t (:wake-timer st)] (timer/cancel-timer t {:async true :info false})) + (let [wake (when-let [deadline (first (sort (map first (vals (:deadlines st)))))] + (timer/send-after (max 0 (- deadline (now))) (act/self) [::wake]))] + (act/hibernate! run-loop m opts parent (-> st (dissoc :hibernate) (assoc :wake-timer wake))))) + +(defn- status-of + "What sys/get-status shows of a machine." + [m parent st dbg] + (let [shown (gs/formatted m {:state (:state st) :data (:data st)})] + {:pid (act/self) :name (act/registered-name (act/self)) :module (type m) + :status (if (:suspended dbg) :suspended :running) :parent parent + :state (:state shown) :data (:data shown)})) + +(defn- system! + "Answer a system message; sys sees the machine's state as [state data]." + [m parent st from req] + (let [[dbg [state data]] (gs/handle-system (:dbg st) req from [(:state st) (:data st)] + #(status-of m parent st %) + #(and (vector? %) (= 2 (count %))))] + (assoc st :dbg dbg :state state :data data))) (defn- run-loop [m opts parent st] (loop [st st] @@ -141,9 +200,27 @@ (let [_ (when (:hibernate st) (hibernate! m opts parent st)) [msg st] (next-event-of parent st (:hibernate-after opts))] (case (first msg) - :stop (finish m (second msg) st msg) + (:stop :parent) (finish m (second msg) st msg) :idle (hibernate! m opts parent st) - (recur (transition! m opts st (second msg) :event))))))) + :system (let [[_ from req] msg] (recur (system! m parent st from req))) + (let [[type content] (second msg) + st (update st :dbg gs/observed [(if (vector? type) (first type) type) content])] + (recur (transition! m opts st (second msg) :event)))))))) + +(defn- begin + "Run the machine from state and data with init's actions, ack (if any) + delivered once they are taken. Never returns." + [m opts parent ack state data actions] + (let [st {:state state :data data :postponed [] :queue [] :timers {} :deadlines {} + :dbg gs/no-debug} + [_ _ inserted replies timeouts] (sm/actions-of actions) + timers (sm/next-timers false {} timeouts) + st (assoc st :queue inserted :timers timers + :deadlines (arm (sm/restarted false {} timeouts) timers {}))] + (doseq [[from v] replies] (reply! from v)) + (when ack (deliver ack [:ok])) + (let [st (if (:state-enter opts) (transition! m opts st [:enter state] :enter) st)] + (run-loop m opts parent st)))) (defn- run [m opts parent ack] (let [r (try (sm/init-of (init m)) @@ -155,21 +232,25 @@ (case (first r) :Ignore (quit! [:ignore] :normal) :Fail (let [[_ why exit] r] (quit! [:error why] exit)) - :Start - (let [[_ state data actions] r - st {:state state :data data :postponed [] :queue [] :timers {} :deadlines {}} - [_ _ inserted replies timeouts] (sm/actions-of actions) - timers (sm/next-timers false {} timeouts) - st (assoc st :queue inserted :timers timers :deadlines (arm (set (map first timeouts)) timers {}))] - (doseq [[from v] replies] (reply! from v)) - (deliver ack [:ok]) - (let [st (if (:state-enter opts) (transition! m opts st [:enter state] :enter) st)] - (run-loop m opts parent st)))))) + :Start (let [[_ state data actions] r] + (begin m opts parent ack state data actions))))) + +(defn enter-loop + "Make the calling actor machine m, in state with data, as gen_statem's + enter_loop: init is not called, and actions are taken as init's would + be. opts are start's (:state-enter, :hibernate-after), and :parent, the + actor whose exit stops it. Never returns." + ([m opts state data] (enter-loop m opts state data [])) + ([m opts state data actions] + (let [as (sm/init-of [:ok state data actions])] + (when (= :Fail (first as)) (act/exit! (second as))) + (begin m opts (:parent opts) nil state data (nth as 3))))) (defn- start* [m {:keys [name trap timeout] :as opts} link?] (let [ack (promise) parent (when link? (act/self)) - a (act/spawn (fn [] (run m opts parent ack)) {:name name :link link? :trap trap})] + a (act/spawn (fn [] (run m opts parent ack)) + {:name name :link link? :trap trap :initial-call [(type m) :init]})] (gs/await-init a ack timeout "gen-statem"))) (defn start diff --git a/src/ensemble/global.clj b/src/ensemble/global.clj new file mode 100644 index 0000000..6dde4ef --- /dev/null +++ b/src/ensemble/global.clj @@ -0,0 +1,197 @@ +(ns ensemble.global + "A name registry over every connected node, as OTP's global. + + Each node runs a registrar, which holds a copy of the table of names. + Registering a name locks it on every node -- in node order, and backing + off when another registration holds a lock, so two never wait on each + other -- checks that no node has it, then sets it on all. A name is + released everywhere when its process exits, and a node's names when the + connection to it is lost. When two nodes connect they send each other + their tables; a name both hold for different processes keeps the one + whose pid sorts first, on both nodes alike, and the other process is + killed, as global's default resolve does. + + [:global nm] is a name wherever one is taken -- !, gen-server's start + and call!, monitor! -- as OTP's {global, Name}." + (:require [clojure.core.async :as a] + [ensemble.actor :as act :refer [receive]] + [ensemble.gen-server :as gs] + [ensemble.node :as node] + [ensemble.process :as proc] + [ensemble.registry :as reg])) + +(defonce ^:private tables + ;; node -> {name pid}: each node's copy, written only by its registrar + (atom {})) + +(defn- table [] (get @tables (act/node) {})) + +(defn- pid-order + "Where a pid sorts, to settle a clash the same way on every node." + [p] + [(str (proc/-node p)) (proc/-pid p)]) + +(defn- bind + "st with nm bound to pid on this node, monitoring pid." + [st nm pid] + (let [mref (act/monitor! pid)] + (swap! tables assoc-in [(act/node) nm] pid) + (assoc-in st [:mons mref] [nm pid]))) + +(defn- unbind + "st with nm released on this node, if it is still bound to pid (any pid + when pid is nil)." + [st nm pid] + (let [cur (get (table) nm)] + (if (and cur (or (nil? pid) (= pid cur))) + (let [mrefs (keep (fn [[r [n p]]] (when (and (= n nm) (= p cur)) r)) (:mons st))] + (doseq [r mrefs] (act/demonitor! r {:flush true})) + (swap! tables update (act/node) dissoc nm) + (update st :mons #(apply dissoc % mrefs))) + st))) + +(defn- merge-entry + "st once the binding nm -> pid, sent by a peer, is merged in." + [st nm pid] + (let [cur (get (table) nm)] + (cond + (nil? cur) (bind st nm pid) + (= cur pid) st + :else (let [[keep lose] (sort-by pid-order [cur pid])] + (try (act/exit! lose :kill) (catch Throwable _ nil)) + (if (= keep cur) st (bind (unbind st nm cur) nm keep)))))) + +(defn- unlock [st nm owner] + (if (= owner (first (get-in st [:locks nm]))) + (do (act/demonitor! (second (get-in st [:locks nm])) {:flush true}) + (update st :locks dissoc nm)) + st)) + +(defrecord Registrar [] + gs/Server + (init [_] + (node/monitor-nodes! true) + [:ok {:locks {} :mons {}}]) + (handle-call [_ req _ st] + (case (first req) + :lock (let [[_ nm owner] req + holder (first (get-in st [:locks nm]))] + (cond + (= holder owner) [:reply [:ok (get (table) nm)] st] + holder [:reply :busy st] + :else [:reply [:ok (get (table) nm)] + (assoc-in st [:locks nm] [owner (act/monitor! owner)])])) + :unlock (let [[_ nm owner] req] [:reply :ok (unlock st nm owner)]) + :register (let [[_ nm pid] req] [:reply :ok (bind (unbind st nm nil) nm pid)]) + :unregister (let [[_ nm] req] [:reply :ok (unbind st nm nil)]))) + (handle-cast [_ req st] + (case (first req) + :sync (let [[_ entries] req] [:noreply (reduce (fn [s [nm pid]] (merge-entry s nm pid)) st entries)]))) + (handle-info [_ msg st] + (cond + (and (vector? msg) (= :DOWN (first msg))) + (let [[_ mref] msg] + (if-let [[nm pid] (get-in st [:mons mref])] + [:noreply (-> (unbind st nm pid) (update :mons dissoc mref))] + ;; a registration that held a lock died + (let [nm (some (fn [[n [_ r]]] (when (= r mref) n)) (:locks st))] + [:noreply (if nm (update st :locks dissoc nm) st)]))) + (and (vector? msg) (= :nodeup (first msg))) + (do (gs/cast! [:At ::registrar (second msg)] [:sync (vec (table))]) + [:noreply st]) + (and (vector? msg) (= :nodedown (first msg))) + (let [peer (second msg)] + [:noreply (reduce (fn [s [nm pid]] (if (= peer (proc/-node pid)) (unbind s nm pid) s)) + st (table))]) + :else [:noreply st])) + (handle-timeout [_ st] [:noreply st]) + (handle-continue [_ _ st] [:noreply st]) + (terminate [_ _ _] nil)) + +(defn- ensure-registrar! + "This node's registrar, started if it is not running." + [] + (or (act/whereis ::registrar) + (try (gs/start (->Registrar) {:name ::registrar}) + (catch Throwable _ (act/whereis ::registrar))))) + +(node/on-start! ::registrar (fn [_] (ensure-registrar!))) + +(defn- all-nodes [] (sort-by str (distinct (cons (act/node) (act/nodes))))) + +(defn- ask + "Call the registrar of node n; nil when it cannot be reached." + [n req] + (try (gs/call! [:At ::registrar n] req 5000) (catch Throwable _ nil))) + +(defn- in-actor + "(f) in a fresh actor of this node, which is the owner of its locks." + [f] + (let [p (promise)] + (act/spawn (fn [] (deliver p (try [:ok (f)] (catch Throwable e [:err e]))))) + (let [[k v] @p] (if (= :ok k) v (throw v))))) + +(defn register-name + "Register pid under nm on every connected node. :yes, or :no when a + live process anywhere has the name already." + [nm pid] + (ensure-registrar!) + (in-actor + (fn [] + (let [me (act/self)] + (loop [attempt 0] + (let [ns (all-nodes) + got (reduce (fn [acc n] + (let [r (ask n [:lock nm me])] + (if (= :busy r) (reduced (conj acc [n :busy])) (conj acc [n r])))) + [] ns) + release! #(doseq [[n r] got :when (vector? r)] (ask n [:unlock nm me]))] + (if (some #(= :busy (second %)) got) + (do (release!) + (when (> attempt 200) (throw (ex-info "global lock not taken" {:reason :timeout :name nm}))) + (a/GlobalRegistry)) diff --git a/src/ensemble/logger.clj b/src/ensemble/logger.clj index bbd1805..6857558 100644 --- a/src/ensemble/logger.clj +++ b/src/ensemble/logger.clj @@ -2,7 +2,8 @@ "Reports, as OTP's logger receives them from the runtime and the behaviours. A report is a map with a :level and a :kind: - :crash-report an actor's body threw: :pid, :name, :reason + :crash-report an actor's body threw: :pid, :name, :reason, + :initial-call, :ancestors :gen-server-terminate a gen-server stopped abnormally: :server, :name, :last-message, :state, :reason :gen-statem-terminate the same for a gen-statem, with :last-event, @@ -13,7 +14,10 @@ An orderly end -- :normal, :shutdown or [:shutdown term] -- is never reported, nor is an actor's own (exit! reason): only a throw it did not - catch is a crash, as the emulator reports only an uncaught error. + catch is a crash, as the emulator reports only an uncaught error. An + exit whose reason is a throwable counts as that throw: it is how a + behaviour passes on a crash in its callback, which OTP reports as a + crash too, beside the behaviour's own report. Every report goes to one handler, a fn of the report, which prints it to *err* until set-handler! installs another. A handler that throws is diff --git a/src/ensemble/match.clj b/src/ensemble/match.clj index a80205c..89a0887 100644 --- a/src/ensemble/match.clj +++ b/src/ensemble/match.clj @@ -17,6 +17,9 @@ [:Bind s] matches anything, binds s to the message [:Cons p q] matches a non-empty sequential message whose first element matches p and rest matches q + [:IsMap] matches any map + [:Has k p q] matches a map holding key k whose value there matches + p, and which itself matches q As in Erlang, a name bound twice in one pattern must match equal values: [x x] matches [1 1] but not [1 2]. @@ -62,4 +65,13 @@ nil (let [c (capture tl (rest m))] (if (nil? c) nil (agree b c))))) - nil)))) + nil)) + :IsMap (if (map? m) {} nil) + :Has (let [[_ k vp q] p] + (if (and (map? m) (contains? m k)) + (let [b (capture vp (get m k))] + (if (nil? b) + nil + (let [c (capture q m)] + (if (nil? c) nil (agree b c))))) + nil)))) diff --git a/src/ensemble/node.clj b/src/ensemble/node.clj index 303c2a7..2725353 100644 --- a/src/ensemble/node.clj +++ b/src/ensemble/node.clj @@ -10,12 +10,28 @@ call, a supervisor's link to its child, or a monitor works the same whether the other end is in this VM, another OS process or another machine. Where each operation goes, what a pid in a message is on - arrival, and what a lost connection does are decided by ensemble.dist. - - Connections come from a Transport. The loopback transport connects nodes - running in one VM, each frame still printed and read back, so what - crosses is exactly what a wire carries; a byte-stream transport (TCP - between OS processes or machines) plugs in the same way. + arrival, what a lost connection does, and every step of the handshake + are decided by ensemble.dist. + + The layers, bottom up: + - a Transport (ensemble.transport) carries a byte stream between two + nodes. That is all a transport library implements; the loopback + transport connects nodes in one VM; + - each frame on the stream is its length, four bytes, then its payload, + which a Codec (ensemble.codec, EDN by default) turns into a value; + - a connection is used only once the handshake has named the peer and + each end has proved it holds the cookie, by signing the other's + challenge with HMAC-SHA256; + - then frames carry the operations of the distribution protocol, each + an envelope [op hdr body]: hdr the operation's own fields (the pids + it names, a ref, a name), body the data it carries -- a message, an + exit reason. A pid in hdr is known by its field; in body each pid + and throwable is tagged, and data that looks like a tag is escaped, + so whatever a process sends arrives as it was sent. + + Each start of a node draws a creation number, and a pid carries its + node's: a pid of an earlier run of a node names no process of a later + one, though the id may be in use again. As in Erlang: - a pid in a message crosses as data and arrives as a pid again; @@ -25,42 +41,75 @@ noconnection, every monitor across it fires with noconnection, and every monitor_node of the peer gets [:nodedown peer]; - (spawn-on node f-sym args) starts a process there, from a fn named by - symbol, as spawn(Node, M, F, A) does." + symbol, as spawn(Node, M, F, A) does -- only from a peer that passed + the handshake, and only a fn the node allows." (:require [clojure.core.async :as a] [clojure.edn :as edn] - [clojure.walk :as walk] [ensemble.actor :as act] + [ensemble.codec :as codec] + [ensemble.digest :as digest] [ensemble.dist :as dist] - [ensemble.process :as proc])) + [ensemble.logger :as logger] + [ensemble.process :as proc] + [ensemble.transport :as tr])) + +;; --- authentication ----------------------------------------------------- + +(defprotocol Auth + (-sign [a challenge] + "Sign challenge, a string, as only a node that may connect could. + Both ends of a connection must sign alike.")) + +(defrecord CookieAuth [key] + Auth + (-sign [_ challenge] (digest/hex (digest/hmac-sha-256 key (vec (.getBytes ^String challenge "UTF-8")))))) -;; --- transports --------------------------------------------------------- +(defn cookie-auth + "Authentication by a shared secret, Erlang's cookie: a challenge is + signed with HMAC-SHA256 under it." + [cookie] + (->CookieAuth (vec (.getBytes ^String (str cookie) "UTF-8")))) -(defprotocol Transport - (-connect [t from to on-frame on-close] - "Open a connection from node from to node to. Frames the peer sends - are handed to (on-frame frame-string); (on-close) runs once when the - connection is lost. Returns a Conn, or nil when to cannot be - reached.")) +(defonce ^:private rng (java.security.SecureRandom.)) -(defprotocol Conn - (-send-frame [c s] "Send the frame string s. False once the connection is lost.") - (-close [c] "Close the connection; both ends' on-close run.")) +(defn- random-hex [n] + (let [bs (byte-array n)] (.nextBytes rng bs) (digest/hex bs))) + +(defonce ^{:doc "The cookie of a node started without one: drawn once per VM, so + nodes in one VM connect, as nodes on one host share ~/.erlang.cookie. + Nodes in different VMs must be given the same :cookie."} + vm-cookie + (random-hex 32)) + +(defn- fresh-creation + "A creation number for a node's start: random, never 0." + [] + (inc (rand-int 2147483646))) ;; --- node state --------------------------------------------------------- (defonce ^:private nodes - ;; name -> {:transport t :conns {peer conn} :watching {ref {...}} - ;; :exported {ref [peer id]} :node-mons [[id peer]] :pending {ref promise}} + ;; name -> {:transport t :listener l :codec c :auth a :creation n + ;; :conns {peer {:conn c :creation n :initiator node}} + ;; :connecting {peer promise} + ;; :watching {ref {...}} :exported {ref [peer pid]} + ;; :node-mons [[id peer]] :spawns {ref [peer promise]} + ;; :spawn allowed :max-frame n :handshake-timeout ms} (atom {})) (defn- state [n] (get @nodes n)) (defn started? "Is n a node running in this VM?" [n] (contains? @nodes n)) +(defn creation + "The creation number of node n's current run (0 for a node not started)." + ([] (creation (act/node))) + ([n] (:creation (state n) 0))) + (declare deliver-remote signal-remote link-remote unlink-remote monitor-remote demonitor-remote monitor-named demonitor-named send-frame!) -(defrecord RemotePid [node id] +(defrecord RemotePid [node id creation] proc/Process (-pid [_] id) (-node [_] node) @@ -80,109 +129,402 @@ (-pid [_] nil) (-node [_] node) (-alive? [_] (contains? (get-in @nodes [(act/node) :conns]) node)) - (-deliver [_ msg] (send-frame! (act/node) node [:send-named nm msg])) + (-deliver [_ msg] (send-frame! (act/node) node :send-named {:name nm} msg)) (-signal [_ _ _ _ _] (throw (ex-info "an exit signal goes to a pid, not a name" {:reason :badarg}))) (-link [_ _] (throw (ex-info "a link goes to a pid, not a name" {:reason :badarg}))) (-unlink [_ _] true) (-add-monitor [_ ref notify] (monitor-named nm node ref notify)) (-drop-monitor [_ ref] (demonitor-named node ref))) +(defn- pid-creation + "The creation a process handle carries: a local actor's is its node's." + [p] + (if (instance? RemotePid p) (:creation p) (creation (proc/-node p)))) + +(defn- wire + "A process handle as [node id creation]." + [p] + [(proc/-node p) (proc/-pid p) (pid-creation p)]) + +(defn- local + "Node n's live actor id, or nil." + [n id] + (when-let [a (act/local-actor id)] + (when (= n (proc/-node a)) a))) + +(defn- pid-of + "What the pid [node id creation] from the wire is at node self, through + dist/arrive: a process of self's current run is its actor again, any + other a RemotePid. A process of self that has gone stays a handle all + the same, as a dead pid does in Erlang." + [self [pn id cr]] + (let [r (dist/arrive self (creation self) [:Pid pn id cr])] + (if (= :Local (first r)) + (or (local self id) (->RemotePid self id cr)) + (->RemotePid pn id cr)))) + ;; --- frames: what crosses, and how -------------------------------------- -(defn- encode - "v with each process in it as [:Pid node id], and each throwable as - data, so it prints as EDN a peer can read." - [v] - (walk/prewalk - (fn [x] - (cond - (act/pid? x) [:Pid (proc/-node x) (proc/-pid x)] - (instance? Throwable x) {::exception (or (ex-message x) (str x)) ::data (ex-data x)} - :else x)) - v)) - -(defn- decode - "A frame's value as node self holds it: each pid of self its process - again, each other pid a RemotePid. A pid of a process of self that has - gone stays a handle all the same, as a dead pid does in Erlang." +(def ^:private tags + ;; what marks a value in a frame's body: a pid, a throwable, and data + ;; that would read as either, escaped + #{::pid ::ex ::q}) + +(defn- wire-leaf? [x] + (or (nil? x) (boolean? x) (number? x) (string? x) (keyword? x) (symbol? x) + (char? x) (uuid? x) (instance? java.util.Date x))) + +(defn- pack + "v as a frame's body carries it: plain data, each pid in it [::pid node + id creation], each throwable [::ex message data], and each vector that + begins with one of those tags escaped as [::q ...]. Anything else -- a + record, an atom, a fn -- has no form on the wire: strict, it throws; + otherwise it goes as [:unsendable its-printed-form], which an exit + reason, that must go whatever it holds, may." + [strict? v] + (let [pk #(pack strict? %)] + (cond + (instance? RemoteName v) [:At (:nm v) (:node v)] + (act/pid? v) (into [::pid] (wire v)) + (instance? Throwable v) [::ex (or (ex-message v) (str v)) (pk (ex-data v))] + (record? v) (if strict? + (throw (ex-info (str "cannot send a " (.getName (class v)) " to another node") + {:reason [:badarg :not-wire-data (.getName (class v))]})) + [:unsendable (pr-str v)]) + (map? v) (into {} (map (fn [[k x]] [(pk k) (pk x)])) v) + (vector? v) (let [xs (mapv pk v)] (if (contains? tags (first v)) (into [::q] xs) xs)) + (set? v) (into #{} (map pk) v) + (seq? v) (apply list (map pk v)) + (wire-leaf? v) v + strict? (throw (ex-info (str "cannot send a " (.getName (class v)) " to another node") + {:reason [:badarg :not-wire-data (.getName (class v))]})) + :else [:unsendable (pr-str v)]))) + +(defn- unpack + "A frame's body as node self holds it: pack undone." + [self v] + (let [up #(unpack self %)] + (cond + (vector? v) (case (first v) + ::pid (pid-of self (subvec v 1 4)) + ::ex (ex-info (str (nth v 1)) (or (up (nth v 2)) {})) + ::q (mapv up (rest v)) + (mapv up v)) + (map? v) (into {} (map (fn [[k x]] [(up k) (up x)])) v) + (set? v) (into #{} (map up) v) + (seq? v) (apply list (map up v)) + :else v))) + +(def ^:private pid-fields + ;; the fields of a frame's hdr that hold a pid + #{:to :from}) + +(def ^:private lossy-ops + ;; the operations whose body is an exit reason, sent whatever it holds + #{:signal :fired :spawned}) + +(defn- frame + "The envelope [op hdr body] of operation op: hdr's pids as [node id + creation], body packed." + [op hdr body] + [op + (into {} (map (fn [[k v]] [k (if (and (contains? pid-fields k) (some? v)) (wire v) v)])) hdr) + (pack (not (contains? lossy-ops op)) body)]) + +(defn- open-frame + "A frame from the wire as node self holds it: [op hdr body]; throws if + it is not an envelope." [self v] - (walk/postwalk - (fn [x] - (cond - (and (vector? x) (= 2 (count x)) (= :Local (first x))) - (or (act/local-actor (second x)) (->RemotePid self (second x))) - (and (vector? x) (= 3 (count x)) (= :Pid (first x)) (keyword? (second x))) - (->RemotePid (second x) (nth x 2)) - :else x)) - (dist/arrive self v))) + (when-not (and (vector? v) (= 3 (count v)) (keyword? (first v)) (map? (second v))) + (throw (ex-info "not a frame" {:reason :bad-frame}))) + (let [[op hdr body] v] + [op + (into {} (map (fn [[k x]] + [k (if (and (contains? pid-fields k) (some? x)) + (if (and (vector? x) (= 3 (count x)) (keyword? (first x))) + (pid-of self x) + (throw (ex-info "not a pid" {:reason :bad-frame :field k}))) + x)])) + hdr) + (unpack self body)])) + +(defn- framed + "The bytes of one frame: payload's length, four bytes, then payload." + ^bytes [^bytes payload] + (let [n (alength payload) + out (byte-array (+ 4 n))] + (doseq [[i b] (map-indexed vector (dist/length-header n))] + (aset-byte out i (unchecked-byte b))) + (System/arraycopy payload 0 out 4 n) + out)) + +(defn- write-frame! + "Write v, encoded by node n's codec, as one frame on conn c." + [n c v] + (boolean (tr/-write c (framed (codec/-encode (:codec (state n)) v))))) + +(def ^:private handshake-max-frame + ;; the largest frame a connection takes before its handshake is done + 4096) + +(def default-max-frame + "The largest frame a node takes, in bytes, unless started with + :max-frame." + (* 64 1024 1024)) + +(defn- reader + "A fn taking the stream's chunks, as tr/-start hands them, that calls + (on-frame payload) with each whole frame's payload, in order, while it + answers true. A frame longer than (max-len) is not read: (on-bad + reason) is called instead. Once either has happened, the rest of the + stream is ignored." + [on-frame max-len on-bad] + (let [buf (atom (byte-array 0)) + dead (atom false)] + (fn [^bytes chunk] + (when-not @dead + (let [^bytes old @buf + joined (byte-array (+ (alength old) (alength chunk)))] + (System/arraycopy old 0 joined 0 (alength old)) + (System/arraycopy chunk 0 joined (alength old) (alength chunk)) + (loop [^bytes b joined] + (let [len (alength b) + n (when (>= len 4) (dist/header-length (mapv #(bit-and (aget b %) 0xff) (range 4))))] + (cond + (and n (> n (max-len))) + (do (reset! dead true) (reset! buf (byte-array 0)) (on-bad [:frame-too-large n])) + (and n (>= len (+ 4 n))) + (let [payload (byte-array n) + rest-b (byte-array (- len 4 n))] + (System/arraycopy b 4 payload 0 n) + (System/arraycopy b (+ 4 n) rest-b 0 (- len 4 n)) + (if (on-frame payload) + (recur rest-b) + (do (reset! dead true) (reset! buf (byte-array 0))))) + :else (reset! buf b))))))))) (declare nodedown! handle-frame) +(defn- tell-watchers! + "Send msg to every actor of node n that monitors all nodes." + [n msg] + (binding [act/*node* n] + (doseq [id (:node-watchers (state n))] + (if-let [w (local n id)] + (proc/-deliver w msg) + (swap! nodes update-in [n :node-watchers] disj id))))) + (defn connected "The peers node n is connected to." ([] (connected (act/node))) ([n] (vec (keys (:conns (state n)))))) +;; --- connections and the handshake ---------------------------------------- + +(defn- ctx-of + "What dist/handshake needs to know of node n." + [n] + (let [s (state n)] + {:up-creation (fn [p] (get-in s [:conns p :creation])) + :pending? (fn [p] (contains? (:connecting s) p)) + :fresh (random-hex 16) + :sign (fn [c] (-sign (:auth s) (str c)))})) + +(defn handshake-step! + "Take a handshake frame on conn c of node n, through dist/handshake: send + what it says, and once the peer is proved make c the connection to it. + sess holds the handshake's state; done, if any, is told how it ended." + [n c sess frame done] + (let [[tag hs frames] (dist/handshake (:hs @sess) frame (ctx-of n))] + (doseq [f frames] (write-frame! n c f)) + (case tag + :Next (swap! sess assoc :hs hs) + :Up (let [peer (:peer hs) + new {:conn c :creation (:peer-creation hs) + :initiator (if (= :initiator (:role hs)) n peer)} + existing (get-in @nodes [n :conns peer]) + decision (dist/on-up n (some-> existing (select-keys [:creation :initiator])) + (select-keys new [:creation :initiator]))] + (if (= :drop decision) + ;; both ends keep the other connection + (do (swap! sess assoc :hs hs :failed :duplicate) + (tr/-close c) + (when done (deliver done [:up (:conn existing)]))) + (do + ;; an earlier run of the peer goes down before this one is up + (when (= :replace-down decision) (nodedown! n peer)) + (swap! nodes assoc-in [n :conns peer] new) + (swap! sess assoc :hs hs :peer peer) + ;; closed once it no longer stands for the peer, so its close + ;; is not a nodedown + (when existing (tr/-close (:conn existing))) + (when done (deliver done [:up c])) + (when-not (= :replace decision) (tell-watchers! n [:nodeup peer]))))) + :Fail (do (swap! sess assoc :failed hs) + (tr/-close c) + (when done (deliver done [:failed hs])))))) + +(declare handshake-timeout) + +(defn- session! + "Run conn c of node n: the handshake from state hs, then the + distribution protocol. done, if any, is told how the handshake ended; + without done c was accepted, and is closed if its handshake takes too + long. A frame that does not decode drops the connection; one whose + operation fails is reported, and the connection carries on." + [n c hs first-frames done] + (let [sess (atom {:hs hs}) + cdc (:codec (state n)) + drop! (fn [why] + (logger/report! {:level :error :kind :dist-connection-dropped :node n + :peer (:peer @sess) :reason why}) + (tr/-close c) + false) + on-frame (fn [payload] + (if-let [peer (:peer @sess)] + (if-let [[op hdr body] (try (open-frame n (codec/-decode cdc payload)) + (catch Throwable e (drop! [:bad-frame (ex-message e)]) nil))] + (do (try (handle-frame n peer op hdr body) + (catch Throwable e + (logger/report! {:level :error :kind :dist-frame-failed :node n + :peer peer :op op :reason e}))) + true) + false) + (try (handshake-step! n c sess (codec/-decode cdc payload) done) + (not (:failed @sess)) + (catch Throwable e (drop! [:bad-handshake (ex-message e)]))))) + max-len (fn [] (if (:peer @sess) + (:max-frame (state n) default-max-frame) + handshake-max-frame))] + (tr/-start c (reader on-frame max-len drop!) + (fn [] + (if-let [peer (:peer @sess)] + ;; only the connection that is up stands for the peer + (when (= c (get-in @nodes [n :conns peer :conn])) (nodedown! n peer)) + (when done (deliver done [:failed :closed]))))) + (when-not done + (let [ms (handshake-timeout n)] + (a/go (a/ (state n) :transport (tr/-connect n peer))] + (let [[_ hs frames] (dist/open-handshake n (creation n) peer)] + (session! n c hs frames done) + (let [[k v] (deref done (handshake-timeout n) [:failed :timeout])] + (cond + (= :up k) v + ;; refused because the peer connected to us meanwhile + (and (vector? v) (= :refused (first v)) (contains? #{:nok :alive} (second v))) + (wait-for-conn n peer (handshake-timeout n)) + :else (do (tr/-close c) nil)))) + (do (deliver done [:failed :unreachable]) nil)) + (finally + (swap! nodes update-in [n :connecting] dissoc peer)))))) + (defn- conn-to "The connection from n to peer, opened on first use as Erlang connects - nodes on first contact; nil when peer cannot be reached." + nodes on first contact; nil when peer cannot be reached or refuses." [n peer] - (or (get-in @nodes [n :conns peer]) - (when-let [t (:transport (state n))] - (when-let [c (-connect t n peer - (fn [s] (handle-frame n peer (edn/read-string s))) - (fn [] (nodedown! n peer)))] - (swap! nodes assoc-in [n :conns peer] c) - c)))) + (or (get-in @nodes [n :conns peer :conn]) + (when (and (state n) (not= n peer)) (open! n peer)))) + +(defn- accept! + "Take a connection opened to node n: it shakes hands before anything + else is read from it." + [n c] + (session! n c (dist/accept-handshake n (creation n)) [] nil)) (defn- send-frame! - "Send frame from node n to peer; false when peer cannot be reached." - [n peer frame] - (if-let [c (conn-to n peer)] - (boolean (-send-frame c (pr-str (encode frame)))) - false)) + "Send operation op, with fields hdr and data body, from node n to peer; + false when peer cannot be reached. Throws, before anything is sent, if + body holds what the wire cannot carry." + ([n peer op hdr] (send-frame! n peer op hdr nil)) + ([n peer op hdr body] + (let [f (frame op hdr body)] + (if-let [c (conn-to n peer)] + (write-frame! n c f) + false)))) ;; --- a process of another node ------------------------------------------ (defn- here - "The local process a route to this node names, or nil when it is gone." - [id] - (act/local-actor id)) + "The local process a frame names, or nil when it is gone: a pid of this + node's current run arrives as its actor." + [x] + (when (act/actor? x) x)) + +(defn- route-of [p] + (dist/route (act/node) (creation) (into [:Pid] (wire p)))) (defn deliver-remote "Send msg to the process p names: through dist/route, locally if p is a pid of this node, over the connection otherwise." [p msg] - (let [r (dist/route (act/node) [:Pid (:node p) (:id p)])] + (let [r (route-of p)] (case (first r) - :Here (let [[_ id] r] (when-let [a (here id)] (proc/-deliver a msg))) - :There (let [[_ n id] r] (send-frame! (act/node) n [:send id msg])) + :Here (when-let [a (local (act/node) (second r))] (proc/-deliver a msg)) + :There (send-frame! (act/node) (second r) :send {:to p} msg) nil))) (defn- signal-remote [p from kind reason checked] - (let [r (dist/route (act/node) [:Pid (:node p) (:id p)])] + (let [r (route-of p)] (case (first r) - :Here (let [[_ id] r] (when-let [a (here id)] (proc/-signal a from kind reason checked))) - :There (let [[_ n id] r] (send-frame! (act/node) n [:signal id from kind reason checked])) + :Here (when-let [a (local (act/node) (second r))] (proc/-signal a from kind reason checked)) + :There (send-frame! (act/node) (second r) :signal {:to p :from from :kind kind :checked checked} reason) nil))) (defn- link-remote "A link to a remote process: asked of its node, which answers noproc if the process is gone. An unreachable node is noconnection at once." [p from] - (let [r (dist/route (act/node) [:Pid (:node p) (:id p)])] + (let [r (route-of p)] (case (first r) - :Here (let [[_ id] r] (if-let [a (here id)] (proc/-link a from) false)) - :There (let [[_ n id] r] - (or (send-frame! (act/node) n [:link id from]) - (do (proc/-signal from p :link :noconnection false) true))) + :Here (if-let [a (local (act/node) (second r))] (proc/-link a from) false) + :Gone false + :There (or (send-frame! (act/node) (second r) :link {:to p :from from}) + (do (proc/-signal from p :link :noconnection false) true)) true))) (defn- unlink-remote [p from] - (let [r (dist/route (act/node) [:Pid (:node p) (:id p)])] + (let [r (route-of p)] (case (first r) - :Here (let [[_ id] r] (when-let [a (here id)] (proc/-unlink a from))) - :There (let [[_ n id] r] (send-frame! (act/node) n [:unlink id from])) + :Here (when-let [a (local (act/node) (second r))] (proc/-unlink a from)) + :There (send-frame! (act/node) (second r) :unlink {:to p :from from}) nil))) (defn- monitor-remote @@ -192,14 +534,15 @@ [p ref notify] (let [n (act/node) watcher (act/self) - r (dist/route n [:Pid (:node p) (:id p)])] + r (route-of p)] (case (first r) - :Here (let [[_ id] r] - (if-let [a (here id)] (proc/-add-monitor a ref notify) (notify :noproc))) - :There (let [[_ peer id] r] + :Here (if-let [a (local n (second r))] (proc/-add-monitor a ref notify) (notify :noproc)) + :Gone (notify :noproc) + :There (let [[_ peer id cr] r] (swap! nodes assoc-in [n :watching ref] - {:notify notify :peer peer :target id :watcher (some-> watcher proc/-pid)}) - (when-not (send-frame! n peer [:monitor id ref]) + {:notify notify :peer peer :target id :creation cr + :watcher (some-> watcher proc/-pid)}) + (when-not (send-frame! n peer :monitor {:to p :ref ref}) (swap! nodes update-in [n :watching] dissoc ref) (notify :noconnection))) nil) @@ -207,12 +550,11 @@ (defn- demonitor-remote [p ref] (let [n (act/node) - r (dist/route n [:Pid (:node p) (:id p)])] + r (route-of p)] (case (first r) - :Here (let [[_ id] r] (when-let [a (here id)] (proc/-drop-monitor a ref))) - :There (let [[_ peer id] r] - (swap! nodes update-in [n :watching] dissoc ref) - (send-frame! n peer [:demonitor id ref])) + :Here (when-let [a (local n (second r))] (proc/-drop-monitor a ref)) + :There (do (swap! nodes update-in [n :watching] dissoc ref) + (send-frame! n (second r) :demonitor {:to p :ref ref})) nil))) (defn- monitor-named @@ -222,8 +564,8 @@ [nm peer ref notify] (let [n (act/node)] (swap! nodes assoc-in [n :watching ref] - {:notify notify :peer peer :target 0 :watcher (some-> (act/self) proc/-pid)}) - (when-not (send-frame! n peer [:monitor-named nm ref]) + {:notify notify :peer peer :target 0 :creation 0 :watcher (some-> (act/self) proc/-pid)}) + (when-not (send-frame! n peer :monitor-named {:name nm :ref ref}) (swap! nodes update-in [n :watching] dissoc ref) (notify :noconnection)) ref)) @@ -231,7 +573,7 @@ (defn- demonitor-named [peer ref] (let [n (act/node)] (swap! nodes update-in [n :watching] dissoc ref) - (send-frame! n peer [:demonitor nil ref]))) + (send-frame! n peer :demonitor {:ref ref}))) (defn- fire! "Run the notify of monitor ref of node n, once." @@ -245,59 +587,72 @@ (defn- spawn-allowed? "May node n start the fn named sym for a peer? Only what its :spawn option allows: a set of namespace symbols, or a predicate on sym. With - no :spawn nothing is: a peer is not authenticated yet, and a spawn runs - any fn it names." + no :spawn nothing is." [n sym] (let [allow (:spawn (state n))] (boolean - (cond - (set? allow) (contains? allow (symbol (namespace sym))) - (ifn? allow) (allow sym) - :else false)))) + (and (symbol? sym) + (cond + (set? allow) (and (namespace sym) (contains? allow (symbol (namespace sym)))) + (ifn? allow) (allow sym) + :else false))))) + +(defn outcome + "What running (f) came to, as erpc reports it: [:ok value], [:exit + reason] for an exit, or [:exception throwable]." + [f] + (try [:ok (f)] + (catch Throwable e + (let [r (act/reason-of e)] + (if (identical? r e) [:exception e] [:exit r]))))) (defn handle-frame - "Perform, as node n, the operation frame from peer asks for." - [n peer frame] + "Perform, as node n, operation op from peer, with fields hdr and data + body. Only a peer that passed the handshake gets here." + [n peer op hdr body] (binding [act/*node* n] - (let [[op & args] (decode n frame)] - (case op - :send (let [[id msg] args] (when-let [a (here id)] (proc/-deliver a msg))) - :send-named (let [[nm msg] args] (when-let [a (act/whereis nm)] (proc/-deliver a msg))) - :signal (let [[id from kind reason checked] args] - (when-let [a (here id)] (proc/-signal a from kind reason checked))) - :link (let [[id from] args] - (when-not (if-let [a (here id)] (proc/-link a from) false) - (send-frame! n peer [:signal (proc/-pid from) (->RemotePid n id) :link :noproc false]))) - :unlink (let [[id from] args] (when-let [a (here id)] (proc/-unlink a from))) - (:monitor :monitor-named) - (let [[target ref] args - a (if (= op :monitor) (here target) (act/whereis target)) - id (some-> a proc/-pid)] - (if a - (do (swap! nodes assoc-in [n :exported ref] [peer id]) - (proc/-add-monitor a ref (fn [reason] - (swap! nodes update-in [n :exported] dissoc ref) - (send-frame! n peer [:fired ref reason])))) - (send-frame! n peer [:fired ref :noproc]))) - :demonitor (let [[id ref] args - id (or id (second (get-in @nodes [n :exported ref])))] - (swap! nodes update-in [n :exported] dissoc ref) - (when-let [a (and id (here id))] (proc/-drop-monitor a ref))) - :fired (let [[ref reason] args] (fire! n ref reason)) - :alias (let [[alias msg] args] (act/send-alias! alias msg)) - :spawn (let [[ref sym fargs link from] args] - (if-not (spawn-allowed? n sym) - (send-frame! n peer [:spawned ref [:refused sym]]) - (let [f (requiring-resolve sym) - ;; the link is made by the new process before it runs a - ;; step, so a crash at once still reaches the spawner - go (promise) - a (act/spawn (fn [] @go (when link (act/link! from)) (apply f fargs)))] - (send-frame! n peer [:spawned ref a]) - (deliver go true)))) - :spawned (let [[ref pid] args] - (when-let [p (get-in @nodes [n :pending ref])] (deliver p pid))) - nil)))) + (case op + :send (when-let [a (here (:to hdr))] (proc/-deliver a body)) + :send-named (when-let [a (act/whereis (:name hdr))] (proc/-deliver a body)) + :signal (let [{:keys [to from kind checked]} hdr] + (when-let [a (here to)] (proc/-signal a from kind body checked))) + :link (let [{:keys [to from]} hdr] + (when-not (if-let [a (here to)] (proc/-link a from) false) + (send-frame! n peer :signal {:to from :from to :kind :link :checked false} :noproc))) + :unlink (let [{:keys [to from]} hdr] (when-let [a (here to)] (proc/-unlink a from))) + (:monitor :monitor-named) + (let [ref (:ref hdr) + a (if (= op :monitor) (here (:to hdr)) (act/whereis (:name hdr)))] + (if a + (do (swap! nodes assoc-in [n :exported ref] [peer a]) + (proc/-add-monitor a ref (fn [reason] + (swap! nodes update-in [n :exported] dissoc ref) + (send-frame! n peer :fired {:ref ref} reason)))) + (send-frame! n peer :fired {:ref ref} :noproc))) + :demonitor (let [ref (:ref hdr) + a (or (here (:to hdr)) (second (get-in @nodes [n :exported ref])))] + (swap! nodes update-in [n :exported] dissoc ref) + (when a (proc/-drop-monitor a ref))) + :fired (fire! n (:ref hdr) body) + :alias (act/send-alias! (:alias hdr) body) + :spawn (let [{:keys [ref sym link from]} hdr + {:keys [args reply]} body + f (when (spawn-allowed? n sym) (try (requiring-resolve sym) (catch Throwable _ nil)))] + (cond + (not (spawn-allowed? n sym)) (send-frame! n peer :spawned {:ref ref} [:refused sym]) + (nil? f) (send-frame! n peer :spawned {:ref ref} [:undefined sym]) + :else + ;; the link is made by the new process before it runs a + ;; step, so a crash at once still reaches the spawner + (let [go (promise) + a (act/spawn (fn [] @go (when link (act/link! from)) + (if reply + (proc/-deliver from [::result reply (outcome #(apply f args))]) + (apply f args))))] + (send-frame! n peer :spawned {:ref ref} [:ok a]) + (deliver go true)))) + :spawned (when-let [[_ p] (get-in @nodes [n :spawns (:ref hdr)])] (deliver p body)) + nil))) ;; --- a lost connection -------------------------------------------------- @@ -310,44 +665,96 @@ (fn [s] (when s (-> s (update :conns dissoc peer) (update :exported (fn [e] (into {} (remove (fn [[_ [p]]] (= p peer))) e))))))) s (get before n) - links (vec (for [[x h] (act/remote-links n)] [:Link (proc/-pid x) (proc/-node h) (proc/-pid h)])) - mons (vec (for [[ref {:keys [peer target watcher]}] (:watching s)] [:Mon (or watcher 0) ref peer target])) + links (vec (for [[x h] (act/remote-links n)] + [:Link (proc/-pid x) (proc/-node h) (proc/-pid h) (pid-creation h)])) + mons (vec (for [[ref {:keys [peer target creation watcher]}] (:watching s)] + [:Mon (or watcher 0) ref peer target (or creation 0)])) nmons (vec (for [[id p] (:node-mons s)] [:NodeMon id p]))] - (binding [act/*node* n] - (doseq [e (dist/on-nodedown peer links mons nmons)] - (case (first e) - :Signal (let [[_ me [_ pn pid] reason] e] - (when-let [a (act/local-actor me)] - (proc/-signal a (->RemotePid pn pid) :link reason true))) - :Deliver (let [[_ me msg] e] - (if (= :DOWN (first msg)) - (fire! n (second msg) :noconnection) - (when-let [a (act/local-actor me)] (proc/-deliver a msg)))) - nil))))) + (when (contains? (:conns s) peer) + (binding [act/*node* n] + ;; the monitors peer held of processes here go with it + (doseq [[ref [p a]] (:exported s) :when (= p peer)] + (proc/-drop-monitor a ref)) + ;; and a spawn asked of it gets no answer now + (doseq [[_ [p pr]] (:spawns s) :when (= p peer)] + (deliver pr [:nodedown])) + (doseq [e (dist/on-nodedown peer links mons nmons)] + (case (first e) + :Signal (let [[_ me [_ pn pid cr] reason] e] + (when-let [a (local n me)] + (proc/-signal a (->RemotePid pn pid cr) :link reason true))) + :Deliver (let [[_ me msg] e] + (if (= :DOWN (first msg)) + (fire! n (second msg) :noconnection) + (when-let [a (local n me)] (proc/-deliver a msg)))) + nil)) + (swap! nodes update-in [n :node-mons] (fn [ms] (vec (remove #(= peer (second %)) ms)))) + (tell-watchers! n [:nodedown peer]))))) ;; --- the API ------------------------------------------------------------ +(defonce ^:private start-hooks + ;; key -> (fn [node]), run as each node starts: the services it runs + (atom {})) + +(defn on-start! + "Run (f node) as every node starts from now on, under key k (a second + call with k replaces the first). How a service -- global, pg -- runs + on each node." + [k f] + (swap! start-hooks assoc k f) + nil) + (defn start! "Start node name in this VM, reachable over transport. Code that runs outside any actor now runs as this node; with-node runs code as another. Options: + :cookie the secret a peer must share to connect (default: one drawn + once per VM, so nodes of this VM connect to each other) + :auth instead of :cookie, any Auth: how a challenge is signed + :codec how frames become bytes (default ensemble.codec/edn) :spawn what a peer may start here with spawn-on: a set of namespace symbols whose fns it may name, or a predicate on the fn's symbol. Without it a peer may start nothing. + :max-frame the largest frame taken from a peer, in bytes + (default-max-frame); a larger one drops it + :handshake-timeout how long a connection may take to shake hands, + in ms (*handshake-timeout*) - Returns name." + Each start draws a new creation number. Returns name." ([nm transport] (start! nm transport {})) ([nm transport opts] - (when-not (and (keyword? nm) (= nm (edn/read-string (pr-str nm)))) - (throw (ex-info (str "a node name is a keyword that reads back as itself: " (pr-str nm)) - {:reason :badarg :node nm}))) - (swap! nodes assoc nm {:transport transport :conns {} :watching {} :exported {} - :node-mons [] :pending {} :spawn (:spawn opts)}) - (act/set-remote-resolver! (fn [[_ remote-nm peer]] (->RemoteName peer remote-nm))) - (act/set-remote-alias-sender! (fn [alias msg] - (send-frame! (act/node) (:ensemble.actor/owner-node alias) [:alias alias msg]))) - nm)) + (when-not (and (keyword? nm) (= nm (edn/read-string (pr-str nm)))) + (throw (ex-info (str "a node name is a keyword that reads back as itself: " (pr-str nm)) + {:reason :badarg :node nm}))) + (swap! nodes assoc nm {:transport transport :conns {} :connecting {} :watching {} :exported {} + :node-mons [] :spawns {} :spawn (:spawn opts) + :max-frame (:max-frame opts default-max-frame) + :handshake-timeout (:handshake-timeout opts) + :codec (or (:codec opts) (codec/edn)) + :auth (or (:auth opts) (cookie-auth (or (:cookie opts) vm-cookie))) + :creation (fresh-creation)}) + (act/set-remote-resolver! (fn [[_ remote-nm peer]] (->RemoteName peer remote-nm))) + (act/set-peers-fn! (fn [] (connected (act/node)))) + (act/set-creation-fn! creation) + (act/set-remote-alias-sender! (fn [alias msg] + (send-frame! (act/node) (:ensemble.actor/owner-node alias) :alias {:alias alias} msg))) + ;; the services start before a peer can connect + (binding [act/*node* nm] + (doseq [[_ f] @start-hooks] (f nm))) + (swap! nodes assoc-in [nm :listener] (tr/-listen transport nm (fn [c] (accept! nm c)))) + nm)) + +(defn stop! + "Stop node name: it stops listening and drops every connection, so its + peers see it go down. Its processes run on." + [nm] + (when-let [s (state nm)] + (some-> (:listener s) tr/-stop) + (doseq [[_ {:keys [conn]}] (:conns s)] (tr/-close conn)) + (swap! nodes dissoc nm)) + nil) (defmacro with-node "Run body as node n: what it spawns runs there, and names resolve there." @@ -364,10 +771,20 @@ "Drop the connection to peer, as erlang:disconnect_node: both ends see the node go down." [peer] - (when-let [c (get-in @nodes [(act/node) :conns peer])] - (-close c)) + (when-let [c (get-in @nodes [(act/node) :conns peer :conn])] + (tr/-close c)) true) +(defn monitor-nodes! + "With on true, the current actor receives [:nodeup peer] and [:nodedown + peer] whenever its node connects to or loses a peer, as + net_kernel:monitor_nodes; with false, no longer." + [on] + (let [n (act/node) + me (proc/-pid (act/self))] + (swap! nodes update-in [n :node-watchers] (fnil (if on conj disj) #{}) me) + true)) + (defn monitor-node! "Receive [:nodedown peer] in the current actor when the connection to peer is lost; at once if there is none, as monitor_node(Node, true)." @@ -383,56 +800,35 @@ "Start a process on node peer running (apply f args), f named by a symbol peer can resolve and allows (see start!'s :spawn), as spawn(Node, M, F, A). With {:link true} it is linked to the current - actor. Returns its pid, a RemotePid; throws {:reason [:not-allowed - sym]} when peer refuses." + actor; with {:reply r} it sends the current actor [::result r outcome] + when (apply f args) is done (see outcome), as erpc's processes do. + Waits up to :timeout ms (default 5000; nil or :infinity, for ever) for + peer to answer. Returns its pid, a RemotePid; throws {:reason + [:not-allowed sym]} when peer refuses, [:undefined sym] when it has no + such fn, :noconnection when it cannot be reached or goes down first." ([peer f-sym args] (spawn-on peer f-sym args {})) - ([peer f-sym args {:keys [link timeout] :or {timeout 5000}}] + ([peer f-sym args {:keys [link timeout reply] :or {timeout 5000}}] (let [n (act/node) ref (act/make-ref) p (promise)] - (swap! nodes assoc-in [n :pending ref] p) - (when-not (send-frame! n peer [:spawn ref f-sym (vec args) (boolean link) (act/self)]) + (swap! nodes assoc-in [n :spawns ref] [peer p]) + (when-not (try (send-frame! n peer :spawn {:ref ref :sym f-sym :link (boolean link) :from (act/self)} + {:args (vec args) :reply reply}) + (catch Throwable e (swap! nodes update-in [n :spawns] dissoc ref) (throw e))) + (swap! nodes update-in [n :spawns] dissoc ref) (throw (ex-info "cannot reach node" {:reason :noconnection :node peer}))) (let [t (act/timeout-ms timeout) - r (if t (deref p t ::timeout) @p)] - (swap! nodes update-in [n :pending] dissoc ref) - (cond - (= ::timeout r) (throw (ex-info "spawn-on timed out" {:reason :timeout :node peer})) - (and (vector? r) (= :refused (first r))) - (throw (ex-info "the node does not allow that spawn" - {:reason [:not-allowed (second r)] :node peer})) - :else r))))) - -;; --- the loopback transport --------------------------------------------- - -(defrecord LoopbackConn [ch closed on-close peer-conn] - Conn - (-send-frame [_ s] (and (not @closed) (a/put! ch s))) - (-close [this] - (when (compare-and-set! closed false true) - (a/close! ch) - (on-close) - (when-let [pc @peer-conn] (-close pc))))) - -(defrecord Loopback [] - Transport - (-connect [_ from to on-frame on-close] - (when (and (started? to) (instance? Loopback (:transport (state to)))) - ;; from's end, whose frames the peer reads, and the peer's end, whose - ;; frames from reads; each end's frames are read on a fiber of their - ;; own, in order - (let [to-ch (a/chan 1024) - from-ch (a/chan 1024) - from-end (->LoopbackConn to-ch (atom false) on-close (atom nil)) - to-end (->LoopbackConn from-ch (atom false) (fn [] (nodedown! to from)) (atom nil))] - (reset! (:peer-conn from-end) to-end) - (reset! (:peer-conn to-end) from-end) - (swap! nodes assoc-in [to :conns from] to-end) - (a/go-loop [] (when-let [s (a/Loopback)) + "The transport between nodes in this VM (ensemble.transport/loopback)." + ([] (tr/loopback)) + ([opts] (tr/loopback opts))) diff --git a/src/ensemble/pattern.clj b/src/ensemble/pattern.clj index 706c3fb..8bdcd63 100644 --- a/src/ensemble/pattern.clj +++ b/src/ensemble/pattern.clj @@ -9,10 +9,25 @@ :kw 1 \"s\" nil a literal: matches a message equal to it [p1 p2 ...] a tuple: matches a sequential message element-wise, so [:pair x y] matches [:pair 1 2] binding x 1, y 2 + [p1 & pt] a list tail, Erlang's [H|T]: p1 matches the first + element and pt the rest, so [:args h & t] matches + [:args 1 2 3] binding h 1, t (2 3) + {k p ...} a map holding at least the keys named, each value + matching its pattern, as Erlang's #{k := P}. A key is + a value or a name bound where the receive is written; + it never binds - Vectors nest, so [x [:tag y]] is a tuple whose second element is itself a - tuple. Any other value, a map or a list among them, is a literal as - written. + Patterns nest, so [x [:tag y]] is a tuple whose second element is itself a + tuple, and {:at [x y]} a map whose :at is a pair. Any other value, a list + or a set among them, is a literal as written. + + A tuple matches any sequential message, a list as well as a vector: a + Clojure program rarely tells them apart, and Erlang's tuple/list split has + no counterpart here. + + A map's key is compiled as written, [:Has k p q]: a symbol there can only + be a bound name (pattern-error refuses any other), and the receive macro + puts in its value. As in Erlang, a name already bound where the receive is written is not a binder: it matches the value it is bound to. compile-form takes the set of @@ -24,44 +39,106 @@ takes only the message whose first element is that ref.") (defn- compile-atom - "A pattern form that is not a tuple." + "A pattern form that is neither a tuple nor a map." [p pinned] (cond (= p '_) [:Wild] - (and (symbol? p) (contains? pinned p)) [:Pin p] + (contains? pinned p) [:Pin p] (symbol? p) [:Bind p] :else [:Lit p])) -(defn- compile-tuple - "The elements of a tuple pattern, compiled and right-nested." - [ps pinned] - (if (empty? ps) - [:Nil] - (let [p (first ps)] - [:Cons (if (vector? p) (compile-tuple p pinned) (compile-atom p pinned)) - (compile-tuple (rest ps) pinned)]))) +(defn- steps + "How many steps a walk over pat may take: it counts down one per element + of a tuple, entry of a map and level of nesting, so that writ can see the + walk ends. Twice the forms in pat, and one, is more than any walk below + takes." + [pat] + (inc (* 2 (count (tree-seq coll? seq pat))))) + +(defn- error-in + "pattern-error, with n steps left; lead? is false on the rest of a tuple, + after its first element." + [n pat pinned lead?] + (cond + ;; never so: steps leaves more than enough + (not (pos? n)) nil + (vector? pat) + (cond + (empty? pat) nil + (= '& (first pat)) (cond + lead? "& in a pattern needs an element before it" + (not= 2 (count pat)) "& in a pattern takes exactly one pattern after it" + :else (error-in (dec n) (second pat) pinned true)) + :else (or (error-in (dec n) (first pat) pinned true) + (error-in (dec n) (vec (rest pat)) pinned false))) + (map? pat) + (if (empty? pat) + nil + (let [[k v] (first pat)] + (if (and (symbol? k) (not (contains? pinned k))) + (str "a map pattern's key must be a value or a bound name, not " k) + (or (error-in (dec n) v pinned true) + (error-in (dec n) (dissoc pat k) pinned true))))) + :else nil)) + +(defn pattern-error + "What is wrong with pattern form pat, as a message, or nil when it is a + pattern. A & needs an element before it and takes exactly one pattern + after it; a map's key that is an unbound name could only bind, and a key + never binds." + [pat pinned] + (if (or (vector? pat) (map? pat)) (error-in (steps pat) pat pinned true) nil)) + +(defn- compile-in + "compile-form, with n steps left." + [n pat pinned] + (cond + (not (pos? n)) [:Wild] + (vector? pat) (cond + (empty? pat) [:Nil] + (= '& (first pat)) (compile-in (dec n) (second pat) pinned) + :else [:Cons (compile-in (dec n) (first pat) pinned) + (compile-in (dec n) (vec (rest pat)) pinned)]) + (map? pat) (if (empty? pat) + [:IsMap] + (let [[k v] (first pat)] + [:Has k (compile-in (dec n) v pinned) + (compile-in (dec n) (dissoc pat k) pinned)])) + :else (compile-atom pat pinned))) (defn compile-form "Compile a pattern form into the tagged-data form capture matches, with the - names in pinned matched by value rather than bound." + names in pinned matched by value rather than bound. A tuple's elements + are right-nested, the one pattern after & standing for the rest; a map's + entries likewise, ending in a test that the message is a map." [pat pinned] - (if (vector? pat) (compile-tuple pat pinned) (compile-atom pat pinned))) + (if (or (vector? pat) (map? pat)) (compile-in (steps pat) pat pinned) (compile-atom pat pinned))) (defn- atom-binder - "The binder a pattern form that is not a tuple introduces, if any." + "The binder a pattern form that is neither a tuple nor a map introduces, + if any." [p pinned] (if (and (symbol? p) (not= p '_) (not (contains? pinned p))) [p] [])) -(defn- tuple-binders - "The binders of a tuple pattern's elements, in order, repeats included." - [ps pinned] - (if (empty? ps) - [] - (let [p (first ps)] - (concat (if (vector? p) (tuple-binders p pinned) (atom-binder p pinned)) - (tuple-binders (rest ps) pinned))))) +(defn- binders-in + "The binders of a pattern form, in order, repeats included, with n steps + left." + [n p pinned] + (cond + (not (pos? n)) [] + (vector? p) (cond + (empty? p) [] + (= '& (first p)) (binders-in (dec n) (second p) pinned) + :else (concat (binders-in (dec n) (first p) pinned) + (binders-in (dec n) (vec (rest p)) pinned))) + (map? p) (if (empty? p) + [] + (let [[k v] (first p)] + (concat (binders-in (dec n) v pinned) + (binders-in (dec n) (dissoc p k) pinned)))) + :else (atom-binder p pinned))) (defn bound-syms "The symbols a pattern binds, in order, leaving out the pinned ones." [pat pinned] - (distinct (if (vector? pat) (tuple-binders pat pinned) (atom-binder pat pinned)))) + (distinct (if (or (vector? pat) (map? pat)) (binders-in (steps pat) pat pinned) (atom-binder pat pinned)))) diff --git a/src/ensemble/pg.clj b/src/ensemble/pg.clj new file mode 100644 index 0000000..38ccf75 --- /dev/null +++ b/src/ensemble/pg.clj @@ -0,0 +1,199 @@ +(ns ensemble.pg + "Process groups over every connected node, as OTP's pg: a group is a name + with processes in it, a process joins from its own node, and every node + learns of it. + + Each node runs a scope process, which keeps the groups its own processes + joined and what each peer has told it of theirs. A join or a leave is + sent to every peer; when two nodes connect, each sends the other its own + groups; when a connection is lost, the peer's members are dropped. A + process that exits leaves all its groups. Membership is eventually + consistent, as pg's is: a member just joined on one node shows on the + others a moment later. + + A process may join a group more than once, and is then a member as many + times, until it leaves as often." + (:require [ensemble.actor :as act] + [ensemble.gen-server :as gs] + [ensemble.node :as node] + [ensemble.process :as proc])) + +(defonce ^:private views + ;; node -> {group [member ...]}: what each node's scope knows, local + ;; members first, written only by the scope + (atom {})) + +(defn- view + "The members of each group as st holds them." + [st] + (let [groups (into (set (keys (:local st))) (mapcat keys (vals (:remote st))))] + (into {} + (for [g groups + :let [ms (into (vec (get-in st [:local g])) (mapcat #(get % g) (vals (:remote st))))] + :when (seq ms)] + [g ms])))) + +(defn- publish! [st] (swap! views assoc (act/node) (view st)) st) + +(defn- notify! + "Tell the monitors of group g that pids joined or left it (kind :join or + :leave)." + [st kind g pids] + (when (seq pids) + (doseq [[ref w] (get-in st [:watchers g])] (act/! w [ref kind g (vec pids)]))) + st) + +(defn- removed + "The pids, from members, that are in xs; each as often as it is in xs and + no more often than in members." + [members xs] + (loop [ms members, xs xs, out []] + (if-let [x (first xs)] + (let [i (.indexOf ^java.util.List ms x)] + (if (neg? i) + (recur ms (rest xs) out) + (recur (into (subvec ms 0 i) (subvec ms (inc i))) (rest xs) (conj out x)))) + [ms out]))) + +(defn- broadcast! [msg] + (doseq [n (act/nodes)] (gs/cast! [:At ::scope n] msg))) + +(defn- leave-local + "st with pids leaving local group g, told to monitors and peers." + [st g pids] + (let [[ms gone] (removed (vec (get-in st [:local g])) pids)] + (when (seq gone) (broadcast! [:leave (act/node) g gone])) + (-> st + (assoc-in [:local g] ms) + (notify! :leave g gone)))) + +(defn- set-remote + "st with peer's groups replaced by groups, the change told to monitors." + [st peer groups] + (let [old (get-in st [:remote peer] {}) + st (if (seq groups) (assoc-in st [:remote peer] groups) (update st :remote dissoc peer))] + (reduce (fn [s g] + (let [before (get old g []) after (get groups g [])] + ;; what is left of before once after's are taken out left, + ;; and what is left of after once before's are, joined + (-> s + (notify! :leave g (first (removed before after))) + (notify! :join g (first (removed after before)))))) + st + (into (set (keys old)) (keys groups))))) + +(defrecord Scope [] + gs/Server + (init [_] + (node/monitor-nodes! true) + [:ok (publish! {:local {} :remote {} :mons {} :watchers {}})]) + (handle-call [_ req _ st] + (case (first req) + :join (let [[_ g pids] req + st (reduce (fn [s p] (if (some #(= p (second %)) (:mons s)) + s + (assoc-in s [:mons (act/monitor! p)] [:member p]))) + st pids)] + (broadcast! [:join (act/node) g pids]) + [:reply :ok (publish! (-> (update-in st [:local g] (fnil into []) pids) + (notify! :join g pids)))]) + :leave (let [[_ g pids] req] [:reply :ok (publish! (leave-local st g pids))]) + :monitor (let [[_ g w] req + ref (act/make-ref) + st (assoc-in st [:watchers g ref] w) + st (assoc-in st [:mons (act/monitor! w)] [:watcher g ref])] + [:reply [ref (get (view st) g [])] st]) + :demonitor (let [[_ g ref] req + mref (some (fn [[m v]] (when (= v [:watcher g ref]) m)) (:mons st))] + (when mref (act/demonitor! mref {:flush true})) + [:reply :ok (cond-> (update-in st [:watchers g] dissoc ref) + mref (update :mons dissoc mref))]))) + (handle-cast [_ req st] + (case (first req) + :join (let [[_ peer g pids] req] + [:noreply (publish! (-> (update-in st [:remote peer g] (fnil into []) pids) + (notify! :join g pids)))]) + :leave (let [[_ peer g pids] req + [ms gone] (removed (vec (get-in st [:remote peer g])) pids)] + [:noreply (publish! (-> (assoc-in st [:remote peer g] ms) + (notify! :leave g gone)))]) + :sync (let [[_ peer groups] req] [:noreply (publish! (set-remote st peer groups))]))) + (handle-info [_ msg st] + (cond + (and (vector? msg) (= :DOWN (first msg))) + (let [[_ mref _ p] msg + [kind & more] (get-in st [:mons mref]) + st (update st :mons dissoc mref)] + (case kind + :member [:noreply (publish! (reduce (fn [s [g ms]] + (leave-local s g (filterv #(= p %) ms))) + st (:local st)))] + :watcher (let [[g ref] more] [:noreply (update-in st [:watchers g] dissoc ref)]) + [:noreply st])) + (and (vector? msg) (= :nodeup (first msg))) + (do (gs/cast! [:At ::scope (second msg)] [:sync (act/node) (into {} (filter (comp seq val)) (:local st))]) + [:noreply st]) + (and (vector? msg) (= :nodedown (first msg))) + [:noreply (publish! (set-remote st (second msg) {}))] + :else [:noreply st])) + (handle-timeout [_ st] [:noreply st]) + (handle-continue [_ _ st] [:noreply st]) + (terminate [_ _ _] nil)) + +(defn- ensure-scope! + "This node's scope, started if it is not running." + [] + (or (act/whereis ::scope) + (try (gs/start (->Scope) {:name ::scope}) + (catch Throwable _ (act/whereis ::scope))))) + +(node/on-start! ::scope (fn [_] (ensure-scope!))) + +(defn- local-pids + "pids as a vector, each a live process of this node; else a badarg." + [pids] + (let [ps (if (sequential? pids) (vec pids) [pids])] + (doseq [p ps] + (when-not (and (act/actor? p) (= (act/node) (proc/-node p))) + (throw (ex-info "a process joins a group from its own node" {:reason :badarg :process p})))) + ps)) + +(defn join + "Add pids (one process or several) to group. Each must be a process of + this node. Returns :ok." + [group pids] + (gs/call! (ensure-scope!) [:join group (local-pids pids)])) + +(defn leave + "Take pids out of group. Returns :ok." + [group pids] + (gs/call! (ensure-scope!) [:leave group (local-pids pids)])) + +(defn get-members + "The members of group on every node, as this node knows them." + [group] + (ensure-scope!) + (get-in @views [(act/node) group] [])) + +(defn get-local-members + "The members of group on this node." + [group] + (filterv #(= (act/node) (proc/-node %)) (get-members group))) + +(defn which-groups + "The groups with a member anywhere." + [] + (ensure-scope!) + (vec (keys (get @views (act/node))))) + +(defn monitor + "Watch group from the current actor: [ref members], members as they are + now; from then on the actor receives [ref :join group pids] and [ref + :leave group pids] as processes join and leave it." + [group] + (gs/call! (ensure-scope!) [:monitor group (act/self)])) + +(defn demonitor + "Stop watching group under ref. Returns :ok." + [group ref] + (gs/call! (ensure-scope!) [:demonitor group ref])) diff --git a/src/ensemble/registry.clj b/src/ensemble/registry.clj new file mode 100644 index 0000000..a6b9f53 --- /dev/null +++ b/src/ensemble/registry.clj @@ -0,0 +1,47 @@ +(ns ensemble.registry + "A process registry other than the node's own, for names written + [:via registry name], as OTP's {via, Module, Name}. Any value + implementing Registry may be one: a global registry, a process group, + a table of its own. + + ensemble registers a process's via name when it is spawned with + {:name [:via r nm]}, resolves the name with whereis-name wherever a + process is taken (!, gen-server's call!, link!, monitor!), and + unregisters it when the process exits, so a registry need not watch its + processes itself -- unless it implements Watches, saying it does.") + +(defprotocol Registry + (register-name [r nm pid] + "Register pid under nm. True if it is now registered, false if nm is + taken.") + (unregister-name [r nm] "Release nm.") + (whereis-name [r nm] "The pid registered under nm, or nil.")) + +(defprotocol Watches + (watches-its-processes? [r] + "True: r releases a process's names itself when the process exits, so + ensemble need not.")) + +(defn via? + "Is x a name written [:via registry name]?" + [x] + (and (vector? x) (= 3 (count x)) (= :via (first x)))) + +(defonce ^{:doc "The registry a name written [:global name] stands for: + ensemble.global's, once it is loaded."} + global + (atom nil)) + +(defn global? + "Is x a name written [:global name], OTP's {global, Name}?" + [x] + (and (vector? x) (= 2 (count x)) (= :global (first x)))) + +(defn named + "x, with a name [:global nm] as the [:via registry nm] it stands for." + [x] + (if (global? x) + (if-let [g @global] + [:via g (second x)] + (throw (ex-info "no global registry: require ensemble.global" {:reason :badarg :name x}))) + x)) diff --git a/src/ensemble/rpc.clj b/src/ensemble/rpc.clj new file mode 100644 index 0000000..54cec5a --- /dev/null +++ b/src/ensemble/rpc.clj @@ -0,0 +1,88 @@ +(ns ensemble.rpc + "Run a fn on another node, as OTP's erpc: each call runs in a process of + its own there, started by spawn-on, so the fn is one the node allows + (ensemble.node/start!'s :spawn) and named by a symbol. + + A failed call throws ex-info whose :reason is :noconnection (the node + cannot be reached, or went down during the call), :timeout (the + process running it is then killed), [:not-allowed sym], [:exception e] + for a throw (e an ex-info with the message and data it was thrown with), or + [:exit reason] for an exit." + (:require [ensemble.actor :as act :refer [receive]] + [ensemble.node :as node])) + +(defn- fail [reason] + (throw (ex-info (str "rpc failed: " (pr-str reason)) {:reason reason}))) + +(defn- in-actor + "(f) run in an actor: this one, or a fresh one when there is none." + [f] + (if (act/self) + (f) + (let [p (promise)] + (act/spawn (fn [] (deliver p (node/outcome f)))) + (let [[k v] @p] + (case k :ok v :exit (act/exit! v) :exception (throw v)))))) + +(defn- start + "Start (apply f args) on node n, answering to the current actor under + ref, waiting up to timeout-ms for n to start it; its pid." + [n f-sym args ref timeout-ms] + (if (= n (act/node)) + (let [me (act/self) + f (requiring-resolve f-sym)] + (act/spawn (fn [] (act/! me [::node/result ref (node/outcome #(apply f args))])))) + (try (node/spawn-on n f-sym args {:reply ref :timeout timeout-ms}) + (catch Throwable e + (let [r (:reason (ex-data e))] + (fail r)))))) + +(defn call + "(apply f args) on node n, f named by f-sym, and its value, waiting up to + timeout-ms (default :infinity). Throws as the ns doc says." + ([n f-sym args] (call n f-sym args :infinity)) + ([n f-sym args timeout-ms] + (in-actor + (fn [] + (let [ref (act/make-ref) + pid (start n f-sym args ref timeout-ms) + mref (act/monitor! pid) + r (receive + [[::node/result ref r] r] + [[:DOWN mref :process _ reason] [:down reason]] + [:after (act/timeout-ms timeout-ms) [:timeout]])] + (act/demonitor! mref {:flush true}) + (case (first r) + :ok (second r) + :exception (fail [:exception (second r)]) + :exit (fail [:exit (second r)]) + :down (fail (if (= :noconnection (second r)) :noconnection [:exit (second r)])) + :timeout (do (act/exit! pid :kill) (fail :timeout)))))))) + +(defn cast + "Start (apply f args) on node n and do not wait, as erpc:cast. Returns + true, whether or not the node could be reached." + [n f-sym args] + (try + (if (= n (act/node)) + (let [f (requiring-resolve f-sym)] (act/spawn #(apply f args))) + (node/spawn-on n f-sym args)) + (catch Throwable _ nil)) + true) + +(defn multicall + "call on each of nodes at once, waiting up to timeout-ms (default + :infinity) for all. A result per node, in order: [:ok value] or + [:error reason]." + ([nodes f-sym args] (multicall nodes f-sym args :infinity)) + ([nodes f-sym args timeout-ms] + (let [here (act/node) + ps (mapv (fn [n] + (let [p (promise)] + (binding [act/*node* here] + (act/spawn (fn [] (deliver p (try [:ok (call n f-sym args timeout-ms)] + (catch Throwable e + [:error (or (:reason (ex-data e)) e)])))))) + p)) + nodes)] + (mapv deref ps)))) diff --git a/src/ensemble/statem.clj b/src/ensemble/statem.clj index 1ed4671..3624654 100644 --- a/src/ensemble/statem.clj +++ b/src/ensemble/statem.clj @@ -5,7 +5,8 @@ which timeouts are armed after the transition. An event is [type content]. A timer is keyed :event, :state or - [:generic name], and holds [ms content].") + [:generic name], and holds [ms content]; ms is [:abs t] for a deadline + on the monotonic clock.") (defn- timeout-ms [t] (if (= :infinity t) nil t)) @@ -14,6 +15,22 @@ [t] (if (integer? t) (not (neg? t)) (or (nil? t) (= :infinity t)))) +(defn- abs-opts? + "A timeout's options: a map whose :abs, if there, is a boolean." + [o] + (and (map? o) (or (not (contains? o :abs)) (boolean? (get o :abs))))) + +(defn- abs? + "Do a timeout's options make its time absolute?" + [o] + (true? (get o :abs))) + +(defn- abs-time? + "A time with its options: an absolute one may be any integer, as a + deadline on the clock is." + [t o] + (if (abs? o) (or (integer? t) (time? t)) (time? t))) + (defn- event-type? "A type a :next-event may insert." [t] @@ -30,8 +47,18 @@ :hibernate (if (and (= 2 n) (boolean? (second a))) :hibernate :bad) :next-event (if (and (= 3 n) (event-type? (second a))) :next-event :bad) :reply (if (= 3 n) :reply :bad) - (:timeout :state-timeout) (if (and (= 3 n) (time? (second a))) :timer :bad) - :generic-timeout (if (and (= 4 n) (time? (nth a 2))) :timer :bad) + (:timeout :state-timeout) + (cond + (= 2 n) (if (= :cancel (second a)) :timer :bad) + (= 3 n) (if (or (= :update (second a)) (time? (second a))) :timer :bad) + (= 4 n) (if (and (abs-opts? (nth a 3)) (abs-time? (second a) (nth a 3))) :timer :bad) + :else :bad) + :generic-timeout + (cond + (= 3 n) (if (= :cancel (nth a 2)) :timer :bad) + (= 4 n) (if (or (= :update (nth a 2)) (time? (nth a 2))) :timer :bad) + (= 5 n) (if (and (abs-opts? (nth a 4)) (abs-time? (nth a 2) (nth a 4))) :timer :bad) + :else :bad) :bad))) (defn- action-kind @@ -86,7 +113,7 @@ (defn- shape-of "A callback's return by its shape alone: [:T state data actions], - [:S reason replies data], or nil." + [:R state data actions] for a repeat, [:S reason replies data], or nil." [ret state data] (let [n (if (vector? ret) (count ret) 0) tag (when (pos? n) (first ret)) @@ -95,6 +122,8 @@ (and (= :next-state tag) (<= 3 n 4)) [:T (nth ret 1) (nth ret 2) (acts 3)] (and (= :keep-state tag) (<= 2 n 3)) [:T state (nth ret 1) (acts 2)] (and (= :keep-state-and-data tag) (<= 1 n 2)) [:T state data (acts 1)] + (and (= :repeat-state tag) (<= 2 n 3)) [:R state (nth ret 1) (acts 2)] + (and (= :repeat-state-and-data tag) (<= 1 n 2)) [:R state data (acts 1)] (and (= :stop tag) (<= 2 n 3)) [:S (nth ret 1) [] (if (= 3 n) (nth ret 2) data)] (and (= :stop-and-reply tag) (<= 3 n 4)) [:S (nth ret 1) (nth ret 2) (if (= 4 n) (nth ret 3) data)] :else nil))) @@ -102,7 +131,8 @@ (defn result-of "What a callback's return ret means, given the current state and data. kind is :enter for a state enter call, else :event. - [:Transition state data actions], [:Stop reason replies data] or + [:Transition state data actions], [:Repeat state data actions] (keep the + state, and run its enter call again), [:Stop reason replies data] or [:Bad reason], the reason the machine stops with, as OTP names it." [kind ret state data] (let [sh (shape-of ret state data)] @@ -116,7 +146,8 @@ (= :Bad (first as)) [:Bad [:bad-reply-action-from-state-function (second as)]] not-reply [:Bad [:bad-reply-action-from-state-function (first not-reply)]] :else [:Stop why (second as) d])) - :T (let [[_ st d acts] sh + (:T :R) + (let [[tag st d acts] sh as (action-list acts)] (cond (= :Bad (first as)) [:Bad [:bad-action-from-state-function (second as)]] @@ -125,16 +156,30 @@ (and (= :enter kind) (first-of #{:postpone :next-event} (second as))) [:Bad [:bad-state-enter-action-from-state-function (first (first-of #{:postpone :next-event} (second as)))]] + (= :R tag) [:Repeat st d (second as)] :else [:Transition st d (second as)]))))) +(defn- time-of + "A timer action's time as a timer holds it: ms, [:abs t], :update, or nil + to cancel." + [t opts] + (cond + (= :cancel t) nil + (= :update t) :update + (nil? (timeout-ms t)) nil + (abs? opts) [:abs t] + :else t)) + (defn- timer-of - "A timer action as [key ms content]." + "A timer action as [key time content]." [a] - (case (if (vector? a) (first a) :bare) - :bare [:event (timeout-ms a) a] - :timeout [:event (timeout-ms (nth a 1)) (nth a 2)] - :state-timeout [:state (timeout-ms (nth a 1)) (nth a 2)] - :generic-timeout [[:generic (nth a 1)] (timeout-ms (nth a 2)) (nth a 3)])) + (if (vector? a) + (let [[tag x y z w] a] + (case tag + (:timeout :state-timeout) + [({:timeout :event :state-timeout :state} tag) (time-of x z) (if (= :cancel x) nil y)] + :generic-timeout [[:generic x] (time-of y w) (if (= :cancel y) nil z)])) + [:event (timeout-ms a) a])) (defn actions-of "Split actions into [:Actions postpone? inserted replies timers], each list @@ -172,12 +217,57 @@ [:Queues [] (vec (concat inserted kept queue))] [:Queues kept (vec (concat inserted queue))]))) +(defn- set-timer + "ts with one timer action applied: a nil time cancels, :update changes a + running timer's content -- or starts one of time 0 -- and any other time + starts the timer." + [ts [k ms content]] + (cond + (nil? ms) (dissoc ts k) + (= :update ms) (if (contains? ts k) (assoc ts k [(first (get ts k)) content]) (assoc ts k [0 content])) + :else (assoc ts k [ms content]))) + +(defn- carried + "The timers a transition starts from: the event timeout cleared, the state + timeout cleared on a state change." + [changed? timers] + (if changed? (dissoc timers :event :state) (dissoc timers :event))) + (defn next-timers "The timers after a transition: the event timeout cleared, the state - timeout cleared on a state change, then each timer action applied in order - (a nil time cancels)." + timeout cleared on a state change, then each timer action applied in + order." + [changed? timers timeouts] + (reduce set-timer (carried changed? timers) timeouts)) + +(defn- started-keys + "The keys of the timers that timeouts start anew from ts." + [ts timeouts] + (second + (reduce (fn [[ts started] [k ms _ :as t]] + [(set-timer ts t) + (cond + (nil? ms) (disj started k) + (and (= :update ms) (contains? ts k)) started + :else (conj started k))]) + [ts #{}] + timeouts))) + +(defn restarted + "The keys of the timers a transition starts anew: those an action sets, + and those an update finds not running. An update of a running timer + keeps its deadline, and a cancel ends whatever was started." [changed? timers timeouts] - (reduce (fn [ts [k ms content]] - (if (nil? ms) (dissoc ts k) (assoc ts k [ms content]))) - (cond-> (dissoc timers :event) changed? (dissoc :state)) - timeouts)) + (started-keys (carried changed? timers) timeouts)) + +(defn enter-timers + "The timers after an enter call: its timer actions applied to the + transition's, which it keeps whole -- the event timeout included, since + no event has arrived since." + [timers timeouts] + (reduce set-timer timers timeouts)) + +(defn enter-restarted + "The keys of the timers an enter call starts anew." + [timers timeouts] + (started-keys timers timeouts)) diff --git a/src/ensemble/supervisor.clj b/src/ensemble/supervisor.clj index f5dd3bd..05371db 100644 --- a/src/ensemble/supervisor.clj +++ b/src/ensemble/supervisor.clj @@ -121,31 +121,39 @@ "Stop the running children all at once, as OTP stops a :simple-one-for-one supervisor's: each is unlinked and sent :shutdown (killed, for :brutal-kill), then all are waited for under one shutdown - time, and those still running then are killed. Returns the children - with no actor." + time, and those still running then are killed. A child that ends other + than as it was told is a shutdown_error, as in shutdown-child. Returns + the children with no actor." [children] (let [running (filterv :actor children) how (:shutdown (first running)) + expected (if (= :brutal-kill how) :killed :shutdown) watched (into {} (for [c running :let [a (:actor c) mref (act/monitor! a)]] (do (act/unlink! a) (receive [[:EXIT a _] nil] [:after 0 nil]) (act/exit! a (if (= :brutal-kill how) :kill :shutdown)) - [mref a]))) + [mref c]))) deadline (when (int? how) (+ (act/now-ms) how)) await (fn [left t] (receive - [[:DOWN mref :process _ _] :when (contains? left mref) mref] - [:after t ::late]))] - (loop [left watched] - (when (seq left) - (let [r (await left (when deadline (max 0 (- deadline (act/now-ms)))))] - (if (= ::late r) - (do (run! (fn [a] (act/exit! a :kill)) (vals left)) - (loop [left left] - (when (seq left) (recur (dissoc left (await left nil)))))) - (recur (dissoc left r)))))) + [[:DOWN mref :process _ why] :when (contains? left mref) [mref why]] + [:after t ::late])) + ended (loop [left watched, ended {}] + (if (empty? left) + ended + (let [r (await left (when deadline (max 0 (- deadline (act/now-ms)))))] + (if (= ::late r) + (do (run! (fn [c] (act/exit! (:actor c) :kill)) (vals left)) + (loop [left left, ended ended] + (if (empty? left) + ended + (let [[mref why] (await left nil)] + (recur (dissoc left mref) (assoc ended mref why)))))) + (let [[mref why] r] (recur (dissoc left mref) (assoc ended mref why)))))))] + (doseq [[mref why] ended :when (not (contains? #{expected :noproc} why))] + (report! :shutdown-error why (get watched mref))) (mapv #(assoc % :actor nil) children))) (defn- stop-all [children] diff --git a/src/ensemble/sys.clj b/src/ensemble/sys.clj new file mode 100644 index 0000000..be15bfa --- /dev/null +++ b/src/ensemble/sys.clj @@ -0,0 +1,71 @@ +(ns ensemble.sys + "OTP's sys: look into and steer a running behaviour -- a gen-server, a + gen-statem, and so a supervisor or a gen-event manager -- through system + messages it answers between its own. + + What a behaviour's state is to sys: a gen-server's state, a gen-statem's + [state data]. A suspended process takes only system messages (and a + stop, and its parent's exit) until it is resumed; everything else waits + in its mailbox. + + Each fn takes an optional timeout in ms (default 5000; nil or :infinity + waits forever) and throws as a gen-server call does when the process is + not there or does not answer." + (:require [ensemble.gen-server :as gs])) + +(def ^:private default-timeout 5000) + +(defn- ask + [srv req timeout] + (let [[tag v] (gs/system-call! srv req timeout)] + (if (= :ok tag) + v + (throw (ex-info (str "sys request failed: " (pr-str v)) + {:reason v :request req} + (when (instance? Throwable v) v)))))) + +(defn get-state + "The behaviour's state." + ([srv] (get-state srv default-timeout)) + ([srv timeout] (ask srv :get-state timeout))) + +(defn replace-state! + "Replace the behaviour's state with (f state) and return it. When f + throws, the state is left and this throws." + ([srv f] (replace-state! srv f default-timeout)) + ([srv f timeout] (ask srv [:replace-state f] timeout))) + +(defn get-status + "What the process is: {:pid :name :module :status :parent :state}, its + :status :running or :suspended, its state as the behaviour's + format-status shows it." + ([srv] (get-status srv default-timeout)) + ([srv timeout] (ask srv :get-status timeout))) + +(defn suspend! + "Suspend the process: it takes only system messages until resumed." + ([srv] (suspend! srv default-timeout)) + ([srv timeout] (ask srv :suspend timeout))) + +(defn resume! + "Resume a suspended process." + ([srv] (resume! srv default-timeout)) + ([srv timeout] (ask srv :resume timeout))) + +(defn statistics + "flag true starts counting, false stops; :get answers {:start-time + :current-time :messages-in} (wall-clock ms), or :no-statistics." + ([srv flag] (statistics srv flag default-timeout)) + ([srv flag timeout] (ask srv [:statistics flag] timeout))) + +(defn trace! + "While on, report each message the process takes to ensemble.logger, + as {:kind :sys-trace :event e}." + ([srv on] (trace! srv on default-timeout)) + ([srv on timeout] (ask srv [:trace on] timeout))) + +(defn terminate! + "Stop the process with reason, as sys:terminate, suspended or not: its + terminate runs and it exits. Returns :ok." + ([srv reason] (terminate! srv reason :infinity)) + ([srv reason timeout] (gs/stop! srv reason timeout))) diff --git a/src/ensemble/transport.clj b/src/ensemble/transport.clj new file mode 100644 index 0000000..782768c --- /dev/null +++ b/src/ensemble/transport.clj @@ -0,0 +1,93 @@ +(ns ensemble.transport + "What distribution needs of a network: a byte stream between two nodes. + + A transport library -- TCP, TLS, WebSocket, a pipe -- implements these + three protocols and nothing else. ensemble.node does the rest on top: + the handshake that names the peer and proves it holds the cookie, the + framing of the stream, the codec, and every operation of the + distribution protocol. A transport resolves a node name to an address + however it likes (a fixed table, DNS, a port mapper). + + The loopback transport here connects nodes in one VM, through channels; + it is for tests, and for an example of the protocols." + (:require [clojure.core.async :as a])) + +(defprotocol Transport + (-listen [t node accept] + "Accept connections to node: call (accept conn) with each one opened + to it. Returns a Listener.") + (-connect [t node peer] + "Open a byte stream from node to node peer. Returns a Conn, or nil + when peer cannot be reached.")) + +(defprotocol Listener + (-stop [l] "Stop accepting connections.")) + +(defprotocol Conn + (-start [c on-bytes on-close] + "Begin reading, once: (on-bytes bs) with each chunk of the stream, a + byte array, in order -- a chunk may hold part of what the peer wrote, + or several writes -- and (on-close) once when the stream ends, from + either end.") + (-write [c bs] + "Write the byte array bs, whole and after anything written before. + Called from any fiber, at once; each call's bytes stay together. + False once the stream is closed.") + (-close [c] "Close the stream. Both ends' on-close run.")) + +;; --- the loopback transport --------------------------------------------- + +(defonce ^:private listening + ;; node -> accept fn, for every loopback transport in this VM + (atom {})) + +(defn- chunks + "bs as chunks of at most n bytes, or whole when n is nil." + [^bytes bs n] + (if (or (nil? n) (<= (alength bs) n)) + [bs] + (for [i (range 0 (alength bs) n)] + (let [m (min n (- (alength bs) i)) + out (byte-array m)] + (System/arraycopy bs i out 0 m) + out)))) + +(defrecord LoopbackEnd [in out closed chunk] + Conn + (-start [_ on-bytes on-close] + (a/go-loop [] + (if-let [bs (a/LoopbackListener node)) + (-connect [_ node peer] + (when-let [accept (get @listening peer)] + (let [to-peer (a/chan 65536) + from-peer (a/chan 65536) + closed (atom false) + mine (->LoopbackEnd from-peer to-peer closed chunk) + theirs (->LoopbackEnd to-peer from-peer closed chunk)] + (accept theirs) + mine)))) + +(defn loopback + "The transport between nodes in this VM. With {:chunk n} each write + reaches the other end in chunks of at most n bytes, as a network may + split it." + ([] (loopback {})) + ([{:keys [chunk]}] (->Loopback chunk))) diff --git a/test/ensemble/actor_test.clj b/test/ensemble/actor_test.clj index efa9c1b..45e76ea 100644 --- a/test/ensemble/actor_test.clj +++ b/test/ensemble/actor_test.clj @@ -113,6 +113,39 @@ (act/! a [3 3]) (is (= [:same 3] (act/join a 1000))))) +(deftest a-list-tail-takes-the-rest + (let [a (act/spawn (fn [] (receive [[:args h & t] [h (vec t)]])))] + (act/! a [:args 1 2 3]) + (is (= [1 [2 3]] (act/join a 1000)))) + (let [a (act/spawn (fn [] (receive [[:one x & []] x] [_ :many])))] + (act/! a [:one 1 2]) + (is (= :many (act/join a 1000))))) + +(deftest a-map-pattern-matches-the-keys-it-names + (let [a (act/spawn (fn [] [(receive [{:op :add :n n} n]) + (receive [{:op :put :at {:x x}} x]) + (receive [m m] [:after 0 nil])]))] + (act/! a {:op :put :at {:x 9}}) + (act/! a [:op :add :n 1]) + (act/! a {:op :add :n 5 :extra true}) + (is (= [5 9 [:op :add :n 1]] (act/join a 1000))))) + +(deftest a-map-key-may-be-a-bound-local + (let [a (act/spawn (fn [] + (let [k (act/make-ref)] + (act/! (act/self) {(act/make-ref) :wrong}) + (act/! (act/self) {k :right}) + (receive [{k v} v]))))] + (is (= :right (act/join a 1000))))) + +(deftest a-map-key-must-be-a-value + (is (thrown? Throwable (eval '(ensemble.actor/receive [{unbound v} v]))))) + +(deftest a-tail-needs-one-pattern + (is (thrown? Throwable (eval '(ensemble.actor/receive [[a &] a])))) + (is (thrown? Throwable (eval '(ensemble.actor/receive [[a & b c] a])))) + (is (thrown? Throwable (eval '(ensemble.actor/receive [[& b] b]))))) + (deftest receive-outside-an-actor-throws (is (thrown? Throwable (receive [_ :x] [:after 0 :none])))) @@ -341,3 +374,96 @@ (is (= :one.vm (act/ref-node r1))) (is (= :two.vm (act/ref-node r2))) (is (not= (assoc r1 :ensemble.actor/ref 0) (assoc r2 :ensemble.actor/ref 0))))) + +;; --- process-info ----------------------------------------------------------- + +(defn- eventually [pred] + (loop [i 0] (cond (pred) true (> i 200) false :else (do (a/JustData 1)))) + (is (not (act/remote? (->JustData 1)))) + (is (not (act/pid? {:a 1})))) + +(deftest join-and-exit-reason-take-infinity + (let [a (act/spawn (fn [] :done))] + (is (= :done (act/join a :infinity))) + (is (= :normal (act/exit-reason a :infinity))) + (is (= :normal (act/exit-reason a nil))))) + +(deftest a-map-pattern-passes-over-a-sorted-map-of-other-keys + (let [a (act/spawn (fn [] (receive [{:k v} [:matched v]] [m [:other m]])))] + (act/! a (sorted-map 1 :a)) + (is (= [:other {1 :a}] (act/join a 1000)) "the actor is not crashed by the sorted map's compare"))) diff --git a/test/ensemble/application_test.clj b/test/ensemble/application_test.clj index eb20e00..542e9a6 100644 --- a/test/ensemble/application_test.clj +++ b/test/ensemble/application_test.clj @@ -66,3 +66,124 @@ (act/! (sup/child top :w) :die) (is (eventually #(= 7 (count @log)))) (is (= [6 5 4 3 2 1 0] @log))))) + +;; --- env -------------------------------------------------------------------- + +(deftest an-application-has-an-env + (app/load! (spec ::env-app :env {:port 80 :host "h"})) + (is (= 80 (app/get-env ::env-app :port))) + (is (nil? (app/get-env ::env-app :missing))) + (is (= :dflt (app/get-env ::env-app :missing :dflt))) + (app/set-env! ::env-app :port 8080) + (is (= 8080 (app/get-env ::env-app :port))) + (app/unset-env! ::env-app :host) + (is (= {:port 8080} (app/get-all-env ::env-app))) + (app/load! (spec ::env-app :env {:port 80})) + (is (= 8080 (app/get-env ::env-app :port)) "a set value outlives a reload, as OTP keeps it") + (is (= {:port 80} (app/get-key ::env-app :env)) "get-key reads the spec as loaded")) + +;; --- start phases and prep-stop ------------------------------------------------ + +(deftest start-phases-run-in-order-after-start + (let [log (atom [])] + (app/load! (spec ::phased + :start-phases [[:init {:a 1}] [:go nil]] + :start-phase (fn [phase type args] (swap! log conj [phase type args]) :ok))) + (app/start! ::phased) + (is (= [[:init :normal {:a 1}] [:go :normal nil]] @log)) + (app/stop! ::phased))) + +(deftest a-failing-start-phase-fails-the-start + (app/load! (spec ::bad-phase + :start-phases [[:init nil]] + :start-phase (fn [_ _ _] [:error :nope]))) + (is (= [:bad-start-phase :init [:error :nope]] + (try (app/start! ::bad-phase) (catch Throwable e (:reason (ex-data e)))))) + (is (not (app/started? ::bad-phase)))) + +(deftest prep-stop-runs-before-the-tree-stops + (let [log (atom []) + top (atom nil)] + (app/load! (spec ::prepped + :prep-stop (fn [st] + (swap! log conj [:prep st (act/alive? @top)]) + [:prepped st]) + :stop (fn [st] (swap! log conj [:stop st])))) + (app/start! ::prepped) + (reset! top (:top (get @@#'app/running ::prepped))) + (app/stop! ::prepped) + (is (= [[:prep ::prepped true] [:stop [:prepped ::prepped]]] @log)))) + +;; --- included and optional applications --------------------------------------- + +(deftest an-included-application-is-not-started-on-its-own + (app/load! (spec ::inc-child)) + (app/load! (spec ::inc-parent :included-applications [::inc-child])) + (app/start! ::inc-parent) + (is (= [:included ::inc-child ::inc-parent] + (try (app/start! ::inc-child) (catch Throwable e (:reason (ex-data e)))))) + (app/stop! ::inc-parent) + (is (= :ok (app/start! ::inc-child)) "once its includer has stopped it may start") + (app/stop! ::inc-child)) + +(deftest an-included-application-must-be-loaded + (app/load! (spec ::inc-missing :included-applications [::never-loaded])) + (is (= [:not-loaded ::never-loaded] + (try (app/start! ::inc-missing) (catch Throwable e (:reason (ex-data e))))))) + +(deftest an-optional-dependency-may-be-absent + (app/load! (spec ::opt-user :applications [::opt-dep ::not-there] + :optional-applications [::opt-dep ::not-there])) + (app/load! (spec ::opt-dep)) + (is (= [:not-started ::opt-dep] + (try (app/start! ::opt-user) (catch Throwable e (:reason (ex-data e))))) + "loaded, it must be running first") + (is (= [::opt-dep ::opt-user] (app/ensure-all-started! ::opt-user))) + (app/stop! ::opt-user) (app/stop! ::opt-dep)) + +;; --- ensure-all-started! rolls back -------------------------------------------- + +(deftest ensure-all-started-stops-what-it-started-on-a-failure + (let [log (atom [])] + (app/load! (spec ::rb-a :stop (fn [_] (swap! log conj :a)))) + (app/load! (spec ::rb-b :applications [::rb-a] :stop (fn [_] (swap! log conj :b)))) + (app/load! {:name ::rb-c :applications [::rb-b] :start (fn [] (throw (ex-info "no" {})))}) + (is (thrown? Throwable (app/ensure-all-started! ::rb-c))) + (is (= [:b :a] @log)) + (is (not (app/started? ::rb-a))))) + +;; --- failures around start and stop ------------------------------------------- + +(deftest a-tree-dead-on-start-leaves-a-consistent-record + (app/load! (spec ::stillborn + :start (fn [] (let [t (tree)] (act/exit! t :kill) (act/exit-reason t 1000) t)))) + (try (app/start! ::stillborn) (catch Throwable _ nil)) + (is (eventually #(not (app/started? ::stillborn))) "a dead tree is not running") + (is (not (some #{::stillborn} (app/which-applications)))) + (app/stop! ::stillborn)) + +(deftest a-throwing-prep-stop-still-stops-the-tree + (let [log (atom [])] + (app/load! (spec ::bad-prep + :prep-stop (fn [_] (throw (ex-info "prep" {}))) + :stop (fn [st] (swap! log conj [:stop st])))) + (app/start! ::bad-prep) + (let [top (:top (get @@#'app/running ::bad-prep))] + (is (thrown? Throwable (app/stop! ::bad-prep)) "stop! reports the failure") + (is (false? (act/alive? top)) "the tree is stopped all the same") + (is (= [[:stop ::bad-prep]] @log) ":stop runs with the state prep-stop was given")))) + +(deftest stop-all-gets-past-a-throwing-prep-stop + (app/load! (spec ::first)) + (app/load! (spec ::bad-prep2 :prep-stop (fn [_] (throw (ex-info "prep" {}))))) + (app/start! ::first) + (app/start! ::bad-prep2) + (#'app/stop-all!) + (is (not (app/started? ::first)) "the applications after the failing one stop too")) + +(deftest reloading-a-spec-takes-its-new-env + (app/load! (spec ::reloaded :env {:a 1 :b 1})) + (app/set-env! ::reloaded :b 2) + (app/load! (spec ::reloaded :env {:a 10 :b 10})) + (is (= 10 (app/get-env ::reloaded :a)) "a value from the old spec gives way to the new") + (is (= 2 (app/get-env ::reloaded :b)) "a value set-env! gave is kept")) diff --git a/test/ensemble/digest_test.clj b/test/ensemble/digest_test.clj new file mode 100644 index 0000000..4f172c3 --- /dev/null +++ b/test/ensemble/digest_test.clj @@ -0,0 +1,34 @@ +(ns ensemble.digest-test + "SHA-256 and HMAC-SHA256 against the published test vectors (FIPS 180-2, + RFC 4231)." + (:require [clojure.test :refer [deftest is]] + [ensemble.digest :as d])) + +(defn- utf8 [s] (vec (.getBytes ^String s "UTF-8"))) + +(deftest sha-256-vectors + (is (= "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" (d/hex (d/sha-256 (utf8 ""))))) + (is (= "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" (d/hex (d/sha-256 (utf8 "abc"))))) + (is (= "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1" + (d/hex (d/sha-256 (utf8 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"))))) + (is (= "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0" + (d/hex (d/sha-256 (vec (repeat 1000000 (int \a)))))))) + +(deftest a-message-at-each-padding-boundary + ;; 55, 56 and 64 bytes: the length either fits in the last block or does not + (is (= "9f4390f8d30c2dd92ec9f095b65e2b9ae9b0a925a5258e241c9f1e910f734318" (d/hex (d/sha-256 (vec (repeat 55 97)))))) + (is (= "b35439a4ac6f0948b6d6f9e3c6af0f5f590ce20f1bde7090ef7970686ec6738a" (d/hex (d/sha-256 (vec (repeat 56 97)))))) + (is (= "ffe054fe7ae0cb6dc65c3af9b61d5209f439851db43d0ba5997337df154668eb" (d/hex (d/sha-256 (vec (repeat 64 97))))))) + +(deftest hmac-sha-256-vectors + (is (= "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" + (d/hex (d/hmac-sha-256 (vec (repeat 20 0x0b)) (utf8 "Hi There"))))) + (is (= "5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843" + (d/hex (d/hmac-sha-256 (utf8 "Jefe") (utf8 "what do ya want for nothing?"))))) + ;; a key longer than a block is hashed first + (is (= "60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54" + (d/hex (d/hmac-sha-256 (vec (repeat 131 0xaa)) + (utf8 "Test Using Larger Than Block-Size Key - Hash Key First")))))) + +(deftest bytes-of-a-signed-array-are-taken-unsigned + (is (= (d/sha-256 [200 1]) (d/sha-256 (vec (byte-array [(unchecked-byte 200) 1])))))) diff --git a/test/ensemble/dist_spec.clj b/test/ensemble/dist_spec.clj index fc068d4..edd32d1 100644 --- a/test/ensemble/dist_spec.clj +++ b/test/ensemble/dist_spec.clj @@ -7,81 +7,96 @@ elsewhere goes to that node. The same send, !, serves both. - Pids travel inside messages. On arrival, a pid of the receiving node is that node's own process again; a pid of any other node stays remote. + (Where in a frame a pid is, the node's envelope says; this decides + each one.) - When the connection to a node goes down, every link to one of its processes is broken with the exit reason noconnection, every monitor of one gets a DOWN with noconnection, and every monitor_node of it gets {nodedown, Node}. Links and monitors on other nodes are untouched, and - each fires once." + each fires once. + - A pid carries its node's creation, a number fresh each time the node + starts: a pid of an earlier run of this node names no process here, + though its id may be in use again. + - Two nodes connect with a handshake: the one connecting sends its name + and creation; the other answers with a status -- ok, nok when the name + is its own or it is connecting to the same peer and its own name sorts + higher (so of two simultaneous connections one is kept), alive when it + is already connected to that run of the peer -- and with a challenge. + A connection to an earlier run of the peer gives way to the new run, as + Erlang's does, and that earlier run goes down. Each end proves it holds + the cookie by signing the other's challenge; a wrong signature ends the + handshake, and only after it does any other frame count. + - A frame on the wire is its length as four bytes, big-endian, then its + payload." (:require [writ.spec :refer [spec data ann refine graph law calls]] [ensemble.dist :as dist] [ensemble.node :as node])) (spec ensemble.dist {:require :proved}) -(data Dest (Pid Keyword Nat) (Name Keyword) (At Keyword Keyword)) -(data Route (Here Nat) (There Keyword Nat) (Named Keyword) (NamedThere Keyword Keyword)) -;; a link or monitor from local process me to pid [:Pid node id] -(data Link (Link Nat Keyword Nat)) -(data Mon (Mon Nat Any Keyword Nat)) +(data Dest (Pid Keyword Nat Nat) (Name Keyword) (At Keyword Keyword)) +(data Route (Here Nat) (Gone) (There Keyword Nat Nat) (Named Keyword) (NamedThere Keyword Keyword)) +;; a link or monitor from local process me to pid [:Pid node id creation] +(data Link (Link Nat Keyword Nat Nat)) +(data Mon (Mon Nat Any Keyword Nat Nat)) (data NodeMon (NodeMon Nat Keyword)) (data Effect (Signal Nat Any Any) (Deliver Nat Any)) +(data Step (Next Any (Vec Any)) (Up Any (Vec Any)) (Fail Any (Vec Any))) -(ann route [Keyword Dest -> Route]) -(ann arrive [Keyword Any -> Any]) +(ann route [Keyword Nat Dest -> Route]) +(ann arrive [Keyword Nat Dest -> Any]) +(ann on-up [Keyword Any Any -> Keyword]) (ann on-nodedown [Keyword (Vec Link) (Vec Mon) (Vec NodeMon) -> (Vec Effect)]) +(ann name-status [Keyword Keyword Nat Any Bool -> Keyword]) +(ann sorts-higher? [Keyword Keyword -> Bool]) +(ann open-handshake [Keyword Nat Keyword -> Step]) +(ann accept-handshake [Keyword Nat -> Any]) +(ann handshake [Any Any Any -> Step]) +(ann length-header [Nat -> (Vec Nat)]) +(ann header-length [(Vec Nat) -> Nat]) -(refine Local [r Route] (contains? #{:Here :Named} (first r))) +(refine Local [r Route] (contains? #{:Here :Named :Gone} (first r))) (refine Remote [r Route] (contains? #{:There :NamedThere} (first r))) (graph send {:states {:dest Dest, :local Local, :remote Remote} - :edges {:dest {[route Keyword _] #{:local :remote}}}}) + :edges {:dest {[route Keyword Nat _] #{:local :remote}}}}) ;; --- routing ------------------------------------------------------------ (law a-pid-here-is-delivered-here - (forall [self Keyword, id Nat] (= (route self [:Pid self id]) [:Here id]))) + (forall [self Keyword, cr Nat, id Nat] (= (route self cr [:Pid self id cr]) [:Here id]))) + +(law a-pid-of-an-earlier-run-is-gone + (forall [self Keyword, cr Nat, old Nat, id Nat] + (=> (not= cr old) (= (route self cr [:Pid self id old]) [:Gone])))) (law a-pid-elsewhere-goes-to-its-node - (forall [self Keyword, n Keyword, id Nat] - (=> (not= self n) (= (route self [:Pid n id]) [:There n id])))) + (forall [self Keyword, cr Nat, n Keyword, id Nat, c Nat] + (=> (not= self n) (= (route self cr [:Pid n id c]) [:There n id c])))) (law a-name-alone-is-this-nodes - (forall [self Keyword, nm Keyword] (= (route self [:Name nm]) [:Named nm]))) + (forall [self Keyword, cr Nat, nm Keyword] (= (route self cr [:Name nm]) [:Named nm]))) (law a-name-at-this-node-is-this-nodes - (forall [self Keyword, nm Keyword] (= (route self [:At nm self]) [:Named nm]))) + (forall [self Keyword, cr Nat, nm Keyword] (= (route self cr [:At nm self]) [:Named nm]))) (law a-name-at-another-node-goes-there - (forall [self Keyword, nm Keyword, n Keyword] - (=> (not= self n) (= (route self [:At nm n]) [:NamedThere n nm])))) + (forall [self Keyword, cr Nat, nm Keyword, n Keyword] + (=> (not= self n) (= (route self cr [:At nm n]) [:NamedThere n nm])))) ;; --- pids in messages --------------------------------------------------- (law a-pid-of-the-receiver-is-its-own-again - {:require :tested :because "a pid may be anywhere in a message, which clojure.walk walks and the prover does not model"} - (forall [self Keyword, id Nat] (= (arrive self [:Pid self id]) [:Local id]))) + (forall [self Keyword, cr Nat, id Nat] (= (arrive self cr [:Pid self id cr]) [:Local id]))) + +(law a-pid-of-an-earlier-run-stays-a-pid + (forall [self Keyword, cr Nat, old Nat, id Nat] + (=> (not= cr old) (= (arrive self cr [:Pid self id old]) [:Pid self id old])))) (law a-pid-of-another-node-stays-remote - {:require :tested :because "a pid may be anywhere in a message, which clojure.walk walks and the prover does not model"} - (forall [self Keyword, n Keyword, id Nat] - (=> (not= self n) (= (arrive self [:Pid n id]) [:Pid n id])))) - -(law pids-inside-a-message-arrive-too - {:require :tested :because "a pid may be anywhere in a message, which clojure.walk walks and the prover does not model"} - (forall [self Keyword, n Keyword, id Nat, k Keyword] - (=> (not= self n) - (= (arrive self [k [:Pid self id] [:Pid n id]]) [k [:Local id] [:Pid n id]])))) - -(law a-pid-inside-a-map-arrives-too - {:require :tested :because "a pid may be anywhere in a message, which clojure.walk walks and the prover does not model"} - (forall [self Keyword, id Nat] - (= (arrive self {:to [:Pid self id] :from #{[:Pid self id]}}) {:to [:Local id] :from #{[:Local id]}}))) - -(law data-without-pids-arrives-unchanged - {:require :tested :because "a pid may be anywhere in a message, which clojure.walk walks and the prover does not model"} - (forall [self Keyword, xs (Vec Int), k Keyword] - (= (arrive self [k xs]) [k xs]))) + (forall [self Keyword, cr Nat, n Keyword, id Nat] + (=> (not= self n) (= (arrive self cr [:Pid n id cr]) [:Pid n id cr])))) ;; --- a node goes down --------------------------------------------------- @@ -89,10 +104,10 @@ "The docs' effects of node n going down, entry by entry." [n links mons nmons] (vec (concat - (for [[_ me pn pid] links :when (= pn n)] - [:Signal me [:Pid pn pid] :noconnection]) - (for [[_ me ref pn pid] mons :when (= pn n)] - [:Deliver me [:DOWN ref :process [:Pid pn pid] :noconnection]]) + (for [[_ me pn pid cr] links :when (= pn n)] + [:Signal me [:Pid pn pid cr] :noconnection]) + (for [[_ me ref pn pid cr] mons :when (= pn n)] + [:Deliver me [:DOWN ref :process [:Pid pn pid cr] :noconnection]]) (for [[_ me mn] nmons :when (= mn n)] [:Deliver me [:nodedown mn]])))) @@ -101,23 +116,144 @@ (= (on-nodedown n links mons nmons) (effects-on n links mons nmons)))) (law a-link-to-the-lost-node-breaks-with-noconnection - (forall [n Keyword, me Nat, id Nat] - (= (on-nodedown n [[:Link me n id]] [] []) - [[:Signal me [:Pid n id] :noconnection]]))) + (forall [n Keyword, me Nat, id Nat, cr Nat] + (= (on-nodedown n [[:Link me n id cr]] [] []) + [[:Signal me [:Pid n id cr] :noconnection]]))) (law a-link-to-another-node-is-untouched - (forall [n Keyword, m Keyword, me Nat, id Nat] - (=> (not= n m) (= (on-nodedown n [[:Link me m id]] [] []) [])))) + (forall [n Keyword, m Keyword, me Nat, id Nat, cr Nat] + (=> (not= n m) (= (on-nodedown n [[:Link me m id cr]] [] []) [])))) (law a-monitor-of-the-lost-node-gets-down-noconnection - (forall [n Keyword, me Nat, ref Any, id Nat] - (= (on-nodedown n [] [[:Mon me ref n id]] []) - [[:Deliver me [:DOWN ref :process [:Pid n id] :noconnection]]]))) + (forall [n Keyword, me Nat, ref Any, id Nat, cr Nat] + (= (on-nodedown n [] [[:Mon me ref n id cr]] []) + [[:Deliver me [:DOWN ref :process [:Pid n id cr] :noconnection]]]))) (law monitor-node-gets-nodedown (forall [n Keyword, me Nat] (= (on-nodedown n [] [] [[:NodeMon me n]]) [[:Deliver me [:nodedown n]]]))) +;; --- the handshake ------------------------------------------------------- + +(law a-name-status-is-ok-for-a-new-peer + (forall [self Keyword, peer Keyword, cr Nat] + (=> (not= self peer) (= :ok (name-status self peer cr nil false))))) + +(law a-node-refuses-its-own-name + (forall [self Keyword, cr Nat, up Nat, pending Bool] (= :nok (name-status self self cr up pending)))) + +(law a-node-already-connected-is-alive + (forall [self Keyword, peer Keyword, cr Nat, pending Bool] + (=> (not= self peer) (= :alive (name-status self peer cr cr pending))))) + +(law a-restarted-peer-is-let-in + (forall [self Keyword, peer Keyword, cr Nat, old Nat, pending Bool] + (=> (and (not= self peer) (not= cr old)) (= :ok (name-status self peer cr old pending))))) + +;; of two simultaneous connections, the one from the higher name is kept +(law a-simultaneous-connection-keeps-the-higher-names + (and (= :nok (name-status :b.vm :a.vm 1 nil true)) + (= :ok (name-status :a.vm :b.vm 1 nil true)))) + +;; a connection that comes up beside another: both ends decide alike +(law a-first-connection-is-installed + (forall [self Keyword, cr Nat, i Keyword] + (= :install (on-up self nil {:creation cr :initiator i})))) + +(law a-connection-to-a-new-run-replaces-the-old-which-goes-down + (forall [self Keyword, cr Nat, old Nat, i Keyword, j Keyword] + (=> (not= cr old) + (= :replace-down (on-up self {:creation old :initiator i} {:creation cr :initiator j}))))) + +(law of-two-connections-to-one-run-the-higher-openers-stays + (and (= :replace (on-up :a.vm {:creation 1 :initiator :a.vm} {:creation 1 :initiator :b.vm})) + (= :drop (on-up :a.vm {:creation 1 :initiator :b.vm} {:creation 1 :initiator :a.vm})) + (= :replace (on-up :b.vm {:creation 1 :initiator :a.vm} {:creation 1 :initiator :b.vm})) + (= :drop (on-up :b.vm {:creation 1 :initiator :b.vm} {:creation 1 :initiator :a.vm})))) + +(defn sign-with + "A signer holding cookie: what the shell computes as an HMAC, modelled as + data the other end can check only by holding the same cookie." + [cookie] + (fn [challenge] [:signed cookie challenge])) + +(defn ctx-for + "A handshake context with no other connection, signing with cookie and + drawing fresh as its challenge." + [cookie fresh] + {:up-creation (fn [_] nil) :pending? (fn [_] false) :fresh fresh :sign (sign-with cookie)}) + +;; a's name reaches b, b's status and challenge reach a, a's reply reaches +;; b, b's ack reaches a +(law the-same-cookie-brings-both-ends-up + (let [[_ ia out-a] (open-handshake :a.vm 1 :b.vm) + [_ hb out-b] (handshake (accept-handshake :b.vm 2) (first out-a) (ctx-for "c" :cb)) + [_ ia] (handshake ia (first out-b) (ctx-for "c" :ca)) + [_ ia out-a] (handshake ia (second out-b) (ctx-for "c" :ca)) + [tb hb out-b] (handshake hb (first out-a) (ctx-for "c" :cb)) + [ta ia] (handshake ia (first out-b) (ctx-for "c" :ca))] + (and (= :Up ta) (= :Up tb) + (= [:b.vm 2] [(:peer ia) (:peer-creation ia)]) + (= [:a.vm 1] [(:peer hb) (:peer-creation hb)])))) + +(law a-wrong-cookie-is-refused-by-the-acceptor + (let [[_ ia out-a] (open-handshake :a.vm 1 :b.vm) + [_ hb out-b] (handshake (accept-handshake :b.vm 2) (first out-a) (ctx-for "d" :cb)) + [_ ia] (handshake ia (first out-b) (ctx-for "c" :ca)) + [_ _ out-a] (handshake ia (second out-b) (ctx-for "c" :ca))] + (= [:Fail :bad-cookie []] (handshake hb (first out-a) (ctx-for "d" :cb))))) + +(law the-acceptor-proves-itself-too + ;; the initiator checks the acceptor's answer to its challenge + (let [ctx {:up-creation (fn [_] nil) :pending? (fn [_] false) :fresh :ca :sign (sign-with "c")} + [_ ia _] (open-handshake :a.vm 1 :b.vm) + [_ ia] (handshake ia [:status :ok] ctx) + [_ ia] (handshake ia [:challenge :b.vm 2 :cb] ctx)] + (= [:Fail :bad-cookie []] (handshake ia [:ack [:signed "d" :ca]] ctx)))) + +(law a-refusing-status-ends-the-handshake + (let [ctx {:up-creation (fn [_] nil) :pending? (fn [_] false) :fresh :ca :sign (sign-with "c")} + [_ ia _] (open-handshake :a.vm 1 :b.vm)] + (and (= [:Fail [:refused :nok] []] (handshake ia [:status :nok] ctx)) + (= [:Fail [:refused :alive] []] (handshake ia [:status :alive] ctx))))) + +(law the-acceptor-answers-a-refused-name-and-stops + (let [ctx {:up-creation (fn [p] (when (= p :a.vm) 1)) :pending? (fn [_] false) :fresh :cb :sign (sign-with "c")}] + (and (= [:Fail [:refused :alive] [[:status :alive]]] + (handshake (accept-handshake :b.vm 2) [:name :a.vm 1] ctx)) + (= [:Fail [:refused :nok] [[:status :nok]]] + (handshake (accept-handshake :b.vm 2) [:name :b.vm 1] ctx))))) + +(law the-peer-must-be-the-node-asked-for + (let [ctx {:up-creation (fn [_] nil) :pending? (fn [_] false) :fresh :ca :sign (sign-with "c")} + [_ ia _] (open-handshake :a.vm 1 :b.vm) + [_ ia] (handshake ia [:status :ok] ctx)] + (= [:Fail [:wrong-node :c.vm] []] (handshake ia [:challenge :c.vm 2 :cb] ctx)))) + +(law a-frame-out-of-turn-ends-the-handshake + (let [ctx {:up-creation (fn [_] nil) :pending? (fn [_] false) :fresh :cb :sign (sign-with "c")}] + (and (= [:Fail [:unexpected [:send 1 :x]] []] + (handshake (accept-handshake :b.vm 2) [:send 1 :x] ctx)) + (= [:Fail [:unexpected [:ack :x]] []] + (handshake (second (open-handshake :a.vm 1 :b.vm)) [:ack :x] ctx))))) + +(law opening-sends-the-name-and-creation + (forall [self Keyword, cr Nat, peer Keyword] + (= [[:name self cr]] (nth (open-handshake self cr peer) 2)))) + +;; --- framing ---------------------------------------------------------------- + +(law a-header-is-four-bytes-big-endian + (and (= [0 0 0 0] (length-header 0)) + (= [0 0 1 0] (length-header 256)) + (= [1 2 3 4] (length-header 16909060)) + (= [255 255 255 255] (length-header 4294967295)))) + +(law a-header-reads-back + {:require :tested :because "bit shifts are outside what the prover models"} + ;; a length past four bytes' reach keeps only what fits + (forall [n Nat] (= (mod n 4294967296) (header-length (length-header n))))) + ;; --- node follows these decisions --------------------------------------- ;; every operation on a pid goes where route says; a frame's pids are what @@ -129,4 +265,5 @@ (calls node/monitor-remote {:through [dist/route]}) (calls node/demonitor-remote {:through [dist/route]}) (calls node/handle-frame {:through [dist/arrive]}) +(calls node/handshake-step! {:through [dist/handshake]}) (calls node/nodedown! {:through [dist/on-nodedown]}) diff --git a/test/ensemble/gen_event_test.clj b/test/ensemble/gen_event_test.clj index 0d09f1b..6adb9bc 100644 --- a/test/ensemble/gen_event_test.clj +++ b/test/ensemble/gen_event_test.clj @@ -164,3 +164,37 @@ (a/Sink (atom []))) + (ev/delete-handler! m :a) + (deliver mp m) + (receive [:never nil]))))] + (act/exit! (deref mp 1000 nil) :kill) + (is (= :killed (act/exit-reason owner 1000)) "the start-link link is kept"))) + +(deftest swapping-a-supervised-handler-tells-its-owner + (let [m (ev/start) + ready (promise) + owner (act/spawn (fn [] + (ev/add-sup-handler! m :a (->Infoed (atom []) :a)) + (deliver ready true) + (receive [[:gen-event-EXIT id reason] [id reason]] + [:after 1000 :nothing])))] + (deref ready 1000 nil) + (ev/swap-handler! m :a :bye :b (fn [_] (->Infoed (atom []) :b))) + (is (= [:a [:swapped :b nil]] (act/join owner 2000))))) + +(deftest swapping-to-the-same-owner-then-deleting-unlinks-it + (let [m (ev/start) + owner (act/spawn (fn [] + (ev/add-sup-handler! m :a (->Infoed (atom []) :a)) + (ev/swap-sup-handler! m :a :bye :b (fn [_] (->Infoed (atom []) :b))) + (ev/delete-handler! m :b) + (receive [:check (do (act/exit! m :kill) (receive [:never nil] [:after 100 nil]) :alive)])))] + (a/SlowInit 0)) a (act/spawn (fn [] (gs/wait-response (gs/send-request s :get) :infinity)))] (is (= [:reply :up] (act/join a 1000))))) + +;; --- names through a registry ({via, Module, Name}) ------------------------- + +(defrecord MapRegistry [names] + reg/Registry + (register-name [_ nm pid] + (let [[old _] (swap-vals! names (fn [m] (if (contains? m nm) m (assoc m nm pid))))] + (not (contains? old nm)))) + (unregister-name [_ nm] (swap! names dissoc nm) nil) + (whereis-name [_ nm] (get @names nm))) + +(deftest a-server-named-through-a-registry + (let [r (->MapRegistry (atom {})) + s (gs/start (->Counter nil) {:name [:via r :counter]})] + (is (= s (reg/whereis-name r :counter))) + (is (= 3 (gs/call! [:via r :counter] [:add 3]))) + (gs/cast! [:via r :counter] [:tick]) + (is (= 4 (gs/call! [:via r :counter] [:get]))) + (is (= [:already-started s] + (reason-of-failure #(gs/start (->Counter nil) {:name [:via r :counter]})))) + (gs/stop! [:via r :counter]) + (is (nil? (reg/whereis-name r :counter)) "the name goes when the server exits") + (is (= :noproc (reason-of-failure #(gs/call! [:via r :counter] [:get])))))) + +(deftest sending-to-a-registry-name + (let [r (->MapRegistry (atom {})) + a (act/spawn (fn [] (receive [m m])) {:name [:via r :box]})] + (act/! [:via r :box] :hello) + (is (= :hello (act/join a 1000))) + (is (thrown? Throwable (act/! [:via r :nobody] :x))))) + +;; --- enter-loop ----------------------------------------------------------------- + +(deftest enter-loop-makes-an-actor-a-server + (let [s (act/spawn (fn [] (gs/enter-loop (->Counter nil) {} 41)))] + (is (= 42 (gs/call! s [:add 1]))) + (gs/stop! s) + (is (= :normal (act/exit-reason s 1000))))) + +(deftest enter-loop-with-a-name-wants-it-registered + (let [s (act/spawn (fn [] (gs/enter-loop (->Counter nil) {:name ::not-mine} 0)))] + (is (= :process-not-registered (act/exit-reason s 1000)))) + (let [s (act/spawn (fn [] (act/register! ::mine (act/self)) + (gs/enter-loop (->Counter nil) {:name ::mine} 0)))] + (loop [i 0] (when (and (nil? (act/whereis ::mine)) (< i 100)) (sleep 5) (recur (inc i)))) + (is (= 0 (gs/call! ::mine [:get]))) + (gs/stop! s))) diff --git a/test/ensemble/gen_statem_test.clj b/test/ensemble/gen_statem_test.clj index e90d979..5c048f2 100644 --- a/test/ensemble/gen_statem_test.clj +++ b/test/ensemble/gen_statem_test.clj @@ -228,3 +228,161 @@ (is (eventually #(act/hibernating? m))) (is (= :here (gs/call! m :where))) (gs/stop! m))) + +;; --- state_functions mode --------------------------------------------------- + +(defrecord Light [] + sm/Machine + (init [_] [:ok :off 0]) + (terminate [_ _ _ _] nil) + sm/StateFunctions + (state-functions [_] + {:off (fn [type content n] + (case type + :cast [:next-state :on (inc n)] + [:keep-state-and-data [[:reply (second type) [:off n]]]])) + :on (fn [type content n] + (case type + :cast (if (= :break content) [:next-state :broken n] [:next-state :off n]) + [:keep-state-and-data [[:reply (second type) [:on n]]]]))})) + +(deftest state-functions-call-the-state-s-own-fn + (let [m (sm/start (->Light))] + (is (= [:off 0] (gs/call! m :q))) + (gs/cast! m :flip) + (is (= [:on 1] (gs/call! m :q))) + (gs/cast! m :flip) + (is (= [:off 1] (gs/call! m :q))) + (gs/stop! m))) + +(deftest a-state-with-no-fn-stops-the-machine + (let [m (sm/start (->Light))] + (gs/cast! m :flip) + (gs/cast! m :break) + (gs/cast! m :flip) + (is (= [:undefined-state-function :broken] (act/exit-reason m 1000))))) + +;; --- repeat_state ------------------------------------------------------------- + +(defrecord Repeater [log] + sm/Machine + (init [_] [:ok :s 0]) + (handle-event [_ type content state n] + (swap! log conj [type content]) + (cond + (= :enter type) [:keep-state-and-data] + (= [:cast :again] [type content]) [:repeat-state (inc n)] + (= [:cast :again-same] [type content]) [:repeat-state-and-data] + (= :cast type) [:keep-state-and-data [:postpone]] + :else [:keep-state-and-data [[:reply (second type) n]]])) + (terminate [_ _ _ _] nil)) + +(deftest repeat-state-runs-the-enter-call-again + (let [log (atom []) + m (sm/start (->Repeater log) {:state-enter true})] + (gs/cast! m :held) + (gs/cast! m :again) + (is (= 1 (gs/call! m :n))) + (gs/cast! m :again-same) + (gs/call! m :n) + (is (= [[:enter :s] [:cast :held] [:cast :again] [:enter :s] [:cast :again-same] [:enter :s]] + (filterv #(not= :call (first %)) (map (fn [[t c]] [(if (vector? t) (first t) t) c]) @log))) + "the enter call repeats, and the postponed event is not retried: the state did not change") + (gs/stop! m))) + +;; --- timeout cancel, update and abs ----------------------------------------- + +(defrecord Timers [log] + sm/Machine + (init [_] [:ok :s nil]) + (handle-event [_ type content _ _] + (swap! log conj [type content]) + (case content + :arm [:keep-state-and-data [[:generic-timeout :g 60 :first] [:state-timeout 60 :st]]] + :cancel [:keep-state-and-data [[:generic-timeout :g :cancel] [:state-timeout :cancel]]] + :update [:keep-state-and-data [[:generic-timeout :g :update :second]]] + :update-none [:keep-state-and-data [[:state-timeout :update :now]]] + :abs [:keep-state-and-data [[:generic-timeout :a (+ (act/now-ms) 40) :abs-fired {:abs true}]]] + [:keep-state-and-data])) + (terminate [_ _ _ _] nil)) + +(defn- fired + "The timeouts that fired, as [kind content]: a generic one's type is + [:generic-timeout name]." + [log] + (into [] (comp (map (fn [[t c]] [(if (vector? t) (first t) t) c])) + (filter #(contains? #{:state-timeout :generic-timeout} (first %)))) + @log)) + +(deftest a-cancel-stops-a-timer + (let [log (atom []) + m (sm/start (->Timers log))] + (gs/cast! m :arm) + (gs/cast! m :cancel) + (sleep 150) + (is (empty? (fired log))) + (gs/stop! m))) + +(deftest an-update-changes-the-content-but-not-the-deadline + (let [log (atom []) + m (sm/start (->Timers log)) + t0 (act/now-ms)] + (gs/cast! m :arm) + (sleep 30) + (gs/cast! m :update) + (is (eventually #(some #{[:generic-timeout :second]} (fired log)))) + (is (< (- (act/now-ms) t0) 85) "it fired at the first deadline, not 60ms after the update") + (gs/stop! m))) + +(deftest an-update-with-no-timer-fires-at-once + (let [log (atom []) + m (sm/start (->Timers log))] + (gs/cast! m :update-none) + (is (eventually #(some #{[:state-timeout :now]} (fired log)))) + (gs/stop! m))) + +(deftest an-abs-timeout-fires-at-its-deadline + (let [log (atom []) + m (sm/start (->Timers log))] + (gs/cast! m :abs) + (is (eventually #(some #{[:generic-timeout :abs-fired]} (fired log)))) + (gs/stop! m))) + +;; --- enter-loop --------------------------------------------------------------- + +(deftest enter-loop-makes-an-actor-a-machine + (let [m (act/spawn (fn [] (sm/enter-loop (->CodeLock [7] nil) {} :locked [])))] + (is (= :locked (gs/call! m :state?))) + (gs/cast! m 7) + (is (= :open (gs/call! m :state?))) + (gs/stop! m) + (is (= :normal (act/exit-reason m 1000))))) + +;; --- enter calls: repeat_state and the transition's event timeout ------------ + +(defrecord EnterRepeat [log] + sm/Machine + (init [_] [:ok :a nil]) + (handle-event [_ type content state _] + (swap! log conj [type state]) + (cond + (= :enter type) [:repeat-state-and-data] + (= :cast type) [:next-state content nil [[:timeout 30 :quiet]]] + (= :timeout type) [:keep-state-and-data] + :else [:keep-state-and-data [[:reply (second type) state]]])) + (terminate [_ _ _ _] nil)) + +(deftest an-enter-call-that-repeats-keeps-the-state + (let [log (atom []) + m (sm/start (->EnterRepeat log) {:state-enter true})] + (is (= :a (gs/call! m :state 1000)) "the machine survives its enter call") + (is (= 1 (count (filter #(= :enter (first %)) @log))) "the enter call runs once") + (gs/stop! m))) + +(deftest an-enter-call-keeps-the-transitions-event-timeout + (let [log (atom []) + m (sm/start (->EnterRepeat log) {:state-enter true})] + (gs/cast! m :b) + (sleep 150) + (is (some #{[:timeout :b]} @log) "the event timeout set with the transition fires") + (gs/stop! m))) diff --git a/test/ensemble/logger_test.clj b/test/ensemble/logger_test.clj index b595bd6..c70f708 100644 --- a/test/ensemble/logger_test.clj +++ b/test/ensemble/logger_test.clj @@ -122,3 +122,15 @@ (let [a (act/spawn (fn [] (throw (ex-info "crash" {}))))] (is (instance? Throwable (act/exit-reason a 1000)))) (finally (log/set-handler! old))))) + +(defn- stubborn [_] + ;; ignores :shutdown, so it is killed when its shutdown time is up + (act/spawn-link (fn [] (act/trap-exit! true) (receive [:never nil])))) + +(deftest a-simple-one-for-one-supervisor-reports-a-child-it-had-to-kill + (capturing rs + (let [s (sup/start {:strategy :simple-one-for-one} [{:id :tpl :start stubborn :shutdown 50}])] + (sup/start-child! s [1]) + (sup/stop! s) + (is (eventually #(some (fn [r] (= :shutdown-error (:context r))) (of-kind rs :supervisor-report)))) + (is (= :killed (:reason (first (filter #(= :shutdown-error (:context %)) (of-kind rs :supervisor-report))))))))) diff --git a/test/ensemble/match_spec.clj b/test/ensemble/match_spec.clj index 43d1f61..53b8edb 100644 --- a/test/ensemble/match_spec.clj +++ b/test/ensemble/match_spec.clj @@ -10,7 +10,9 @@ Nil (Lit Any) (Bind Symbol) - (Cons Pattern Pattern)) + (Cons Pattern Pattern) + IsMap + (Has Any Pattern Pattern)) (ann capture [Pattern Any -> Any]) @@ -20,19 +22,22 @@ (refine BindP [p Pattern] (= :Bind (first p))) (refine LitP [p Pattern] (= :Lit (first p))) (refine TupleP [p Pattern] (contains? #{:Nil :Cons} (first p))) +(refine MapP [p Pattern] (contains? #{:IsMap :Has} (first p))) (refine Matched [b Any] (map? b)) (refine Outcome [b Any] (or (nil? b) (map? b))) ;; a wildcard or a binder takes any message; a literal or a tuple may also ;; refuse it, with nil -- which ones match is pinned by the laws below (graph capture - {:states {:wild WildP, :bind BindP, :lit LitP, :tuple TupleP, + {:states {:wild WildP, :bind BindP, :lit LitP, :tuple TupleP, :map MapP, :matched Matched, :outcome Outcome} :edges {:wild {[capture Any] #{:matched}} :bind {[capture Any] #{:matched}} :lit {[capture Any] #{:outcome}} - :tuple {[capture Any] #{:outcome}}} - :tested {:tuple "capture recurses over a Pattern of any depth, a recursive data type the prover does not unfold"}}) + :tuple {[capture Any] #{:outcome}} + :map {[capture Any] #{:outcome}}} + :tested {:tuple "capture recurses over a Pattern of any depth, a recursive data type the prover does not unfold" + :map "capture recurses over a Pattern of any depth, a recursive data type the prover does not unfold"}}) (def two-tuple [:Cons [:Wild] [:Nil]]) (def bind-pair [:Cons [:Bind 'l] [:Cons [:Bind 'r] [:Nil]]]) @@ -107,3 +112,64 @@ (law a-nan-in-a-tuple-matches-a-nan-there (= {} (capture [:Cons [:Lit 1] [:Cons [:Lit ##NaN] [:Nil]]] [1 ##NaN]))) + +;; --- list tails ------------------------------------------------------------ +;; [x & r] compiles to a Cons whose tail is a pattern itself, not Nil: the +;; tail matches whatever is left of the message, as Erlang's [H|T] + +(def head-tail [:Cons [:Bind 'h] [:Bind 't]]) + +(law a-tail-takes-the-rest + (forall [a Any, b Any, c Any] + (= (capture head-tail [a b c]) {'h a 't [b c]}))) + +(law a-tail-may-be-empty + (forall [a Any] (= (capture head-tail [a]) {'h a 't []}))) + +(law a-tail-needs-a-head + (and (nil? (capture head-tail [])) (nil? (capture head-tail 7)))) + +(law a-tail-can-be-a-tuple + (forall [a Any, b Any] + (and (= {} (capture [:Cons [:Lit a] [:Nil]] [a])) + (= {'h a} (capture [:Cons [:Bind 'h] [:Cons [:Lit b] [:Nil]]] [a b]))))) + +;; --- maps ---------------------------------------------------------------- +;; {:k p} compiles to [:Has :k p [:IsMap]]: the message must be a map +;; holding every key named, each value matching its pattern. Keys not named +;; are allowed, as in Erlang's #{k := V}. + +(law ismap-matches-any-map + (forall [m (Map Keyword Int)] (= {} (capture [:IsMap] m)))) + +(law ismap-rejects-a-non-map + (and (nil? (capture [:IsMap] [1 2])) (nil? (capture [:IsMap] nil)) (nil? (capture [:IsMap] 3)))) + +(def has-k [:Has :k [:Bind 'v] [:IsMap]]) + +(law has-binds-the-value + (forall [n Int, x Int] (= {'v n} (capture has-k {:k n :other x})))) + +(law has-needs-the-key + (forall [n Int] (nil? (capture has-k {:j n})))) + +(law has-takes-a-nil-value-that-is-there + (= {'v nil} (capture has-k {:k nil}))) + +(law has-value-must-match + (forall [n Int] + (and (= {} (capture [:Has :k [:Lit n] [:IsMap]] {:k n})) + (nil? (capture [:Has :k [:Lit n] [:IsMap]] {:k (inc n)}))))) + +(law has-chains + (forall [a Int, b Int] + (= {'x a 'y b} + (capture [:Has :a [:Bind 'x] [:Has :b [:Bind 'y] [:IsMap]]] {:a a :b b})))) + +(law has-agrees-on-a-repeated-name + (forall [a Int] + (and (= {'x a} (capture [:Has :a [:Bind 'x] [:Has :b [:Bind 'x] [:IsMap]]] {:a a :b a})) + (nil? (capture [:Has :a [:Bind 'x] [:Has :b [:Bind 'x] [:IsMap]]] {:a a :b (inc a)}))))) + +(law has-rejects-a-non-map + (forall [n Int] (nil? (capture has-k [:k n])))) diff --git a/test/ensemble/node_test.clj b/test/ensemble/node_test.clj index ef942d8..ae6c506 100644 --- a/test/ensemble/node_test.clj +++ b/test/ensemble/node_test.clj @@ -5,7 +5,9 @@ [clojure.test :refer [deftest is testing]] [ensemble.actor :as act :refer [receive]] [ensemble.gen-server :as gs] - [ensemble.node :as node])) + [ensemble.node :as node] + [ensemble.sys :as sys] + [ensemble.transport :as tr])) (defn- sleep [ms] (a/RemotePid b 999999)) + (act/link! (node/->RemotePid b 999999 (node/creation b))) (deliver got (receive [[:EXIT _ reason] reason] [:after 2000 :timeout]))))) (is (= :noproc (deref got 3000 nil))))) @@ -161,3 +163,177 @@ (is (= [:not-allowed `echo] (try (node/with-node b (node/spawn-on a `echo [])) (catch Throwable e (:reason (ex-data e)))))) (is (act/pid? (node/with-node a (node/spawn-on b `idle [])))))) + +;; --- multi_call and abcast ------------------------------------------------------ + +(defrecord Named [] + gs/Server + (init [_] [:ok nil]) + (handle-call [_ req _ st] [:reply [(act/node) req] st]) + (handle-cast [_ req _] [:noreply req]) + (handle-info [_ _ st] [:noreply st]) + (handle-timeout [_ st] [:noreply st]) + (handle-continue [_ _ st] [:noreply st]) + (terminate [_ _ _] nil)) + +(deftest multi-call-asks-the-name-on-each-node + (let [[a b] (two-nodes) + c (keyword (str (gensym "c") ".vm"))] + (node/with-node a (gs/start (->Named) {:name :svc})) + (node/with-node b (gs/start (->Named) {:name :svc})) + (let [[replies bad] (node/with-node a (gs/multi-call [a b c] :svc :q 2000))] + (is (= #{[a [a :q]] [b [b :q]]} (set replies))) + (is (= [c] bad) "a node that cannot be reached is bad")) + (is (= #{a b} (set (map first (first (node/with-node a (gs/multi-call :svc :q)))))) "by default, this node and its peers"))) + +(deftest abcast-casts-the-name-on-each-node + (let [[a b] (two-nodes) + sa (node/with-node a (gs/start (->Named) {:name :svc})) + sb (node/with-node b (gs/start (->Named) {:name :svc}))] + (is (= :abcast (node/with-node a (gs/abcast [a b] :svc :hello)))) + (is (eventually #(= :hello (node/with-node a (sys/get-state sa))))) + (is (eventually #(= :hello (node/with-node b (sys/get-state sb))))))) + +;; --- the handshake, framing and creation --------------------------------------- + +(defn- fresh-node [& [opts transport]] + (let [n (keyword (str (gensym "n") ".vm"))] + (node/start! n (or transport (node/loopback)) (merge {:spawn #{'ensemble.node-test}} opts)) + n)) + +(deftest a-peer-with-the-wrong-cookie-cannot-connect + (let [a (fresh-node {:cookie "one"}) + b (fresh-node {:cookie "two"})] + (is (false? (node/with-node a (node/connect! b)))) + (is (= [] (node/with-node a (node/connected)))) + (is (= [] (node/with-node b (node/connected)))) + (is (= :noconnection + (try (node/with-node a (node/spawn-on b `idle [])) (catch Throwable e (:reason (ex-data e))))) + "an unauthenticated peer cannot spawn"))) + +(deftest the-same-cookie-connects + (let [a (fresh-node {:cookie "shared"}) + b (fresh-node {:cookie "shared"})] + (is (true? (node/with-node a (node/connect! b)))) + (is (= [b] (node/with-node a (node/connected)))) + (is (eventually #(= [a] (node/with-node b (node/connected))))))) + +(deftest frames-survive-a-stream-split-anywhere + (let [a (fresh-node {} (node/loopback {:chunk 3})) + b (fresh-node {} (node/loopback {:chunk 3})) + e (node/with-node a (node/spawn-on b `echo []))] + (is (= [:echo (apply str (repeat 500 "x"))] (ask a e (apply str (repeat 500 "x"))))) + (is (= [:echo {:k [1 2 {:z #{3}}]}] (ask a e {:k [1 2 {:z #{3}}]}))))) + +(deftest a-pid-of-an-earlier-run-names-no-process + (let [[a b] (two-nodes) + e (node/with-node a (node/spawn-on b `echo [])) + stale (node/->RemotePid b (:id e) (inc (node/creation b)))] + (is (= :timeout (ask a stale :hi)) "the id is in use, but not by that run") + (is (= [:echo :hi] (ask a e :hi))))) + +(deftest two-nodes-connecting-at-once-share-one-connection + (dotimes [_ 5] + (let [a (fresh-node) + b (fresh-node) + ra (future (node/with-node a (node/connect! b))) + rb (future (node/with-node b (node/connect! a)))] + (is (true? @ra)) + (is (true? @rb)) + (is (= [b] (node/with-node a (node/connected)))) + (is (= [a] (node/with-node b (node/connected))))))) + +(deftest a-stopped-node-goes-down-for-its-peers + (let [[a b] (two-nodes) + got (promise)] + (node/with-node a + (act/spawn (fn [] (node/monitor-node! b) + (deliver got (receive [m m] [:after 2000 :timeout]))))) + (sleep 20) + (node/stop! b) + (is (= [:nodedown b] (deref got 3000 nil))) + (is (false? (node/with-node a (node/connect! b)))))) + +(deftest refs-carry-their-nodes-creation + (let [a (fresh-node)] + (is (= (node/creation a) (:ensemble.actor/creation (node/with-node a (act/make-ref))))))) + +;; --- the envelope: protocol fields apart from the data --------------------------- + +(defrecord NotWire [x]) + +(deftest data-shaped-like-the-wire-format-arrives-as-sent + (let [[a b] (two-nodes) + e (node/with-node a (node/spawn-on b `echo []))] + (doseq [v [[:Pid b 1 2] [:Local 5] [:ensemble.node/pid :x 1 2] [:ensemble.node/q 1] + {:ensemble.node/exception "x"} '(:Pid :x 1 2) #{[:Local 1]}]] + (is (= [:echo v] (ask a e v)) (pr-str v))))) + +(deftest a-throwable-crosses-as-an-ex-info + (let [[a b] (two-nodes) + e (node/with-node a (node/spawn-on b `echo [])) + [_ ex] (ask a e (ex-info "boom" {:k 1}))] + (is (= "boom" (ex-message ex))) + (is (= {:k 1} (ex-data ex))))) + +(deftest data-the-wire-cannot-carry-fails-at-the-sender + (let [[a b] (two-nodes) + e (node/with-node a (node/spawn-on b `echo []))] + (is (thrown? Throwable (node/with-node a (act/! e [:me (->NotWire 1)])))) + (is (thrown? Throwable (node/with-node a (act/! e [:me (atom 1)])))) + (is (= [:echo :still-up] (ask a e :still-up)) "the connection is unharmed"))) + +(deftest a-malformed-frame-drops-the-connection + (let [[a b] (two-nodes) + conn (get-in @@#'node/nodes [b :conns a :conn])] + (#'node/write-frame! b conn [:not-an-op]) + (is (eventually #(= [] (node/with-node a (node/connected)))) "the receiver drops the peer") + (is (eventually #(= [] (node/with-node b (node/connected)))) "and the peer sees it go"))) + +(deftest a-bad-spawn-is-refused-and-the-connection-survives + (let [[a b] (two-nodes)] + (is (= [:not-allowed 'echo] + (try (node/with-node a (node/spawn-on b 'echo [])) (catch Throwable e (:reason (ex-data e)))))) + (is (= [:undefined `no-such-fn] + (try (node/with-node a (node/spawn-on b `no-such-fn [] {:timeout 2000})) + (catch Throwable e (:reason (ex-data e)))))) + (let [e (node/with-node a (node/spawn-on b `echo []))] + (is (= [:echo :ok] (ask a e :ok)))))) + +(deftest monitors-a-peer-held-go-with-it + (let [[a b] (two-nodes) + target (node/with-node b (act/spawn idle))] + ;; as a sees it: a process of b, so the monitor crosses + (let [remote (node/->RemotePid b (:ensemble.actor/pid target) (node/creation b))] + (node/with-node a (act/spawn (fn [] (act/monitor! remote) (receive [:never nil]))))) + (is (eventually #(seq @(:ensemble.actor/monitors target)))) + (node/with-node a (node/disconnect! b)) + (is (eventually #(empty? @(:ensemble.actor/monitors target))) + "the monitor the lost peer asked for is dropped"))) + +(deftest a-restarted-peer-is-taken-in-place-of-its-old-run + (let [[a b] (two-nodes) + seen (atom []) + w (node/with-node a (act/spawn (fn [] (node/monitor-nodes! true) + (loop [] (receive [m (do (swap! seen conj m) (recur))])))))] + (sleep 20) + ;; b starts again without its old connection closing + (node/start! b (node/loopback) {:spawn #{'ensemble.node-test}}) + (is (true? (node/with-node b (node/connect! a))) "the new run connects") + (is (eventually #(= [[:nodedown b] [:nodeup b]] @seen)) "the old run goes down first") + (act/exit! w :kill))) + +(deftest an-oversized-frame-drops-the-connection + (let [a (fresh-node {:max-frame 1000}) + b (fresh-node) + _ (node/with-node b (node/connect! a)) + e (node/with-node b (node/spawn-on a `echo []))] + (node/with-node b (act/! e [:x (apply str (repeat 5000 "x"))])) + (is (eventually #(= [] (node/with-node a (node/connected))))))) + +(deftest a-connection-that-never-shakes-hands-is-closed + (let [a (fresh-node {:handshake-timeout 100}) + closed (promise) + c (tr/-connect (node/loopback) :someone a)] + (tr/-start c (fn [_] nil) (fn [] (deliver closed true))) + (is (true? (deref closed 2000 false))))) diff --git a/test/ensemble/pattern_spec.clj b/test/ensemble/pattern_spec.clj index 88ae162..d6ffe73 100644 --- a/test/ensemble/pattern_spec.clj +++ b/test/ensemble/pattern_spec.clj @@ -4,8 +4,9 @@ the symbols it binds, in source order. A pattern form is one of _ (wildcard), a symbol (binds the whole message), a - non-vector literal (matches itself), or a vector (a tuple, matched - element-wise and right-nested). A symbol already bound where the receive + vector (a tuple, matched element-wise and right-nested, with & naming a + pattern for the rest), a map (a map holding the keys named, each value + matching its pattern) or any other value, a literal that matches itself. A symbol already bound where the receive is written -- one of the pinned names -- is not a binder: it compiles to [:Pin sym], which matches the local's value, as Erlang's receive does." (:require [writ.spec :refer [spec data ann refine graph law calls]] @@ -19,13 +20,18 @@ (Lit Any) (Bind Symbol) (Pin Symbol) - (Cons Pattern Pattern)) + (Cons Pattern Pattern) + IsMap + (Has Any Pattern Pattern)) (ann compile-form [Any (Set Symbol) -> Pattern]) -(ann compile-tuple [(List Any) (Set Symbol) -> Pattern]) (ann compile-atom [Any (Set Symbol) -> Pattern]) +(ann pattern-error [Any (Set Symbol) -> (Opt String)]) (ann atom-binder [Any (Set Symbol) -> (List Symbol)]) -(ann tuple-binders [(List Any) (Set Symbol) -> (List Symbol)]) +(ann steps [Any -> Int]) +(ann binders-in [Int Any (Set Symbol) -> (List Symbol)]) +(ann compile-in [Int Any (Set Symbol) -> Pattern]) +(ann error-in [Int Any (Set Symbol) Bool -> (Opt String)]) (ann bound-syms [Any (Set Symbol) -> (List Symbol)]) ;; --- the state graph ---------------------------------------------------- @@ -33,8 +39,8 @@ ;; the forms a pattern is written as; _ is a single value, pinned by ;; wildcard-is-wild below rather than generated (refine Name [s Symbol] (not= s '_)) -(refine Literal [f Any] (not (or (symbol? f) (vector? f)))) -(refine Binder [f (Vec Symbol)] (boolean (some #(not= '_ %) f))) +(refine Literal [f Any] (not (or (symbol? f) (vector? f) (map? f)))) +(refine Binder [f (Vec Symbol)] (boolean (and (some #(not= '_ %) f) (not-any? #{'&} f)))) ;; what each compiles to (refine BindP [p Pattern] (= :Bind (first p))) @@ -57,6 +63,7 @@ :tuple-form {[compile-form 'none] #{:tuple}} :binder {[compile-form 'none] #{:tuple}, [bound-syms 'none] #{:names}}} :tested {:tuple-form "a tuple form of unknown length needs induction" + [:literal compile-form] "the prover does not carry the refinement's (not (map? f)) into compile-form's test" :binder "a tuple form of unknown length needs induction"}}) ;; --- compile-form: atoms ------------------------------------------------- @@ -104,16 +111,64 @@ (law literal-element (= (compile-form '[1 2] #{}) [:Cons [:Lit 1] [:Cons [:Lit 2] [:Nil]]])) -;; only a vector is a tuple: any other collection is a literal, kept as written, -;; so it matches a message equal to it -(law map-is-literal - (forall [k Keyword, n Int] (= (compile-form {k n} #{}) [:Lit {k n}]))) - +;; a list or a set is a literal, kept as written, so it matches a message +;; equal to it (law list-is-literal (= (compile-form '(a b) #{}) [:Lit '(a b)])) (law literal-inside-tuple-is-kept - (= (compile-form '[x {:k v} (f y)] #{}) - [:Cons [:Bind 'x] [:Cons [:Lit '{:k v}] [:Cons [:Lit '(f y)] [:Nil]]]])) + (= (compile-form '[x (f y)] #{}) + [:Cons [:Bind 'x] [:Cons [:Lit '(f y)] [:Nil]]])) + +;; --- list tails ------------------------------------------------------------- + +(law a-tail-after-amp + (= (compile-form '[h & t] #{}) [:Cons [:Bind 'h] [:Bind 't]])) + +(law a-tail-after-several + (= (compile-form '[:a b & _] #{}) [:Cons [:Lit :a] [:Cons [:Bind 'b] [:Wild]]])) + +(law a-tail-can-be-a-tuple + (= (compile-form '[h & [x]] #{}) [:Cons [:Bind 'h] [:Cons [:Bind 'x] [:Nil]]])) + +(law a-tail-binds-in-order (= (vec (bound-syms '[h & t] #{})) '[h t])) + +;; a & with nothing before it, or not one pattern after it, is not a pattern +(law a-good-tail-is-no-error (nil? (pattern-error '[h & [x y]] #{}))) +(def no-head "& in a pattern needs an element before it") +(def not-one-tail "& in a pattern takes exactly one pattern after it") + +(law amp-first-is-an-error (= no-head (pattern-error '[& t] #{}))) +(law amp-last-is-an-error (= not-one-tail (pattern-error '[h &] #{}))) +(law amp-with-two-after-is-an-error (= not-one-tail (pattern-error '[h & t u] #{}))) +(law a-nested-bad-tail-is-an-error (= no-head (pattern-error '[:x [& t]] #{}))) +(law a-bad-tail-in-a-map-is-an-error (= no-head (pattern-error '{:k [& t]} #{}))) + +;; --- maps -------------------------------------------------------------------- + +(law empty-map-is-any-map (= (compile-form {} #{}) [:IsMap])) + +(law a-map-names-a-key + (= (compile-form '{:k v} #{}) [:Has :k [:Bind 'v] [:IsMap]])) + +(law a-map-chains-its-entries + (= (compile-form '{:a x :b y} #{}) + [:Has :a [:Bind 'x] [:Has :b [:Bind 'y] [:IsMap]]])) + +;; a bound name as a key is kept as the name: the receive macro puts in its value +(law a-map-key-may-be-pinned + (= (compile-form '{k v} '#{k}) [:Has 'k [:Bind 'v] [:IsMap]])) + +(law a-map-value-nests + (= (compile-form '{:r [:ok x]} #{}) + [:Has :r [:Cons [:Lit :ok] [:Cons [:Bind 'x] [:Nil]]] [:IsMap]])) + +(law a-map-inside-a-tuple + (= (compile-form '[:m {:k v}] #{}) + [:Cons [:Lit :m] [:Cons [:Has :k [:Bind 'v] [:IsMap]] [:Nil]]])) + +(law a-map-binds-its-values (= (set (bound-syms '{:a x :b [y z]} #{})) '#{x y z})) + +(law a-map-key-does-not-bind (= (vec (bound-syms '{k 1} '#{k})) [])) ;; --- bound-syms ---------------------------------------------------------- @@ -152,6 +207,14 @@ (law a-repeated-binder-is-named-once (= (vec (bound-syms '[a a b] #{})) '[a b])) +(law an-unbound-key-is-an-error + (= "a map pattern's key must be a value or a bound name, not k" (pattern-error '{k v} #{}))) +(law a-bound-key-is-no-error (nil? (pattern-error '{k v} '#{k}))) +(law a-literal-key-is-no-error (nil? (pattern-error '{:k v "s" [a & b]} #{}))) +(law an-atom-is-no-error + (forall [x Any] (=> (not (or (vector? x) (map? x))) (nil? (pattern-error x #{}))))) + ;; --- the receive macro compiles its patterns here ------------------------ -(calls ensemble.actor/receive {:through [ensemble.pattern/compile-form ensemble.pattern/bound-syms]}) +(calls ensemble.actor/receive {:through [ensemble.pattern/pattern-error ensemble.pattern/compile-form + ensemble.pattern/bound-syms]}) diff --git a/test/ensemble/select_spec.clj b/test/ensemble/select_spec.clj index 86ac1f7..3c6be2c 100644 --- a/test/ensemble/select_spec.clj +++ b/test/ensemble/select_spec.clj @@ -14,7 +14,7 @@ (spec ensemble.select {:require :proved :test {:trials 500}}) -(data Pattern Wild Nil (Lit Any) (Bind Symbol) (Cons Pattern Pattern)) +(data Pattern Wild Nil (Lit Any) (Bind Symbol) (Cons Pattern Pattern) IsMap (Has Any Pattern Pattern)) (data Hit (Hit Nat (Map Symbol Any)) (Miss)) (data Scan (Take Nat Nat (Map Symbol Any)) (None Nat)) diff --git a/test/ensemble/services_test.clj b/test/ensemble/services_test.clj new file mode 100644 index 0000000..99e837a --- /dev/null +++ b/test/ensemble/services_test.clj @@ -0,0 +1,270 @@ +(ns ensemble.services-test + "The distribution services, over loopback nodes: monitor-nodes, rpc, + global and pg." + (:require [clojure.core.async :as a] + [clojure.test :refer [deftest is testing]] + [ensemble.actor :as act :refer [receive]] + [ensemble.gen-server :as gs] + [ensemble.global :as global] + [ensemble.node :as node] + [ensemble.pg :as pg] + [ensemble.process :as proc] + [ensemble.rpc :as rpc])) + +(defn- sleep [ms] (a/ i 300) false :else (do (sleep 10) (recur (inc i)))))) + +(defn- fresh-node [] + (let [n (keyword (str (gensym "s") ".vm"))] + (node/start! n (node/loopback) {:spawn #{'ensemble.services-test}}) + n)) + +(defn- nodes + "k fresh nodes, all connected." + [k] + (let [ns (vec (repeatedly k fresh-node))] + (doseq [x ns, y ns :when (not= x y)] (node/with-node x (node/connect! y))) + ns)) + +(defn- on + "Run f in a fresh actor of node n and return what it returns." + [n f] + (let [p (promise)] + (node/with-node n (act/spawn (fn [] (deliver p (try [:ok (f)] (catch Throwable e [:err e])))))) + (let [[k v] (deref p 5000 [:err (ex-info "no answer" {})])] (if (= :ok k) v (throw v))))) + +(defn idle [] (receive [:stop :ok])) +(defn add [a b] (+ a b)) +(defn boom [] (throw (ex-info "rpc boom" {:x 1}))) +(defn slow [ms] (sleep ms) :slow) +(defn where [] (act/node)) +(defn tell [nm msg] (act/! nm msg)) + +;; --- monitor-nodes --------------------------------------------------------------- + +(deftest monitor-nodes-sees-each-node-come-and-go + (let [a (fresh-node) b (fresh-node) + got (atom []) + w (node/with-node a (act/spawn (fn [] (node/monitor-nodes! true) + (loop [] (swap! got conj (receive [m m])) (recur)))))] + (sleep 20) + (node/with-node a (node/connect! b)) + (is (eventually #(= [[:nodeup b]] @got))) + (node/with-node a (node/disconnect! b)) + (is (eventually #(= [[:nodeup b] [:nodedown b]] @got)) (pr-str @got)) + (act/exit! w :kill))) + +(deftest act-nodes-lists-the-connected-nodes + (let [[a b c] (nodes 3)] + (is (= #{b c} (set (node/with-node a (act/nodes))))))) + +;; --- is_process_alive on a remote pid ----------------------------------------------- + +(deftest alive-on-a-remote-pid-is-a-badarg + (let [[a b] (nodes 2) + p (node/with-node a (node/spawn-on b `idle []))] + (is (= :badarg (try (act/alive? p) (catch Throwable e (:reason (ex-data e)))))))) + +;; --- rpc ---------------------------------------------------------------------- + +(deftest rpc-call-runs-a-fn-on-another-node + (let [[a b] (nodes 2)] + (is (= 5 (node/with-node a (rpc/call b `add [2 3])))) + (is (= 5 (on a #(rpc/call b `add [2 3]))) "from an actor too") + (is (= b (node/with-node a (rpc/call b `where []))) "it ran there"))) + +(deftest rpc-call-rethrows-what-the-fn-threw + (let [[a b] (nodes 2) + r (try (node/with-node a (rpc/call b `boom [])) (catch Throwable e (ex-data e)))] + (is (= :exception (first (:reason r)))) + (is (= "rpc boom" (ex-message (get-in r [:reason 1]))) "the throwable crosses as an ex-info"))) + +(deftest rpc-call-times-out + (let [[a b] (nodes 2)] + (is (= :timeout (try (node/with-node a (rpc/call b `slow [500] 50)) + (catch Throwable e (:reason (ex-data e)))))))) + +(deftest rpc-call-to-a-node-out-of-reach-is-noconnection + (let [a (fresh-node)] + (is (= :noconnection (try (node/with-node a (rpc/call :nowhere.vm `add [1 2])) + (catch Throwable e (:reason (ex-data e)))))))) + +(deftest rpc-runs-only-what-the-node-allows + (let [[a b] (nodes 2)] + (is (= [:not-allowed `slurp] + (try (node/with-node a (rpc/call b `slurp ["/etc/passwd"])) + (catch Throwable e (:reason (ex-data e)))))))) + +(deftest rpc-multicall-asks-every-node + (let [[a b c] (nodes 3)] + (is (= [[:ok 3] [:ok 3] [:error :noconnection]] + (node/with-node a (rpc/multicall [b c :nowhere.vm] `add [1 2])))))) + +(deftest rpc-cast-runs-without-an-answer + (let [[a b] (nodes 2) + box (node/with-node b (act/spawn (fn [] (receive [m m])) {:name :box}))] + (is (= true (node/with-node a (rpc/cast b `tell [:box :hi])))) + (is (= :hi (act/join box 2000))))) + +;; --- global --------------------------------------------------------------------- + +(deftest a-global-name-is-seen-on-every-node + (let [[a b c] (nodes 3) + p (node/with-node a (act/spawn idle))] + (is (= :yes (node/with-node a (global/register-name :svc p)))) + (is (eventually #(= (id p) (id (node/with-node c (global/whereis-name :svc)))))) + (is (= :no (node/with-node b (global/register-name :svc (node/with-node b (act/spawn idle))))) + "a name taken anywhere is taken") + (is (some #{:svc} (node/with-node b (global/registered-names)))) + (node/with-node a (global/unregister-name :svc)) + (is (eventually #(nil? (node/with-node c (global/whereis-name :svc))))))) + +(deftest a-global-name-goes-with-its-process + (let [[a b] (nodes 2) + p (node/with-node a (act/spawn idle))] + (node/with-node a (global/register-name :temp p)) + (is (eventually #(= (id p) (id (node/with-node b (global/whereis-name :temp)))))) + (act/! p :stop) + (is (eventually #(nil? (node/with-node b (global/whereis-name :temp))))))) + +(deftest a-global-name-goes-with-its-node + (let [[a b] (nodes 2) + p (node/with-node a (act/spawn idle))] + (node/with-node a (global/register-name :far p)) + (is (eventually #(= (id p) (id (node/with-node b (global/whereis-name :far)))))) + (node/with-node b (node/disconnect! a)) + (is (eventually #(nil? (node/with-node b (global/whereis-name :far))))))) + +(deftest global-names-merge-when-nodes-connect + (let [a (fresh-node) b (fresh-node) + pa (node/with-node a (act/spawn idle)) + pb (node/with-node b (act/spawn idle)) + qa (node/with-node a (act/spawn idle)) + qb (node/with-node b (act/spawn idle))] + (node/with-node a (global/register-name :only-a pa)) + (node/with-node b (global/register-name :only-b pb)) + (node/with-node a (global/register-name :both qa)) + (node/with-node b (global/register-name :both qb)) + (node/with-node a (node/connect! b)) + (is (eventually #(= (id pb) (id (node/with-node a (global/whereis-name :only-b)))))) + (is (eventually #(= (id pa) (id (node/with-node b (global/whereis-name :only-a)))))) + (testing "a clash keeps one of the two, the same on both nodes, and the other process is killed" + (is (eventually #(let [x (id (node/with-node a (global/whereis-name :both))) + y (id (node/with-node b (global/whereis-name :both)))] + (and x (= x y))))) + (let [kept (id (node/with-node a (global/whereis-name :both))) + lost (if (= kept (id qa)) qb qa)] + (is (= :killed (act/exit-reason lost 2000))))))) + +(defrecord Echo [] + gs/Server + (init [_] [:ok nil]) + (handle-call [_ req _ st] [:reply [(act/node) req] st]) + (handle-cast [_ _ st] [:noreply st]) + (handle-info [_ _ st] [:noreply st]) + (handle-timeout [_ st] [:noreply st]) + (handle-continue [_ _ st] [:noreply st]) + (terminate [_ _ _] nil)) + +(deftest a-gen-server-with-a-global-name + (let [[a b] (nodes 2)] + (node/with-node a (gs/start (->Echo) {:name [:global :echo]})) + (is (eventually #(node/with-node b (global/whereis-name :echo)))) + (is (= [a :hi] (node/with-node b (gs/call! [:global :echo] :hi)))) + (let [r (try (node/with-node b (gs/start (->Echo) {:name [:global :echo]})) + (catch Throwable e (:reason (ex-data e))))] + (is (= :already-started (first r))) + (is (= (id (node/with-node a (global/whereis-name :echo))) (id (second r))))) + (node/with-node b (global/send :echo [:not-a-call])))) + +(deftest concurrent-global-registrations-pick-one + (let [[a b c] (nodes 3) + ps (mapv #(node/with-node % (act/spawn idle)) [a b c]) + rs (mapv (fn [n p] (future (node/with-node n (global/register-name :race p)))) [a b c] ps) + answers (mapv deref rs)] + (is (= 1 (count (filter #{:yes} answers))) (pr-str answers)) + (let [winner (nth ps (.indexOf answers :yes))] + (is (eventually #(every? (fn [n] (= (id winner) (id (node/with-node n (global/whereis-name :race))))) [a b c])))))) + +;; --- pg ------------------------------------------------------------------------- + +(deftest pg-groups-span-nodes + (let [[a b] (nodes 2) + pa (node/with-node a (act/spawn idle)) + pb (node/with-node b (act/spawn idle))] + (node/with-node a (pg/join :workers pa)) + (node/with-node b (pg/join :workers pb)) + (is (eventually #(= (ids [pa pb]) (ids (node/with-node a (pg/get-members :workers)))))) + (is (eventually #(= (ids [pa pb]) (ids (node/with-node b (pg/get-members :workers)))))) + (is (= [pa] (node/with-node a (pg/get-local-members :workers)))) + (is (some #{:workers} (node/with-node b (pg/which-groups)))) + (node/with-node a (pg/leave :workers pa)) + (is (eventually #(= (ids [pb]) (ids (node/with-node b (pg/get-members :workers)))))))) + +(deftest a-process-leaves-its-groups-when-it-exits + (let [[a b] (nodes 2) + p (node/with-node a (act/spawn idle))] + (node/with-node a (pg/join :g p)) + (is (eventually #(= (ids [p]) (ids (node/with-node b (pg/get-members :g)))))) + (act/! p :stop) + (is (eventually #(empty? (node/with-node b (pg/get-members :g))))))) + +(deftest a-node-s-members-go-with-the-node + (let [[a b] (nodes 2) + p (node/with-node a (act/spawn idle))] + (node/with-node a (pg/join :g2 p)) + (is (eventually #(= (ids [p]) (ids (node/with-node b (pg/get-members :g2)))))) + (node/with-node b (node/disconnect! a)) + (is (eventually #(empty? (node/with-node b (pg/get-members :g2))))))) + +(deftest members-already-joined-reach-a-node-that-connects-later + (let [a (fresh-node) b (fresh-node) + p (node/with-node a (act/spawn idle))] + (node/with-node a (pg/join :late p)) + (node/with-node a (node/connect! b)) + (is (eventually #(= (ids [p]) (ids (node/with-node b (pg/get-members :late)))))))) + +(deftest a-pg-monitor-sees-joins-and-leaves + (let [[a b] (nodes 2) + p (node/with-node b (act/spawn idle)) + got (promise)] + (node/with-node a + (act/spawn (fn [] + (let [[ref members] (pg/monitor :watched)] + (deliver got [members + (receive [[ref :join :watched ps] [:join (mapv id ps)]] [:after 2000 :none]) + (receive [[ref :leave :watched ps] [:leave (mapv id ps)]] [:after 2000 :none])]))))) + (sleep 30) + (node/with-node b (pg/join :watched p)) + (sleep 30) + (node/with-node b (pg/leave :watched p)) + (is (= [[] [:join [(id p)]] [:leave [(id p)]]] (deref got 3000 nil))))) + +(deftest a-pid-joins-only-from-its-own-node + (let [[a b] (nodes 2) + p (node/with-node b (act/spawn idle))] + (is (= :badarg (try (node/with-node a (pg/join :g3 p)) (catch Throwable e (:reason (ex-data e)))))))) + +(deftest a-pg-demonitor-drops-the-scopes-monitor-of-the-watcher + (let [a (fresh-node) + mons #(node/with-node a (count (act/process-info (act/whereis :ensemble.pg/scope) :monitors))) + before (mons) + r (promise)] + (node/with-node a + (act/spawn (fn [] + (let [[ref _] (pg/monitor :dm) + during (mons)] + (pg/demonitor :dm ref) + (deliver r [during (mons)])) + (receive [:never nil])))) + (is (= [(inc before) before] (deref r 2000 nil))))) diff --git a/test/ensemble/statem_spec.clj b/test/ensemble/statem_spec.clj index b1ac65f..51ce25d 100644 --- a/test/ensemble/statem_spec.clj +++ b/test/ensemble/statem_spec.clj @@ -14,18 +14,27 @@ [:next-state s d] [:next-state s d actions] [:keep-state d] [:keep-state d actions] [:keep-state-and-data] [:keep-state-and-data actions] + [:repeat-state d] [:repeat-state d actions] + [:repeat-state-and-data] [:repeat-state-and-data actions] [:stop reason] [:stop reason d] [:stop-and-reply reason replies] [:stop-and-reply reason replies d] and anything else stops the machine with {bad_return_from_state_function, - Ret}. A state enter call may not change the state + Ret}. A repeat keeps the state as keep does, and runs the state enter + call again as if the state had been entered anew: [:Repeat s d actions]. A state enter call may not change the state ({bad_state_enter_return_from_state_function, Ret}), postpone, or insert events ({bad_state_enter_action_from_state_function, Action}). Actions: :postpone or [:postpone bool], [:next-event type content], [:reply from value], [:timeout ms content] (the event timeout), a bare time ms (short for [:timeout ms ms]), [:state-timeout ms content], - [:generic-timeout name ms content]. A time of nil or :infinity cancels. + [:generic-timeout name ms content]. A time of nil or :infinity cancels, + as does [:timeout :cancel], [:state-timeout :cancel] or + [:generic-timeout name :cancel]. [:timeout :update content] (and the + same for the others) changes a running timer's content and leaves its + time; with no such timer it starts one of time 0. An options map after + the content, {:abs true}, makes the time an absolute deadline on the + monotonic clock, kept as [:abs t]. :hibernate or [:hibernate bool]: hibernate before waiting for the next event; of several, the last decides. Where a list of actions goes, one action alone may go instead, as OTP's [action()] | action(). An action @@ -53,6 +62,7 @@ (data Result (Transition Any Any (Vec Any)) + (Repeat Any Any (Vec Any)) (Stop Any (Vec Any) Any) (Bad Any)) @@ -74,10 +84,13 @@ (ann first-of [(Set Keyword) (List Any) -> (Opt (Vec Any))]) (ann next-queues [Bool Bool Any (Vec Any) (Vec Any) (Vec Any) -> Queues]) (ann next-timers [Bool (Map Any Any) (Vec Any) -> (Map Any Any)]) +(ann restarted [Bool (Map Any Any) (Vec Any) -> (Set Any)]) +(ann enter-timers [(Map Any Any) (Vec Any) -> (Map Any Any)]) +(ann enter-restarted [(Map Any Any) (Vec Any) -> (Set Any)]) ;; --- the state graph ---------------------------------------------------- -(refine Transitions [r Result] (= :Transition (first r))) +(refine Transitions [r Result] (contains? #{:Transition :Repeat} (first r))) (refine Stops [r Result] (= :Stop (first r))) (refine Bad [r Result] (= :Bad (first r))) @@ -120,6 +133,24 @@ (= (result-of :event [:keep-state-and-data [[:reply from 1]]] st d) [:Transition st d [[:reply from 1]]])))) +(law repeat-keeps-the-state + (forall [st Any, d Any, ms Nat] + (and (= (result-of :event [:repeat-state d] st :d0) [:Repeat st d []]) + (= (result-of :event [:repeat-state d [ms]] st :d0) [:Repeat st d [ms]]) + (= (result-of :event [:repeat-state-and-data] st d) [:Repeat st d []]) + (= (result-of :event [:repeat-state-and-data :postpone] st d) [:Repeat st d [:postpone]])))) + +(law an-enter-call-may-repeat + (= (result-of :enter [:repeat-state :d1] :s :d) [:Repeat :s :d1 []])) + +(law a-repeat-takes-only-actions + (and (= (result-of :event [:repeat-state :d [:bogus]] :s :d) + [:Bad [:bad-action-from-state-function :bogus]]) + (= (result-of :event [:repeat-state] :s :d) + [:Bad [:bad-return-from-state-function [:repeat-state]]]) + (= (result-of :enter [:repeat-state-and-data :postpone] :s :d) + [:Bad [:bad-state-enter-action-from-state-function :postpone]]))) + (law stop-forms (forall [why Any, d Any] (and (= (result-of :event [:stop why] :s d) [:Stop why [] d]) @@ -185,7 +216,33 @@ (= (result-of :event [:keep-state-and-data [[:timeout -1 :x]]] :s :d) [:Bad [:bad-action-from-state-function [:timeout -1 :x]]]) (= (result-of :event [:keep-state-and-data [[:next-event :bogus 1]]] :s :d) - [:Bad [:bad-action-from-state-function [:next-event :bogus 1]]]))) + [:Bad [:bad-action-from-state-function [:next-event :bogus 1]]]) + (= (result-of :event [:keep-state-and-data [[:timeout :cancel :x]]] :s :d) + [:Bad [:bad-action-from-state-function [:timeout :cancel :x]]]) + (= (result-of :event [:keep-state-and-data [[:state-timeout :update]]] :s :d) + [:Bad [:bad-action-from-state-function [:state-timeout :update]]]) + (= (result-of :event [:keep-state-and-data [[:timeout 5 :x {:abs :yes}]]] :s :d) + [:Bad [:bad-action-from-state-function [:timeout 5 :x {:abs :yes}]]]) + (= (result-of :event [:keep-state-and-data [[:generic-timeout :g :cancel :x]]] :s :d) + [:Bad [:bad-action-from-state-function [:generic-timeout :g :cancel :x]]]) + (= (result-of :event [:keep-state-and-data [[:generic-timeout :g :never]]] :s :d) + [:Bad [:bad-action-from-state-function [:generic-timeout :g :never]]]) + (= (result-of :event [:keep-state-and-data [[:generic-timeout :g]]] :s :d) + [:Bad [:bad-action-from-state-function [:generic-timeout :g]]]) + (= (result-of :event [:keep-state-and-data [[:generic-timeout :g 1 :x {:abs 1}]]] :s :d) + [:Bad [:bad-action-from-state-function [:generic-timeout :g 1 :x {:abs 1}]]]) + (= (result-of :event [:keep-state-and-data [[:generic-timeout :g 1 :x {} :y]]] :s :d) + [:Bad [:bad-action-from-state-function [:generic-timeout :g 1 :x {} :y]]]))) + +(law cancel-update-and-abs-are-timer-actions + (= (result-of :event [:keep-state-and-data [[:timeout :cancel] [:state-timeout :update :c] + [:generic-timeout :g :cancel] [:generic-timeout :g :update :c] + [:timeout 5 :x {:abs true}] [:state-timeout 5 :x {}] + [:generic-timeout :g -5 :x {:abs true}]]] :s :d) + [:Transition :s :d [[:timeout :cancel] [:state-timeout :update :c] + [:generic-timeout :g :cancel] [:generic-timeout :g :update :c] + [:timeout 5 :x {:abs true}] [:state-timeout 5 :x {}] + [:generic-timeout :g -5 :x {:abs true}]]])) (law stop-and-reply-takes-only-replies (= (result-of :event [:stop-and-reply :why [[:reply from 1] :postpone]] :s :d) @@ -233,6 +290,15 @@ (= (actions-of [[:timeout 5 :a] [:state-timeout 6 :b] [:generic-timeout :g 7 :c]]) [:Actions false [] [] [[:event 5 :a] [:state 6 :b] [[:generic :g] 7 :c]]])) +(law cancel-update-and-abs-parse + (= (actions-of [[:timeout :cancel] [:state-timeout :update :c] [:generic-timeout :g :cancel] + [:generic-timeout :g :update :c] [:timeout 5 :x {:abs true}] + [:state-timeout 6 :y {:abs false}] [:generic-timeout :g 7 :z {:abs true}] + [:timeout :infinity :w {:abs true}]]) + [:Actions false [] [] + [[:event nil nil] [:state :update :c] [[:generic :g] nil nil] [[:generic :g] :update :c] + [:event [:abs 5] :x] [:state 6 :y] [[:generic :g] [:abs 7] :z] [:event nil :w]]])) + (law infinity-is-a-cancel (= (actions-of [[:timeout :infinity :a]]) [:Actions false [] [] [[:event nil :a]]])) @@ -306,6 +372,46 @@ (and (= (next-timers changed {[:generic :g] [5 :a]} [[[:generic :g] nil :x]]) {}) (= (next-timers false {:state [5 :a]} [[:state nil :x]]) {})))) +(law an-update-changes-only-the-content + (forall [changed Bool] + (= (next-timers changed {[:generic :g] [5 :a]} [[[:generic :g] :update :b]]) + {[:generic :g] [5 :b]}))) + +(law an-update-with-no-timer-starts-one-of-time-0 + (and (= (next-timers true {:state [5 :a]} [[:state :update :b]]) {:state [0 :b]}) + (= (next-timers false {:event [5 :a]} [[:event :update :b]]) {:event [0 :b]}))) + +(law an-abs-time-is-kept + (= (next-timers false {} [[:state [:abs 9] :a]]) {:state [[:abs 9] :a]})) + +;; which timers a transition starts anew, so the runtime knows which to +;; arm from now and which keep their deadline +(law restarted-names-what-the-actions-start + (and (= (restarted false {:state [5 :a]} [[:event 3 :e]]) #{:event}) + (= (restarted false {:state [5 :a]} [[:state :update :b]]) #{}) + (= (restarted true {:state [5 :a]} [[:state :update :b]]) #{:state}) + (= (restarted false {:state [5 :a]} [[:state 1 :b] [:state :update :c]]) #{:state}) + (= (restarted false {} [[:state 1 :b] [:state nil nil]]) #{}))) + +(law restarted-is-within-the-timers + (every? (fn [[changed ts acts]] (every? (set (keys (next-timers changed ts acts))) (restarted changed ts acts))) + [[false {} [[:event 1 :a] [:state :update :b]]] + [true {:state [1 :a]} [[:state :update :b] [[:generic :g] nil nil]]] + [false {[:generic :g] [1 :a]} [[[:generic :g] 2 :b] [[:generic :g] nil nil]]]])) + +;; an enter call runs before any new event, so the transition's event +;; timeout stands; the enter call's own actions apply on top of it +(law an-enter-call-keeps-the-event-timeout + (and (= (enter-timers {:event [5 :a]} []) {:event [5 :a]}) + (= (enter-timers {:event [5 :a] :state [3 :s]} [[:state 9 :b]]) {:event [5 :a] :state [9 :b]}) + (= (enter-timers {:event [5 :a]} [[:event nil nil]]) {}))) + +(law an-enter-call-restarts-what-it-sets + (and (= (enter-restarted {:event [5 :a]} []) #{}) + (= (enter-restarted {:event [5 :a]} [[:event :update :b]]) #{}) + (= (enter-restarted {} [[:event :update :b]]) #{:event}) + (= (enter-restarted {:event [5 :a]} [[:state 1 :b]]) #{:state}))) + (law the-last-action-for-a-timer-wins (= (next-timers false {} [[:state 1 :a] [:state 2 :b]]) {:state [2 :b]})) diff --git a/test/ensemble/sys_test.clj b/test/ensemble/sys_test.clj new file mode 100644 index 0000000..7bfc121 --- /dev/null +++ b/test/ensemble/sys_test.clj @@ -0,0 +1,170 @@ +(ns ensemble.sys-test + (:require [clojure.core.async :as a] + [clojure.test :refer [deftest is]] + [ensemble.actor :as act] + [ensemble.gen-server :as gs] + [ensemble.gen-statem :as sm] + [ensemble.logger :as log] + [ensemble.supervisor :as sup] + [ensemble.sys :as sys])) + +(defn- sleep [ms] (a/Counter))] + (gs/cast! s :inc) + (is (= {:n 1 :secret "pw"} (sys/get-state s))) + (is (= {:n 10 :secret "pw"} (sys/replace-state! s #(assoc % :n 10)))) + (is (= 10 (gs/call! s :n))) + (is (thrown? Throwable (sys/replace-state! s (fn [_] (throw (ex-info "no" {})))))) + (is (= 10 (gs/call! s :n)) "a replace fn that throws leaves the state") + (gs/stop! s))) + +(deftest a-suspended-server-handles-only-system-messages + (let [s (gs/start (->Counter))] + (sys/suspend! s) + (gs/cast! s :inc) + (sleep 30) + (is (= {:n 0 :secret "pw"} (sys/get-state s))) + (is (= :suspended (:status (sys/get-status s)))) + (sys/resume! s) + (is (= 1 (gs/call! s :n))) + (gs/stop! s))) + +(deftest get-status-describes-the-server + (let [s (gs/start (->Counter) {:name ::counted}) + st (sys/get-status s)] + (is (= s (:pid st))) + (is (= :counted (:name st))) + (is (= :running (:status st))) + (is (= {:n 0 :secret "pw"} (:state st))) + (gs/stop! s))) + +(deftest format-status-filters-status-and-reports + (let [s (gs/start (->Secret)) + reports (atom []) + old (log/set-handler! #(swap! reports conj %))] + (try + (is (= {:n 0} (:state (sys/get-status s)))) + (try (gs/call! s :crash) (catch Throwable _ nil)) + (act/exit-reason s 1000) + (is (= {:n 0} (:state (first (filter #(= :gen-server-terminate (:kind %)) @reports))))) + (finally (log/set-handler! old))))) + +(deftest statistics-count-the-messages + (let [s (gs/start (->Counter))] + (is (= :no-statistics (sys/statistics s :get))) + (sys/statistics s true) + (gs/cast! s :inc) + (gs/cast! s :inc) + (gs/call! s :n) + (let [stats (sys/statistics s :get)] + (is (= 3 (:messages-in stats))) + (is (<= (:start-time stats) (:current-time stats)))) + (sys/statistics s false) + (is (= :no-statistics (sys/statistics s :get))) + (gs/stop! s))) + +(deftest trace-reports-each-event + (let [s (gs/start (->Counter)) + reports (atom []) + old (log/set-handler! #(swap! reports conj %))] + (try + (sys/trace! s true) + (gs/cast! s :inc) + (gs/call! s :n) + (sys/trace! s false) + (gs/cast! s :inc) + (gs/call! s :n) + (is (= [[:cast :inc] [:call :n]] (mapv :event (filter #(= :sys-trace (:kind %)) @reports)))) + (finally (log/set-handler! old))) + (gs/stop! s))) + +(deftest sys-terminate-stops-the-server + (let [s (gs/start (->Counter))] + (sys/suspend! s) + (is (= :ok (sys/terminate! s :bye))) + (is (= :bye (act/exit-reason s 1000))))) + +;; --- a gen-statem and a supervisor answer too ------------------------------ + +(defrecord Toggle [] + sm/Machine + (init [_] [:ok :off 0]) + (handle-event [_ _ _ state n] [:next-state (if (= :off state) :on :off) (inc n)]) + (terminate [_ _ _ _] nil)) + +(deftest a-gen-statem-answers-system-messages + (let [m (sm/start (->Toggle))] + (gs/cast! m :flip) + (is (= [:on 1] (sys/get-state m))) + (sys/replace-state! m (fn [[_ n]] [:off (+ n 10)])) + (is (= [:off 11] (sys/get-state m))) + (sys/suspend! m) + (gs/cast! m :flip) + (sleep 30) + (is (= [:off 11] (sys/get-state m))) + (sys/resume! m) + (sleep 30) + (is (= [:on 12] (sys/get-state m))) + (gs/stop! m))) + +(deftest a-supervisor-answers-system-messages + (let [s (sup/start {} [])] + (is (map? (sys/get-state s))) + (is (= :running (:status (sys/get-status s)))) + (sup/stop! s))) + +;; --- proc_lib: initial call and ancestors ----------------------------------- + +(deftest a-server-records-its-initial-call-and-ancestors + (let [parent (act/spawn (fn [] + (let [s (gs/start-link (->Counter))] + (act/! (act/self) [:info (act/process-info s :initial-call) + (act/process-info s :ancestors)]) + (act/receive [[:info ic an] [s ic an]])))) + [s ic an] (act/join parent 1000)] + (is (= [Counter :init] ic) "OTP's {Module, init, 1}") + (is (= [parent] an)))) + +(deftest a-crash-report-names-the-initial-call-and-ancestors + (let [reports (atom []) + old (log/set-handler! #(swap! reports conj %))] + (try + (let [p (act/spawn (fn [] + (let [c (act/spawn (fn [] (throw (ex-info "x" {}))) {:initial-call [:my :fn]})] + (act/exit-reason c 1000))))] + (act/join p 1000) + (let [r (first (filter #(= :crash-report (:kind %)) @reports))] + (is (= [:my :fn] (:initial-call r))) + (is (= [p] (:ancestors r))))) + (finally (log/set-handler! old))))) + +(deftest a-gen-statem-refuses-a-replaced-state-of-the-wrong-shape + (let [m (sm/start (->Toggle))] + (is (thrown? Throwable (sys/replace-state! m (fn [_] {:not :a-pair})))) + (is (thrown? Throwable (sys/replace-state! m (fn [_] nil)))) + (is (= [:off 0] (sys/get-state m)) "the machine is unharmed") + (gs/stop! m)))