writers.clj
Branches > main > 5bc2073 > files / src / net / bowmap / server / protocol / writers.clj
(ns net.bowmap.server.protocol.writers
"Functions for writing values into write buffers.
Functions look like type>, where 'type' is a Minecraft protocol type.
See https://minecraft.wiki/w/Java_Edition_protocol/Packets#Data_types"
(:require
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[net.bowmap.server.protocol.buffer :as buffer]
[net.bowmap.server.protocol.schema :as p]
[net.bowmap.server.protocol.types :as types])
(:import
[java.nio.charset StandardCharsets]
[java.util UUID]))
(s/def ::writer (s/fspec
:args (s/cat :buf ::buffer/write-buffer
:value any?)
:fn #(= (-> % :args :buf)
(:ret %))))
(defn- write-key
"Writes a map key via the supplied writer, throwing a useful error message
when writing fails."
[writer buf m k]
(try
(writer buf (get m k))
(catch Exception e
(throw (ex-info "Error while writing map key."
{:key k
:val (get m k)
:writer writer
:in-map m}
e)))))
(defn map>
"Takes pairs of map keys and writers, and returns a writer that takes a map
and writes each key's mapped values (or nil) via its corresponding writer."
[& keys-and-writers]
{:pre [(even? (count keys-and-writers))]}
(let [pairs (partition 2 keys-and-writers)]
(fn map-writer [buf m]
(reduce (fn [acc [k writer]]
(write-key writer acc m k))
buf pairs))))
(def byte> buffer/write-byte!)
(defn- integer> [byte-count]
(let [range (range (* 8 (dec byte-count)) -1 -8)]
(fn [buf n]
(reduce (fn [acc bits]
(byte> acc (bit-shift-right n bits)))
buf range))))
(defn- apply>
"Returns a writer that writes (f x) via 'writer'."
[f writer]
(fn [buf x]
(try
(writer buf (f x))
(catch Exception e
(throw (ex-info "Failed to call writer with applied function" {:f f :writer writer} e))))))
(defn then>
"Returns a writer that writes (f x) to the buffer, then (g x)."
[f g]
(fn [buf x]
(-> buf
(f x)
(g x))))
(def ubyte> byte>)
(def short> (integer> 2))
(def ushort> short>)
(def int> (integer> 4))
(def long> (integer> 8))
(def float> (apply> (comp Float/floatToRawIntBits float) int>))
(def double> (apply> Double/doubleToRawLongBits long>))
(defn boolean>
"Writes the byte 1 if 'x' is truthy, else the byte 0."
[buf x]
(if x
(byte> buf 1)
(byte> buf 0)))
(defn varint> [buf n]
(loop [buf buf
n n]
(let [b (bit-and n 0x7F)
nxt (unsigned-bit-shift-right n 7)]
(if (zero? nxt)
(byte> buf b)
(recur (byte> buf (bit-or b 0x80))
nxt)))))
(defn array>
"Returns a writer that writes every value in a coll via 'writer'."
[writer]
(fn [buf xs]
(reduce (fn [acc x]
(writer acc x))
buf xs)))
(defn list>
"Returns a writer that writes every value in a coll via 'writer', preceded
by the varint length of the coll.
When supplied 2 or more key value pairs, writes a collection of maps via map>."
([writer]
(then> (apply> count varint>)
(array> writer)))
([k v & kvs]
(list> (apply map> k v kvs))))
(def bytes> (list> byte>))
(defn string>
"Writes a string as a varint byte length followed by its UTF-8 bytes.
When passed 1 arg, returns a string writer that throws when the string
exceeds the supplied maximum number of UTF-8 bytes."
([max-length]
(fn [buf s]
(if (> (count s) max-length)
(throw (ex-info "Cannot encode string, too long." {:max-length max-length :string s}))
(string> buf s))))
([buf s]
(bytes> buf (String/.getBytes s StandardCharsets/UTF_8))))
(defn split-identifier>
"Writes an identifier as 2 strings: the namespace and the name."
[buf identifier]
(let [{:keys! [namespace name]} (types/identifier-segments identifier)]
(-> buf
(string> namespace)
(string> name))))
(def json>
"Turns 'x' into JSON and writes it as a string."
(apply> json/write-str string>))
(defn- ->status-response [{::p/keys! [version-name protocol]
::p/keys [motd max-player-count online-player-count]}]
(cond-> {:version {:name version-name
:protocol protocol}}
motd (assoc :description motd)
(and max-player-count online-player-count)
(assoc :players {:max max-player-count
:online online-player-count})))
(def status-response> (apply> ->status-response json>))
(defn uuid> [buf uuid]
{:pre [(uuid? uuid)]}
(-> buf
(long> (UUID/.getMostSignificantBits uuid))
(long> (UUID/.getLeastSignificantBits uuid))))
(defn context-optional>
"Returns a writer that only writes a value via 'writer' if the value is non-nil.
Unlike optional>, is not prefixed with a boolean. Reading is dependent on context."
[writer]
(fn [buf x]
(if (some? x)
(writer buf x)
buf)))
(defn optional>
"Returns a writer that prefixes the value with a boolean indicating whether
it is present, and only writes the value via 'writer' if the value is non-nil."
[writer]
(context-optional> (then> boolean> writer)))
(def game-profile> (map> ::p/uuid uuid>
::p/username (string> 16)
::p/game-profile-properties
(list> ::p/game-profile-property-name (string> 64)
::p/game-profile-property-value (string> 32767)
::p/game-profile-property-signature (optional> (string> 1024)))))