Sunday, September 29, 2013

Deal Journal - Part Three

Part three of my journal for the Deal Project. Part one and two are already up, of course.

T minus 22 days

There's a couple of small patterns that I've come across. One:

($ [foo]
   (button (create :icons (create :primary "ui-icon-[icon-name]") :text nil))
   (click (lambda (event) ($ [parent-or-child-of-foo] ([do-something])))))

and two

($ foo
   (on [event] [child]
       (lambda (event)
         ($ [parent-or-child-of-foo] ([do-something])))))

Or, if you're more comfortable with JavaScript, I guess,

$("foo")
    .button({"icons": { "primary" : "ui-icon-[icon-name]"}, "text": false})
    .click(function (event) {
        $("parent-or-child-of-foo").do-something();
    })

$("foo")
    .on("event", "child",
        function (event) {
            $("parent-or-child-of-foo").do-something();
        })

Now, you could argue about whether the JS-style hash-literal syntax is more elegant, or about how I might save a word or two somewhere if I was writing jQuery directly, but neither the JS nor the Lisp version of these are particularly fun to type. So.

(defpsmacro $button (selector (icon-name &key text? (class "control-button")) &body on-click)
  `($ ,selector
      (button (create :icons (create :primary ,(format nil "ui-icon-~(~a~)" icon-name)) :text ,text?))
      (click (lambda (event) ,@on-click))
      ,@(when class `((add-class ,class)))))

(defpsmacro $on (context-selector &rest event/selector/behavior-list)
  `($ ,context-selector
      ,@(loop for (ev sel . behav) in event/selector/behavior-list
           collect `(on ,ev ,sel (lambda (event) ,@behav)))))

Tadaah. I also took the liberty of having the $button macro add a custom body class, for my own ease-of-use in the CSS. These let me write greatly simplified versions of both constructs like this:

($button foo (:icon-name) ($ parent-or-child-of-foo (do-something)))

($on foo
     (:event "child"
             ($ parent-or-child-of-foo (do-something)))
     ...)

Much better. I'll be adding both of these to cl-web-dev later on. While we're on the subject by the way, that project has been very helpful for me, even though I've yet to actually use it anywhere. Porting code from :deal to :cl-web-dev forced me to think about how to generalize certain constructs, and its made me pay a lot more attention to the small assumptions I've been making while writing front-end code. I thoroughly recommend it. In fact, I may just get into the habit of writing a general version along with whatever project-specific code I'm writing in the future.

Later That Day...

Two things. First off, I updated the $on macro to give me the same kind of sugar as $keydown

(defpsmacro $on (context-selector &rest event/selector/behavior-list)
  `($ ,context-selector
      ,@(loop for (ev sel . behav) in event/selector/behavior-list
           collect 
             `(on ,ev ,sel (lambda (event) 
                             ,@(if (eq ev :keydown)
                                   `((let (,@mod-keys ,@key-codes
                                           (key-code (or (@ event key-code) (@ event which))))
                                       (cond ,@(loop for (key body) on behav by #'cddr
                                                  collect `((= key-code ,(if (stringp key) `(chain ,key (char-code-at 0)) key)) ,body)))))
                                   behav))))))

That complicates the definition, but it lets me do things like

...
($on "#deck-editor"
     (:keydown ".new-card"
               <ret> (unless shift?
                       (chain event (prevent-default))
                       ($ "#deck-editor button.add-card" (click)))
               <esc> ($ "#deck-editor .new-card" (val ""))))
...

Instead of putting together that keychecking manually, so fair enough. In this particular case, I could have gotten away with just using $keydown diretly, but I have some nefarious plans that involve front-end changes to the way this editor works, so it will shortly become important that the key event gets delegated rather than attached to a particular DOM node.

Second, it turns out file uploading isn't the only way JS file operations suck absolute balls in the browser.

File downloading as well as loading local files are both giant shit sandwiches that'll hopefully get fixed up at some point fairly soon. In the meantime, I've chosen to follow Dave's advice for the file saving, which is basically "Use FileSaver.js", and use a stupid handler workaround for loading.

As in, when the client needs to load a part of their local filesystem, they'll upload it to the server, which will echo it back so that it can be saved on the client side.

; deal.lisp

...
;;; TODO: figure out a way to do this entirely on the client side. 
;;; Why should I have to give a rats' ass what they want to load?
(define-handler (load-deck) ((deck :json-file))
  deck)
...
; deal-ui.lisp

...
($ "#load-deck-form" 
   (change 
    (fn ($upload "#load-deck-form" "/load-deck"
                 (load-deck-for-editing res)))))
...

I tell you, it's a good thing I don't drink.

There has got to be a better way of doing that. If all else fails, I'll just unwrap it into the naked define-easy-handler call. Because, just in case you didn't catch that, that wonderful define-handler mini-language works hard against me here. Because all of its output is JSON-serialized, and the incoming argument is of type :json-file, what's actually happening in load-deck is

  1. the server receives a file
  2. it parses said file into an s-exp representation of the JSON tree[1]
  3. it encodes the result into JSON and writes it out as a string[2]

What you're looking at is an On implementation of identity, with some really, really bad, network-dependent constant factors tacked on. And the entire thing is completely, aggravatingly unnecessary anyway because as the comment says: why do I care what my users are loading in the first place? I guess it doesn't really matter for the short term. It will begin to matter the instant people start actually using the thing, because I really won't be able to afford the extra traffic at that point.

T minus 21 days

Today, I showed Deal off to the first bunch of humans who aren't programmers. Reaction was by and large positive, so that's good I guess. Also, someone called me an "idealistic craftsman", in what I'm sure he thought was a condescending way, but, well... I resemble that remark.

What I found out is that I'm pretty much on target for what people want, and my observations told me I really ought to fast-track some features I was planning for later on

  • custom backgrounds on cards/decks
  • custom tablecloths/minis
  • adding notes[3]
  • rotation

I figured I could wait on these, but having seen some games people actually play, they'll will become painfully necessary soon. Also, I got the idea for a feature I wasn't even thinking of, but that's entirely obvious in retrospect. The ability to ping a particular location on the board, or perhaps an existing placeable. This wouldn't change the board in any way, but it would highlight a particular thing on it to draw everyones' attention.

The server-side components for all of those have been implemented, by the by. By the time this is published, they'll have been in production for about two weeks. The client side will take a little longer. Mostly because I have to figure out intuitive ways to trigger all of this without cluttering the UI.

T minus 14 days

I've been spending most of my time figuring out a new server arrangement for the project. Which I did, more or less, and the incomplete[4] results have already been published here. I don't expect the session is going to give me any trouble at all, but I"m still leaving it for a bit. I've already got a running server with the shitty deployment method, after all, and work on the UI will benefit my current as well as my future deployments, so I figure those are higher priority targets. In particular, the more I think about rotation the more I think that's going to be the really annoying feature to add. We'll see I guess. I hope to have a further update on this project for you later today.

T minus 13 days

Got a bit done yesterday, and a bit today. It turns out that neither implementing element rotation nor implementing HTML5 localStorage were particularly difficult. It did give me a couple of ideas that I'll need to look into though

  • resizing minis/tablecloths[5]
  • storing custom mini/tablecloth URIs in local storage[6]

The project's really winding down though. Apart from that server rewrite/tweak I'll need to make at some point, the work's pretty much done. And even that won't really change the UI much. Depending on the approach I end up taking, I may need to switch from EventSource to WebSockets on the front-end, and that's about as intense a project as I've got left. We've got a fairly nice tool in just under 2500 lines of Common Lisp.

Lets see what it'll take to make it beautiful instead of just nice...

T minus 9 days

The deck editor has finally been overhauled into something approaching beautiful. You no longer need to know JSON to use it at all[7], and it's reasonably intuitive. That's it. That was the goal. I've amended the note in README.md to reflect that we now, in fact, have the prototyping down cold.

At this point I'm giving serious thought to plowing ahead and putting together that special-purpose server I was on about last time. In a separate branch obviously, so that I still have something to show if it passes "pencils down" before I get done with it, but still.

T minus 8 days

I've re-considered that again. Looking at the issue tracker, there's still a few things I want to put together before I start thinking about re-engineering the back end. It still needs to happen; putting together a stripped-down, async server with SSE and Session capabilities out of the box will make game writing in Lisp much easier. To the point that I might finally go back and finish up Strifebarge once it's done. For this specific project though, some stuff is slightly more important than re-working the back end. Stuff like card images, custom notes, peek/show/play-from, setting the number of seats and starting private games. Normally, I'd say that's a short list. And I'd probably try to get all of the above done. Unfortunately, my next week is going to be busy as hell even without factoring in the additional work I intend to pour into Deal, so I'm picking my battles at the moment.

On another note, I was pointed to two "competitors" to this project way back when I showed this off to other humans. The reason the word "competitors" has quotes around it is that, as I said to the other human, I'm not competing. Deal is an entirely free-time project that I intend to release under the AGPL and use for some personal projects with a friend, but I'm not selling it[8] or pushing it, I just want feedback. So it feels really bizarre to refer to anything as a competing product.

Anyhow, the two that got pointed out are Vassal and Roll20, both of which I'd have trouble thinking of as "competitors" even if not for the previous points. Vassal is, bizarrely, a Java-based desktop app that requires you to connect to a central server to play. They can probably bend the UI to their will further than I can, but there are disadvantages to making something like this a piece of desktop software. Not the least of which is that connectivity is the point, which means you still need to worry about network connections, and run a server, but you get to build it all from the ground up[9]. So, to summarize: similar goals, wildly different architecture and approach.

Roll20 takes a similar approach, but has much different goals. It's a web application people connect to[10], and they connect in order to have a shared space they can manipulate. That seems to be that though. The focus of Roll20 is to play tabletop games, and I'm not sure, but it looks like their card game support isn't very extensive. They focus on tabletop games in the vein of D&D, and they don't seem to bother providing facilities to mock up your own minis/boards/cards/what-have-you, which is kind of key if you're looking for a prototyping tool. So again, executive summary: similar architecture and approach, wildly different goal.

I guess you could look at Deal as an attempt to unify these two applications, but that would imply I was aware of either when I started, and I wasn't.

T minus 4 days

I seriously wanted to do a countdown from 5, but life gets in the way of that. Today I had an idea for a cooperative card game heavily riffing off of ShadowRift, so I figured I'd put Deal through its paces. It was slow going at first, I'll admit, but I added two or three minor features that made it easier. Most notably, the card editor now deals with copy count rather than naively treating each individual card as a separate record, even if they're copies. It still doesn't go deep; the JSON representation I save still does the stupid thing and it shouldn't in the long run, but the interface has been greatly simplified. I'm going to release the game files so you guys can try it once I get it to version 1.0.

This weekend is the last couple of full days I'll be able to throw at the thing before the contest is up, which means I want to add a last couple of features to the front end, then concentrate on cleanup. There aren't any particularly gnarly bits I can think of off the top of my head, but its been a while since I got the chance to just sit down and read the UI code, so maybe I'll see rot accumulating where I wasn't expecting it.

T minus 3 days

Today saw some minor UI changes, inspired by my attempt to actually build a game, as well as the removal of the last piece of stupid JS hack code on the server. There used to be a thing, which I already bitched about earlier, that looked like this

;;;;;;;;;; Stupid hacks around in-browser JS limitations
;;; TODO: figure out a way to do this entirely on the client side. 
;;; Why should I have to give a rats' ass what they want to load?
(define-handler (load-deck) ((deck :json-file))
  deck)

in deal.lisp. The only reason it was there is that there didn't seem to be a good way of loading a local file into a JS application. Which a player would want to do if they saved their deck file, but were away from their machine or main browser. The result was that in order to accomplish this relatively straight-forward task, I had to let users upload their deck files, send them back (After parsing unfortunately; :json-file does a parse of its contents and I didn't feel like putting in further pseudo-types just for something I saw as a hack anyhow), where they would then be loaded locally.

The way I ended up solving that was with a bit of HTML5 tech (which unfortunately means that only HTML5-compatible browsers can load decks, but on the plus side, the sever is finally out of a loop it doesn't belong in anyhow)

;;; in pQuery.lisp
...
(defpsmacro $load (elem-id &body body)
  (with-ps-gensyms (f-list)
    `(let ((reader (new -file-reader))
           (,f-list (chain document (get-element-by-id ,elem-id) files)))
       (setf (@ reader onloadend)
             (lambda (event)
               (let ((res (string->obj (@ event target result)))) 
                 ,@body)))
       (when ,f-list
         (chain reader (read-as-text (@ ,f-list 0)))))))
...
;;; in deal-ui.lisp
...
($ "#load-deck-form" 
   (change (fn 
            ($load "load-deck-file" (load-deck-for-editing res))
            ($ "#load-deck-dialog" (dialog :close)))))
...

The macro takes an element id[11] and a callback body. It sets up a FileReader to read the first file specified by the named element if any, then evaluates body in an environment where event is bound to the reader event and res is bound to the JSON-parsed content of the read file.

The block in deal-ui.lisp just calls that macro in a change event for #load-deck-form, and loads the resulting JSON for editing as a deck.

Not as pretty as it could possibly be, but it does the job.

T Minus 2 days

I'm in the middle of throwing the second biggest chunk of time I've had at this project. For an opener, I put together a peek system which lets players look at and manipulate the cards in stacks. You can just peek, and you can reorder the cards you're looking at, and you can take arbitrary ones into your hand. Of course, as usual, all of this is logged in the games public broadcast, so you can't exactly cheat inconspicuously using these techniques.

That killed a good three or four feature requests with one stone. Before the day's up, I'm still hoping to do something about

  • the ability to play a card directly from a stack[12]
  • the ability to flip over the top card of a stack
  • card/deck background images
  • leavers hands
  • in-game player status

and that's all. Once those are put together, I'm just doing a final few cleanup runs before the deadline is up. At that point, I'll consider this One Point Ohed, and I'll move on to the larger project chunklets I still want to put together, including a custom server and multi-select functionality.

Later That Day...

So that's done.

Seriously.

All of it.

The only thing I've got left to do tomorrow is cleanup, which is non-trivial but certainly possible. I don't even have enough mental energy to witter about technique at this point, so I know damn well that I don't want to bite off any more features on a schedule this tight. This has been a pretty draining three months, all things considered, but I'm almost done here. A break will be quite welcome after that.

Dawn of the Final day

Satori.

So that's it. It's actually T Minus 1 day, but it's highly doubtful I'll be able to do much work tomorrow. Off to tuning I go. If you're used to "refactoring" in the Java/C# sense, this is probably going to be the weirdest round of tweaks you've seen. Because I'll be trying to maximize front-end readability as opposed to performance. In other words, as a result of the effort I'm about to put forth, the application will probably get slower and smaller[13].

Preliminary triage on The Server Side turned up one thing, but it was very preliminary so there may be more. There's a few handlers like this one

(define-player-handler (table/stack/play) ((table :table) (stack :stack) (card-id :keyword) (face :facing) (x :int) (y :int) (z :int) (rot :int))
  (let ((card (find card-id (cards stack) :key #'id)))
    (assert card)
    (set-props card face x y z rot)
    (publish! table :played-from-stack `((stack . ,(id stack)) (card . ,(redact card))))
    (move! card stack table)
    :ok))

the relevant parts are

(define-player-handler (table/stack/play) (... (stack :stack) (card-id :keyword) ...)
  (let ((card (find card-id (cards stack) :key #'id)))
    (assert card)
    ...))

What I'm doing is expecting a card. But it won't be in a hand, or on the table, it'll be in a stack. My psuedo-type-system doesn't cover this possibility, so what you see there is me getting a keyword from the client, looking it up manually and asserting that it's actually in the stack I care about. This is a change I'm not doing right now, because I think the front-end will need much more work, but what I really want to be able to say in this situation is something like

(define-player-handler (table/stack/play) (... (stack :stack) (card (:card :in-stack stack) ...)
  ...)

and have the lookups/assertions happen automatically on my behalf. There's a couple more places this pattern emerges, so I'll come back to put the fix together, but not right now. At the moment, this is a Note To Self.

There's a fuckton of work on The Client Side, as I suspected. There's places where I need to add define-thing declarations, there's places where things overlap more than I'd like, and there's a few places where small, counter-intuitive patterns are emerging. So, we'll begin at the beginning, get through as much of the middle as possible, hopefully come to the end and then stop.

Incrementing

There's a bunch of places that exhibit this sort of pattern

...
(let ((trg ($ this (siblings ".num-dice"))))
  ($ trg (text (max 1 (- ($int trg) 1))))
  (store-dice))
...

The (store-dice) call there is actually just noise, but the rest of that expression is relevant. What I'm trying to express is "Decrement the number contained in this DOM element, and make sure the result doesn't go below 1", but because the number is stored textually, there's a bunch of overhead that needs to happen for that fairly simple concept to be executed. I need to get the element, get an integer from its contents, increment it, make sure it's not below 1 and then store it in place. You'll note that there's already a macro there that isn't helping much. $int just takes an element and returns its contents after a parse-int call. What I really want to be able to write in this situation is

...
($decf ($ this (siblings ".num-dice")) -1 :min 1)
(store-dice)
...

Which is going to mean finally fixing the $int plumbing properly, like I've been meaning to. I already more-or-less solved this problem in cl-web-dev, so I'll be borrowing a slightly modified copy of that solution.

(defpsmacro $val (selector &optional new-value)
  (with-ps-gensyms (sel type elem)
    (let* ((!exp (when new-value `(,new-value)))
           (val-exp `(chain ,elem (val ,@!exp))))
      `(let* ((,sel ,selector)
              (,elem ($ ,sel))
              (,type (chain ,elem (get 0) tag-name)))
         (case ,type
           ("INPUT" ,val-exp) ("BUTTON" ,val-exp) ("TEXTAREA" ,val-exp)
           (t (chain ,elem (text ,@!exp))))))))

That's going to do a better job than the current $int of getting/setting the val or text of a particular target[14]. It takes a selector, and optionally a new-value, checks what kind of element the selector specifies, and returns or modifies either its text or val as appropriate. The !exp[15] shows up wherever a value is changed/looked up. It's written oddly, because I want it to expand into nothing as opposed to nil if a new-value wasn't passed in, which means stitching with ,@ rather than just ,. The val-exp is what I run if the element is of a type that has a (val), otherwise we need to return its (text). This is one of those things that might go easier without jQuery.

Anyhow, now that we have a generic value getter/setter, we can define a new, shorter $int in terms of it.

(defpsmacro $int (selector)
  `(parse-int ($val ,selector)))

Which should be self-explanatory. Next, $incf would be trivial to define if not for the bounding requirements. If we wanted a naive increment, we could just say

(defpsmacro $incf (selector &optional (delta +1))
  (with-ps-gensyms (elem)
    `(let ((,elem ,selector))
       ($val ,elem (+ 1 ($int ,elem))))))

with just one minor complication we need so that selector isn't evaluated twice. however, we want to make sure this is a bounded $incf, so we need to account for that. Luckily, unlike with the $val macro, we can do that at macro-expansion time

(defpsmacro $incf (selector &optional (delta +1) &key min max)
  (with-ps-gensyms (elem)
    (let* ((val-exp `(+ ,delta ($int ,elem)))
           (new-val (cond ((and min max)
                           `(max (min ,max ,val-exp) ,min))
                          (max `(min ,max ,val-exp))
                          (min `(max ,val-exp ,min))
                          (t val-exp))))
      `(let ((,elem ,selector))
         ($val ,elem ,new-val)))))

Now that we've got that, we can define $decf in terms of $incf for a bit of syntactic sugar[16]. That kills this pattern. Boom. Headshot.

Self-Replacing components and aif-friendly $exists?

Next up, not so much a pattern as an annoying thing I've had to write

...
(let ((sel (+ "#game-" (@ ev id))))
  (if ($exists? sel)
      ($ sel (replace (render-table-entry (@ ev table))))
      (render-table-entry (@ ev table))))
...

What I want there is to replace an existing game record with an update. It's not entirely obvious from that expression, but the reason I do this is that I want recently updated games to be at the top of the games list. render-table-entry prepends, you see. Now that I think back on it actually, the only reason I didn't use define-thing[17] here is that prepending issue. So...

(defpsmacro define-thing ((name &key prepend? replace?) markup &body behavior)
  (with-ps-gensyms (container)
    `(defun ,(intern (format nil "create-~a" name)) (,container thing)
       ,@(when replace?
               `(when (@ thing id)
                  (aif ($exists? (+ "#" (@ thing id)))
                       ($ it (remove)))))
       ($ ,container (,(if prepend? 'prepend 'append) (who-ps-html ,(expand-self-expression markup 'thing))))
       (let (($self (aif (@ thing id) ($ (+ "#" it)) ($ ,container (children) ,(if prepend? '(first) '(last))))))
         (flet (($child (selector) (chain $self (children selector)))
                ($find (selector) (chain $self (find selector))))
           ,@(loop for clause in behavior
                collect (expand-self-expression clause 'thing)))))))

There. That adds optional prepend? and replace? options to define-thing. Note that I make the choice about replacement and prepending in the macro call, rather than the resulting function definition. That means that I can't prepend a thing I've declared as appending[18], but it means more work can be done at macro-expansion time, which is usually a good thing.

As an aside, in the course of this edit, I noticed that there's another call pattern surrounding $exists?. Specifically

...
(if ($exists? (+ "#deck-editor .cards .card[title='" (@ res name) "']"))
    ($incf (+ "#deck-editor .cards .card[title='" (@ res name) "'] .count"))
    (create-card-record "#deck-editor .cards" res))
...

the relevant idea here is that if a particular element $exists?, I tend to do something with it. Which means that I'd really like to use aif here, except I can't because $exists? returns true or false, rather than something interesting in the positive case. That's a pretty quick edit:

(defpsmacro $exists? (selector)
  `(when (> (@ ($ ,selector) length) 0)
     ,selector))

It now returns the original selector, which means that I can re-write that if above as a very slightly cleaner

...
(aif ($exists? (+ "#deck-editor .cards .card[title='" (@ res name) "']"))
     ($incf ($ it (children ".count")))
     (create-card-record "#deck-editor .cards" res))
...

Ahem. Now, then[19].

...
(define-thing (table-entry :prepend? t :replace? t)
    (:li :id (self id)
         (:span :class "tag" (self tag))
         (:span :class "id" (self id))
         (:span :class "players" (:span :class "count" (self player-count)) "/" (self max-players))
         (:button :class "join" "Join"))
  ($highlight $self)
  ($button ($child ".join") (:arrowthick-1-ne) 
           (let ((passphrase ""))
             (lobby/join-table (self id) passphrase))))
...

Now that I've got that definition, I can go back and replace things like this

...
(let ((sel (+ "#game-" (@ ev id))))
  (if ($exists? sel)
      ($ sel (replace (render-table-entry (@ ev table))))
      (render-table-entry (@ ev table))))
...

with things like this

...
(create-table-entry "#open-tables" (@ ev table))
...
Hidden Components

Next up, there's a few elements on the front end that are components, but aren't defined as components. Specifically, there are mini-windows for specifying new games, custom minis and such, and they have their own behaviors, but they're specified ad-hoc and in-line.

...
(define-component (new-table-form :empty? nil)
    (:div :id "new-table-setup" :class "overlay"
          (:h3 "New Table")
          (:div :class "content"
                (:input :class "game-tag")
                (:button :class "ok" "Ok")
                (:button :class "cancel" "Cancel")))
  ($button "#new-table-setup .ok" (:check :text? t)
           (lobby/new-table ($ "#new-table-setup .game-tag" (val)) ""))
  ($button "#new-table-setup .cancel" (:cancel :text? t) ($ "#new-table-setup" (hide)))
  
  ($keydown "#new-table-setup .game-tag" 
            <ret> ($ "#new-table-setup .ok" (click))
            <esc> ($ "#new-table-setup .cancel" (click))))
...

(define-component (custom-tablecloth-form :empty? nil)
    (:div :id "custom-tablecloth-form" :class "overlay" 
          (:h3 "Custom Tablecloth")
          (:div :class "content"
                (:input :class "url-input" :placeholder "Tablecloth image URL")
                (:input :class "name-input" :placeholder "Tablecloth Name")
                (:button :class "ok" "Ok")
                (:button :class "cancel" "Cancel")))
  ($button "#custom-tablecloth-form .ok" (:check :text? t)
           (let* ((name ($val "#custom-tablecloth-form .name-input"))
                  (tblc (create :name name :uri ($val "#custom-tablecloth-form .url-input"))))
             (create-custom-tablecloth "#tablecloth-tab .content" tblc)
             (setf (aref *session* :custom-tablecloths name) tblc)
             (store-custom-tablecloths)
             ($val "#custom-tablecloth-form input" "")
             ($ "#custom-tablecloth-form" (hide))))
  ($button "#custom-tablecloth-form .cancel" (:cancel :text? t) ($ "#custom-tablecloth-form" (hide))))
...

(define-component (custom-mini-form :empty? nil)
    (:div :id "custom-mini-form" :class "overlay"
          (:h3 "Custom Mini")
          (:div :class "content"
                (:input :class "url-input" :placeholder "Mini image URL")
                (:button :class "ok" "Ok")
                (:button :class "cancel" "Cancel")))
  ($button "#custom-mini-form .ok" (:check :text? t)
           (let ((uri ($ "#custom-mini-form .url-input" (val))))
             (create-custom-mini "#minis-tab .content" (create :uri uri))
             (aif (aref *session* :custom-minis)
                  (chain it (push uri))
                  (setf (aref *session* :custom-minis) (list uri)))
             (store-custom-minis)
             ($val "#custom-mini-form .url-input" "")
             ($ "#custom-mini-form" (hide))))
  ($button "#custom-mini-form .cancel" (:cancel :text? t) ($ "#custom-mini-form" (hide))))
...

(define-component (load-deck-form :empty? nil)
    (:div :id "load-deck-form" :class "overlay"
          (:h3 "Load Deck")
          (:div :class "content"
                (:form :id "load-deck-inputs" :enctype "multipart/form-data"
                       (:input :id "load-deck-file" :name "deck" :type "file")))
          (:button :class "cancel" "Cancel"))
  ($ "#load-deck-inputs" 
     (change (fn 
              ($load "load-deck-file" (load-deck-for-editing res))
              ($ "#load-deck-form" (hide)))))
  ($button "#load-deck-form .cancel" (:cancel :text? t) ($ "#load-deck-form" (hide))))
...

So that's done; they're all pulled together now. Except, that tweak makes it clear that I really mean something else. These are all overlays. They're meant to go in the middle of the screen in place of a prompt, they have a title, a bit of markup and a bit of behavior, and they all have :cancel buttons that work exactly the same way. This looks like something we could easily abstract.

Defining Overlays
(defpsmacro define-overlay ((name &key (ok-button? t)) content &body behavior)
  (let* ((elem-name (format nil "~(~a~)-overlay" name))
         (display-name (string-capitalize (cl-ppcre:regex-replace-all "-" (symbol-name name) " ")))
         (id (concatenate 'string "#" elem-name)))
    `(define-component (,(intern (string-upcase elem-name)) :empty? nil)
         (:div :id ,elem-name :class "overlay"
               (:h3 ,display-name)
               (:div :class "content"
                     ,content
                     (:button :class "cancel" "Cancel")
                     ,@(when ok-button? `((:button :class "ok" "Ok")))))
       (let (($self ,id))
         (flet (($find (selector) ($ $self (find selector))))
           ,@behavior
           ($button (+ ,id " .cancel") (:cancel :text? t) ($ ".overlay" (hide))))))))

If you haven't seen it before, you may want to go through this one slowly. It's a macro that expands into a definition macro to abstract away the pieces this particular set have in common, leaving more or less just their differences in the resulting define-overlay calls. In this particular case, that's common extra arguments to define-component, a few lines of markup and a line of behavior. I could probably have boiled more out if I wanted to, but as you'll see below, this is already a pretty good result.

...
(define-overlay (new-table)
    (:input :class "game-tag")
  ($button ($find ".ok") (:check :text? t)
           (lobby/new-table ($ "#new-table-setup .game-tag" (val)) ""))
  ($keydown ($find ".game-tag")
            <ret> ($ ($find ".ok") (click))
            <esc> ($ ($find ".cancel") (click))))
...

(define-overlay (custom-tablecloth)
    (:span (:input :class "url-input" :placeholder "Tablecloth image URL")
           (:input :class "name-input" :placeholder "Tablecloth Name"))
  ($button ($find ".ok") (:check :text? t)
           (let* ((name ($val "#custom-tablecloth-form .name-input"))
                  (tblc (create :name name :uri ($val "#custom-tablecloth-form .url-input"))))
             (create-custom-tablecloth "#tablecloth-tab .content" tblc)
             (setf (aref *session* :custom-tablecloths name) tblc)
             (store-custom-tablecloths)
             ($val ($find "input") "")
             ($ $self (hide)))))
...

(define-overlay (custom-mini)
    (:input :class "url-input" :placeholder "Mini image URL")
  ($button ($find ".ok") (:check :text? t)
           (let ((uri ($val "#custom-mini-form .url-input")))
             (create-custom-mini "#minis-tab .content" (create :uri uri))
             (aif (aref *session* :custom-minis)
                  (chain it (push uri))
                  (setf (aref *session* :custom-minis) (list uri)))
             (store-custom-minis)
             ($val ($find ".url-input") "")
             ($ $self (hide)))))
...

(define-overlay (load-deck :ok-button? nil)
    (:form :id "load-deck-inputs" :enctype "multipart/form-data"
           (:input :id "load-deck-file" :name "deck" :type "file"))
  ($change "#load-deck-inputs"
           ($load "load-deck-file" (load-deck-for-editing res))
           ($ $self (hide))))
...

And that's going to be the mod I end off on for now. There's more refactoring to do, of course.

  • The server-side still needs those additions to define-handler
  • There's a lot of boilerplate on the client-side relating to storing things in localStorage which I'm pretty sure I could abstract away
  • The initial localStorage loads happen all over the place, as opposed to just where I set *session*
  • There's still implicit components hiding in a couple of places
  • I've yet to unify the front-end SSE handlers with the chat message interface
  • and I'm calling $button/$droppable/$draggable/$keydown a lot more than I thought I would, and each of them has their own local bindings for the modifier and special key values. the specials, at least, probably ought to be global bindings instead of being inlined each time.

But all of that, and probably a lot more besides, will have to wait until I've had a bit of rest.


Footnotes

1 - [back] - Possibly failing for encoding reasons.

2 - [back] - Possibly failing due to that encoding-depth, alist-related bug we discussed last time.

3 - [back] - Either standalone to the table, or attached to an existing placeable.

4 - [back] - Sans session.

5 - [back] - Which will require server-side changes because I don't currently track the size of anything.

6 - [back] - That way you don't need to keep pasting from imgur or whatever every time you start a game.

7 - [back] - Entry happens in explicit k/v inputs and preview takes the form of actual, zoomable preview cards you can poke at instead of just an object dump.

8 - [back] - Though, because it's AGPL, you should feel perfectly free to, as long as you respect your users' freedom by pointing them at a repo that includes any changes you've made.

9 - [back] - Rather than getting the vast majority of it for free, as you would if you took the web application approach.

10 - [back] - Though it's not AGPL, which I guess technically means that I should have disregarded it even had I known about it when starting this project.

11 - [back] - This is the only construct that does so, but I'm not going to hack leading "#" support into it quite yet because I have a sneaking suspicion that I could have put Deal together purely using HTML5 constructs. That's something else I'll look into after the contest; porting the back-end away from jQuery, hopefully just by re-defining the pQuery macros.

12 - [back] - Which will also be helped by that peek interface.

13 - [back] - Both conceptually and in terms of line-count, but that first one is the more important of the two.

14 - [back] - For the record, I re-wrote that macro three times as I was writing this paragraph. Someone asked me why I blogged a while ago, and my answer was basically that this was an attempt at rubber-duck debugging with the internet instead of the duck. Don't laugh; it works.

15 - [back] - For the non-schemers, that's pronounced "set expression"; ! denotes a side-effect, not logical negation.

16 - [back] - Specifically so that we don't have to say correct, but counter-intuitive things like ($incf -4).

17 - [back] - That's a basic macro I defined earlier to let me group markup with behavior in various places. It defines some who-ps-html and some initialization to run each time I create a thing, and its gotten slightly more elaborate since I started.

18 - [back] - Which I don't need to do anywhere.

19 - [back] -

Actually, as an aside to the aside, this change ended up giving me the expression

(aif ($exists? (+ ".new-deck.new-custom-deck[title='" deck-name "']"))
     ($ it (remove)))

in one particular place. The ($ it (remove)) just looks odd to me. And it's one of the reasons I've been defining $foo macros everywhere; my eyebrow wouldn't be raised at ($remove it) in the same way. I'm not going to go down the rabbit-hole of implementing that right now, but it would be fairly easiy to.

Sunday, September 15, 2013

Deal Journal - Interlude One -- A Treatise on the Design and Construction of Special-Purpose HTTP Servers using Common Lisp with a focus on Readability and Real-World Deployment

Just a heads up: you won't see any of the below code checked into the Deal repo quite yet. And production still uses the nginx PushStream module for its asynchronous needs, and will continue to do so either until I finish enough of the other tasks to pull back enough time to re-structure its server, or until the contest ends and I no longer have to worry about making fast forward progress. Once I get around to it though, yes the real, actual Deal server is going to use this approach. It'll still use nginx as a reverse proxy to make sure static files are being served as fast as possible, but it won't rely on external SSE machinery longer than it has to. Not that the machinery's bad, mind you. It just complicates deployment more than I'd like.

Why and When

Lets just get this out of the way. Yes, there already exist some pretty good general-purpose web servers written in Common Lisp. The reason you'd build your own is if you had a very particular purpose in mind. If you're out to host a vanilla web site, or a traditional stateless, HTML-emitting web application, you'd already have your bases covered. But imagine you were building an application that had a heavy focus on JSON-interaction and session-tracking, with built-in support for SSEs. Say for the sake of argument, something like a web-game. You probably could make one of the existing things work for you. If you tried hard enough, and were willing to hack in support for one or two things[1]. But as you can see by reading the define-handler mini-language I put together for Deal, using a general purpose server for such a specific task incurs complexity penalties that you could completely sidestep by building something minimal and specialized.

That's the point at which I'd start aiming for a goal like this. When using the existing, tested, reasonably-performing options is introducing conceptual and deployment complexity into my project. And, just in case you missed it, it is.

Gotchas

HTTP is old. A child of the mid-ninties. There are people alive and programming professionally today who were born after it was created. Lisp is a bit older. And I can only assume no one working on its standardization knew how big the web would actually get, so they made a couple choices that must have made sense to them, but that will annoy the fuck out of you if you need to generate valid HTTP responses from a CL application.

#\newline is a "platform independent line break", you see. It expands to #\linefeed, #\return or #\return #\linefeed depending on where and how you write it. And the format directive ~% outputs a #\newline. This is relevant because HTTP specifies terminators for header lines and request bodies as #\return #\linefeed, which means that if you were expecting an expression like (format stream "~a ~a~%~{~a~%~}~%~%~a~%~%" protocol response-code headers body) to output a valid response string, I have some news for you.

It's not particularly easy to do this sort of formatting with the format function, ironically. There aren't directives like ~% specified for crlf, or even for #\return and #\linefeed individually. About the best you can hope to do using the defaults is (format t "Hello world.~C~C" #\return #\linefeed), which is a shit sandwich if I ever saw one.

So. Step one, if you're going to be hacking on HTTP from lisp is to define a shortcut for that. It can either be something like

(defun crlf (&optional (stream *standard-output*))
  (write-char #\return stream)
  (write-char #\linefeed stream))

or it can be something like

(defconstant crlf (list #\return #\newline))

(defun cat (&rest things)
  (apply #'concatenate 'string things))

I'm not committed yet, and may just go with defining all of the above. The crlf function looks like it would be more useful for an approach where I tried to do as close to single-traversal output as possible, while the crlf constant/cat function pair looks like they'd be more useful for testing purposes. Like I said, they don't really get in each others' way, so "both" is not, in fact, an unreasonable choice.

That out of the way, lets spend just a moment discussing...

The Approach

As far as I can tell, there are two legitimate approaches to building an async server in Common Lisp.

  • First, you could install libevent-core-2.0 and libevent-extra-2.0, and make use of the cl-async bindings. This way seems to save you having to buffer messages yourself, and it probably provides better performance at the expense of a very mildly complicated deployment.
  • Second, you could go pure Lisp and build the whole thing out of usockets.

I'm taking that second approach in this article, but you can use the same theory to construct a cl-async-based equivalent without too much trouble.

Now Then

We're building a toy example. The simplest async server that can possibly be constructed while remaining worthy of the name. We're going to have three applicable handlers:

  • one to serve up a basic front end, which will use JavaScript to connect to our subscription handler and get future messages from our server
  • one to handle that subscription
  • one to trigger a message send to all existing listeners

nothing fancy like user-specified messages, or multiple channels, both of which will be fairly easy changes once you understand what the basic server structure is. To start with, we need to generate responses, which means tacking a body message onto some situation-dependent HTTP headers, and handling the above crlf problems elegantly. So, here are the basics:

(ql:quickload (list :cl-ppcre :usocket :cl-who :parenscript :babel))
(defpackage :ts-usocket (:use :cl :cl-ppcre :usocket :cl-who :parenscript :babel))
(in-package :ts-usocket)

(defvar crlf (list #\return #\linefeed))
(defparameter day-names '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
(defparameter month-names '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))

(defun http-date ()
  (multiple-value-bind (second minute hour date month year day-of-week dst-p tz)
      (get-decoded-time)
    (format nil "~a, ~a ~a ~a ~a:~a:~a GMT~@d"
            (nth day-of-week day-names) date
            (nth month month-names) year hour minute second (- tz))))

(defun cat (&rest seqs)
  (apply #'concatenate 'string seqs))

(defun response (&key (response-code "200 OK") (content-type "text/html") keep-alive? body)
  (cat "HTTP/1.1 " response-code crlf
       "Content-Type: " content-type "; charset=utf-8" crlf
       "Cache-Control: no-cache, no-store, must-revalidate" crlf
       (when keep-alive?
         (cat "Connection: keep-alive" crlf
              "Date: " (http-date) crlf
              "Expires: Thu, 01 Jan 1970 00:00:01 GMT" crlf))
       (when body 
         (cat "Content-Length: " (write-to-string (length body)) crlf crlf 
              body crlf)) 
       crlf))

crlf and cat are pretty self-explanatory. The response function is going to take some basic options, populated with sane defaults, and use them to generate appropriate HTTP headers. The http-date function just formats the current date in a particular format. In a real implementation, I'd probably end up ditching this one. Its presence/absence doesn't seem to make much of a difference, and it seems like it might be resource intensive[2]. Next up, lets set up our three responses:

(defparameter *channel* nil)

(defparameter interface
  (response 
   :body 
   (with-html-output-to-string (str nil :prologue t)
     (:html
      (:head (:title "Test page"))
      (:body
       (:div :id "console")
       (:script
        :type "text/javascript"
        (str (ps (defvar src (new (-event-source "/sub")))
                 (defun p (msg)
                   (let ((elem (chain document (get-element-by-id "console"))))
                     (setf (@ elem inner-h-t-m-l)
                           (+ (@ elem inner-h-t-m-l) "<p>" msg "</p>"))))
                 (setf (@ src onerror)
                       (lambda (e) 
                         (p "ERROR OCCURRED...")
                         (p (chain -j-s-o-n (stringify e))))
                       (@ src onopen)
                       (lambda (e) (p "STREAM OPENED..."))
                       (@ src onmessage)
                       (lambda (e) 
                         (p "GOT MESSAGE!")
                         (p (+ "data: " (@ e data)))))))))))))

(defun subscribe! (sock)
  (let ((s (socket-stream sock)))
    (write-string (response :keep-alive? t :content-type "text/event-stream") s)
    (force-output s)
    (push sock *channel*)))

(defun publish! (msg)
  (loop for sock in *channel*
     do (handler-case
            (ignore-errors
              (let ((s (socket-stream sock)))
                (write-string (cat "data: " msg crlf crlf) s)
                (force-output s)))
          (error (e)
            (format t "~s" e)
            (setf *channel* (remove sock *channel*))))))

The interface is just a flat file. We'll be sending out exactly the same one to anyone that asks for it, and it would be fairly resource-intensive to generate that each time, so I just cached the result of a response call. What you see in the ps there is a call to create a new EventStream, and calls to attach onopen, onerror and onmessage listeners to it. When the client trips any of those events, it'll add some relevant information to the innerHTML of a div with id console[3]. The subscribe! function sends headers appropriate for starting an SSE stream, calls force-output then pushes the relevant socket into *channel*. Finally, publish! takes a message and sends it out to each member of *channel*. If the write errors, the relevant socket is removed from *channel*.

Notice that we're doing literally everything so far in a very naive way. The http-date mechanics could be made much more efficient, or removed entirely with little negative effect, we're calling concatenate 'string like it's going out of style, and we're calling remove on each and every socket removal. It's just conceptually easier this way. Once we get to a reasonably well-tested server, we'll go back and make sure that we traverse messages as little as possible, writing directly where we can, and make sure to collect running sockets for re-assignment rather than incurring a traversal per removal. Maybe. If the end result doesn't profile well enough.

Don't worry about it for now. Next up is the actual handler.

(defmethod handle-request (socket request-uri)
  (let ((s (socket-stream socket)))
    (cond ((string= "/sub" request-uri)
           (subscribe! socket))
          ((string= "/pub" request-uri)
           (publish! (format nil "Got a message! ~a" (gensym)))
           (write-string (response 
                          :content-type "text/plain"
                          :body "Published!") s)
           (socket-close socket))
          (t
           (write-string interface s)
           (socket-close socket)))))

That'll do it. If we get a request for /sub, we just pass the socket off to the subscribe! function, and pointedly don't close it. If we get one for pub, we publish! a unique message, and send a small, token response to the current requester, then close the socket. Note that if we're closing the connection right away, we don't need to worry about force-output calls, since that automatically gets done on cleanup. Lastly, if we get a request for any other resource, we send out the interface we defined earlier.

We're almost done. We need exactly one more component; a piece that'll monitor a particular port, buffer incoming HTTP requests and call the handler when it gets a completed one.

(defvar *socket-handle* nil)

(defun stop ()
  (when *socket-handle*
    (loop while (socket-close *socket-handle*))
    (setf *socket-handle* nil
          *channel* nil)))

(defclass buffer ()
  ((contents :accessor contents :initform nil)
   (started :reader started :initform (get-universal-time))
   (state :accessor state :initform :empty)))

(defmethod buffered-read! (stream (buffer buffer))
  (loop for char = (read-char-no-hang stream nil :eof)
     until (or (null char) (eql :eof char))
     do (push char (contents buffer))))

(defmethod starts-with? ((prefix list) (list list) &optional (test #'eql))
  (loop for (p . rest-p) on prefix for (l . rest-l) on list
     when (or (and rest-p (not rest-l)) (not (funcall test p l))) 
     do (return nil)
     finally (return t)))

(defun start (port &optional (log-stream *standard-output*))
  (stop)  
  (setf *socket-handle* (socket-listen "127.0.0.1" port :reuse-address t))
  (let ((conns (list *socket-handle*))
        (buffers (make-hash-table)))
    (loop (loop for ready in (wait-for-input conns :ready-only t)
                do (if (typep ready 'stream-server-usocket)
                       (push (socket-accept ready) conns)
                     (let ((buf (gethash ready buffers (make-instance 'buffer))))
                       (buffered-read! (socket-stream ready) buf)
                       (when (starts-with? (list #\newline #\return #\newline #\return)
                                           (contents buf))
                         (format log-stream "COMPLETE ~s~%"
                                 (coerce (reverse (contents buf)) 'string))
                         (setf conns (remove ready conns))
                         (remhash ready buffers)
                         (let ((parsed (parse buf)))
                           (format log-stream "PARSED: ~s~%" parsed)
                           (handle-request ready (parse buf))))))))))

Ok, I may have gone a little overboard in defining starts-with? myself, since there's a similar one already available as part of the library called alexandria, but you get the idea. stop stops our listener explicitly because usocket doesn't free up the socket it's listening on if it errors out, and it also clears out *channel* for the next go.

The buffer class and accompanying buffered-read! procedure are going to make the job of collecting possibly chunked requests easier, and starts-with? does exactly what it says on the tin. It walks a list and a prefix, comparing for equality element-wise by a user-specified predicate, and it keeps going until

  • it finds a predicate failure (in which case, it returns nil)
  • the list runs out before the prefix (in which case it returns nil again)
  • the prefix runs out (in which case it returns t)

The last piece is the meat. The start function is going to take a port and a log-stream, and listen on that port while dumping logging data to log-stream. Lets take this one slow.

...
  (setf *socket-handle* (socket-listen "127.0.0.1" port :reuse-address t))
...

That sets up the listener on localhost listening on the specified port and ensures *socket-handle* is a reference to that listener.

...
  (let ((conns (list *socket-handle*))
        (buffers (make-hash-table)))
...

That initializes conns to be a list whose only element is the listener we just set up. It also sets up a blank hash-table called buffers.

...
    (loop (loop for ready in (wait-for-input conns :ready-only t)
...

We're setting up an infinite loop here. And on each iteration, we're going to wait for some of the sockets in conns to need attention, at which point we will iterate through all ready sockets to give it some attention.

...
                do (if (typep ready 'stream-server-usocket)
                       (push (socket-accept ready) conns)
...

If the ready socket is a stream-server, that means it has a new listener wanting to connect to our server. We push the newcomer onto conns; its request will be handled when it becomes ready.

...
                     (let ((buf (gethash ready buffers (make-instance 'buffer))))
                       (buffered-read! (socket-stream ready) buf)
                       (when (starts-with? (list #\newline #\return #\newline #\return)
                                           (contents buf))
                         (format log-stream "COMPLETE ~s~%"
                                 (coerce (reverse (contents buf)) 'string))
                         (setf conns (remove ready conns))
                         (remhash ready buffers)
                         (let ((parsed (parse buf)))
                           (format log-stream "PARSED: ~s~%" parsed)
                           (handle-request ready (parse buf))))))))))

If it's not a stream-server, that means it's a regular usocket, which means that it has some data ready for us to read. If we wanted to be extremely naive here, we'd just call read-line repeatedly, but just because some data is ready doesn't mean that it represents a complete HTTP request. If the client on the other end is particularly slow, or has a particularly large request to make, it might arrive in chunks. Lets go through that step-by-step.

...
                     (let ((buf (gethash ready buffers (make-instance 'buffer))))
                       (buffered-read! (socket-stream ready) buf)
                       (when (starts-with? (list #\newline #\return #\newline #\return)
                                           (contents buf))
...

We're either getting this particular connections' buffer (if one exists), or assigning it a fresh buffer. We're then calling buffered-read! which will result in the contents of that buffer getting filled with all data available for reading from the ready socket. If that data ends with a reversed crlf crlf, we should do something about it. As a Note to Self here, if it doesn't we should make sure that the buffered data doesn't exceed some pre-determined threshold and that this particular request hasn't been around for too long. buffer already has a started slot, we'll just need to check it and evict ones that get too old.

...
                         (format log-stream "COMPLETE ~s~%"
                                 (coerce (reverse (contents buf)) 'string))
                         (setf conns (remove ready conns))
                         (remhash ready buffers)
                         (let ((parsed (parse buf)))
                           (format log-stream "PARSED: ~s~%" parsed)
                           (handle-request ready (parse buf))))))))))

If we have a complete HTTP request, we emit some logging data, remove that socket from conns and its buffer from buffers, since we won't be reading from it again one way or the other, then call handle-request, passing along the socket and the result of calling parse on the buffer. Eventually, parse should provide a tree of relevant data such as POST/GET requests and all incoming headers, but for right now, we just care about one property of the incoming request.

(defmethod parse ((buf buffer))
  (let ((lines (split "\\r?\\n" (coerce (reverse (contents buf)) 'string))))
    (second (split " " (first lines)))))

That'll return the request uri of a well-formed, incoming HTTP request. handle will then run it through that logic we set up earlier to decide what is to be done.

And that's that. Assuming I've actually got the SSE points ironed out, and we'll see what the mailing lists say on that score, we have a very minimal asynchronous HTTP server built in just under 150 lines of un-obfuscated Common Lisp.

(ql:quickload (list :cl-ppcre :usocket :cl-who :parenscript :babel))
(defpackage :ts-usocket (:use :cl :cl-ppcre :usocket :cl-who :parenscript :babel))
(in-package :ts-usocket)

(defvar *socket-handle* nil)
(defparameter *channel* nil)
(defvar crlf (list #\return #\linefeed))

(defun stop ()
  (when *socket-handle*
    (loop while (socket-close *socket-handle*))
    (setf *socket-handle* nil
          *channel* nil)))

(defun start (port &optional (log-stream *standard-output*))
  (stop)  
  (setf *socket-handle* (socket-listen "127.0.0.1" port :reuse-address t))
  (let ((conns (list *socket-handle*))
        (buffers (make-hash-table)))
    (loop (loop for ready in (wait-for-input conns :ready-only t)
                do (if (typep ready 'stream-server-usocket)
                       (push (socket-accept ready) conns)
                     (let ((buf (gethash ready buffers (make-instance 'buffer))))
                       (buffered-read! (socket-stream ready) buf)
                       (when (starts-with? (list #\newline #\return #\newline #\return)
                                           (contents buf))
                         (format log-stream "COMPLETE ~s~%"
                                 (coerce (reverse (contents buf)) 'string))
                         (setf conns (remove ready conns))
                         (remhash ready buffers)
                         (let ((parsed (parse buf)))
                           (format log-stream "PARSED: ~s~%" parsed)
                           (handle-request ready (parse buf))))))))))

(defmethod handle-request (socket request-uri)
  (let ((s (socket-stream socket)))
    (cond ((string= "/sub" request-uri)
           (subscribe! socket))
          ((string= "/pub" request-uri)
           (publish! (format nil "Got a message! ~a" (gensym)))
           (write-string (response 
                          :content-type "text/plain"
                          :body "Published!") s)
           (socket-close socket))
          (t
           (write-string interface s)
           (socket-close socket)))))

(defun publish! (msg)
  (loop for sock in *channel*
     do (handler-case
            (ignore-errors
              (let ((s (socket-stream sock)))
                (write-string (cat "data: " msg crlf crlf) s)
                (force-output s)))
          (error (e)
            (format t "~s" e)
            (setf *channel* (remove sock *channel*))))))

(defun subscribe! (sock)
  (let ((s (socket-stream sock)))
    (write-string (response :keep-alive? t :content-type "text/event-stream") s)
    (force-output s)
    (push sock *channel*)))

(defclass buffer ()
  ((contents :accessor contents :initform nil)
   (started :reader started :initform (get-universal-time))
   (state :accessor state :initform :empty)))

(defmethod buffered-read! (stream (buffer buffer))
  (loop for char = (read-char-no-hang stream nil :eof)
     until (or (null char) (eql :eof char))
     do (push char (contents buffer))))

(defmethod parse ((buf buffer))
  (let ((lines (split "\\r?\\n" (coerce (reverse (contents buf)) 'string))))
    (second (split " " (first lines)))))

(defun response (&key (response-code "200 OK") (content-type "text/html") keep-alive? body)
  (cat "HTTP/1.1 " response-code crlf
       "Content-Type: " content-type "; charset=utf-8" crlf
       "Cache-Control: no-cache, no-store, must-revalidate" crlf
       (when keep-alive?
         (cat "Connection: keep-alive" crlf
              "Date: " (http-date) crlf
              "Expires: Thu, 01 Jan 1970 00:00:01 GMT" crlf))
       (when body 
         (cat "Content-Length: " (write-to-string (length body)) crlf crlf 
              body crlf)) 
       crlf))

(defun cat (&rest seqs)
  (apply #'concatenate 'string seqs))

(defparameter interface
  (response 
   :body 
   (with-html-output-to-string (str nil :prologue t)
     (:html
      (:head (:title "Test page"))
      (:body
       (:div :id "console")
       (:script
        :type "text/javascript"
        (str (ps (defvar src (new (-event-source "/sub")))
                 (defun p (msg)
                   (let ((elem (chain document (get-element-by-id "console"))))
                     (setf (@ elem inner-h-t-m-l)
                           (+ (@ elem inner-h-t-m-l) "<p>" msg "</p>"))))
                 (setf (@ src onerror)
                       (lambda (e) 
                         (p "ERROR OCCURRED...")
                         (p (chain -j-s-o-n (stringify e))))
                       (@ src onopen)
                       (lambda (e) (p "STREAM OPENED..."))
                       (@ src onmessage)
                       (lambda (e) 
                         (p "GOT MESSAGE!")
                         (p (+ "data: " (@ e data)))))))))))))

(defmethod starts-with? ((prefix list) (list list) &optional (test #'eql))
  (loop for (p . rest-p) on prefix for (l . rest-l) on list
     when (or (and rest-p (not rest-l)) (not (funcall test p l))) 
     do (return nil)
     finally (return t)))

(defparameter day-names '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
(defparameter month-names '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))

(defun http-date ()
  (multiple-value-bind (second minute hour date month year day-of-week dst-p tz)
      (get-decoded-time)
    (format nil "~a, ~a ~a ~a ~a:~a:~a GMT~@d"
            (nth day-of-week day-names) date
            (nth month month-names) year hour minute second (- tz))))

Loading that into your repl, then evaluating

(in-package :ts-usocket)
(start 3000)

should start that minimal server on your local port 3000. At which point you can go to http://localhost:3000 in one browser, and hit http://localhost:3000/pub twice in another to see output like

STREAM OPENED...

GOT MESSAGE!

data: Got a message! G1042

GOT MESSAGE!

data: Got a message! G1043

If you keep hammering F5 on localhost:3000/pub, you'll see new messages streaming into the listening window. Once I've gotten this tested, and worked out the kinks, I'll be able to use it to radically simplify the deployment process for the Deal project.

What you don't see above is an implementation of sessions, or very many performance optimizations, but there's a reason I titled this "Interlude Part 1".


Footnotes

1 - [back] - Of the three I linked, Araneida has been superseded by Hunchentoot, Hunchentoot works on a thread-per-request model so you'd need to add SSE/websockets/what-have-you support, and Wookie doesn't have sessions (or very good performance, apparently) out of the box.

2 - [back] - To be fair, I probably could put together a system that just generates one per second, and sends that pre-serialized version to each endpoint. That would, at least, save me the effort of having to generate it per-user, but it would complicate things.

3 - [back] - In case you're wondering, the main reason I didn't just console.log is that I happen to use a browser that doesn't have very good console facilities. Or leastwise, it didn't when I last installed it.

Saturday, September 7, 2013

Deal Journal - Part Two

This is part two of the journal for the Deal project. Part one can be found here.

Day 44

I've been pouring time into the thing, as you can see by taking a look at the code contribution graphs. I'm trying desperately to keep the JS as terse and understandable as possible, but I'm running into challenges all over the place. If I wasn't writing Lisp, I'd probably have given up by now. Which is not to say that its been easy in Lisp. Mistakes have been made and rolled back, rest assured, and I still need to take a second look at the SSE/chat system to make it as DRY as possible. I currently have a very similar structure repeating in three places, which means its time to factor that out.

Here are a couple of close-ups on things I already changed:

(defpsmacro $keypress (target &rest key/body-pairs)
  `($ ,target
      (keypress
       (lambda (event)
         (let ((shift? (@ event shift-key))
               (alt? (@ event alt-key))
               (ctrl? (@ event ctrl-key))
               (meta? (@ event meta-key))
               (<ret> 13) (<esc> 27) (<space> 32) 
               (<up> 38) (<down> 40) (<left> 37) (<right> 39))
           (cond ,@(loop for (key body) on key/body-pairs by #'cddr
                      collect `((= (@ event which) ,(if (stringp key) `(chain ,key (char-code-at 0)) key)) ,body))))))))

That's a function for simplifying $("foo").keypress() use. It doesn't simplify the call itself much, but it handles looking up some common keycodes for me. This is the shittily performing version; if I really felt like it, I could have it substitute literals at macro-expansion time rather than doing a run-time let. Hm. In fact, Note To Self.

Next up:

(defpsmacro $droppable (target (&key overlapping) &rest class/action-list)
  `($ ,target
      (droppable 
       (create 
        :drop (lambda (event ui)
                (let ((dropped (@ ui helper context))
                      (shift? (@ event shift-key)))
                  (cond ,@(loop for (class action) in class/action-list
                             collect `(($ dropped (has-class ,class)) ,action)))))
        ,@(when overlapping
                `(:over (fn ($ ,overlapping (droppable "disable")))
                  :out (fn ($ ,overlapping (droppable "enable")))))))))

$droppable got a bit of a face-lift due to the way overlapping jQuery droppables interact with one another. Specifically, they all trigger. If you don't want that, you have to write a couple of lines of code to disable potentially overlapping droppables so as not to trigger them. This is a "good-enough" solution, but I'm still wondering if the HTML5 droppable interface handles this situation better.

(defpsmacro $draggable (target (&key revert handle cancel) &body body)
  `($ ,target (draggable (create :stop (lambda (event ui) 
                                         (let ((shift? (@ event shift-key)))
                                           ,@body))
                                 ,@(when revert `(:revert ,revert))
                                 ,@(when handle `(:handle ,handle))
                                 ,@(when cancel `(:cancel ,cancel))))))

Finally, $draggable got the tiny addition of an injected binding of shift?, just because I use it in a few places. Really, I should probably be consistent with these and bind similar symbols for all the modifier keys. That's something I'll change for the versions of these functions that end up getting dropped into cl-web-dev

The back-end isn't going to get any more complicated. In fact, now that I've gotten the chance to test drive the result a few times, I'm probably going to aggressively cut features from it. Every change made to deal.lisp since last time has been either a bug fix, a clearer and simpler way to say something, or a change to parameter bounds. Specifically, it came to my attention that rolling 4096 dice at once created a message big enough to choke the push-stream module, so I limited players to rolling only 128 dice at a time.

Tons of the features I wanted got put together in the last couple of days. The front-end is now good enough that I'm seriously considering starting in on the deck/board builder rather than adding more stuff. There's nice-to-haves, obviously, but nothing that'll outright prevent any game I can think of from being played.

Day 45

Didn't get as much work done as I was hoping today. The lack of sleep is finally taking its toll, I think. Hopefully I can catch up on some rest this weekend, then move on to the deck/setup editor, then get to polishing the fuck out of all of it. I did a bit of that. Little things like

  • the ability to shuffle
  • changed the thought process behind stacks[1]
  • fixing some bugs that don't seem to have bitten yet, but would have in pretty short order

but nothing major.

One thing I wanted to point out explicitly, just to convince you that I'm serious about this "clarity" thing:

inaimathi@lambda:~$ cd projects/deal/
inaimathi@lambda:~/projects/deal$ wc -l *lisp model/*lisp deal-ui/*lisp *asd
  197 deal.lisp
  124 define-handler.lisp
   24 package.lisp
   32 start.lisp
   81 util.lisp
   68 model/server.lisp
  123 model/table.lisp
   96 deal-ui/css.lisp
  461 deal-ui/deal-ui.lisp
    4 deal-ui/package.lisp
  150 deal-ui/pQuery.lisp
   46 deal-ui/util.lisp
   14 deal.asd
   15 deal-ui.asd
 1435 total
inaimathi@lambda:~/projects/deal$ 

We're at ~1500 lines, and not terribly likely to crack 2000, and we've got a pretty feature-full little play-testing tool to show for it.

Day I've lost track. And actually, these have been bullshit for a while. It's August 31st though, so maybe I just start counting from the end now? Yeah, ok, lets do that.

T minus 30 days

It's amazing what a little sleep will accomplish. I haven't written any more code, but I've got the shape of the deck/board editor in my head.

Basically, it'll be an interface where users can specify collections of cards in text or JSON format. Those collections will then be added to their decks pane, at which point they can add it to the table. Each deck will also get a download button, which will let the user save that particular deck in a JSON format suitable for uploading later.

Before a second player joins a game, there will be a save button somewhere on the toolbar, and clicking it will let the user download a chunklet of JSON that represents everything on the board. The "new table" window will also gain a new upload button which will let the user upload a start file, and start the game off with the specified items pre-arranged on the board. We want this dump to contain everything. That is, all the information about things on the board, including the contents slots of face-down cards, and the list of cards inside of all stacks in play. That means we can't let the user randomly save out state; they could use it to cheat at the game[2].

Now, because a goal of this project is zero authentication, and because I want it to be inherently distributed, I can't just save all this stuff on the server side. The client actually needs to store their own games and start files, and upload them when they need to use them. This makes certain seemingly uncommon things very slightly clunkier, but it lets a given user freely switch browsers and servers whenever they like, rather than being bound to a single instance of Deal.

Also, because I'm not going to be serializing everything in these dumps[3], the complete system will actually need three different ways of outputting its internal data structures:

  • one that leaves out any private information, such as the contents of stacks, or the text on face-down cards. This one is already implemented as the redact method
  • one that keeps private information, but strips anything game-specific, such as IDs and belongs-to slots. This is what I'm discussing for the save feature; it should be possible to use these to instantiate a particular object or board in a different game. Not sure what to call it, but it's named serialize for the moment. Maybe save or something?
  • one that keeps everything. This is the one I'll be using to store logs and replays later. It needs all the information about a particular game, its result shouldn't be available until after a game is concluded, and the board should have an additional piece of data attached to describe its starting position.

T minus 29 days

Something odd started going wrong recently, and I had to sit down to puzzle through it. It turned out to be an odd corner of how cl-json handles encoding lists. See, because a list might represent an alist, a plist or just a vanilla list, there's ambiguity in terms of how to encode it. The way that this seems to be handled is with an error/backtrack strategy that tries each option and sees what it comes up with. The trouble with that when you're serializing things that look something like

`((TYPE . :TABLE) (ID . :G2444) (TABLECLOTH)
  (THINGS ((:G2523 (TYPE . :STACK) (ID . :G2523) (X . 677) (Y . 461) (Z . 0) (ROT . 0)
                   (BELONGS-TO . :G2443) (CARD-COUNT . 78) (CARD-TYPE . :OCCULT-TAROT))
           (:G2578 (TYPE . :STACK) (ID . :G2578) (X . 705) (Y . 259) (Z . 0) (ROT . 0)
                   (BELONGS-TO . :G2443) (CARD-COUNT . 54) (CARD-TYPE . :FRENCH))
           (:G2619 (TYPE . :STACK) (ID . :G2619) (X . 815) (Y . 358) (Z . 0) (ROT . 0)
                   (BELONGS-TO . :G2443) (CARD-COUNT . 40) (CARD-TYPE . :N-ITALIAN)))
          (PLAYERS ((ID . :G2443) (HAND . 0)))
          (HISTORY
           ((TIME . 3587036264) (TYPE . :NEW-DECK) (PLAYER . :G2443)
            (PLAYER-TAG . "Anonymous Coward") (NAME . "Northern Italian")
            (STACK (TYPE . :STACK) (ID . :G2619) (X . 815) (Y . 358) (Z . 0) (ROT . 0)
                   (BELONGS-TO . :G2443) (CARD-COUNT . 40) (CARD-TYPE . :N-ITALIAN)))
           ((TIME . 3587036262) (TYPE . :NEW-DECK) (PLAYER . :G2443)
            (PLAYER-TAG . "Anonymous Coward") (NAME . "54-Card Standard")
            (STACK (TYPE . :STACK) (ID . :G2578) (X . 705) (Y . 259) (Z . 0) (ROT . 0)
                   (BELONGS-TO . :G2443) (CARD-COUNT . 54) (CARD-TYPE . :FRENCH)))
           ((TIME . 3587036259) (TYPE . :NEW-DECK) (PLAYER . :G2443)
            (PLAYER-TAG . "Anonymous Coward") (NAME . "Occult Tarot")
            (STACK (TYPE . :STACK) (ID . :G2523) (X . 677) (Y . 461) (Z . 0) (ROT . 0)
                   (BELONGS-TO . :G2443) (CARD-COUNT . 78) (CARD-TYPE . :OCCULT-TAROT))))))

With, maybe, a few more levels in a couple of places, the error/backtrack strategy ends up bottoming out your error depth. Even if you use encode-json-alist instead of the standard encode-json, the library seems to guess what it needs to do separately for each element of each level. Also, I'm not sure whether it's how I have Hunchentoot configured or whatever, but for some reason, this error would immediately be ignored in REPL. I had to really be paying attention to catch the flicker of error depth exceeded pass by SLIME. The only real symptom I could detect was otherwise unexplained 502 errors on the client side, which is why it took me a few hours to figure out what was actually happening.

The solution ended up being fairly easy to implement: just use hashes everywhere. Because those are unambiguous to encode into JSON, they won't incur the same guessing damage. So even though I've got a feeling they're heavier than alists, they'll avoid a whole lot of unnecessary work later. Of course, since Common Lisp doesn't have good built-in syntax for writing hashes, I had to write my own.

(defmacro hash (&rest k/v-pairs)
  (with-gensyms (hash-table)
    `(let ((,hash-table (make-hash-table)))
       ,@(loop for (k v) on k/v-pairs by #'cddr
            collect `(setf (gethash ,k ,hash-table) ,v))
       ,hash-table)))

Which lets me redefine the redact methods to emit hash tables rather than alists, like so:

(defmethod redact ((stack stack))
  (with-slots (id x y z rot belongs-to card-count card-type) stack
    (hash :type :stack :id id :x x :y y :z z :rot rot
          :belongs-to belongs-to
          :card-count card-count
          :card-type card-type)))

That's still begging for some better syntax, of course. Its already bitten me once; I wrote the card emitter and forgot to have it encode the id slot, which ended up preventing cards from being interacted with on the front-end. Anyhow, that's fixed. Hopefully.

The other thing I managed to do was put together a very minimal little system for creating custom decks. Which means that after I hack in the intentionally limited game-state save/load feature, this will officially be a capable playtesting and prototyping tool. Wish me luck.

T minus 28 days: wee hours of the morning

It's about 1:20 right now, and I managed to put a few more hours in. The latest codebase up at github has a working, if ugly, upload system. That is, while you're the only one in your game, you can set stuff up, save a game.json file, and load it up again later to replicate your earlier setup. It looks like the web hasn't been sitting still after all, by the way. Whereas the server-push situation still sucks a bag of donkey dongs, file uploading now sucks only a single such dong. Two at the outside. You can do asynchronous file uploads fairly simply, provided you're willing to live with only supporting HTML5 browsers, and trust me, I am. Having put that together, this is technically a finished playtesting/prototyping tool for tabletop card games. There's still a bunch of polish I want to put on it, patches welcome by the by, and I still want to make a few things make slightly more sense, and I really want to make some parts of the tool prettier before I start promoting it publicly, but even Deal as it stands is now enough to do the prototype work which was ostensibly the point of the project.

T minus 23 days

I just finished the single biggest commit since the start of this project. It... well, here, I'll just read you the log message.

16fb9532 * origin/master 
         | Author: inaimathi <inaimathi@lambda>
         | Date:   Sat Sep 7 20:53:26 2013 -0400
         | 
         |     Easily the biggest commit yet
         |     
         |     -Added cl-fad to dependency list
         |     -minis are now implemented (still no custom minis; working on it)
         |     -tablecloths are now implemented (still no custom tableclblah blah blah)
         |     -fixed droppable bug related to window scrolling. Not pixel-precise, but I think this is as close as we're gonna get
         |     -fixed droppable bug which kept competing droppables disabled even after a droppable event was completed
         |     -added go-board tablecloth
         |     -added chess-board tablecloth
         |     -added chess/checkers/go/chinese-checkers minis
         |     -added all relevant images
         |     -dragging a card/mini/stack to your backpack now removes it from play (may want to keep this at just minis. Might get a bit confusing otherwise)
         |     -chat history is now tracked in-cookie for completion purposes
         |     -player tag is now tracked in-cookie for completion purposes
         |     -dice counts for rolling icons in backpack are now tracked in-cookie for ease of use (I still prefer rolling via the @roll command)
         |     -position of zoomed card and table-toolbar is now tracked in-cookie for ease of use
         |     -did I mention we had zoomed cards now? We have zoomed cards now.

Not mentioned is the addition of an actual license[4], but I won't dwell on that.

Minis now actually work. Ditto tablecloths. Which means you can now effectively play chess, checkers and go in deal, which was a not-entirely-unintended side-effect of building a general-purpose tabletop game simulator. That's all up, by the way. You can play around with it now.

The big stuff that still needs to get done, as far as I'm concerned, is in order of priority

  • some UI-tweaking regarding the chat, tablecloths, dice interface, stacks (which are still ugly as sin) and deck editing
  • cookie-ing of custom decks
  • the ability to specify custom tablecloths and minis, and cookie-fying those too
  • a bunch of re-factoring and code contraction related to various wordy and common patterns that cropped up in deal-ui

that's basically it though. And all of those things deal with the front-end, which I've already mentioned, should really be thought of as "the reference UI implementation" rather than "the UI". The intent is for people to be able to put together their own specialized, possibly game-specific user interfaces, and run them against the same back-end server.

That's the elephant in the room at the moment, by the way. The server is currently much, much harder to set up than I'd like. The main reason is the separation of SSEs from the rest of the application. Since that involves a non-standard nginx module, it means any potential user needs to compile their own nginx, then perform some non-trivial, and not-easily-automated setup before anything starts working. Ideally, that would all be handled by the application. Which means that, after the contest ends, I've got two options:

  • write a custom, high-performance asynchronous web server for Common Lisp
  • re-write the server-side of the application in a language that already has such a server. Most likely candidates being Haskell and Erlang

Neither will be too much of a challenge.

If I go the server route, there's no reason whatsoever for me to put together a general-purpose web server. All it'll have to do is handle stream publishing, and serve static files faster than it would take to type them manually[5].

On the other hand, the complete back-end including asds, config files and the entire define-handler DSL weighs in at 805 lines of code[6], so I can't see it being exceedingly difficult to port over. I could see either Haskells' assorted type-system bullshittery or Erlangs' built-in bureaucracy adding another couple hundred lines, but 1000 total is still nothing to worry about in the grand scheme of things. Especially since it would end up letting potential users run the fucker without compiling anything themselves.


Footnotes

1 - [back] - That'll necessitate interacting with multiple cards in the future, but it's the better alternative, I think.

2 - [back] - Of course, it is possible to just log this event to history to make everyone aware of the possibility, so it might work either way.

3 - [back] - In particular, they'll be leaving out any id and belongs-to slots.

4 - [back] - The AGPL, surprise, surprise.

5 - [back] - The assumption being that it should be able to support small custom servers, and that if someone wants to serve several thousand people, they should use a reverse proxy and serve static files that way anyhow.

6 - [back] - In case you were wondering, yes, I take the Yegge quote to heart.

Large systems suck. This rule is 100% transitive. If you build one, you suck. SteveY