Merge branch 'master' into hoon-spot

.gitignore

@@ -9,6 +9,9 @@ tags
 TAGS
 cross/
 release/
+.stack-work
+\#*\#
+s/*
 **/.DS_Store
 **/dist
 **/node_modules
@@ -16,4 +19,5 @@ release/
 **/*.swp
 **/*.swo
 **/*-min.js
+.stack-work
 pkg/interface/link-webext/web-ext-artifacts

.ignore

@@ -0,0 +1,3 @@
+.stack-work
+./pkg/hs-vere/.stack-work
+./pkg/hs-urbit/.stack-work

.stylish-haskell.yaml

@@ -0,0 +1,84 @@
+steps:
+  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
+  # by default.
+  # - unicode_syntax:
+  #     # In order to make this work, we also need to insert the UnicodeSyntax
+  #     # language pragma. If this flag is set to true, we insert it when it's
+  #     # not already present. You may want to disable it if you configure
+  #     # language extensions using some other method than pragmas. Default:
+  #     # true.
+  #     add_language_pragma: true
+
+  - simple_align:
+      cases: true
+      top_level_patterns: true
+      records: true
+
+  # Import cleanup
+  - imports:
+      align: group
+      list_align: after_alias
+      pad_module_names: true
+      long_list_align: inline
+      empty_list_align: inherit
+      list_padding: 4
+      separate_lists: false
+      space_surround: false
+
+  - language_pragmas:
+      style: vertical
+      align: true
+      remove_redundant: true
+
+  - tabs:
+      spaces: 4
+
+  - trailing_whitespace: {}
+
+  # squash: {}
+
+columns: 80
+
+newline: lf
+
+language_extensions:
+  - ApplicativeDo
+  - BangPatterns
+  - BlockArguments
+  - DataKinds
+  - DefaultSignatures
+  - DeriveAnyClass
+  - DeriveDataTypeable
+  - DeriveFoldable
+  - DeriveGeneric
+  - DeriveTraversable
+  - DerivingStrategies
+  - EmptyDataDecls
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - GADTs
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - MagicHash
+  - MultiParamTypeClasses
+  - NamedFieldPuns
+  - NoImplicitPrelude
+  - NumericUnderscores
+  - OverloadedStrings
+  - PartialTypeSignatures
+  - PatternSynonyms
+  - QuasiQuotes
+  - Rank2Types
+  - RankNTypes
+  - RecordWildCards
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TemplateHaskell
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - TypeOperators
+  - UnboxedTuples
+  - UnicodeSyntax
+  - ViewPatterns

.travis.yml

@@ -1,20 +1,45 @@
-language: nix
-nix: 2.1.3
+jobs:
+  include:
+  - os: linux
+    language: nix
+    nix: 2.1.3
+    env: STACK_YAML=pkg/hs/stack.yaml
+    before_install:
+      - git lfs pull
+      - sh/travis-install-stack
 
-install:
-  - nix-env -iA cachix -f https://cachix.org/api/v1/install
+    install:
+      - nix-env -iA cachix -f https://cachix.org/api/v1/install
+      - stack --no-terminal --install-ghc build urbit-king --only-dependencies
 
-before_install:
-  - git lfs pull
+    script:
+      - cachix use urbit2
+      - ./sh/cachix
+      - make build
+      - make release
+      - sh/release-king-linux64-dynamic
+      - sh/ci-tests
 
-script:
-  - cachix use urbit2
-  - ./sh/cachix || true
+  - os: osx
+    language: generic
+    sudo: required
+    env: STACK_YAML=pkg/hs/stack.yaml
 
-  - make
-  - make release
+    before_install:
+      - sh/travis-install-stack
 
-  - sh/ci-tests
+    install:
+      - stack --no-terminal --install-ghc build urbit-king --only-dependencies
+
+    script:
+      - sh/release-king-darwin-dynamic
+
+cache:
+  directories:
+  - $HOME/.ghc
+  - $HOME/.cabal
+  - $HOME/.stack
+  - $TRAVIS_BUILD_DIR/.stack-work
 
 deploy:
   - skip_cleanup: true

MAINTAINERS.md

@@ -5,9 +5,9 @@
 Here lies an informal guide for making hotfix releases and deploying them to
 the network.
 
-Take [this recent PR][1], as an example.  This constituted a great hotfix.
-It's a single commit, targeting a problem that existed on the network at the
-time.  Here's it should be released and deployed OTA.
+Take [this PR][1], as an example.  This constituted a great hotfix.  It's a
+single commit, targeting a problem that existed on the network at the time.
+Here's it should be released and deployed OTA.
 
 [1]: https://github.com/urbit/urbit/pull/2025
 
@@ -16,14 +16,9 @@ time.  Here's it should be released and deployed OTA.
 Unless it's very trivial, it should probably have a single "credible looking"
 review from somebody else on it.
 
-You can just merge the PR in GitHub.  As I, `~nidsut-tomdun`, am a l33t
-h4x0r, I use a custom merge commit format, gotten by:
-
-```
-git merge --no-ff --signoff --log BRANCH
-```
-
-with the commit message:
+You should avoid merging the PR in GitHub directly.  Instead, use the
+`sh/merge-with-custom-msg` script -- it will produce a merge commit with
+message along the lines of:
 
 ```
 Merge branch FOO (#PR_NUM)
@@ -32,21 +27,29 @@ Merge branch FOO (#PR_NUM)
   bar: ...
   baz: ...
 
-Signed-off-by: Jared Tobin <jared@tlon.io>
+Signed-off-by: SIGNER <signer@example.com>
 ```
 
-All this extra wankery is hardly required, but IMO it's nice to have the
-commit log information in the merge commit, which GitHub's "Merge PR" button
-doesn't do (at least by default).
+We do this as it's nice to have the commit log information in the merge commit,
+which GitHub's "Merge PR" button doesn't do (at least by default).
+`sh/merge-with-custom-msg` performs some useful last-minute urbit-specific
+checks, as well.
 
-The script at `sh/merge-with-custom-message` can be used to make this simple(r)
-to do.  I use `git mu` as an alias for it, locally.
+You might want to alias `sh/merge-with-custom-msg` locally, to make it easier
+to use.  My .git/config contains the following, for example:
+
+```
+[alias]
+        mu = !sh/merge-with-custom-msg
+```
+
+so that I can type e.g. `git mu origin/foo 1337`.
 
 ### Apply the changes to this era's release branch
 
-This corresponds to the 'vx.y' part of the most recent 'urbit vx.y.z' release.
-At the time of writing, we're on v0.10 (and I'll use this branch as a running
-example):
+For now, the release branch corresponds to the `vx.y` part of the most recent
+Vere release (i.e., `urbit vx.y.z`).  At the time of writing, we're on v0.10
+(and I'll use this branch as a running example):
 
 If the branch doesn't yet exist, just create it via:
 
@@ -55,8 +58,8 @@ git checkout -b v0.10 master
 ```
 
 If you can get away with merging master to v0.10 without pulling in any
-superfluous commits, feel free to do that.  Otherwise, you'll want to cherry
-pick the commits like so:
+superfluous or non-OTA-able commits, feel free to do that.  Otherwise, you'll
+want to cherry pick the commits like so:
 
 ```
 git cherry-pick -x TARGET_COMMITS
@@ -65,12 +68,43 @@ git cherry-pick -x TARGET_COMMITS
 Use the `-x` flag to `git-cherry-pick`, because this will indicate in the
 commit message where the things originally came from.
 
+A useful technique is to cherry-pick merge commits on master directly.  Take
+following commit, for example:
+
+```
+commit 769996d09
+Merge: 171fcbd26 8428f0ab1
+Author: Jared Tobin <jared@tlon.io>
+Date:   Sun Feb 2 19:11:04 2020 +0400
+
+    Merge branch 'liam-fitzgerald/langserver-doc-autocomplete' (#2204)
+
+    * liam-fitzgerald/langserver-doc-autocomplete:
+      language-server: magic-spoon hover, autocomplete
+      language-server: build ford prelude
+      language-server: dynamically compute subject
+      language-server: revive rune/symbol completion
+      language-server: add completion JSON parsers
+
+    Signed-off-by: Jared Tobin <jared@tlon.io>
+```
+
+rather than cherry-picking the individual commits, one could just use the
+following while on the release branch:
+
+```
+git cherry-pick -x -m 1 769996d09
+```
+
+you can check the man page for `git-cherry-pick(1)` for details here.
+
 Create Landscape or alternative pill builds, if or as appropriate (i.e., if
-anything in Landscape changed -- don't trust the compiled JS/CSS that's
+anything in Landscape changed -- don't trust any compiled JS/CSS that's
 included in the commit).
 
-You may also want to create a brass pill, in particular, as it's convenient for
-tooling to be able to boot directly from a given release.
+You should always create a solid pill, in particular, as it's convenient for
+tooling to be able to boot directly from a given release.  If you're making a
+Vere release, just play it safe and update all the pills.
 
 ### Tag the resulting commit
 
@@ -106,8 +140,7 @@ You can get the "contributions" section by the shortlog between the
 last release and this release:
 
 ```
-git log --pretty=short --no-merges \
-  LAST_RELEASE..v0.10 | git shortlog
+git log --pretty=short LAST_RELEASE.. | git shortlog
 ```
 
 I originally tried to curate this list somewhat, but now just paste it
@@ -121,7 +154,7 @@ If the commit descriptions are too poor to easily do this, then again, yell at
 your fellow contributors to make them better in the future.
 
 If it's *not* a trivial hotfix, you should probably make any number of release
-candidate tags (e.g. `arvo.yyyy.mm.dd.rc-1`, `arvo.yyyy.mm.dd.rc-2`, ..), test
+candidate tags (e.g. `arvo.yyyy.mm.dd.rc1`, `arvo.yyyy.mm.dd.rc2`, ..), test
 them, and after you confirm one of them is good, tag the release as
 `arvo.yyyy.mm.dd`.
 
@@ -150,13 +183,17 @@ Contributions:
 
 The same schpeel re: release candidates applies here.
 
-You should probably avoid putting both Arvo and Vere changes into Vere
-releases.
+Do not include implicit Arvo changes in Vere releases.  This used to be done,
+historically, but shouldn't be any longer.  If there are Arvo and Vere changes
+to be released, make two releases.
 
 ### Deploy the update
 
-For Arvo updates, this means copying the files into ~zod's %base desk.  For
-consistency, I download the release tarball and then rsync the files in:
+For Arvo updates, this means copying the files into ~zod's %base desk.  The
+changes will be synced to /~zod/kids and then propagated through other galaxies
+and stars to the rest of the network.
+
+For consistency, I download the release tarball and then rsync the files in:
 
 ```
 $ wget https://github.com/urbit/urbit/archive/arvo.yyyy.mm.dd.tar.gz
@@ -166,13 +203,13 @@ $ rsync -zr --delete urbit-arvo.yyyy.mm.dd/pkg/arvo/ zod/base
 $ herb zod -p hood -d "+hood/commit %base"
 ```
 
-For Vere updates, this means shutting down each desired ship, installing the
-new binary, and restarting the pier with it.
+For Vere updates, this means simply shutting down each desired ship, installing
+the new binary, and restarting the pier with it.
 
 ### Announce the update
 
 Post an announcement to urbit-dev.  The tag annotation, basically, is fine here
 -- I usually add the %base hash (for Arvo releases) and the release binary URLs
-(for Vere releaes).  Check the urbit-dev archives for examples of these
+(for Vere releases).  Check the urbit-dev archives for examples of these
 announcements.
 

bin/brass.pill

@@ -1,3 +1,3 @@
 version https://git-lfs.github.com/spec/v1
-oid sha256:ca42dfc461829d813295ec1d11933fdc5cd929b82e43c1d8506d51bad8645700
-size 7224077
+oid sha256:4de6eed9c7702cc0f07ab01fc4f970a59f394a9b632ad4c20d4c544b93199f0f
+size 7225555

bin/ivory.pill

@@ -1,3 +1,3 @@
 version https://git-lfs.github.com/spec/v1
-oid sha256:34d930f73099aae049183e5ac2ce5498b8f74723685b11f12da875f089f36224
+oid sha256:a027859d4d4d322fc90ae72b5cd04747d806894051cb60426f35dc5a0dea5216
 size 1231117

bin/solid.pill

@@ -1,3 +1,3 @@
 version https://git-lfs.github.com/spec/v1
-oid sha256:add234cdae90c44f41e5260da3db9498c7e0ad3b3ebe26f0ed8b85490b4a0ece
-size 9645804
+oid sha256:5838a1f03644fb1c53e14a2c8b4726649036bcb131138a82331096062bae3ac1
+size 9649825

pkg/arvo/.ignore

@@ -0,0 +1 @@
+app/*/js/*

pkg/arvo/app/permission-hook.hoon

@@ -195,7 +195,15 @@
       %delete
     ?.  (~(has by synced) path.diff)
       [~ state]
-    :_  state(synced (~(del by synced) path.diff))
+    =/  control=(unit path)
+      =+  (~(got by synced) path.diff)
+      ?.  =(our.bowl ship)  ~
+      `access-control
+    :_  %_  state
+          synced          (~(del by synced) path.diff)
+          access-control  ?~  control  access-control
+                          (~(del ju access-control) u.control path.diff)
+        ==
     :_  ~
     :*  %pass
         [%permission path.diff]

pkg/arvo/app/ping.hoon

@@ -41,7 +41,11 @@
       ?.  ?=(%poking -.ship-state.u.s)
         %-  (slog leaf+"ping: strange state {<ship s>}" ~)
         `state
-      =/  until  (add ~m5 now)
+      ::  NAT timeouts are often pretty short for UDP entries.  5
+      ::  minutes is a common value.  We use 30 seconds, which is fairly
+      ::  aggressive, but should be safe.
+      ::
+      =/  until  (add ~s30 now)
       =.  ships.state
         (~(put by ships.state) ship u.s(ship-state [%waiting until]))
       :_  state

pkg/arvo/gen/dbug.hoon

@@ -26,7 +26,7 @@
     ==
 :-  %dbug
 ?-  args
-  ~        [%bowl *about]
+  ~        [%state *about]
   [@ ~]    [what.args *about]
   [@ * ~]  [what about]:args
 ==

pkg/arvo/gen/frontpage.hoon

@@ -19,7 +19,7 @@
   ==
   ;body
     ;h1:"Ran generator"
-    ::  ;p:"Executing on {<(scot %p our)>}."
+    ;p:"Executing on {<(scot %p p.bek)>}."
     ;p:"The method was {<(trip method)>}."
     ;p:"The url was {<(trip url)>}."
   ==

pkg/arvo/sys/hoon.hoon

@@ -1337,7 +1337,7 @@
       a(r c)
     c(l a(r l.c))
   ::
-  ++  rep                                               ::  replace by product
+  ++  rep                                               ::  reduce to product
     |*  b/_=>(~ |=({* *} +<+))
     |-
     ?~  a  +<+.b
@@ -1592,7 +1592,7 @@
       a(r d)
     d(l a(r l.d))
   ::
-  ++  rep                                               ::  replace by product
+  ++  rep                                               ::  reduce to product
     |*  b/_=>(~ |=({* *} +<+))
     |-
     ?~  a  +<+.b

pkg/arvo/sys/vane/ames.hoon

@@ -1886,6 +1886,20 @@
         ::
         =/  =peer-state  +.u.ship-state
         ::
+        ::  XX  routing hack to mimic old ames.
+        ::
+        ::    Before removing this, consider: moons when their planet is
+        ::    behind a NAT; a planet receiving initial acknowledgment
+        ::    from a star; a planet talking to another planet under
+        ::    another galaxy.
+        ::
+        ?:  ?|  =(our ship)
+                ?&  !=(final-ship ship)
+                    !=(%czar (clan:title ship))
+                ==
+            ==
+          (try-next-sponsor sponsor.peer-state)
+        ::
         ?:  =(our ship)
           ::  if forwarding, don't send to sponsor to avoid loops
           ::

pkg/arvo/sys/vane/gall.hoon

@@ -38,6 +38,7 @@
       %watch-as
       %poke
       %leave
+      %missing
   ==
 --
 |%
@@ -54,7 +55,7 @@
 ++  state
   $:  :: state version
       ::
-      %3
+      %4
       :: agents by ship
       ::
       =agents
@@ -610,12 +611,16 @@
         [%a %done *]
       =^  remote-request  outstanding.agents.state
         ?~  t.t.t.wire
+          =/  full-wire  sys+wire
           =/  stand
-            %+  ~(gut by outstanding.agents.state)  [sys+wire hen]
-            *(qeu remote-request)
-          ~|  [sys+wire=wire hen=hen stand=stand outs=outstanding.agents.state]
+            %+  ~(gut by outstanding.agents.state)  [full-wire hen]
+            ::  default is do nothing; should only hit if cleared queue
+            ::  in +load 3-to-4
+            ::
+            (~(put to *(qeu remote-request)) %missing)
+          ~|  [full-wire=full-wire hen=hen stand=stand outs=outstanding.agents.state]
           =^  rr  stand  ~(get to stand)
-          [rr (~(put by outstanding.agents.state) [wire hen] stand)]
+          [rr (~(put by outstanding.agents.state) [full-wire hen] stand)]
         ::  non-null case of wire is old, remove on next breach after
         ::  2019/12
         ::
@@ -631,6 +636,7 @@
         %watch     (mo-give %unto %watch-ack err)
         %poke      (mo-give %unto %poke-ack err)
         %leave     mo-core
+        %missing   (mo-give:(mo-give %unto %watch-ack err) %unto %poke-ack err)
       ==
     ::
         [%a %boon *]
@@ -1576,16 +1582,32 @@
   =?  all-state  ?=(%2 -.all-state)
     (state-2-to-3 all-state)
   ::
-  ?>  ?=(%3 -.all-state)
+  =?  all-state  ?=(%3 -.all-state)
+    (state-3-to-4 all-state)
+  ::
+  ?>  ?=(%4 -.all-state)
   gall-payload(state all-state)
   ::
   ::  +all-state: upgrade path
   ::
-  ++  all-state  $%(state-0 state-1 state-2 ^state)
+  ++  all-state  $%(state-0 state-1 state-2 state-3 ^state)
+  ::
+  ++  state-3-to-4
+    |=  =state-3
+    ^-  ^state
+    %=    state-3
+        -  %4
+        outstanding.agents  ~
+    ==
+  ::
+  ++  state-3
+    $:  %3
+        =agents
+    ==
   ::
   ++  state-2-to-3
     |=  =state-2
-    ^-  ^state
+    ^-  state-3
     %=    state-2
         -  %3
         running.agents-2

pkg/hs/default.nix

@@ -0,0 +1,51 @@
+# Run using:
+#
+#     $(nix-build --no-link -A fullBuildScript)
+{
+  stack2nix-output-path ? "custom-stack2nix-output.nix",
+}:
+let
+  cabalPackageName = "urbit-king";
+  compiler = "ghc865"; # matching stack.yaml
+
+  # Pin static-haskell-nix version.
+  static-haskell-nix =
+    if builtins.pathExists ../.in-static-haskell-nix
+      then toString ../. # for the case that we're in static-haskell-nix itself, so that CI always builds the latest version.
+      # Update this hash to use a different `static-haskell-nix` version:
+      else fetchTarball https://github.com/nh2/static-haskell-nix/archive/d1b20f35ec7d3761e59bd323bbe0cca23b3dfc82.tar.gz;
+
+  # Pin nixpkgs version
+  # By default to the one `static-haskell-nix` provides, but you may also give
+  # your own as long as it has the necessary patches, using e.g.
+  #     pkgs = import (fetchTarball https://github.com/nh2/nixpkgs/archive/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa123.tar.gz) {};
+  pkgs = import "${static-haskell-nix}/nixpkgs.nix";
+
+  stack2nix-script = import "${static-haskell-nix}/static-stack2nix-builder/stack2nix-script.nix" {
+    inherit pkgs;
+    stack-project-dir = toString ./.; # where stack.yaml is
+    hackageSnapshot = "2020-01-20T00:00:00Z"; # pins e.g. extra-deps without hashes or revisions
+  };
+
+  static-stack2nix-builder = import "${static-haskell-nix}/static-stack2nix-builder/default.nix" {
+    normalPkgs = pkgs;
+    inherit cabalPackageName compiler stack2nix-output-path;
+    # disableOptimization = true; # for compile speed
+  };
+
+  # Full invocation, including pinning `nix` version itself.
+  fullBuildScript = pkgs.writeShellScript "stack2nix-and-build-script.sh" ''
+    set -eu -o pipefail
+    STACK2NIX_OUTPUT_PATH=$(${stack2nix-script})
+    export NIX_PATH=nixpkgs=${pkgs.path}
+    ${pkgs.nix}/bin/nix-build --no-link -A static_package --argstr stack2nix-output-path "$STACK2NIX_OUTPUT_PATH" "$@"
+  '';
+
+in
+  {
+    static_package = static-stack2nix-builder.static_package;
+    inherit fullBuildScript;
+    # For debugging:
+    inherit stack2nix-script;
+    inherit static-stack2nix-builder;
+  }

pkg/hs/lmdb-static/.gitignore

@@ -0,0 +1,12 @@
+dist
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+.virtualenv
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+cabal.config
+*~

pkg/hs/lmdb-static/LICENSE

@@ -0,0 +1,24 @@
+Copyright (c) 2014, David Barbour
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+

pkg/hs/lmdb-static/README.md

@@ -0,0 +1,13 @@
+This is a hack to avoid dynamic depencency on lmdb:
+
+This is a vendoring of `haskell-lmdb` and `lmdb` modified to include
+the c-build of `lmdb` statically into `haskell-lmdb`.
+
+```
+haskell-lmdb:
+  repo: https://github.com/dmbarbour/haskell-lmdb.git
+  hash: 1e562429874919d445576c87cf118d7de5112b5b
+lmdb:
+  repo: https://github.com/LMDB/lmdb.git
+  hash: c3e6b4209eed13af4a3670e5f04f42169c08e5c6
+```

pkg/hs/lmdb-static/Setup.hs

@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+

pkg/hs/lmdb-static/cbits/midl.c

@@ -0,0 +1,421 @@
+/**	@file midl.c
+ *	@brief ldap bdb back-end ID List functions */
+/* $OpenLDAP$ */
+/* This work is part of OpenLDAP Software <http://www.openldap.org/>.
+ *
+ * Copyright 2000-2019 The OpenLDAP Foundation.
+ * Portions Copyright 2001-2018 Howard Chu, Symas Corp.
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted only as authorized by the OpenLDAP
+ * Public License.
+ *
+ * A copy of this license is available in the file LICENSE in the
+ * top-level directory of the distribution or, alternatively, at
+ * <http://www.OpenLDAP.org/license.html>.
+ */
+
+#include <limits.h>
+#include <string.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <sys/types.h>
+#include "midl.h"
+
+/** @defgroup internal	LMDB Internals
+ *	@{
+ */
+/** @defgroup idls	ID List Management
+ *	@{
+ */
+#define CMP(x,y)	 ( (x) < (y) ? -1 : (x) > (y) )
+
+unsigned mdb_midl_search( MDB_IDL ids, MDB_ID id )
+{
+	/*
+	 * binary search of id in ids
+	 * if found, returns position of id
+	 * if not found, returns first position greater than id
+	 */
+	unsigned base = 0;
+	unsigned cursor = 1;
+	int val = 0;
+	unsigned n = ids[0];
+
+	while( 0 < n ) {
+		unsigned pivot = n >> 1;
+		cursor = base + pivot + 1;
+		val = CMP( ids[cursor], id );
+
+		if( val < 0 ) {
+			n = pivot;
+
+		} else if ( val > 0 ) {
+			base = cursor;
+			n -= pivot + 1;
+
+		} else {
+			return cursor;
+		}
+	}
+
+	if( val > 0 ) {
+		++cursor;
+	}
+	return cursor;
+}
+
+#if 0	/* superseded by append/sort */
+int mdb_midl_insert( MDB_IDL ids, MDB_ID id )
+{
+	unsigned x, i;
+
+	x = mdb_midl_search( ids, id );
+	assert( x > 0 );
+
+	if( x < 1 ) {
+		/* internal error */
+		return -2;
+	}
+
+	if ( x <= ids[0] && ids[x] == id ) {
+		/* duplicate */
+		assert(0);
+		return -1;
+	}
+
+	if ( ++ids[0] >= MDB_IDL_DB_MAX ) {
+		/* no room */
+		--ids[0];
+		return -2;
+
+	} else {
+		/* insert id */
+		for (i=ids[0]; i>x; i--)
+			ids[i] = ids[i-1];
+		ids[x] = id;
+	}
+
+	return 0;
+}
+#endif
+
+MDB_IDL mdb_midl_alloc(int num)
+{
+	MDB_IDL ids = malloc((num+2) * sizeof(MDB_ID));
+	if (ids) {
+		*ids++ = num;
+		*ids = 0;
+	}
+	return ids;
+}
+
+void mdb_midl_free(MDB_IDL ids)
+{
+	if (ids)
+		free(ids-1);
+}
+
+void mdb_midl_shrink( MDB_IDL *idp )
+{
+	MDB_IDL ids = *idp;
+	if (*(--ids) > MDB_IDL_UM_MAX &&
+		(ids = realloc(ids, (MDB_IDL_UM_MAX+2) * sizeof(MDB_ID))))
+	{
+		*ids++ = MDB_IDL_UM_MAX;
+		*idp = ids;
+	}
+}
+
+static int mdb_midl_grow( MDB_IDL *idp, int num )
+{
+	MDB_IDL idn = *idp-1;
+	/* grow it */
+	idn = realloc(idn, (*idn + num + 2) * sizeof(MDB_ID));
+	if (!idn)
+		return ENOMEM;
+	*idn++ += num;
+	*idp = idn;
+	return 0;
+}
+
+int mdb_midl_need( MDB_IDL *idp, unsigned num )
+{
+	MDB_IDL ids = *idp;
+	num += ids[0];
+	if (num > ids[-1]) {
+		num = (num + num/4 + (256 + 2)) & -256;
+		if (!(ids = realloc(ids-1, num * sizeof(MDB_ID))))
+			return ENOMEM;
+		*ids++ = num - 2;
+		*idp = ids;
+	}
+	return 0;
+}
+
+int mdb_midl_append( MDB_IDL *idp, MDB_ID id )
+{
+	MDB_IDL ids = *idp;
+	/* Too big? */
+	if (ids[0] >= ids[-1]) {
+		if (mdb_midl_grow(idp, MDB_IDL_UM_MAX))
+			return ENOMEM;
+		ids = *idp;
+	}
+	ids[0]++;
+	ids[ids[0]] = id;
+	return 0;
+}
+
+int mdb_midl_append_list( MDB_IDL *idp, MDB_IDL app )
+{
+	MDB_IDL ids = *idp;
+	/* Too big? */
+	if (ids[0] + app[0] >= ids[-1]) {
+		if (mdb_midl_grow(idp, app[0]))
+			return ENOMEM;
+		ids = *idp;
+	}
+	memcpy(&ids[ids[0]+1], &app[1], app[0] * sizeof(MDB_ID));
+	ids[0] += app[0];
+	return 0;
+}
+
+int mdb_midl_append_range( MDB_IDL *idp, MDB_ID id, unsigned n )
+{
+	MDB_ID *ids = *idp, len = ids[0];
+	/* Too big? */
+	if (len + n > ids[-1]) {
+		if (mdb_midl_grow(idp, n | MDB_IDL_UM_MAX))
+			return ENOMEM;
+		ids = *idp;
+	}
+	ids[0] = len + n;
+	ids += len;
+	while (n)
+		ids[n--] = id++;
+	return 0;
+}
+
+void mdb_midl_xmerge( MDB_IDL idl, MDB_IDL merge )
+{
+	MDB_ID old_id, merge_id, i = merge[0], j = idl[0], k = i+j, total = k;
+	idl[0] = (MDB_ID)-1;		/* delimiter for idl scan below */
+	old_id = idl[j];
+	while (i) {
+		merge_id = merge[i--];
+		for (; old_id < merge_id; old_id = idl[--j])
+			idl[k--] = old_id;
+		idl[k--] = merge_id;
+	}
+	idl[0] = total;
+}
+
+/* Quicksort + Insertion sort for small arrays */
+
+#define SMALL	8
+#define	MIDL_SWAP(a,b)	{ itmp=(a); (a)=(b); (b)=itmp; }
+
+void
+mdb_midl_sort( MDB_IDL ids )
+{
+	/* Max possible depth of int-indexed tree * 2 items/level */
+	int istack[sizeof(int)*CHAR_BIT * 2];
+	int i,j,k,l,ir,jstack;
+	MDB_ID a, itmp;
+
+	ir = (int)ids[0];
+	l = 1;
+	jstack = 0;
+	for(;;) {
+		if (ir - l < SMALL) {	/* Insertion sort */
+			for (j=l+1;j<=ir;j++) {
+				a = ids[j];
+				for (i=j-1;i>=1;i--) {
+					if (ids[i] >= a) break;
+					ids[i+1] = ids[i];
+				}
+				ids[i+1] = a;
+			}
+			if (jstack == 0) break;
+			ir = istack[jstack--];
+			l = istack[jstack--];
+		} else {
+			k = (l + ir) >> 1;	/* Choose median of left, center, right */
+			MIDL_SWAP(ids[k], ids[l+1]);
+			if (ids[l] < ids[ir]) {
+				MIDL_SWAP(ids[l], ids[ir]);
+			}
+			if (ids[l+1] < ids[ir]) {
+				MIDL_SWAP(ids[l+1], ids[ir]);
+			}
+			if (ids[l] < ids[l+1]) {
+				MIDL_SWAP(ids[l], ids[l+1]);
+			}
+			i = l+1;
+			j = ir;
+			a = ids[l+1];
+			for(;;) {
+				do i++; while(ids[i] > a);
+				do j--; while(ids[j] < a);
+				if (j < i) break;
+				MIDL_SWAP(ids[i],ids[j]);
+			}
+			ids[l+1] = ids[j];
+			ids[j] = a;
+			jstack += 2;
+			if (ir-i+1 >= j-l) {
+				istack[jstack] = ir;
+				istack[jstack-1] = i;
+				ir = j-1;
+			} else {
+				istack[jstack] = j-1;
+				istack[jstack-1] = l;
+				l = i;
+			}
+		}
+	}
+}
+
+unsigned mdb_mid2l_search( MDB_ID2L ids, MDB_ID id )
+{
+	/*
+	 * binary search of id in ids
+	 * if found, returns position of id
+	 * if not found, returns first position greater than id
+	 */
+	unsigned base = 0;
+	unsigned cursor = 1;
+	int val = 0;
+	unsigned n = (unsigned)ids[0].mid;
+
+	while( 0 < n ) {
+		unsigned pivot = n >> 1;
+		cursor = base + pivot + 1;
+		val = CMP( id, ids[cursor].mid );
+
+		if( val < 0 ) {
+			n = pivot;
+
+		} else if ( val > 0 ) {
+			base = cursor;
+			n -= pivot + 1;
+
+		} else {
+			return cursor;
+		}
+	}
+
+	if( val > 0 ) {
+		++cursor;
+	}
+	return cursor;
+}
+
+int mdb_mid2l_insert( MDB_ID2L ids, MDB_ID2 *id )
+{
+	unsigned x, i;
+
+	x = mdb_mid2l_search( ids, id->mid );
+
+	if( x < 1 ) {
+		/* internal error */
+		return -2;
+	}
+
+	if ( x <= ids[0].mid && ids[x].mid == id->mid ) {
+		/* duplicate */
+		return -1;
+	}
+
+	if ( ids[0].mid >= MDB_IDL_UM_MAX ) {
+		/* too big */
+		return -2;
+
+	} else {
+		/* insert id */
+		ids[0].mid++;
+		for (i=(unsigned)ids[0].mid; i>x; i--)
+			ids[i] = ids[i-1];
+		ids[x] = *id;
+	}
+
+	return 0;
+}
+
+int mdb_mid2l_append( MDB_ID2L ids, MDB_ID2 *id )
+{
+	/* Too big? */
+	if (ids[0].mid >= MDB_IDL_UM_MAX) {
+		return -2;
+	}
+	ids[0].mid++;
+	ids[ids[0].mid] = *id;
+	return 0;
+}
+
+#ifdef MDB_VL32
+unsigned mdb_mid3l_search( MDB_ID3L ids, MDB_ID id )
+{
+	/*
+	 * binary search of id in ids
+	 * if found, returns position of id
+	 * if not found, returns first position greater than id
+	 */
+	unsigned base = 0;
+	unsigned cursor = 1;
+	int val = 0;
+	unsigned n = (unsigned)ids[0].mid;
+
+	while( 0 < n ) {
+		unsigned pivot = n >> 1;
+		cursor = base + pivot + 1;
+		val = CMP( id, ids[cursor].mid );
+
+		if( val < 0 ) {
+			n = pivot;
+
+		} else if ( val > 0 ) {
+			base = cursor;
+			n -= pivot + 1;
+
+		} else {
+			return cursor;
+		}
+	}
+
+	if( val > 0 ) {
+		++cursor;
+	}
+	return cursor;
+}
+
+int mdb_mid3l_insert( MDB_ID3L ids, MDB_ID3 *id )
+{
+	unsigned x, i;
+
+	x = mdb_mid3l_search( ids, id->mid );
+
+	if( x < 1 ) {
+		/* internal error */
+		return -2;
+	}
+
+	if ( x <= ids[0].mid && ids[x].mid == id->mid ) {
+		/* duplicate */
+		return -1;
+	}
+
+	/* insert id */
+	ids[0].mid++;
+	for (i=(unsigned)ids[0].mid; i>x; i--)
+		ids[i] = ids[i-1];
+	ids[x] = *id;
+
+	return 0;
+}
+#endif /* MDB_VL32 */
+
+/** @} */
+/** @} */

pkg/hs/lmdb-static/cbits/midl.h

@@ -0,0 +1,200 @@
+/**	@file midl.h
+ *	@brief LMDB ID List header file.
+ *
+ *	This file was originally part of back-bdb but has been
+ *	modified for use in libmdb. Most of the macros defined
+ *	in this file are unused, just left over from the original.
+ *
+ *	This file is only used internally in libmdb and its definitions
+ *	are not exposed publicly.
+ */
+/* $OpenLDAP$ */
+/* This work is part of OpenLDAP Software <http://www.openldap.org/>.
+ *
+ * Copyright 2000-2019 The OpenLDAP Foundation.
+ * Portions Copyright 2001-2019 Howard Chu, Symas Corp.
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted only as authorized by the OpenLDAP
+ * Public License.
+ *
+ * A copy of this license is available in the file LICENSE in the
+ * top-level directory of the distribution or, alternatively, at
+ * <http://www.OpenLDAP.org/license.html>.
+ */
+
+#ifndef _MDB_MIDL_H_
+#define _MDB_MIDL_H_
+
+#include "lmdb.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/** @defgroup internal	LMDB Internals
+ *	@{
+ */
+
+/** @defgroup idls	ID List Management
+ *	@{
+ */
+	/** A generic unsigned ID number. These were entryIDs in back-bdb.
+	 *	Preferably it should have the same size as a pointer.
+	 */
+typedef mdb_size_t MDB_ID;
+
+	/** An IDL is an ID List, a sorted array of IDs. The first
+	 * element of the array is a counter for how many actual
+	 * IDs are in the list. In the original back-bdb code, IDLs are
+	 * sorted in ascending order. For libmdb IDLs are sorted in
+	 * descending order.
+	 */
+typedef MDB_ID *MDB_IDL;
+
+/* IDL sizes - likely should be even bigger
+ *   limiting factors: sizeof(ID), thread stack size
+ */
+#define	MDB_IDL_LOGN	16	/* DB_SIZE is 2^16, UM_SIZE is 2^17 */
+#define MDB_IDL_DB_SIZE		(1<<MDB_IDL_LOGN)
+#define MDB_IDL_UM_SIZE		(1<<(MDB_IDL_LOGN+1))
+
+#define MDB_IDL_DB_MAX		(MDB_IDL_DB_SIZE-1)
+#define MDB_IDL_UM_MAX		(MDB_IDL_UM_SIZE-1)
+
+#define MDB_IDL_SIZEOF(ids)		(((ids)[0]+1) * sizeof(MDB_ID))
+#define MDB_IDL_IS_ZERO(ids) ( (ids)[0] == 0 )
+#define MDB_IDL_CPY( dst, src ) (memcpy( dst, src, MDB_IDL_SIZEOF( src ) ))
+#define MDB_IDL_FIRST( ids )	( (ids)[1] )
+#define MDB_IDL_LAST( ids )		( (ids)[(ids)[0]] )
+
+	/** Current max length of an #mdb_midl_alloc()ed IDL */
+#define MDB_IDL_ALLOCLEN( ids )	( (ids)[-1] )
+
+	/** Append ID to IDL. The IDL must be big enough. */
+#define mdb_midl_xappend(idl, id) do { \
+		MDB_ID *xidl = (idl), xlen = ++(xidl[0]); \
+		xidl[xlen] = (id); \
+	} while (0)
+
+	/** Search for an ID in an IDL.
+	 * @param[in] ids	The IDL to search.
+	 * @param[in] id	The ID to search for.
+	 * @return	The index of the first ID greater than or equal to \b id.
+	 */
+unsigned mdb_midl_search( MDB_IDL ids, MDB_ID id );
+
+	/** Allocate an IDL.
+	 * Allocates memory for an IDL of the given size.
+	 * @return	IDL on success, NULL on failure.
+	 */
+MDB_IDL mdb_midl_alloc(int num);
+
+	/** Free an IDL.
+	 * @param[in] ids	The IDL to free.
+	 */
+void mdb_midl_free(MDB_IDL ids);
+
+	/** Shrink an IDL.
+	 * Return the IDL to the default size if it has grown larger.
+	 * @param[in,out] idp	Address of the IDL to shrink.
+	 */
+void mdb_midl_shrink(MDB_IDL *idp);
+
+	/** Make room for num additional elements in an IDL.
+	 * @param[in,out] idp	Address of the IDL.
+	 * @param[in] num	Number of elements to make room for.
+	 * @return	0 on success, ENOMEM on failure.
+	 */
+int mdb_midl_need(MDB_IDL *idp, unsigned num);
+
+	/** Append an ID onto an IDL.
+	 * @param[in,out] idp	Address of the IDL to append to.
+	 * @param[in] id	The ID to append.
+	 * @return	0 on success, ENOMEM if the IDL is too large.
+	 */
+int mdb_midl_append( MDB_IDL *idp, MDB_ID id );
+
+	/** Append an IDL onto an IDL.
+	 * @param[in,out] idp	Address of the IDL to append to.
+	 * @param[in] app	The IDL to append.
+	 * @return	0 on success, ENOMEM if the IDL is too large.
+	 */
+int mdb_midl_append_list( MDB_IDL *idp, MDB_IDL app );
+
+	/** Append an ID range onto an IDL.
+	 * @param[in,out] idp	Address of the IDL to append to.
+	 * @param[in] id	The lowest ID to append.
+	 * @param[in] n		Number of IDs to append.
+	 * @return	0 on success, ENOMEM if the IDL is too large.
+	 */
+int mdb_midl_append_range( MDB_IDL *idp, MDB_ID id, unsigned n );
+
+	/** Merge an IDL onto an IDL. The destination IDL must be big enough.
+	 * @param[in] idl	The IDL to merge into.
+	 * @param[in] merge	The IDL to merge.
+	 */
+void mdb_midl_xmerge( MDB_IDL idl, MDB_IDL merge );
+
+	/** Sort an IDL.
+	 * @param[in,out] ids	The IDL to sort.
+	 */
+void mdb_midl_sort( MDB_IDL ids );
+
+	/** An ID2 is an ID/pointer pair.
+	 */
+typedef struct MDB_ID2 {
+	MDB_ID mid;		/**< The ID */
+	void *mptr;		/**< The pointer */
+} MDB_ID2;
+
+	/** An ID2L is an ID2 List, a sorted array of ID2s.
+	 * The first element's \b mid member is a count of how many actual
+	 * elements are in the array. The \b mptr member of the first element is unused.
+	 * The array is sorted in ascending order by \b mid.
+	 */
+typedef MDB_ID2 *MDB_ID2L;
+
+	/** Search for an ID in an ID2L.
+	 * @param[in] ids	The ID2L to search.
+	 * @param[in] id	The ID to search for.
+	 * @return	The index of the first ID2 whose \b mid member is greater than or equal to \b id.
+	 */
+unsigned mdb_mid2l_search( MDB_ID2L ids, MDB_ID id );
+
+
+	/** Insert an ID2 into a ID2L.
+	 * @param[in,out] ids	The ID2L to insert into.
+	 * @param[in] id	The ID2 to insert.
+	 * @return	0 on success, -1 if the ID was already present in the ID2L.
+	 */
+int mdb_mid2l_insert( MDB_ID2L ids, MDB_ID2 *id );
+
+	/** Append an ID2 into a ID2L.
+	 * @param[in,out] ids	The ID2L to append into.
+	 * @param[in] id	The ID2 to append.
+	 * @return	0 on success, -2 if the ID2L is too big.
+	 */
+int mdb_mid2l_append( MDB_ID2L ids, MDB_ID2 *id );
+
+#ifdef MDB_VL32
+typedef struct MDB_ID3 {
+	MDB_ID mid;		/**< The ID */
+	void *mptr;		/**< The pointer */
+	unsigned int mcnt;		/**< Number of pages */
+	unsigned int mref;		/**< Refcounter */
+} MDB_ID3;
+
+typedef MDB_ID3 *MDB_ID3L;
+
+unsigned mdb_mid3l_search( MDB_ID3L ids, MDB_ID id );
+int mdb_mid3l_insert( MDB_ID3L ids, MDB_ID3 *id );
+
+#endif /* MDB_VL32 */
+/** @} */
+/** @} */
+#ifdef __cplusplus
+}
+#endif
+#endif	/* _MDB_MIDL_H_ */

pkg/hs/lmdb-static/lmdb-static.cabal

@@ -0,0 +1,89 @@
+Name: lmdb-static
+Version: 0.2.5
+Synopsis: Lightning MDB bindings
+Category: Database
+Description:
+  LMDB is a read-optimized Berkeley DB replacement developed by Symas
+  for the OpenLDAP project. LMDB has impressive performance characteristics
+  and a friendly BSD-style OpenLDAP license. See <http://symas.com/mdb/>.
+  .
+  This library has Haskell bindings to the LMDB library. You must install
+  the lmdb development files before installing this library,
+  e.g. `sudo apt-get install liblmdb-dev` works for Ubuntu 14.04.
+  .
+  For now, only a low level interface is provided, and the author is moving
+  on to use LMDB rather than further develop its bindings. If a higher level
+  API is desired, please consider contributing, or develop a separate package.
+
+Author: David Barbour
+Maintainer: dmbarbour@gmail.com
+Homepage: http://github.com/dmbarbour/haskell-lmdb
+
+Package-Url:
+Copyright: (c) 2014 by David Barbour
+License: BSD2
+license-file: LICENSE
+Stability: experimental
+build-type: Simple
+cabal-version: >= 1.16.0.3
+
+Source-repository head
+  type: git
+  location: http://github.com/dmbarbour/haskell-lmdb.git
+
+Library
+  hs-Source-Dirs: hsrc_lib
+  default-language: Haskell2010
+  Build-Depends: base (>= 4.6 && < 5), array
+  Build-Tools: hsc2hs
+
+  Exposed-Modules:
+    Database.LMDB.Raw
+
+  Include-dirs: cbits
+  Includes:     lmdb.h midl.h
+  C-Sources:    cbits/mdb.c cbits/midl.c
+  cc-options:   -Wall -O2 -g -pthread -fPIC
+  ghc-options:  -Wall -fprof-auto -fPIC
+
+ default-extensions: ApplicativeDo
+                   , BangPatterns
+                   , BlockArguments
+                   , DataKinds
+                   , DefaultSignatures
+                   , DeriveAnyClass
+                   , DeriveDataTypeable
+                   , DeriveFoldable
+                   , DeriveGeneric
+                   , DeriveTraversable
+                   , DerivingStrategies
+                   , EmptyCase
+                   , EmptyDataDecls
+                   , FlexibleContexts
+                   , FlexibleInstances
+                   , FunctionalDependencies
+                   , GADTs
+                   , GeneralizedNewtypeDeriving
+                   , LambdaCase
+                   , MagicHash
+                   , MultiParamTypeClasses
+                   , NamedFieldPuns
+                   , NoImplicitPrelude
+                   , NumericUnderscores
+                   , OverloadedStrings
+                   , PartialTypeSignatures
+                   , PatternSynonyms
+                   , QuasiQuotes
+                   , Rank2Types
+                   , RankNTypes
+                   , RecordWildCards
+                   , ScopedTypeVariables
+                   , StandaloneDeriving
+                   , TemplateHaskell
+                   , TupleSections
+                   , TypeApplications
+                   , TypeFamilies
+                   , TypeOperators
+                   , UnboxedTuples
+                   , UnicodeSyntax
+                   , ViewPatterns

pkg/hs/proto/.gitignore

@@ -0,0 +1,3 @@
+.stack-work/
+proto.cabal
+*~

pkg/hs/proto/LICENSE

@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2016 urbit
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

pkg/hs/proto/app/Main.hs

@@ -0,0 +1,41 @@
+module Main where
+
+import ClassyPrelude
+
+import Control.Lens ((&))
+
+import Untyped.Parser hiding (main)
+import Untyped.CST
+import Untyped.Hoon
+import Untyped.Core
+import Nock
+import SimpleNoun
+import Dashboard
+
+import Text.Show.Pretty (pPrint)
+
+import qualified Prelude as P
+
+-------------------------------------------------------------------------------
+
+main :: IO ()
+main = (P.head <$> getArgs) >>= compileHoonTest
+
+compileHoonTest :: Text -> IO ()
+compileHoonTest ln = do
+    cst <- parse ln & \case
+              Left x  -> error (unpack x)
+              Right x -> pure x
+    -- pPrint cst
+    hon <- pure $ hone cst
+    pPrint hon
+    exp <- pure $ desugar hon
+    pPrint exp
+    nok <- pure $ copy exp
+    putStrLn "==== input  ===="
+    putStrLn ln
+    putStrLn "==== nock   ===="
+    pPrint nok
+    putStrLn "==== output ===="
+    res <- runCare $ nock (A 140) nok
+    pPrint res

pkg/hs/proto/lib/Dashboard.hs

@@ -0,0 +1,135 @@
+module Dashboard
+  ( pattern FastAtom
+  , pattern FastHint
+  , Jet
+  , Dashboard (match)
+  , Freeboard
+  , Hashboard
+  , Fastboard
+  , Careboard
+  , runFree
+  , runHash
+  , runFast
+  , runCare
+  ) where
+
+import ClassyPrelude
+
+import Control.Monad.State.Strict
+
+import SimpleNoun
+
+type Jet = Noun -> Noun
+type JetName = Atom
+type Hash = Int
+
+pattern FastAtom = 1953718630  -- %fast
+pattern FastHint id n =
+  C (A 11)
+    (C
+      (C (A FastAtom) (C (A 1) (A id)))
+      n)
+
+-- | A context in which to run nock which supports jet lookup.
+class Monad m => Dashboard m where
+  -- | Find the jet associated with the formula represented by the given noun,
+  -- if any.
+  match :: Noun -> m (Maybe Jet)
+
+-- | A dashboard which doesn't jet.
+newtype Freeboard a = Freeboard (Identity a)
+  deriving newtype Functor
+  deriving newtype Applicative
+  deriving newtype Monad
+
+-- | A dashboard which looks for jets by formula hash
+newtype Hashboard a = Hashboard (Identity a)
+  deriving newtype Functor
+  deriving newtype Applicative
+  deriving newtype Monad
+
+-- | A dashboard which checks the head of formulas for "fast
+-- hints" and uses the name contained in such a hint to look for jets.
+newtype Fastboard a = Fastboard (Identity a)
+  deriving newtype Functor
+  deriving newtype Applicative
+  deriving newtype Monad
+
+-- | A dashboard which uses both lookup strategies, checking for consistency
+-- between them and that each fast hint is applied to a unique formula.
+-- Violations of these principles are written to standard out.
+newtype Careboard a = Careboard (StateT (HashMap JetName Noun) IO a)
+  deriving newtype Functor
+  deriving newtype Applicative
+  deriving newtype Monad
+
+runFree :: Freeboard a -> a
+runFree (Freeboard x) = runIdentity x
+
+runHash :: Hashboard a -> a
+runHash (Hashboard x) = runIdentity x
+
+runFast :: Fastboard a -> a
+runFast (Fastboard x) = runIdentity x
+
+runCare :: Careboard a -> IO a
+runCare (Careboard x) = evalStateT x mempty
+
+instance Dashboard Freeboard where
+  match _ = Freeboard $ pure Nothing
+
+instance Dashboard Hashboard where
+  match = Hashboard . pure . byHash . hash
+
+instance Dashboard Fastboard where
+  match = Fastboard . \case
+    FastHint id n -> pure (byFast id)
+    _ -> pure Nothing
+
+-- TODO maybe also detect hash collisions
+instance Dashboard Careboard where
+  match = Careboard . \case
+    n@(FastHint nm _) -> case namely nm of
+      Just (h, j) -> do
+        when (h /= hash n) $
+          putStrLn ("careboard: jet " <> tshowA nm <> " should have its hash "
+                    <> "updated from " <> tshow h <> " to " <> tshow (hash n))
+        get <&> lookup nm >>= \case
+          Just n' ->
+            when (n' /= n) $
+              putStrLn ("careboard: jet hint " <> tshowA nm <> " has been "
+                        <> "detected on unequal formulae " <> tshow n
+                        <> " and " <> tshow n' <> ", which is very bad")
+          Nothing -> modify' (insertMap nm n)
+        pure (Just j)
+      Nothing -> do
+        putStrLn ("careboard: unmatched fast hint: " ++ tshowA nm)
+        pure $ byHash $ hash n
+    n -> pure $ byHash $ hash n
+
+byFast :: JetName -> Maybe Jet
+byFast = flip lookup fast
+  where
+    fast :: HashMap JetName Jet
+    fast = mapFromList $ map (\(n, _, j) -> (n, j)) jets
+
+byHash :: Hash -> Maybe Jet
+byHash = flip lookup hash
+  where
+    hash :: HashMap Hash Jet
+    hash = mapFromList $ map (\(_, h, j) -> (h, j)) jets
+
+namely :: JetName -> Maybe (Hash, Jet)
+namely = flip lookup fash
+  where
+    fash :: HashMap JetName (Hash, Jet)
+    fash = mapFromList $ map (\(n, h, j) -> (n, (h, j))) jets
+
+tx = textToAtom
+
+type Entry = (JetName, Hash, Jet)
+-- | Your jets here
+jets :: [Entry]
+jets =
+  [ (tx "dec", 1520491622440108403, \(A a) -> trace "jetting" $ A (a - 1))
+  ]

pkg/hs/proto/lib/Deppy/Core.hs

@@ -0,0 +1,302 @@
+module Deppy.Core where
+
+import ClassyPrelude
+
+import Bound
+import Data.Deriving (deriveEq1, deriveOrd1, deriveRead1, deriveShow1)
+import Data.Maybe (fromJust)
+import Data.Set (isSubsetOf)
+import qualified Data.Set as Set
+import Numeric.Natural
+
+type Typ = Exp
+
+data Exp a
+  = Var a
+  -- types
+  | Typ
+  | Fun (Abs a)
+  | Cel (Abs a)
+  | Wut (Set Tag)
+  -- introduction forms
+  | Lam (Abs a)
+  | Cns (Exp a) (Exp a)
+  | Tag Tag
+  -- elimination forms
+  | App (Exp a) (Exp a)
+  | Hed (Exp a)
+  | Tal (Exp a)
+  | Cas (Typ a) (Exp a) (Map Tag (Exp a))
+  -- recursion, flow control
+  | Let (Exp a) (Scope () Exp a)
+  | Rec (Abs a)
+  deriving (Functor, Foldable, Traversable)
+
+type Tag = Natural
+
+data Abs a = Abs
+  { spec :: Typ a
+  , body :: Scope () Exp a
+  }
+  deriving (Functor, Foldable, Traversable)
+
+deriveEq1   ''Abs
+deriveOrd1  ''Abs
+deriveRead1 ''Abs
+deriveShow1 ''Abs
+--makeBound   ''Abs
+
+deriveEq1   ''Exp
+deriveOrd1  ''Exp
+deriveRead1 ''Exp
+deriveShow1 ''Exp
+--makeBound   ''Exp
+
+deriving instance Eq a   => Eq (Abs a)
+deriving instance Ord a  => Ord (Abs a)
+deriving instance Read a => Read (Abs a)
+deriving instance Show a => Show (Abs a)
+
+deriving instance Eq a   => Eq (Exp a)
+deriving instance Ord a  => Ord (Exp a)
+deriving instance Read a => Read (Exp a)
+deriving instance Show a => Show (Exp a)
+
+instance Applicative Exp where
+  pure = Var
+  (<*>) = ap
+
+instance Monad Exp where
+  return = Var
+  Var a >>= f = f a
+  Typ   >>= _ = Typ
+  Fun a >>= f = Fun (bindAbs a f)
+  Cel a >>= f = Cel (bindAbs a f)
+  Wut ls >>= _ = Wut ls
+  Lam a >>= f = Lam (bindAbs a f)
+  Cns x y >>= f = Cns (x >>= f) (y >>= f)
+  Tag l >>= _ = Tag l
+  App x y >>= f = App (x >>= f) (y >>= f)
+  Hed x >>= f = Hed (x >>= f)
+  Tal x >>= f = Tal (x >>= f)
+  Cas t x cs >>= f = Cas (t >>= f) (x >>= f) (cs <&> (>>= f))
+  Let a b >>= f = Let (a >>= f) (b >>>= f)
+  Rec a >>= f = Rec (bindAbs a f)
+
+bindAbs :: Abs a -> (a -> Exp b) -> Abs b
+bindAbs (Abs s b) f = Abs (s >>= f) (b >>>= f)
+
+lam :: Eq a => a -> Typ a -> Exp a -> Exp a
+lam v t e = Lam (Abs t (abstract1 v e))
+
+fun :: Eq a => a -> Typ a -> Typ a -> Typ a
+fun v t u = Fun (Abs t (abstract1 v u))
+
+fun_ :: Typ a -> Typ a -> Typ a
+fun_ t u = Fun (Abs t (abstract (const Nothing) u))
+
+cel :: Eq a => a -> Typ a -> Typ a -> Typ a
+cel v t u = Cel (Abs t (abstract1 v u))
+
+cel_ :: Typ a -> Typ a -> Typ a
+cel_ t u = Cel (Abs t (abstract (const Nothing) u))
+
+rec :: Eq a => a -> Typ a -> Exp a -> Exp a
+rec v t e = Rec (Abs t (abstract1 v e))
+
+ledt :: Eq a => a -> Exp a -> Exp a -> Exp a
+ledt v e e' = Let e (abstract1 v e')
+
+wut = Wut . setFromList
+
+cas t e cs = Cas t e (mapFromList cs)
+
+infixl 9 @:
+(@:) = App
+
+-- | typing environment
+type Env a = a -> Typ a
+
+extend :: (b -> Typ a) -> Env a -> Env (Var b a)
+extend handleNewBindings oldEnv = \case
+  -- TODO can we use Scope to decrease the cost of this?
+  B v -> F <$> handleNewBindings v
+  F v -> F <$> oldEnv v
+
+extend1 :: Typ a -> Env a -> Env (Var () a)
+extend1 t = extend \() -> t
+
+-- | amber rule assumptions
+type Asm a = Set (Typ a, Typ a)
+
+extendAsm :: (Ord a, Ord b) => Asm a -> Asm (Var b a)
+extendAsm = Set.map \(t, u) -> (F <$> t, F <$> u)
+
+-- | Remove types that mention variables that are no longer in scope
+retractAsm :: (Ord a, Ord b) => Asm (Var b a) -> Asm a
+retractAsm = foldMap wither
+  where
+    wither = \case
+      (cleanTyp -> Just t, cleanTyp -> Just u) -> singleton (t, u)
+      _ -> mempty
+    cleanTyp = traverse \case
+      F v -> pure v
+      B _ -> Nothing
+
+type Typing = Maybe
+
+-- TODO
+--   - better errors
+--   - state monad for Asm (how to handle polymorphic recursion?)
+nest :: (Show a, Ord a) => Env a -> Typ a -> Typ a -> Typing ()
+nest env = fmap void . go env mempty
+  where
+    go :: (Show a, Ord a) => Env a -> Asm a -> Typ a -> Typ a -> Typing (Asm a)
+    -- FIXME use a better more aggro normal form
+    go env asm0 (whnf -> t0) (whnf -> u0) =
+      if t0 == u0 || member (t0, u0) asm0
+        then pure asm0
+        else let asm = Set.insert (t0, u0) asm0 in
+          case (t0, u0) of
+            (Typ, Typ) -> pure asm
+            -- FIXME yeah actually I think this is wrong
+            -- we're comaring the type of a type variable with 
+            -- (Var v, u) -> go env asm (env v) u
+            -- (t, Var v) -> go env asm t (env v)
+            -- following Cardelli 80something, we check the RHSs assuming
+            -- the putatively *lesser* of the LHSs for both
+            (Fun (Abs a b), Fun (Abs a' b')) -> do
+              asm' <- go env asm a' a
+              retractAsm <$>
+                go (extend1 a' env) (extendAsm asm') (fromScope b) (fromScope b')
+            (Cel (Abs a b), Cel (Abs a' b')) -> do
+              asm' <- go env asm a a'
+              retractAsm <$>
+                go (extend1 a env) (extendAsm asm') (fromScope b) (fromScope b')
+            (Wut ls, Wut ls') -> do
+              guard (ls `isSubsetOf` ls')
+              pure asm
+            -- TODO put into Typing errors
+            (Lam{}, _) -> error "nest: lambda"
+            (_, Lam{}) -> error "nest: lambda"
+            (Cns{}, _) -> error "nest: cons"
+            (_, Cns{}) -> error "nest: cons"
+            (Tag{}, _) -> error "nest: tag"
+            (_, Tag{}) -> error "nest: tag"
+            -- Special rule for the Cas eliminator to enable sums and products
+            (Cas _ e cs, Cas _ e' cs') -> do
+                guard (whnf e == whnf e')
+                Wut s <- infer env e
+                -- TODO I should thread changing asm through the traversal
+                -- but I can't be bothered right now. Perf regression.
+                asm <$ traverse_ chk (setToList s)
+              where 
+                chk tag = case (lookup tag cs, lookup tag cs') of
+                  (Just t, Just u) -> go env asm t u
+                  _ -> error "the Spanish inquisition"
+            (Cas _ e cs, u) -> do
+              Wut s <- infer env e
+              -- TODO thread asms
+              asm <$ traverse_
+                (\tag -> go env asm (fromJust $ lookup tag cs) u)
+                s
+            (t, Cas _ e cs) -> do
+              Wut s <- infer env e
+              -- TODO thread asms
+              asm <$ traverse_
+                (\tag -> go env asm t (fromJust $ lookup tag cs))
+                s
+            (t@Cas{}, u) -> go env asm (whnf t) u
+            (t, u@Cas{}) -> go env asm t (whnf u)
+            (t@(Rec (Abs _ b)), u) -> go env asm (instantiate1 t b) u
+            (t, u@(Rec (Abs _ b))) -> go env asm t (instantiate1 u b)
+            _ -> Nothing
+
+check :: (Show a, Ord a) => Env a -> Exp a -> Typ a -> Typing ()
+check env e t = do
+  t' <- infer env e
+  nest env t' t
+
+infer :: forall a. (Show a, Ord a) => Env a -> Exp a -> Typing (Typ a)
+infer env = \case
+  Var v -> pure $ env v
+  Typ -> pure Typ
+  Fun (Abs t b) -> do
+    Typ <- infer env t
+    Typ <- infer (extend1 t env) (fromScope b)
+    pure Typ
+  Cel (Abs t b) -> do
+    Typ <- infer env t
+    Typ <- infer (extend1 t env) (fromScope b)
+    pure Typ
+  Wut _ -> pure Typ
+  Lam (Abs t b) -> do
+    -- TODO do I need (whnf -> Typ)? (and elsewhere)
+    Typ <- infer env t
+    (toScope -> t') <- infer (extend1 t env) (fromScope b)
+    pure $ Fun (Abs t t')
+  Cns x y -> do
+    -- Infer non-dependent pairs; if you want dependency, you must annotate
+    t <- infer env x
+    u <- infer env y
+    pure $ Cel (Abs t (abstract (const Nothing) u))
+  Tag t -> pure $ Wut (singleton t)
+  App x y -> do
+    Fun (Abs t b) <- infer env x
+    check env y t
+    pure $ whnf (instantiate1 y b)
+  Hed x -> do
+    Cel (Abs t _) <- infer env x
+    pure t
+  Tal x -> do
+    Cel (Abs _ u) <- infer env x
+    pure $ instantiate1 (whnf $ Hed $ x) u
+  Cas t x cs -> do
+    Typ <- infer env t
+    Wut ts <- infer env x
+    -- pretty restrictive - do we want?
+    guard (ts == keysSet cs)
+    traverse_ (\e -> check env e t) cs
+    pure t
+  -- Let e b -> do
+  -- -- TODO is below faster, or infer env (instantiate1 e b)?
+  -- t <- infer env e
+  -- instantiate1 e $ infer (extend1 t env) (fromScope b)
+  Rec (Abs t b) -> do
+    Typ <- infer env t
+    -- todo can F <$> be made faster?
+    check (extend1 t env) (fromScope b) (F <$> t)
+    pure t
+
+whnf :: (Show a, Eq a) => Exp a -> Exp a
+whnf = \case
+  App (whnf -> Lam (Abs _ b)) x -> whnf $ instantiate1 x b
+  Hed (whnf -> Cns x _) -> whnf x
+  Tal (whnf -> Cns _ y) -> whnf y
+  Cas _ (whnf -> Tag t) cs -> whnf $ fromJust $ lookup t cs
+  e@(Rec (Abs _ b)) -> whnf $ instantiate1 e b
+  e -> trace "sadface" e
+{-
+  = Var a
+  -- types
+  | Typ
+  | Fun (Abs a)
+  | Cel (Abs a)
+  | Wut (Set Tag)
+  -- introduction forms
+  | Lam (Abs a)
+  | Cns (Exp a) (Exp a)
+  | Tag Tag
+  -- elimination forms
+  | App (Exp a) (Exp a)
+  | Hed (Exp a)
+  | Tal (Exp a)
+  | Cas (Typ a) (Exp a) (Map Tag (Exp a))
+  -- recursion
+  | Rec (Abs a)
+-}
+
+nf :: (Show a, Eq a) => Exp a -> Exp a
+nf = traceShowId . \case
+  Typ -> Typ
+  _ -> undefined

pkg/hs/proto/lib/Nock.hs

@@ -0,0 +1,114 @@
+module Nock where
+
+import ClassyPrelude
+
+import Dashboard
+import SimpleNoun
+
+data Nock
+  = NC Nock Nock           -- ^ ^: autocons
+  | N0 Axis                -- ^ 0, axis: tree addressing
+  | N1 Noun                -- ^ 1, const
+  | N2 Nock Nock           -- ^ 2, compose: compute subject, formula; apply
+  | N3 Nock                -- ^ 3, is cell
+  | N4 Nock                -- ^ 4, succ
+  | N5 Nock Nock           -- ^ 5, eq
+  | N6 Nock Nock Nock      -- ^ 6, if
+  | N7 Nock Nock           -- ^ 7, then: =>
+  | N8 Nock Nock           -- ^ 8, push: =+
+  | N9 Axis Nock           -- ^ 9, invoke
+  | N10 (Axis, Nock) Nock  -- ^ 10, edit
+  | N11 Hint Nock          -- ^ 11, hint
+  | N12 Nock Nock          -- ^ 12, scry
+  deriving (Eq, Ord, Read, Generic)
+
+data Hint
+  = Tag Atom
+  | Assoc Atom Nock
+  deriving (Eq, Ord, Read, Show, Generic)
+
+instance Hashable Nock
+instance Hashable Hint
+
+instance Show Nock where
+  show = show . nockToNoun
+
+nockToNoun :: Nock -> Noun
+nockToNoun = go
+  where
+    go = \case
+      NC f g            -> C (go f) (go g)
+      N0 a              -> C (A 0) (A a)
+      N1 n              -> C (A 1) n
+      N2 f g            -> C (A 2) (C (go f) (go g))
+      N3 f              -> C (A 3) (go f)
+      N4 f              -> C (A 4) (go f)
+      N5 f g            -> C (A 5) (C (go f) (go g))
+      N6 f g h          -> C (A 6) (C (go f) (C (go g) (go h)))
+      N7 f g            -> C (A 7) (C (go f) (go g))
+      N8 f g            -> C (A 8) (C (go f) (go g))
+      N9 a f            -> C (A 9) (C (A a) (go f))
+      N10 (a, f) g      -> C (A 10) (C (C (A a) (go f)) (go g))
+      N11 (Tag a) f     -> C (A 11) (C (A a) (go f))
+      N11 (Assoc a f) g -> C (A 11) (C (C (A a) (go f)) (go g))
+      N12 f g           -> C (A 12) (C (go f) (go g))
+
+nounToNock :: Noun -> Nock
+nounToNock = go
+  where
+    go = \case
+      A{} -> error "nounToNock: atom"
+      C n@C{} m -> NC (go n) (go m)
+      C (A op) n -> case op of
+        0  | (A a)              <- n  -> N0 a
+        1                             -> N1 n
+        2  | (C m o)            <- n  -> N2 (go m) (go o)
+        3                             -> N3 (go n)
+        4                             -> N4 (go n)
+        5  | (C m o)            <- n  -> N5 (go m) (go o)
+        6  | (C m (C o p))      <- n  -> N6 (go m) (go o) (go p)
+        7  | (C m o)            <- n  -> N7 (go m) (go o)
+        8  | (C m o)            <- n  -> N8 (go m) (go o)
+        9  | (C (A a) m)        <- n  -> N9 a (go m)
+        10 | (C (C (A a) m) o)  <- n  -> N10 (a, (go m)) (go o)
+        11 | (C (C (A a) m) o)  <- n  -> N11 (Assoc a (go m)) (go o)
+           | (C (A a) m)        <- n  -> N11 (Tag a) (go m)
+        12 | (C m o)            <- n  -> N12 (go m) (go o)
+        _ -> error ("nockToNoun: invalid " <> show op <> " " <> show n)
+
+-- | Nock interpreter
+nock :: (Dashboard d) => Noun -> Nock -> d Noun
+nock n = \case
+  NC f g -> C <$> nock n f <*> nock n g
+  N0 a -> pure $ axis a n
+  N1 n' -> pure n'
+  N2 sf ff -> do
+    s <- nock n sf
+    f <- nock n ff
+    match f >>= \case
+      Just jet -> pure (jet s)
+      Nothing  -> nock s (nounToNock f)
+  N3 f -> nock n f <&> \case
+    C{} -> yes
+    A{} -> no
+  N4 f -> nock n f <&> \case
+    C{} -> error "nock: cannot increment cell"
+    A a -> A (a + 1)
+  N5 f g -> loob <$> ((==) <$> nock n f <*> nock n g)
+  N6 f g h -> nock n f >>= \case
+    (A 0) -> nock n g
+    (A 1) -> nock n h
+    _ -> error "nock: invalid test value"
+  N7 f g -> do
+    n' <- nock n f
+    nock n' g
+  N8 f g -> do
+    n' <- nock n f
+    nock (C n' n) g
+  N9 a f -> do
+    c <- nock n f
+    nock c (nounToNock (axis a c))
+  N10 (a, f) g -> edit a <$> nock n f <*> nock n g
+  N11 _ f -> nock n f
+  N12{} -> error "nock: scrying is not allowed"
+

pkg/hs/proto/lib/SimpleNoun.hs

@@ -0,0 +1,122 @@
+module SimpleNoun where
+
+import ClassyPrelude
+import Numeric.Natural
+
+import qualified Urbit.Noun as N
+
+type Atom = Natural
+
+type Noun = Tree Atom
+data Tree a
+  = A !a
+  | C !(Tree a) !(Tree a)
+  deriving (Eq, Ord, Read, Functor, Generic)
+
+instance Hashable a => Hashable (Tree a)
+
+data Fern a
+  = FernA !a
+  | FernF [Fern a]
+
+toFern :: Tree a -> Fern a
+toFern = \case
+  A a -> FernA a
+  C h t -> case toFern t of
+    a@FernA{} -> FernF [toFern h, a]
+    FernF fs -> FernF (toFern h : fs)
+
+instance Show a => Show (Fern a) where
+  show = \case
+    FernA a -> show a
+    FernF xs -> "[" <> intercalate " " (map show xs) <> "]"
+
+instance Show a => Show (Tree a) where
+  show = show . toFern
+
+yes, no :: Noun
+yes = A 0
+no  = A 1
+
+loob :: Bool -> Noun
+loob = \case
+  True  -> yes
+  False -> no
+
+textToAtom :: Text -> Atom
+textToAtom t = case N.textToUtf8Atom t of
+  N.A a -> a
+
+showA :: Atom -> String
+showA a = show (N.A a)
+
+tshowA :: Atom -> Text
+tshowA = pack . showA
+
+-- | Tree address
+type Axis = Atom
+
+data Dir = L | R
+  deriving (Eq, Ord, Enum, Read, Show)
+type Path = [Dir]
+
+-- some stuff from hoon.hoon
+
+cap :: Axis -> Dir
+cap = \case
+  2 -> L
+  3 -> R
+  a | a <= 1    -> error "cap: bad axis"
+    | otherwise -> cap (div a 2)
+
+mas :: Axis -> Axis
+mas = \case
+  2 -> 1
+  3 -> 1
+  a | a <= 1    -> error "mas: bad axis"
+    | otherwise -> (mod a 2) + 2 * mas (div a 2)
+
+capMas :: Axis -> (Dir, Axis)
+capMas = \case
+  2 -> (L, 1)
+  3 -> (R, 1)
+  a | a <= 1    -> error "capMas: bad axis"
+    | otherwise -> (d, (mod a 2) + 2 * r)
+    where
+      (d, r) = capMas (div a 2)
+
+peg :: Axis -> Axis -> Axis
+peg a = \case
+  1 -> a
+  2 -> a * 2
+  3 -> a * 2 + 1
+  b -> (mod b 2) + 2 * peg a (div b 2)
+
+axis :: Axis -> Tree a -> Tree a
+axis 1 n = n
+axis (capMas -> (d, r)) (C n m) = case d of
+  L -> axis r n
+  R -> axis r m
+axis a _ = error ("bad axis: " ++ show a)
+
+edit :: Axis -> Tree a -> Tree a -> Tree a
+edit 1 v n = v
+edit (capMas -> (d, r)) v (C n m) = case d of
+  L -> C (edit r v n) m
+  R -> C n (edit r v m)
+edit a _ _ = error ("bad edit: " ++ show a)
+
+-- Write an axis as a binary number; e.g. 5 as 101.
+-- The rule is: after droping the 1 in the msb, you read from left to right.
+-- 0 becomes L and 1 becomes R. So 5 becomes [L,R]
+toPath :: Axis -> Path
+toPath = \case
+  1 -> []
+  (capMas -> (d, r)) -> d : toPath r
+
+toAxis :: Path -> Axis
+toAxis = foldl' step 1
+  where
+    step r = \case
+      L -> 2 * r
+      R -> 2 * r + 1

pkg/hs/proto/lib/Untyped/CST.hs

@@ -0,0 +1,54 @@
+module Untyped.CST where
+
+import ClassyPrelude
+import Prelude (foldr1)
+
+import SimpleNoun
+import qualified Untyped.Hoon as H
+import Untyped.Parser  -- remove after we've moved the CST type
+
+hone :: CST -> H.Hoon Sym
+hone = go
+  where
+    go = \case 
+      WutCol c d e -> H.WutCol (go c) (go d) (go e)
+      WutPat c d e -> H.WutPat (go c) (go d) (go e)
+      WutKet c d e -> H.WutKet (go c) (go d) (go e)
+      WutPam cs -> foldr H.WutPam (H.HAtom 0) $ map go cs
+      WutBar cs -> foldr H.WutBar (H.HAtom 1) $ map go cs
+      WutHep c pcs -> H.WutHep (go c) (map tr pcs)
+      TisFas s c d -> H.TisFas s (go c) (go d)
+      ColHep c d -> H.HCons (go c) (go d)
+      ColLus{} -> error "hone: offensive rune :+ -- use :*"
+      ColKet{} -> error "hone: offensive rune :^ -- use :*"
+      ColTar [] -> error "hone: empty :*"
+      ColTar cs -> foldr1 H.HCons $ map go cs
+      ColSig cs -> foldr H.HCons (H.HAtom 0) $ map go cs
+      BarTis s c -> H.BarTis s (go c)
+      BarHep r v i c -> H.BarHep r v (go i) (go c)
+      BarCen pcs -> H.BarCen (map tr pcs)
+      CenHep c d -> H.CenHep (go c) (go d)
+      CenDot c d -> H.CenDot (go c) (go d)
+      DotDot s c -> H.DotDot s (go c)
+      SigFas (go -> H.HAtom a) c -> H.SigFas a (go c)
+      SigFas{} -> error "hone: invalid ~/ tag"
+      ZapZap -> H.ZapZap
+      Tupl cs -> go (ColTar cs)
+      Var s -> H.HVar s
+      Atom a -> H.HAtom a
+      Tag tx -> H.HAtom (textToAtom tx)
+      Cord tx -> H.HAtom (textToAtom tx)
+      Tape tx -> undefined
+      Incr c -> H.DotLus (go c)
+      IncrIrr c -> H.DotLus (go c)
+      AppIrr c d -> H.CenHep (go c) (go d)
+      IsEq c d -> H.DotTis (go c) (go d)
+      IsEqIrr c d -> H.DotTis (go c) (go d)
+      Pam -> H.HAtom 0
+      Bar -> H.HAtom 1
+      Yes -> H.HAtom 0
+      No -> H.HAtom 1
+      Sig -> H.HAtom 0
+
+    tr (PatTar, c) = (H.Wild, go c)
+    tr (PatTag s, c) = (H.Exact (A $ textToAtom s), go c)

pkg/hs/proto/lib/Untyped/Core.hs

@@ -0,0 +1,230 @@
+module Untyped.Core where
+
+import ClassyPrelude
+
+import Bound
+import Control.Monad.Writer hiding (fix)
+import Data.Deriving (deriveEq1, deriveOrd1, deriveRead1, deriveShow1)
+import qualified Data.Function as F
+import Data.List (elemIndex)
+import Data.Maybe (fromJust)
+import qualified Data.Set as Set
+import Data.Void
+
+import Dashboard (pattern FastAtom)
+import Nock
+import SimpleNoun
+
+type Nat = Int
+
+data Exp a
+  = Var a
+  | App (Exp a) (Exp a)
+  | Lam (Scope () Exp a)
+  | Atm Atom
+  | Cel (Exp a) (Exp a)
+  | IsC (Exp a)
+  | Suc (Exp a)
+  | Eql (Exp a) (Exp a)
+  | Ift (Exp a) (Exp a) (Exp a)
+  | Let (Exp a) (Scope () Exp a)
+  | Jet Atom (Exp a)
+  | Fix (Scope () Exp a)
+  | Zap
+  deriving (Functor, Foldable, Traversable)
+
+deriveEq1   ''Exp
+deriveOrd1  ''Exp
+deriveRead1 ''Exp
+deriveShow1 ''Exp
+makeBound   ''Exp
+
+deriving instance Eq a => Eq (Exp a)
+deriving instance Ord a => Ord (Exp a)
+deriving instance Read a => Read (Exp a)
+deriving instance Show a => Show (Exp a)
+
+lam :: Eq a => a -> Exp a -> Exp a
+lam v e = Lam (abstract1 v e)
+
+ledt :: Eq a => a -> Exp a -> Exp a -> Exp a
+ledt v e f = Let e (abstract1 v f)
+
+fix :: Eq a => a -> Exp a -> Exp a
+fix v e = Fix (abstract1 v e)
+
+-- | The expression that returns the given noun as a constant.
+con :: Noun -> Exp a
+con = \case
+  A a   -> Atm a
+  C n m -> Cel (con n) (con m)
+
+data CExp a
+  = CVar a
+  | CSef a
+  | CApp (CExp a) (CExp a)
+  | CLam [a] (CExp (Var () Int))
+  | CAtm Atom
+  | CCel (CExp a) (CExp a)
+  | CIsC (CExp a)
+  | CSuc (CExp a)
+  | CEql (CExp a) (CExp a)
+  | CIft (CExp a) (CExp a) (CExp a)
+  | CLet (CExp a) (CExp (Var () a))
+  | CJet Atom (CExp a)
+  | CFix [a] (CExp (Var () Int))
+  | CZap
+  deriving (Functor, Foldable, Traversable)
+
+deriveEq1   ''CExp
+deriveOrd1  ''CExp
+deriveRead1 ''CExp
+deriveShow1 ''CExp
+
+deriving instance Eq a => Eq (CExp a)
+deriving instance Ord a => Ord (CExp a)
+deriving instance Read a => Read (CExp a)
+deriving instance Show a => Show (CExp a)
+
+data Manner a
+  = Direct a
+  | Selfish a
+  deriving (Functor, Foldable, Traversable)
+
+rude :: Manner a -> a
+rude = \case
+  Direct x  -> x
+  Selfish x -> x
+
+toCopy :: Ord a => Exp a -> CExp b
+toCopy = fst . runWriter . go \v -> error "toCopy: free variable"
+  where
+    go :: Ord a => (a -> Manner c) -> Exp a -> Writer (Set a) (CExp c)
+    go env = \case
+      Var v     -> do
+        tell (singleton v)
+        case env v of
+          Direct  v' -> pure (CVar v')
+          Selfish v' -> pure (CSef v')
+      App e f   -> CApp <$> go env e <*> go env f
+      Atm a     -> pure (CAtm a)
+      Cel e f   -> CCel <$> go env e <*> go env f
+      IsC e     -> CIsC <$> go env e
+      Suc e     -> CSuc <$> go env e
+      Eql e f   -> CEql <$> go env e <*> go env f
+      Ift e t f -> CIft <$> go env e <*> go env t <*> go env f
+      Jet a e   -> CJet a <$> go env e
+      Zap       -> pure CZap
+      Let e s   -> do
+        ce <- go env e
+        let
+          env' = \case
+            B () -> Direct (B ())
+            F x  -> fmap F (env x)
+        cf <- retcon removeBound (go env' (fromScope s))
+        pure (CLet ce cf)
+      Fix s     -> lam s env CFix Selfish
+      Lam s     -> lam s env CLam Direct
+
+    lam s env ctor manner =
+      writer
+        ( ctor (rude . env <$> Set.toAscList usedLexicals) ce
+        , usedLexicals
+        )
+      where
+        (ce, usedVars) = runWriter $ go env' $ fromScope s
+        env' = \case
+          B () -> manner $ B ()
+          F v  -> env v $> F (Set.findIndex v usedLexicals)
+        usedLexicals = removeBound usedVars
+
+    removeBound :: (Ord a, Ord b) => Set (Var b a) -> Set a
+    removeBound = mapMaybeSet \case
+      B _ -> Nothing
+      F v -> Just v
+
+-- | Like censor, except you can change the type of the log
+retcon :: (w -> uu) -> Writer w a -> Writer uu a
+retcon f = mapWriter \(a, m) -> (a, f m)
+
+-- I begin to wonder why there aren't primary abstractions around filtering.
+mapMaybeSet :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
+mapMaybeSet f = setFromList . mapMaybe f . toList
+
+-- Possible improvements:
+--   - a "quote and unquote" framework for nock code generation (maybe)
+copyToNock :: CExp a -> Nock
+copyToNock = go \v -> error "copyToNock: free variable"
+  where
+    -- if you comment out this declaration, you get a type error!
+    go :: (a -> Path) -> CExp a -> Nock
+    go env = \case
+      CVar v     -> N0 (toAxis $ env v)
+      CSef v     -> N2 (N0 $ toAxis $ env v) (N0 $ toAxis $ env v)
+      CApp e f   -> N2 (go env f) (go env e)
+      CAtm a     -> N1 (A a)
+      CCel e f   -> cell (go env e) (go env f)
+      CIsC e     -> N3 (go env e)
+      CSuc e     -> N4 (go env e)
+      CEql e f   -> N5 (go env e) (go env f)
+      CIft e t f -> N6 (go env e) (go env t) (go env f)
+      CJet a e   -> jet a (go env e)
+      CZap       -> N0 0
+      CLet e f   -> N8 (go env e) (go env' f)
+        where
+          env' = \case
+            B ()   -> [L]
+            F v    -> R : env v
+      CLam vs e  -> lam (map (go env . CVar) vs) (go (lamEnv vs) e)
+      CFix vs e  ->
+        N7
+          (lam (map (go env . CVar) vs) (go (lamEnv vs) e))
+          (N2 (N0 1) (N0 1))
+
+    lamEnv vs = if null vs
+      then \case
+        B () -> []
+        F _  -> error "copyToNock: unexpected lexical"
+      else \case
+        B () -> [R]
+        F i  -> L : posIn i (length vs)
+      
+    jet a ef =
+      NC
+        (N1 (A 11))
+        (NC
+          (N1
+            (C (A FastAtom)
+              (C (A 1) (A a))))
+          ef)
+    lam vfs ef = case layOut vfs of
+      Nothing -> N1 (nockToNoun ef)
+      Just pr -> NC (N1 (A 8)) $ NC (NC (N1 (A 1)) pr) $ N1 (nockToNoun ef)
+
+cell :: Nock -> Nock -> Nock
+cell (N1 n) (N1 m) = N1 (C n m)
+cell ef ff = NC ef ff
+
+layOut :: [Nock] -> Maybe Nock
+layOut = \case
+  []  -> Nothing
+  [x] -> Just x
+  xs  -> Just $ NC (fromJust $ layOut l) (fromJust $ layOut r)
+    where
+      (l, r) = splitAt (length xs `div` 2) xs
+
+posIn :: Int -> Int -> Path
+posIn 0 1 = []
+posIn i n
+  | i < 0 || n <= i = error ("posIn: " <> show i <> " out of bound " <> show n)
+  | i < mid         = L : posIn i mid
+  | otherwise       = R : posIn (i - mid) (n - mid)
+  where mid = n `div` 2
+
+-- | The proposed new calling convention
+copy :: Ord a => Exp a -> Nock
+copy = copyToNock . toCopy
+
+-- | Decrements its argument.
+decrement :: Exp String
+decrement = lam "a" $ App (fix "f" $ lam "b" $ Ift (Eql (Var "a") (Suc (Var "b"))) (Var "b") (App (Var "f") (Suc (Var "b")))) (Atm 0)

pkg/hs/proto/lib/Untyped/Hoon.hs

@@ -0,0 +1,77 @@
+module Untyped.Hoon where
+
+import ClassyPrelude
+
+import Bound
+import Bound.Name
+
+import SimpleNoun
+import Untyped.Core
+
+data Hoon a
+  = HVar a
+  | HAtom Atom
+  | HCons (Hoon a) (Hoon a)
+  | BarCen (Cases a)
+  | BarHep a a (Hoon a) (Hoon a)
+  | BarTis a (Hoon a)
+  | CenDot (Hoon a) (Hoon a)
+  | CenHep (Hoon a) (Hoon a)
+--  | CenKet (Hoon a) (Hoon a) (Hoon a)
+--  | CenTar [Hoon a]
+  | TisFas a (Hoon a) (Hoon a)
+  | DotDot a (Hoon a)
+  | DotLus (Hoon a)
+  | DotTis (Hoon a) (Hoon a)
+  | SigFas Atom (Hoon a)
+  | WutBar (Hoon a) (Hoon a)
+  | WutCol (Hoon a) (Hoon a) (Hoon a)
+  | WutHep (Hoon a) (Cases a)
+  | WutKet (Hoon a) (Hoon a) (Hoon a)
+  | WutPam (Hoon a) (Hoon a)
+  | WutPat (Hoon a) (Hoon a) (Hoon a)
+  | ZapZap
+  deriving (Functor)
+
+deriving instance Show a => Show (Hoon a)
+
+type Cases a = [(Pat, Hoon a)]
+
+data Pat
+  = Exact Noun
+  | Wild
+  deriving (Show)
+
+desugar :: Eq a => Hoon a -> Exp a
+desugar = go
+  where
+    go = \case
+      HVar v         -> Var v
+      HAtom a        -> Atm a
+      HCons h j      -> Cel (go h) (go j)
+      BarCen cs      -> Lam $ Scope $ branch (Var . F . go) (Var (B ())) cs
+      BarHep r s i h -> go $ CenDot i $ DotDot r $ BarTis s $ h
+      BarTis v h     -> lam v (go h)
+      CenDot h j     -> App (go j) (go h)
+      CenHep h j     -> App (go h) (go j)
+      TisFas v h j   -> ledt v (go h) (go j)
+      DotDot v h     -> fix v (go h)
+      DotLus h       -> Suc (go h)
+      DotTis h j     -> Eql (go h) (go j)
+      SigFas a h     -> Jet a (go h)
+      WutBar h j     -> Ift (go h) (Atm 0) (go j)
+      WutCol h j k   -> Ift (go h) (go j) (go k)
+      -- or branch go (go h) cs
+      WutHep h cs    -> Let (go h) $ Scope $ branch (Var . F . go) (Var (B ())) cs
+      WutKet h j k   -> Ift (IsC (go h)) (go j) (go k)
+      WutPam h j     -> Ift (go h) (go j) (Atm 1)
+      WutPat h j k   -> go $ WutKet h k j
+      ZapZap         -> Zap
+
+branch :: (Hoon b -> Exp a) -> Exp a -> Cases b -> Exp a
+branch go e = foldr f Zap
+  where
+   f c acc = case c of
+     (Exact n, h) -> Ift (Eql e (con n)) (go h) acc
+     (Wild,    h) -> go h
+

pkg/hs/proto/lib/Untyped/Parser.hs

@@ -0,0 +1,345 @@
+module Untyped.Parser where
+
+import ClassyPrelude hiding (head, many, some, try)
+import Control.Lens
+import GHC.Natural
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Control.Monad.State.Lazy
+
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Void          (Void)
+import Prelude            (head)
+import Text.Format.Para   (formatParas)
+
+import qualified Data.MultiMap     as MM
+import qualified Data.Text         as T
+import qualified Data.Text.Lazy    as LT
+import qualified Data.Text.Lazy.IO as LT
+import qualified Prelude
+
+
+-- Types -----------------------------------------------------------------------
+
+type Nat  = Natural
+type Sym  = Text
+
+
+-- CST -------------------------------------------------------------------------
+
+data Pat
+    = PatTar
+    | PatTag Sym
+  deriving (Eq, Ord, Show)
+
+data CST
+    = WutCol CST CST CST          --  ?:(c t f)
+    | WutPat CST CST CST          --  ?@(c t f)
+    | WutKet CST CST CST          --  ?^(c t f)
+    | WutPam [CST]                --  ?&(c cs ...)
+    | WutBar [CST]                --  ?|(c cs ...)
+    | WutHep CST [(Pat, CST)]     --  ?-(c p e ps es ...)
+    | TisFas Sym CST CST          --  =/(x 3 x)
+    | ColHep CST CST              --  :-(a b)
+    | ColLus CST CST CST          --  :+(a b c)
+    | ColKet CST CST CST CST      --  :^(a b c d)
+    | ColTar [CST]                --  :*(a as ...)
+    | ColSig [CST]                --  :~(a as ...)
+    | BarTis Sym CST              --  |=(s h)
+    | BarHep Sym Sym CST CST      --  |-(rec var init body)
+    | BarCen [(Pat, CST)]         --  |%  %a  3  ==
+    | CenHep CST CST              --  %-  f  x
+    | CenDot CST CST              --  %.  x  f
+    | DotDot Sym CST              --  ..  $  f
+    | SigFas CST CST
+    | ZapZap                      --  !!
+    | Tupl [CST]                  --  [a b ...]
+    | Var  Sym                    --  a
+    | Atom Nat                    --  3
+    | Tag Text                    --  %asdf
+    | Cord Text                   --  'cord'
+    | Tape Text                   --  "tape"
+    | Incr CST                    --  .+(3)
+    | IncrIrr CST                 --  +(3)
+    | AppIrr CST CST              --  (x y)
+    | IsEq CST CST                --  .=(3 4)
+    | IsEqIrr CST CST             --  =(3 4)
+    | Pam                         --  &
+    | Bar                         --  |
+    | Yes                         --  %.y
+    | No                          --  %.n
+    | Sig                         --  ~
+  deriving (Eq, Ord, Show)
+
+-- Parser Monad ----------------------------------------------------------------
+
+data Mode = Wide | Tall
+  deriving (Eq, Ord, Show)
+
+type Parser = StateT Mode (Parsec Void Text)
+
+withLocalState ∷ Monad m => s → StateT s m a → StateT s m a
+withLocalState val x = do { old <- get; put val; x <* put old }
+
+inWideMode ∷ Parser a → Parser a
+inWideMode = withLocalState Wide
+
+ace, pal, par ∷ Parser ()
+ace = void (char ' ')
+pal = void (char '(')
+par = void (char ')')
+
+-- Simple Lexers ---------------------------------------------------------------
+
+gap ∷ Parser ()
+gap = choice [ char ' ' >> void (some spaceChar)
+             , newline  >> void (many spaceChar)
+             ]
+
+whitespace ∷ Parser ()
+whitespace = ace <|> void gap
+
+
+-- Literals --------------------------------------------------------------------
+
+alpha ∷ Parser Char
+alpha = oneOf (['a'..'z'] ++ ['A'..'Z'])
+
+sym ∷ Parser Sym
+sym = bucSym <|> pack <$> some alpha
+  where bucSym = char '$' *> pure ""
+
+atom ∷ Parser Nat
+atom = do
+  init ← some digitChar
+  rest ← many (char '.' *> some digitChar)
+  guard True -- TODO Validate '.'s
+  pure (Prelude.read $ concat $ init:rest)
+
+nat ∷ Parser Nat
+nat = Prelude.read <$> some digitChar
+
+tape ∷ Parser Text
+tape = do
+  between (char '"') (char '"') $
+    pack <$> many (label "tape char" (anySingleBut '"'))
+
+cord ∷ Parser Text
+cord = do
+  between (char '\'') (char '\'') $
+    pack <$> many (label "cord char" (anySingleBut '\''))
+
+tag ∷ Parser Text
+tag = try (char '%' >> sym)
+
+literal ∷ Parser CST
+literal = choice
+  [ Yes  <$  string "%.y"
+  , No   <$  string "%.n"
+  , Var  <$> sym
+  , Atom <$> atom
+  , Pam  <$  char '&'
+  , Bar  <$  char '|'
+  , Sig  <$  char '~'
+  , Tag  <$> tag
+  , Cord <$> cord
+  , Tape <$> tape
+  ]
+
+
+-- Rune Helpers ----------------------------------------------------------------
+
+{-
+    - If the parser is in `Wide` mode, only accept the `wide` form.
+    - If the parser is in `Tall` mode, either
+      - accept the `tall` form or:
+      - swich to `Wide` mode and then accept the wide form.
+-}
+parseRune ∷ Parser a → Parser a → Parser a
+parseRune tall wide = get >>= \case
+  Wide → wide
+  Tall → tall <|> inWideMode wide
+
+rune0 ∷ a → Parser a
+rune0 = pure
+
+rune1 ∷ (a→b) → Parser a → Parser b
+rune1 node x = parseRune tall wide
+  where tall = do gap; p←x;      pure (node p)
+        wide = do pal; p←x; par; pure (node p)
+
+rune2 ∷ (a→b→c) → Parser a → Parser b → Parser c
+rune2 node x y = parseRune tall wide
+  where tall = do gap; p←x; gap; q←y;      pure (node p q)
+        wide = do pal; p←x; ace; q←y; par; pure (node p q)
+
+rune3 ∷ (a→b→c→d) → Parser a → Parser b → Parser c → Parser d
+rune3 node x y z = parseRune tall wide
+  where tall = do gap; p←x; gap; q←y; gap; r←z;      pure (node p q r)
+        wide = do pal; p←x; ace; q←y; ace; r←z; par; pure (node p q r)
+
+rune4 ∷ (a→b→c→d→e) → Parser a → Parser b → Parser c → Parser d → Parser e
+rune4 node x y z g = parseRune tall wide
+  where tall = do gap; p←x; gap; q←y; gap; r←z; gap; s←g; pure (node p q r s)
+        wide = do pal; p←x; ace; q←y; ace; r←z; ace; s←g; pure (node p q r s)
+
+runeN ∷ ([a]→b) → Parser a → Parser b
+runeN node elem = node <$> parseRune tall wide
+  where tall = gap >> elems
+                 where elems   = term <|> elemAnd
+                       elemAnd = do x ← elem; gap; xs ← elems; pure (x:xs)
+                       term    = string "==" *> pure []
+        wide = pal *> option [] elems <* par
+                 where elems = (:) <$> elem <*> many (ace >> elem)
+
+runeNE ∷ (NonEmpty a → b) → Parser a → Parser b
+runeNE node elem = node <$> parseRune tall wide
+  where tall = do
+          let elems   = term <|> elemAnd
+              elemAnd = do x ← elem; gap; xs ← elems; pure (x:xs)
+              term    = string "==" *> pure []
+          fst <- gap *> elem
+          rst <- gap *> elems
+          pure (fst :| rst)
+        wide = mzero -- No wide form for cores
+
+-- Irregular Syntax ------------------------------------------------------------
+
+inc ∷ Parser CST -- +(3)
+inc = do
+  string "+("
+  h ← cst
+  char ')'
+  pure h
+
+equals ∷ Parser (CST, CST) -- =(3 4)
+equals = do
+  string "=("
+  x ← cst
+  ace
+  y ← cst
+  char ')'
+  pure (x, y)
+
+tuple ∷ ∀a. Parser a → Parser [a]
+tuple p = char '[' >> elems
+  where
+    xs ∷ Parser [a]
+    xs = do { x ← p; (x:) <$> tail }
+
+    tail ∷ Parser [a]
+    tail = (pure [] <* char ']')
+       <|> (ace >> elems)
+
+    elems ∷ Parser [a]
+    elems = (pure [] <* char ']') <|> xs
+
+appIrr ∷ Parser CST
+appIrr = do
+  char '('
+  x <- cst
+  char ' '
+  y <- cst
+  char ')'
+  pure (AppIrr x y)
+
+irregular ∷ Parser CST
+irregular =
+  inWideMode $
+    choice [ Tupl            <$> tuple cst
+           , IncrIrr         <$> inc
+           , uncurry IsEqIrr <$> equals
+           , appIrr
+           ]
+
+-- Runes -----------------------------------------------------------------------
+
+pat ∷ Parser Pat
+pat = choice [ PatTag   <$> tag
+             , char '*'  $> PatTar
+             ]
+
+cases ∷ Parser [(Pat, CST)]
+cases = do
+    mode ← get
+    guard (mode == Tall)
+    end <|> lop
+  where
+    goo = lop <|> end
+    end = string "==" $> []
+    lop = do { p <- pat; gap; b <- cst; gap; ((p,b):) <$> goo }
+
+wutHep ∷ Parser CST
+wutHep = do
+    mode ← get
+    guard (mode == Tall)
+    gap
+    ex <- cst
+    gap
+    cs <- cases
+    pure (WutHep ex cs)
+
+barCen ∷ Parser CST
+barCen = do
+    mode ← get
+    guard (mode == Tall)
+    gap
+    cs <- cases
+    pure (BarCen cs)
+
+rune ∷ Parser CST
+rune = runeSwitch [ ("|=", rune2 BarTis sym cst)
+                  , ("|-", rune4 BarHep sym sym cst cst)
+                  , (":-", rune2 ColHep cst cst)
+                  , (":+", rune3 ColLus cst cst cst)
+                  , (":^", rune4 ColKet cst cst cst cst)
+                  , (":*", runeN ColTar cst)
+                  , (":~", runeN ColSig cst)
+                  , ("%-", rune2 CenHep cst cst)
+                  , ("%.", rune2 CenDot cst cst)
+                  , ("..", rune2 DotDot sym cst)
+                  , ("!!", rune0 ZapZap)
+                  , ("?:", rune3 WutCol cst cst cst)
+                  , ("?@", rune3 WutPat cst cst cst)
+                  , ("?&", runeN WutPam cst)
+                  , ("?|", runeN WutBar cst)
+                  , ("?^", rune3 WutKet cst cst cst)
+                  , ("=/", rune3 TisFas sym cst cst)
+                  , (".+", rune1 Incr cst)
+                  , (".=", rune2 IsEq cst cst)
+                  , ("?-", wutHep)
+                  , ("|%", barCen)
+                  , ("~/", rune2 SigFas cst cst)
+                  ]
+
+runeSwitch ∷ [(Text, Parser a)] → Parser a
+runeSwitch = choice . fmap (\(s, p) → string s *> p)
+
+
+-- CST Parser ------------------------------------------------------------------
+
+cst ∷ Parser CST
+cst = irregular <|> rune <|> literal
+
+
+-- Entry Point -----------------------------------------------------------------
+
+hoonFile = do
+  option () whitespace
+  h ← cst
+  option () whitespace
+  eof
+  pure h
+
+parse ∷ Text → Either Text CST
+parse txt =
+  runParser (evalStateT hoonFile Tall) "stdin" txt & \case
+    Left  e → Left (pack $ errorBundlePretty e)
+    Right x → pure x
+
+parseHoonTest ∷ Text → IO ()
+parseHoonTest = parseTest (evalStateT hoonFile Tall)
+
+main ∷ IO ()
+main = (head <$> getArgs) >>= parseHoonTest

pkg/hs/proto/lib/Untyped/ShittyCorePrinter.hs

@@ -0,0 +1,24 @@
+module Untyped.ShittyCorePrinter where
+
+-- it's pretty clowny but whatever
+-- TODO: handle the new cases (maybe don't do)
+
+import Prelude
+
+import Bound
+import Data.Foldable
+
+import Untyped.Core
+
+prettyPrec :: [String] -> Bool -> Int -> Exp String -> ShowS
+prettyPrec _      d n (Var a)    = showString a
+prettyPrec vs     d n (App x y)  = showParen d $ 
+  prettyPrec vs False n x . showChar ' ' . prettyPrec vs True n y
+prettyPrec (v:vs) d n (Lam b)    = showParen d $ 
+  showString v . showString ". " . prettyPrec vs False n (instantiate1 (Var v) b)
+
+prettyWith :: [String] -> Exp String -> String
+prettyWith vs t = prettyPrec (filter (`notElem` toList t) vs) False 0 t ""
+
+pretty :: Exp String -> String
+pretty = prettyWith $ [ [i] | i <- ['a'..'z']] ++ [i : show j | j <- [1 :: Int ..], i <- ['a'..'z'] ]

pkg/hs/proto/package.yaml

@@ -0,0 +1,91 @@
+name: proto
+version: 0.1.0
+license: MIT
+license-file: LICENSE
+
+dependencies:
+  - base
+  - bound
+  - classy-prelude
+  - containers
+  - deriving-compat
+  - lens
+  - megaparsec
+  - mtl
+  - multimap
+  - para
+  - pretty-show
+  - text
+  - transformers
+  - transformers-compat
+  - unordered-containers
+  - urbit-king
+
+default-extensions:
+  - ApplicativeDo
+  - BangPatterns
+  - BlockArguments
+  - DeriveAnyClass
+  - DeriveDataTypeable
+  - DeriveFoldable
+  - DeriveGeneric
+  - DeriveTraversable
+  - DerivingStrategies
+  - EmptyDataDecls
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - GADTs
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - MultiParamTypeClasses
+  - NamedFieldPuns
+  - NoImplicitPrelude
+  - NumericUnderscores
+  - OverloadedStrings
+  - PartialTypeSignatures
+  - PatternSynonyms
+  - QuasiQuotes
+  - Rank2Types
+  - RankNTypes
+  - RecordWildCards
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TemplateHaskell
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - UnicodeSyntax
+  - ViewPatterns
+
+library:
+  source-dirs: lib
+  ghc-options:
+    - -fwarn-incomplete-patterns
+    - -fwarn-unused-binds
+    - -fwarn-unused-imports
+    - -O2
+
+executables:
+  proto:
+    main: Main.hs
+    source-dirs: app
+    dependencies:
+      - proto
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -O2
+      - "-with-rtsopts=-N"
+      - -fwarn-incomplete-patterns
+
+tests:
+  proto-test:
+    main: Spec.hs
+    source-dirs: test
+    dependencies:
+      - proto
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N

pkg/hs/proto/test/Spec.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import ClassyPrelude
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"

pkg/hs/stack.yaml

@@ -0,0 +1,26 @@
+resolver: lts-14.21
+
+packages:
+  - lmdb-static
+  - proto
+  - terminal-progress-bar
+  - urbit-atom
+  - urbit-azimuth
+  - urbit-king
+
+extra-deps:
+  - flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38
+  - base58-bytestring-0.1.0@sha256:a1da72ee89d5450bac1c792d9fcbe95ed7154ab7246f2172b57bd4fd9b5eab79
+  - lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00
+  - urbit-hob-0.3.1@sha256:afbdc7ad071eefc6ca85f5b598b6c62ed49079d15d1840dac27438a3b3150303
+  - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81
+
+# This allows building on NixOS.
+nix:
+  packages:
+    - pkgconfig
+    - zlib
+
+# TODO: Why is this here?
+ghc-options:
+  urbit-king: '-optP-Wno-nonportable-include-path'

pkg/hs/terminal-progress-bar/LICENSE

@@ -0,0 +1 @@
+../LICENSE

pkg/hs/terminal-progress-bar/README.markdown

@@ -0,0 +1 @@
+../README.markdown

pkg/hs/terminal-progress-bar/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

pkg/hs/terminal-progress-bar/bench/bench.hs

@@ -0,0 +1,51 @@
+{-# language PackageImports #-}
+module Main where
+
+import "base" Data.Monoid ( (<>) )
+import "criterion" Criterion.Main
+import "terminal-progress-bar" System.ProgressBar
+import "time" Data.Time.Clock ( UTCTime(..) )
+
+main :: IO ()
+main = defaultMain
+       [ renderProgressBarBenchmark  10   0
+       , renderProgressBarBenchmark  10  50
+       , renderProgressBarBenchmark  10 100
+       , renderProgressBarBenchmark 100   0
+       , renderProgressBarBenchmark 100  50
+       , renderProgressBarBenchmark 100 100
+       , renderProgressBarBenchmark 200   0
+       , renderProgressBarBenchmark 200  50
+       , renderProgressBarBenchmark 200 100
+       , labelBenchmark "percentage" percentage (Progress   0 100 ())
+       , labelBenchmark "percentage" percentage (Progress  50 100 ())
+       , labelBenchmark "percentage" percentage (Progress 100 100 ())
+       , labelBenchmark "exact"      exact      (Progress   0 100 ())
+       , labelBenchmark "exact"      exact      (Progress  50 100 ())
+       , labelBenchmark "exact"      exact      (Progress 100 100 ())
+       ]
+
+renderProgressBarBenchmark :: Int -> Int -> Benchmark
+renderProgressBarBenchmark width done =
+    bench name $ nf (\(s, p, t) -> renderProgressBar s p t)
+        ( defStyle{styleWidth = ConstantWidth width}
+        , Progress done 100 ()
+        , someTiming
+        )
+  where
+    name = "progressBar/default - "
+           <> show width <> " wide - progress " <> show done <> " % 100"
+
+labelBenchmark :: String -> Label () -> Progress () -> Benchmark
+labelBenchmark labelName label progress =
+    bench name $ nf (\(p, t) -> runLabel label p t) (progress, someTiming)
+  where
+    name = "label/" <> labelName <> " "
+           <> show (progressDone progress) <> " % "
+           <> show (progressTodo progress)
+
+someTime :: UTCTime
+someTime = UTCTime (toEnum 0) 0
+
+someTiming :: Timing
+someTiming = Timing someTime someTime

pkg/hs/terminal-progress-bar/changelog.md

@@ -0,0 +1 @@
+../changelog.md

pkg/hs/terminal-progress-bar/shell.nix

@@ -0,0 +1,2 @@
+(import ../.).haskellPackages.terminal-progress-bar.env
+# (import ../.).haskell.packages.ghc844.terminal-progress-bar.env

pkg/hs/terminal-progress-bar/src/System/ProgressBar.hs

@@ -0,0 +1,716 @@
+{-# language DeriveGeneric #-}
+{-# language GeneralizedNewtypeDeriving #-}
+{-# language OverloadedStrings #-}
+{-# language PackageImports #-}
+{-# language ScopedTypeVariables #-}
+
+{- |
+A progress bar in the terminal.
+
+A progress bar conveys the progress of a task. Use a progress bar to
+provide a visual cue that processing is underway.
+-}
+module System.ProgressBar
+    ( -- * Getting started
+      -- $start
+
+      -- * Example
+      -- $example
+
+      -- * Progress bars
+      ProgressBar
+    , newProgressBar
+    , killProgressBar
+    , hNewProgressBar
+    , renderProgressBar
+    , updateProgress
+    , incProgress
+      -- * Options
+    , Style(..)
+    , EscapeCode
+    , OnComplete(..)
+    , defStyle
+    , ProgressBarWidth(..)
+      -- * Progress
+    , Progress(..)
+      -- * Labels
+    , Label(..)
+    , Timing(..)
+    , msg
+    , percentage
+    , exact
+    , elapsedTime
+    , remainingTime
+    , totalTime
+    , renderDuration
+    ) where
+
+import "base" Control.Monad ( when )
+import "base" Data.Int       ( Int64 )
+import "base" Data.Monoid    ( Monoid, mempty )
+import "base" Data.Ratio     ( Ratio, (%) )
+import "base" Data.Semigroup ( Semigroup, (<>) )
+import "base" Data.String    ( IsString, fromString )
+import "base" GHC.Generics   ( Generic )
+import "deepseq" Control.DeepSeq ( NFData, rnf )
+import qualified "terminal-size" System.Console.Terminal.Size as TS
+import qualified "text" Data.Text.Lazy             as TL
+import qualified "text" Data.Text.Lazy.Builder     as TLB
+import qualified "text" Data.Text.Lazy.Builder.Int as TLB
+import "time" Data.Time.Clock ( UTCTime, NominalDiffTime, diffUTCTime, getCurrentTime )
+
+import ClassyPrelude (liftIO, MVar, newMVar, modifyMVar_)
+
+import RIO (logSticky, logStickyDone, HasLogFunc, RIO, display)
+
+--------------------------------------------------------------------------------
+
+-- | A terminal progress bar.
+--
+-- A 'ProgressBar' value contains the state of a progress bar.
+--
+-- Create a progress bar with 'newProgressBar' or 'hNewProgressBar'.
+-- Update a progress bar with 'updateProgress' or 'incProgress'.
+data ProgressBar s
+   = ProgressBar
+     { pbStyle :: !(Style s)
+     , pbStateMv :: !(MVar (State s))
+     , pbRefreshDelay :: !Double
+     , pbStartTime :: !UTCTime
+     }
+
+instance (NFData s) => NFData (ProgressBar s) where
+    rnf pb =  pbStyle pb
+        `seq` pbStateMv pb
+        `seq` pbRefreshDelay pb
+        `seq` pbStartTime pb
+        `seq` ()
+
+-- | State of a progress bar.
+data State s
+   = State
+     { stProgress :: !(Progress s)
+       -- ^ Current progress.
+     , stRenderTime :: !UTCTime
+       -- ^ Moment in time of last render.
+     }
+
+-- | An amount of progress.
+data Progress s
+   = Progress
+     { progressDone :: !Int
+       -- ^ Amount of work completed.
+     , progressTodo :: !Int
+       -- ^ Total amount of work.
+     , progressCustom :: !s
+       -- ^ A value which is used by custom labels. The builtin labels
+       -- do not care about this field. You can ignore it by using the
+       -- unit value '()'.
+     }
+
+progressFinished :: Progress s -> Bool
+progressFinished p = progressDone p >= progressTodo p
+
+-- | Creates a progress bar.
+--
+-- The progress bar is drawn immediately. Update the progress bar with
+-- 'updateProgress' or 'incProgress'. Do not output anything to your
+-- terminal between updates. It will mess up the animation.
+--
+-- The progress bar is written to 'stderr'. Write to another handle
+-- with 'hNewProgressBar'.
+newProgressBar
+    :: HasLogFunc e
+    => Style s -- ^ Visual style of the progress bar.
+    -> Double -- ^ Maximum refresh rate in Hertz.
+    -> Progress s -- ^ Initial progress.
+    -> RIO e (ProgressBar s)
+newProgressBar = hNewProgressBar
+
+-- | Creates a progress bar which outputs to the given handle.
+--
+-- See 'newProgressBar'.
+hNewProgressBar
+    :: HasLogFunc e
+    => Style s -- ^ Visual style of the progress bar.
+    -> Double -- ^ Maximum refresh rate in Hertz.
+    -> Progress s -- ^ Initial progress.
+    -> RIO e (ProgressBar s)
+hNewProgressBar style maxRefreshRate initProgress = do
+    style' <- updateWidth style
+
+    startTime <- liftIO getCurrentTime
+    hPutProgressBar style' initProgress (Timing startTime startTime)
+
+    stateMv <- newMVar
+      State
+      { stProgress   = initProgress
+      , stRenderTime = startTime
+      }
+    pure ProgressBar
+         { pbStyle = style'
+         , pbStateMv = stateMv
+         , pbRefreshDelay = recip maxRefreshRate
+         , pbStartTime = startTime
+         }
+
+-- | Update the width based on the current terminal.
+updateWidth :: Style s -> RIO e (Style s)
+updateWidth style =
+    case styleWidth style of
+      ConstantWidth {} -> pure style
+      TerminalWidth {} -> do
+        mbWindow <- liftIO TS.size
+        pure $ case mbWindow of
+          Nothing -> style
+          Just window -> style{ styleWidth = TerminalWidth (TS.width window) }
+
+-- | Change the progress of a progress bar.
+--
+-- This function is thread safe. Multiple threads may update a single
+-- progress bar at the same time.
+--
+-- There is a maximum refresh rate. This means that some updates might not be drawn.
+updateProgress
+    :: forall s e
+     . HasLogFunc e
+    => ProgressBar s -- ^ Progress bar to update.
+    -> (Progress s -> Progress s) -- ^ Function to change the progress.
+    -> RIO e ()
+updateProgress progressBar f = do
+    updateTime <- liftIO getCurrentTime
+    modifyMVar_ (pbStateMv progressBar) $ renderAndUpdate updateTime
+  where
+    renderAndUpdate :: UTCTime -> State s -> RIO e (State s)
+    renderAndUpdate updateTime state = do
+        when shouldRender $
+          hPutProgressBar (pbStyle progressBar) newProgress timing
+        pure State
+             { stProgress = newProgress
+             , stRenderTime = if shouldRender then updateTime else stRenderTime state
+             }
+      where
+        timing = Timing
+                 { timingStart = pbStartTime progressBar
+                 , timingLastUpdate = updateTime
+                 }
+
+        shouldRender = not tooFast || finished
+        tooFast = secSinceLastRender <= pbRefreshDelay progressBar
+        finished = progressFinished newProgress
+
+        newProgress = f $ stProgress state
+
+        -- Amount of time that passed since last render, in seconds.
+        secSinceLastRender :: Double
+        secSinceLastRender = realToFrac $ diffUTCTime updateTime (stRenderTime state)
+
+-- | Increment the progress of an existing progress bar.
+--
+-- See 'updateProgress' for more information.
+incProgress
+    :: HasLogFunc e
+    => ProgressBar s -- ^ Progress bar which needs an update.
+    -> Int -- ^ Amount by which to increment the progress.
+    -> RIO e ()
+incProgress pb n = updateProgress pb $ \p -> p{ progressDone = progressDone p + n }
+
+killProgressBar :: HasLogFunc e => ProgressBar s -> RIO e ()
+killProgressBar _ = pure ()
+
+hPutProgressBar :: HasLogFunc e => Style s -> Progress s -> Timing -> RIO e ()
+hPutProgressBar style progress timing = do
+    let barStr = (display (renderProgressBar style progress timing))
+    logSticky barStr
+    when (progressFinished progress) $ do
+        logStickyDone barStr
+
+-- | Renders a progress bar.
+--
+-- >>> let t = UTCTime (ModifiedJulianDay 0) 0
+-- >>> renderProgressBar defStyle (Progress 30 100 ()) (Timing t t)
+-- "[============>..............................]  30%"
+--
+-- Note that this function can not use 'TerminalWidth' because it
+-- doesn't use 'IO'. Use 'newProgressBar' or 'hNewProgressBar' to get
+-- automatic width.
+renderProgressBar
+    :: Style s
+    -> Progress s -- ^ Current progress.
+    -> Timing -- ^ Timing information.
+    -> TL.Text -- ^ Textual representation of the 'Progress' in the given 'Style'.
+renderProgressBar style progress timing = TL.concat
+    [ styleEscapePrefix style progress
+    , prefixLabel
+    , prefixPad
+    , styleEscapeOpen style progress
+    , styleOpen style
+    , styleEscapeDone style progress
+    , TL.replicate completed $ TL.singleton $ styleDone style
+    , styleEscapeCurrent style progress
+    , if remaining /= 0 && completed /= 0
+      then TL.singleton $ styleCurrent style
+      else ""
+    , styleEscapeTodo style progress
+    , TL.replicate
+        (remaining - if completed /= 0 then 1 else 0)
+        (TL.singleton $ styleTodo style)
+    , styleEscapeClose style progress
+    , styleClose style
+    , styleEscapePostfix style progress
+    , postfixPad
+    , postfixLabel
+    ]
+  where
+    todo = fromIntegral $ progressTodo progress
+    done = fromIntegral $ progressDone progress
+    -- Amount of (visible) characters that should be used to display to progress bar.
+    width = fromIntegral $ getProgressBarWidth $ styleWidth style
+
+    -- Amount of work completed.
+    fraction :: Ratio Int64
+    fraction | todo /= 0 = done % todo
+             | otherwise = 0 % 1
+
+    -- Amount of characters available to visualize the progress.
+    effectiveWidth = max 0 $ width - usedSpace
+    -- Amount of printing characters needed to visualize everything except the bar .
+    usedSpace =   TL.length (styleOpen  style)
+                + TL.length (styleClose style)
+                + TL.length prefixLabel
+                + TL.length postfixLabel
+                + TL.length prefixPad
+                + TL.length postfixPad
+
+    -- Number of characters needed to represent the amount of work
+    -- that is completed. Note that this can not always be represented
+    -- by an integer.
+    numCompletedChars :: Ratio Int64
+    numCompletedChars = fraction * (effectiveWidth % 1)
+
+    completed, remaining :: Int64
+    completed = min effectiveWidth $ floor numCompletedChars
+    remaining = effectiveWidth - completed
+
+    prefixLabel, postfixLabel :: TL.Text
+    prefixLabel  = runLabel (stylePrefix  style) progress timing
+    postfixLabel = runLabel (stylePostfix style) progress timing
+
+    prefixPad, postfixPad :: TL.Text
+    prefixPad  = pad prefixLabel
+    postfixPad = pad postfixLabel
+
+pad :: TL.Text -> TL.Text
+pad s | TL.null s = TL.empty
+      | otherwise = TL.singleton ' '
+
+-- | Width of progress bar in characters.
+data ProgressBarWidth
+   = ConstantWidth !Int
+     -- ^ A constant width.
+   | TerminalWidth !Int
+     -- ^ Use the entire width of the terminal.
+     --
+     -- Identical to 'ConstantWidth' if the width of the terminal can
+     -- not be determined.
+     deriving (Generic)
+
+instance NFData ProgressBarWidth
+
+getProgressBarWidth :: ProgressBarWidth -> Int
+getProgressBarWidth (ConstantWidth n) = n
+getProgressBarWidth (TerminalWidth n) = n
+
+{- | Visual style of a progress bar.
+
+The style determines how a progress bar is rendered to text.
+
+The textual representation of a progress bar follows the following template:
+
+\<__prefix__>\<__open__>\<__done__>\<__current__>\<__todo__>\<__close__>\<__postfix__>
+
+Where \<__done__> and \<__todo__> are repeated as often as necessary.
+
+Consider the following progress bar
+
+> "Working [=======>.................]  30%"
+
+This bar can be specified using the following style:
+
+@
+'Style'
+{ 'styleOpen'    = \"["
+, 'styleClose'   = \"]"
+, 'styleDone'    = \'='
+, 'styleCurrent' = \'>'
+, 'styleTodo'    = \'.'
+, 'stylePrefix'  = 'msg' \"Working"
+, 'stylePostfix' = 'percentage'
+, 'styleWidth'   = 'ConstantWidth' 40
+, 'styleEscapeOpen'    = const 'TL.empty'
+, 'styleEscapeClose'   = const 'TL.empty'
+, 'styleEscapeDone'    = const 'TL.empty'
+, 'styleEscapeCurrent' = const 'TL.empty'
+, 'styleEscapeTodo'    = const 'TL.empty'
+, 'styleEscapePrefix'  = const 'TL.empty'
+, 'styleEscapePostfix' = const 'TL.empty'
+, 'styleOnComplete' = 'WriteNewline'
+}
+@
+-}
+data Style s
+   = Style
+     { styleOpen :: !TL.Text
+       -- ^ Bar opening symbol.
+     , styleClose :: !TL.Text
+       -- ^ Bar closing symbol
+     , styleDone :: !Char
+       -- ^ Completed work.
+     , styleCurrent :: !Char
+       -- ^ Symbol used to denote the current amount of work that has been done.
+     , styleTodo :: !Char
+       -- ^ Work not yet completed.
+     , stylePrefix :: Label s
+       -- ^ Prefixed label.
+     , stylePostfix :: Label s
+       -- ^ Postfixed label.
+     , styleWidth :: !ProgressBarWidth
+       -- ^ Total width of the progress bar.
+     , styleEscapeOpen :: EscapeCode s
+       -- ^ Escape code printed just before the 'styleOpen' symbol.
+     , styleEscapeClose :: EscapeCode s
+       -- ^ Escape code printed just before the 'styleClose' symbol.
+     , styleEscapeDone :: EscapeCode s
+       -- ^ Escape code printed just before the first 'styleDone' character.
+     , styleEscapeCurrent :: EscapeCode s
+       -- ^ Escape code printed just before the 'styleCurrent' character.
+     , styleEscapeTodo :: EscapeCode s
+       -- ^ Escape code printed just before the first 'styleTodo' character.
+     , styleEscapePrefix :: EscapeCode s
+       -- ^ Escape code printed just before the 'stylePrefix' label.
+     , styleEscapePostfix :: EscapeCode s
+       -- ^ Escape code printed just before the 'stylePostfix' label.
+     , styleOnComplete :: !OnComplete
+       -- ^ What happens when progress is finished.
+     } deriving (Generic)
+
+instance (NFData s) => NFData (Style s)
+
+-- | An escape code is a sequence of bytes which the terminal looks
+-- for and interprets as commands, not as character codes.
+--
+-- It is vital that the output of this function, when send to the
+-- terminal, does not result in characters being drawn.
+type EscapeCode s
+   = Progress s -- ^ Current progress bar state.
+  -> TL.Text -- ^ Resulting escape code. Must be non-printable.
+
+-- | What happens when a progress bar is finished.
+data OnComplete
+   = WriteNewline
+     -- ^ Write a new line when the progress bar is finished. The
+     -- completed progress bar will remain visible.
+   | Clear -- ^ Clear the progress bar once it is finished.
+     deriving (Generic)
+
+instance NFData OnComplete
+
+-- | The default style.
+--
+-- This style shows the progress as a percentage. It does not use any
+-- escape sequences.
+--
+-- Override some fields of the default instead of specifying all the
+-- fields of a 'Style' record.
+defStyle :: Style s
+defStyle =
+    Style
+    { styleOpen          = "["
+    , styleClose         = "]"
+    , styleDone          = '='
+    , styleCurrent       = '>'
+    , styleTodo          = '.'
+    , stylePrefix        = mempty
+    , stylePostfix       = percentage
+    , styleWidth         = TerminalWidth 50
+    , styleEscapeOpen    = const TL.empty
+    , styleEscapeClose   = const TL.empty
+    , styleEscapeDone    = const TL.empty
+    , styleEscapeCurrent = const TL.empty
+    , styleEscapeTodo    = const TL.empty
+    , styleEscapePrefix  = const TL.empty
+    , styleEscapePostfix = const TL.empty
+    , styleOnComplete    = WriteNewline
+    }
+
+-- | A label is a part of a progress bar that changes based on the progress.
+--
+-- Labels can be at the front (prefix) or at the back (postfix) of a progress bar.
+--
+-- Labels can use both the current amount of progress and the timing
+-- information to generate some text.
+newtype Label s = Label{ runLabel :: Progress s -> Timing -> TL.Text } deriving (NFData)
+
+-- | Combining labels combines their output.
+instance Semigroup (Label s) where
+    Label f <> Label g = Label $ \p t -> f p t <> g p t
+
+-- | The mempty label always outputs an empty text.
+instance Monoid (Label s) where
+    mempty = msg TL.empty
+    mappend = (<>)
+
+-- | Every string is a label which ignores its input and just outputs
+-- that string.
+instance IsString (Label s) where
+    fromString = msg . TL.pack
+
+-- | Timing information about a 'ProgressBar'.
+--
+-- This information is used by 'Label's to calculate elapsed time, remaining time, total time, etc.
+--
+-- See 'elapsedTime', 'remainingTime' and 'totalTime'.
+data Timing
+   = Timing
+     { timingStart :: !UTCTime
+       -- ^ Moment in time when a progress bar was created. See
+       -- 'newProgressBar'.
+     , timingLastUpdate :: !UTCTime
+       -- ^ Moment in time of the most recent progress update.
+     }
+
+-- | Static text.
+--
+-- The output does not depend on the input.
+--
+-- >>> msg "foo" st
+-- "foo"
+msg :: TL.Text -> Label s
+msg s = Label $ \_ _ -> s
+
+-- | Progress as a percentage.
+--
+-- >>> runLabel $ percentage (Progress 30 100 ()) someTiming
+-- " 30%"
+--
+-- __Note__: if no work is to be done (todo == 0) the percentage will
+-- be shown as 100%.
+percentage :: Label s
+percentage = Label render
+  where
+    render progress _timing
+      | todo == 0 = "100%"
+      | otherwise = TL.justifyRight 4 ' ' $ TLB.toLazyText $
+                      TLB.decimal (round (done % todo * 100) :: Int)
+                      <> TLB.singleton '%'
+      where
+        done = progressDone progress
+        todo = progressTodo progress
+
+-- | Progress as a fraction of the total amount of work.
+--
+-- >>> runLabel $ exact (Progress 30 100 ()) someTiming
+-- " 30/100"
+exact :: Label s
+exact = Label render
+  where
+    render progress _timing =
+        TL.justifyRight (TL.length todoStr) ' ' doneStr <> "/" <> todoStr
+      where
+        todoStr = TLB.toLazyText $ TLB.decimal todo
+        doneStr = TLB.toLazyText $ TLB.decimal done
+
+        done = progressDone progress
+        todo = progressTodo progress
+
+-- | Amount of time that has elapsed.
+--
+-- Time starts when a progress bar is created.
+--
+-- The user must supply a function which actually renders the amount
+-- of time that has elapsed. You can use 'renderDuration' or
+-- @formatTime@ from time >= 1.9.
+elapsedTime
+    :: (NominalDiffTime -> TL.Text)
+    -> Label s
+elapsedTime formatNDT = Label render
+  where
+    render _progress timing = formatNDT dt
+      where
+        dt :: NominalDiffTime
+        dt = diffUTCTime (timingLastUpdate timing) (timingStart timing)
+
+-- | Estimated remaining time.
+--
+-- Tells you how much longer some task is expected to take.
+--
+-- This label uses a simple estimation algorithm. It assumes progress
+-- is linear. To prevent nonsense results it won't estimate remaining
+-- time until at least 1 second of work has been done.
+--
+-- When it refuses to estimate the remaining time it will show an
+-- alternative message instead.
+--
+-- The user must supply a function which actually renders the amount
+-- of time that has elapsed. Use 'renderDuration' or @formatTime@ from
+-- the time >= 1.9 package.
+remainingTime
+    :: (NominalDiffTime -> TL.Text)
+    -> TL.Text
+       -- ^ Alternative message when remaining time can't be
+       -- calculated (yet).
+    -> Label s
+remainingTime formatNDT altMsg = Label render
+  where
+    render progress timing
+        | dt > 1 = formatNDT estimatedRemainingTime
+        | progressDone progress <= 0 = altMsg
+        | otherwise = altMsg
+      where
+        estimatedRemainingTime = estimatedTotalTime - dt
+        estimatedTotalTime = dt * recip progressFraction
+
+        progressFraction :: NominalDiffTime
+        progressFraction
+          | progressTodo progress <= 0 = 1
+          | otherwise = fromIntegral (progressDone progress)
+                      / fromIntegral (progressTodo progress)
+
+        dt :: NominalDiffTime
+        dt = diffUTCTime (timingLastUpdate timing) (timingStart timing)
+
+-- | Estimated total time.
+--
+-- This label uses a simple estimation algorithm. It assumes progress
+-- is linear. To prevent nonsense results it won't estimate the total
+-- time until at least 1 second of work has been done.
+--
+-- When it refuses to estimate the total time it will show an
+-- alternative message instead.
+--
+-- The user must supply a function which actually renders the total
+-- amount of time that a task will take. You can use 'renderDuration'
+-- or @formatTime@ from the time >= 1.9 package.
+totalTime
+    :: (NominalDiffTime -> TL.Text)
+    -> TL.Text
+       -- ^ Alternative message when total time can't be calculated
+       -- (yet).
+    -> Label s
+totalTime formatNDT altMsg = Label render
+  where
+    render progress timing
+        | dt > 1 = formatNDT estimatedTotalTime
+        | progressDone progress <= 0 = altMsg
+        | otherwise = altMsg
+      where
+        estimatedTotalTime = dt * recip progressFraction
+
+        progressFraction :: NominalDiffTime
+        progressFraction
+          | progressTodo progress <= 0 = 1
+          | otherwise = fromIntegral (progressDone progress)
+                      / fromIntegral (progressTodo progress)
+
+        dt :: NominalDiffTime
+        dt = diffUTCTime (timingLastUpdate timing) (timingStart timing)
+
+-- | Show amount of time.
+--
+-- > renderDuration (fromInteger 42)
+-- 42
+--
+-- > renderDuration (fromInteger $ 5 * 60 + 42)
+-- 05:42
+--
+-- > renderDuration (fromInteger $ 8 * 60 * 60 + 5 * 60 + 42)
+-- 08:05:42
+--
+-- Use the time >= 1.9 package to get a formatTime function which
+-- accepts 'NominalDiffTime'.
+renderDuration :: NominalDiffTime -> TL.Text
+renderDuration dt = hTxt <> mTxt <> sTxt
+  where
+    hTxt | h == 0 = mempty
+         | otherwise = renderDecimal h <> ":"
+    mTxt | m == 0 = mempty
+         | otherwise = renderDecimal m <> ":"
+    sTxt = renderDecimal s
+
+    (h, hRem) = ts   `quotRem` 3600
+    (m, s   ) = hRem `quotRem`   60
+
+    -- Total amount of seconds
+    ts :: Int
+    ts = round dt
+
+    renderDecimal n = TL.justifyRight 2 '0' $ TLB.toLazyText $ TLB.decimal n
+
+{- $start
+
+You want to perform some task which will take some time. You wish to
+show the progress of this task in the terminal.
+
+    1. Determine the total amount of work
+
+    2. Create a progress bar with 'newProgressBar'
+
+    3. For each unit of work:
+
+        3a. Perform the work
+
+        3b. Update the progress bar with 'incProgress'
+
+Explore the 'Style' and the 'Label' types to see various ways in which
+you can customize the progress bar.
+
+You do not have to close the progress bar, or even finish the task. It
+is perfectly fine to stop half way (maybe your task throws an
+exception).
+
+Just remember to avoid outputting text to the terminal while a
+progress bar is active. It will mess up the output a bit.
+-}
+
+{- $example
+
+Write a function which represents a unit of work. This could be a file
+copy operation, a network operation or some other expensive
+calculation. This example simply waits 1 second.
+
+@
+  work :: IO ()
+  work = threadDelay 1000000 -- 1 second
+@
+
+And you define some work to be done. This could be a list of files to
+process or some jobs that need to be processed.
+
+@
+  toBeDone :: [()]
+  toBeDone = replicate 20 ()
+@
+
+Now create the progress bar. Use the default style and choose a
+maximum refresh rate of 10 Hz. The initial progress is 0 work done out
+of 20.
+
+@
+  pb <- 'newProgressBar' 'defStyle' 10 ('Progress' 0 20 ())
+@
+
+Start performing the work while keeping the user informed of the progress:
+
+@
+  for_ toBeDone $ \() -> do
+    work             -- perform 1 unit of work
+    'incProgress' pb 1 -- increment progress by 1
+@
+
+That's it! You get a nice animated progress bar in your terminal. It
+will look like this:
+
+@
+[==========>................................]  25%
+@
+-}

pkg/hs/terminal-progress-bar/terminal-progress-bar.cabal

@@ -0,0 +1,72 @@
+name:          terminal-progress-bar
+version:       0.4.1
+cabal-version: >=1.10
+build-type:    Simple
+author:        Roel van Dijk <roel@lambdacube.nl>
+maintainer:    Roel van Dijk <roel@lambdacube.nl>
+copyright:     2012–2019 Roel van Dijk <roel@lambdacube.nl>
+license:       BSD3
+-- ense-file:  LICENSE
+category:      System, User Interfaces
+homepage:      https://github.com/roelvandijk/terminal-progress-bar
+bug-reports:   https://github.com/roelvandijk/terminal-progress-bar/issues
+synopsis:      A progress bar in the terminal
+description:
+  A progress bar conveys the progress of a task. This package
+  implements a progress bar that is displayed in a terminal.
+  .
+  See the module 'System.ProgressBar' to get started or look at the
+  terminal-progress-bar-example package.
+  .
+  The animated progress bar depends entirely on the interpretation of
+  the carriage return character (\'\\r\'). If your terminal interprets
+  it as something else than \"move cursor to beginning of line\", the
+  animation won't work.
+
+-- ra-source-files: LICENSE, README.markdown, changelog.md
+
+source-repository head
+  type:     git
+  location: git://github.com/roelvandijk/terminal-progress-bar.git
+
+library
+    hs-source-dirs: src
+    build-depends:
+        base          >= 4.5 && < 5
+      , deepseq       >= 1.4.3
+      , terminal-size >= 0.3.2
+      , text          >= 1.2
+      , time          >= 1.8
+      , rio
+      , classy-prelude
+    exposed-modules: System.ProgressBar
+    ghc-options: -Wall
+    default-language: Haskell2010
+
+test-suite test-terminal-progress-bar
+    type: exitcode-stdio-1.0
+    main-is: test.hs
+    hs-source-dirs: test
+    ghc-options: -Wall
+    build-depends:
+        base                 >= 4.5 && < 5
+      , HUnit                >= 1.2.4.2
+      , terminal-progress-bar
+      , test-framework       >= 0.3.3
+      , test-framework-hunit >= 0.2.6
+      , text                 >= 1.2
+      , time                 >= 1.8
+    default-language: Haskell2010
+
+benchmark bench-terminal-progress-bar
+    type: exitcode-stdio-1.0
+    main-is: bench.hs
+    hs-source-dirs: bench
+
+    build-depends:
+        base      >= 4.5 && < 5
+      , criterion >= 1.1.4
+      , terminal-progress-bar
+      , time      >= 1.8
+    ghc-options: -Wall -O2
+    default-language: Haskell2010

pkg/hs/terminal-progress-bar/test/test.hs

@@ -0,0 +1,102 @@
+{-# language OverloadedStrings #-}
+{-# language PackageImports #-}
+
+module Main where
+
+--------------------------------------------------------------------------------
+-- Imports
+--------------------------------------------------------------------------------
+
+import "base" System.Environment ( getArgs )
+import "base" Data.Semigroup ( (<>) )
+import "HUnit" Test.HUnit.Base ( assertEqual )
+import "test-framework" Test.Framework
+    ( defaultMainWithOpts, interpretArgsOrExit, Test, testGroup )
+import "test-framework-hunit" Test.Framework.Providers.HUnit ( testCase )
+import "terminal-progress-bar" System.ProgressBar
+import qualified "text" Data.Text.Lazy as TL
+import "time" Data.Time.Clock ( UTCTime(..), NominalDiffTime )
+
+--------------------------------------------------------------------------------
+-- Test suite
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do opts <- interpretArgsOrExit =<< getArgs
+          defaultMainWithOpts tests opts
+
+tests :: [Test]
+tests =
+  [ testGroup "Label padding"
+    [ eqTest "no labels"  "[]"          mempty      mempty       0 $ Progress 0 0 ()
+    , eqTest "pre"        "pre []"      (msg "pre") mempty       0 $ Progress 0 0 ()
+    , eqTest "post"       "[] post"     mempty      (msg "post") 0 $ Progress 0 0 ()
+    , eqTest "pre & post" "pre [] post" (msg "pre") (msg "post") 0 $ Progress 0 0 ()
+    ]
+  , testGroup "Bar fill"
+    [ eqTest "empty"       "[....]" mempty mempty 6 $ Progress  0   1 ()
+    , eqTest "almost half" "[=>..]" mempty mempty 6 $ Progress 49 100 ()
+    , eqTest "half"        "[==>.]" mempty mempty 6 $ Progress  1   2 ()
+    , eqTest "almost full" "[===>]" mempty mempty 6 $ Progress 99 100 ()
+    , eqTest "full"        "[====]" mempty mempty 6 $ Progress  1   1 ()
+    , eqTest "overfull"    "[====]" mempty mempty 6 $ Progress  2   1 ()
+    ]
+  , testGroup "Labels"
+    [ testGroup "Percentage"
+      [ eqTest "  0%" "  0% [....]" percentage mempty 11 $ Progress 0 1 ()
+      , eqTest "100%" "100% [====]" percentage mempty 11 $ Progress 1 1 ()
+      , eqTest " 50%" " 50% [==>.]" percentage mempty 11 $ Progress 1 2 ()
+      , eqTest "200%" "200% [====]" percentage mempty 11 $ Progress 2 1 ()
+      , labelTest "0 work todo" percentage (Progress 10 0 ()) "100%"
+      ]
+    , testGroup "Exact"
+      [ eqTest "0/0" "0/0 [....]" exact mempty 10 $ Progress 0 0 ()
+      , eqTest "1/1" "1/1 [====]" exact mempty 10 $ Progress 1 1 ()
+      , eqTest "1/2" "1/2 [==>.]" exact mempty 10 $ Progress 1 2 ()
+      , eqTest "2/1" "2/1 [====]" exact mempty 10 $ Progress 2 1 ()
+      , labelTest "0 work todo" exact (Progress 10 0 ()) "10/0"
+      ]
+    , testGroup "Label Semigroup"
+      [ eqTest "exact <> msg <> percentage"
+               "1/2 -  50% [===>...]"
+               (exact <> msg " - " <> percentage)
+               mempty 20 $ Progress 1 2 ()
+      ]
+    , testGroup "rendeRuration"
+      [ renderDurationTest 42 "42"
+      , renderDurationTest (5 * 60 + 42) "05:42"
+      , renderDurationTest (8 * 60 * 60 + 5 * 60 + 42) "08:05:42"
+      , renderDurationTest (123 * 60 * 60 + 59 * 60 + 59) "123:59:59"
+      ]
+    ]
+  ]
+
+labelTest :: String -> Label () -> Progress () -> TL.Text -> Test
+labelTest testName label progress expected =
+    testCase testName $ assertEqual expectationError expected $ runLabel label progress someTiming
+
+renderDurationTest :: NominalDiffTime -> TL.Text -> Test
+renderDurationTest dt expected =
+    testCase ("renderDuration " <> show dt) $ assertEqual expectationError expected $ renderDuration dt
+
+eqTest :: String -> TL.Text -> Label () -> Label () -> Int -> Progress () -> Test
+eqTest name expected mkPreLabel mkPostLabel width progress =
+    testCase name $ assertEqual expectationError expected actual
+  where
+    actual = renderProgressBar style progress someTiming
+
+    style :: Style ()
+    style = defStyle
+            { stylePrefix = mkPreLabel
+            , stylePostfix = mkPostLabel
+            , styleWidth = ConstantWidth width
+            }
+
+someTime :: UTCTime
+someTime = UTCTime (toEnum 0) 0
+
+someTiming :: Timing
+someTiming = Timing someTime someTime
+
+expectationError :: String
+expectationError = "Expected result doesn't match actual result"

pkg/hs/urbit-atom/.gitignore

@@ -0,0 +1 @@
+urbit-atom.cabal

pkg/hs/urbit-atom/LICENSE

@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2016 urbit
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

pkg/hs/urbit-atom/lib/Urbit/Atom.hs

@@ -0,0 +1,61 @@
+{-|
+    Atom implementation with fast conversions between bytestrings
+    and atoms.
+-}
+
+module Urbit.Atom
+    ( Atom
+    , atomBytes, bytesAtom
+    , atomWords, wordsAtom
+    , utf8Atom, atomUtf8, atomUtf8Exn, atomUtf8Lenient
+    ) where
+
+import Prelude
+
+import Data.ByteString       (ByteString)
+import Data.Vector.Primitive (Vector)
+import GHC.Natural           (Natural)
+
+import qualified Data.Text                as T
+import qualified Data.Text.Encoding       as T
+import qualified Data.Text.Encoding.Error as T
+import qualified Urbit.Atom.Internal      as I
+
+
+--------------------------------------------------------------------------------
+
+type Atom = Natural
+
+--------------------------------------------------------------------------------
+
+-- | Cast an atom to a vector. Does not copy.
+atomWords :: Atom → Vector Word
+atomWords = I.natWords
+
+-- | Cast a vector to an atom. Does not copy unless given a slice.
+wordsAtom :: Vector Word → Atom
+wordsAtom = I.wordsNat
+
+-- | Dump an atom to a bytestring.
+atomBytes ∷ Atom → ByteString
+atomBytes = I.pillBytes . I.natPill
+
+-- | Load a bytestring into an atom.
+bytesAtom ∷ ByteString → Atom
+bytesAtom = I.pillNat . I.bytesPill
+
+-- | Encode a utf8-encoded atom from text.
+utf8Atom ∷ T.Text → Atom
+utf8Atom = bytesAtom . T.encodeUtf8
+
+-- | Interpret an atom as utf8 text.
+atomUtf8 ∷ Atom → Either T.UnicodeException T.Text
+atomUtf8 = T.decodeUtf8' . atomBytes
+
+-- | Interpret an atom as utf8 text, throwing an exception on bad unicode.
+atomUtf8Exn ∷ Atom → T.Text
+atomUtf8Exn = T.decodeUtf8 . atomBytes
+
+-- | Interpret an atom as utf8 text, replacing bad unicode characters.
+atomUtf8Lenient ∷ Atom → T.Text
+atomUtf8Lenient = T.decodeUtf8With T.lenientDecode . atomBytes

pkg/hs/urbit-atom/lib/Urbit/Atom/Internal.hs

@@ -0,0 +1,223 @@
+{-|
+    Atom implementation with fast conversions between bytestrings
+    and atoms.
+
+    TODO Support 32-bit archetectures.
+    TODO Support Big Endian.
+-}
+
+module Urbit.Atom.Internal where
+
+import Prelude
+
+import Data.Bits                 (shiftL, shiftR, (.&.), (.|.))
+import Data.ByteString           (ByteString)
+import Data.Vector.Primitive     (Vector(..))
+import Data.Word                 (Word8)
+import GHC.Exts                  (Ptr(Ptr), sizeofByteArray#)
+import GHC.Int                   (Int(..))
+import GHC.Integer.GMP.Internals (BigNat(..), bigNatToWord, sizeofBigNat#)
+import GHC.Integer.GMP.Internals (indexBigNat#)
+import GHC.Integer.GMP.Internals (byteArrayToBigNat#, wordToBigNat, zeroBigNat)
+import GHC.Natural               (Natural(..))
+import GHC.Prim                  (clz#, minusWord#, plusWord#)
+import GHC.Prim                  (Word#, int2Word#, subIntC#, timesWord#)
+import GHC.Word                  (Word(..))
+import System.IO.Unsafe          (unsafePerformIO)
+
+import qualified Data.ByteString           as BS
+import qualified Data.ByteString.Unsafe    as BS
+import qualified Data.ByteString.Internal  as BS
+import qualified Data.Primitive.ByteArray  as Prim
+import qualified Data.Primitive.Types      as Prim
+import qualified Data.Vector.Primitive     as VP
+import qualified Foreign.ForeignPtr.Unsafe as Ptr
+
+
+--------------------------------------------------------------------------------
+
+wordBitWidth# :: Word# -> Word#
+wordBitWidth# w = minusWord# 64## (clz# w)
+
+wordBitWidth :: Word -> Word
+wordBitWidth (W# w) = W# (wordBitWidth# w)
+
+bigNatBitWidth# :: BigNat -> Word#
+bigNatBitWidth# nat =
+    lswBits `plusWord#` ((int2Word# lastIdx) `timesWord#` 64##)
+  where
+    (# lastIdx, _ #) = subIntC# (sizeofBigNat# nat) 1#
+    lswBits          = wordBitWidth# (indexBigNat# nat lastIdx)
+
+atomBitWidth# :: Natural -> Word#
+atomBitWidth# (NatS# gl) = wordBitWidth# gl
+atomBitWidth# (NatJ# bn) = bigNatBitWidth# bn
+
+bitWidth :: Num a => Natural -> a
+bitWidth a = fromIntegral (W# (atomBitWidth# a))
+
+--------------------------------------------------------------------------------
+
+{-# INLINE takeBitsWord #-}
+takeBitsWord :: Int -> Word -> Word
+takeBitsWord wid wor = wor .&. (shiftL 1 wid - 1)
+
+
+--------------------------------------------------------------------------------
+
+{-
+    A `Pill` is a bytestring without trailing zeros.
+-}
+newtype Pill = Pill { unPill :: ByteString }
+
+instance Eq Pill where
+  (==) x y = pillBytes x == pillBytes y
+
+instance Show Pill where
+  show = show . pillBytes
+
+--------------------------------------------------------------------------------
+
+strip :: ByteString → ByteString
+strip buf = BS.take (len - go 0 (len - 1)) buf
+  where
+    len = BS.length buf
+    go n i | i < 0                  = n
+           | 0 == BS.unsafeIndex buf i = go (n+1) (i-1)
+           | otherwise              = n
+
+pillBytes :: Pill -> ByteString
+pillBytes = strip . unPill
+
+bytesPill :: ByteString -> Pill
+bytesPill = Pill . strip
+
+
+--------------------------------------------------------------------------------
+
+{-
+    Cast a BigNat to a vector without a copy.
+-}
+bigNatWords ∷ BigNat → Vector Word
+bigNatWords (BN# bArr) =
+    Vector 0 (I# (sizeofByteArray# bArr) `div` 8)
+             (Prim.ByteArray bArr)
+
+{-|
+    Cast a vector to a BigNat. This will not copy.
+
+    TODO Don't crash if given a slice.
+-}
+wordsBigNat ∷ Vector Word → BigNat
+wordsBigNat v@(Vector off (I# len) (Prim.ByteArray buf)) =
+    case VP.length v of
+        0 -> zeroBigNat
+        1 -> case VP.unsafeIndex v 0 of W# w -> wordToBigNat w
+        n -> if off /= 0 then error "words2Nat: bad-vec" else
+             byteArrayToBigNat# buf len
+
+{-|
+    More careful version of `wordsBigNat`, but not yet tested.
+
+    Cast a vector to a BigNat. This will not copy unless input is a slice.
+
+    Note that the length of the vector is in words, and the length passed
+    to `byteArrayToBigNat#` is also in words.
+-}
+wordsBigNat' ∷ Vector Word → BigNat
+wordsBigNat' v =
+    case VP.length v of
+        0 -> zeroBigNat
+        1 -> wordToBigNat w where W# w = VP.unsafeIndex v 0
+        n -> if offset v == 0 then extract v else extract (VP.force v)
+  where
+    offset (Vector off _ _) = off
+
+    extract (Vector _ (I# len) (Prim.ByteArray buf)) =
+        byteArrayToBigNat# buf len
+
+
+--------------------------------------------------------------------------------
+
+-- | Cast a nat to a vector (no copy)
+natWords :: Natural → Vector Word
+natWords = bigNatWords . natBigNat
+
+-- | Cast a vector to a nat (no copy)
+wordsNat ∷ Vector Word → Natural
+wordsNat = bigNatNat . wordsBigNat
+
+-- | Cast a Nat to a BigNat (no copy).
+natBigNat ∷ Natural → BigNat
+natBigNat (NatS# w)  = wordToBigNat w
+natBigNat (NatJ# bn) = bn
+
+-- | Cast a BigNat to a Nat (no copy).
+bigNatNat ∷ BigNat → Natural
+bigNatNat bn =
+    case sizeofBigNat# bn of
+        0# -> 0
+        1# -> NatS# (bigNatToWord bn)
+        _  -> NatJ# bn
+
+--------------------------------------------------------------------------------
+
+-- | TODO This assumes 64-bit words
+wordBytes ∷ Word → ByteString
+wordBytes wor =
+    BS.reverse $ BS.pack $ go 0 []
+  where
+    go i acc | i >= 8    = acc
+    go i acc | otherwise = go (i+1) (fromIntegral (shiftR wor (i*8)) : acc)
+
+-- | TODO This assumes 64-bit words
+bytesFirstWord ∷ ByteString → Word
+bytesFirstWord buf = go 0 0
+  where
+    top        = min 8 (BS.length buf)
+    i idx off  = shiftL (fromIntegral $ BS.index buf idx) off
+    go acc idx = if idx >= top then acc else
+                 go (acc .|. i idx (8*idx)) (idx+1)
+
+--------------------------------------------------------------------------------
+
+pillWords ∷ Pill → Vector Word
+pillWords = bsToWords . pillBytes
+
+wordsPill ∷ Vector Word → Pill
+wordsPill = bytesPill . vecBytes . wordsToBytes
+
+--------------------------------------------------------------------------------
+
+wordsToBytes :: Vector Word -> Vector Word8
+wordsToBytes (Vector off sz buf) =
+    Vector (off*8) (sz*8) buf
+
+bsToWords :: ByteString -> Vector Word
+bsToWords bs =
+    VP.generate (1 + BS.length bs `div` 8) $ \i ->
+        bytesFirstWord (BS.drop (i*8) bs)
+
+--------------------------------------------------------------------------------
+
+vecBytes :: Vector Word8 -> ByteString
+vecBytes (Vector off sz buf) =
+    unsafePerformIO $ do
+        fp <- BS.mallocByteString sz
+        let Ptr a = Ptr.unsafeForeignPtrToPtr fp -- Safe b/c returning fp
+        Prim.copyByteArrayToAddr (Prim.Addr a) buf 0 sz
+        pure (BS.PS fp off sz)
+
+bytesVec ∷ ByteString → Vector Word8
+bytesVec bs = VP.generate (BS.length bs) (BS.index bs)
+
+--------------------------------------------------------------------------------
+
+natPill ∷ Natural → Pill
+natPill = wordsPill . natWords
+
+pillNat ∷ Pill → Natural
+pillNat = wordsNat . bsToWords . pillBytes
+
+--------------------------------------------------------------------------------
+

pkg/hs/urbit-atom/package.yaml

@@ -0,0 +1,66 @@
+name: urbit-atom
+version: 0.10.1
+license: MIT
+license-file: LICENSE
+
+library:
+  source-dirs: lib
+  ghc-options:
+    - -fwarn-incomplete-patterns
+    - -fwarn-unused-binds
+    - -fwarn-unused-imports
+    - -Werror
+    - -O2
+
+dependencies:
+  - base
+  - bytestring
+  - ghc-prim
+  - integer-gmp
+  - primitive
+  - text
+  - vector
+
+default-extensions:
+  - ApplicativeDo
+  - BangPatterns
+  - BlockArguments
+  - DataKinds
+  - DefaultSignatures
+  - DeriveAnyClass
+  - DeriveDataTypeable
+  - DeriveFoldable
+  - DeriveGeneric
+  - DeriveTraversable
+  - DerivingStrategies
+  - EmptyCase
+  - EmptyDataDecls
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - GADTs
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - MagicHash
+  - MultiParamTypeClasses
+  - NamedFieldPuns
+  - NoImplicitPrelude
+  - NumericUnderscores
+  - OverloadedStrings
+  - PackageImports
+  - PartialTypeSignatures
+  - PatternSynonyms
+  - QuasiQuotes
+  - Rank2Types
+  - RankNTypes
+  - RecordWildCards
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TemplateHaskell
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - TypeOperators
+  - UnboxedTuples
+  - UnicodeSyntax
+  - ViewPatterns

pkg/hs/urbit-azimuth/.gitignore

@@ -0,0 +1 @@
+urbit-azimuth.cabal

pkg/hs/urbit-azimuth/LICENSE

@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2016 urbit
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

pkg/hs/urbit-azimuth/Urbit/Azimuth.hs

@@ -0,0 +1,5 @@
+module Urbit.Azimuth where
+
+import Network.Ethereum.Contract.TH
+
+[abiFrom|azimuth.json|]

pkg/hs/urbit-azimuth/package.yaml

@@ -0,0 +1,55 @@
+name: urbit-azimuth
+version: 0.10.1
+license: MIT
+license-file: LICENSE
+
+library:
+  source-dirs: .
+
+dependencies:
+  - base
+  - web3
+
+default-extensions:
+  - ApplicativeDo
+  - BangPatterns
+  - BlockArguments
+  - DataKinds
+  - DefaultSignatures
+  - DeriveAnyClass
+  - DeriveDataTypeable
+  - DeriveFoldable
+  - DeriveGeneric
+  - DeriveTraversable
+  - DerivingStrategies
+  - EmptyCase
+  - EmptyDataDecls
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - GADTs
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - MagicHash
+  - MultiParamTypeClasses
+  - NamedFieldPuns
+  - NoImplicitPrelude
+  - NumericUnderscores
+  - OverloadedStrings
+  - PackageImports
+  - PartialTypeSignatures
+  - PatternSynonyms
+  - QuasiQuotes
+  - Rank2Types
+  - RankNTypes
+  - RecordWildCards
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TemplateHaskell
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - TypeOperators
+  - UnboxedTuples
+  - UnicodeSyntax
+  - ViewPatterns

pkg/hs/urbit-king/.gitignore

@@ -0,0 +1,3 @@
+.stack-work
+*.cabal
+test/gold/*.writ

pkg/hs/urbit-king/LICENSE

@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2016 urbit
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

pkg/hs/urbit-king/app/Main.hs

@@ -0,0 +1,2 @@
+module Main (module Urbit.King.Main) where
+import Urbit.King.Main

pkg/hs/urbit-king/lib/Data/RAcquire.hs

@@ -0,0 +1,139 @@
+{-|
+    RAcquire = ReaderT e Acquire a
+-}
+module Data.RAcquire where
+{-
+    ( RAcquire (..)
+    , Allocated (..)
+    , with
+    , mkRAcquire
+    , ReleaseType (..)
+    , mkRAcquireType
+    ) where
+-}
+
+import Prelude
+
+import qualified Control.Exception     as E
+import qualified Control.Monad.Catch   as C ()
+import qualified Data.Acquire.Internal as Act
+
+import Control.Applicative     (Applicative(..))
+import Control.Monad           (ap, liftM)
+import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO, withRunInIO)
+import Control.Monad.Reader
+import Data.Typeable           (Typeable)
+
+import RIO (RIO, runRIO)
+
+--------------------------------------------------------------------------------
+
+data ReleaseType
+    = ReleaseEarly
+    | ReleaseNormal
+    | ReleaseException
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)
+
+data Allocated e a
+    = Allocated !a !(ReleaseType -> RIO e ())
+
+newtype RAcquire e a
+    = RAcquire ((forall b. RIO e b -> RIO e b) -> RIO e (Allocated e a))
+  deriving Typeable
+
+--------------------------------------------------------------------------------
+
+class MonadRIO m where
+    liftRIO :: RIO e a -> m e a
+
+instance MonadRIO RIO where
+    liftRIO = id
+
+class MonadAcquire m where
+    liftAcquire :: Act.Acquire a -> m a
+
+--------------------------------------------------------------------------------
+
+instance Functor (RAcquire e) where
+    fmap = liftM
+
+instance Applicative (RAcquire e) where
+    pure a = RAcquire (\_ -> return (Allocated a (const $ return ())))
+    (<*>) = ap
+
+instance Monad (RAcquire e) where
+    return = pure
+    RAcquire f >>= g' = RAcquire $ \restore -> do
+        env <- ask
+        Allocated x free1 <- f restore
+        let RAcquire g = g' x
+        Allocated y free2 <- liftIO $ E.onException
+                                        (runRIO env $ g restore)
+                                        (runRIO env $ free1 ReleaseException)
+
+        return $! Allocated y $ \rt ->
+            liftIO $ E.finally (runRIO env $ free2 rt)
+                               (runRIO env $ free1 rt)
+
+instance MonadReader e (RAcquire e) where
+    ask                    = liftRIO ask
+    local mod (RAcquire f) = RAcquire $ \restore -> local mod (f restore)
+
+--------------------------------------------------------------------------------
+
+instance MonadRIO RAcquire where
+    liftRIO f = RAcquire $ \restore -> do
+        x <- restore f
+        return $! Allocated x (const $ return ())
+
+instance MonadIO (RAcquire e) where
+    liftIO = liftRIO . liftIO
+
+unTransRIO :: e -> (RIO e a -> RIO e a) -> IO a -> IO a
+unTransRIO env trans act = runRIO env $ trans $ liftIO act
+
+instance MonadAcquire (RAcquire e) where
+    liftAcquire (Act.Acquire f) = do
+        env <- liftRIO ask
+        RAcquire $ \restore -> do
+            fmap fixAllo $ liftIO $ f $ unTransRIO env restore
+      where
+        fixAllo (Act.Allocated x y) = Allocated x $ fmap liftIO (y . fixTy)
+
+        fixTy = \case
+          ReleaseEarly     -> Act.ReleaseEarly
+          ReleaseNormal    -> Act.ReleaseNormal
+          ReleaseException -> Act.ReleaseException
+
+--------------------------------------------------------------------------------
+
+mkRAcquire :: RIO e a
+          -> (a -> RIO e ())
+          -> RAcquire e a
+mkRAcquire create free = RAcquire $ \restore -> do
+    x <- restore create
+    return $! Allocated x (const $ free x)
+
+mkRAcquireType
+    :: RIO e a -- ^ acquire the resource
+    -> (a -> ReleaseType -> RIO e ()) -- ^ free the resource
+    -> RAcquire e a
+mkRAcquireType create free = RAcquire $ \restore -> do
+    x <- restore create
+    return $! Allocated x (free x)
+
+transRIO :: e -> (IO a -> IO a) -> RIO e a -> RIO e a
+transRIO env trans act = liftIO $ trans $ runRIO env act
+
+rwith :: (MonadUnliftIO (m e), MonadReader e (m e))
+      => RAcquire e a
+      -> (a -> m e b)
+      -> m e b
+rwith (RAcquire f) g = do
+    env <- ask
+    withRunInIO $ \run -> E.mask $ \restore -> do
+        Allocated x free <- runRIO env $ f $ transRIO env restore
+        res <- E.onException (restore $ run $ g x)
+                             (runRIO env $ free ReleaseException)
+        runRIO env $ free ReleaseNormal
+        return res

pkg/hs/urbit-king/lib/Urbit/Arvo.hs

@@ -0,0 +1,13 @@
+module Urbit.Arvo
+  ( module Urbit.Arvo.Common
+  , module Urbit.Arvo.Effect
+  , module Urbit.Arvo.Event
+  , FX
+  ) where
+
+import Urbit.Arvo.Common
+import Urbit.Arvo.Effect
+import Urbit.Arvo.Event
+import Urbit.Noun.Conversions (Lenient)
+
+type FX = [Lenient Ef]

pkg/hs/urbit-king/lib/Urbit/Arvo/Common.hs

@@ -0,0 +1,236 @@
+{-|
+    Types used in both Events and Effects.
+-}
+module Urbit.Arvo.Common
+  ( KingId(..), ServId(..)
+  , Json, JsonNode(..)
+  , Desk(..), Mime(..)
+  , Port(..), Turf(..)
+  , HttpServerConf(..), PEM(..), Key, Cert
+  , HttpEvent(..), Method, Header(..), ResponseHeader(..)
+  , ReOrg(..), reorgThroughNoun
+  , AmesDest(..), Ipv4(..), Ipv6(..), Patp(..), Galaxy, AmesAddress(..)
+  ) where
+
+import Urbit.Prelude hiding (Term)
+
+import qualified Network.HTTP.Types.Method as H
+import qualified Urbit.Ob                  as Ob
+
+
+-- Misc Types ------------------------------------------------------------------
+
+{-|
+    Domain Name in TLD order:
+
+        ["org", "urbit", "dns"] -> dns.urbit.org
+-}
+newtype Turf = Turf { unTurf :: [Cord] }
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
+
+newtype KingId = KingId { unKingId :: UV }
+  deriving newtype (Eq, Ord, Show, Num, Real, Enum, Integral, FromNoun, ToNoun)
+
+newtype ServId = ServId { unServId :: UV }
+  deriving newtype (Eq, Ord, Show, Num, Enum, Integral, Real, FromNoun, ToNoun)
+
+
+-- Http Common -----------------------------------------------------------------
+
+data Header = Header Cord Bytes
+  deriving (Eq, Ord, Show)
+
+data ResponseHeader = ResponseHeader
+     { statusCode :: Word
+     , headers    :: [Header]
+     }
+  deriving (Eq, Ord, Show)
+
+data HttpEvent
+    = Start ResponseHeader (Maybe File) Bool
+    | Continue (Maybe File) Bool
+    | Cancel ()
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''ResponseHeader
+deriveNoun ''Header
+deriveNoun ''HttpEvent
+
+
+-- Http Requests ---------------------------------------------------------------
+
+type Method = H.StdMethod
+
+-- TODO Hack! Don't write instances for library types. Write them for
+-- our types instead.
+
+instance ToNoun H.StdMethod where
+  toNoun = toNoun . MkBytes . H.renderStdMethod
+
+instance FromNoun H.StdMethod where
+  parseNoun n = named "StdMethod" $ do
+    MkBytes bs <- parseNoun n
+    case H.parseMethod bs of
+      Left md -> fail ("Unexpected method: " <> unpack (decodeUtf8 md))
+      Right m -> pure m
+
+
+
+-- Http Server Configuration ---------------------------------------------------
+
+newtype PEM = PEM { unPEM :: Cord }
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
+
+type Key  = PEM
+type Cert = PEM
+
+data HttpServerConf = HttpServerConf
+    { hscSecure   :: Maybe (Key, Cert)
+    , hscProxy    :: Bool
+    , hscLog      :: Bool
+    , hscRedirect :: Bool
+    }
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''HttpServerConf
+
+
+-- Desk and Mime ---------------------------------------------------------------
+
+newtype Desk = Desk { unDesk :: Cord }
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
+
+data Mime = Mime Path File
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''Mime
+
+
+-- Json ------------------------------------------------------------------------
+
+type Json = Nullable JsonNode
+
+data JsonNode
+    = JNA [Json]
+    | JNB Bool
+    | JNO (HoonMap Cord Json)
+    | JNN Knot
+    | JNS Cord
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''JsonNode
+
+
+-- Ames Destinations -------------------------------------------------
+
+newtype Patp a = Patp { unPatp :: a }
+  deriving newtype (Eq, Ord, Enum, Real, Integral, Num, ToNoun, FromNoun)
+
+-- Network Port
+newtype Port = Port { unPort :: Word16 }
+  deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
+
+-- @if
+newtype Ipv4 = Ipv4 { unIpv4 :: Word32 }
+  deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
+
+-- @is
+newtype Ipv6 = Ipv6 { unIpv6 :: Word128 }
+  deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
+
+type Galaxy = Patp Word8
+
+instance Integral a => Show (Patp a) where
+  show = show . Ob.renderPatp . Ob.patp . fromIntegral . unPatp
+
+data AmesAddress
+    = AAIpv4 Ipv4 Port
+    | AAVoid Void
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''AmesAddress
+
+type AmesDest = Each Galaxy (Jammed AmesAddress)
+
+
+-- Path+Tagged Restructuring ---------------------------------------------------
+
+{-|
+    This reorganized events and effects to be easier to parse. This is
+    complicated and gross, and a better way should be found!
+
+    ReOrg takes in nouns with the following shape:
+
+        [[fst snd rest] [tag val]]
+
+    And turns that into:
+
+        ReOrg fst snd tag rest val
+
+    For example,
+
+        [//behn/5 %doze ~ 9999]
+
+    Becomes:
+
+        Reorg "" "behn" "doze" ["5"] 9999
+
+    This is convenient, since we can then use our head-tag based FromNoun
+    and ToNoun instances.
+
+    NOTE:
+
+        Also, in the wild, I ran into this event:
+
+            [//term/1 %init]
+
+        So, I rewrite atom-events as follows:
+
+            [x y=@] -> [x [y ~]]
+
+        Which rewrites the %init example to:
+
+            [//term/1 [%init ~]]
+
+        TODO The reverse translation is not done yet.
+
+-}
+data ReOrg = ReOrg Cord Cord Cord EvilPath Noun
+
+instance FromNoun ReOrg where
+  parseNoun = named "ReOrg" . \case
+      A _                     -> expected "got atom"
+      C (A _)         _       -> expected "empty route"
+      C h             (A a)   -> parseNoun (C h (C (A a) (A 0)))
+      C (C _ (A _))   (C _ _) -> expected "route is too short"
+      C (C f (C s p)) (C t v) -> do
+        fst :: Cord     <- named "first-route"   $ parseNoun f
+        snd :: Cord     <- named "second-route"  $ parseNoun s
+        pax :: EvilPath <- named "rest-of-route" $ parseNoun p
+        tag :: Cord     <- named "tag"           $ parseNoun t
+        val :: Noun     <- pure v
+        pure (ReOrg fst snd tag pax val)
+    where
+      expected got = fail ("expected route+tagged; " <> got)
+
+instance ToNoun ReOrg where
+  toNoun (ReOrg fst snd tag pax val) =
+    toNoun ((fst, snd, pax), (tag, val))
+
+{-|
+    Given something parsed from a ReOrg Noun, convert that back to
+    a ReOrg.
+
+    This code may crash, but only if the FromNoun/ToNoun instances for
+    the effects are incorrect.
+-}
+reorgThroughNoun :: ToNoun x => (Cord, x) -> ReOrg
+reorgThroughNoun =
+    fromNounCrash . toNoun >>> \case
+        (f, s, t, p, v) -> ReOrg f s t p v
+  where
+    fromNounCrash :: FromNoun a => Noun -> a
+    fromNounCrash =
+      fromNounErr >>> \case
+        Left err -> error (show err)
+        Right vl -> vl

pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs

@@ -0,0 +1,205 @@
+{-|
+    Effect Types and Their Noun Conversions
+-}
+module Urbit.Arvo.Effect where
+
+import Urbit.Prelude
+import Urbit.Time
+
+import Urbit.Arvo.Common (KingId(..), ServId(..))
+import Urbit.Arvo.Common (Header, HttpEvent, HttpServerConf, Method, Mime)
+import Urbit.Arvo.Common (AmesDest, Turf)
+import Urbit.Arvo.Common (ReOrg(..), reorgThroughNoun)
+import Urbit.Arvo.Common (Desk)
+
+
+-- Newt Effects ----------------------------------------------------------------
+
+{-|
+    %turf -- Set which domain names we've bound.
+    %send -- Send a UDP packet.
+-}
+data NewtEf
+    = NewtEfTurf (Atom, ()) [Turf]
+    | NewtEfSend (Atom, ()) AmesDest Bytes
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''NewtEf
+
+
+-- HTTP Client Effects ---------------------------------------------------------
+
+data HttpClientReq = HttpClientReq
+    { method     :: Method
+    , url        :: Cord
+    , headerList :: [Header]
+    , body       :: Maybe Octs
+    }
+  deriving (Eq, Ord, Show)
+
+{-|
+    %request        -- TODO
+    %cancel-request -- TODO
+-}
+data HttpClientEf
+    = HCERequest       (Atom, ()) Word HttpClientReq
+    | HCECancelRequest Path       Word
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''HttpClientReq
+deriveNoun ''HttpClientEf
+
+
+-- HTTP Server Effects ---------------------------------------------------------
+
+{-|
+    %set-config -- Update HTTP server configuration.
+    %response   -- Respond to an active HTTP request.
+-}
+data HttpServerEf
+    = HSESetConfig (ServId, ())         HttpServerConf
+    | HSEResponse  (ServId, UD, UD, ()) HttpEvent
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''HttpServerEf
+
+
+-- File System Effects ---------------------------------------------------------
+
+{-|
+    %hill -- TODO
+    %dirk -- mark mount dirty
+    %ergo -- TODO
+    %ogre -- TODO
+-}
+data SyncEf
+    = SyncEfHill ()  [Desk]
+    | SyncEfDirk Path Desk
+    | SyncEfErgo Path Desk [(Path, Maybe Mime)]
+    | SyncEfOgre Path Desk
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''SyncEf
+
+
+-- UDP Effects -----------------------------------------------------------------
+
+{-|
+    %init -- "I don't think that's something that can happen"
+    %west -- "Those also shouldn't happen"
+    %woot -- "Those also shouldn't happen"
+-}
+data AmesEf
+    = AmesEfInit Path ()
+    | AmesEfWest Path Ship Path Noun
+    | AmesEfWoot Path Ship (Maybe (Maybe (Term, [Tank])))
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''AmesEf
+
+
+-- Timer Effects ---------------------------------------------------------------
+
+{-|
+    %doze -- Set or clear timer.
+    %void -- Nasty hack to make the parser not treat this as a record.
+-}
+data BehnEf
+    = BehnEfDoze (KingId, ()) (Maybe Wen)
+    | BehnEfVoid Void
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''BehnEf
+
+
+-- Terminal Effects ------------------------------------------------------------
+
+{-|
+    %bel -- TODO
+    %clr -- TODO
+    %hop -- TODO
+    %lin -- TODO
+    %mor -- TODO
+    %sag -- TODO
+    %sav -- TODO
+    %url -- TODO
+-}
+data Blit
+    = Bel ()
+    | Clr ()
+    | Hop Word64
+    | Lin [Char]
+    | Mor ()
+    | Sag Path Noun
+    | Sav Path Atom
+    | Url Cord
+  deriving (Eq, Ord)
+
+-- Manual instance to not save the noun/atom in Sag/Sav, because these can be
+-- megabytes and makes king hang.
+instance Show Blit where
+  show (Bel ())     = "Bel ()"
+  show (Clr ())     = "Clr ()"
+  show (Hop x)      = "Hop " ++ (show x)
+  show (Lin c)      = "Lin " ++ (show c)
+  show (Mor ())     = "Mor ()"
+  show (Sag path _) = "Sag " ++ (show path)
+  show (Sav path _) = "Sav " ++ (show path)
+  show (Url c)      = "Url " ++ (show c)
+
+{-|
+    %blip -- TODO
+    %init -- TODO
+    %logo -- Shutdown
+    %mass -- Measure memory usage (unused)
+-}
+data TermEf
+    = TermEfBlit (UD, ()) [Blit]
+    | TermEfInit (UD, ()) Ship
+    | TermEfLogo Path ()
+    | TermEfMass Path Noun -- Irrelevant
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''Blit
+deriveNoun ''TermEf
+
+
+-- IO-Driver Routing -----------------------------------------------------------
+
+data VaneEf
+    = VENewt       NewtEf
+    | VEHttpClient HttpClientEf
+    | VEHttpServer HttpServerEf
+    | VEBehn       BehnEf
+    | VEAmes       AmesEf
+    | VETerm       TermEf
+    | VEClay       SyncEf
+    | VESync       SyncEf
+    | VEBoat       SyncEf
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''VaneEf
+
+
+-- Top-Level Ef Type -----------------------------------------------------------
+
+data Ef
+    = EfVane VaneEf
+    | EfVega Cord EvilPath -- second path component, rest of path
+    | EfExit Cord EvilPath -- second path component, rest of path
+  deriving (Eq, Ord, Show)
+
+instance ToNoun Ef where
+  toNoun = \case
+    EfVane v   -> toNoun $ reorgThroughNoun ("", v)
+    EfExit s p -> toNoun $ ReOrg "" s "exit" p (A 0)
+    EfVega s p -> toNoun $ ReOrg "" s "vega" p (A 0)
+
+instance FromNoun Ef where
+  parseNoun = parseNoun >=> \case
+    ReOrg "" s "exit" p (A 0) -> pure (EfExit s p)
+    ReOrg "" s "exit" p _     -> fail "%exit effect expects nil value"
+    ReOrg "" s "vega" p (A 0) -> pure (EfVega s p)
+    ReOrg "" s "vega" p _     -> fail "%vega effect expects nil value"
+    ReOrg "" s tag    p val   -> EfVane <$> parseNoun (toNoun (s, tag, p, val))
+    ReOrg _  _ _      _ _     -> fail "Non-empty first path-element"

pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs

@@ -0,0 +1,375 @@
+{-|
+    Event Types and Noun Conversion
+-}
+module Urbit.Arvo.Event where
+
+import Urbit.Noun.Tree (HoonMap, HoonSet)
+import Urbit.Prelude   hiding (Term)
+
+import Urbit.Arvo.Common (KingId(..), ServId(..))
+import Urbit.Arvo.Common (Desk, Mime)
+import Urbit.Arvo.Common (Header(..), HttpEvent)
+import Urbit.Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
+import Urbit.Arvo.Common (ReOrg(..), reorgThroughNoun)
+
+import qualified Crypto.Sign.Ed25519       as Ed
+import qualified Data.ByteString           as BS
+import qualified Data.ByteString.Char8     as C
+import qualified Network.HTTP.Types.Method as H
+
+-- Misc Types ------------------------------------------------------------------
+
+type Rift = Atom -- Continuity number
+type Life = Word -- Number of Azimoth key revs.
+type Bloq = Atom -- TODO
+type Oath = Atom -- Signature
+
+-- Parsed URLs -----------------------------------------------------------------
+
+type Host = Each Turf Ipv4
+type Hart = (Bool, Maybe Atom, Host)
+type Pork = (Maybe Knot, [Cord])
+type Quay = [(Cord, Cord)]
+
+data PUrl = PUrl Hart Pork Quay
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''PUrl
+
+
+-- Dawn Records ----------------------------------------------------------------
+
+padByteString :: BS.ByteString -> Int -> BS.ByteString
+padByteString bs length | remaining > 0 = bs <> (BS.replicate remaining 0)
+                        | otherwise = bs
+  where remaining = (length - (BS.length bs))
+
+-- A Pass is the Atom concatenation of 'b', the public encryption key, and the
+-- public authentication key. (see +pass-from-eth.)
+data Pass = Pass { passSign :: Ed.PublicKey, passCrypt :: Ed.PublicKey }
+  deriving (Eq, Ord, Show)
+
+passToBS :: Pass -> BS.ByteString
+passToBS Pass{..} = C.singleton 'b' <>
+                    (Ed.unPublicKey passSign) <>
+                    (Ed.unPublicKey passCrypt)
+
+instance ToNoun Pass where
+  toNoun = Atom . bytesAtom . passToBS
+
+instance FromNoun Pass where
+  parseNoun n = named "Pass" $ do
+    MkBytes unpadded <- parseNoun n
+    let bs = padByteString unpadded 65
+    when ((C.head bs) /= 'b') $ do
+      fail "Expecting 'b' prefix in public key structure"
+    let removedPrefix = C.tail bs
+    let passSign = Ed.PublicKey (take 32 removedPrefix)
+    let passCrypt = Ed.PublicKey (drop 32 removedPrefix)
+    unless ((length $ Ed.unPublicKey passSign) == 32) $
+      error "Sign pubkey not 32 bytes"
+    unless ((length $ Ed.unPublicKey passCrypt) == 32) $
+      error "Crypt pubkey not 32 bytes"
+    pure $ Pass{..}
+
+-- A Ring isn't the secret keys: it's the ByteString input which generates both
+-- the public key and the secret key. A Ring is the concatenation of 'B', the
+-- encryption key derivation seed, and the authentication key derivation
+-- seed. These aren't actually private keys, but public/private keypairs which
+-- can be derived from these seeds.
+data Ring = Ring { ringSign :: BS.ByteString, ringCrypt :: BS.ByteString }
+  deriving (Eq)
+
+instance ToNoun Ring where
+  toNoun Ring{..} =
+    Atom $ bytesAtom (C.singleton 'B' <> ringSign <> ringCrypt)
+
+instance FromNoun Ring where
+  parseNoun n = named "Ring" $ do
+      MkBytes unpadded <- parseNoun n
+      let bs = padByteString unpadded 65
+      when ((C.head bs) /= 'B') $ do
+        fail "Expecting 'B' prefix in public key structure"
+      let removedPrefix = C.tail bs
+      let ringSign = (take 32 removedPrefix)
+      let ringCrypt = (drop 32 removedPrefix)
+      unless ((length ringSign) == 32) $
+        error "Sign seed not 32 bytes"
+      unless ((length ringCrypt) == 32) $
+        error "Crypt seed not 32 bytes"
+      pure $ Ring ringSign ringCrypt
+
+instance Show Ring where
+  show r = "(Ring <<seed>> <<seed>>)"
+
+data Seed = Seed
+    { sShip :: Ship
+    , sLife :: Life
+    , sRing :: Ring
+    , sOath :: (Maybe Oath)
+    }
+  deriving (Eq, Show)
+
+type Public = (Life, HoonMap Life Pass)
+
+data Dnses = Dnses { dPri::Cord, dSec::Cord, dTer::Cord }
+  deriving (Eq, Ord, Show)
+
+type EthAddr = Atom --Bytes -- 20 bytes
+type ContNum = Word
+
+data EthPoint = EthPoint
+    { epOwn :: (EthAddr, EthAddr, EthAddr, EthAddr)
+    , epNet :: Maybe (Life, Pass, ContNum, (Bool, Ship), Maybe Ship)
+    , epKid :: Maybe (EthAddr, HoonSet Ship)
+    }
+  deriving (Eq, Show)
+
+data Dawn = MkDawn
+    { dSeed    :: Seed
+    , dSponsor :: [(Ship, EthPoint)]
+    , dCzar    :: HoonMap Ship (Rift, Life, Pass)
+    , dTurf    :: [Turf]
+    , dBloq    :: Bloq
+    , dNode    :: (Maybe PUrl)
+    }
+  deriving (Eq, Show)
+
+deriveNoun ''Dnses
+deriveNoun ''EthPoint
+deriveNoun ''Seed
+deriveNoun ''Dawn
+
+
+-- HTTP ------------------------------------------------------------------------
+
+type ServerId = Atom
+
+data Address
+    = AIpv4 Ipv4
+    | AIpv6 Ipv6
+    | AAmes Ship
+  deriving (Eq, Ord, Show)
+
+data HttpRequest = HttpRequest
+    { reqMeth :: H.StdMethod
+    , reqUrl  :: Cord
+    , reqHead :: [Header]
+    , reqBody :: Maybe File
+    }
+  deriving (Eq, Ord, Show)
+
+data HttpServerReq = HttpServerReq
+    { hsrSecure  :: Bool
+    , hsrAddress :: Address
+    , hsrRequest :: HttpRequest
+    }
+  deriving (Eq, Ord, Show)
+
+data HttpClientEv
+    = HttpClientEvReceive (KingId, ()) ServerId HttpEvent
+    | HttpClientEvBorn    (KingId, ()) ()
+    | HttpClientEvCrud    Path       Cord Tang
+  deriving (Eq, Ord, Show)
+
+data HttpServerEv
+    = HttpServerEvRequest       (ServId, UD, UD, ()) HttpServerReq
+    | HttpServerEvCancelRequest (ServId, UD, UD, ()) ()
+    | HttpServerEvRequestLocal  (ServId, UD, UD, ()) HttpServerReq
+    | HttpServerEvLive          (ServId, ())         Port (Maybe Port)
+    | HttpServerEvBorn          (KingId, ())         ()
+    | HttpServerEvCrud          Path                 Cord Tang
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''Address
+deriveNoun ''HttpClientEv
+deriveNoun ''HttpRequest
+deriveNoun ''HttpServerEv
+deriveNoun ''HttpServerReq
+
+
+-- Ames ------------------------------------------------------------------------
+
+data AmesEv
+    = AmesEvHear ()   AmesDest Bytes
+    | AmesEvHole ()   AmesDest Bytes
+    | AmesEvCrud Path Cord Tang
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''AmesEv
+
+
+-- Arvo Events -----------------------------------------------------------------
+
+data ArvoEv
+    = ArvoEvWhom () Ship
+    | ArvoEvWack () Word512
+    | ArvoEvWarn Path Noun
+    | ArvoEvCrud Path Cord Tang
+    | ArvoEvVeer Atom Noun
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''ArvoEv
+
+
+-- Boat Events -----------------------------------------------------------------
+
+data BoatEv
+    = BoatEvBoat ()   ()
+    | BoatEvCrud Path Cord Tang
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''BoatEv
+
+
+-- Timer Events ----------------------------------------------------------------
+
+data BehnEv
+    = BehnEvWake ()           ()
+    | BehnEvBorn (KingId, ()) ()
+    | BehnEvCrud Path         Cord Tang
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''BehnEv
+
+
+-- Newt Events -----------------------------------------------------------------
+
+data NewtEv
+    = NewtEvBorn (KingId, ()) ()
+    | NewtEvCrud Path         Cord Tang
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''NewtEv
+
+
+-- FileSystem Events -----------------------------------------------------------
+
+data SyncEv
+    = SyncEvInto (Nullable (KingId, ())) Desk Bool [(Path, Maybe Mime)]
+    | SyncEvCrud Path                    Cord Tang
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''SyncEv
+
+
+-- Terminal Events -------------------------------------------------------------
+
+data LegacyBootEvent
+    = Fake Ship
+    | Dawn Dawn
+  deriving (Eq, Show)
+
+data ArrowKey = D | L | R | U
+  deriving (Eq, Ord, Show)
+
+data Belt
+    = Aro ArrowKey
+    | Bac ()
+    | Ctl Cord
+    | Del ()
+    | Met Cord
+    | Ret ()
+    | Txt Tour
+  deriving (Eq, Ord, Show)
+
+data TermEv
+    = TermEvBelt (UD, ()) Belt
+    | TermEvBlew (UD, ()) Word Word
+    | TermEvBoot (UD, ()) Bool LegacyBootEvent
+    | TermEvHail (UD, ()) ()
+    | TermEvCrud Path       Cord Tang
+  deriving (Eq, Show)
+
+deriveNoun ''LegacyBootEvent
+deriveNoun ''ArrowKey
+deriveNoun ''Belt
+deriveNoun ''TermEv
+
+
+-- Events for Device Drivers ---------------------------------------------------
+
+data BlipEv
+    = BlipEvAmes       AmesEv
+    | BlipEvArvo       ArvoEv
+    | BlipEvBehn       BehnEv
+    | BlipEvBoat       BoatEv
+    | BlipEvHttpClient HttpClientEv
+    | BlipEvHttpServer HttpServerEv
+    | BlipEvNewt       NewtEv
+    | BlipEvSync       SyncEv
+    | BlipEvTerm       TermEv
+  deriving (Eq, Show)
+
+deriveNoun ''BlipEv
+
+
+-- Boot Events -----------------------------------------------------------------
+
+data Vane
+    = VaneVane VaneEv
+    | VaneZuse ZuseEv
+  deriving (Eq, Ord, Show)
+
+data VaneName
+    = Ames | Behn | Clay | Dill | Eyre | Ford | Gall | Iris | Jael
+  deriving (Eq, Ord, Show, Enum, Bounded)
+
+data ZuseEv
+    = ZEVeer () Cord Path BigCord
+    | ZEVoid Void
+  deriving (Eq, Ord, Show)
+
+data VaneEv
+    = VEVeer (VaneName, ()) Cord Path BigCord
+    | VEVoid Void
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''Vane
+deriveNoun ''VaneName
+deriveNoun ''VaneEv
+deriveNoun ''ZuseEv
+
+
+-- The Main Event Type ---------------------------------------------------------
+
+data Ev
+    = EvBlip BlipEv
+    | EvVane Vane
+  deriving (Eq, Show)
+
+instance ToNoun Ev where
+  toNoun = \case
+    EvBlip v -> toNoun $ reorgThroughNoun (Cord "",     v)
+    EvVane v -> toNoun $ reorgThroughNoun (Cord "vane", v)
+
+instance FromNoun Ev where
+  parseNoun = parseNoun >=> \case
+    ReOrg ""     s t p v -> fmap EvBlip $ parseNoun $ toNoun (s,t,p,v)
+    ReOrg "vane" s t p v -> fmap EvVane $ parseNoun $ toNoun (s,t,p,v)
+    ReOrg _      _ _ _ _ -> fail "First path-elem must be ?($ %vane)"
+
+-- Short Event Names -----------------------------------------------------------
+
+{-
+    In the case of the user hitting enter, the cause is technically a
+    terminal event, but we don't display any name because the cause is
+    really the user.
+-}
+getSpinnerNameForEvent :: Ev -> Maybe Text
+getSpinnerNameForEvent = \case
+    EvVane _ -> Nothing
+    EvBlip b -> case b of
+        BlipEvAmes _           -> Just "ames"
+        BlipEvArvo _           -> Just "arvo"
+        BlipEvBehn _           -> Just "behn"
+        BlipEvBoat _           -> Just "boat"
+        BlipEvHttpClient _     -> Just "iris"
+        BlipEvHttpServer _     -> Just "eyre"
+        BlipEvNewt _           -> Just "newt"
+        BlipEvSync _           -> Just "clay"
+        BlipEvTerm t | isRet t -> Nothing
+        BlipEvTerm t           -> Just "term"
+  where
+    isRet (TermEvBelt _ (Ret ())) = True
+    isRet _                       = False

pkg/hs/urbit-king/lib/Urbit/King/API.hs

@@ -0,0 +1,135 @@
+{-|
+    TODO This has a bunch of stub logic that was intended for an
+         architecture with a single Urbit daemon running multiple
+         ships. Do it or strip it out.
+-}
+
+module Urbit.King.API (King(..), kingAPI, readPortsFile) where
+
+import RIO.Directory
+import Urbit.Prelude
+
+import Network.Socket (Socket)
+import Prelude        (read)
+import Urbit.Arvo     (Belt)
+import Urbit.King.App (HasConfigDir(..))
+
+import qualified Network.HTTP.Types             as H
+import qualified Network.Wai                    as W
+import qualified Network.Wai.Handler.Warp       as W
+import qualified Network.Wai.Handler.WebSockets as WS
+import qualified Network.WebSockets             as WS
+import qualified Urbit.Vere.NounServ            as NounServ
+import qualified Urbit.Vere.Term.API            as Term
+
+
+-- Types -----------------------------------------------------------------------
+
+type TermConn = NounServ.Conn Belt [Term.Ev]
+
+type TermConnAPI = TVar (Maybe (TermConn -> STM ()))
+
+{-|
+    Daemon state.
+-}
+data King = King
+    { kServer   :: Async ()
+    , kTermConn :: TermConnAPI
+    }
+
+
+--------------------------------------------------------------------------------
+
+{-|
+    Get the filepath of the urbit config directory and the ports file.
+-}
+portsFilePath :: HasConfigDir e => RIO e (FilePath, FilePath)
+portsFilePath = do
+    dir <- view configDirL
+    fil <- pure (dir </> ".king.ports")
+    pure (dir, fil)
+
+{-|
+    Write the ports file.
+-}
+portsFile :: HasConfigDir e => Word -> RAcquire e (FilePath, FilePath)
+portsFile por =
+    mkRAcquire mkFile (removeFile . snd)
+  where
+    mkFile = do
+        (dir, fil) <- portsFilePath
+        createDirectoryIfMissing True dir
+        writeFile fil (encodeUtf8 $ tshow por)
+        pure (dir, fil)
+
+{-|
+    Get the HTTP port for the running Urbit daemon.
+-}
+readPortsFile :: HasConfigDir e => RIO e (Maybe Word)
+readPortsFile = do
+    (_, fil) <- portsFilePath
+    bs <- readFile fil
+    evaluate (readMay $ unpack $ decodeUtf8 bs)
+
+kingServer :: HasLogFunc e => (Int, Socket) -> RAcquire e King
+kingServer is =
+    mkRAcquire (startKing is) (cancel . kServer)
+  where
+    startKing :: HasLogFunc e => (Int, Socket) -> RIO e King
+    startKing (port, sock) = do
+        api <- newTVarIO Nothing
+        let opts = W.defaultSettings & W.setPort port
+        env <- ask
+        tid <- async $ io $ W.runSettingsSocket opts sock $ app env api
+        pure (King tid api)
+
+{-|
+    Start the HTTP server and write to the ports file.
+-}
+kingAPI :: (HasConfigDir e, HasLogFunc e)
+        => RAcquire e King
+kingAPI = do
+    (port, sock) <- io $ W.openFreePort
+    (dir, fil)   <- portsFile (fromIntegral port)
+    -- lockFile dir
+    kingServer (port, sock)
+
+serveTerminal :: HasLogFunc e => e -> TermConnAPI -> Word -> W.Application
+serveTerminal env api word =
+    WS.websocketsOr WS.defaultConnectionOptions wsApp fallback
+  where
+    fallback req respond =
+        respond $ W.responseLBS H.status500 []
+                $ "This endpoint uses websockets"
+
+    wsApp pen =
+        atomically (readTVar api) >>= \case
+            Nothing -> WS.rejectRequest pen "Ship not running"
+            Just sp -> do
+                wsc <- io $ WS.acceptRequest pen
+                inp <- io $ newTBMChanIO 5
+                out <- io $ newTBMChanIO 5
+                atomically $ sp $ NounServ.mkConn inp out
+                let doit = runRIO env
+                         $ NounServ.wsConn "NOUNSERV (wsServ) " inp out wsc
+
+                -- If `wai` kills this thread for any reason, the TBMChans
+                -- need to be closed. If they are not closed, the
+                -- terminal will not know that they disconnected.
+                finally doit $ atomically $ do
+                    closeTBMChan inp
+                    closeTBMChan out
+
+data BadShip = BadShip Text
+  deriving (Show, Exception)
+
+app :: HasLogFunc e => e -> TermConnAPI -> W.Application
+app env api req respond =
+    case W.pathInfo req of
+        ["terminal", session] -> do
+            session :: Word <- evaluate $ read $ unpack session
+            serveTerminal env api session req respond
+        ["status"] ->
+            respond $ W.responseLBS H.status200 [] "{}"
+        _ ->
+            respond $ W.responseLBS H.status404 [] "No implemented"

pkg/hs/urbit-king/lib/Urbit/King/App.hs

@@ -0,0 +1,140 @@
+{-|
+    Code for setting up the RIO environment.
+-}
+module Urbit.King.App
+    ( App
+    , runApp
+    , runAppLogFile
+    , runAppNoLog
+    , runPierApp
+    , HasConfigDir(..)
+    , HasStderrLogFunc(..)
+    ) where
+
+import Urbit.King.Config
+import Urbit.Prelude
+
+import System.Directory (createDirectoryIfMissing, getHomeDirectory)
+
+--------------------------------------------------------------------------------
+
+class HasConfigDir a where
+    configDirL ∷ Lens' a FilePath
+
+class HasStderrLogFunc a where
+    stderrLogFuncL :: Lens' a LogFunc
+
+--------------------------------------------------------------------------------
+
+data App = App
+    { _appLogFunc       :: !LogFunc
+    , _appStderrLogFunc :: !LogFunc
+    }
+
+makeLenses ''App
+
+instance HasLogFunc App where
+    logFuncL = appLogFunc
+
+instance HasStderrLogFunc App where
+    stderrLogFuncL = appStderrLogFunc
+
+runApp :: RIO App a -> IO a
+runApp inner = do
+    logOptions <- logOptionsHandle stderr True
+        <&> setLogUseTime True
+        <&> setLogUseLoc False
+
+    withLogFunc logOptions $ \logFunc ->
+        runRIO (App logFunc logFunc) inner
+
+runAppLogFile :: RIO App a -> IO a
+runAppLogFile inner =
+    withLogFileHandle $ \h -> do
+      logOptions <- logOptionsHandle h True
+          <&> setLogUseTime True
+          <&> setLogUseLoc False
+      stderrLogOptions <- logOptionsHandle stderr True
+          <&> setLogUseTime False
+          <&> setLogUseLoc False
+
+      withLogFunc stderrLogOptions $ \stderrLogFunc ->
+        withLogFunc logOptions $ \logFunc ->
+          runRIO (App logFunc stderrLogFunc) inner
+
+withLogFileHandle :: (Handle -> IO a) -> IO a
+withLogFileHandle act = do
+    home <- getHomeDirectory
+    let logDir = home </> ".urbit"
+    createDirectoryIfMissing True logDir
+    withFile (logDir </> "king.log") AppendMode $ \handle -> do
+        hSetBuffering handle LineBuffering
+        act handle
+
+runAppNoLog :: RIO App a -> IO a
+runAppNoLog act =
+    withFile "/dev/null" AppendMode $ \handle -> do
+      logOptions <- logOptionsHandle handle True
+      withLogFunc logOptions $ \logFunc ->
+        runRIO (App logFunc logFunc) act
+
+--------------------------------------------------------------------------------
+
+-- | A PierApp is like an App, except that it also provides a PierConfig
+data PierApp = PierApp
+    { _pierAppLogFunc       :: !LogFunc
+    , _pierAppStderrLogFunc :: !LogFunc
+    , _pierAppPierConfig    :: !PierConfig
+    , _pierAppNetworkConfig :: !NetworkConfig
+    }
+
+makeLenses ''PierApp
+
+instance HasStderrLogFunc PierApp where
+    stderrLogFuncL = pierAppStderrLogFunc
+
+instance HasLogFunc PierApp where
+    logFuncL = pierAppLogFunc
+
+instance HasPierConfig PierApp where
+    pierConfigL = pierAppPierConfig
+
+instance HasNetworkConfig PierApp where
+    networkConfigL = pierAppNetworkConfig
+
+instance HasConfigDir PierApp where
+    configDirL = pierAppPierConfig . pcPierPath
+
+runPierApp :: PierConfig -> NetworkConfig -> Bool -> RIO PierApp a -> IO a
+runPierApp pierConfig networkConfig daemon inner =
+    if daemon
+    then execStderr
+    else withLogFileHandle execFile
+  where
+    execStderr = do
+        logOptions <- logOptionsHandle stderr True
+            <&> setLogUseTime True
+            <&> setLogUseLoc False
+
+        withLogFunc logOptions $ \logFunc ->
+            go $ PierApp { _pierAppLogFunc = logFunc
+                         , _pierAppStderrLogFunc = logFunc
+                         , _pierAppPierConfig = pierConfig
+                         , _pierAppNetworkConfig = networkConfig
+                         }
+
+    execFile logHandle = do
+        logOptions <- logOptionsHandle logHandle True
+            <&> setLogUseTime True
+            <&> setLogUseLoc False
+        logStderrOptions <- logOptionsHandle stderr True
+            <&> setLogUseTime False
+            <&> setLogUseLoc False
+        withLogFunc logStderrOptions $ \logStderr ->
+          withLogFunc logOptions $ \logFunc ->
+              go $ PierApp { _pierAppLogFunc = logFunc
+                           , _pierAppStderrLogFunc = logStderr
+                           , _pierAppPierConfig = pierConfig
+                           , _pierAppNetworkConfig = networkConfig
+                           }
+    go app = runRIO app inner

pkg/hs/urbit-king/lib/Urbit/King/CLI.hs

@@ -0,0 +1,389 @@
+{-# OPTIONS_GHC -Werror -Wall #-}
+{-# LANGUAGE CPP #-}
+
+{-|
+    Command line parsing.
+-}
+module Urbit.King.CLI where
+
+import ClassyPrelude
+import Options.Applicative
+import Options.Applicative.Help.Pretty
+
+import Data.Word          (Word16)
+import System.Environment (getProgName)
+
+--------------------------------------------------------------------------------
+
+data Opts = Opts
+    { oQuiet      :: Bool
+    , oHashless   :: Bool
+    , oExit       :: Bool
+    , oDryRun     :: Bool
+    , oDryFrom    :: Maybe Word64
+    , oVerbose    :: Bool
+    , oAmesPort   :: Maybe Word16
+    , oTrace      :: Bool
+    , oCollectFx  :: Bool
+    , oLocalhost  :: Bool
+    , oOffline    :: Bool
+    , oFullReplay :: Bool
+    }
+  deriving (Show)
+
+data BootType
+  = BootComet
+  | BootFake Text
+  | BootFromKeyfile FilePath
+  deriving (Show)
+
+data PillSource
+  = PillSourceFile FilePath
+  | PillSourceURL String
+  deriving (Show)
+
+data New = New
+    { nPillSource :: PillSource
+    , nPierPath   :: Maybe FilePath -- Derived from ship name if not specified.
+    , nArvoDir    :: Maybe FilePath
+    , nBootType   :: BootType
+    , nLite       :: Bool
+    }
+  deriving (Show)
+
+data Run = Run
+    { rPierPath :: FilePath
+    }
+  deriving (Show)
+
+data Bug
+    = ValidatePill
+        { bPillPath :: FilePath
+        , bPrintPil :: Bool
+        , bPrintSeq :: Bool
+        }
+    | CollectAllFX
+        { bPierPath :: FilePath
+        }
+    | EventBrowser
+        { bPierPath :: FilePath
+        }
+    | ValidateEvents
+        { bPierPath :: FilePath
+        , bFirstEvt :: Word64
+        , bFinalEvt :: Word64
+        }
+    | ValidateFX
+        { bPierPath :: FilePath
+        , bFirstEvt :: Word64
+        , bFinalEvt :: Word64
+        }
+    | ReplayEvents
+        { bPierPath :: FilePath
+        , bFinalEvt :: Word64
+        }
+    | CheckDawn
+        { bKeyfilePath :: FilePath
+        }
+    | CheckComet
+  deriving (Show)
+
+data Cmd
+    = CmdNew New Opts
+    | CmdRun Run Opts Bool
+    | CmdBug Bug
+    | CmdCon FilePath
+  deriving (Show)
+
+--------------------------------------------------------------------------------
+
+headNote :: String -> Doc
+headNote _version = string $ intercalate "\n"
+  [ "Urbit: a personal server operating function"
+  , "https://urbit.org"
+  , "Version " <> VERSION_urbit_king
+  ]
+
+-- | TODO This needs to be updated.
+footNote :: String -> Doc
+footNote exe = string $ intercalate "\n"
+  [ "Development Usage:"
+  , "  To create a development ship, use a fakezod:"
+  , "    $ " <>exe<> " new zod /path/to/pill -F zod -A arvo/folder"
+  , ""
+  , "Simple Usage: "
+  , "  $ " <>exe<> " new pier <my-comet> to create a comet (anonymous urbit)"
+  , "  $ " <>exe<> " new pier <my-planet> -k <my-key-file> if you own a planet"
+  , "  $ " <>exe<> " run <myplanet or mycomet> to restart an existing urbit"
+  , ""
+  , "For more information about developing on urbit, see:"
+  , "  https://github.com/urbit/urbit/blob/master/CONTRIBUTING.md"
+  ]
+
+--------------------------------------------------------------------------------
+
+parseArgs :: IO Cmd
+parseArgs = do
+    nm <- getProgName
+
+    let p = prefs $ showHelpOnError
+                 <> showHelpOnEmpty
+                 <> columns 80
+
+    let o = info (cmd <**> helper)
+              $ progDesc "Start an existing Urbit or boot a new one."
+             <> headerDoc (Just $ headNote "0.9001.0")
+             <> footerDoc (Just $ footNote nm)
+             <> fullDesc
+
+    customExecParser p o
+
+--------------------------------------------------------------------------------
+
+defaultPillURL :: String
+defaultPillURL = "https://bootstrap.urbit.org/urbit-v" <> ver <> ".pill"
+  where
+    ver = VERSION_urbit_king
+
+--------------------------------------------------------------------------------
+
+newComet :: Parser BootType
+newComet = flag' BootComet
+    ( long "comet"
+   <> help "Boot a new comet"
+    )
+
+newFakeship :: Parser BootType
+newFakeship = BootFake <$> strOption
+                         (short 'F'
+                        <> long "fake"
+                        <> metavar "SHIP"
+                        <> help "Boot a fakeship")
+
+newFromKeyfile :: Parser BootType
+newFromKeyfile = BootFromKeyfile <$> strOption
+                             (short 'k'
+                            <> long "keyfile"
+                            <> metavar "KEYFILE"
+                            <> help "Boot from a keyfile")
+
+pillFromPath :: Parser PillSource
+pillFromPath = PillSourceFile <$> strOption
+                     ( short 'B'
+                    <> long "pill"
+                    <> metavar "PILL"
+                    <> help "Path to pill file")
+
+pillFromURL :: Parser PillSource
+pillFromURL = PillSourceURL <$> strOption
+                     ( short 'u'
+                    <> long "pill-url"
+                    <> metavar "URL"
+                    <> value defaultPillURL
+                    <> help "URL to pill file")
+
+pierPath :: Parser FilePath
+pierPath = strArgument (metavar "PIER" <> help "Path to pier")
+
+new :: Parser New
+new = do
+    nPierPath <- optional pierPath
+
+    nBootType <- newComet <|> newFakeship <|> newFromKeyfile
+
+    nPillSource <- pillFromPath <|> pillFromURL
+
+    nLite <- switch
+               $ short 'l'
+              <> long "lite"
+              <> help "Boots ship in lite mode"
+
+    nArvoDir <- option auto
+                    $ metavar "PATH"
+                   <> short 'A'
+                   <> long "arvo"
+                   <> value Nothing
+                   <> help "Replace initial clay filesys with contents of PATH"
+
+    pure New{..}
+
+opts :: Parser Opts
+opts = do
+    oAmesPort  <- optional $ option auto $ metavar "PORT"
+                             <> short 'p'
+                             <> long "ames"
+                             <> help "Ames port number"
+                             <> hidden
+
+    -- Always disable hashboard. Right now, urbit is almost unusable with this
+    -- flag enabled and it is disabled in vere.
+    let oHashless = True
+    -- oHashless  <- switch $ short 'S'
+    --                     <> long "hashless"
+    --                     <> help "Disable battery hashing"
+    --                     <> hidden
+
+    oQuiet     <- switch $ short 'q'
+                        <> long "quiet"
+                        <> help "Quiet"
+                        <> hidden
+
+    oVerbose   <- switch $ short 'v'
+                        <> long "verbose"
+                        <> help "Verbose"
+                        <> hidden
+
+    oExit      <- switch $ short 'x'
+                        <> long "exit"
+                        <> help "Exit immediately"
+                        <> hidden
+
+    oDryRun    <- switch $ long "dry-run"
+                        <> help "Persist no events and turn off Ames networking"
+                        <> hidden
+
+    oDryFrom   <- optional $ option auto $ metavar "EVENT"
+                             <> long "dry-from"
+                             <> help "Dry run from event number"
+                             <> hidden
+
+    oTrace     <- switch $ short 't'
+                        <> long "trace"
+                        <> help "Enable tracing"
+                        <> hidden
+
+    oLocalhost <- switch $ short 'L'
+                        <> long "local"
+                        <> help "Localhost-only networking"
+                        <> hidden
+
+    oCollectFx <- switch $ short 'f'
+                        <> long "collect-fx"
+                        <> help "Write effects to disk for debugging"
+                        <> hidden
+
+    oOffline   <- switch $ short 'O'
+                        <> long "offline"
+                        <> help "Run without any networking"
+                        <> hidden
+
+    oFullReplay <- switch
+          $ long "full-log-replay"
+         <> help "Ignores the snapshot and recomputes state from log"
+         <> hidden
+
+    pure (Opts{..})
+
+newShip :: Parser Cmd
+newShip = CmdNew <$> new <*> opts
+
+runShip :: Parser Cmd
+runShip = do
+    rPierPath <- pierPath
+    o         <- opts
+    daemon    <- switch $ short 'd'
+                         <> long "daemon"
+                         <> help "Daemon mode"
+                         <> hidden
+    pure (CmdRun (Run{..}) o daemon)
+
+valPill :: Parser Bug
+valPill = do
+    bPillPath <- strArgument (metavar "PILL" <> help "Path to pill")
+
+    bPrintPil <- switch $ long "print-pill"
+                       <> help "Print pill"
+
+    bPrintSeq <- switch $ long "print-boot"
+                       <> help "Print boot sequence"
+
+    pure ValidatePill{..}
+
+keyfilePath :: Parser FilePath
+keyfilePath = strArgument (metavar "KEYFILE" <> help "Path to key file")
+
+firstEv :: Parser Word64
+firstEv = option auto $ long "first"
+                     <> metavar "FST"
+                     <> help "starting from event FST"
+                     <> value 1
+
+lastEv :: Parser Word64
+lastEv = option auto $ long "last"
+                    <> metavar "LAS"
+                    <> help "ending with event LAS"
+                    <> value maxBound
+
+checkEvs :: Parser Bug
+checkEvs = ValidateEvents <$> pierPath <*> firstEv <*> lastEv
+
+checkFx :: Parser Bug
+checkFx = ValidateFX <$> pierPath <*> firstEv <*> lastEv
+
+replayEvs :: Parser Bug
+replayEvs = ReplayEvents <$> pierPath <*> lastEv
+
+browseEvs :: Parser Bug
+browseEvs = EventBrowser <$> pierPath
+
+checkDawn :: Parser Bug
+checkDawn = CheckDawn <$> keyfilePath
+
+bugCmd :: Parser Cmd
+bugCmd = fmap CmdBug
+        $ subparser
+        $ command "validate-pill"
+            ( info (valPill <**> helper)
+            $ progDesc "Validate a pill file."
+            )
+       <> command "collect-all-fx"
+            ( info (allFx <**> helper)
+            $ progDesc "Replay entire event log, collecting all effects"
+            )
+       <> command "validate-events"
+            ( info (checkEvs <**> helper)
+            $ progDesc "Parse all data in event log"
+            )
+       <> command "event-browser"
+            ( info (browseEvs <**> helper)
+            $ progDesc "Interactively view (and prune) event log"
+            )
+       <> command "validate-effects"
+            ( info (checkFx <**> helper)
+            $ progDesc "Parse all data in event log"
+            )
+       <> command "partial-replay"
+            ( info (replayEvs <**> helper)
+            $ progDesc "Replay up to N events"
+            )
+       <> command "dawn"
+            ( info (checkDawn <**> helper)
+            $ progDesc "Test run dawn"
+            )
+       <> command "comet"
+            ( info (pure CheckComet)
+            $ progDesc "Shows the list of stars accepting comets"
+            )
+
+conCmd :: Parser Cmd
+conCmd = CmdCon <$> pierPath
+
+allFx :: Parser Bug
+allFx = do
+    bPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
+    pure CollectAllFX{..}
+
+cmd :: Parser Cmd
+cmd = subparser
+        $ command "new" ( info (newShip <**> helper)
+                        $ progDesc "Boot a new ship."
+                        )
+       <> command "run" ( info (runShip <**> helper)
+                        $ progDesc "Run an existing ship."
+                        )
+       <> command "bug" ( info (bugCmd <**> helper)
+                        $ progDesc "Run a debugging sub-command."
+                        )
+       <> command "con" ( info (conCmd <**> helper)
+                        $ progDesc "Connect a terminal to a running urbit."
+                        )

pkg/hs/urbit-king/lib/Urbit/King/Config.hs

@@ -0,0 +1,53 @@
+{-|
+    Pier Configuration
+-}
+module Urbit.King.Config where
+
+import Urbit.Prelude
+
+{-|
+    All the configuration data revolving around a ship and the current
+    execution options.
+-}
+data PierConfig = PierConfig
+    { _pcPierPath :: FilePath
+    , _pcDryRun   :: Bool
+    } deriving (Show)
+
+makeLenses ''PierConfig
+
+class HasPierConfig env where
+    pierConfigL :: Lens' env PierConfig
+
+pierPathL ∷ HasPierConfig a => Lens' a FilePath
+pierPathL = pierConfigL . pcPierPath
+
+dryRunL :: HasPierConfig a => Lens' a Bool
+dryRunL = pierConfigL . pcDryRun
+
+-------------------------------------------------------------------------------
+
+data NetworkingType
+  = NetworkNone
+  | NetworkNormal
+  | NetworkLocalhost
+  deriving (Show)
+
+data NetworkConfig = NetworkConfig
+  { ncNetworking :: NetworkingType
+  , ncAmesPort   :: Maybe Word16
+  } deriving (Show)
+
+class HasNetworkConfig env where
+    networkConfigL :: Lens' env NetworkConfig
+
+getNetworkingType :: (MonadReader env m, HasNetworkConfig env)
+                  => m NetworkingType
+getNetworkingType = do
+  NetworkConfig{..} <- view networkConfigL
+  pure ncNetworking
+
+getAmesPort :: (MonadReader env m, HasNetworkConfig env) => m (Maybe Word16)
+getAmesPort = do
+  NetworkConfig{..} <- view networkConfigL
+  pure ncAmesPort

pkg/hs/urbit-king/lib/Urbit/King/EventBrowser.hs

@@ -0,0 +1,192 @@
+{-|
+    Interactive Event-Log Browser
+
+    TODO Handle CTRL-D
+-}
+
+module Urbit.King.EventBrowser (run) where
+
+import Urbit.Prelude
+
+import Data.Conduit
+import Urbit.Arvo
+import Urbit.Time
+import Urbit.Vere.Pier.Types
+
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Urbit.Vere.Log            (EventLog)
+
+import qualified Data.Conduit.Combinators as C
+import qualified Urbit.Vere.Log           as Log
+
+--------------------------------------------------------------------------------
+
+data Event = Event
+    { num :: Word64
+    , mug :: Mug
+    , wen :: Wen
+    , ova :: Ev
+    }
+  deriving Show
+
+data Input = Next | Prev | Quit | Trim | Effs | Init | Last
+
+--------------------------------------------------------------------------------
+
+run :: HasLogFunc e => EventLog -> RIO e ()
+run log = do
+    hSetBuffering stdin NoBuffering
+    hSetEcho stdin False
+    logInfo $ displayShow (Log.identity log)
+    let cycle = fromIntegral $ lifecycleLen $ Log.identity log
+    las <- Log.lastEv log
+    loop cycle las las
+  where
+    failRead cur =
+        putStrLn ("ERROR: Failed to read event: " <> tshow cur)
+
+    input cyc las cur mFx = do
+        getInput las cur >>= \case
+            Next -> loop cyc las (succ cur)
+            Prev -> loop cyc las (pred cur)
+            Init -> loop cyc las 1
+            Last -> loop cyc las las
+            Quit -> pure ()
+            Trim -> trim cyc las cur mFx
+            Effs -> showEffects mFx >> input cyc las cur mFx
+
+    trim cyc las cur mFx = do
+        deleteFrom log las cur >>= \case
+            True  -> loop cyc (pred cur) (pred cur)
+            False -> input cyc las cur mFx
+
+    loop cyc las 0                = loop cyc las 1
+    loop cyc las cur | cur > las  = loop cyc las las
+    loop cyc las cur | cyc >= cur = do
+        putStrLn ""
+        putStrLn "    [EVENT]"
+        putStrLn ""
+        putStrLn "    Lifecycle Nock"
+        putStrLn ""
+        input cyc las cur (Just [])
+
+    loop cyc las cur = do
+        mEv <- peekEvent  log cur
+        mFx <- peekEffect log cur
+
+        case mEv of
+            Nothing -> failRead cur
+            Just ev -> showEvent ev >> showEffectsTeaser mFx
+
+        input cyc las cur mFx
+
+deleteFrom :: HasLogFunc e => EventLog -> Word64 -> Word64 -> RIO e Bool
+deleteFrom log las cur = do
+    sure <- areYouSure
+    if sure then doDelete else abortDelete
+    pure sure
+  where
+    abortDelete = do
+        putStrLn "\n\n    [ABORTED]\n"
+        putStrLn "    Aborted delete, no events pruned.\n"
+
+    doDelete = do
+        Log.trimEvents log cur
+        putStrLn "\n\n    [DELETED]\n"
+        putStrLn "    It's gone forever!\n"
+
+    question =
+      if las == cur
+      then mconcat [ "    This will permanently delete the last event (#"
+                   , tshow las
+                   , ")\n" ]
+      else mconcat [ "    This will permanently delete all events in (#"
+                   , tshow cur
+                   , " - #"
+                   , tshow las
+                   , ")\n" ]
+
+    areYouSure = do
+        putStrLn "\n\n    ARE YOU SURE????"
+        putStrLn ""
+        putStrLn question
+        putStr "(y|n) "
+        hFlush stdout
+        getChar <&> \case
+          'y' -> True
+          _   -> False
+
+getInput :: Word64 -> Word64 -> RIO e Input
+getInput las cur = do
+    putStr ("(" <> tshow cur <> "/" <> tshow las <> ") ")
+    hFlush stdout
+    getChar >>= \case
+        'j'    -> pure Next
+        'k'    -> pure Prev
+        'q'    -> pure Quit
+        'f'    -> pure Effs
+        'x'    -> pure Trim
+        '0'    -> pure Init
+        'G'    -> pure Last
+        _      -> do putStrLn "\n"
+                     putStrLn help
+                     getInput las cur
+  where
+    help = unlines
+       [ "    [HELP]"
+       , ""
+       , "    k    View the previous event"
+       , "    j    View the next event"
+       , "    0    View the first event"
+       , "    G    View the last event"
+       , "    q    Quit"
+       , "    x    Delete (only the last event)"
+       , "    ?    Show this help"
+       ]
+
+showEffectsTeaser :: Maybe FX -> RIO e ()
+showEffectsTeaser Nothing   = putStrLn "    [No collected effects]\n"
+showEffectsTeaser (Just []) = putStrLn "    [No effects for this event]\n"
+showEffectsTeaser (Just fx) = putStrLn $ mconcat
+    [ "    ["
+    , tshow (length fx)
+    , " collected effects. Press 'f' to view]\n"
+    ]
+
+showEffects :: Maybe FX -> RIO e ()
+showEffects Nothing   = putStrLn "    [No collected effects]\n"
+showEffects (Just []) = putStrLn "    [No effects for this event]\n"
+showEffects (Just fx) = do
+    putStrLn "\n"
+    putStrLn "    [EFFECTS]"
+    for_ fx $ \ef -> do
+        putStrLn ""
+        showEffect ef
+    putStrLn ""
+
+showEffect :: Lenient Ef -> RIO e ()
+showEffect (GoodParse ef) =
+    putStrLn $ unlines $ fmap ("    " <>) $ lines $ pack $ ppShow ef
+showEffect (FailParse n) =
+    putStrLn $ unlines $ fmap ("    " <>) $ lines $ pack $ ppShow n
+
+showEvent :: Event -> RIO e ()
+showEvent ev = do
+    putStrLn "\n"
+    putStrLn "    [EVENT]"
+    putStrLn ""
+    putStrLn $ unlines $ fmap ("    " <>) $ lines $ pack $ ppShow (ova ev)
+
+peekEffect :: HasLogFunc e => EventLog -> Word64 -> RIO e (Maybe FX)
+peekEffect log eId = runMaybeT $ do
+   (id, bs) <- MaybeT $ runConduit (Log.streamEffectsRows log eId .| C.head)
+   guard (id == eId)
+   io $ cueBSExn bs >>= fromNounExn
+
+peekEvent :: HasLogFunc e => EventLog -> Word64 -> RIO e (Maybe Event)
+peekEvent log eId = runMaybeT $ do
+    octs    <- MaybeT $ runConduit (Log.streamEvents log eId .| C.head)
+    noun    <- io $ cueBSExn octs
+    (m,w,e) <- io $ fromNounExn noun
+    ovum    <- fromNounExn e
+    pure (Event eId m w ovum)

pkg/hs/urbit-king/lib/Urbit/King/Main.hs

@@ -0,0 +1,638 @@
+{-|
+    King Haskell Entry Point
+
+    # Event Pruning
+
+    - `king discard-events NUM_EVENTS`: Delete the last `n` events from
+      the event log.
+
+    - `king discard-events-interactive`: Iterate through the events in
+      the event log, from last to first, pretty-print each event, and
+      ask if it should be pruned.
+
+    # Implement subcommands to test event and effect parsing.
+
+    - `king * --collect-fx`: All effects that come from the serf get
+      written into the `effects` LMDB database.
+
+    - `king clear-fx PIER`: Deletes all collected effects.
+
+    - `king full-replay PIER`: Replays the whole event log events, print
+      any failures. On success, replace the snapshot.
+
+
+    # Full Replay -- An Integration Test
+
+    - Copy the event log:
+
+      - Create a new event log at the destination.
+      - Stream events from the first event log.
+      - Parse each event.
+      - Re-Serialize each event.
+      - Verify that the round-trip was successful.
+      - Write the event into the new database.
+
+    - Replay the event log at the destination.
+      - If `--collect-fx` is set, then record effects as well.
+
+    - Snapshot.
+
+    - Verify that the final mug is the same as it was before.
+
+    # Implement Remaining Serf Flags
+
+    - `DebugRam`: Memory debugging.
+    - `DebugCpu`: Profiling
+    - `CheckCorrupt`: Heap Corruption Tests
+    - `CheckFatal`: TODO What is this?
+    - `Verbose`: TODO Just the `-v` flag?
+    - `DryRun`: TODO Just the `-N` flag?
+    - `Quiet`: TODO Just the `-q` flag?
+    - `Hashless`: Don't use hashboard for jets.
+-}
+
+module Urbit.King.Main (main) where
+
+import Urbit.Prelude
+
+import Data.Conduit
+import Network.HTTP.Client.TLS
+import RIO.Directory
+import Urbit.Arvo
+import Urbit.King.Config
+import Urbit.Vere.Dawn
+import Urbit.Vere.Pier
+import Urbit.Vere.Pier.Types
+import Urbit.Vere.Serf
+
+import Control.Concurrent     (myThreadId)
+import Control.Exception      (AsyncException(UserInterrupt))
+import Control.Lens           ((&))
+import System.Process         (system)
+import Text.Show.Pretty       (pPrint)
+import Urbit.King.App         (runApp, runAppLogFile, runAppNoLog, runPierApp)
+import Urbit.King.App         (HasConfigDir(..), HasStderrLogFunc(..))
+import Urbit.Noun.Conversions (cordToUW)
+import Urbit.Time             (Wen)
+import Urbit.Vere.LockFile    (lockFile)
+
+import qualified Data.Set                as Set
+import qualified Data.Text               as T
+import qualified Network.HTTP.Client     as C
+import qualified System.Posix.Signals    as Sys
+import qualified System.ProgressBar      as PB
+import qualified System.Random           as Sys
+import qualified Urbit.King.CLI          as CLI
+import qualified Urbit.King.EventBrowser as EventBrowser
+import qualified Urbit.Ob                as Ob
+import qualified Urbit.Vere.Log          as Log
+import qualified Urbit.Vere.Pier         as Pier
+import qualified Urbit.Vere.Serf         as Serf
+import qualified Urbit.Vere.Term         as Term
+
+--------------------------------------------------------------------------------
+
+zod :: Ship
+zod = 0
+
+--------------------------------------------------------------------------------
+
+removeFileIfExists :: HasLogFunc env => FilePath -> RIO env ()
+removeFileIfExists pax = do
+  exists <- doesFileExist pax
+  when exists $ do
+      removeFile pax
+
+--------------------------------------------------------------------------------
+
+toSerfFlags :: CLI.Opts -> Serf.Flags
+toSerfFlags CLI.Opts{..} = catMaybes m
+  where
+    -- TODO: This is not all the flags.
+    m = [ from oQuiet Serf.Quiet
+        , from oTrace Serf.Trace
+        , from oHashless Serf.Hashless
+        , from oQuiet Serf.Quiet
+        , from oVerbose Serf.Verbose
+        , from (oDryRun || isJust oDryFrom) Serf.DryRun
+        ]
+    from True flag = Just flag
+    from False _   = Nothing
+
+
+toPierConfig :: FilePath -> CLI.Opts -> PierConfig
+toPierConfig pierPath CLI.Opts{..} = PierConfig
+    { _pcPierPath = pierPath
+    , _pcDryRun   = (oDryRun || isJust oDryFrom)
+    }
+
+toNetworkConfig :: CLI.Opts -> NetworkConfig
+toNetworkConfig CLI.Opts{..} = NetworkConfig
+    { ncNetworking = if (oDryRun || isJust oDryFrom) then NetworkNone
+                     else if oOffline then NetworkNone
+                     else if oLocalhost then NetworkLocalhost
+                     else NetworkNormal
+    , ncAmesPort = oAmesPort
+    }
+
+tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
+                   , HasConfigDir e, HasStderrLogFunc e
+                   )
+                => Bool -> Pill -> Bool -> Serf.Flags -> Ship
+                -> LegacyBootEvent
+                -> RIO e ()
+tryBootFromPill oExit pill lite flags ship boot = do
+    mStart <- newEmptyMVar
+    runOrExitImmediately bootedPier oExit mStart
+  where
+    bootedPier = do
+        view pierPathL >>= lockFile
+        rio $ logTrace "Starting boot"
+        sls <- Pier.booted pill lite flags ship boot
+        rio $ logTrace "Completed boot"
+        pure sls
+
+runOrExitImmediately :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
+                        , HasConfigDir e
+                        )
+                     => RAcquire e (Serf e, Log.EventLog, SerfState)
+                     -> Bool
+                     -> MVar ()
+                     -> RIO e ()
+runOrExitImmediately getPier oExit mStart =
+    rwith getPier $ if oExit then shutdownImmediately else runPier
+  where
+    shutdownImmediately (serf, log, ss) = do
+        logTrace "Sending shutdown signal"
+        logTrace $ displayShow ss
+
+        -- Why is this here? Do I need to force a snapshot to happen?
+        io $ threadDelay 500000
+
+        ss <- shutdown serf 0
+        logTrace $ displayShow ss
+        logTrace "Shutdown!"
+
+    runPier sls = do
+        runRAcquire $ Pier.pier sls mStart
+
+tryPlayShip :: ( HasStderrLogFunc e, HasLogFunc e, HasNetworkConfig e
+               , HasPierConfig e, HasConfigDir e
+               )
+            => Bool -> Bool -> Maybe Word64 -> Serf.Flags -> MVar () -> RIO e ()
+tryPlayShip exitImmediately fullReplay playFrom flags mStart = do
+    when fullReplay wipeSnapshot
+    runOrExitImmediately resumeShip exitImmediately mStart
+  where
+    wipeSnapshot = do
+        shipPath <- view pierPathL
+        logTrace "wipeSnapshot"
+        logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
+        logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
+        removeFileIfExists (north shipPath)
+        removeFileIfExists (south shipPath)
+
+    north shipPath = shipPath <> "/.urb/chk/north.bin"
+    south shipPath = shipPath <> "/.urb/chk/south.bin"
+
+    resumeShip = do
+        view pierPathL >>= lockFile
+        rio $ logTrace "RESUMING SHIP"
+        sls <- Pier.resumed playFrom flags
+        rio $ logTrace "SHIP RESUMED"
+        pure sls
+
+runRAcquire :: (MonadUnliftIO (m e),  MonadIO (m e), MonadReader e (m e))
+            => RAcquire e a -> m e a
+runRAcquire act = rwith act pure
+
+--------------------------------------------------------------------------------
+
+checkEvs :: forall e. HasLogFunc e => FilePath -> Word64 -> Word64 -> RIO e ()
+checkEvs pierPath first last = do
+    rwith (Log.existing logPath) $ \log -> do
+        let ident = Log.identity log
+        let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
+        logTrace (displayShow ident)
+
+        last <- Log.lastEv log <&> \lastReal -> min last lastReal
+
+        let evCount = fromIntegral (last - first)
+
+        pb <- PB.newProgressBar pbSty 10 (PB.Progress 1 evCount ())
+
+        runConduit $ Log.streamEvents log first
+                  .| showEvents pb first (fromIntegral $ lifecycleLen ident)
+  where
+    logPath :: FilePath
+    logPath = pierPath <> "/.urb/log"
+
+    showEvents :: PB.ProgressBar () -> EventId -> EventId
+               -> ConduitT ByteString Void (RIO e) ()
+    showEvents pb eId _ | eId > last = pure ()
+    showEvents pb eId cycle          = await >>= \case
+        Nothing -> do
+            lift $ PB.killProgressBar pb
+            lift $ logTrace "Everything checks out."
+        Just bs -> do
+            lift $ PB.incProgress pb 1
+            lift $ do
+                n <- io $ cueBSExn bs
+                when (eId > cycle) $ do
+                    (mug, wen, evNoun) <- unpackJob n
+                    fromNounErr evNoun & \case
+                        Left err       -> logError (displayShow (eId, err))
+                        Right (_ ∷ Ev) -> pure ()
+            showEvents pb (succ eId) cycle
+
+    unpackJob :: Noun -> RIO e (Mug, Wen, Noun)
+    unpackJob = io . fromNounExn
+
+--------------------------------------------------------------------------------
+
+{-|
+    This runs the serf at `$top/.tmpdir`, but we disable snapshots,
+    so this should never actually be created. We just do this to avoid
+    letting the serf use an existing snapshot.
+-}
+collectAllFx :: ∀e. HasLogFunc e => FilePath -> RIO e ()
+collectAllFx top = do
+    logTrace $ display $ pack @Text top
+    rwith collectedFX $ \() ->
+        logTrace "Done collecting effects!"
+  where
+    tmpDir :: FilePath
+    tmpDir = top </> ".tmpdir"
+
+    collectedFX :: RAcquire e ()
+    collectedFX = do
+        lockFile top
+        log  <- Log.existing (top <> "/.urb/log")
+        serf <- Serf.run (Serf.Config tmpDir serfFlags)
+        rio $ Serf.collectFX serf log
+
+    serfFlags :: Serf.Flags
+    serfFlags = [Serf.Hashless, Serf.DryRun]
+
+--------------------------------------------------------------------------------
+
+replayPartEvs :: ∀e. (HasStderrLogFunc e, HasLogFunc e)
+              => FilePath -> Word64 -> RIO e ()
+replayPartEvs top last = do
+    logTrace $ display $ pack @Text top
+    fetchSnapshot
+    rwith replayedEvs $ \() ->
+        logTrace "Done replaying events!"
+  where
+    fetchSnapshot :: RIO e ()
+    fetchSnapshot = do
+      snap <- Pier.getSnapshot top last
+      case snap of
+        Nothing -> pure ()
+        Just sn -> do
+          liftIO $ system $ "cp -r \"" <> sn <> "\" \"" <> tmpDir <> "\""
+          pure ()
+
+    tmpDir :: FilePath
+    tmpDir = top </> ".partial-replay" </> show last
+
+    replayedEvs :: RAcquire e ()
+    replayedEvs = do
+        lockFile top
+        log  <- Log.existing (top <> "/.urb/log")
+        serf <- Serf.run (Serf.Config tmpDir serfFlags)
+        rio $ do
+          ss <- Serf.replay serf log $ Just last
+          Serf.snapshot serf ss
+          io $ threadDelay 500000 -- Copied from runOrExitImmediately
+          pure ()
+
+    serfFlags :: Serf.Flags
+    serfFlags = [Serf.Hashless]
+
+--------------------------------------------------------------------------------
+
+{-|
+    Interesting
+-}
+testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
+testPill pax showPil showSeq = do
+  putStrLn "Reading pill file."
+  pillBytes <- readFile pax
+
+  putStrLn "Cueing pill file."
+  pillNoun <- io $ cueBS pillBytes & either throwIO pure
+
+  putStrLn "Parsing pill file."
+  pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure
+
+  putStrLn "Using pill to generate boot sequence."
+  bootSeq <- generateBootSeq zod pill False (Fake $ Ship 0)
+
+  putStrLn "Validate jam/cue and toNoun/fromNoun on pill value"
+  reJam <- validateNounVal pill
+
+  putStrLn "Checking if round-trip matches input file:"
+  unless (reJam == pillBytes) $ do
+    putStrLn "    Our jam does not match the file...\n"
+    putStrLn "    This is surprising, but it is probably okay."
+
+  when showPil $ do
+      putStrLn "\n\n== Pill ==\n"
+      io $ pPrint pill
+
+  when showSeq $ do
+      putStrLn "\n\n== Boot Sequence ==\n"
+      io $ pPrint bootSeq
+
+validateNounVal :: (HasLogFunc e, Eq a, ToNoun a, FromNoun a)
+                => a -> RIO e ByteString
+validateNounVal inpVal = do
+    putStrLn "  jam"
+    inpByt <- evaluate $ jamBS $ toNoun inpVal
+
+    putStrLn "  cue"
+    outNon <- cueBS inpByt & either throwIO pure
+
+    putStrLn "  fromNoun"
+    outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure
+
+    putStrLn "  toNoun"
+    outNon <- evaluate (toNoun outVal)
+
+    putStrLn "  jam"
+    outByt <- evaluate $ jamBS outNon
+
+    putStrLn "Checking if: x == cue (jam x)"
+    unless (inpVal == outVal) $
+        error "Value fails test: x == cue (jam x)"
+
+    putStrLn "Checking if: jam x == jam (cue (jam x))"
+    unless (inpByt == outByt) $
+        error "Value fails test: jam x == jam (cue (jam x))"
+
+    pure outByt
+
+--------------------------------------------------------------------------------
+
+pillFrom :: CLI.PillSource -> RIO e Pill
+
+pillFrom (CLI.PillSourceFile pillPath) = do
+  putStrLn $ "boot: reading pill from " ++ pack pillPath
+  io (loadFile pillPath >>= either throwIO pure)
+
+pillFrom (CLI.PillSourceURL url) = do
+  putStrLn $ "boot: retrieving pill from " ++ pack url
+  -- Get the jamfile with the list of stars accepting comets right now.
+  manager <- io $ C.newManager tlsManagerSettings
+  request <- io $ C.parseRequest url
+  response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
+  let body = toStrict $ C.responseBody response
+
+  noun <- cueBS body & either throwIO pure
+  fromNounErr noun & either (throwIO . uncurry ParseErr) pure
+
+newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e ()
+newShip CLI.New{..} opts
+  | CLI.BootComet <- nBootType = do
+      pill <- pillFrom nPillSource
+      putStrLn "boot: retrieving list of stars currently accepting comets"
+      starList <- dawnCometList
+      putStrLn ("boot: " ++ (tshow $ length starList) ++
+                " star(s) currently accepting comets")
+      putStrLn "boot: mining a comet"
+      eny <- io $ Sys.randomIO
+      let seed = mineComet (Set.fromList starList) eny
+      putStrLn ("boot: found comet " ++ renderShip (sShip seed))
+      bootFromSeed pill seed
+
+  | CLI.BootFake name <- nBootType = do
+      pill <- pillFrom nPillSource
+      ship <- shipFrom name
+      runTryBootFromPill pill name ship (Fake ship)
+
+  | CLI.BootFromKeyfile keyFile <- nBootType = do
+      text <- readFileUtf8 keyFile
+      asAtom <- case cordToUW (Cord $ T.strip text) of
+        Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
+        Just (UW a) -> pure a
+
+      asNoun <- cueExn asAtom
+      seed :: Seed <- case fromNoun asNoun of
+        Nothing -> error "Keyfile does not seem to contain a seed."
+        Just s  -> pure s
+
+      pill <- pillFrom nPillSource
+
+      bootFromSeed pill seed
+
+  where
+    shipFrom :: Text -> RIO e Ship
+    shipFrom name = case Ob.parsePatp name of
+      Left x  -> error "Invalid ship name"
+      Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
+
+    pierPath :: Text -> FilePath
+    pierPath name = case nPierPath of
+      Just x  -> x
+      Nothing -> "./" <> unpack name
+
+    nameFromShip :: Ship -> RIO e Text
+    nameFromShip s = name
+      where
+        nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
+        name = case stripPrefix "~" nameWithSig of
+          Nothing -> error "Urbit.ob didn't produce string with ~"
+          Just x  -> pure x
+
+    bootFromSeed :: Pill -> Seed -> RIO e ()
+    bootFromSeed pill seed = do
+      ethReturn <- dawnVent seed
+
+      case ethReturn of
+        Left x -> error $ unpack x
+        Right dawn -> do
+          let ship = sShip $ dSeed dawn
+          name <- nameFromShip ship
+          runTryBootFromPill pill name ship (Dawn dawn)
+
+    flags = toSerfFlags opts
+
+    -- Now that we have all the information for running an application with a
+    -- PierConfig, do so.
+    runTryBootFromPill pill name ship bootEvent = do
+      let pierConfig = toPierConfig (pierPath name) opts
+      let networkConfig = toNetworkConfig opts
+      io $ runPierApp pierConfig networkConfig True $
+        tryBootFromPill True pill nLite flags ship bootEvent
+------  tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
+
+
+runShip :: CLI.Run -> CLI.Opts -> Bool -> IO ()
+runShip (CLI.Run pierPath) opts daemon = do
+    tid <- myThreadId
+    let onTermExit = throwTo tid UserInterrupt
+    mStart <- newEmptyMVar
+    if daemon
+    then runPier mStart
+    else do
+      connectionThread <- async $ do
+        readMVar mStart
+        finally (runAppNoLog $ connTerm pierPath) onTermExit
+      finally (runPier mStart) (cancel connectionThread)
+  where
+    runPier mStart =
+          runPierApp pierConfig networkConfig daemon $
+            tryPlayShip
+              (CLI.oExit opts)
+              (CLI.oFullReplay opts)
+              (CLI.oDryFrom opts)
+              (toSerfFlags opts)
+              mStart
+    pierConfig = toPierConfig pierPath opts
+    networkConfig = toNetworkConfig opts
+
+
+startBrowser :: HasLogFunc e => FilePath -> RIO e ()
+startBrowser pierPath = runRAcquire $ do
+    -- lockFile pierPath
+    log <- Log.existing (pierPath <> "/.urb/log")
+    rio $ EventBrowser.run log
+
+checkDawn :: HasLogFunc e => FilePath -> RIO e ()
+checkDawn keyfilePath = do
+  -- The keyfile is a jammed Seed then rendered in UW format
+  text <- readFileUtf8 keyfilePath
+  asAtom <- case cordToUW (Cord $ T.strip text) of
+    Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
+    Just (UW a) -> pure a
+
+  asNoun <- cueExn asAtom
+  seed :: Seed <- case fromNoun asNoun of
+    Nothing -> error "Keyfile does not seem to contain a seed."
+    Just s  -> pure s
+
+  print $ show seed
+
+  e <- dawnVent seed
+  print $ show e
+
+
+checkComet :: HasLogFunc e => RIO e ()
+checkComet = do
+  starList <- dawnCometList
+  putStrLn "Stars currently accepting comets:"
+  let starNames = map (Ob.renderPatp . Ob.patp . fromIntegral) starList
+  print starNames
+  putStrLn "Trying to mine a comet..."
+  eny <- io $ Sys.randomIO
+  let s = mineComet (Set.fromList starList) eny
+  print s
+
+main :: IO ()
+main = do
+    mainTid <- myThreadId
+
+    hSetBuffering stdout NoBuffering
+
+    let onTermSig = throwTo mainTid UserInterrupt
+
+    Sys.installHandler Sys.sigTERM (Sys.Catch onTermSig) Nothing
+
+    CLI.parseArgs >>= \case
+        CLI.CmdRun r o d                        -> runShip r o d
+        CLI.CmdNew n o                          -> runApp $ newShip n o
+        CLI.CmdBug (CLI.CollectAllFX pax)       -> runApp $ collectAllFx pax
+        CLI.CmdBug (CLI.EventBrowser pax)       -> runApp $ startBrowser pax
+        CLI.CmdBug (CLI.ValidatePill pax pil s) -> runApp $ testPill pax pil s
+        CLI.CmdBug (CLI.ValidateEvents pax f l) -> runApp $ checkEvs pax f l
+        CLI.CmdBug (CLI.ValidateFX pax f l)     -> runApp $ checkFx  pax f l
+        CLI.CmdBug (CLI.ReplayEvents pax l)     -> runApp $ replayPartEvs pax l
+        CLI.CmdBug (CLI.CheckDawn pax)          -> runApp $ checkDawn pax
+        CLI.CmdBug CLI.CheckComet               -> runApp $ checkComet
+        CLI.CmdCon pier                         -> runAppLogFile $ connTerm pier
+
+
+--------------------------------------------------------------------------------
+
+connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e ()
+connTerm pier =
+    Term.runTerminalClient pier
+
+--------------------------------------------------------------------------------
+
+checkFx :: HasLogFunc e
+        => FilePath -> Word64 -> Word64 -> RIO e ()
+checkFx pierPath first last =
+    rwith (Log.existing logPath) $ \log ->
+        runConduit $ streamFX log first last
+                  .| tryParseFXStream
+  where
+    logPath = pierPath <> "/.urb/log"
+
+streamFX :: HasLogFunc e
+         => Log.EventLog -> Word64 -> Word64
+         -> ConduitT () ByteString (RIO e) ()
+streamFX log first last = do
+    Log.streamEffectsRows log first .| loop
+  where
+    loop = await >>= \case Nothing                     -> pure ()
+                           Just (eId, bs) | eId > last -> pure ()
+                           Just (eId, bs)              -> yield bs >> loop
+
+tryParseFXStream :: HasLogFunc e => ConduitT ByteString Void (RIO e) ()
+tryParseFXStream = loop
+  where
+    loop = await >>= \case
+        Nothing -> pure ()
+        Just bs -> do
+            n <- liftIO (cueBSExn bs)
+            fromNounErr n & either (logError . displayShow) pure
+            loop
+
+
+{-
+tryCopyLog :: IO ()
+tryCopyLog = do
+  let logPath      = "/Users/erg/src/urbit/zod/.urb/falselog/"
+      falselogPath = "/Users/erg/src/urbit/zod/.urb/falselog2/"
+
+  persistQ <- newTQueueIO
+  releaseQ <- newTQueueIO
+  (ident, nextEv, events) <-
+      with (do { log <- Log.existing logPath
+               ; Pier.runPersist log persistQ (writeTQueue releaseQ)
+               ; pure log
+               })
+        \log -> do
+          ident  <- pure $ Log.identity log
+          events <- runConduit (Log.streamEvents log 1 .| consume)
+          nextEv <- Log.nextEv log
+          pure (ident, nextEv, events)
+
+  print ident
+  print nextEv
+  print (length events)
+
+  persistQ2 <- newTQueueIO
+  releaseQ2 <- newTQueueIO
+  with (do { log <- Log.new falselogPath ident
+           ; Pier.runPersist log persistQ2 (writeTQueue releaseQ2)
+           ; pure log
+           })
+    $ \log2 -> do
+      let writs = zip [1..] events <&> \(id, a) ->
+                      (Writ id Nothing a, [])
+
+      print "About to write"
+
+      for_ writs $ \w ->
+        atomically (writeTQueue persistQ2 w)
+
+      print "About to wait"
+
+      replicateM_ 100 $ do
+        atomically $ readTQueue releaseQ2
+
+      print "Done"
+-}

pkg/hs/urbit-king/lib/Urbit/King/TryJamPill.hs

@@ -0,0 +1,52 @@
+{-|
+    Test jam/cue on pills.
+-}
+module Urbit.King.TryJamPill where
+
+import ClassyPrelude
+import Control.Lens
+import Urbit.Noun
+
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+  print "cue brass" -- void getLine
+  tryCueJamPill Brass
+
+  print "cue ivory" -- void getLine
+  tryCueJamPill Ivory
+
+  print "cue solid" -- void getLine
+  tryCueJamPill Solid
+
+loadNoun :: FilePath -> IO (Maybe Noun)
+loadNoun = fmap (preview _Cue) . readFile
+
+dumpJam :: FilePath -> Noun -> IO ()
+dumpJam fp = writeFile fp . view (re _Cue)
+
+tryCuePill :: PillFile -> IO ()
+tryCuePill pill =
+    loadNoun (show pill) >>= \case Nothing         -> print "nil"
+                                   Just (Atom _)   -> print "atom"
+                                   Just (Cell _ _) -> print "cell"
+
+tryCueJamPill :: PillFile -> IO ()
+tryCueJamPill pill = do
+  n <- loadNoun (show pill) >>= \case
+         Nothing           -> print "failure" >> pure (Atom 0)
+         Just n@(Atom _)   -> print "atom"    >> pure n
+         Just n@(Cell _ _) -> print "cell"    >> pure n
+
+  bs <- evaluate (force (jamBS n))
+
+  print ("jam size: " <> show (length bs))
+
+data PillFile = Brass | Ivory | Solid
+
+instance Show PillFile where
+  show = \case
+    Brass -> "./bin/brass.pill"
+    Solid -> "./bin/solid.pill"
+    Ivory -> "./bin/ivory.pill"

pkg/hs/urbit-king/lib/Urbit/Noun.hs

@@ -0,0 +1,57 @@
+{-|
+    Noun Library
+
+    This module just re-exports things from submodules.
+-}
+module Urbit.Noun
+    ( module Urbit.Atom
+    , module Data.Word
+    , module Urbit.Noun.Conversions
+    , module Urbit.Noun.Convert
+    , module Urbit.Noun.Core
+    , module Urbit.Noun.Cue
+    , module Urbit.Noun.Jam
+    , module Urbit.Noun.Tank
+    , module Urbit.Noun.TH
+    , module Urbit.Noun.Tree
+    , _Cue
+    , LoadErr(..)
+    , loadFile
+    ) where
+
+import ClassyPrelude
+import Control.Lens
+
+import Data.Word
+import Urbit.Atom
+import Urbit.Noun.Conversions
+import Urbit.Noun.Convert
+import Urbit.Noun.Core
+import Urbit.Noun.Cue
+import Urbit.Noun.Jam
+import Urbit.Noun.Tank
+import Urbit.Noun.TH
+import Urbit.Noun.Tree
+
+--------------------------------------------------------------------------------
+
+_Cue :: Prism' ByteString Noun
+_Cue = prism' jamBS (eitherToMaybe . cueBS)
+  where
+    eitherToMaybe (Left _)  = Nothing
+    eitherToMaybe (Right x) = Just x
+
+data LoadErr
+    = FileErr IOException
+    | CueErr DecodeErr
+    | ParseErr [Text] Text
+  deriving (Show)
+
+instance Exception LoadErr
+
+loadFile :: ∀a. FromNoun a => FilePath -> IO (Either LoadErr a)
+loadFile pax = try $ do
+    byt <- try (readFile pax) >>= either (throwIO . FileErr) pure
+    non <- cueBS byt & either (throwIO . CueErr) pure
+    res <- fromNounErr non & either (throwIO . uncurry ParseErr) pure
+    pure res

pkg/hs/urbit-king/lib/Urbit/Noun/Conversions.hs

@@ -0,0 +1,860 @@
+{-|
+    Large Library of conversion between various types and Nouns.
+-}
+
+module Urbit.Noun.Conversions
+  ( Nullable(..), Jammed(..), AtomCell(..)
+  , Word128, Word256, Word512
+  , Bytes(..), Octs(..), File(..)
+  , Cord(..), Knot(..), Term(..), Tape(..), Tour(..)
+  , BigTape(..), BigCord(..)
+  , Wall, Each(..)
+  , UD(..), UV(..), UW(..), cordToUW
+  , Mug(..), Path(..), EvilPath(..), Ship(..)
+  , Lenient(..), pathToFilePath, filePathToPath
+  ) where
+
+import ClassyPrelude hiding (hash)
+
+import Control.Lens         hiding (Each, Index, (<.>))
+import Data.Void
+import Data.Word
+import Text.Regex.TDFA
+import Text.Regex.TDFA.Text ()
+import Urbit.Atom
+import Urbit.Noun.Convert
+import Urbit.Noun.Core
+import Urbit.Noun.TH
+
+import Data.LargeWord   (LargeKey, Word128, Word256)
+import GHC.Exts         (chr#, isTrue#, leWord#, word2Int#)
+import GHC.Natural      (Natural)
+import GHC.Types        (Char(C#))
+import GHC.Word         (Word32(W32#))
+import Prelude          ((!!))
+import RIO.FilePath     (joinPath, splitDirectories, takeBaseName,
+                         takeDirectory, takeExtension, (<.>))
+import Urbit.Noun.Cue   (cue)
+import Urbit.Noun.Jam   (jam)
+
+import qualified Data.Char                as C
+import qualified Data.Text.Encoding       as T
+
+
+-- Noun ------------------------------------------------------------------------
+
+instance ToNoun Noun where
+  toNoun = id
+
+instance FromNoun Noun where
+  parseNoun = pure
+
+
+--- Atom -----------------------------------------------------------------------
+
+instance ToNoun Atom where
+  toNoun = Atom
+
+instance FromNoun Atom where
+  parseNoun = named "Atom" . \case
+    Atom a   -> pure a
+    Cell _ _ -> fail "Expecting an atom, but got a cell"
+
+
+-- Void ------------------------------------------------------------------------
+
+instance ToNoun Void where
+  toNoun = absurd
+
+instance FromNoun Void where
+  parseNoun _ = named "Void" $ fail "Can't produce void"
+
+
+-- Cord ------------------------------------------------------------------------
+
+newtype Cord = Cord { unCord :: Text }
+  deriving newtype (Eq, Ord, Show, IsString, NFData)
+
+instance ToNoun Cord where
+  toNoun = textToUtf8Atom . unCord
+
+instance FromNoun Cord where
+  parseNoun = named "Cord" . fmap Cord . parseNounUtf8Atom
+
+
+-- Decimal Cords ---------------------------------------------------------------
+
+newtype UD = UD { unUD :: Word }
+  deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num)
+
+instance ToNoun UD where
+  toNoun = toNoun . Cord . tshow . unUD
+
+instance FromNoun UD where
+  parseNoun n = named "UD" do
+    Cord t <- parseNoun n
+    readMay t & \case
+      Nothing -> fail ("invalid decimal atom: " <> unpack (filter (/= '.') t))
+      Just vl -> pure (UD vl)
+
+
+--------------------------------------------------------------------------------
+
+uTypeAddDots :: String -> String
+uTypeAddDots = reverse . go . reverse
+  where
+    go s = if null tel then hed
+                       else hed <> "." <> go tel
+      where
+        hed = take 5 s
+        tel = drop 5 s
+
+convertToU :: [Char] -> [Char] -> Atom -> String
+convertToU baseMap prefix = go []
+  where
+    go acc 0 = "0" <> prefix <> uTypeAddDots acc
+    go acc n = go (char n : acc) (n `div` len)
+
+    char n = baseMap !! (fromIntegral (n `mod` len))
+
+    len = fromIntegral (length baseMap)
+
+convertFromU :: (Char -> Maybe Atom) -> Char -> Atom -> String -> Maybe Atom
+convertFromU fetch prefix length = \case
+    ('0':prefix:cs) -> go (0, 0) (reverse cs)
+    _               -> Nothing
+  where
+    go (i, acc) []         = pure acc
+    go (i, acc) ('.' : cs) = go (i, acc) cs
+    go (i, acc) (c   : cs) = do
+        n <- fetch c
+        go (i+1, acc+(length^i)*n) cs
+
+
+-- @uv
+newtype UV = UV { unUV :: Atom }
+  deriving newtype (Eq, Ord, Show, Num, Enum, Real, Integral)
+
+instance ToNoun UV where
+    toNoun = toNoun . Cord . pack . toUV . fromIntegral . unUV
+
+instance FromNoun UV where
+    parseNoun n = do
+      Cord c <- parseNoun n
+      case fromUV $ unpack c of
+        Nothing -> fail ("Invalid @uv: " <> unpack c)
+        Just uv -> pure (UV uv)
+
+fromUV :: String -> Maybe Atom
+fromUV = convertFromU uvCharNum 'v' (fromIntegral $ length base32Chars)
+
+toUV :: Atom -> String
+toUV = convertToU base32Chars "v"
+
+base32Chars :: [Char]
+base32Chars = (['0'..'9'] <> ['a'..'v'])
+
+uvCharNum :: Char -> Maybe Atom
+uvCharNum = \case
+  '0' -> pure 0
+  '1' -> pure 1
+  '2' -> pure 2
+  '3' -> pure 3
+  '4' -> pure 4
+  '5' -> pure 5
+  '6' -> pure 6
+  '7' -> pure 7
+  '8' -> pure 8
+  '9' -> pure 9
+  'a' -> pure 10
+  'b' -> pure 11
+  'c' -> pure 12
+  'd' -> pure 13
+  'e' -> pure 14
+  'f' -> pure 15
+  'g' -> pure 16
+  'h' -> pure 17
+  'i' -> pure 18
+  'j' -> pure 19
+  'k' -> pure 20
+  'l' -> pure 21
+  'm' -> pure 22
+  'n' -> pure 23
+  'o' -> pure 24
+  'p' -> pure 25
+  'q' -> pure 26
+  'r' -> pure 27
+  's' -> pure 28
+  't' -> pure 29
+  'u' -> pure 30
+  'v' -> pure 31
+  _   -> Nothing
+
+--------------------------------------------------------------------------------
+
+-- @uw
+newtype UW = UW { unUW :: Atom }
+  deriving newtype (Eq, Ord, Show, Num, Enum, Real, Integral)
+
+instance ToNoun UW where
+  toNoun = toNoun . Cord . pack . toUW . fromIntegral . unUW
+
+instance FromNoun UW where
+  parseNoun n = do
+    Cord c <- parseNoun n
+    case fromUW $ unpack c of
+      Nothing -> fail ("Invalid @uw: " <> unpack c)
+      Just uw -> pure (UW uw)
+
+fromUW :: String -> Maybe Atom
+fromUW = convertFromU uwCharNum 'w' (fromIntegral $ length base64Chars)
+
+toUW :: Atom -> String
+toUW = convertToU base64Chars "w"
+
+base64Chars :: [Char]
+base64Chars = (['0'..'9'] <> ['a'..'z'] <> ['A'..'Z'] <> ['-', '~'])
+
+uwCharNum :: Char -> Maybe Atom
+uwCharNum = \case
+  '0' -> pure 0
+  '1' -> pure 1
+  '2' -> pure 2
+  '3' -> pure 3
+  '4' -> pure 4
+  '5' -> pure 5
+  '6' -> pure 6
+  '7' -> pure 7
+  '8' -> pure 8
+  '9' -> pure 9
+  'a' -> pure 10
+  'b' -> pure 11
+  'c' -> pure 12
+  'd' -> pure 13
+  'e' -> pure 14
+  'f' -> pure 15
+  'g' -> pure 16
+  'h' -> pure 17
+  'i' -> pure 18
+  'j' -> pure 19
+  'k' -> pure 20
+  'l' -> pure 21
+  'm' -> pure 22
+  'n' -> pure 23
+  'o' -> pure 24
+  'p' -> pure 25
+  'q' -> pure 26
+  'r' -> pure 27
+  's' -> pure 28
+  't' -> pure 29
+  'u' -> pure 30
+  'v' -> pure 31
+  'w' -> pure 32
+  'x' -> pure 33
+  'y' -> pure 34
+  'z' -> pure 35
+  'A' -> pure 36
+  'B' -> pure 37
+  'C' -> pure 38
+  'D' -> pure 39
+  'E' -> pure 40
+  'F' -> pure 41
+  'G' -> pure 42
+  'H' -> pure 43
+  'I' -> pure 44
+  'J' -> pure 45
+  'K' -> pure 46
+  'L' -> pure 47
+  'M' -> pure 48
+  'N' -> pure 49
+  'O' -> pure 50
+  'P' -> pure 51
+  'Q' -> pure 52
+  'R' -> pure 53
+  'S' -> pure 54
+  'T' -> pure 55
+  'U' -> pure 56
+  'V' -> pure 57
+  'W' -> pure 58
+  'X' -> pure 59
+  'Y' -> pure 60
+  'Z' -> pure 61
+  '-' -> pure 62
+  '~' -> pure 63
+  _   -> Nothing
+
+-- Maybe parses the underlying atom value from a text printed in UW format.
+cordToUW :: Cord -> Maybe UW
+cordToUW = fromNoun . toNoun
+
+-- Char ------------------------------------------------------------------------
+
+instance ToNoun Char where
+  toNoun = Atom . fromIntegral . C.ord
+
+{-
+    Hack: pulled this logic from Data.Char impl.
+-}
+instance FromNoun Char where
+  parseNoun n = named "Char" $ do
+    W32# w :: Word32 <- parseNoun n
+    if isTrue# (w `leWord#` 0x10FFFF##)
+      then pure (C# (chr# (word2Int# w)))
+      else fail "Word is not a valid character."
+
+
+-- Tour ------------------------------------------------------------------------
+
+newtype Tour = Tour [Char]
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
+
+
+-- Double Jammed ---------------------------------------------------------------
+
+newtype Jammed a = Jammed a
+  deriving (Eq, Ord, Show)
+
+instance ToNoun a => ToNoun (Jammed a) where
+  toNoun (Jammed a) = Atom $ jam $ toNoun a
+
+instance FromNoun a => FromNoun (Jammed a) where
+  parseNoun n = named "Jammed" $ do
+    a <- parseNoun n
+    cue a & \case
+      Left err  -> fail (show err)
+      Right res -> do
+        Jammed <$> parseNoun res
+
+
+-- Atom or Cell ----------------------------------------------------------------
+
+type Word512 = LargeKey Word256 Word256
+
+data AtomCell a c
+    = ACAtom a
+    | ACCell c
+  deriving (Eq, Ord, Show)
+
+instance (ToNoun a, ToNoun c) => ToNoun (AtomCell a c) where
+  toNoun (ACAtom a) = toNoun a
+  toNoun (ACCell c) = toNoun c
+
+instance (FromNoun a, FromNoun c) => FromNoun (AtomCell a c) where
+  parseNoun n = named "(,)" $ case n of
+                                Atom _   -> ACAtom <$> parseNoun n
+                                Cell _ _ -> ACCell <$> parseNoun n
+
+
+-- Lenient ---------------------------------------------------------------------
+
+data Lenient a
+    = FailParse Noun
+    | GoodParse a
+  deriving (Eq, Ord, Show)
+
+instance FromNoun a => FromNoun (Lenient a) where
+  parseNoun n =
+      (GoodParse <$> parseNoun n) <|> fallback
+    where
+      fallback =
+        fromNounErr n & \case
+          Right x  -> pure (GoodParse x)
+          Left err -> do
+            -- traceM ("LENIENT.FromNoun: " <> show err)
+            -- traceM (ppShow n)
+            pure (FailParse n)
+
+instance ToNoun a => ToNoun (Lenient a) where
+  toNoun (FailParse n) = n -- trace ("LENIENT.ToNoun: " <> show n)
+  toNoun (GoodParse x) = toNoun x
+
+
+-- Todo -- Debugging Hack ------------------------------------------------------
+
+newtype Todo a = Todo a
+  deriving newtype (Eq, Ord, ToNoun)
+
+instance Show (Todo a) where
+  show (Todo _) = "TODO"
+
+instance FromNoun a => FromNoun (Todo a) where
+  parseNoun n = do
+      fromNounErr n & \case
+        Right x -> pure (Todo x)
+        Left er -> fail (show er)
+          -- traceM ("[TODO]: " <> show er <> "\n" <> ppShow n <> "\n")
+
+
+-- Nullable --------------------------------------------------------------------
+
+{-|
+    `Nullable a <-> ?@(~ a)`
+
+    This is distinct from `unit`, since there is no tag on the non-atom
+    case, therefore `a` must always be cell type.
+-}
+data Nullable a = None | Some a
+  deriving (Eq, Ord, Show)
+
+instance ToNoun a => ToNoun (Nullable a) where
+  toNoun = toNoun . \case None   -> ACAtom ()
+                          Some x -> ACCell x
+
+instance FromNoun a => FromNoun (Nullable a) where
+  parseNoun n = named "Nullable" $ do
+    parseNoun n >>= \case
+      (ACAtom ()) -> pure None
+      (ACCell x)  -> pure (Some x)
+
+
+-- List ------------------------------------------------------------------------
+
+instance ToNoun a => ToNoun [a] where
+  toNoun xs = nounFromList (toNoun <$> xs)
+    where
+      nounFromList :: [Noun] -> Noun
+      nounFromList []     = Atom 0
+      nounFromList (x:xs) = Cell x (nounFromList xs)
+
+instance FromNoun a => FromNoun [a] where
+  parseNoun = named "[]" . \case
+      Atom 0   -> pure []
+      Atom _   -> fail "list terminated with non-null atom"
+      Cell l r -> (:) <$> parseNoun l <*> parseNoun r
+
+
+-- Tape ------------------------------------------------------------------------
+
+{-
+    A `tape` is a list of utf8 bytes.
+-}
+newtype Tape = Tape { unTape :: Text }
+  deriving newtype (Eq, Ord, Show, Semigroup, Monoid, IsString)
+
+instance ToNoun Tape where
+  toNoun = toNoun . (unpack :: ByteString -> [Word8]) . encodeUtf8 . unTape
+
+instance FromNoun Tape where
+  parseNoun n = named "Tape" $ do
+    as :: [Word8] <- parseNoun n
+    T.decodeUtf8' (pack as) & \case
+        Left err -> fail (show err)
+        Right tx -> pure (Tape tx)
+
+
+-- Wall -- Text Lines ----------------------------------------------------------
+
+type Wall = [Tape]
+
+
+-- Big Cord -- Don't Print -----------------------------------------------------
+
+newtype BigCord = BigCord Cord
+  deriving newtype (Eq, Ord, ToNoun, FromNoun, IsString)
+
+instance Show BigCord where
+  show (BigCord (Cord t)) = show (take 32 t <> "...")
+
+
+-- Big Tape -- Don't Print -----------------------------------------------------
+
+newtype BigTape = BigTape Tape
+  deriving newtype (Eq, Ord, ToNoun, FromNoun, IsString)
+
+instance Show BigTape where
+  show (BigTape (Tape t)) = show (take 32 t <> "...")
+
+
+-- Bytes -----------------------------------------------------------------------
+
+newtype Bytes = MkBytes { unBytes :: ByteString }
+  deriving newtype (Eq, Ord, Show)
+
+instance ToNoun Bytes where
+    toNoun = Atom . bytesAtom . unBytes
+
+instance FromNoun Bytes where
+    parseNoun = named "Bytes" . fmap (MkBytes . atomBytes) . parseNoun
+
+
+-- Octs ------------------------------------------------------------------------
+
+newtype Octs = Octs { unOcts :: ByteString }
+  deriving newtype (Eq, Ord, Show, IsString)
+
+instance ToNoun Octs where
+  toNoun (Octs bs) =
+      toNoun (int2Word (length bs), bytesAtom bs)
+    where
+      int2Word :: Int -> Word
+      int2Word = fromIntegral
+
+instance FromNoun Octs where
+    parseNoun x = named "Octs" $ do
+        (word2Int -> len, atom) <- parseNoun x
+        let bs = atomBytes atom
+        pure $ Octs $ case compare (length bs) len of
+          EQ -> bs
+          LT -> bs <> replicate (len - length bs) 0
+          GT -> take len bs
+      where
+        word2Int :: Word -> Int
+        word2Int = fromIntegral
+
+
+-- File Contents -- Don't Print ------------------------------------------------
+
+newtype File = File { unFile :: Octs }
+  deriving newtype (Eq, Ord, IsString, ToNoun, FromNoun)
+
+instance Show File where
+  show (File (Octs bs)) = show (take 32 bs <> "...")
+
+
+-- Knot ------------------------------------------------------------------------
+
+{-
+    Knot (@ta) is an array of Word8 encoding an ASCII string.
+-}
+newtype Knot = MkKnot { unKnot :: Text }
+  deriving newtype (Eq, Ord, Show, Semigroup, Monoid, IsString)
+
+instance ToNoun Knot where
+  toNoun = textToUtf8Atom . unKnot
+
+instance FromNoun Knot where
+  parseNoun n = named "Knot" $ do
+    txt <- parseNounUtf8Atom n
+    if all C.isAscii txt
+      then pure (MkKnot txt)
+      else fail ("Non-ASCII chars in knot: " <> unpack txt)
+
+
+-- Term ------------------------------------------------------------------------
+
+{-
+    A Term (@tas) is a Knot satisfying the regular expression:
+
+        ([a-z][a-z0-9]*(-[a-z0-9]+)*)?
+-}
+newtype Term = MkTerm { unTerm :: Text }
+  deriving newtype (Eq, Ord, Show, Semigroup, Monoid, IsString)
+
+instance ToNoun Term where -- XX TODO
+  toNoun = textToUtf8Atom . unTerm
+
+knotRegex :: Text
+knotRegex = "([a-z][a-z0-9]*(-[a-z0-9]+)*)?"
+
+instance FromNoun Term where -- XX TODO
+  parseNoun n = named "Term" $ do
+    MkKnot t <- parseNoun n
+    if t =~ knotRegex
+      then pure (MkTerm t)
+      else fail ("Term not valid symbol: " <> unpack t)
+
+
+-- Ship ------------------------------------------------------------------------
+
+newtype Ship = Ship Word128 -- @p
+  deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
+
+
+-- Path ------------------------------------------------------------------------
+
+newtype Path = Path { unPath :: [Knot] }
+  deriving newtype (Eq, Ord, Semigroup, Monoid)
+
+instance Show Path where
+  show = show . intercalate "/" . ("":) . unPath
+
+newtype EvilPath = EvilPath { unEvilPath :: [Atom] }
+  deriving newtype (Eq, Ord, Semigroup, Monoid)
+
+instance Show EvilPath where
+  show = show . unEvilPath
+
+pathToFilePath :: Path -> FilePath
+pathToFilePath p = joinPath components
+  where
+    elements :: [String] = map (unpack . unKnot) (unPath p)
+    components = case reverse elements of
+      [] -> []
+      [p] -> [p]
+      (ext : fname : dirs) -> (reverse dirs) <> [(fname <.> ext)]
+
+-- Takes a filepath and converts it to a clay path, changing the '.' to a '/'
+-- and removing any prefixed '/'.
+filePathToPath :: FilePath -> Path
+filePathToPath fp = Path path
+  where
+    path = map (MkKnot . pack) (dir ++ file)
+    dir = case (splitDirectories $ (takeDirectory fp)) of
+      ["."]    -> []
+      ("/":xs) -> xs
+      x        -> x
+    file = if ext /= "" then [takeBaseName fp, ext] else [takeBaseName fp]
+    ext = case takeExtension fp of
+      ('.':xs) -> xs
+      x        -> x
+
+-- Mug -------------------------------------------------------------------------
+
+newtype Mug = Mug Word32
+  deriving newtype (Eq, Ord, Show, Num, ToNoun, FromNoun)
+
+
+-- Bool ------------------------------------------------------------------------
+
+instance ToNoun Bool where
+  toNoun True  = Atom 0
+  toNoun False = Atom 1
+
+instance FromNoun Bool where
+  parseNoun = named "Bool" . parse
+    where
+      parse n =
+        parseNoun n >>= \case
+          (0::Atom) -> pure True
+          1         -> pure False
+          _         -> fail "Atom is not a valid loobean"
+
+
+-- Integer ---------------------------------------------------------------------
+
+instance ToNoun Integer where
+    toNoun = toNoun . (fromIntegral :: Integer -> Natural)
+
+instance FromNoun Integer where
+    parseNoun = named "Integer" . fmap natInt . parseNoun
+      where
+        natInt :: Natural -> Integer
+        natInt = fromIntegral
+
+
+-- Words -----------------------------------------------------------------------
+
+atomToWord :: forall a. (Bounded a, Integral a) => Atom -> Parser a
+atomToWord atom = do
+  if atom > fromIntegral (maxBound :: a)
+  then fail "Atom doesn't fit in fixed-size word"
+  else pure (fromIntegral atom)
+
+wordToNoun :: Integral a => a -> Noun
+wordToNoun = Atom . fromIntegral
+
+nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a
+nounToWord = parseNoun >=> atomToWord
+
+instance ToNoun Word    where toNoun = wordToNoun
+instance ToNoun Word8   where toNoun = wordToNoun
+instance ToNoun Word16  where toNoun = wordToNoun
+instance ToNoun Word32  where toNoun = wordToNoun
+instance ToNoun Word64  where toNoun = wordToNoun
+instance ToNoun Word128 where toNoun = wordToNoun
+instance ToNoun Word256 where toNoun = wordToNoun
+instance ToNoun Word512 where toNoun = wordToNoun
+
+instance FromNoun Word    where parseNoun = named "Word"    . nounToWord
+instance FromNoun Word8   where parseNoun = named "Word8"   . nounToWord
+instance FromNoun Word16  where parseNoun = named "Word16"  . nounToWord
+instance FromNoun Word32  where parseNoun = named "Word32"  . nounToWord
+instance FromNoun Word64  where parseNoun = named "Word64"  . nounToWord
+instance FromNoun Word128 where parseNoun = named "Word128" . nounToWord
+instance FromNoun Word256 where parseNoun = named "Word256" . nounToWord
+instance FromNoun Word512 where parseNoun = named "Word512" . nounToWord
+
+
+-- Maybe is `unit` -------------------------------------------------------------
+
+-- TODO Consider enforcing that `a` must be a cell.
+instance ToNoun a => ToNoun (Maybe a) where
+  toNoun Nothing  = Atom 0
+  toNoun (Just x) = Cell (Atom 0) (toNoun x)
+
+instance FromNoun a => FromNoun (Maybe a) where
+  parseNoun = named "Maybe" . \case
+      Atom          0   -> pure Nothing
+      Atom          n   -> unexpected ("atom " <> show n)
+      Cell (Atom 0) t   -> Just <$> parseNoun t
+      Cell n        _   -> unexpected ("cell with head-atom " <> show n)
+    where
+      unexpected s = fail ("Expected unit value, but got " <> s)
+
+-- Each is a direct translation of Hoon +each, preserving order
+data Each a b
+    = EachYes a
+    | EachNo b
+  deriving (Eq, Ord, Show)
+
+instance (ToNoun a, ToNoun b) => ToNoun (Each a b) where
+    toNoun (EachYes x) = C (A 0) (toNoun x)
+    toNoun (EachNo x)  = C (A 1) (toNoun x)
+
+instance (FromNoun a, FromNoun b) => FromNoun (Each a b) where
+    parseNoun n = named "Each" $ do
+        (Atom tag, v) <- parseNoun n
+        case tag of
+            0 -> named "&" (EachYes <$> parseNoun v)
+            1 -> named "|" (EachNo <$> parseNoun v)
+            n -> fail ("Each has invalid head-atom: " <> show n)
+
+-- Tuple Conversions -----------------------------------------------------------
+
+instance ToNoun () where
+    toNoun () = Atom 0
+
+instance FromNoun () where
+    parseNoun = named "()" . \case
+        Atom 0 -> pure ()
+        x      -> fail ("expecting `~`, but got " <> show x)
+
+instance (ToNoun a, ToNoun b) => ToNoun (a, b) where
+    toNoun (x, y) = Cell (toNoun x) (toNoun y)
+
+
+shortRec :: Word -> Parser a
+shortRec 0 = fail "expected a record, but got an atom"
+shortRec 1 = fail ("record too short, only one cell")
+shortRec n = fail ("record too short, only " <> show n <> " cells")
+
+instance (FromNoun a, FromNoun b) => FromNoun (a, b) where
+  parseNoun n = named ("(,)") $ do
+    case n of
+      A _   -> shortRec 0
+      C x y -> do
+        (,) <$> named "1" (parseNoun x)
+            <*> named "2" (parseNoun y)
+
+instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where
+  toNoun (x, y, z) = toNoun (x, (y, z))
+
+instance (FromNoun a, FromNoun b, FromNoun c) => FromNoun (a, b, c) where
+  parseNoun n = named "(,,)" $ do
+    case n of
+      A _         -> shortRec 0
+      C x (A _)   -> shortRec 1
+      C x (C y z) ->
+        (,,) <$> named "1" (parseNoun x)
+             <*> named "2" (parseNoun y)
+             <*> named "3" (parseNoun z)
+
+instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where
+  toNoun (p, q, r, s) = toNoun (p, (q, r, s))
+
+instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d)
+      => FromNoun (a, b, c, d)
+      where
+  parseNoun n = named "(,,,)" $ do
+    case n of
+      A _               -> shortRec 0
+      C _ (A _)         -> shortRec 1
+      C _ (C _ (A _))   -> shortRec 2
+      C p (C q (C r s)) ->
+        (,,,) <$> named "1" (parseNoun p)
+              <*> named "2" (parseNoun q)
+              <*> named "3" (parseNoun r)
+              <*> named "4" (parseNoun s)
+
+instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e)
+      => ToNoun (a, b, c, d, e) where
+  toNoun (p, q, r, s, t) = toNoun (p, (q, r, s, t))
+
+instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e)
+      => FromNoun (a, b, c, d, e)
+      where
+  parseNoun n = named "(,,,,)" $ do
+    case n of
+      A _                     -> shortRec 0
+      C _ (A _)               -> shortRec 1
+      C _ (C _ (A _))         -> shortRec 2
+      C _ (C _ (C _ (A _)))   -> shortRec 3
+      C p (C q (C r (C s t))) ->
+        (,,,,) <$> named "1" (parseNoun p)
+               <*> named "2" (parseNoun q)
+               <*> named "3" (parseNoun r)
+               <*> named "4" (parseNoun s)
+               <*> named "5" (parseNoun t)
+
+instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f)
+      => ToNoun (a, b, c, d, e, f) where
+  toNoun (p, q, r, s, t, u) = toNoun (p, (q, r, s, t, u))
+
+instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
+         , FromNoun f
+         )
+      => FromNoun (a, b, c, d, e, f)
+      where
+  parseNoun n = named "(,,,,,)" $ do
+    (p, tail)       <- parseNoun n
+    (q, r, s, t, u) <- parseNoun tail
+    pure (p, q, r, s, t, u)
+
+instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f, ToNoun g)
+      => ToNoun (a, b, c, d, e, f, g) where
+  toNoun (p, q, r, s, t, u, v) = toNoun (p, (q, r, s, t, u, v))
+
+instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
+         , FromNoun f, FromNoun g
+         )
+      => FromNoun (a, b, c, d, e, f, g)
+      where
+  parseNoun n = named "(,,,,,,)" $ do
+    (p, tail)          <- parseNoun n
+    (q, r, s, t, u, v) <- parseNoun tail
+    pure (p, q, r, s, t, u, v)
+
+instance ( ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f, ToNoun g
+         , ToNoun h
+         )
+      => ToNoun (a, b, c, d, e, f, g, h) where
+  toNoun (p, q, r, s, t, u, v, w) = toNoun (p, (q, r, s, t, u, v, w))
+
+instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
+         , FromNoun f, FromNoun g, FromNoun h
+         )
+      => FromNoun (a, b, c, d, e, f, g, h)
+      where
+  parseNoun n = named "(,,,,,,,)" $ do
+    (p, tail)             <- parseNoun n
+    (q, r, s, t, u, v, w) <- parseNoun tail
+    pure (p, q, r, s, t, u, v, w)
+
+instance ( ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f, ToNoun g
+         , ToNoun h, ToNoun i
+         )
+      => ToNoun (a, b, c, d, e, f, g, h, i) where
+  toNoun (p, q, r, s, t, u, v, w, x) = toNoun (p, (q, r, s, t, u, v, w, x))
+
+instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
+         , FromNoun f, FromNoun g, FromNoun h, FromNoun i
+         )
+      => FromNoun (a, b, c, d, e, f, g, h, i)
+      where
+  parseNoun n = named "(,,,,,,,,)" $ do
+    (p, tail)                <- parseNoun n
+    (q, r, s, t, u, v, w, x) <- parseNoun tail
+    pure (p, q, r, s, t, u, v, w, x)
+
+instance ( ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f, ToNoun g
+         , ToNoun h, ToNoun i, ToNoun j
+         )
+      => ToNoun (a, b, c, d, e, f, g, h, i, j) where
+  toNoun (p, q, r, s, t, u, v, w, x, y) =
+    toNoun (p, (q, r, s, t, u, v, w, x, y))
+
+instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
+         , FromNoun f, FromNoun g, FromNoun h, FromNoun i, FromNoun j
+         )
+      => FromNoun (a, b, c, d, e, f, g, h, i, j)
+      where
+  parseNoun n = named "(,,,,,,,,,)" $ do
+    (p, tail)                   <- parseNoun n
+    (q, r, s, t, u, v, w, x, y) <- parseNoun tail
+    pure (p, q, r, s, t, u, v, w, x, y)
+
+
+-- Ugg -------------------------------------------------------------------------
+
+deriveNoun ''Path
+deriveNoun ''EvilPath

pkg/hs/urbit-king/lib/Urbit/Noun/Convert.hs

@@ -0,0 +1,199 @@
+{-|
+    Framework for writing conversions between types and nouns.
+-}
+module Urbit.Noun.Convert
+    ( ToNoun(toNoun)
+    , FromNoun(parseNoun), fromNoun, fromNounErr, fromNounExn
+    , Parser(..)
+    , ParseStack
+    , parseNounUtf8Atom
+    , named
+    ) where
+
+import ClassyPrelude hiding (hash)
+
+import Urbit.Noun.Core
+
+import qualified Control.Monad.Fail as Fail
+
+
+-- Types -----------------------------------------------------------------------
+
+type ParseStack = [Text]
+
+
+-- IResult ---------------------------------------------------------------------
+
+data IResult a = IError ParseStack String | ISuccess a
+  deriving (Eq, Show, Typeable, Functor, Foldable, Traversable)
+
+instance Applicative IResult where
+    pure  = ISuccess
+    (<*>) = ap
+
+instance Fail.MonadFail IResult where
+    fail err = IError [] err
+
+instance Monad IResult where
+    return = pure
+    fail   = Fail.fail
+    ISuccess a      >>= k = k a
+    IError path err >>= _ = IError path err
+
+instance MonadPlus IResult where
+    mzero = fail "mzero"
+    mplus a@(ISuccess _) _ = a
+    mplus _ b              = b
+
+instance Alternative IResult where
+    empty = mzero
+    (<|>) = mplus
+
+instance Semigroup (IResult a) where
+    (<>) = mplus
+
+instance Monoid (IResult a) where
+    mempty  = fail "mempty"
+    mappend = (<>)
+
+
+-- Result ----------------------------------------------------------------------
+
+data Result a = Error String | Success a
+  deriving (Eq, Show, Typeable, Functor, Foldable, Traversable)
+
+instance Applicative Result where
+    pure  = Success
+    (<*>) = ap
+
+instance Fail.MonadFail Result where
+    fail err = Error err
+
+instance Monad Result where
+    return = pure
+    fail   = Fail.fail
+
+    Success a >>= k = k a
+    Error err >>= _ = Error err
+
+instance MonadPlus Result where
+    mzero = fail "mzero"
+    mplus a@(Success _) _ = a
+    mplus _ b             = b
+
+instance Alternative Result where
+    empty = mzero
+    (<|>) = mplus
+
+instance Semigroup (Result a) where
+    (<>) = mplus
+    {-# INLINE (<>) #-}
+
+instance Monoid (Result a) where
+    mempty  = fail "mempty"
+    mappend = (<>)
+
+
+-- "Parser" --------------------------------------------------------------------
+
+type Failure f r   = ParseStack -> String -> f r
+type Success a f r = a -> f r
+
+newtype Parser a = Parser {
+  runParser :: forall f r.  ParseStack -> Failure f r -> Success a f r -> f r
+}
+
+named :: Text -> Parser a -> Parser a
+named nm (Parser cb) =
+    Parser $ \path kf ks -> cb (nm:path) kf ks
+
+instance Monad Parser where
+    m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks
+                                       in runParser m path kf ks'
+    return = pure
+    fail = Fail.fail
+
+instance Fail.MonadFail Parser where
+    fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
+
+instance Functor Parser where
+    fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a)
+                                        in runParser m path kf ks'
+
+apP :: Parser (a -> b) -> Parser a -> Parser b
+apP d e = do
+  b <- d
+  b <$> e
+
+instance Applicative Parser where
+    pure a = Parser $ \_path _kf ks -> ks a
+    (<*>) = apP
+
+instance Alternative Parser where
+    empty = fail "empty"
+    (<|>) = mplus
+
+instance MonadPlus Parser where
+    mzero = fail "mzero"
+    mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks
+                                         in runParser a path kf' ks
+
+instance Semigroup (Parser a) where
+    (<>) = mplus
+
+instance Monoid (Parser a) where
+    mempty  = fail "mempty"
+    mappend = (<>)
+
+
+-- Conversion ------------------------------------------------------------------
+
+class FromNoun a where
+  parseNoun :: Noun -> Parser a
+
+class ToNoun a where
+  toNoun :: a -> Noun
+
+--------------------------------------------------------------------------------
+
+fromNoun :: FromNoun a => Noun -> Maybe a
+fromNoun n = runParser (parseNoun n) [] onFail onSuccess
+  where
+    onFail p m  = Nothing
+    onSuccess x = Just x
+
+fromNounErr :: FromNoun a => Noun -> Either ([Text], Text) a
+fromNounErr n = runParser (parseNoun n) [] onFail onSuccess
+  where
+    onFail p m  = Left (p, pack m)
+    onSuccess x = Right x
+
+data BadNoun = BadNoun [Text] String
+  deriving (Eq, Ord)
+
+instance Show BadNoun where
+  show (BadNoun pax msg) =
+    mconcat [ "(BadNoun "
+            , show (intercalate "." pax)
+            , " "
+            , show msg
+            , ")"
+            ]
+
+instance Exception BadNoun where
+
+fromNounExn :: MonadIO m => FromNoun a => Noun -> m a
+fromNounExn n = runParser (parseNoun n) [] onFail onSuccess
+  where
+    onFail p m  = throwIO (BadNoun p m)
+    onSuccess x = pure x
+
+
+-- Cord Conversions ------------------------------------------------------------
+
+parseNounUtf8Atom :: Noun -> Parser Text
+parseNounUtf8Atom n =
+    named "utf8-atom" $ do
+      case utf8AtomToText n of
+        Left err -> fail (unpack err)
+        Right tx -> pure tx

pkg/hs/urbit-king/lib/Urbit/Noun/Core.hs

@@ -0,0 +1,171 @@
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+{-# LANGUAGE Strict     #-}
+{-# LANGUAGE StrictData #-}
+
+{-|
+    Core Noun Implementation
+
+    Each cell has a pre-calculated hash and a `size` field. The size is
+    the total number of nodes under the tree of the cell. This is used
+    as a heuristic to choose a hash-table size for `jam` and `cue`.
+-}
+module Urbit.Noun.Core
+  ( Noun, nounSize
+  , pattern Cell, pattern Atom
+  , pattern C, pattern A
+  , textToUtf8Atom, utf8AtomToText
+  ) where
+
+import ClassyPrelude hiding (hash)
+
+import Urbit.Atom
+
+import Data.Bits                 (xor)
+import Data.Function             ((&))
+import Data.Hashable             (hash)
+import GHC.Natural               (Natural)
+import GHC.Prim                  (reallyUnsafePtrEquality#)
+import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary))
+import Test.QuickCheck.Gen       (Gen, getSize, resize, scale)
+
+import qualified Data.Char as C
+
+
+-- Types -----------------------------------------------------------------------
+
+data Noun
+    = NCell Int Word Noun Noun
+    | NAtom Int Atom
+
+pattern Cell x y <- NCell _ _ x y where Cell = mkCell
+pattern Atom a   <- NAtom _ a     where Atom = mkAtom
+
+{-# COMPLETE Cell, Atom #-}
+
+pattern C x y <- NCell _ _ x y where C = mkCell
+pattern A a   <- NAtom _ a     where A = mkAtom
+
+{-# COMPLETE C, A #-}
+
+
+--------------------------------------------------------------------------------
+
+instance Hashable Noun where
+  hash = \case NCell h _ _ _ -> h
+               NAtom h _     -> h
+  {-# INLINE hash #-}
+  hashWithSalt = defaultHashWithSalt
+  {-# INLINE hashWithSalt #-}
+
+textToUtf8Atom :: Text -> Noun
+textToUtf8Atom = Atom . utf8Atom
+
+utf8AtomToText :: Noun -> Either Text Text
+utf8AtomToText = \case
+    Cell _ _ -> Left "Expected @t, but got ^"
+    Atom atm -> atomUtf8 atm & \case
+        Left err -> Left (tshow err)
+        Right tx -> pure tx
+
+instance Show Noun where
+  show = \case Atom a   -> showAtom a
+               Cell x y -> fmtCell (show <$> (x : toTuple y))
+    where
+      fmtCell :: [String] -> String
+      fmtCell xs = "(" <> intercalate ", " xs <> ")"
+
+      toTuple :: Noun -> [Noun]
+      toTuple (Cell x xs) = x : toTuple xs
+      toTuple atom        = [atom]
+
+      showAtom :: Atom -> String
+      showAtom 0 = "0"
+      showAtom a | a >= 2^1024 = "\"...\""
+      showAtom a =
+          let mTerm = do
+                t <- utf8AtomToText (Atom a)
+                let ok = \x -> (C.isPrint x)
+                if (all ok (t :: Text))
+                    then pure ("\"" <> unpack t <> "\"")
+                    else Left "Don't show as text."
+
+          in case mTerm of
+               Left _   -> show a
+               Right st -> st
+
+instance Eq Noun where
+  (==) x y =
+    case reallyUnsafePtrEquality# x y of
+      1# -> True
+      _  -> case (x, y) of
+              (NAtom x1 a1, NAtom x2 a2) ->
+                  x1 == x2 && a1 == a2
+              (NCell x1 s1 h1 t1, NCell x2 s2 h2 t2) ->
+                  s1==s2 && x1==x2 && h1==h2 && t1==t2
+              _ ->
+                  False
+  {-# INLINE (==) #-}
+
+instance Ord Noun where
+  compare x y =
+    case reallyUnsafePtrEquality# x y of
+      1# -> EQ
+      _  -> case (x, y) of
+              (Atom _,     Cell _ _)   -> LT
+              (Cell _ _,   Atom _)     -> GT
+              (Atom a1,    Atom a2)    -> compare a1 a2
+              (Cell h1 t1, Cell h2 t2) -> compare h1 h2 <> compare t1 t2
+  {-# INLINE compare #-}
+
+
+instance Arbitrary Noun where
+  arbitrary = resize 1000 go
+    where
+      dub x = Cell x x
+      go = do
+        sz  <- getSize
+        (bit, bat :: Bool) <- arbitrary
+        case (sz, bit, bat) of
+          ( 0, _,     _    ) -> Atom <$> genAtom
+          ( _, False, _    ) -> Atom <$> genAtom
+          ( _, True,  True ) -> dub <$> arbitrary
+          ( _, True,  _    ) -> scale (\x -> x-10) (Cell <$> go <*> go)
+
+genNatural :: Gen Natural
+genNatural = fromInteger . abs <$> arbitrary
+
+genAtom :: Gen Atom
+genAtom = do
+  arbitrary >>= \case
+    False -> genNatural
+    True  -> (`mod` 16) <$> genNatural
+
+--------------------------------------------------------------------------------
+
+{-# INLINE nounSize #-}
+nounSize :: Noun -> Word
+nounSize = \case
+  NCell _ s _ _ -> s
+  NAtom _ _     -> 1
+
+{-# INLINE mkAtom #-}
+mkAtom :: Atom -> Noun
+mkAtom a = NAtom (hash a) a
+
+{-# INLINE mkCell #-}
+mkCell :: Noun -> Noun -> Noun
+mkCell h t = NCell has siz h t
+  where
+    siz = nounSize h + nounSize t
+    has = hash h `combine` hash t
+
+
+-- Stolen from Hashable Library ------------------------------------------------
+
+{-# INLINE combine #-}
+combine :: Int -> Int -> Int
+combine h1 h2 = (h1 * 16777619) `xor` h2
+
+{-# INLINE defaultHashWithSalt #-}
+defaultHashWithSalt :: Hashable a => Int -> a -> Int
+defaultHashWithSalt salt x = salt `combine` hash x

pkg/hs/urbit-king/lib/Urbit/Noun/Cue.hs

@@ -0,0 +1,392 @@
+{-# OPTIONS_GHC -O2 #-}
+
+{-|
+    Fast implementation of `cue :: Atom -> Maybe Noun`.
+
+    Implementation is based on the approach used in `flat`.
+-}
+module Urbit.Noun.Cue (cue, cueExn, cueBS, cueBSExn, DecodeErr) where
+
+import ClassyPrelude
+
+import Urbit.Atom
+import Urbit.Noun.Core
+
+import Data.Bits        (shiftL, shiftR, (.&.), (.|.))
+import Data.Function    ((&))
+import Foreign.Ptr      (Ptr, castPtr, plusPtr, ptrToWordPtr)
+import Foreign.Storable (peek)
+import GHC.Prim         (ctz#)
+import GHC.Word         (Word(..))
+import System.IO.Unsafe (unsafePerformIO)
+import Text.Printf      (printf)
+
+import qualified Data.ByteString.Unsafe as BS
+import qualified Data.HashTable.IO      as H
+import qualified Data.Vector.Primitive  as VP
+
+
+--------------------------------------------------------------------------------
+
+cueBS :: ByteString -> Either DecodeErr Noun
+cueBS = doGet dNoun
+
+cueBSExn :: MonadIO m => ByteString -> m Noun
+cueBSExn bs =
+  cueBS bs & \case
+    Left e  -> throwIO e
+    Right x -> pure x
+
+cue :: Atom -> Either DecodeErr Noun
+cue = cueBS . atomBytes
+
+cueExn :: MonadIO m => Atom -> m Noun
+cueExn = cueBSExn . atomBytes
+
+
+-- Debugging -------------------------------------------------------------------
+
+{-# INLINE debugM #-}
+debugM :: Monad m => String -> m ()
+debugM _ = pure ()
+
+{-# INLINE debugMId #-}
+debugMId :: (Monad m, Show a) => String -> m a -> m a
+debugMId _ a = a
+
+
+-- Types -----------------------------------------------------------------------
+
+{-|
+    The decoder state.
+
+    - An array of words (internal structure of our atoms).
+    - A pointer to the word *after* the last word in the array.
+    - A pointer into the current word of that array.
+    - A bit-offset into that word.
+-}
+data S = S
+  { currPtr  :: {-# UNPACK #-} !(Ptr Word)
+  , usedBits :: {-# UNPACK #-} !Word
+  , pos      :: {-# UNPACK #-} !Word
+  } deriving (Show,Eq,Ord)
+
+type Env = (Ptr Word, S)
+
+data DecodeErr
+    = InfiniteCue Env
+    | BadEncoding Env String
+  deriving (Show, Eq, Ord)
+
+data GetResult a = GetResult {-# UNPACK #-} !S !a
+  deriving (Show, Functor)
+
+newtype Get a = Get
+  { runGet :: Ptr Word
+           -> H.BasicHashTable Word Noun
+           -> S
+           -> IO (GetResult a)
+  }
+
+doGet :: Get a -> ByteString -> Either DecodeErr a
+doGet m bs =
+  unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do
+    let endPtr = ptr `plusPtr` len
+    let sz = max 50
+           $ min 10_000_000
+           $ length bs `div` 6
+    tbl <- H.newSized sz
+    GetResult _ r <- runGet m endPtr tbl (S (castPtr ptr) 0 0)
+    pure r
+
+--------------------------------------------------------------------------------
+
+instance Exception DecodeErr
+
+instance Functor Get where
+    fmap f g = Get $ \end tbl s -> do
+        GetResult s' a <- runGet g end tbl s
+        return $ GetResult s' (f a)
+    {-# INLINE  fmap #-}
+
+instance Applicative Get where
+    pure x = Get (\_ _ s -> return $ GetResult s x)
+    {-# INLINE pure #-}
+
+    Get f <*> Get g = Get $ \end tbl s1 -> do
+        GetResult s2 f' <- f end tbl s1
+        GetResult s3 g' <- g end tbl s2
+        return $ GetResult s3 (f' g')
+    {-# INLINE (<*>) #-}
+
+    Get f *> Get g = Get $ \end tbl s1 -> do
+        GetResult s2 _ <- f end tbl s1
+        g end tbl s2
+    {-# INLINE (*>) #-}
+
+instance Monad Get where
+    return = pure
+    {-# INLINE return #-}
+
+    (>>) = (*>)
+    {-# INLINE (>>) #-}
+
+    Get x >>= f = Get $ \end tbl s -> do
+        GetResult s' x' <- x end tbl s
+        runGet (f x') end tbl s'
+    {-# INLINE (>>=) #-}
+
+    fail msg = Get $ \end tbl s -> do
+      badEncoding end s msg
+    {-# INLINE fail #-}
+
+instance MonadIO Get where
+  liftIO io = Get $ \end tbl s -> GetResult s <$> io
+  {-# INLINE liftIO #-}
+
+--------------------------------------------------------------------------------
+
+{-# INLINE badEncoding #-}
+badEncoding :: Ptr Word -> S -> String -> IO a
+badEncoding !endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg
+
+--------------------------------------------------------------------------------
+
+{-# INLINE getPos #-}
+getPos :: Get Word
+getPos = Get $ \_ _ s ->
+  pure (GetResult s (pos s))
+
+{-# INLINE insRef #-}
+insRef :: Word -> Noun -> Get ()
+insRef !pos !now = Get $ \_ tbl s -> do
+  H.insert tbl pos now
+  pure $ GetResult s ()
+
+{-# INLINE getRef #-}
+getRef :: Word -> Get Noun
+getRef !ref = Get $ \x tbl s -> do
+  H.lookup tbl ref >>= \case
+    Nothing -> runGet (fail ("Invalid Reference: " <> show ref)) x tbl s
+    Just no -> pure (GetResult s no)
+
+{-# INLINE advance #-}
+advance :: Word -> Get ()
+advance 0 = debugM "advance: 0" >> pure ()
+advance !n = Get $ \_ _ s -> do
+  debugM ("advance: " <> show n)
+  let newUsed = n + usedBits s
+      newS    = s { pos      = pos s + n
+                  , usedBits = newUsed `mod` 64
+                  , currPtr  = plusPtr (currPtr s)
+                                 (8 * (fromIntegral (newUsed `div` 64)))
+                  }
+
+  pure (GetResult newS ())
+
+--------------------------------------------------------------------------------
+
+{-# INLINE guardInfinite #-}
+guardInfinite :: Ptr Word -> Ptr Word -> S -> IO ()
+guardInfinite end cur s =
+    when (cur >= (end `plusPtr` 16)) $ do
+        throwIO (InfiniteCue (end, s))
+
+-- TODO Should this be (>= end) or (> end)?
+{-# INLINE peekCurWord #-}
+peekCurWord :: Get Word
+peekCurWord = Get $ \end _ s -> do
+ debugMId "peekCurWord" $ do
+  guardInfinite end (currPtr s) s
+  if ptrToWordPtr (currPtr s) >= ptrToWordPtr end
+  then pure (GetResult s 0)
+  else GetResult s <$> peek (currPtr s)
+
+-- TODO Same question as above.
+{-# INLINE peekNextWord #-}
+peekNextWord :: Get Word
+peekNextWord = Get $ \end _ s -> do
+ debugMId "peekNextWord" $ do
+  let pTarget = currPtr s `plusPtr` 8
+  guardInfinite end pTarget s
+  if ptrToWordPtr pTarget >= ptrToWordPtr end
+  then pure (GetResult s 0)
+  else GetResult s <$> peek pTarget
+
+{-# INLINE peekUsedBits #-}
+peekUsedBits :: Get Word
+peekUsedBits =
+ debugMId "peekUsedBits" $ do
+  Get $ \_ _ s -> pure (GetResult s (usedBits s))
+
+{-|
+    Get a bit.
+
+    - Peek the current word.
+    - Right-shift by the bit-offset.
+    - Mask the high bits.
+-}
+{-# INLINE dBit #-}
+dBit :: Get Bool
+dBit = do
+  debugMId "dBit" $ do
+    wor <- peekCurWord
+    use <- fromIntegral <$> peekUsedBits
+    advance 1
+    pure (0 /= shiftR wor use .&. 1)
+
+{-# INLINE dWord #-}
+dWord :: Get Word
+dWord = do
+  debugMId "dWord" $ do
+    res <- peekWord
+    advance 64
+    pure res
+
+{-|
+    Get n bits, where n > 64:
+
+    - Get (n/64) words.
+    - Advance by n bits.
+    - Calculate an offset (equal to the current bit-offset)
+    - Calculate the length (equal to n)
+    - Construct a bit-vector using the buffer*length*offset.
+-}
+{-# INLINE dAtomBits #-}
+dAtomBits :: Word -> Get Atom
+dAtomBits !(fromIntegral -> bits) = do
+    debugMId ("dAtomBits(" <> show bits <> ")") $ do
+      fmap wordsAtom $
+        VP.generateM bufSize $ \i -> do
+          debugM (show i)
+          if (i == lastIdx && numExtraBits /= 0)
+          then dWordBits (fromIntegral numExtraBits)
+          else dWord
+  where
+    bufSize      = numFullWords + min 1 numExtraBits
+    lastIdx      = bufSize - 1
+    numFullWords = bits `div` 64
+    numExtraBits = bits `mod` 64
+
+{-|
+    In order to peek at the next Word64:
+
+    - If we are past the end of the buffer:
+      - Return zero.
+    - If the bit-offset is zero:
+      - Just peek.
+    - If we are pointing to the last word:
+      - Peek and right-shift by the bit offset.
+    - Otherwise,
+      - Peek the current word *and* the next word.
+      - Right-shift the current word by the bit-offset.
+      - Left-shift the next word by the bit-offset.
+      - Binary or the resulting two words.
+-}
+{-# INLINE peekWord #-}
+peekWord :: Get Word
+peekWord = do
+ debugMId "peekWord" $ do
+  off <- peekUsedBits
+  cur <- peekCurWord
+  nex <- peekNextWord
+  let res = swiz off (cur, nex)
+  debugM ("\t" <> (take 10 $ reverse $ printf "%b" (fromIntegral res :: Integer)) <> "..")
+  pure res
+
+{-# INLINE swiz #-}
+swiz :: Word -> (Word, Word) -> Word
+swiz !(fromIntegral -> off) (!low, !hig) =
+  (.|.) (shiftR low off) (shiftL hig (64-off))
+
+{-# INLINE takeLowBits #-}
+takeLowBits :: Word -> Word -> Word
+takeLowBits 64   !wor = wor
+takeLowBits !wid !wor = (2^wid - 1) .&. wor
+
+{-|
+  Make a word from the next n bits (where n <= 64).
+
+  - Peek at the next word.
+  - Mask the n lowest bits from the word.
+  - Advance by that number of bits.
+  - Return the word.
+-}
+{-# INLINE dWordBits #-}
+dWordBits :: Word -> Get Word
+dWordBits !n = do
+ debugMId ("dWordBits(" <> show n <> ")") $ do
+  w <- peekWord
+  advance n
+  debugM ("dWordBits: " <> show (takeLowBits n w))
+  pure (takeLowBits n w)
+
+
+-- Fast Cue --------------------------------------------------------------------
+
+{-|
+    Get the exponent-prefix of an atom:
+
+    - Peek at the next word.
+    - Calculate the number of least-significant bits in that word (there's
+      a primitive for this).
+    - Advance by that number of bits.
+    - Return the number of bits
+-}
+{-# INLINE dExp #-}
+dExp :: Get Word
+dExp = do
+ debugMId "dExp" $ do
+  W# w <- peekWord
+  let res = W# (ctz# w)
+  advance (res+1)
+  pure res
+
+{-# INLINE dAtomLen #-}
+dAtomLen :: Get Word
+dAtomLen = do
+ debugMId "dAtomLen" $ do
+  dExp >>= \case
+    0 -> pure 0
+    e -> do p <- dWordBits (e-1)
+            pure (2^(e-1) .|. p)
+
+{-# INLINE dRef #-}
+dRef :: Get Word
+dRef = debugMId "dRef" (dAtomLen >>= dWordBits)
+
+{-# INLINE dAtom #-}
+dAtom :: Get Atom
+dAtom = do
+ debugMId "dAtom" $ do
+  dAtomLen >>= \case
+    0 -> pure 0
+    n -> dAtomBits n
+
+{-# INLINE dCell #-}
+dCell :: Get Noun
+dCell = Cell <$> dNoun <*> dNoun
+
+{-|
+    Get a Noun.
+
+    - Get a bit
+    - If it's zero, get an atom.
+    - Otherwise, get another bit.
+    - If it's zero, get a cell.
+    - If it's one, get an atom.
+-}
+dNoun :: Get Noun
+dNoun = do
+  p <- getPos
+
+  let yield r = insRef p r >> pure r
+
+  dBit >>= \case
+    False -> do debugM "It's an atom"
+                (Atom <$> dAtom) >>= yield
+    True  -> dBit >>= \case
+      False -> do debugM "It's a cell"
+                  dCell >>= yield
+      True  -> do debugM "It's a backref"
+                  dRef >>= getRef

pkg/hs/urbit-king/lib/Urbit/Noun/Jam.hs

@@ -0,0 +1,368 @@
+{-# OPTIONS_GHC -O2 #-}
+
+{-|
+    Fast implementation of Jam (Noun → Atom).
+
+    This is based on the implementation of `flat`.
+-}
+module Urbit.Noun.Jam (jam, jamBS) where
+
+import ClassyPrelude hiding (hash)
+
+import Urbit.Atom
+import Urbit.Atom.Internal
+import Urbit.Noun.Core
+
+import Data.Bits                 (clearBit, setBit, shiftL, shiftR, (.|.))
+import Data.Vector.Primitive     ((!))
+import Foreign.Marshal.Alloc     (callocBytes, free)
+import Foreign.Ptr               (Ptr, castPtr, plusPtr)
+import Foreign.Storable          (poke)
+import GHC.Int                   (Int(I#))
+import GHC.Integer.GMP.Internals (BigNat)
+import GHC.Natural               (Natural(NatJ#, NatS#))
+import GHC.Prim                  (Word#, plusWord#, word2Int#)
+import GHC.Word                  (Word(W#))
+import System.IO.Unsafe          (unsafePerformIO)
+
+import qualified Data.ByteString.Unsafe as BS
+import qualified Data.HashTable.IO      as H
+import qualified Data.Vector.Primitive  as VP
+
+
+-- Exports ---------------------------------------------------------------------
+
+jamBS :: Noun -> ByteString
+jamBS n = doPut bt sz (writeNoun n)
+  where
+    (sz, bt) = unsafePerformIO (compress n)
+
+jam :: Noun -> Atom
+jam = bytesAtom . jamBS
+
+
+-- Types -----------------------------------------------------------------------
+
+{-|
+    The encoder state.
+
+    - ptr: Pointer into the output buffer.
+    - reg: Next 64 bits of output, partially written.
+    - off: Number of bits already written into `reg`
+    - pos: Total number of bits written.
+-}
+data S = S
+  { ptr :: {-# UNPACK #-} !(Ptr Word)
+  , reg :: {-# UNPACK #-} !Word
+  , off :: {-# UNPACK #-} !Int
+  , pos :: {-# UNPACK #-} !Word
+  } deriving (Show,Eq,Ord)
+
+data PutResult a = PutResult {-# UNPACK #-} !S !a
+  deriving Functor
+
+newtype Put a = Put
+  { runPut :: H.CuckooHashTable Word Word
+           -> S
+           -> IO (PutResult a)
+  }
+
+--------------------------------------------------------------------------------
+
+{-# INLINE getRef #-}
+getRef :: Put (Maybe Word)
+getRef = Put $ \tbl s -> PutResult s <$> H.lookup tbl (pos s)
+
+{-|
+  1. Write the register to the output, and increment the output pointer.
+-}
+{-# INLINE flush #-}
+flush :: Put ()
+flush = Put $ \tbl s@S{..} -> do
+    poke ptr reg
+    pure $ PutResult (s { ptr = ptr `plusPtr` 8 }) ()
+
+{-# INLINE update #-}
+update :: (S -> S) -> Put ()
+update f = Put $ \tbl s@S{..} -> pure (PutResult (f s) ())
+
+{-# INLINE setRegOff #-}
+setRegOff :: Word -> Int -> Put ()
+setRegOff r o = update $ \s@S{..} -> (s {reg=r, off=o})
+
+{-# INLINE setReg #-}
+setReg :: Word -> Put ()
+setReg r = update $ \s@S{..} -> (s { reg=r })
+
+{-# INLINE getS #-}
+getS :: Put S
+getS = Put $ \tbl s -> pure (PutResult s s)
+
+{-# INLINE putS #-}
+putS :: S -> Put ()
+putS s = Put $ \tbl _ -> pure (PutResult s ())
+
+{-|
+    To write a bit:
+
+    | reg  |= 1 << off
+    | off <- (off + 1) % 64
+    | if (!off):
+    |     buf[w++] <- reg
+    |     reg      <- 0
+-}
+{-# INLINE writeBit #-}
+writeBit :: Bool -> Put ()
+writeBit b = Put $ \tbl s@S{..} -> do
+    let s' = s { reg = (if b then setBit else clearBit) reg off
+               , off = (off + 1) `mod` 64
+               , pos = pos + 1
+               }
+
+    if off == 63
+    then runPut (flush >> setRegOff 0 0) tbl s'
+    else pure $ PutResult s' ()
+
+{-|
+    To write a 64bit word:
+
+    | reg |= w << off
+    | buf[bufI++] = reg
+    | reg = w >> (64 - off)
+-}
+{-# INLINE writeWord #-}
+writeWord :: Word -> Put ()
+writeWord wor = do
+    S{..} <- getS
+    setReg (reg .|. shiftL wor off)
+    flush
+    update $ \s -> s { pos = 64 + pos
+                     , reg = shiftR wor (64 - off)
+                     }
+
+{-|
+    To write some bits (< 64) from a word:
+
+    | wor = takeBits(wid, wor)
+    | reg = reg .|. (wor << off)
+    | off = (off + wid) % 64
+    |
+    | if (off + wid >= 64)
+    |     buf[w] = x
+    |     reg    = wor >> (wid - off)
+-}
+{-# INLINE writeBitsFromWord #-}
+writeBitsFromWord :: Int -> Word -> Put ()
+writeBitsFromWord wid wor = do
+    wor <- pure (takeBitsWord wid wor)
+
+    oldSt <- getS
+
+    let newSt = oldSt { reg = reg oldSt .|. shiftL wor (off oldSt)
+                      , off = (off oldSt + wid) `mod` 64
+                      , pos = fromIntegral wid + pos oldSt
+                      }
+
+    putS newSt
+
+    when (wid + off oldSt >= 64) $ do
+        flush
+        setReg (shiftR wor (wid - off newSt))
+
+{-|
+    Write all of the the signficant bits of a direct atom.
+-}
+{-# INLINE writeAtomWord# #-}
+writeAtomWord# :: Word# -> Put ()
+writeAtomWord# w = do
+    writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w)
+
+{-# INLINE writeAtomWord #-}
+writeAtomWord :: Word -> Put ()
+writeAtomWord (W# w) = writeAtomWord# w
+
+{-|
+  Write all of the the signficant bits of an indirect atom.
+
+  TODO Use memcpy when the bit-offset of the output is divisible by 8.
+-}
+{-# INLINE writeAtomBigNat #-}
+writeAtomBigNat :: BigNat -> Put ()
+writeAtomBigNat !(bigNatWords -> words) = do
+  let lastIdx = VP.length words - 1
+  for_ [0..(lastIdx-1)] $ \i ->
+      writeWord (words ! i)
+  writeAtomWord (words ! lastIdx)
+
+{-# INLINE writeAtomBits #-}
+writeAtomBits :: Atom -> Put ()
+writeAtomBits = \case NatS# wd -> writeAtomWord# wd
+                      NatJ# bn -> writeAtomBigNat bn
+
+
+-- Put Instances ---------------------------------------------------------------
+
+instance Functor Put where
+    fmap f g = Put $ \tbl s -> do
+        PutResult s' a <- runPut g tbl s
+        pure $ PutResult s' (f a)
+    {-# INLINE fmap #-}
+
+instance Applicative Put where
+    pure x = Put (\_ s -> return $ PutResult s x)
+    {-# INLINE pure #-}
+
+    Put f <*> Put g = Put $ \tbl s1 -> do
+        PutResult s2 f' <- f tbl s1
+        PutResult s3 g' <- g tbl s2
+        return $ PutResult s3 (f' g')
+    {-# INLINE (<*>) #-}
+
+    Put f *> Put g = Put $ \tbl s1 -> do
+        PutResult s2 _ <- f tbl s1
+        g tbl s2
+    {-# INLINE (*>) #-}
+
+instance Monad Put where
+    return = pure
+    {-# INLINE return #-}
+
+    (>>) = (*>)
+    {-# INLINE (>>) #-}
+
+    Put x >>= f = Put $ \tbl s -> do
+        PutResult s' x' <- x tbl s
+        runPut (f x') tbl s'
+    {-# INLINE (>>=) #-}
+
+
+--------------------------------------------------------------------------------
+
+doPut :: H.CuckooHashTable Word Word -> Word -> Put () -> ByteString
+doPut !tbl !sz m =
+    unsafePerformIO $ do
+        -- traceM "doPut"
+        buf <- callocBytes (fromIntegral (wordSz*8))
+        _   <- runPut (m >> mbFlush) tbl (S buf 0 0 0)
+        BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf)
+  where
+    !wordSz = fromIntegral (sz `divUp` 64)
+    !byteSz = fromIntegral (sz `divUp` 8)
+    !divUp  = \x y -> (x `div` y) + (if x `mod` y == 0 then 0 else 1)
+
+    mbFlush :: Put ()
+    mbFlush = do
+      shouldFlush <- (/= 0) . off <$> getS
+      when shouldFlush flush
+
+
+--------------------------------------------------------------------------------
+
+{-|
+    TODO Handle back references
+-}
+writeNoun :: Noun -> Put ()
+writeNoun !n =
+  getRef >>= \case
+    Just bk -> writeBackRef bk
+    Nothing -> case n of Atom a   -> writeAtom a
+                         Cell h t -> writeCell h t
+
+{-# INLINE writeMat #-}
+writeMat :: Atom -> Put ()
+writeMat 0   = writeBit True
+writeMat atm = do
+    writeBitsFromWord (preWid+1) (shiftL 1 preWid)
+    writeBitsFromWord (preWid-1) atmWid
+    writeAtomBits atm
+  where
+    atmWid = bitWidth atm
+    preWid = fromIntegral (wordBitWidth atmWid)
+
+{-# INLINE writeCell #-}
+writeCell :: Noun -> Noun -> Put ()
+writeCell !h !t = do
+    writeBit True
+    writeBit False
+    writeNoun h
+    writeNoun t
+
+{-# INLINE writeAtom #-}
+writeAtom :: Atom -> Put ()
+writeAtom !a = do
+    writeBit False
+    writeMat a
+
+{-# INLINE writeBackRef #-}
+writeBackRef :: Word -> Put ()
+writeBackRef !a = do
+    p <- pos <$> getS
+    writeBit True
+    writeBit True
+    writeMat (fromIntegral a)
+
+
+-- Calculate Jam Size and Backrefs ---------------------------------------------
+
+{-# INLINE matSz #-}
+matSz :: Atom -> Word
+matSz !a = W# (matSz# a)
+
+{-# INLINE matSz# #-}
+matSz# :: Atom -> Word#
+matSz# 0 = 1##
+matSz# a = preW `plusWord#` preW `plusWord#` atmW
+  where
+    atmW = atomBitWidth# a
+    preW = wordBitWidth# atmW
+
+{-# INLINE atomSz #-}
+atomSz :: Atom -> Word
+atomSz !w = 1 + matSz w
+
+{-# INLINE refSz #-}
+refSz :: Word -> Word
+refSz !w = 1 + jamWordSz w
+
+{-# INLINE jamWordSz #-}
+jamWordSz :: Word -> Word
+jamWordSz 0      = 2
+jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW)
+  where
+    atmW = wordBitWidth# w
+    preW = wordBitWidth# atmW
+
+compress :: Noun -> IO (Word, H.CuckooHashTable Word Word)
+compress !top = do
+    let sz = max 50
+           $ min 10_000_000
+           $ (2*) $ (10^) $ floor $ logBase 600 $ fromIntegral $ nounSize top
+
+    nodes :: H.BasicHashTable  Noun Word <- H.newSized sz
+    backs :: H.CuckooHashTable Word Word <- H.newSized sz
+
+    let proc :: Word -> Noun -> IO Word
+        proc !pos = \case
+            Atom a   -> pure (atomSz a)
+            Cell h t -> do !hSz <- go (pos+2) h
+                           !tSz <- go (pos+2+hSz) t
+                           pure (2+hSz+tSz)
+
+        go :: Word -> Noun -> IO Word
+        go !p !inp = do
+            H.lookup nodes inp >>= \case
+                Nothing -> do
+                    H.insert nodes inp p
+                    proc p inp
+                Just bak -> do
+                    let rs    = refSz bak
+                        doRef = H.insert backs p bak $> rs
+                        noRef = proc p inp
+                    case inp of
+                        Cell _ _                              -> doRef
+                        Atom a | rs < atomSz (fromIntegral a) -> doRef
+                        _                                     -> noRef
+
+    res <- go 0 top
+
+    pure (res, backs)

pkg/hs/urbit-king/lib/Urbit/Noun/TH.hs

@@ -0,0 +1,269 @@
+{-|
+    Template Haskell Code to Generate FromNoun and ToNoun Instances
+-}
+module Urbit.Noun.TH (deriveNoun, deriveToNoun, deriveFromNoun) where
+
+import ClassyPrelude              hiding (fromList)
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Urbit.Noun.Convert
+
+import Urbit.Noun.Core (textToUtf8Atom)
+
+import qualified Data.Char as C
+
+
+--------------------------------------------------------------------------------
+
+type ConInfo = (Name, [Type])
+
+data Shape
+    = Vod
+    | Tup ConInfo
+    | Sum [(String, Name)] [(String, ConInfo)]
+  deriving (Eq, Ord, Show)
+
+typeShape :: Name -> Q ([TyVarBndr], Shape)
+typeShape tyName = do
+    (vars, cs) <-
+        reify tyName >>= \case
+            TyConI (DataD _ nm vars _ cs _)   -> pure (vars, unpackCon <$> cs)
+            TyConI (NewtypeD _ nm vars _ c _) -> pure (vars, [unpackCon c])
+            TyConI _                          -> fail badSynonym
+            _                                 -> fail "not type"
+
+    let prefix = getPrefix (nameStr . fst <$> cs)
+        splits = splitFn ([], []) cs
+        splitFn (l, r) = \case
+          []          -> (l, r)
+          (n,[]) : cs -> splitFn (tagName prefix n:l, r) cs
+          conInf : cs -> splitFn (l, tagConInfo prefix conInf:r) cs
+
+    pure $ (vars,) $ case cs of
+        []  -> Vod
+        [c] -> Tup c
+        cs  -> uncurry Sum splits
+
+  where
+    badSynonym = "deriveFunctor: tyCon may not be a type synonym."
+
+    tagConInfo :: Int -> ConInfo -> (String, ConInfo)
+    tagConInfo pre ci@(nm, _) = (tagString pre nm, ci)
+
+    tagName :: Int -> Name -> (String, Name)
+    tagName pre n = (tagString pre n, n)
+
+    tyStr   = nameStr tyName
+    tyAbbrv = filter C.isUpper tyStr
+
+    typePrefixed  = (tyStr `isPrefixOf`)
+    abbrvPrefixed = (tyAbbrv `isPrefixOf`)
+
+    getPrefix :: [String] -> Int
+    getPrefix cs | all typePrefixed cs  = length tyStr
+    getPrefix cs | all abbrvPrefixed cs = length tyAbbrv
+    getPrefix _                         = 0
+
+    unpackCon :: Con -> ConInfo
+    unpackCon = \case
+      NormalC nm bangTypes          -> (nm, snd <$> bangTypes)
+      RecC nm varBangTypes          -> (nm, varBangTypes <&> (\(_, _, t) -> t))
+      InfixC bangType1 nm bangType2 -> error "Infix Cnstrs are not supported"
+      ForallC tyVarBndrs ctx con    -> error "Polymorphic tys are not supported"
+      GadtC nm bangTypes ty         -> error "GADTs are not supported"
+      RecGadtC nm varBangTypes ty   -> error "GADTs are not supported"
+
+--------------------------------------------------------------------------------
+
+deriveNoun :: Name -> Q [Dec]
+deriveNoun n = (<>) <$> deriveToNoun n <*> deriveFromNoun n
+
+--------------------------------------------------------------------------------
+
+deriveToNoun :: Name -> Q [Dec]
+deriveToNoun tyName = do
+    (params, shape) <- typeShape tyName
+
+    let exp = case shape of Vod             -> vodToNoun
+                            Tup con         -> tupToNoun con
+                         -- Enu cons        -> enumToAtom cons
+                            Sum atoms cells -> sumToNoun atoms cells
+
+    params <- pure $ zip ['a' ..] params <&> \(n,_) -> mkName (singleton n)
+
+    let ty = foldl' (\acc v -> AppT acc (VarT v)) (ConT tyName) params
+
+    let overlap = Nothing
+        body    = NormalB exp
+        ctx     = params <&> \t -> AppT (ConT ''ToNoun) (VarT t)
+        inst    = AppT (ConT ''ToNoun) ty
+
+    pure [InstanceD overlap ctx inst [ValD (VarP 'toNoun) body []]]
+
+--------------------------------------------------------------------------------
+
+addErrTag :: String -> Exp -> Exp
+addErrTag tag exp =
+    InfixE (Just $ AppE (VarE 'named) str) (VarE (mkName ".")) (Just exp)
+  where
+    str = LitE $ StringL tag
+
+deriveFromNoun :: Name -> Q [Dec]
+deriveFromNoun tyName = do
+    (params, shape) <- typeShape tyName
+
+    let exp = case shape of Vod             -> vodFromNoun
+                            Tup con         -> tupFromNoun con
+                         -- Enu cons        -> enumFromAtom cons
+                            Sum atoms cells -> sumFromNoun atoms cells
+
+    params <- pure $ zip ['a' ..] params <&> \(n,_) -> mkName (singleton n)
+
+    let ty = foldl' (\acc v -> AppT acc (VarT v)) (ConT tyName) params
+
+    let overlap = Nothing
+        body    = NormalB (addErrTag (nameStr tyName) exp)
+        ctx     = params <&> \t -> AppT (ConT ''FromNoun) (VarT t)
+        inst    = AppT (ConT ''FromNoun) ty
+
+    pure [InstanceD overlap ctx inst [ValD (VarP 'parseNoun) body []]]
+
+sumFromNoun :: [(String, Name)] -> [(String, ConInfo)] -> Exp
+sumFromNoun [] cl = taggedFromNoun cl
+sumFromNoun at [] = enumFromAtom at
+sumFromNoun at cl = eitherParser (taggedFromNoun cl) (enumFromAtom at)
+  where
+    eitherParser :: Exp -> Exp -> Exp
+    eitherParser x y =
+        LamE [VarP n] $
+          InfixE (Just xCase) (VarE (mkName "<|>")) (Just yCase)
+      where
+        xCase = AppE x (VarE n)
+        yCase = AppE y (VarE n)
+        n = mkName "atomOrCell"
+
+enumFromAtom :: [(String, Name)] -> Exp
+enumFromAtom cons = LamE [VarP x] body
+  where
+    (x, c)    = (mkName "x", mkName "c")
+    getTag    = BindS (VarP c) $ AppE (VarE 'parseNounUtf8Atom) (VarE x)
+    examine   = NoBindS $ CaseE (VarE c) (matches ++ [fallback])
+    matches   = mkMatch <$> cons
+    fallback  = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
+    body      = DoE [getTag, examine]
+    matchFail = LitE $ StringL ("Expected one of: " <> possible)
+    possible  = intercalate " " (('%':) . fst <$> cons)
+    mkMatch   = \(tag, nm) ->
+      Match (SigP (LitP $ StringL tag) (ConT ''Text))
+            (NormalB $ AppE (VarE 'pure) (ConE nm))
+            []
+
+applyE :: Exp -> [Exp] -> Exp
+applyE e []     = e
+applyE e (a:as) = applyE (AppE e a) as
+
+vodFromNoun :: Exp
+vodFromNoun = LamE [WildP] body
+  where
+    body = AppE (VarE 'fail)
+         $ LitE $ StringL "Can't FromNoun on uninhabited data type"
+
+tupFromNoun :: ConInfo -> Exp
+tupFromNoun (n, tys) = LamE [VarP x] body
+  where
+    x       = mkName "x"
+    vars    = mkName . singleton . fst <$> zip ['a'..] tys
+    body    = DoE [getTup, convert]
+    convert = NoBindS $ AppE (VarE 'pure) $ applyE (ConE n) (VarE <$> vars)
+    getTup  = BindS (TupP $ VarP <$> vars) $ AppE (VarE 'parseNoun) (VarE x)
+
+unexpectedTag :: [String] -> Exp -> Exp
+unexpectedTag expected got =
+    applyE (VarE 'mappend) [LitE (StringL prefix), AppE (VarE 'unpack) got]
+  where
+    possible  = intercalate " " (('%':) <$> expected)
+    prefix    = "Expected one of: " <> possible <> " but got %"
+
+taggedFromNoun :: [(String, ConInfo)] -> Exp
+taggedFromNoun cons = LamE [VarP n] (DoE [getHead, getTag, examine])
+  where
+    (n, h, t, c) = (mkName "noun", mkName "hed", mkName "tel", mkName "tag")
+
+    getHead = BindS (TupP [VarP h, VarP t])
+            $ AppE (VarE 'parseNoun) (VarE n)
+
+    getTag = BindS (SigP (VarP c) (ConT ''Text))
+           $ AppE (VarE 'parseNounUtf8Atom) (VarE h)
+
+    examine = NoBindS
+            $ CaseE (VarE c) (matches ++ [fallback])
+
+    matches = mkMatch <$> cons
+    mkMatch = \(tag, (n, tys)) ->
+                let body = AppE (addErrTag ('%':tag) (tupFromNoun (n, tys)))
+                                (VarE t)
+                in Match (LitP $ StringL tag) (NormalB body) []
+
+    fallback  = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
+    matchFail = unexpectedTag (fst <$> cons) (VarE c)
+
+--------------------------------------------------------------------------------
+
+tagString :: Int -> Name -> String
+tagString prefix = hsToHoon . drop prefix . nameStr
+
+nameStr :: Name -> String
+nameStr (Name (OccName n) _) = n
+
+tagNoun :: String -> Exp
+tagNoun = AppE (VarE 'textToUtf8Atom)
+        . LitE
+        . StringL
+
+tagTup :: String -> [Name] -> Exp
+tagTup tag args = AppE (VarE 'toNoun) $ TupE (tagNoun tag : fmap VarE args)
+
+tup :: [Name] -> Exp
+tup = AppE (VarE 'toNoun) . TupE . fmap VarE
+
+--------------------------------------------------------------------------------
+
+vodToNoun :: Exp
+vodToNoun = LamCaseE []
+
+tupToNoun :: ConInfo -> Exp
+tupToNoun cons = LamCaseE [mkMatch cons]
+  where
+    mkMatch :: ConInfo -> Match
+    mkMatch (nm, tys) = Match (ConP nm params) (NormalB body) []
+      where vars   = (zip tys ['a'..]) <&> (mkName . singleton . snd)
+            params = VarP <$> vars
+            body   = tup vars
+
+sumToNoun :: [(String, Name)] -> [(String, ConInfo)] -> Exp
+sumToNoun a c =
+    LamCaseE (mixed <&> uncurry mkMatch)
+  where
+    mixed = mconcat [ a <&> \(x,y) -> (x, Left y)
+                    , c <&> \(x,y) -> (x, Right y)
+                    ]
+
+    mkMatch :: String -> Either Name ConInfo -> Match
+    mkMatch tag = \case
+      Left nm         -> Match (ConP nm []) (NormalB $ tagNoun tag) []
+      Right (nm, tys) -> Match (ConP nm params) (NormalB body) []
+        where vars   = (zip tys ['a'..]) <&> (mkName . singleton . snd)
+              params = VarP <$> vars
+              body   = tagTup tag vars
+
+--------------------------------------------------------------------------------
+
+hsToHoon :: String -> String
+hsToHoon = go []
+  where
+    go acc []     = intercalate "-" $ reverse acc
+    go acc (c:cs) = go (elem:acc) remain
+      where
+        head           = C.toLower c
+        (tail, remain) = break C.isUpper cs
+        elem           = head:tail

pkg/hs/urbit-king/lib/Urbit/Noun/Tank.hs

@@ -0,0 +1,283 @@
+{-|
+    Pretty Printer Types
+-}
+
+module Urbit.Noun.Tank where
+
+import ClassyPrelude
+import Urbit.Noun.Conversions
+import Urbit.Noun.TH
+
+--------------------------------------------------------------------------------
+
+type Tang = [Tank]
+
+data Tank
+    = Leaf Tape
+    | Plum Plum
+    | Palm (Tape, Tape, Tape, Tape) [Tank]
+    | Rose (Tape, Tape, Tape) [Tank]
+  deriving (Eq, Ord, Show)
+
+data WideFmt = WideFmt { delimit :: Cord, enclose :: Maybe (Cord, Cord) }
+  deriving (Eq, Ord, Show)
+
+data TallFmt = TallFmt { intro :: Cord, indef :: Maybe (Cord, Cord) }
+  deriving (Eq, Ord, Show)
+
+data PlumFmt = PlumFmt (Maybe WideFmt) (Maybe TallFmt)
+  deriving (Eq, Ord, Show)
+
+type Plum = AtomCell Cord PlumTree
+
+data PlumTree
+    = Para Cord [Cord]
+    | Tree PlumFmt [Plum]
+    | Sbrk Plum
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''WideFmt
+deriveNoun ''TallFmt
+deriveNoun ''PlumFmt
+deriveNoun ''Tank
+deriveNoun ''PlumTree
+
+--------------------------------------------------------------------------------
+
+data WashCfg = WashCfg
+    { wcIndent :: Word
+    , wcWidth  :: Word
+    }
+
+--------------------------------------------------------------------------------
+
+wash :: WashCfg -> Tank -> Wall
+wash _cfg t = [ram t]
+
+-- win :: WashCfg -> Tank -> Wall
+-- win = undefined
+
+flat :: Plum -> Tape
+flat = Tape . tshow
+
+ram :: Tank -> Tape
+ram = \case
+    Leaf tape           -> tape
+    Plum plum           -> flat plum
+    Palm (p,q,r,s) kids -> ram (Rose (p, q<>r, s) kids)
+    Rose (p,q,r) kids   -> q <> loop kids
+      where
+        loop []     = r
+        loop [x]    = ram x <> r
+        loop (x:xs) = ram x <> p <> loop xs
+
+{-
+  ++  win
+    |=  {tab/@ edg/@}
+    =.  tac  (act:ug tac)
+    %-  fix:ug
+    =+  lug=`wall`~
+    |^  |-  ^-  wall
+        ?-    -.tac
+            $leaf  (rig p.tac)
+            $plum  (turn ~(tall plume p.tac) |=(=cord (trip cord)))
+            $palm
+          ?:  fit
+            (rig ram)
+          ?~  q.tac
+            (rig q.p.tac)
+          ?~  t.q.tac
+            (rig(tab (add 2 tab), lug $(tac i.q.tac)) q.p.tac)
+          =>  .(q.tac `(list tank)`q.tac)
+          =+  lyn=(mul 2 (lent q.tac))
+          =+  ^=  qyr
+              |-  ^-  wall
+              ?~  q.tac
+                lug
+              %=  ^$
+                tac  i.q.tac
+                tab  (add tab (sub lyn 2))
+                lug  $(q.tac t.q.tac, lyn (sub lyn 2))
+              ==
+          (wig(lug qyr) q.p.tac)
+        ::
+            $rose
+          ?:  fit
+            (rig ram)
+          =.  lug
+            |-  ^-  wall
+            ?~  q.tac
+              ?:(=(~ r.p.tac) lug (rig r.p.tac))
+            ^$(tac i.q.tac, lug $(q.tac t.q.tac), tab din)
+          ?:  =(~ q.p.tac)
+            lug
+          (wig q.p.tac)
+        ==
+    ::
+    ++  din  (mod (add 2 tab) (mul 2 (div edg 3)))
+    ++  fit  (lte (lent ram) (sub edg tab))
+    ++  rig
+      |=  hom/tape
+      ^-  wall
+      ?:  (lte (lent hom) (sub edg tab))
+        [(runt [tab ' '] hom) lug]
+      =>  .(tab (add tab 2), edg (sub edg 2))
+      =+  mut=(trim (sub edg tab) hom)
+      :-  (runt [(sub tab 2) ' '] ['\\' '/' (weld p.mut `_hom`['\\' '/' ~])])
+      =>  .(hom q.mut)
+      |-
+      ?~  hom
+        :-  %+  runt
+              [(sub tab 2) ' ']
+            ['\\' '/' (runt [(sub edg tab) ' '] ['\\' '/' ~])]
+        lug
+      =>  .(mut (trim (sub edg tab) hom))
+      [(runt [tab ' '] p.mut) $(hom q.mut)]
+    ::
+    ++  wig
+      |=  hom/tape
+      ^-  wall
+      ?~  lug
+        (rig hom)
+      =+  lin=(lent hom)
+      =+  wug=:(add 1 tab lin)
+      ?.  =+  mir=i.lug
+          |-  ?~  mir
+                |
+              ?|(=(0 wug) ?&(=(' ' i.mir) $(mir t.mir, wug (dec wug))))
+        (rig hom)       :: ^ XX regular form?
+      [(runt [tab ' '] (weld hom `tape`[' ' (slag wug i.lug)])) t.lug]
+    --
+  --
+-}
+
+{-
+++  re
+  |_  tac/tank
+  ++  ram
+    ^-  tape
+    ?-    -.tac
+        $leaf  p.tac
+        $plum  ~(flat plume p.tac)
+        $palm  ram(tac [%rose [p.p.tac (weld q.p.tac r.p.tac) s.p.tac] q.tac])
+        $rose
+      %+  weld
+        q.p.tac
+      |-  ^-  tape
+      ?~  q.tac
+        r.p.tac
+      =+  voz=$(q.tac t.q.tac)
+      (weld ram(tac i.q.tac) ?~(t.q.tac voz (weld p.p.tac voz)))
+    ==
+  ::
+  ++  ug                                                ::  horrible hack
+    |%
+    ++  ace                                             ::  strip ctrl chars
+      |=  a=tape
+      ^-  tape
+      ?~  a  ~
+      ?:  |((lth i.a 32) =(127 `@`i.a))
+        $(a t.a)
+      [i.a $(a t.a)]
+    ::
+    ++  act                                             ::  pretend tapes
+      |=  tac=tank
+      ^-  tank
+      ?-  -.tac
+        %leaf  [%leaf (hew p.tac)]
+        %plum  tac    ::  XX consider
+        %palm  :+  %palm
+                 [(hew p.p.tac) (hew q.p.tac) (hew r.p.tac) (hew s.p.tac)]
+               (turn q.tac act)
+        %rose  :+  %rose
+                 [(hew p.p.tac) (hew q.p.tac) (hew r.p.tac)]
+               (turn q.tac act)
+      ==
+    ::
+    ++  fix                                             ::  restore tapes
+      |=  wol=wall
+      %+  turn  wol
+      |=(a=tape (tufa `(list @c)``(list @)`a))
+    ::
+    ++  hew                                             ::  pretend tape
+      |=(a=tape `tape``(list @)`(tuba (ace a)))
+    --
+  ::
+  ++  win
+    |=  {tab/@ edg/@}
+    =.  tac  (act:ug tac)
+    %-  fix:ug
+    =+  lug=`wall`~
+    |^  |-  ^-  wall
+        ?-    -.tac
+            $leaf  (rig p.tac)
+            $plum  (turn ~(tall plume p.tac) |=(=cord (trip cord)))
+            $palm
+          ?:  fit
+            (rig ram)
+          ?~  q.tac
+            (rig q.p.tac)
+          ?~  t.q.tac
+            (rig(tab (add 2 tab), lug $(tac i.q.tac)) q.p.tac)
+          =>  .(q.tac `(list tank)`q.tac)
+          =+  lyn=(mul 2 (lent q.tac))
+          =+  ^=  qyr
+              |-  ^-  wall
+              ?~  q.tac
+                lug
+              %=  ^$
+                tac  i.q.tac
+                tab  (add tab (sub lyn 2))
+                lug  $(q.tac t.q.tac, lyn (sub lyn 2))
+              ==
+          (wig(lug qyr) q.p.tac)
+        ::
+            $rose
+          ?:  fit
+            (rig ram)
+          =.  lug
+            |-  ^-  wall
+            ?~  q.tac
+              ?:(=(~ r.p.tac) lug (rig r.p.tac))
+            ^$(tac i.q.tac, lug $(q.tac t.q.tac), tab din)
+          ?:  =(~ q.p.tac)
+            lug
+          (wig q.p.tac)
+        ==
+    ::
+    ++  din  (mod (add 2 tab) (mul 2 (div edg 3)))
+    ++  fit  (lte (lent ram) (sub edg tab))
+    ++  rig
+      |=  hom/tape
+      ^-  wall
+      ?:  (lte (lent hom) (sub edg tab))
+        [(runt [tab ' '] hom) lug]
+      =>  .(tab (add tab 2), edg (sub edg 2))
+      =+  mut=(trim (sub edg tab) hom)
+      :-  (runt [(sub tab 2) ' '] ['\\' '/' (weld p.mut `_hom`['\\' '/' ~])])
+      =>  .(hom q.mut)
+      |-
+      ?~  hom
+        :-  %+  runt
+              [(sub tab 2) ' ']
+            ['\\' '/' (runt [(sub edg tab) ' '] ['\\' '/' ~])]
+        lug
+      =>  .(mut (trim (sub edg tab) hom))
+      [(runt [tab ' '] p.mut) $(hom q.mut)]
+    ::
+    ++  wig
+      |=  hom/tape
+      ^-  wall
+      ?~  lug
+        (rig hom)
+      =+  lin=(lent hom)
+      =+  wug=:(add 1 tab lin)
+      ?.  =+  mir=i.lug
+          |-  ?~  mir
+                |
+              ?|(=(0 wug) ?&(=(' ' i.mir) $(mir t.mir, wug (dec wug))))
+        (rig hom)       :: ^ XX regular form?
+      [(runt [tab ' '] (weld hom `tape`[' ' (slag wug i.lug)])) t.lug]
+    --
+  --
+-}

pkg/hs/urbit-king/lib/Urbit/Noun/Tree.hs

@@ -0,0 +1,245 @@
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE DuplicateRecordFields    #-}
+
+{-|
+    Hoon's `map` and `set` types and conversions to/from Nouns.
+-}
+module Urbit.Noun.Tree
+    ( HoonSet, setToHoonSet, setFromHoonSet
+    , HoonMap, mapToHoonMap, mapFromHoonMap
+    , mug
+    ) where
+
+import ClassyPrelude
+import Control.Lens  hiding (non)
+
+import Urbit.Atom
+import Urbit.Noun.Conversions ()
+import Urbit.Noun.Convert
+import Urbit.Noun.Core
+import Urbit.Noun.TH
+
+import Data.Bits        (shiftR, xor)
+import Data.Hash.Murmur (murmur3)
+import GHC.Natural      (Natural)
+
+
+-- Types -----------------------------------------------------------------------
+
+data NounVal a = NounVal
+    { non ∷ Noun
+    , val ∷ !a
+    }
+
+data HoonTreeNode a = NTN
+    { n ∷ NounVal a
+    , l ∷ HoonTree a
+    , r ∷ HoonTree a
+    }
+  deriving (Eq, Ord, Show)
+
+data HoonTree a = E | Node (HoonTreeNode a)
+  deriving (Eq, Ord, Show)
+
+pattern N n l r = Node (NTN n l r)
+
+newtype HoonSet a = HoonSet { unHoonSet ∷ HoonTree a }
+  deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
+
+newtype HoonMap k v = HoonMap { unHoonMap ∷ HoonTree (k, v) }
+  deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
+
+
+-- Instances -------------------------------------------------------------------
+
+instance Eq (NounVal a) where
+  (==) = on (==) non
+
+instance Ord (NounVal a) where
+  compare = comparing non
+
+instance ToNoun (NounVal a) where
+  toNoun = non
+
+instance Show a ⇒ Show (NounVal a) where
+  show = show . val
+
+instance FromNoun a ⇒ FromNoun (NounVal a) where
+    parseNoun x = NounVal x <$> parseNoun x
+
+instance ToNoun a ⇒ ToNoun (HoonTree a) where
+    toNoun E        = A 0
+    toNoun (Node n) = toNoun n
+
+instance FromNoun a ⇒ FromNoun (HoonTree a) where
+    parseNoun (A 0) = pure E
+    parseNoun n     = Node <$> parseNoun n
+
+deriveNoun ''HoonTreeNode
+
+
+-- Mug -------------------------------------------------------------------------
+
+type Nat = Natural
+
+slowMug ∷ Noun → Nat
+slowMug = trim 0xcafe_babe . \case
+    A a   → a
+    C h t → mix (slowMug h) $ mix 0x7fff_ffff (slowMug t)
+  where
+    trim ∷ Nat → Nat → Nat
+    trim syd key =
+        if 0/=ham then ham else trim (succ syd) key
+      where
+        haz = muk syd (met 3 key) key
+        ham = mix (rsh 0 31 haz) (end 0 31 haz)
+
+mix ∷ Nat → Nat → Nat
+mix = xor
+
+-- Murmur3
+muk ∷ Nat → Nat → Nat → Nat
+muk seed len =
+    fromIntegral . murmur3 (word32 seed) . resize . atomBytes
+  where
+    resize ∷ ByteString → ByteString
+    resize buf =
+      case compare (length buf) (int len) of
+          EQ → buf
+          LT → error "bad-muk"
+          GT → error "bad-muk"
+--        LT → buf <> replicate (len - length buf) 0
+--        GT → take len buf
+
+int ∷ Integral i ⇒ i → Int
+int = fromIntegral
+
+word32 ∷ Integral i ⇒ i → Word32
+word32 = fromIntegral
+
+bex ∷ Nat → Nat
+bex = (2^)
+
+end ∷ Nat → Nat → Nat → Nat
+end blockSize blocks n =
+  n `mod` (bex (bex blockSize * blocks))
+
+rsh ∷ Nat → Nat → Nat → Nat
+rsh blockSize blocks n =
+    shiftR n $ fromIntegral $ (bex blockSize * blocks)
+
+met ∷ Nat → Nat → Nat
+met bloq = go 0
+  where
+    go c 0 = c
+    go c n = go (succ c) (rsh bloq 1 n)
+
+-- XX TODO
+mug ∷ Noun → Nat
+mug = slowMug
+
+
+-- Order -----------------------------------------------------------------------
+
+{-
+    Orders in ascending double mug hash order, collisions fall back to dor.
+-}
+mor ∷ Noun → Noun → Bool
+mor a b = if c == d then dor a b else c < d
+  where
+    c = mug $ A $ mug a
+    d = mug $ A $ mug b
+
+{-
+    Orders in ascending tree depth.
+-}
+dor ∷ Noun → Noun → Bool
+dor a       b       | a == b = True
+dor (A a)   (C _ _)          = True
+dor (C x y) (A b)            = False
+dor (A a)   (A b)            = a < b
+dor (C x y) (C p q) | x == p = dor y q
+dor (C x y) (C p q)          = dor x p
+
+{-
+    Orders in ascending +mug hash order.
+
+    Collisions fall back to dor.
+-}
+gor ∷ Noun → Noun → Bool
+gor a b = if c==d then dor a b else c<d
+  where (c, d) = (mug a, mug b)
+
+morVal, gorVal ∷ NounVal a → NounVal a → Bool
+morVal = on mor non
+gorVal = on gor non
+
+
+--------------------------------------------------------------------------------
+
+nounVal ∷ ToNoun a ⇒ Iso' a (NounVal a)
+nounVal = iso to val
+  where
+    to x = NounVal (toNoun x) x
+
+treeToList ∷ ∀a. HoonTree a → [a]
+treeToList = go []
+  where
+    go ∷ [a] → HoonTree a → [a]
+    go acc = \case
+        E                → acc
+        Node (NTN v l r) → go (go (val v : acc) l) r
+
+setFromHoonSet ∷ Ord a ⇒ HoonSet a → Set a
+setFromHoonSet = setFromList . treeToList . unHoonSet
+
+mapFromHoonMap ∷ Ord k ⇒ HoonMap k v → Map k v
+mapFromHoonMap = mapFromList . treeToList . unHoonMap
+
+setToHoonSet ∷ ∀a. (Ord a, ToNoun a) ⇒ Set a → HoonSet a
+setToHoonSet = HoonSet . foldr put E . fmap (view nounVal) . setToList
+  where
+    put x = \case
+        E                       → N x E E
+        Node a | x == n a       → Node a
+        Node a | gorVal x (n a) → lef x a
+        Node a                  → rit x a
+
+    rit x a = put x (r a) & \case
+        E                           → error "bad-put-set"
+        Node c | morVal (n a) (n c) → N (n a) (l a) (Node c)
+        Node c                      → N (n c) (N (n a) (l a) (l c)) (r c)
+
+    lef x a = put x (l a) & \case
+        E                           → error "bad-put-set"
+        Node c | morVal (n a) (n c) → N (n a) (Node c) (r a)
+        Node c                      → N (n c) (l c) (N (n a) (r c) (r a))
+
+p ∷ (ToNoun a, ToNoun b) ⇒ NounVal (a,b) → NounVal a
+p = view (from nounVal . to fst . nounVal)
+
+pq ∷ (ToNoun a, ToNoun b) ⇒ NounVal (a,b) → (NounVal a, NounVal b)
+pq = boof . view (from nounVal)
+  where
+    boof (x, y) = (x ^. nounVal, y ^. nounVal)
+
+mapToHoonMap ∷ ∀k v. (ToNoun k, ToNoun v, Ord k, Ord v) ⇒ Map k v → HoonMap k v
+mapToHoonMap = HoonMap . foldr put E . fmap (view nounVal) . mapToList
+  where
+    put ∷ NounVal (k, v) → HoonTree (k, v) → HoonTree (k, v)
+    put kv@(pq -> (b, c)) = \case
+      E                            → N kv E E
+      Node a | kv == n a           → Node a
+      Node a | b  == p (n a)       → N kv (l a) (r a)
+      Node a | gorVal b (p $ n a)  → lef kv a
+      Node a                       → rit kv a
+
+    lef kv@(pq -> (b, c)) a = put kv (l a) & \case
+      E                                   → error "bad-put-map"
+      Node d | morVal (p $ n a) (p $ n d) → N (n a) (Node d) (r a)
+      Node d                              → N (n d) (l d) (N (n a) (r d) (r a))
+
+    rit kv@(pq -> (b, c)) a = put kv (r a) & \case
+      E                                   → error "bad-put-map"
+      Node d | morVal (p $ n a) (p $ n d) → N (n a) (l a) (Node d)
+      Node d                              → N (n d) (N (n a) (l a) (l d)) (r d)

pkg/hs/urbit-king/lib/Urbit/Prelude.hs

@@ -0,0 +1,49 @@
+{-|
+    Convenient Re-Exports
+-}
+
+module Urbit.Prelude
+    ( module ClassyPrelude
+    , module Control.Arrow
+    , module Control.Lens
+    , module Data.Acquire
+    , module Data.RAcquire
+    , module Data.Void
+    , module Urbit.Noun
+    , module Text.Show.Pretty
+    , module Text.Printf
+    , module RIO
+    , io, rio
+    , logTrace
+    ) where
+
+import ClassyPrelude
+import Urbit.Noun
+
+import Control.Lens hiding (Each, Index, cons, index, snoc, uncons, unsnoc,
+                     (<.>), (<|))
+
+import Control.Arrow    ((<<<), (>>>))
+import Data.Acquire     (Acquire, mkAcquire, with)
+import Data.RAcquire    (RAcquire, mkRAcquire, rwith)
+import Data.RAcquire    (MonadAcquire(..), MonadRIO(..))
+import Data.Void        (Void, absurd)
+import Text.Printf      (printf)
+import Text.Show.Pretty (pPrint, ppShow)
+
+import RIO (RIO, runRIO)
+import RIO (Utf8Builder, display, displayShow)
+import RIO (threadDelay)
+
+import RIO (HasLogFunc, LogFunc, logDebug, logError, logFuncL, logInfo,
+            logOptionsHandle, logOther, logWarn, mkLogFunc, setLogUseLoc,
+            setLogUseTime, withLogFunc)
+
+io :: MonadIO m => IO a -> m a
+io = liftIO
+
+rio :: MonadRIO m => RIO e a -> m e a
+rio = liftRIO
+
+logTrace :: HasLogFunc e => Utf8Builder -> RIO e ()
+logTrace = logOther "trace"

pkg/hs/urbit-king/lib/Urbit/Time.hs

@@ -0,0 +1,111 @@
+{-|
+    TODO This is slow.
+-}
+
+module Urbit.Time where
+
+import Control.Lens
+import Prelude
+
+import Data.Bits              (shiftL, shiftR)
+import Data.Time.Clock        (DiffTime, UTCTime)
+import Data.Time.Clock        (diffTimeToPicoseconds, picosecondsToDiffTime)
+import Data.Time.Clock.System (SystemTime(..), getSystemTime)
+import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
+import Urbit.Noun             (FromNoun, ToNoun)
+
+
+-- Types -----------------------------------------------------------------------
+
+newtype Gap = Gap { _fractoSecs :: Integer }
+  deriving newtype (Eq, Ord, Show, Num, ToNoun, FromNoun)
+
+newtype Unix = Unix { _sinceUnixEpoch :: Gap }
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
+
+newtype Wen = Wen { _sinceUrbitEpoch :: Gap }
+  deriving newtype (Eq, Ord, Show, Num, ToNoun, FromNoun)
+
+
+-- Lenses ----------------------------------------------------------------------
+
+makeLenses ''Gap
+makeLenses ''Unix
+makeLenses ''Wen
+
+diffTime :: Iso' Gap DiffTime
+diffTime = iso fromGap toGap
+  where
+    fromGap = picosecondsToDiffTime . view picoSecs
+    toGap   = view (from picoSecs)  . diffTimeToPicoseconds
+
+sysUTC :: Iso' SystemTime UTCTime
+sysUTC = iso systemToUTCTime utcToSystemTime
+
+utcTime :: Iso' Wen UTCTime
+utcTime = systemTime . sysUTC
+
+unixEpoch :: Wen
+unixEpoch = Wen (Gap 0x8000_000c_ce9e_0d80_0000_0000_0000_0000)
+
+unixSystemTime :: Iso' Unix SystemTime
+unixSystemTime = iso toSys fromSys
+  where
+    toSys (Unix gap) = MkSystemTime (fromInteger sec) (fromInteger ns)
+      where (sec, ns) = quotRem (gap ^. nanoSecs) 1_000_000_000
+    fromSys (MkSystemTime sec ns) =
+      Unix $ (toInteger sec ^. from secs)
+           + (toInteger ns  ^. from nanoSecs)
+
+unix :: Iso' Wen Unix
+unix = iso toUnix fromUnix
+  where
+    toUnix (Wen g)    = Unix (g - unWen unixEpoch)
+    fromUnix (Unix g) = Wen (unWen unixEpoch + g)
+    unWen (Wen x) = x
+
+systemTime :: Iso' Wen SystemTime
+systemTime = unix . unixSystemTime
+
+
+--------------------------------------------------------------------------------
+
+toDenomSecs :: Integer -> Gap -> Integer
+toDenomSecs denom (Gap g) = shiftR (g * denom) 64
+
+fromDenomSecs :: Integer -> Integer -> Gap
+fromDenomSecs denom ds =
+  Gap $ (shiftL ds 64) `div` denom
+
+picoSecs :: Iso' Gap Integer
+picoSecs = iso (toDenomSecs denom) (fromDenomSecs denom)
+  where denom = 1_000_000_000_000
+
+nanoSecs :: Iso' Gap Integer
+nanoSecs = iso (toDenomSecs denom) (fromDenomSecs denom)
+  where denom = 1_000_000_000
+
+microSecs :: Iso' Gap Integer
+microSecs = iso (toDenomSecs denom) (fromDenomSecs denom)
+  where denom = 1_000_000
+
+milliSecs :: Iso' Gap Integer
+milliSecs = iso (toDenomSecs denom) (fromDenomSecs denom)
+  where denom = 1_000
+
+secs :: Iso' Gap Integer
+secs = iso (toDenomSecs denom) (fromDenomSecs denom)
+  where denom = 1
+
+
+--------------------------------------------------------------------------------
+
+now :: IO Wen
+now = view (from systemTime) <$> getSystemTime
+
+gap :: Wen -> Wen -> Gap
+gap (Wen x) (Wen y) | x > y     = x - y
+                    | otherwise = y - x
+
+addGap :: Wen -> Gap -> Wen
+addGap (Wen x) y = Wen (x+y)

pkg/hs/urbit-king/lib/Urbit/Timer.hs

@@ -0,0 +1,45 @@
+module Urbit.Timer ( Timer(..), init, stop, start
+                   , Sys.getSystemTime, sysTimeGapMicroSecs
+                   ) where
+
+import Data.IORef
+import Prelude    hiding (init)
+
+import qualified Data.Time.Clock.System as Sys
+import qualified GHC.Event              as Ev
+
+
+-- Timer Stuff -----------------------------------------------------------------
+
+data Timer = Timer
+  { bState   :: IORef (Maybe Ev.TimeoutKey)
+  , bManager :: Ev.TimerManager
+  }
+
+init :: IO Timer
+init = do
+  st  <- newIORef Nothing
+  man <- Ev.getSystemTimerManager
+  pure (Timer st man)
+
+sysTimeGapMicroSecs :: Sys.SystemTime -> Sys.SystemTime -> Int
+sysTimeGapMicroSecs (Sys.MkSystemTime xSec xNs) (Sys.MkSystemTime ySec yNs) =
+    (+) (1_000_000 * fromIntegral (ySec - xSec))
+        ((fromIntegral yNs - fromIntegral xNs) `quot` 1000)
+
+start :: Timer -> Sys.SystemTime -> IO () -> IO ()
+start timer@(Timer vSt man) time cb = do
+  let fire = cb >> stop timer
+  stop timer
+  now <- Sys.getSystemTime
+  let sleep = sysTimeGapMicroSecs now time
+  -- print (now, time, "->", sleep)
+  if (sleep <= 0) then fire else do
+    key <- Ev.registerTimeout man sleep fire
+    atomicWriteIORef vSt $! Just key
+
+stop :: Timer -> IO ()
+stop (Timer vSt man) =
+  atomicModifyIORef' vSt (Nothing,) >>= \case
+    Just key -> Ev.unregisterTimeout man key
+    Nothing  -> pure ()

pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs

@@ -0,0 +1,305 @@
+{-|
+    Ames IO Driver -- UDP
+-}
+
+module Urbit.Vere.Ames (ames) where
+
+import Urbit.Prelude
+
+import Control.Monad.Extra       hiding (mapM_)
+import Network.Socket            hiding (recvFrom, sendTo)
+import Network.Socket.ByteString
+import Urbit.Arvo                hiding (Fake)
+import Urbit.King.Config
+import Urbit.Vere.Pier.Types
+
+import qualified Data.ByteString as BS
+import qualified Data.Map        as M
+import qualified Urbit.Ob        as Ob
+import qualified Urbit.Time      as Time
+
+-- Types -----------------------------------------------------------------------
+
+data AmesDrv = AmesDrv
+  { aTurfs         :: TVar (Maybe [Turf])
+  , aGalaxies      :: IORef (M.Map Galaxy (Async (), TQueue ByteString))
+  , aSocket        :: Maybe Socket
+  , aListener      :: Async ()
+  , aSendingQueue  :: TQueue (SockAddr, ByteString)
+  , aSendingThread :: Async ()
+  }
+
+data NetworkMode = Fake | Localhost | Real | NoNetwork
+  deriving (Eq, Ord, Show)
+
+
+-- Utils -----------------------------------------------------------------------
+
+galaxyPort :: NetworkMode -> Galaxy -> PortNumber
+galaxyPort Fake (Patp g)      = fromIntegral g + 31337
+galaxyPort Localhost (Patp g) = fromIntegral g + 13337
+galaxyPort Real (Patp g)      = fromIntegral g + 13337
+galaxyPort NoNetwork _        = fromIntegral 0
+
+listenPort :: NetworkMode -> Ship -> PortNumber
+listenPort m s | s < 256 = galaxyPort m (fromIntegral s)
+listenPort m _ = 0
+
+localhost :: HostAddress
+localhost = tupleToHostAddress (127,0,0,1)
+
+inaddrAny :: HostAddress
+inaddrAny = tupleToHostAddress (0,0,0,0)
+
+okayFakeAddr :: AmesDest -> Bool
+okayFakeAddr = \case
+    EachYes _          -> True
+    EachNo (Jammed (AAIpv4 (Ipv4 a) _)) -> a == localhost
+    EachNo (Jammed (AAVoid v)) -> absurd v
+
+localhostSockAddr :: NetworkMode -> AmesDest -> SockAddr
+localhostSockAddr mode = \case
+    EachYes g   -> SockAddrInet (galaxyPort mode g) localhost
+    EachNo (Jammed (AAIpv4 _ p)) -> SockAddrInet (fromIntegral p) localhost
+    EachNo (Jammed (AAVoid v)) -> absurd v
+
+bornEv :: KingId -> Ev
+bornEv inst =
+  EvBlip $ BlipEvNewt $ NewtEvBorn (fromIntegral inst, ()) ()
+
+hearEv :: PortNumber -> HostAddress -> ByteString -> Ev
+hearEv p a bs =
+    EvBlip $ BlipEvAmes $ AmesEvHear () dest (MkBytes bs)
+  where
+    dest = EachNo $ Jammed $ AAIpv4 (Ipv4 a) (fromIntegral p)
+
+_turfText :: Turf -> Text
+_turfText = intercalate "." . reverse . fmap unCord . unTurf
+
+renderGalaxy :: Galaxy -> Text
+renderGalaxy = Ob.renderPatp . Ob.patp . fromIntegral . unPatp
+
+
+--------------------------------------------------------------------------------
+
+{-|
+    inst      -- Process instance number.
+    who       -- Which ship are we?
+    enqueueEv -- Queue-event action.
+    mPort     -- Explicit port override from command line arguments.
+
+    TODO Handle socket exceptions in waitPacket
+
+    4096 is a reasonable number for recvFrom. Packets of that size are
+    not possible on the internet.
+
+    TODO verify that the KingIds match on effects.
+-}
+ames :: forall e. (HasLogFunc e, HasNetworkConfig e)
+     => KingId -> Ship -> Bool -> QueueEv
+     -> (Text -> RIO e ())
+     -> ([Ev], RAcquire e (EffCb e NewtEf))
+ames inst who isFake enqueueEv stderr =
+    (initialEvents, runAmes)
+  where
+    initialEvents :: [Ev]
+    initialEvents = [bornEv inst]
+
+    runAmes :: RAcquire e (EffCb e NewtEf)
+    runAmes = do
+        drv <- mkRAcquire start stop
+        pure (handleEffect drv)
+
+    start :: RIO e AmesDrv
+    start = do
+        aTurfs         <- newTVarIO Nothing
+        aGalaxies      <- newIORef mempty
+        aSocket        <- bindSock
+        aListener      <- async (waitPacket aSocket)
+        aSendingQueue  <- newTQueueIO
+        aSendingThread <- async (sendingThread aSendingQueue aSocket)
+        pure            $ AmesDrv{..}
+
+    netMode :: RIO e NetworkMode
+    netMode = do
+      if isFake
+      then pure Fake
+      else getNetworkingType >>= \case
+        NetworkNormal -> pure Real
+        NetworkLocalhost -> pure Localhost
+        NetworkNone -> pure NoNetwork
+
+    stop :: AmesDrv -> RIO e ()
+    stop AmesDrv{..} = do
+        readIORef aGalaxies >>= mapM_ (cancel . fst)
+
+        cancel aSendingThread
+        cancel aListener
+        io $ maybeM (pure ()) (close') (pure aSocket)
+        -- io $ close' aSocket
+
+    bindSock :: RIO e (Maybe Socket)
+    bindSock = getBindAddr >>= doBindSocket
+        where
+           getBindAddr = netMode >>= \case
+              Fake      -> pure $ Just localhost
+              Localhost -> pure $ Just localhost
+              Real      -> pure $ Just inaddrAny
+              NoNetwork -> pure Nothing
+
+           doBindSocket :: Maybe HostAddress -> RIO e (Maybe Socket)
+           doBindSocket Nothing = pure Nothing
+           doBindSocket (Just bindAddr) = do
+             mode <- netMode
+             mPort <- getAmesPort
+             let ourPort = maybe (listenPort mode who) fromIntegral mPort
+             s  <- io $ socket AF_INET Datagram defaultProtocol
+
+             logTrace $ displayShow ("(ames) Binding to port ", ourPort)
+             let addr = SockAddrInet ourPort bindAddr
+             () <- io $ bind s addr
+
+             pure $ Just s
+
+    waitPacket :: Maybe Socket -> RIO e ()
+    waitPacket Nothing = pure ()
+    waitPacket (Just s) = forever $ do
+        (bs, addr) <- io $ recvFrom s 4096
+        logTrace $ displayShow ("(ames) Received packet from ", addr)
+        case addr of
+            SockAddrInet p a -> atomically (enqueueEv $ hearEv p a bs)
+            _                -> pure ()
+
+    handleEffect :: AmesDrv -> NewtEf -> RIO e ()
+    handleEffect drv@AmesDrv{..} = \case
+      NewtEfTurf (_id, ()) turfs -> do
+          atomically $ writeTVar aTurfs (Just turfs)
+
+      NewtEfSend (_id, ()) dest (MkBytes bs) -> do
+          atomically (readTVar aTurfs) >>= \case
+            Nothing -> pure ()
+            Just turfs -> do
+              mode <- netMode
+              (sendPacket drv mode dest bs)
+
+    sendPacket :: AmesDrv -> NetworkMode -> AmesDest -> ByteString -> RIO e ()
+
+    sendPacket AmesDrv{..} NoNetwork dest bs = pure ()
+
+    sendPacket AmesDrv{..} Fake dest bs = do
+      when (okayFakeAddr dest) $ atomically $
+        writeTQueue aSendingQueue ((localhostSockAddr Fake dest), bs)
+
+    -- In localhost only mode, regardless of the actual destination, send it to
+    -- localhost.
+    sendPacket AmesDrv{..} Localhost dest bs = atomically $
+      writeTQueue aSendingQueue ((localhostSockAddr Localhost dest), bs)
+
+    sendPacket AmesDrv{..} Real (EachYes galaxy) bs = do
+      galaxies <- readIORef aGalaxies
+      queue <- case M.lookup galaxy galaxies of
+        Just (_, queue) -> pure queue
+        Nothing -> do
+          inQueue <- newTQueueIO
+          thread <- async $ galaxyResolver galaxy aTurfs inQueue aSendingQueue
+          modifyIORef (aGalaxies) (M.insert galaxy (thread, inQueue))
+          pure inQueue
+
+      atomically $ writeTQueue queue bs
+
+    sendPacket AmesDrv{..} Real (EachNo (Jammed (AAIpv4 a p))) bs = do
+      let addr = SockAddrInet (fromIntegral p) (unIpv4 a)
+      atomically $ writeTQueue aSendingQueue (addr, bs)
+
+    sendPacket AmesDrv{..} Real (EachNo (Jammed (AAVoid v))) bs = do
+      pure (absurd v)
+
+    -- An outbound queue of messages. We can only write to a socket from one
+    -- thread, so coalesce those writes here.
+    sendingThread :: TQueue (SockAddr, ByteString) -> Maybe Socket -> RIO e ()
+    sendingThread queue Nothing = pure ()
+    sendingThread queue (Just socket) = forever $
+      do
+        (dest, bs) <- atomically $ readTQueue queue
+        logTrace $ displayShow ("(ames) Sending packet to ", socket, dest)
+        sendAll bs dest
+      where
+        sendAll bs dest = do
+          bytesSent <- io $ sendTo socket bs dest
+          when (bytesSent /= BS.length bs) $ do
+            sendAll (drop bytesSent bs) dest
+
+    -- Asynchronous thread per galaxy which handles domain resolution, and can
+    -- block its own queue of ByteStrings to send.
+    --
+    -- Maybe perform the resolution asynchronously, injecting into the resolver
+    -- queue as a message.
+    --
+    -- TODO: Figure out how the real haskell time library works.
+    galaxyResolver :: Galaxy -> TVar (Maybe [Turf]) -> TQueue ByteString
+                   -> TQueue (SockAddr, ByteString)
+                   -> RIO e ()
+    galaxyResolver galaxy turfVar incoming outgoing =
+      loop Nothing Time.unixEpoch
+      where
+        loop :: Maybe SockAddr -> Time.Wen -> RIO e ()
+        loop lastGalaxyIP lastLookupTime = do
+          packet <- atomically $ readTQueue incoming
+
+          checkIP lastGalaxyIP lastLookupTime >>= \case
+            (Nothing, t) -> do
+              -- We've failed to lookup the IP. Drop the outbound packet
+              -- because we have no IP for our galaxy, including possible
+              -- previous IPs.
+              logDebug $ displayShow
+                ("(ames) Dropping packet; no ip for galaxy ", galaxy)
+              loop Nothing t
+            (Just ip, t) -> do
+              queueSendToGalaxy ip packet
+              loop (Just ip) t
+
+        checkIP :: Maybe SockAddr -> Time.Wen
+                -> RIO e (Maybe SockAddr, Time.Wen)
+        checkIP lastIP lastLookupTime = do
+          current <- io $ Time.now
+          if (Time.gap current lastLookupTime ^. Time.secs) < 300
+          then pure (lastIP, lastLookupTime)
+          else do
+            toCheck <- fromMaybe [] <$> atomically (readTVar turfVar)
+            mybIp <- resolveFirstIP lastIP toCheck
+            timeAfterResolution <- io $ Time.now
+            pure (mybIp, timeAfterResolution)
+
+        resolveFirstIP :: Maybe SockAddr -> [Turf] -> RIO e (Maybe SockAddr)
+        resolveFirstIP prevIP [] = do
+          stderr $ "ames: czar at " ++ renderGalaxy galaxy ++ ": not found"
+          logDebug $ displayShow
+              ("(ames) Failed to lookup IP for ", galaxy)
+          pure prevIP
+
+        resolveFirstIP prevIP (x:xs) = do
+          hostname <- buildDNS galaxy x
+          let portstr = show $ galaxyPort Real galaxy
+          listIPs <- io $ getAddrInfo Nothing (Just hostname) (Just portstr)
+          case listIPs of
+            []     -> resolveFirstIP prevIP xs
+            (y:ys) -> do
+              let sockaddr = Just $ addrAddress y
+              when (sockaddr /= prevIP) $
+                stderr $ "ames: czar " ++ renderGalaxy galaxy ++ ": ip " ++
+                         (tshow $ addrAddress y)
+              logDebug $ displayShow
+                ("(ames) Looked up ", hostname, portstr, y)
+              pure sockaddr
+
+        buildDNS :: Galaxy -> Turf -> RIO e String
+        buildDNS (Patp g) turf = do
+          let nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral g
+          name <- case stripPrefix "~" nameWithSig of
+              Nothing -> error "Urbit.ob didn't produce string with ~"
+              Just x  -> pure (unpack x)
+          pure $ name ++ "." ++ (unpack $ _turfText turf)
+
+        queueSendToGalaxy :: SockAddr -> ByteString -> RIO e ()
+        queueSendToGalaxy inet packet = do
+          atomically $ writeTQueue outgoing (inet, packet)

pkg/hs/urbit-king/lib/Urbit/Vere/Behn.hs

@@ -0,0 +1,48 @@
+{-|
+    Behn: Timer Driver
+-}
+
+module Urbit.Vere.Behn (behn) where
+
+import Urbit.Arvo            hiding (Behn)
+import Urbit.Prelude
+import Urbit.Vere.Pier.Types
+
+import Urbit.Time  (Wen)
+import Urbit.Timer (Timer)
+
+import qualified Urbit.Time  as Time
+import qualified Urbit.Timer as Timer
+
+
+-- Behn Stuff ------------------------------------------------------------------
+
+bornEv :: KingId -> Ev
+bornEv king = EvBlip $ BlipEvBehn $ BehnEvBorn (king, ()) ()
+
+wakeEv :: Ev
+wakeEv = EvBlip $ BlipEvBehn $ BehnEvWake () ()
+
+sysTime = view Time.systemTime
+
+behn :: KingId -> QueueEv -> ([Ev], Acquire (EffCb e BehnEf))
+behn king enqueueEv =
+    (initialEvents, runBehn)
+  where
+    initialEvents = [bornEv king]
+
+    runBehn :: Acquire (EffCb e BehnEf)
+    runBehn = do
+        tim <- mkAcquire Timer.init Timer.stop
+        pure (handleEf tim)
+
+    handleEf :: Timer -> BehnEf -> RIO e ()
+    handleEf b = io . \case
+        BehnEfVoid v            -> absurd v
+        BehnEfDoze (i, ()) mWen -> do
+            when (i == king) (doze b mWen)
+
+    doze :: Timer -> Maybe Wen -> IO ()
+    doze tim = \case
+        Nothing -> Timer.stop tim
+        Just t  -> Timer.start tim (sysTime t) $ atomically (enqueueEv wakeEv)

pkg/hs/urbit-king/lib/Urbit/Vere/Clay.hs

@@ -0,0 +1,237 @@
+{-|
+    UNIX Filesystem Driver
+-}
+
+module Urbit.Vere.Clay (clay) where
+
+import Urbit.Arvo            hiding (Term)
+import Urbit.King.Config
+import Urbit.Prelude
+import Urbit.Vere.Pier.Types
+
+import Conduit
+import RIO.Directory
+import RIO.FilePath
+
+import qualified Data.Conduit.Combinators as CC
+import qualified Data.Map.Strict          as M
+import qualified Data.Set                 as S
+
+
+--------------------------------------------------------------------------------
+
+data ClayDrv = ClayDrv
+  { cdMountPoints :: TVar (Map Desk (Map FilePath Int))
+  }
+
+deskToPath :: Desk -> FilePath
+deskToPath (Desk (Cord t)) = unpack t
+
+-- | The hard coded mime type of every file.
+textPlain = Path [(MkKnot "text"), (MkKnot "plain")]
+
+-- | Filter for dotfiles, tempfiles and backup files.
+validClaySyncPath :: FilePath -> Bool
+validClaySyncPath fp = hasPeriod && notTildeFile && notDotHash && notDoubleHash
+  where
+    fileName = takeFileName fp
+    hasPeriod = elem '.' fileName
+    notTildeFile = not $ "~" `isSuffixOf` fileName
+    notDotHash = not $ ".#" `isPrefixOf` fileName
+    notDoubleHash =
+      not $ ("#" `isPrefixOf` fileName) && ("#" `isSuffixOf` fileName)
+
+{-|
+    Returns a list of the result of running a function on each valid
+    file in the directory fp. Runnable in IO.
+-}
+foreachFileIn :: (MonadUnliftIO m)
+              => FilePath -> (FilePath -> (ResourceT m) a) -> m [a]
+foreachFileIn fp fun =
+  runConduitRes $ (sourceDirectoryDeep False fp)
+               .| filterC validClaySyncPath
+               .| CC.mapM fun
+               .| sinkList
+
+{-|
+    Note: Vere just reuses +mug, but since the actual hash function is
+    an implementation detail which doesn't leave the io driver, we just
+    use the standard hash.
+-}
+getHashOfFile :: (MonadIO m) => FilePath -> m (FilePath, Int)
+getHashOfFile fp = do
+  bs <- readFile fp
+  let !h = hash bs
+  pure (fp, h)
+
+{-|
+   Takes an initial snapshot of the filesystem, recording what files exist and
+   what their hashes are.
+-}
+takeFilesystemSnapshot :: FilePath -> RIO e (Map FilePath Int)
+takeFilesystemSnapshot fp = do
+  exists <- doesDirectoryExist fp
+  if not exists then
+    pure M.empty
+  else
+    M.fromList <$> foreachFileIn fp getHashOfFile
+
+{-|
+    Check an existing filepath against a snapshot of files that existed on disk
+    the last time we checked. Returns Either (unchanged) (new file data).
+-}
+checkFileForUpdates :: (MonadIO m)
+                    => Map FilePath Int -> FilePath
+                    -> m (Either FilePath (FilePath, Mime, Int))
+checkFileForUpdates snapshot fp = do
+  bs <- readFile fp
+  let !newHash = hash bs
+  pure $ case lookup fp snapshot of
+    -- text/plain is the hardcoded mime type of every file sent to clay.
+    Nothing -> Right (fp, (Mime textPlain (File (Octs bs))), newHash)
+    Just i -> if i == newHash then Left fp
+              else Right (fp, (Mime textPlain (File (Octs bs))), newHash)
+
+{-|
+    Given a previous snapshot of the filesystem, produces a list of changes
+-}
+buildActionListFromDifferences :: FilePath -> Map FilePath Int
+                               -> RIO e [(FilePath, Maybe (Mime, Int))]
+buildActionListFromDifferences fp snapshot = do
+  checks <- foreachFileIn fp (checkFileForUpdates snapshot)
+
+  let changedItems = rights checks <&> \(fp, m, i) -> (fp, Just (m, i))
+
+  let existsSet = S.fromList $ flip map checks $ \case
+        Left fp          -> fp
+        Right (fp, _, _) -> fp
+  let deletedSet = S.difference (M.keysSet snapshot) existsSet
+  let deletedItems = (toList deletedSet) <&> \x -> (x, Nothing)
+
+  pure $ sort (deletedItems ++ changedItems)
+
+--------------------------------------------------------------------------------
+
+clay :: forall e. (HasPierConfig e, HasLogFunc e)
+     => KingId -> QueueEv -> ([Ev], RAcquire e (EffCb e SyncEf))
+clay king enqueueEv =
+    (initialEvents, runSync)
+  where
+    initialEvents = [
+      EvBlip $ BlipEvBoat $ BoatEvBoat () ()
+      -- TODO: In the case of -A, we need to read all the data from the
+      -- specified directory and shove it into an %into event.
+      ]
+
+    runSync :: RAcquire e (EffCb e SyncEf)
+    runSync = handleEffect <$> mkRAcquire start stop
+
+    start :: RIO e ClayDrv
+    start = ClayDrv <$> newTVarIO mempty
+    stop c = pure ()
+
+    handleEffect :: ClayDrv -> SyncEf -> RIO e ()
+    handleEffect cd = \case
+      SyncEfHill _ mountPoints -> do
+        logDebug $ displayShow ("(clay) known mount points:", mountPoints)
+        pierPath <- view pierPathL
+        mountPairs <- flip mapM mountPoints $ \desk -> do
+          ss <- takeFilesystemSnapshot (pierPath </> (deskToPath desk))
+          pure (desk, ss)
+        atomically $ writeTVar (cdMountPoints cd) (M.fromList mountPairs)
+
+      SyncEfDirk p desk -> do
+        logDebug $ displayShow ("(clay) dirk:", p, desk)
+        m <- atomically $ readTVar (cdMountPoints cd)
+        let snapshot = M.findWithDefault M.empty desk m
+        pierPath <- view pierPathL
+        let dir = pierPath </> deskToPath desk
+        actions <- buildActionListFromDifferences dir snapshot
+
+        logDebug $ displayShow ("(clay) dirk actions: ", actions)
+
+        let !intoList = map (actionsToInto dir) actions
+        atomically $ enqueueEv $ EvBlip $ BlipEvSync $
+            SyncEvInto (Some (king, ())) desk False intoList
+
+        atomically $ modifyTVar
+            (cdMountPoints cd)
+            (applyActionsToMountPoints desk actions)
+
+      SyncEfErgo p desk actions -> do
+        logDebug $ displayShow ("(clay) ergo:", p, desk, actions)
+
+        m <- atomically $ readTVar (cdMountPoints cd)
+        let mountPoint = M.findWithDefault M.empty desk m
+
+        pierPath <- view pierPathL
+        let dir = pierPath </> deskToPath desk
+        let hashedActions = map (calculateActionHash dir) actions
+        for_ hashedActions (performAction mountPoint)
+
+        atomically $ modifyTVar
+            (cdMountPoints cd)
+            (applyActionsToMountPoints desk hashedActions)
+
+      SyncEfOgre p desk -> do
+        logDebug $ displayShow ("(clay) ogre:", p, desk)
+        pierPath <- view pierPathL
+        removeDirectoryRecursive $ pierPath </> deskToPath desk
+        atomically $ modifyTVar (cdMountPoints cd) (M.delete desk)
+
+
+    -- Change the structures off of the event into something we can work with
+    -- in Unix.
+    calculateActionHash :: FilePath -> (Path, Maybe Mime)
+                        -> (FilePath, Maybe (Mime, Int))
+    calculateActionHash base (p, Nothing) = (base </> pathToFilePath p, Nothing)
+    calculateActionHash base (p, Just (Mime t f)) =
+      (base </> pathToFilePath p, Just ((Mime t f), (hash $ unOcts $ unFile f)))
+
+    -- Performs the actions on the actual filesystem
+    performAction :: (Map FilePath Int) -> (FilePath, Maybe (Mime, Int))
+                  -> RIO e ()
+    performAction m (fp, Nothing) = do
+      logDebug $ displayShow ("(clay) deleting file ", fp)
+      removeFile fp
+    performAction m (fp, Just ((Mime _ (File (Octs bs)), hash)))
+        | skip = logDebug $
+                 displayShow ("(clay) skipping unchanged file update " , fp)
+        | otherwise = do
+            logDebug $ displayShow ("(clay) updating file " , fp)
+            createDirectoryIfMissing True $ takeDirectory fp
+            writeFile fp bs
+      where
+        skip = case M.lookup fp m of
+          Nothing -> False
+          Just i  -> i == hash
+
+    -- Apply the actions to our internal snapshots
+    applyActionsToMountPoints :: Desk
+                              -> [(FilePath, Maybe (Mime, Int))]
+                              -> (Map Desk (Map FilePath Int))
+                              -> (Map Desk (Map FilePath Int))
+    applyActionsToMountPoints desk actions m = M.alter change desk m
+      where
+        change (Just fileMap) = Just (foldl' applySyncAction fileMap actions)
+        change Nothing        = change (Just M.empty)
+
+        -- Applies the sync mutations specified.
+        applySyncAction :: (Map FilePath Int)
+                        -> (FilePath, Maybe (Mime, Int))
+                        -> (Map FilePath Int)
+        applySyncAction m (fp, Nothing)       = M.delete fp m
+        applySyncAction m (fp, (Just (_, h))) = M.insert fp h m
+
+    -- Changes an action list item into a form injectable into Urbit
+    actionsToInto :: FilePath -> (FilePath, Maybe (Mime, Int))
+                  -> (Path, Maybe Mime)
+    actionsToInto prefix (fp, mybData) = (p, mybOutData)
+      where
+        p = filePathToPath strippedFp
+        strippedFp = case stripPrefix prefix fp of
+          Nothing -> error "Impossible missing prefix"
+          Just x  -> x
+        mybOutData = case mybData of
+          Nothing     -> Nothing
+          Just (m, i) -> Just m

pkg/hs/urbit-king/lib/Urbit/Vere/Dawn.hs

@@ -0,0 +1,307 @@
+{-|
+    Use etherium to access PKI information.
+-}
+
+module Urbit.Vere.Dawn where
+
+import Urbit.Arvo.Common
+import Urbit.Arvo.Event  hiding (Address)
+import Urbit.Prelude     hiding (Call, rights, to)
+
+import Data.Bits                     (xor)
+import Data.List                     (nub)
+import Data.Text                     (splitOn)
+import Network.Ethereum.Account
+import Network.Ethereum.Api.Eth
+import Network.Ethereum.Api.Provider
+import Network.Ethereum.Api.Types    hiding (blockNumber)
+import Network.Ethereum.Web3
+import Network.HTTP.Client.TLS
+
+import qualified Crypto.Hash.SHA256    as SHA256
+import qualified Crypto.Hash.SHA512    as SHA512
+import qualified Crypto.Sign.Ed25519   as Ed
+import qualified Data.Binary           as B
+import qualified Data.ByteArray        as BA
+import qualified Data.ByteString       as BS
+import qualified Data.ByteString.Char8 as C
+import qualified Network.Ethereum.Ens  as Ens
+import qualified Network.HTTP.Client   as C
+import qualified Urbit.Azimuth         as AZ
+import qualified Urbit.Ob              as Ob
+
+-- During boot, use the infura provider
+provider = HttpProvider
+  "https://mainnet.infura.io/v3/196a7f37c7d54211b4a07904ec73ad87"
+
+-- Conversion Utilities --------------------------------------------------------
+
+-- Takes the web3's bytes representation and changes the endianness.
+bytes32ToBS :: BytesN 32 -> ByteString
+bytes32ToBS = reverse . BA.pack . BA.unpack
+
+toBloq :: Quantity -> Bloq
+toBloq = fromIntegral . unQuantity
+
+passFromEth :: BytesN 32 -> BytesN 32 -> UIntN 32 -> Pass
+passFromEth enc aut sut | sut /= 1 =
+      Pass (Ed.PublicKey mempty) (Ed.PublicKey mempty)
+passFromEth enc aut sut =
+      Pass (decode aut) (decode enc)
+    where
+      decode = Ed.PublicKey . bytes32ToBS
+
+clanFromShip :: Ship -> Ob.Class
+clanFromShip = Ob.clan . Ob.patp . fromIntegral
+
+shipSein :: Ship -> Ship
+shipSein = Ship . fromIntegral . Ob.fromPatp . Ob.sein . Ob.patp . fromIntegral
+
+renderShip :: Ship -> Text
+renderShip = Ob.renderPatp . Ob.patp . fromIntegral
+
+-- Data Validation -------------------------------------------------------------
+
+-- Derive public key structure from the key derivation seed structure
+ringToPass :: Ring -> Pass
+ringToPass Ring{..} = Pass{..}
+  where
+    passCrypt = decode ringCrypt
+    passSign = decode ringSign
+    decode = fst . fromJust . Ed.createKeypairFromSeed_
+    fromJust = \case
+      Nothing -> error "Invalid seed passed to createKeypairFromSeed"
+      Just x -> x
+
+-- Azimuth Functions -----------------------------------------------------------
+
+-- Perform a request to azimuth at a certain block number
+withAzimuth :: Quantity
+            -> Address
+            -> DefaultAccount Web3 a
+            -> Web3 a
+withAzimuth bloq azimuth action =
+    withAccount () $
+      withParam (to .~ azimuth) $
+        withParam (block .~ BlockWithNumber bloq)
+          action
+
+-- Retrieves the EthPoint information for an individual point.
+retrievePoint :: Quantity -> Address -> Ship -> Web3 EthPoint
+retrievePoint bloq azimuth ship =
+  withAzimuth bloq azimuth $ do
+    (encryptionKey,
+     authenticationKey,
+     hasSponsor,
+     active,
+     escapeRequested,
+     sponsor,
+     escapeTo,
+     cryptoSuite,
+     keyRevision,
+     continuityNum) <- AZ.points (fromIntegral ship)
+
+    let escapeState = if escapeRequested
+                      then Just $ Ship $ fromIntegral escapeTo
+                      else Nothing
+
+    -- The hoon version also sets this to all 0s and then does nothing with it.
+    let epOwn = (0, 0, 0, 0)
+
+    let epNet = if not active
+        then Nothing
+        else Just
+          ( fromIntegral keyRevision
+          , passFromEth encryptionKey authenticationKey cryptoSuite
+          , fromIntegral continuityNum
+          , (hasSponsor, Ship (fromIntegral sponsor))
+          , escapeState
+          )
+
+    -- TODO: wtf?
+    let epKid = case clanFromShip ship of
+           Ob.Galaxy -> Just (0, setToHoonSet mempty)
+           Ob.Star   -> Just (0, setToHoonSet mempty)
+           _         -> Nothing
+
+    pure EthPoint{..}
+
+-- Retrieves information about all the galaxies from Ethereum.
+retrieveGalaxyTable :: Quantity -> Address -> Web3 (Map Ship (Rift, Life, Pass))
+retrieveGalaxyTable bloq azimuth =
+    withAzimuth bloq azimuth $ mapFromList <$> mapM getRow [0..255]
+  where
+    getRow idx = do
+      (encryptionKey, authenticationKey, _, _, _, _, _, cryptoSuite,
+       keyRev, continuity) <- AZ.points idx
+      pure ( fromIntegral idx
+           , ( fromIntegral continuity
+             , fromIntegral keyRev
+             , passFromEth encryptionKey authenticationKey cryptoSuite
+             )
+          )
+
+-- Reads the three Ames domains from Ethereum, removing duplicates
+readAmesDomains :: Quantity -> Address -> Web3 [Turf]
+readAmesDomains bloq azimuth =
+    withAzimuth bloq azimuth $ nub <$> mapM getTurf [0..2]
+  where
+    getTurf idx =
+      Turf . fmap Cord . reverse . splitOn "." <$> AZ.dnsDomains idx
+
+
+validateShipAndGetImmediateSponsor :: Quantity -> Address -> Seed -> Web3 Ship
+validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
+  case clanFromShip ship of
+    Ob.Comet -> validateComet
+    Ob.Moon  -> validateMoon
+    _        -> validateRest
+  where
+    validateComet = do
+      -- A comet address is the fingerprint of the keypair
+      let shipFromPass = cometFingerprint $ ringToPass ring
+      when (ship /= shipFromPass) $
+        fail ("comet name doesn't match fingerprint " ++ show ship ++ " vs " ++
+              show shipFromPass)
+      when (life /= 1) $
+        fail ("comet can never be re-keyed")
+      pure (shipSein ship)
+
+    validateMoon = do
+      -- TODO: The current code in zuse does nothing, but we should be able to
+      -- try to validate the oath against the current as exists planet on
+      -- chain.
+      pure $ shipSein ship
+
+    validateRest = do
+      putStrLn ("boot: retrieving " ++ renderShip ship ++ "'s public keys")
+
+      whoP <- retrievePoint block azimuth ship
+      case epNet whoP of
+        Nothing -> fail "ship not keyed"
+        Just (netLife, pass, contNum, (hasSponsor, who), _) -> do
+          when (netLife /= life) $
+              fail ("keyfile life mismatch; keyfile claims life " ++
+                    show life ++ ", but Azimuth claims life " ++
+                    show netLife)
+          when ((ringToPass ring) /= pass) $
+              fail "keyfile does not match blockchain"
+          -- TODO: The hoon code does a breach check, but the C code never
+          -- supplies the data necessary for it to function.
+          pure who
+
+
+-- Walk through the sponsorship chain retrieving the actual sponsorship chain
+-- as it exists on Ethereum.
+getSponsorshipChain :: Quantity -> Address -> Ship -> Web3 [(Ship,EthPoint)]
+getSponsorshipChain block azimuth = loop
+  where
+    loop ship = do
+      putStrLn ("boot: retrieving keys for sponsor " ++ renderShip ship)
+      ethPoint <- retrievePoint block azimuth ship
+
+      case (clanFromShip ship, epNet ethPoint) of
+        (Ob.Comet, _) -> fail "Comets cannot be sponsors"
+        (Ob.Moon, _)  -> fail "Moons cannot be sponsors"
+
+        (_, Nothing) ->
+            fail $ unpack ("Ship " ++ renderShip ship ++ " not booted")
+
+        (Ob.Galaxy, Just _) -> pure [(ship, ethPoint)]
+
+        (_, Just (_, _, _, (False, _), _)) ->
+            fail $ unpack ("Ship " ++ renderShip ship ++ " has no sponsor")
+
+        (_, Just (_, _, _, (True, sponsor), _)) -> do
+            chain <- loop sponsor
+            pure $ chain ++ [(ship, ethPoint)]
+
+
+-- Produces either an error or a validated boot event structure.
+dawnVent :: Seed -> RIO e (Either Text Dawn)
+dawnVent dSeed@(Seed ship life ring oaf) = do
+  ret <- runWeb3' provider $ do
+    block <- blockNumber
+    putStrLn ("boot: ethereum block #" ++ tshow block)
+
+    putStrLn "boot: retrieving azimuth contract"
+    azimuth <- withAccount () $ Ens.resolve "azimuth.eth"
+
+    immediateSponsor <- validateShipAndGetImmediateSponsor block azimuth dSeed
+    dSponsor <- getSponsorshipChain block azimuth immediateSponsor
+
+    putStrLn "boot: retrieving galaxy table"
+    dCzar <- mapToHoonMap <$> retrieveGalaxyTable block azimuth
+
+    putStrLn "boot: retrieving network domains"
+    dTurf <- readAmesDomains block azimuth
+
+    let dBloq = toBloq block
+    let dNode = Nothing
+    pure $ MkDawn{..}
+
+  case ret of
+    Left x  -> pure $ Left $ tshow x
+    Right y -> pure $ Right y
+
+
+dawnCometList :: RIO e [Ship]
+dawnCometList = do
+  -- Get the jamfile with the list of stars accepting comets right now.
+  manager <- io $ C.newManager tlsManagerSettings
+  request <- io $ C.parseRequest "https://bootstrap.urbit.org/comet-stars.jam"
+  response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
+  let body = toStrict $ C.responseBody response
+
+  noun <- cueBS body & either throwIO pure
+  fromNounErr noun & either (throwIO . uncurry ParseErr) pure
+
+
+-- Comet Mining ----------------------------------------------------------------
+
+mix :: BS.ByteString -> BS.ByteString -> BS.ByteString
+mix a b = BS.pack $ loop (BS.unpack a) (BS.unpack b)
+  where
+    loop [] []         = []
+    loop a  []         = a
+    loop [] b          = b
+    loop (x:xs) (y:ys) = (xor x y) : loop xs ys
+
+shas :: BS.ByteString -> BS.ByteString -> BS.ByteString
+shas salt = SHA256.hash . mix salt . SHA256.hash
+
+shaf :: BS.ByteString -> BS.ByteString -> BS.ByteString
+shaf salt ruz = (mix a b)
+  where
+    haz = shas salt ruz
+    a = (take 16 haz)
+    b = (drop 16 haz)
+
+cometFingerprintBS :: Pass -> ByteString
+cometFingerprintBS = (shaf $ C.pack "bfig") . passToBS
+
+cometFingerprint :: Pass -> Ship
+cometFingerprint = Ship . B.decode . fromStrict . reverse . cometFingerprintBS
+
+tryMineComet :: Set Ship -> Word64 -> Maybe Seed
+tryMineComet ships seed =
+  if member shipSponsor ships
+  then Just $ Seed shipName 1 ring Nothing
+  else Nothing
+  where
+    -- Hash the incoming seed into a 64 bytes.
+    baseHash = SHA512.hash $ toStrict $ B.encode seed
+    signSeed = (take 32 baseHash)
+    ringSeed = (drop 32 baseHash)
+    ring = Ring signSeed ringSeed
+    pass = ringToPass ring
+    shipName = cometFingerprint pass
+    shipSponsor = shipSein shipName
+
+mineComet :: Set Ship -> Word64 -> Seed
+mineComet ships = loop
+  where
+    loop eny =
+      case (tryMineComet ships eny) of
+        Nothing -> loop (eny + 1)
+        Just x  -> x

pkg/hs/urbit-king/lib/Urbit/Vere/Http.hs

@@ -0,0 +1,25 @@
+{-|
+    HTTP Driver
+-}
+
+module Urbit.Vere.Http where
+
+import ClassyPrelude
+import Urbit.Arvo
+import Urbit.Noun
+
+import qualified Data.CaseInsensitive as CI
+import qualified Network.HTTP.Types   as HT
+
+--------------------------------------------------------------------------------
+
+convertHeaders :: [HT.Header] -> [Header]
+convertHeaders = fmap f
+  where
+    f (k, v) = Header (Cord $ decodeUtf8 $ CI.foldedCase k)
+                      (MkBytes v)
+
+unconvertHeaders :: [Header] -> [HT.Header]
+unconvertHeaders = fmap f
+  where
+    f (Header (Cord k) (MkBytes v)) = (CI.mk (encodeUtf8 k), v)

pkg/hs/urbit-king/lib/Urbit/Vere/Http/Client.hs

@@ -0,0 +1,158 @@
+{-|
+    Http Client Driver
+
+    TODO When making a request, handle the case where the request id is
+    already in use.
+-}
+
+module Urbit.Vere.Http.Client where
+
+import Urbit.Arvo            (BlipEv(..), Ev(..), HttpClientEf(..),
+                              HttpClientEv(..), HttpClientReq(..),
+                              HttpEvent(..), KingId, ResponseHeader(..))
+import Urbit.Prelude         hiding (Builder)
+import Urbit.Vere.Pier.Types
+
+import Urbit.Vere.Http
+
+import qualified Data.Map                as M
+import qualified Network.HTTP.Client     as H
+import qualified Network.HTTP.Client.TLS as TLS
+import qualified Network.HTTP.Types      as HT
+
+-- Types -----------------------------------------------------------------------
+
+type ReqId = Word
+
+data HttpClientDrv = HttpClientDrv
+  { hcdManager :: H.Manager
+  , hcdLive    :: TVar (Map ReqId (Async ()))
+  }
+
+--------------------------------------------------------------------------------
+
+cvtReq :: HttpClientReq -> Maybe H.Request
+cvtReq r =
+  H.parseRequest (unpack (unCord $ url r)) <&> \init -> init
+    { H.method = encodeUtf8 $ tshow (method r)
+    , H.requestHeaders = unconvertHeaders (headerList r)
+    , H.requestBody =
+        H.RequestBodyBS $ case body r of
+                            Nothing        -> ""
+                            Just (Octs bs) -> bs
+    }
+
+cvtRespHeaders :: H.Response a -> ResponseHeader
+cvtRespHeaders resp =
+    ResponseHeader (fromIntegral $ HT.statusCode (H.responseStatus resp)) heads
+  where
+    heads = convertHeaders (H.responseHeaders resp)
+
+bornEv :: KingId -> Ev
+bornEv king =
+    EvBlip $ BlipEvHttpClient $ HttpClientEvBorn (king, ()) ()
+
+--------------------------------------------------------------------------------
+
+client :: forall e. HasLogFunc e
+       => KingId -> QueueEv -> ([Ev], RAcquire e (EffCb e HttpClientEf))
+client kingId enqueueEv = (initialEvents, runHttpClient)
+  where
+    initialEvents :: [Ev]
+    initialEvents = [bornEv kingId]
+
+    runHttpClient :: RAcquire e (EffCb e HttpClientEf)
+    runHttpClient = handleEffect <$> mkRAcquire start stop
+
+    start :: RIO e (HttpClientDrv)
+    start = HttpClientDrv <$>
+      (io $ H.newManager TLS.tlsManagerSettings) <*>
+      newTVarIO M.empty
+
+    stop :: HttpClientDrv -> RIO e ()
+    stop HttpClientDrv{..} = do
+      -- Cancel all the outstanding asyncs, ignoring any exceptions.
+      liveThreads <- atomically $ readTVar hcdLive
+      mapM_ cancel liveThreads
+
+    handleEffect :: HttpClientDrv -> HttpClientEf -> RIO e ()
+    handleEffect drv = \case
+      HCERequest _ id req -> newReq drv id req
+      HCECancelRequest _ id -> cancelReq drv id
+
+    newReq :: HttpClientDrv -> ReqId -> HttpClientReq -> RIO e ()
+    newReq drv id req = do
+      async <- runReq drv id req
+      atomically $ modifyTVar (hcdLive drv) (insertMap id async)
+
+    -- The problem with the original http client code was that it was written
+    -- to the idea of what the events "should have" been instead of what they
+    -- actually were. This means that this driver doesn't run like the vere
+    -- http client driver. The vere driver was written assuming that parts of
+    -- events could be compressed together: a Start might contain the only
+    -- chunk of data and immediately complete, where here the Start event, the
+    -- Continue (with File) event, and the Continue (completed) event are three
+    -- separate things.
+    runReq :: HttpClientDrv -> ReqId -> HttpClientReq -> RIO e (Async ())
+    runReq HttpClientDrv{..} id req = async $
+      case cvtReq req of
+        Nothing -> do
+          logDebug $ displayShow ("(malformed http client request)", id, req)
+          planEvent id (Cancel ())
+        Just r -> do
+          logDebug $ displayShow ("(http client request)", id, req)
+          withRunInIO $ \run ->
+            H.withResponse r hcdManager $ \x -> run (exec x)
+      where
+        recv :: H.BodyReader -> RIO e (Maybe ByteString)
+        recv read = io $ read <&> \case chunk | null chunk -> Nothing
+                                              | otherwise  -> Just chunk
+
+        exec :: H.Response H.BodyReader -> RIO e ()
+        exec resp = do
+          let headers  = cvtRespHeaders resp
+              getChunk = recv (H.responseBody resp)
+              loop     = getChunk >>= \case
+                           Nothing -> planEvent id (Continue Nothing True)
+                           Just bs -> do
+                             planEvent id $
+                               Continue (Just $ File $ Octs bs) False
+                             loop
+          planEvent id (Start headers Nothing False)
+          loop
+
+    planEvent :: ReqId -> HttpEvent -> RIO e ()
+    planEvent id ev = do
+      logDebug $ displayShow ("(http client response)", id, (describe ev))
+      atomically $ enqueueEv $ EvBlip $ BlipEvHttpClient $
+        HttpClientEvReceive (kingId, ()) (fromIntegral id) ev
+
+    -- show an HttpEvent with byte count instead of raw data
+    describe :: HttpEvent -> String
+    describe (Start header Nothing final) =
+      "(Start " ++ (show header) ++ " ~ " ++ (show final)
+    describe (Start header (Just (File (Octs bs))) final) =
+      "(Start " ++ (show header) ++ " (" ++ (show $ length bs) ++ " bytes) " ++
+      (show final)
+    describe (Continue Nothing final) =
+      "(Continue ~ " ++ (show final)
+    describe (Continue (Just (File (Octs bs))) final) =
+      "(Continue (" ++ (show $ length bs) ++ " bytes) " ++ (show final)
+    describe (Cancel ()) = "(Cancel ())"
+
+    waitCancel :: Async a -> RIO e (Either SomeException a)
+    waitCancel async = cancel async >> waitCatch async
+
+    cancelThread :: ReqId -> Async a -> RIO e ()
+    cancelThread id =
+      waitCancel >=> \case Left _  -> planEvent id $ Cancel ()
+                           Right _ -> pure ()
+
+    cancelReq :: HttpClientDrv -> ReqId -> RIO e ()
+    cancelReq drv id =
+      join $ atomically $ do
+        tbl <- readTVar (hcdLive drv)
+        case lookup id tbl of
+          Nothing    -> pure (pure ())
+          Just async -> do writeTVar (hcdLive drv) (deleteMap id tbl)
+                           pure (cancelThread id async)

pkg/hs/urbit-king/lib/Urbit/Vere/Http/Server.hs

@@ -0,0 +1,555 @@
+{-|
+    Http Server Driver
+
+    TODO Make sure that HTTP sockets get closed on shutdown.
+
+    TODO What is this about?
+
+        //  if we don't explicitly set this field, h2o will send with
+        //  transfer-encoding: chunked
+        //
+        if ( 1 == has_len_i ) {
+          rec_u->res.content_length = ( 0 == gen_u->bod_u ) ?
+                                      0 : gen_u->bod_u->len_w;
+        }
+
+    TODO Does this matter, is is using WAI's default behavior ok?
+
+        rec_u->res.reason = (status < 200) ? "weird" :
+                            (status < 300) ? "ok" :
+                            (status < 400) ? "moved" :
+                            (status < 500) ? "missing" :
+                            "hosed";
+-}
+
+module Urbit.Vere.Http.Server where
+
+import Data.Conduit
+import Urbit.Arvo            hiding (ServerId, reqBody, reqUrl, secure)
+import Urbit.King.Config
+import Urbit.Noun
+import Urbit.Prelude         hiding (Builder)
+import Urbit.Vere.Pier.Types
+
+import Data.Binary.Builder (Builder, fromByteString)
+import Data.Bits           (shiftL, (.|.))
+import Network.Socket      (SockAddr(..))
+import System.Directory    (doesFileExist, removeFile)
+import System.Random       (randomIO)
+import Urbit.Vere.Http     (convertHeaders, unconvertHeaders)
+
+import qualified Network.HTTP.Types          as H
+import qualified Network.Socket              as Net
+import qualified Network.Wai                 as W
+import qualified Network.Wai.Conduit         as W
+import qualified Network.Wai.Handler.Warp    as W
+import qualified Network.Wai.Handler.WarpTLS as W
+
+
+-- Internal Types --------------------------------------------------------------
+
+type ReqId = UD
+type SeqId = UD -- Unused, always 1
+
+{-|
+    The sequence of actions on a given request *should* be:
+
+        [%head .] [%bloc .]* %done
+
+    But we will actually accept anything, and mostly do the right
+    thing. There are two situations where we ignore ignore the data from
+    some actions.
+
+    - If you send something *after* a %done action, it will be ignored.
+    - If you send a %done before a %head, we will produce "444 No
+      Response" with an empty response body.
+-}
+data RespAction
+    = RAHead ResponseHeader File
+    | RAFull ResponseHeader File
+    | RABloc File
+    | RADone
+  deriving (Eq, Ord, Show)
+
+data LiveReqs = LiveReqs
+    { nextReqId  :: ReqId
+    , activeReqs :: Map ReqId (TQueue RespAction)
+    }
+
+data Ports = Ports
+    { pHttps :: Maybe Port
+    , pHttp  :: Port
+    , pLoop  :: Port
+    }
+  deriving (Eq, Ord, Show)
+
+newtype Drv = Drv { unDrv :: MVar (Maybe Serv) }
+
+data Serv = Serv
+    { sServId    :: ServId
+    , sConfig    :: HttpServerConf
+    , sLoopTid   :: Async ()
+    , sHttpTid   :: Async ()
+    , sHttpsTid  :: Maybe (Async ())
+    , sLoopSock  :: Net.Socket
+    , sHttpSock  :: Net.Socket
+    , sHttpsSock :: Net.Socket
+    , sPorts     :: Ports
+    , sPortsFile :: FilePath
+    , sLiveReqs  :: TVar LiveReqs
+    }
+
+
+-- RespAction -- Reorganized HttpEvent for Cleaner Processing ------------------
+
+reorgHttpEvent :: HttpEvent -> [RespAction]
+reorgHttpEvent = \case
+    Start head mBlk True   -> [RAFull head (fromMaybe "" mBlk)]
+    Start head mBlk False  -> [RAHead head (fromMaybe "" mBlk)]
+    Cancel ()              -> [RADone]
+    Continue mBlk isDone   -> toList (RABloc <$> mBlk)
+                           <> if isDone then [RADone] else []
+
+
+-- Generic Service Stop/Restart -- Using an MVar for Atomicity -----------------
+
+{-|
+    Restart a running service.
+
+    This can probably be made simpler, but it
+
+    - Sets the MVar to Nothing if there was an exception whil starting
+      or stopping the service.
+
+    - Keeps the MVar lock until the restart process finishes.
+-}
+restartService :: ∀e s. HasLogFunc e
+               => MVar (Maybe s)
+               -> RIO e s
+               -> (s -> RIO e ())
+               -> RIO e (Either SomeException s)
+restartService vServ sstart kkill = do
+    logDebug "restartService"
+    modifyMVar vServ $ \case
+        Nothing -> doStart
+        Just sv -> doRestart sv
+  where
+    doRestart :: s -> RIO e (Maybe s, Either SomeException s)
+    doRestart serv = do
+        logDebug "doStart"
+        try (kkill serv) >>= \case
+            Left exn -> pure (Nothing, Left exn)
+            Right () -> doStart
+
+    doStart :: RIO e (Maybe s, Either SomeException s)
+    doStart = do
+        logDebug "doStart"
+        try sstart <&> \case
+            Right s  -> (Just s,  Right s)
+            Left exn -> (Nothing, Left exn)
+
+stopService :: HasLogFunc e
+            => MVar (Maybe s)
+            -> (s -> RIO e ())
+            -> RIO e (Either SomeException ())
+stopService vServ kkill = do
+    logDebug "stopService"
+    modifyMVar vServ $ \case
+        Nothing -> pure (Nothing, Right ())
+        Just sv -> do res <- try (kkill sv)
+                      pure (Nothing, res)
+
+
+-- Live Requests Table -- All Requests Still Waiting for Responses -------------
+
+emptyLiveReqs :: LiveReqs
+emptyLiveReqs = LiveReqs 1 mempty
+
+respondToLiveReq :: TVar LiveReqs -> ReqId -> RespAction -> STM ()
+respondToLiveReq var req ev = do
+    mVar <- lookup req . activeReqs <$> readTVar var
+    case mVar of
+        Nothing -> pure ()
+        Just tv -> writeTQueue tv ev
+
+rmLiveReq :: TVar LiveReqs -> ReqId -> STM ()
+rmLiveReq var reqId = do
+    liv <- readTVar var
+    writeTVar var (liv { activeReqs = deleteMap reqId (activeReqs liv) })
+
+newLiveReq :: TVar LiveReqs -> STM (ReqId, TQueue RespAction)
+newLiveReq var = do
+    liv <- readTVar var
+    tmv <- newTQueue
+
+    let (nex, act) = (nextReqId liv, activeReqs liv)
+
+    writeTVar var (LiveReqs (nex+1) (insertMap nex tmv act))
+
+    pure (nex, tmv)
+
+
+-- Ports File ------------------------------------------------------------------
+
+removePortsFile :: FilePath -> RIO e ()
+removePortsFile pax =
+    io (doesFileExist pax) >>= \case
+        True  -> io $ removeFile pax
+        False -> pure ()
+
+portsFileText :: Ports -> Text
+portsFileText Ports{..} =
+  unlines $ catMaybes
+    [ pHttps <&> \p -> (tshow p <> " secure public")
+    , Just (tshow (unPort pHttp) <> " insecure public")
+    , Just (tshow (unPort pLoop) <> " insecure loopback")
+    ]
+
+writePortsFile :: FilePath -> Ports -> RIO e ()
+writePortsFile f = writeFile f . encodeUtf8 . portsFileText
+
+
+-- Random Helpers --------------------------------------------------------------
+
+cordBytes :: Cord -> ByteString
+cordBytes = encodeUtf8 . unCord
+
+pass :: Monad m => m ()
+pass = pure ()
+
+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenJust Nothing  act = pure ()
+whenJust (Just a) act = act a
+
+cookMeth :: W.Request -> Maybe Method
+cookMeth = H.parseMethod . W.requestMethod >>> \case
+             Left _  -> Nothing
+             Right m -> Just m
+
+reqIdCord :: ReqId -> Cord
+reqIdCord = Cord . tshow
+
+reqBody :: W.Request -> RIO e (Maybe File)
+reqBody req = do
+    bodyLbs <- io $ W.strictRequestBody req
+    pure $ if length bodyLbs == 0
+      then Nothing
+      else Just $ File $ Octs (toStrict bodyLbs)
+
+reqAddr :: W.Request -> Address
+reqAddr = W.remoteHost >>> \case
+    SockAddrInet  _ a     -> AIpv4 (Ipv4 a)
+    SockAddrInet6 _ _ a _ -> AIpv6 (mkIpv6 a)
+    _                     -> error "invalid sock addr"
+
+mkIpv6 :: (Word32, Word32, Word32, Word32) -> Ipv6
+mkIpv6 (p, q, r, s) = Ipv6 (pBits .|. qBits .|. rBits .|. sBits)
+  where
+    pBits = shiftL (fromIntegral p) 0
+    qBits = shiftL (fromIntegral q) 32
+    rBits = shiftL (fromIntegral r) 64
+    sBits = shiftL (fromIntegral s) 96
+
+reqUrl :: W.Request -> Cord
+reqUrl r = Cord $ decodeUtf8 $ W.rawPathInfo r <> W.rawQueryString r
+
+
+-- Utilities for Constructing Events -------------------------------------------
+
+data WhichServer = Secure | Insecure | Loopback
+  deriving (Eq)
+
+servEv :: HttpServerEv -> Ev
+servEv = EvBlip . BlipEvHttpServer
+
+bornEv :: KingId -> Ev
+bornEv king =
+    servEv $ HttpServerEvBorn (king, ()) ()
+
+liveEv :: ServId -> Ports -> Ev
+liveEv sId Ports{..} =
+    servEv $ HttpServerEvLive (sId, ()) pHttp pHttps
+
+cancelEv :: ServId -> ReqId -> Ev
+cancelEv sId reqId =
+    servEv $ HttpServerEvCancelRequest (sId, reqId, 1, ()) ()
+
+reqEv :: ServId -> ReqId -> WhichServer -> Address -> HttpRequest -> Ev
+reqEv sId reqId which addr req =
+    case which of
+        Loopback ->
+            servEv $ HttpServerEvRequestLocal (sId, reqId, 1, ())
+                   $ HttpServerReq False addr req
+        _        ->
+            servEv $ HttpServerEvRequest (sId, reqId, 1, ())
+                   $ HttpServerReq (which == Secure) addr req
+
+
+-- Http Server Flows -----------------------------------------------------------
+
+data Resp
+    = RHead ResponseHeader [File]
+    | RFull ResponseHeader [File]
+    | RNone
+  deriving (Show)
+
+{-|
+    This accepts all action orderings so that there are no edge-cases
+    to be handled:
+
+    - If %bloc before %head, collect it and wait for %head.
+    - If %done before %head, ignore all chunks and produce Nothing.
+
+    TODO Be strict about this instead. Ignore invalid request streams.
+-}
+getResp :: TQueue RespAction -> RIO e Resp
+getResp tmv = go []
+  where
+    go çunks = atomically (readTQueue tmv) >>= \case
+                 RAHead head ç -> pure $ RHead head $ reverse (ç : çunks)
+                 RAFull head ç -> pure $ RFull head $ reverse (ç : çunks)
+                 RABloc ç      -> go (ç : çunks)
+                 RADone        -> pure RNone
+
+{-|
+    - Immediatly yield all of the initial chunks
+    - Yield the data from %bloc action.
+    - Close the stream when we hit a %done action.
+-}
+streamBlocks :: HasLogFunc e
+             => e -> [File] -> TQueue RespAction
+             -> ConduitT () (Flush Builder) IO ()
+streamBlocks env init tmv =
+    for_ init yieldÇunk >> go
+  where
+    yieldFlush = \x -> yield (Chunk x) >> yield Flush
+    logDupHead = runRIO env (logError "Multiple %head actions on one request")
+
+    yieldÇunk  = \case
+        "" -> runRIO env (logTrace "sending empty chunk")
+        c  -> do runRIO env (logTrace (display ("sending chunk " <> tshow c)))
+                 (yieldFlush . fromByteString . unOcts . unFile) c
+
+    go = atomically (readTQueue tmv) >>= \case
+             RAHead head c -> logDupHead >> yieldÇunk c >> go
+             RAFull head c -> logDupHead >> yieldÇunk c >> go
+             RABloc c      -> yieldÇunk c >> go
+             RADone        -> pure ()
+
+sendResponse :: HasLogFunc e
+             => (W.Response -> IO W.ResponseReceived)
+             -> TQueue RespAction
+             -> RIO e W.ResponseReceived
+sendResponse cb tmv = do
+    env <- ask
+    getResp tmv >>= \case
+        RNone     -> io $ cb $ W.responseLBS (H.mkStatus 444 "No Response") []
+                             $ ""
+        RFull h f -> io $ cb $ W.responseLBS (hdrStatus h) (hdrHeaders h)
+                             $ fromStrict $ concat $ unOcts . unFile <$> f
+        RHead h i -> io $ cb $ W.responseSource (hdrStatus h) (hdrHeaders h)
+                             $ streamBlocks env i tmv
+  where
+    hdrHeaders :: ResponseHeader -> [H.Header]
+    hdrHeaders = unconvertHeaders . headers
+
+    hdrStatus :: ResponseHeader -> H.Status
+    hdrStatus = toEnum . fromIntegral . statusCode
+
+liveReq :: TVar LiveReqs -> RAcquire e (ReqId, TQueue RespAction)
+liveReq vLiv = mkRAcquire ins del
+  where
+    ins = atomically (newLiveReq vLiv)
+    del = atomically . rmLiveReq vLiv . fst
+
+app :: HasLogFunc e
+    => e -> ServId -> TVar LiveReqs -> (Ev -> STM ()) -> WhichServer
+    -> W.Application
+app env sId liv plan which req respond =
+   runRIO env $
+   rwith (liveReq liv) $ \(reqId, respVar) -> do
+        body <- reqBody req
+        meth <- maybe (error "bad method") pure (cookMeth req)
+
+        let addr  = reqAddr req
+            hdrs  = convertHeaders $ W.requestHeaders req
+            evReq = HttpRequest meth (reqUrl req) hdrs body
+
+        atomically $ plan (reqEv sId reqId which addr evReq)
+
+        try (sendResponse respond respVar) >>= \case
+          Right rr -> pure rr
+          Left exn -> do
+            io $ atomically $ plan (cancelEv sId reqId)
+            logError $ display ("Exception during request" <> tshow exn)
+            throwIO (exn :: SomeException)
+
+
+-- Top-Level Driver Interface --------------------------------------------------
+
+{-|
+    Opens a socket on some port, accepting connections from `127.0.0.1`
+    if fake and `0.0.0.0` if real.
+
+    It will attempt to open a socket on each of the supplied ports in
+    order. If they all fail, it will ask the operating system to give
+    us an open socket on *any* open port. If that fails, it will throw
+    an exception.
+-}
+openPort :: HasLogFunc e => Bool -> [W.Port] -> RIO e (W.Port, Net.Socket)
+openPort isFake = go
+  where
+    go = \case
+        []   -> io W.openFreePort
+        x:xs -> io (tryOpen x) >>= \case
+                    Left (err∷IOError) -> do
+                        logWarn (display ("Failed to open port " <> tshow x))
+                        logWarn (display (tshow err))
+                        go xs
+                    Right ps -> do
+                        logTrace (display ("Opening port " <> tshow (fst ps)))
+                        pure ps
+
+    bindTo = if isFake then "127.0.0.1" else "0.0.0.0"
+
+    bindListenPort ∷ W.Port → Net.Socket → IO Net.PortNumber
+    bindListenPort por sok = do
+        bindAddr <- Net.getAddrInfo Nothing (Just bindTo) Nothing >>= \case
+                        []  -> error "this should never happen."
+                        x:_ -> pure (Net.addrAddress x)
+
+        Net.bind sok bindAddr
+        Net.listen sok 1
+        Net.socketPort sok
+
+    --  `inet_addr`, `bind`, and `listen` all throw `IOError` if they fail.
+    tryOpen ∷ W.Port → IO (Either IOError (W.Port, Net.Socket))
+    tryOpen por = do
+        sok <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol
+        try (bindListenPort por sok) >>= \case
+            Left exn  -> Net.close sok $> Left exn
+            Right por -> pure (Right (fromIntegral por, sok))
+
+startServ :: (HasPierConfig e, HasLogFunc e)
+          => Bool -> HttpServerConf -> (Ev -> STM ())
+          -> RIO e Serv
+startServ isFake conf plan = do
+  logDebug "startServ"
+
+  let tls = hscSecure conf <&> \(PEM key, PEM cert) ->
+              (W.tlsSettingsMemory (cordBytes cert) (cordBytes key))
+
+  sId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
+  liv <- newTVarIO emptyLiveReqs
+
+  let insPor = if isFake then [8080..8085] else (80  : [8080..8085])
+      secPor = if isFake then [8443..8448] else (443 : [8443..8448])
+
+  (httpPortInt,  httpSock)  <- openPort isFake insPor
+  (httpsPortInt, httpsSock) <- openPort isFake secPor
+  (loopPortInt,  loopSock)  <- openPort isFake [12321..12326]
+
+  let httpPort  = Port (fromIntegral httpPortInt)
+      httpsPort = Port (fromIntegral httpsPortInt)
+      loopPort  = Port (fromIntegral loopPortInt)
+
+  let loopOpts  = W.defaultSettings & W.setPort (fromIntegral loopPort)
+                                    & W.setHost "127.0.0.1"
+                                    & W.setTimeout (5 * 60)
+      httpOpts  = W.defaultSettings & W.setHost "*"
+                                    & W.setPort (fromIntegral httpPort)
+      httpsOpts = W.defaultSettings & W.setHost "*"
+                                    & W.setPort (fromIntegral httpsPort)
+
+  env <- ask
+
+  logDebug "Starting loopback server"
+  loopTid  <- async $ io
+                    $ W.runSettingsSocket loopOpts loopSock
+                    $ app env sId liv plan Loopback
+
+  logDebug "Starting HTTP server"
+  httpTid  <- async $ io
+                    $ W.runSettingsSocket httpOpts httpSock
+                    $ app env sId liv plan Insecure
+
+  logDebug "Starting HTTPS server"
+  httpsTid <- for tls $ \tlsOpts ->
+                async $ io
+                      $ W.runTLSSocket tlsOpts httpsOpts httpsSock
+                      $ app env sId liv plan Secure
+
+  pierPath <- view pierPathL
+  let por = Ports (tls <&> const httpsPort) httpPort loopPort
+      fil = pierPath <> "/.http.ports"
+
+  logDebug $ displayShow (sId, por, fil)
+
+  logDebug "Finished started HTTP Servers"
+
+  pure $ Serv sId conf
+              loopTid httpTid httpsTid
+              httpSock httpsSock loopSock
+              por fil liv
+
+killServ :: HasLogFunc e => Serv -> RIO e ()
+killServ Serv{..} = do
+    cancel sLoopTid
+    cancel sHttpTid
+    traverse_ cancel sHttpsTid
+    io $ Net.close sHttpSock
+    io $ Net.close sHttpsSock
+    io $ Net.close sLoopSock
+    removePortsFile sPortsFile
+    (void . waitCatch) sLoopTid
+    (void . waitCatch) sHttpTid
+    traverse_ (void . waitCatch) sHttpsTid
+
+kill :: HasLogFunc e => Drv -> RIO e ()
+kill (Drv v) = stopService v killServ >>= fromEither
+
+respond :: HasLogFunc e
+        => Drv -> ReqId -> HttpEvent -> RIO e ()
+respond (Drv v) reqId ev = do
+    readMVar v >>= \case
+        Nothing -> logWarn "Got a response to a request that does not exist."
+        Just sv -> do logDebug $ displayShow $ reorgHttpEvent ev
+                      for_ (reorgHttpEvent ev) $
+                        atomically . respondToLiveReq (sLiveReqs sv) reqId
+
+serv :: ∀e. (HasPierConfig e, HasLogFunc e)
+     => KingId -> QueueEv -> Bool
+     -> ([Ev], RAcquire e (EffCb e HttpServerEf))
+serv king plan isFake =
+    (initialEvents, runHttpServer)
+  where
+    initialEvents :: [Ev]
+    initialEvents = [bornEv king]
+
+    runHttpServer :: RAcquire e (EffCb e HttpServerEf)
+    runHttpServer = handleEf <$> mkRAcquire (Drv <$> newMVar Nothing) kill
+
+    restart :: Drv -> HttpServerConf -> RIO e Serv
+    restart (Drv var) conf = do
+        logDebug "Restarting http server"
+        res <- fromEither =<<
+                 restartService var (startServ isFake conf plan) killServ
+        logDebug "Done restating http server"
+        pure res
+
+    handleEf :: Drv -> HttpServerEf -> RIO e ()
+    handleEf drv = \case
+        HSESetConfig (i, ()) conf -> do
+            -- print (i, king)
+            -- when (i == fromIntegral king) $ do
+                logDebug "restarting"
+                Serv{..} <- restart drv conf
+                logDebug "Enqueue %live"
+                atomically $ plan (liveEv sServId sPorts)
+                logDebug "Write ports file"
+                writePortsFile sPortsFile sPorts
+        HSEResponse (i, req, _seq, ()) ev -> do
+            -- print (i, king)
+            -- when (i == fromIntegral king) $ do
+                logDebug "respond"
+                respond drv (fromIntegral req) ev

pkg/hs/urbit-king/lib/Urbit/Vere/LMDB.hs

@@ -0,0 +1,325 @@
+{-|
+    Low-Level Inferface for LMDB Event Log.
+-}
+
+module Urbit.Vere.LMDB where
+
+import Urbit.Prelude hiding (init)
+
+import Data.RAcquire
+import Database.LMDB.Raw
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Urbit.Vere.Pier.Types
+
+import Foreign.Storable (peek, poke, sizeOf)
+
+import qualified Data.ByteString.Unsafe as BU
+
+
+-- Types -----------------------------------------------------------------------
+
+type Env = MDB_env
+type Val = MDB_val
+type Txn = MDB_txn
+type Dbi = MDB_dbi
+type Cur = MDB_cursor
+
+data VereLMDBExn
+    = NoLogIdentity
+    | MissingEvent EventId
+    | BadNounInLogIdentity ByteString DecodeErr ByteString
+    | BadKeyInEventLog
+    | BadWriteLogIdentity LogIdentity
+    | BadWriteEvent EventId
+    | BadWriteEffect EventId
+  deriving Show
+
+instance Exception VereLMDBExn where
+
+
+-- Transactions ----------------------------------------------------------------
+
+{-|
+    A read-only transaction that commits at the end.
+
+    Use this when opening database handles.
+-}
+openTxn :: Env -> RAcquire e Txn
+openTxn env = mkRAcquire begin commit
+  where
+    begin  = io $ mdb_txn_begin env Nothing True
+    commit = io . mdb_txn_commit
+
+{-|
+    A read-only transaction that aborts at the end.
+
+    Use this when reading data from already-opened databases.
+-}
+readTxn :: Env -> RAcquire e Txn
+readTxn env = mkRAcquire begin abort
+  where
+    begin = io $ mdb_txn_begin env Nothing True
+    abort = io . mdb_txn_abort
+
+{-|
+    A read-write transaction that commits upon sucessful completion and
+    aborts on exception.
+
+    Use this when reading data from already-opened databases.
+-}
+writeTxn :: Env -> RAcquire e Txn
+writeTxn env = mkRAcquireType begin finalize
+  where
+    begin = io $ mdb_txn_begin env Nothing False
+    finalize txn = io . \case
+        ReleaseNormal    -> mdb_txn_commit txn
+        ReleaseEarly     -> mdb_txn_commit txn
+        ReleaseException -> mdb_txn_abort  txn
+
+
+-- Cursors ---------------------------------------------------------------------
+
+cursor :: Txn -> Dbi -> RAcquire e Cur
+cursor txn dbi = mkRAcquire open close
+  where
+    open  = io $ mdb_cursor_open txn dbi
+    close = io . mdb_cursor_close
+
+
+-- Last Key In Dbi -------------------------------------------------------------
+
+lastKeyWord64 :: Env -> Dbi -> Txn -> RIO e Word64
+lastKeyWord64 env dbi txn =
+    rwith (cursor txn dbi) $ \cur ->
+    withKVPtrs' nullVal nullVal $ \pKey pVal ->
+    io $ mdb_cursor_get MDB_LAST cur pKey pVal >>= \case
+        False -> pure 0
+        True  -> peek pKey >>= mdbValToWord64
+
+
+-- Delete Rows -----------------------------------------------------------------
+
+deleteAllRows :: Env -> Dbi -> RIO e ()
+deleteAllRows env dbi =
+    rwith (writeTxn env) $ \txn ->
+    rwith (cursor txn dbi) $ \cur ->
+    withKVPtrs' nullVal nullVal $ \pKey pVal -> do
+        let loop = io (mdb_cursor_get MDB_LAST cur pKey pVal) >>= \case
+                False -> pure ()
+                True  -> do io $ mdb_cursor_del (compileWriteFlags []) cur
+                            loop
+        loop
+
+deleteRowsFrom :: HasLogFunc e => Env -> Dbi -> Word64 -> RIO e ()
+deleteRowsFrom env dbi start = do
+    rwith (writeTxn env) $ \txn -> do
+        last <- lastKeyWord64 env dbi txn
+        for_ [start..last] $ \eId -> do
+            withWordPtr eId $ \pKey -> do
+                let key = MDB_val 8 (castPtr pKey)
+                found <- io $ mdb_del txn dbi key Nothing
+                unless found $
+                    throwIO (MissingEvent eId)
+
+
+-- Append Rows to Sequence -----------------------------------------------------
+
+{-
+appendToSequence :: Env -> Dbi -> Vector ByteString -> RIO e ()
+appendToSequence env dbi events = do
+    numEvs <- readIORef (numEvents log)
+    next   <- pure (numEvs + 1)
+    doAppend $ zip [next..] $ toList events
+    writeIORef (numEvents log) (numEvs + word (length events))
+  where
+    flags    = compileWriteFlags [MDB_NOOVERWRITE]
+    doAppend = \kvs ->
+        rwith (writeTxn env) $ \txn ->
+        for_ kvs $ \(k,v) -> do
+            putBytes flags txn dbi k v >>= \case
+                True  -> pure ()
+                False -> throwIO (BadWriteEvent k)
+-}
+
+
+-- Insert ----------------------------------------------------------------------
+
+insertWord64 :: Env -> Dbi -> Word64 -> ByteString -> RIO e ()
+insertWord64 env dbi k v = do
+    rwith (writeTxn env) $ \txn ->
+        putBytes flags txn dbi k v >>= \case
+            True  -> pure ()
+            False -> throwIO (BadWriteEffect k)
+  where
+    flags = compileWriteFlags []
+
+
+{-
+--------------------------------------------------------------------------------
+-- Read Events -----------------------------------------------------------------
+
+streamEvents :: HasLogFunc e
+             => EventLog -> Word64
+             -> ConduitT () ByteString (RIO e) ()
+streamEvents log first = do
+    last  <- lift $ lastEv log
+    batch <- lift $ readBatch log first
+    unless (null batch) $ do
+        for_ batch yield
+        streamEvents log (first + word (length batch))
+
+streamEffectsRows :: ∀e. HasLogFunc e
+                  => EventLog -> EventId
+                  -> ConduitT () (Word64, ByteString) (RIO e) ()
+streamEffectsRows log = go
+  where
+    go :: EventId -> ConduitT () (Word64, ByteString) (RIO e) ()
+    go next = do
+        batch <- lift $ readRowsBatch (env log) (effectsTbl log) next
+        unless (null batch) $ do
+            for_ batch yield
+            go (next + fromIntegral (length batch))
+
+{-
+   Read 1000 rows from the events table, starting from event `first`.
+
+   Throws `MissingEvent` if an event was missing from the log.
+-}
+readBatch :: EventLog -> Word64 -> RIO e (V.Vector ByteString)
+readBatch log first = start
+  where
+    start = do
+        last <- lastEv log
+        if (first > last)
+            then pure mempty
+            else readRows $ fromIntegral $ min 1000 $ ((last+1) - first)
+
+    assertFound :: EventId -> Bool -> RIO e ()
+    assertFound id found = do
+        unless found $ throwIO $ MissingEvent id
+
+    readRows count =
+        withWordPtr first $ \pIdx ->
+        withKVPtrs' (MDB_val 8 (castPtr pIdx)) nullVal $ \pKey pVal ->
+        rwith (readTxn $ env log) $ \txn ->
+        rwith (cursor txn $ eventsTbl log) $ \cur -> do
+            assertFound first =<< io (mdb_cursor_get MDB_SET_KEY cur pKey pVal)
+            fetchRows count cur pKey pVal
+
+    fetchRows count cur pKey pVal = do
+        env <- ask
+        V.generateM count $ \i -> runRIO env $ do
+            key <- io $ peek pKey >>= mdbValToWord64
+            val <- io $ peek pVal >>= mdbValToBytes
+            idx <- pure (first + word i)
+            unless (key == idx) $ throwIO $ MissingEvent idx
+            when (count /= succ i) $ do
+                assertFound idx =<< io (mdb_cursor_get MDB_NEXT cur pKey pVal)
+            pure val
+
+{-
+   Read 1000 rows from the database, starting from key `first`.
+-}
+readRowsBatch :: ∀e. HasLogFunc e
+              => Env -> Dbi -> Word64 -> RIO e (V.Vector (Word64, ByteString))
+readRowsBatch env dbi first = readRows
+  where
+    readRows = do
+        logDebug $ display ("(readRowsBatch) From: " <> tshow first)
+        withWordPtr first $ \pIdx ->
+            withKVPtrs' (MDB_val 8 (castPtr pIdx)) nullVal $ \pKey pVal ->
+            rwith (readTxn env) $ \txn ->
+            rwith (cursor txn dbi) $ \cur ->
+            io (mdb_cursor_get MDB_SET_RANGE cur pKey pVal) >>= \case
+                False -> pure mempty
+                True  -> V.unfoldrM (fetchBatch cur pKey pVal) 1000
+
+    fetchBatch :: Cur -> Ptr Val -> Ptr Val -> Word
+              -> RIO e (Maybe ((Word64, ByteString), Word))
+    fetchBatch cur pKey pVal 0 = pure Nothing
+    fetchBatch cur pKey pVal n = do
+        key <- io $ peek pKey >>= mdbValToWord64
+        val <- io $ peek pVal >>= mdbValToBytes
+        io $ mdb_cursor_get MDB_NEXT cur pKey pVal >>= \case
+            False -> pure $ Just ((key, val), 0)
+            True  -> pure $ Just ((key, val), pred n)
+
+-}
+
+-- Utils -----------------------------------------------------------------------
+
+withKVPtrs' :: (MonadIO m, MonadUnliftIO m)
+            => Val -> Val -> (Ptr Val -> Ptr Val -> m a) -> m a
+withKVPtrs' k v cb =
+    withRunInIO $ \run ->
+        withKVPtrs k v $ \x y -> run (cb x y)
+
+nullVal :: MDB_val
+nullVal = MDB_val 0 nullPtr
+
+word :: Int -> Word64
+word = fromIntegral
+
+assertExn :: Exception e => Bool -> e -> IO ()
+assertExn True  _ = pure ()
+assertExn False e = throwIO e
+
+eitherExn :: Exception e => Either a b -> (a -> e) -> IO b
+eitherExn eat exn = either (throwIO . exn) pure eat
+
+byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a
+byteStringAsMdbVal bs k =
+  BU.unsafeUseAsCStringLen bs $ \(ptr,sz) ->
+    k (MDB_val (fromIntegral sz) (castPtr ptr))
+
+mdbValToWord64 :: MDB_val -> IO Word64
+mdbValToWord64 (MDB_val sz ptr) = do
+  assertExn (sz == 8) BadKeyInEventLog
+  peek (castPtr ptr)
+
+withWord64AsMDBval :: (MonadIO m, MonadUnliftIO m)
+                   => Word64 -> (MDB_val -> m a) -> m a
+withWord64AsMDBval w cb = do
+  withWordPtr w $ \p ->
+    cb (MDB_val (fromIntegral (sizeOf w)) (castPtr p))
+
+withWordPtr :: (MonadIO m, MonadUnliftIO m)
+            => Word64 -> (Ptr Word64 -> m a) -> m a
+withWordPtr w cb =
+    withRunInIO $ \run ->
+        allocaBytes (sizeOf w) (\p -> poke p w >> run (cb p))
+
+
+-- Lower-Level Operations ------------------------------------------------------
+
+getMb :: MonadIO m => Txn -> Dbi -> ByteString -> m (Maybe Noun)
+getMb txn db key =
+  io $
+  byteStringAsMdbVal key $ \mKey ->
+  mdb_get txn db mKey >>= traverse (mdbValToNoun key)
+
+mdbValToBytes :: MDB_val -> IO ByteString
+mdbValToBytes (MDB_val sz ptr) = do
+  BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz)
+
+mdbValToNoun :: ByteString -> MDB_val -> IO Noun
+mdbValToNoun key (MDB_val sz ptr) = do
+  bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz)
+  let res = cueBS bs
+  eitherExn res (\err -> BadNounInLogIdentity key err bs)
+
+putNoun :: MonadIO m
+        => MDB_WriteFlags -> Txn -> Dbi -> ByteString -> Noun -> m Bool
+putNoun flags txn db key val =
+  io $
+  byteStringAsMdbVal key $ \mKey ->
+  byteStringAsMdbVal (jamBS val) $ \mVal ->
+  mdb_put flags txn db mKey mVal
+
+putBytes :: MonadIO m
+         => MDB_WriteFlags -> Txn -> Dbi -> Word64 -> ByteString -> m Bool
+putBytes flags txn db id bs = io $
+    withWord64AsMDBval id $ \idVal ->
+    byteStringAsMdbVal bs $ \mVal ->
+    mdb_put flags txn db idVal mVal

pkg/hs/urbit-king/lib/Urbit/Vere/LockFile.hs

@@ -0,0 +1,30 @@
+{-|
+    Acquire and release the vere lockfile.
+-}
+
+module Urbit.Vere.LockFile (lockFile) where
+
+import Urbit.Prelude
+
+import Data.Default                (def)
+import RIO.Directory               (createDirectoryIfMissing)
+import System.IO.LockFile.Internal (LockingParameters(..), RetryStrategy(..),
+                                    lock, unlock)
+
+--------------------------------------------------------------------------------
+
+lockFile :: HasLogFunc e => FilePath -> RAcquire e ()
+lockFile pax = void $ mkRAcquire start stop
+  where
+    fil = pax <> "/.vere.lock"
+
+    stop handle = do
+        logInfo $ display @Text $ ("Releasing lock file: " <> pack fil)
+        io $ unlock fil handle
+
+    params = def { retryToAcquireLock = No }
+
+    start = do
+        createDirectoryIfMissing True pax
+        logInfo $ display @Text $ ("Taking lock file: " <> pack fil)
+        io (lock params fil)

pkg/hs/urbit-king/lib/Urbit/Vere/Log.hs

@@ -0,0 +1,429 @@
+{-|
+    High-Level Event-Log Interface
+
+    TODO Effects storage logic is messy.
+-}
+
+module Urbit.Vere.Log ( EventLog, identity, nextEv, lastEv
+                      , new, existing
+                      , streamEvents, appendEvents, trimEvents
+                      , streamEffectsRows, writeEffectsRow
+                      ) where
+
+import Urbit.Prelude hiding (init)
+
+import Data.Conduit
+import Data.RAcquire
+import Database.LMDB.Raw
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Urbit.Vere.Pier.Types
+
+import Foreign.Storable (peek, poke, sizeOf)
+
+import qualified Data.ByteString.Unsafe as BU
+import qualified Data.Vector            as V
+
+
+-- Types -----------------------------------------------------------------------
+
+type Env = MDB_env
+type Val = MDB_val
+type Txn = MDB_txn
+type Dbi = MDB_dbi
+type Cur = MDB_cursor
+
+data EventLog = EventLog
+    { env        :: Env
+    , _metaTbl   :: Dbi
+    , eventsTbl  :: Dbi
+    , effectsTbl :: Dbi
+    , identity   :: LogIdentity
+    , numEvents  :: IORef EventId
+    }
+
+nextEv :: EventLog -> RIO e EventId
+nextEv = fmap succ . readIORef . numEvents
+
+lastEv :: EventLog -> RIO e EventId
+lastEv = readIORef . numEvents
+
+data EventLogExn
+    = NoLogIdentity
+    | MissingEvent EventId
+    | BadNounInLogIdentity ByteString DecodeErr ByteString
+    | BadKeyInEventLog
+    | BadWriteLogIdentity LogIdentity
+    | BadWriteEvent EventId
+    | BadWriteEffect EventId
+  deriving Show
+
+
+-- Instances -------------------------------------------------------------------
+
+instance Exception EventLogExn where
+
+
+-- Open/Close an Event Log -----------------------------------------------------
+
+rawOpen :: MonadIO m => FilePath -> m Env
+rawOpen dir = io $ do
+    env <- mdb_env_create
+    mdb_env_set_maxdbs env 3
+    mdb_env_set_mapsize env (100 * 1024 * 1024 * 1024)
+    mdb_env_open env dir []
+    pure env
+
+create :: HasLogFunc e => FilePath -> LogIdentity -> RIO e EventLog
+create dir id = do
+    logDebug $ display (pack @Text $ "Creating LMDB database: " <> dir)
+    logDebug $ display (pack @Text $ "Log Identity: " <> show id)
+    env       <- rawOpen dir
+    (m, e, f) <- createTables env
+    clearEvents env e
+    writeIdent env m id
+    EventLog env m e f id <$> newIORef 0
+  where
+    createTables env =
+      rwith (writeTxn env) $ \txn -> io $
+        (,,) <$> mdb_dbi_open txn (Just "META")    [MDB_CREATE]
+             <*> mdb_dbi_open txn (Just "EVENTS")  [MDB_CREATE, MDB_INTEGERKEY]
+             <*> mdb_dbi_open txn (Just "EFFECTS") [MDB_CREATE, MDB_INTEGERKEY]
+
+open :: HasLogFunc e => FilePath -> RIO e EventLog
+open dir = do
+    logDebug $ display (pack @Text $ "Opening LMDB database: " <> dir)
+    env       <- rawOpen dir
+    (m, e, f) <- openTables env
+    id        <- getIdent env m
+    logDebug $ display (pack @Text $ "Log Identity: " <> show id)
+    numEvs    <- getNumEvents env e
+    EventLog env m e f id <$> newIORef numEvs
+  where
+    openTables env =
+      rwith (writeTxn env) $ \txn -> io $
+        (,,) <$> mdb_dbi_open txn (Just "META")    []
+             <*> mdb_dbi_open txn (Just "EVENTS")  [MDB_INTEGERKEY]
+             <*> mdb_dbi_open txn (Just "EFFECTS") [MDB_CREATE, MDB_INTEGERKEY]
+
+close :: HasLogFunc e => FilePath -> EventLog -> RIO e ()
+close dir (EventLog env meta events effects _ _) = do
+    logDebug $ display (pack @Text $ "Closing LMDB database: " <> dir)
+    io $ do mdb_dbi_close env meta
+            mdb_dbi_close env events
+            mdb_dbi_close env effects
+            mdb_env_sync_flush env
+            mdb_env_close env
+
+
+-- Create a new event log or open an existing one. -----------------------------
+
+existing :: HasLogFunc e => FilePath -> RAcquire e EventLog
+existing dir = mkRAcquire (open dir) (close dir)
+
+new :: HasLogFunc e => FilePath -> LogIdentity -> RAcquire e EventLog
+new dir id = mkRAcquire (create dir id) (close dir)
+
+
+-- Read/Write Log Identity -----------------------------------------------------
+
+{-|
+    A read-only transaction that commits at the end.
+
+    Use this when opening database handles.
+-}
+_openTxn :: Env -> RAcquire e Txn
+_openTxn env = mkRAcquire begin commit
+  where
+    begin  = io $ mdb_txn_begin env Nothing True
+    commit = io . mdb_txn_commit
+
+{-|
+    A read-only transaction that aborts at the end.
+
+    Use this when reading data from already-opened databases.
+-}
+readTxn :: Env -> RAcquire e Txn
+readTxn env = mkRAcquire begin abort
+  where
+    begin = io $ mdb_txn_begin env Nothing True
+    abort = io . mdb_txn_abort
+
+{-|
+    A read-write transaction that commits upon sucessful completion and
+    aborts on exception.
+
+    Use this when reading data from already-opened databases.
+-}
+writeTxn :: Env -> RAcquire e Txn
+writeTxn env = mkRAcquireType begin finalize
+  where
+    begin = io $ mdb_txn_begin env Nothing False
+    finalize txn = io . \case
+        ReleaseNormal    -> mdb_txn_commit txn
+        ReleaseEarly     -> mdb_txn_commit txn
+        ReleaseException -> mdb_txn_abort  txn
+
+cursor :: Txn -> Dbi -> RAcquire e Cur
+cursor txn dbi = mkRAcquire open close
+  where
+    open  = io $ mdb_cursor_open txn dbi
+    close = io . mdb_cursor_close
+
+getIdent :: HasLogFunc e => Env -> Dbi -> RIO e LogIdentity
+getIdent env dbi = do
+    logDebug "Reading log identity"
+    getTbl env >>= traverse decodeIdent >>= \case
+        Nothing -> throwIO NoLogIdentity
+        Just li -> pure li
+  where
+    decodeIdent :: (Noun, Noun, Noun) -> RIO e LogIdentity
+    decodeIdent = fromNounExn . toNoun
+
+    getTbl :: Env -> RIO e (Maybe (Noun, Noun, Noun))
+    getTbl env = do
+        rwith (readTxn env) $ \txn -> do
+            who  <- getMb txn dbi "who"
+            fake <- getMb txn dbi "is-fake"
+            life <- getMb txn dbi "life"
+            pure $ (,,) <$> who <*> fake <*> life
+
+writeIdent :: HasLogFunc e => Env -> Dbi -> LogIdentity -> RIO e ()
+writeIdent env metaTbl ident@LogIdentity{..} = do
+    logDebug "Writing log identity"
+    let flags = compileWriteFlags []
+    rwith (writeTxn env) $ \txn -> do
+        x <- putNoun flags txn metaTbl "who"     (toNoun who)
+        y <- putNoun flags txn metaTbl "is-fake" (toNoun isFake)
+        z <- putNoun flags txn metaTbl "life"    (toNoun lifecycleLen)
+        unless (x && y && z) $ do
+            throwIO (BadWriteLogIdentity ident)
+
+
+-- Latest Event Number ---------------------------------------------------------
+
+getNumEvents :: Env -> Dbi -> RIO e Word64
+getNumEvents env eventsTbl =
+    rwith (readTxn env) $ \txn ->
+    rwith (cursor txn eventsTbl) $ \cur ->
+    withKVPtrs' nullVal nullVal $ \pKey pVal ->
+    io $ mdb_cursor_get MDB_LAST cur pKey pVal >>= \case
+        False -> pure 0
+        True  -> peek pKey >>= mdbValToWord64
+
+
+-- Write Events ----------------------------------------------------------------
+
+clearEvents :: Env -> Dbi -> RIO e ()
+clearEvents env eventsTbl =
+    rwith (writeTxn env) $ \txn ->
+    rwith (cursor txn eventsTbl) $ \cur ->
+    withKVPtrs' nullVal nullVal $ \pKey pVal -> do
+        let loop = io (mdb_cursor_get MDB_LAST cur pKey pVal) >>= \case
+                False -> pure ()
+                True  -> do io $ mdb_cursor_del (compileWriteFlags []) cur
+                            loop
+        loop
+
+appendEvents :: EventLog -> Vector ByteString -> RIO e ()
+appendEvents log !events = do
+    numEvs <- readIORef (numEvents log)
+    next   <- pure (numEvs + 1)
+    doAppend $ zip [next..] $ toList events
+    writeIORef (numEvents log) (numEvs + word (length events))
+  where
+    flags    = compileWriteFlags [MDB_NOOVERWRITE]
+    doAppend = \kvs ->
+        rwith (writeTxn $ env log) $ \txn ->
+        for_ kvs $ \(k,v) -> do
+            putBytes flags txn (eventsTbl log) k v >>= \case
+                True  -> pure ()
+                False -> throwIO (BadWriteEvent k)
+
+writeEffectsRow :: EventLog -> EventId -> ByteString -> RIO e ()
+writeEffectsRow log k v = do
+    rwith (writeTxn $ env log) $ \txn ->
+        putBytes flags txn (effectsTbl log) k v >>= \case
+            True  -> pure ()
+            False -> throwIO (BadWriteEffect k)
+  where
+    flags = compileWriteFlags []
+
+
+-- Read Events -----------------------------------------------------------------
+
+trimEvents :: HasLogFunc e => EventLog -> Word64 -> RIO e ()
+trimEvents log start = do
+    last <- lastEv log
+    rwith (writeTxn $ env log) $ \txn ->
+        for_ [start..last] $ \eId ->
+        withWordPtr eId $ \pKey -> do
+            let key = MDB_val 8 (castPtr pKey)
+            found <- io $ mdb_del txn (eventsTbl log) key Nothing
+            unless found $
+                throwIO (MissingEvent eId)
+    writeIORef (numEvents log) (pred start)
+
+streamEvents :: HasLogFunc e
+             => EventLog -> Word64
+             -> ConduitT () ByteString (RIO e) ()
+streamEvents log first = do
+    batch <- lift $ readBatch log first
+    unless (null batch) $ do
+        for_ batch yield
+        streamEvents log (first + word (length batch))
+
+streamEffectsRows :: ∀e. HasLogFunc e
+                  => EventLog -> EventId
+                  -> ConduitT () (Word64, ByteString) (RIO e) ()
+streamEffectsRows log = go
+  where
+    go :: EventId -> ConduitT () (Word64, ByteString) (RIO e) ()
+    go next = do
+        batch <- lift $ readRowsBatch (env log) (effectsTbl log) next
+        unless (null batch) $ do
+            for_ batch yield
+            go (next + fromIntegral (length batch))
+
+{-|
+   Read 1000 rows from the events table, starting from event `first`.
+
+   Throws `MissingEvent` if an event was missing from the log.
+-}
+readBatch :: EventLog -> Word64 -> RIO e (V.Vector ByteString)
+readBatch log first = start
+  where
+    start = do
+        last <- lastEv log
+        if (first > last)
+            then pure mempty
+            else readRows $ fromIntegral $ min 1000 $ ((last+1) - first)
+
+    assertFound :: EventId -> Bool -> RIO e ()
+    assertFound id found = do
+        unless found $ throwIO $ MissingEvent id
+
+    readRows count =
+        withWordPtr first $ \pIdx ->
+        withKVPtrs' (MDB_val 8 (castPtr pIdx)) nullVal $ \pKey pVal ->
+        rwith (readTxn $ env log) $ \txn ->
+        rwith (cursor txn $ eventsTbl log) $ \cur -> do
+            assertFound first =<< io (mdb_cursor_get MDB_SET_KEY cur pKey pVal)
+            fetchRows count cur pKey pVal
+
+    fetchRows count cur pKey pVal = do
+        env <- ask
+        V.generateM count $ \i -> runRIO env $ do
+            key <- io $ peek pKey >>= mdbValToWord64
+            val <- io $ peek pVal >>= mdbValToBytes
+            idx <- pure (first + word i)
+            unless (key == idx) $ throwIO $ MissingEvent idx
+            when (count /= succ i) $ do
+                assertFound idx =<< io (mdb_cursor_get MDB_NEXT cur pKey pVal)
+            pure val
+
+{-|
+   Read 1000 rows from the database, starting from key `first`.
+-}
+readRowsBatch :: ∀e. HasLogFunc e
+              => Env -> Dbi -> Word64 -> RIO e (V.Vector (Word64, ByteString))
+readRowsBatch env dbi first = readRows
+  where
+    readRows = do
+        logDebug $ display ("(readRowsBatch) From: " <> tshow first)
+        withWordPtr first $ \pIdx ->
+            withKVPtrs' (MDB_val 8 (castPtr pIdx)) nullVal $ \pKey pVal ->
+            rwith (readTxn env) $ \txn ->
+            rwith (cursor txn dbi) $ \cur ->
+            io (mdb_cursor_get MDB_SET_RANGE cur pKey pVal) >>= \case
+                False -> pure mempty
+                True  -> V.unfoldrM (fetchBatch cur pKey pVal) 1000
+
+    fetchBatch :: Cur -> Ptr Val -> Ptr Val -> Word
+              -> RIO e (Maybe ((Word64, ByteString), Word))
+    fetchBatch cur pKey pVal 0 = pure Nothing
+    fetchBatch cur pKey pVal n = do
+        key <- io $ peek pKey >>= mdbValToWord64
+        val <- io $ peek pVal >>= mdbValToBytes
+        io $ mdb_cursor_get MDB_NEXT cur pKey pVal >>= \case
+            False -> pure $ Just ((key, val), 0)
+            True  -> pure $ Just ((key, val), pred n)
+
+
+-- Utils -----------------------------------------------------------------------
+
+withKVPtrs' :: (MonadIO m, MonadUnliftIO m)
+            => Val -> Val -> (Ptr Val -> Ptr Val -> m a) -> m a
+withKVPtrs' k v cb =
+    withRunInIO $ \run ->
+        withKVPtrs k v $ \x y -> run (cb x y)
+
+nullVal :: MDB_val
+nullVal = MDB_val 0 nullPtr
+
+word :: Int -> Word64
+word = fromIntegral
+
+assertExn :: Exception e => Bool -> e -> IO ()
+assertExn True  _ = pure ()
+assertExn False e = throwIO e
+
+eitherExn :: Exception e => Either a b -> (a -> e) -> IO b
+eitherExn eat exn = either (throwIO . exn) pure eat
+
+byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a
+byteStringAsMdbVal bs k =
+  BU.unsafeUseAsCStringLen bs $ \(ptr,sz) ->
+    k (MDB_val (fromIntegral sz) (castPtr ptr))
+
+mdbValToWord64 :: MDB_val -> IO Word64
+mdbValToWord64 (MDB_val sz ptr) = do
+  assertExn (sz == 8) BadKeyInEventLog
+  peek (castPtr ptr)
+
+withWord64AsMDBval :: (MonadIO m, MonadUnliftIO m)
+                   => Word64 -> (MDB_val -> m a) -> m a
+withWord64AsMDBval w cb = do
+  withWordPtr w $ \p ->
+    cb (MDB_val (fromIntegral (sizeOf w)) (castPtr p))
+
+withWordPtr :: (MonadIO m, MonadUnliftIO m)
+            => Word64 -> (Ptr Word64 -> m a) -> m a
+withWordPtr w cb =
+    withRunInIO $ \run ->
+        allocaBytes (sizeOf w) (\p -> poke p w >> run (cb p))
+
+
+-- Lower-Level Operations ------------------------------------------------------
+
+getMb :: MonadIO m => Txn -> Dbi -> ByteString -> m (Maybe Noun)
+getMb txn db key =
+  io $
+  byteStringAsMdbVal key $ \mKey ->
+  mdb_get txn db mKey >>= traverse (mdbValToNoun key)
+
+mdbValToBytes :: MDB_val -> IO ByteString
+mdbValToBytes (MDB_val sz ptr) = do
+  BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz)
+
+mdbValToNoun :: ByteString -> MDB_val -> IO Noun
+mdbValToNoun key (MDB_val sz ptr) = do
+  bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz)
+  let res = cueBS bs
+  eitherExn res (\err -> BadNounInLogIdentity key err bs)
+
+putNoun :: MonadIO m
+        => MDB_WriteFlags -> Txn -> Dbi -> ByteString -> Noun -> m Bool
+putNoun flags txn db key val =
+  io $
+  byteStringAsMdbVal key $ \mKey ->
+  byteStringAsMdbVal (jamBS val) $ \mVal ->
+  mdb_put flags txn db mKey mVal
+
+putBytes :: MonadIO m
+         => MDB_WriteFlags -> Txn -> Dbi -> Word64 -> ByteString -> m Bool
+putBytes flags txn db id bs =
+  io $
+  withWord64AsMDBval id $ \idVal ->
+  byteStringAsMdbVal bs $ \mVal ->
+  mdb_put flags txn db idVal mVal

pkg/hs/urbit-king/lib/Urbit/Vere/NounServ.hs

@@ -0,0 +1,186 @@
+{-|
+    Use websockets to pass nouns between a client and server.
+-}
+
+module Urbit.Vere.NounServ
+    ( Conn(..)
+    , Server(..)
+    , Client(..)
+    , wsServer
+    , wsClient
+    , testIt
+    , wsServApp
+    , mkConn
+    , wsConn
+    ) where
+
+import Urbit.Prelude
+
+import qualified Network.Wai.Handler.Warp as W
+import qualified Network.WebSockets       as WS
+
+--------------------------------------------------------------------------------
+
+data Conn i o = Conn
+    { cRecv :: STM (Maybe i)
+    , cSend :: o -> STM ()
+    }
+
+mkConn :: TBMChan i -> TBMChan o -> Conn i o
+mkConn inp out = Conn (readTBMChan inp) (writeTBMChan out)
+
+--------------------------------------------------------------------------------
+
+data Client i o = Client
+    { cConn  :: Conn i o
+    , cAsync :: Async ()
+    }
+
+data Server i o a = Server
+    { sAccept :: STM (Maybe (Conn i o))
+    , sAsync  :: Async ()
+    , sData   :: a
+    }
+
+--------------------------------------------------------------------------------
+
+withRIOThread ∷ RIO e a → RIO e (Async a)
+withRIOThread act = do
+    env <- ask
+    io $ async $ runRIO env $ act
+
+wsConn :: (FromNoun i, ToNoun o, Show i, Show o, HasLogFunc e)
+       => Utf8Builder
+       -> TBMChan i -> TBMChan o
+       -> WS.Connection
+       -> RIO e ()
+wsConn pre inp out wsc = do
+    logWarn (pre <> "(wcConn) Connected!")
+
+    writer <- withRIOThread $ forever $ do
+        logWarn (pre <> "(wsConn) Waiting for data.")
+        byt <- io $ toStrict <$> WS.receiveData wsc
+        logWarn (pre <> "Got data")
+        dat <- cueBSExn byt >>= fromNounExn
+        logWarn (pre <> "(wsConn) Decoded data, writing to chan")
+        atomically $ writeTBMChan inp dat
+
+    reader <- withRIOThread $ forever $ do
+        logWarn (pre <> "Waiting for data from chan")
+        atomically (readTBMChan out) >>= \case
+            Nothing  -> do
+                logWarn (pre <> "(wsConn) Connection closed")
+                error "dead-conn"
+            Just msg -> do
+                logWarn (pre <> "(wsConn) Got message! " <> displayShow msg)
+                io $ WS.sendBinaryData wsc $ fromStrict $ jamBS $ toNoun msg
+
+    let cleanup = do
+            atomically (closeTBMChan inp >> closeTBMChan out)
+            cancel writer
+            cancel reader
+
+    flip finally cleanup $ do
+         res <- atomically (waitCatchSTM writer <|> waitCatchSTM reader)
+         logWarn $ displayShow (res :: Either SomeException ())
+
+
+--------------------------------------------------------------------------------
+
+wsClient :: ∀i o e. (ToNoun o, FromNoun i, Show o, Show i, HasLogFunc e)
+         => Text -> W.Port -> RIO e (Client i o)
+wsClient pax por = do
+    env <- ask
+    inp <- io $ newTBMChanIO 5
+    out <- io $ newTBMChanIO 5
+    con <- pure (mkConn inp out)
+
+    logDebug "NOUNSERV (wsClie) Trying to connect"
+
+    tid <- io $ async
+              $ WS.runClient "127.0.0.1" por (unpack pax)
+              $ \con -> WS.withPingThread con 15 (pure ()) $
+                            runRIO env (wsConn "NOUNSERV (wsClie) " inp out con)
+
+    pure $ Client con tid
+
+--------------------------------------------------------------------------------
+
+wsServApp :: (HasLogFunc e, ToNoun o, FromNoun i, Show i, Show o)
+          => (Conn i o -> STM ())
+          -> WS.PendingConnection
+          -> RIO e ()
+wsServApp cb pen = do
+    logError "NOUNSERV (wsServer) Got connection!"
+    wsc <- io $ WS.acceptRequest pen
+    inp <- io $ newTBMChanIO 5
+    out <- io $ newTBMChanIO 5
+    atomically $ cb (mkConn inp out)
+    wsConn "NOUNSERV (wsServ) " inp out wsc
+
+wsServer :: ∀i o e. (ToNoun o, FromNoun i, Show i, Show o, HasLogFunc e)
+         => RIO e (Server i o W.Port)
+wsServer = do
+    con <- io $ newTBMChanIO 5
+
+    tid <- async $ do
+        env <- ask
+        logError "NOUNSERV (wsServer) Starting server"
+        io $ WS.runServer "127.0.0.1" 9999
+           $ runRIO env . wsServApp (writeTBMChan con)
+        logError "NOUNSERV (wsServer) Server died"
+        atomically $ closeTBMChan con
+
+    pure $ Server (readTBMChan con) tid 9999
+
+
+-- Hacky Integration Test ------------------------------------------------------
+
+fromJust :: MonadIO m => Text -> Maybe a -> m a
+fromJust err Nothing  = error (unpack err)
+fromJust _   (Just x) = pure x
+
+type Example = Maybe (Word, (), Word)
+
+example :: Example
+example = Just (99, (), 44)
+
+testIt :: HasLogFunc e => RIO e ()
+testIt = do
+    logTrace "(testIt) Starting Server"
+    Server{..} <- wsServer @Example @Example
+    logTrace "(testIt) Connecting"
+    Client{..} <- wsClient @Example @Example "/" sData
+
+    logTrace "(testIt) Accepting connection"
+    sConn <- fromJust "accept" =<< atomically sAccept
+
+    let
+        clientSend = do
+            logTrace "(testIt) Sending from client"
+            atomically (cSend cConn example)
+            logTrace "(testIt) Waiting for response"
+            res <- atomically (cRecv sConn)
+            print ("clientSend", res, example)
+            unless (res == Just example) $ do
+                error "Bad data"
+            logInfo "(testIt) Success"
+
+        serverSend = do
+            logTrace "(testIt) Sending from server"
+            atomically (cSend sConn example)
+            logTrace "(testIt) Waiting for response"
+            res <- atomically (cRecv cConn)
+            print ("serverSend", res, example)
+            unless (res == Just example) $ do
+                error "Bad data"
+            logInfo "(testIt) Success"
+
+    clientSend
+    clientSend
+    clientSend
+    serverSend
+    serverSend
+
+    cancel sAsync
+    cancel cAsync

pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs

@@ -0,0 +1,460 @@
+{-|
+    Top-Level Pier Management
+
+    This is the code that starts the IO drivers and deals with
+    communication between the serf, the log, and the IO drivers.
+-}
+module Urbit.Vere.Pier
+  ( booted, resumed, getSnapshot, pier, runPersist, runCompute, generateBootSeq
+  ) where
+
+import Urbit.Prelude
+
+import RIO.Directory
+import System.Random
+import Urbit.Arvo
+import Urbit.King.Config
+import Urbit.Vere.Pier.Types
+import Control.Monad.Trans.Maybe
+
+import Data.Text              (append)
+import System.Posix.Files     (ownerModes, setFileMode)
+import Urbit.King.App         (HasConfigDir(..), HasStderrLogFunc(..))
+import Urbit.Vere.Ames        (ames)
+import Urbit.Vere.Behn        (behn)
+import Urbit.Vere.Clay        (clay)
+import Urbit.Vere.Http.Client (client)
+import Urbit.Vere.Http.Server (serv)
+import Urbit.Vere.Log         (EventLog)
+import Urbit.Vere.Serf        (Serf, SerfState(..), doJob, sStderr)
+
+import qualified System.Entropy         as Ent
+import qualified Urbit.King.API         as King
+import qualified Urbit.Time             as Time
+import qualified Urbit.Vere.Log         as Log
+import qualified Urbit.Vere.Serf        as Serf
+import qualified Urbit.Vere.Term        as Term
+import qualified Urbit.Vere.Term.API    as Term
+import qualified Urbit.Vere.Term.Demux  as Term
+import qualified Urbit.Vere.Term.Render as Term
+
+
+--------------------------------------------------------------------------------
+
+_ioDrivers = [] :: [IODriver]
+
+setupPierDirectory :: FilePath -> RIO e ()
+setupPierDirectory shipPath = do
+   for_ ["put", "get", "log", "chk"] $ \seg -> do
+       let pax = shipPath <> "/.urb/" <> seg
+       createDirectoryIfMissing True pax
+       io $ setFileMode pax ownerModes
+
+
+-- Load pill into boot sequence. -----------------------------------------------
+
+genEntropy :: RIO e Word512
+genEntropy = fromIntegral . bytesAtom <$> io (Ent.getEntropy 64)
+
+generateBootSeq :: Ship -> Pill -> Bool -> LegacyBootEvent -> RIO e BootSeq
+generateBootSeq ship Pill{..} lite boot = do
+    ent <- genEntropy
+    let ovums = preKern ent <> pKernelOvums <> postKern <> pUserspaceOvums
+    pure $ BootSeq ident pBootFormulas ovums
+  where
+    ident       = LogIdentity ship isFake (fromIntegral $ length pBootFormulas)
+    preKern ent = [ EvBlip $ BlipEvArvo $ ArvoEvWhom ()     ship
+                  , EvBlip $ BlipEvArvo $ ArvoEvWack ()     ent
+                  ]
+    postKern = [ EvBlip $ BlipEvTerm $ TermEvBoot (1,()) lite boot ]
+    isFake = case boot of
+      Fake _ -> True
+      _      -> False
+
+
+-- Write a batch of jobs into the event log ------------------------------------
+
+writeJobs :: EventLog -> Vector Job -> RIO e ()
+writeJobs log !jobs = do
+    expect <- Log.nextEv log
+    events <- fmap fromList $ traverse fromJob (zip [expect..] $ toList jobs)
+    Log.appendEvents log events
+  where
+    fromJob :: (EventId, Job) -> RIO e ByteString
+    fromJob (expectedId, job) = do
+        unless (expectedId == jobId job) $
+            error $ show ("bad job id!", expectedId, jobId job)
+        pure $ jamBS $ jobPayload job
+
+    jobPayload :: Job -> Noun
+    jobPayload (RunNok (LifeCyc _ m n)) = toNoun (m, n)
+    jobPayload (DoWork (Work _ m d o))  = toNoun (m, d, o)
+
+
+-- Boot a new ship. ------------------------------------------------------------
+
+booted :: (HasPierConfig e, HasStderrLogFunc e, HasLogFunc e)
+       => Pill -> Bool -> Serf.Flags -> Ship -> LegacyBootEvent
+       -> RAcquire e (Serf e, EventLog, SerfState)
+booted pill lite flags ship boot = do
+  seq@(BootSeq ident x y) <- rio $ generateBootSeq ship pill lite boot
+
+  rio $ logTrace "BootSeq Computed"
+
+  pierPath <- view pierPathL
+
+  liftRIO (setupPierDirectory pierPath)
+
+  rio $ logTrace "Directory Setup"
+
+  log  <- Log.new (pierPath <> "/.urb/log") ident
+
+  rio $ logTrace "Event Log Initialized"
+
+  serf <- Serf.run (Serf.Config pierPath flags)
+
+  rio $ logTrace "Serf Started"
+
+  rio $ do
+      (events, serfSt) <- Serf.bootFromSeq serf seq
+      logTrace "Boot Sequence completed"
+      Serf.snapshot serf serfSt
+      logTrace "Snapshot taken"
+      writeJobs log (fromList events)
+      logTrace "Events written"
+      pure (serf, log, serfSt)
+
+
+-- Resume an existing ship. ----------------------------------------------------
+
+resumed :: (HasStderrLogFunc e, HasPierConfig e, HasLogFunc e)
+        => Maybe Word64 -> Serf.Flags
+        -> RAcquire e (Serf e, EventLog, SerfState)
+resumed event flags = do
+    rio $ logTrace "Resuming ship"
+    top    <- view pierPathL
+    tap    <- fmap (fromMaybe top) $ rio $ runMaybeT $ do
+                ev <- MaybeT (pure event)
+                MaybeT (getSnapshot top ev)
+
+    rio $ logTrace $ display @Text ("pier: " <> pack top)
+    rio $ logTrace $ display @Text ("running serf in: " <> pack tap)
+
+    log    <- Log.existing (top <> "/.urb/log")
+
+    serf   <- Serf.run (Serf.Config tap flags)
+
+    serfSt <- rio $ Serf.replay serf log event
+
+    rio $ Serf.snapshot serf serfSt
+
+    pure (serf, log, serfSt)
+
+getSnapshot :: forall e. FilePath -> Word64 -> RIO e (Maybe FilePath)
+getSnapshot top last = do
+    lastSnapshot <- lastMay <$> listReplays
+    pure (replayToPath <$> lastSnapshot)
+  where
+    replayDir        = top </> ".partial-replay"
+    replayToPath eId = replayDir </> show eId
+
+    listReplays :: RIO e [Word64]
+    listReplays = do
+        createDirectoryIfMissing True replayDir
+        snapshotNums <- mapMaybe readMay <$> listDirectory replayDir
+        pure $ sort (filter (<= fromIntegral last) snapshotNums)
+
+
+-- Run Pier --------------------------------------------------------------------
+
+acquireWorker :: RIO e () -> RAcquire e (Async ())
+acquireWorker act = mkRAcquire (async act) cancel
+
+pier :: ∀e. (HasConfigDir e, HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
+     => (Serf e, EventLog, SerfState)
+     -> MVar ()
+     -> RAcquire e ()
+pier (serf, log, ss) mStart = do
+    computeQ  <- newTQueueIO
+    persistQ  <- newTQueueIO
+    executeQ  <- newTQueueIO
+    saveM     <- newEmptyTMVarIO
+    shutdownM <- newEmptyTMVarIO
+
+    kapi ← King.kingAPI
+
+    termApiQ <- atomically $ do
+        q <- newTQueue
+        writeTVar (King.kTermConn kapi) (Just $ writeTQueue q)
+        pure q
+
+    let shutdownEvent = putTMVar shutdownM ()
+
+    inst <- io (KingId . UV . fromIntegral <$> randomIO @Word16)
+
+    -- (sz, local) <- Term.localClient
+
+    -- (waitExternalTerm, termServPort) <- Term.termServer
+
+    (demux, muxed) <- atomically $ do
+        res <- Term.mkDemux
+        --  Term.addDemux local res
+        pure (res, Term.useDemux res)
+
+    -- rio $ logInfo $ display $
+        -- "TERMSERV Terminal Server running on port: " <> tshow termServPort
+
+    acquireWorker $ forever $ do
+            logTrace "TERMSERV Waiting for external terminal."
+            atomically $ do
+                ext <- Term.connClient <$> readTQueue termApiQ
+                Term.addDemux ext demux
+            logTrace "TERMSERV External terminal connected."
+
+    swapMVar (sStderr serf) (atomically . Term.trace muxed)
+
+    let logId = Log.identity log
+    let ship = who logId
+
+    -- Our call above to set the logging function which echos errors from the
+    -- Serf doesn't have the appended \r\n because those \r\n s are added in
+    -- the c serf code. Logging output from our haskell process must manually
+    -- add them.
+    let showErr = atomically . Term.trace muxed . (flip append "\r\n")
+    let (bootEvents, startDrivers) =
+            drivers inst ship (isFake logId)
+                (writeTQueue computeQ)
+                shutdownEvent
+                (Term.TSize{tsWide=80, tsTall=24}, muxed)
+                showErr
+
+    io $ atomically $ for_ bootEvents (writeTQueue computeQ)
+
+    tExe  <- startDrivers >>= router (readTQueue executeQ)
+    tDisk <- runPersist log persistQ (writeTQueue executeQ)
+    tCpu  <- runCompute serf ss
+               (readTQueue computeQ)
+               (takeTMVar saveM)
+               (takeTMVar shutdownM)
+               (Term.spin muxed)
+               (Term.stopSpin muxed)
+               (writeTQueue persistQ)
+
+    tSaveSignal <- saveSignalThread saveM
+
+    putMVar mStart ()
+
+    -- Wait for something to die.
+
+    let ded = asum [ death "effect thread" tExe
+                   , death "persist thread" tDisk
+                   , death "compute thread" tCpu
+                   ]
+
+    atomically ded >>= \case
+      Left (txt, exn) -> logError $ displayShow ("Somthing died", txt, exn)
+      Right tag       -> logError $ displayShow ("something simply exited", tag)
+
+    atomically $ (Term.spin muxed) (Just "shutdown")
+
+
+death :: Text -> Async () -> STM (Either (Text, SomeException) Text)
+death tag tid = do
+  waitCatchSTM tid <&> \case
+    Left exn -> Left (tag, exn)
+    Right () -> Right tag
+
+saveSignalThread :: TMVar () -> RAcquire e (Async ())
+saveSignalThread tm = mkRAcquire start cancel
+  where
+    start = async $ forever $ do
+      threadDelay (120 * 1000000) -- 120 seconds
+      atomically $ putTMVar tm ()
+
+-- Start All Drivers -----------------------------------------------------------
+
+data Drivers e = Drivers
+    { dAmes       :: EffCb e AmesEf
+    , dBehn       :: EffCb e BehnEf
+    , dHttpClient :: EffCb e HttpClientEf
+    , dHttpServer :: EffCb e HttpServerEf
+    , dNewt       :: EffCb e NewtEf
+    , dSync       :: EffCb e SyncEf
+    , dTerm       :: EffCb e TermEf
+    }
+
+drivers :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
+        => KingId -> Ship -> Bool -> (Ev -> STM ())
+        -> STM()
+        -> (Term.TSize, Term.Client)
+        -> (Text -> RIO e ())
+        -> ([Ev], RAcquire e (Drivers e))
+drivers inst who isFake plan shutdownSTM termSys stderr =
+    (initialEvents, runDrivers)
+  where
+    (behnBorn, runBehn) = behn inst plan
+    (amesBorn, runAmes) = ames inst who isFake plan stderr
+    (httpBorn, runHttp) = serv inst plan isFake
+    (clayBorn, runClay) = clay inst plan
+    (irisBorn, runIris) = client inst plan
+    (termBorn, runTerm) = Term.term termSys shutdownSTM inst plan
+    initialEvents       = mconcat [behnBorn, clayBorn, amesBorn, httpBorn,
+                                   termBorn, irisBorn]
+    runDrivers          = do
+        dNewt       <- runAmes
+        dBehn       <- liftAcquire $ runBehn
+        dAmes       <- pure $ const $ pure ()
+        dHttpClient <- runIris
+        dHttpServer <- runHttp
+        dSync       <- runClay
+        dTerm       <- runTerm
+        pure (Drivers{..})
+
+
+-- Route Effects to Drivers ----------------------------------------------------
+
+router :: HasLogFunc e => STM FX -> Drivers e -> RAcquire e (Async ())
+router waitFx Drivers{..} =
+    mkRAcquire start cancel
+  where
+    start = async $ forever $ do
+        fx <- atomically waitFx
+        for_ fx $ \ef -> do
+            logEffect ef
+            case ef of
+              GoodParse (EfVega _ _)               -> error "TODO"
+              GoodParse (EfExit _ _)               -> error "TODO"
+              GoodParse (EfVane (VEAmes ef))       -> dAmes ef
+              GoodParse (EfVane (VEBehn ef))       -> dBehn ef
+              GoodParse (EfVane (VEBoat ef))       -> dSync ef
+              GoodParse (EfVane (VEClay ef))       -> dSync ef
+              GoodParse (EfVane (VEHttpClient ef)) -> dHttpClient ef
+              GoodParse (EfVane (VEHttpServer ef)) -> dHttpServer ef
+              GoodParse (EfVane (VENewt ef))       -> dNewt ef
+              GoodParse (EfVane (VESync ef))       -> dSync ef
+              GoodParse (EfVane (VETerm ef))       -> dTerm ef
+              FailParse n                          -> logError
+                                                    $ display
+                                                    $ pack @Text (ppShow n)
+
+
+-- Compute Thread --------------------------------------------------------------
+
+data ComputeRequest
+    = CREvent Ev
+    | CRSave ()
+    | CRShutdown ()
+  deriving (Eq, Show)
+
+logEvent :: HasLogFunc e => Ev -> RIO e ()
+logEvent ev =
+    logDebug $ display $ "[EVENT]\n" <> pretty
+  where
+    pretty :: Text
+    pretty = pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow ev
+
+logEffect :: HasLogFunc e => Lenient Ef -> RIO e ()
+logEffect ef =
+    logDebug $ display $ "[EFFECT]\n" <> pretty ef
+  where
+    pretty :: Lenient Ef -> Text
+    pretty = \case
+       GoodParse e -> pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow e
+       FailParse n -> pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow n
+
+runCompute :: ∀e. HasLogFunc e
+           => Serf e
+           -> SerfState
+           -> STM Ev
+           -> STM ()
+           -> STM ()
+           -> (Maybe Text -> STM ())
+           -> STM ()
+           -> ((Job, FX) -> STM ())
+           -> RAcquire e (Async ())
+runCompute serf ss getEvent getSaveSignal getShutdownSignal
+           showSpinner hideSpinner putResult =
+    mkRAcquire (async (go ss)) cancel
+  where
+    go :: SerfState -> RIO e ()
+    go ss = do
+        cr  <- atomically $
+          CRShutdown <$> getShutdownSignal <|>
+          CRSave     <$> getSaveSignal     <|>
+          CREvent    <$> getEvent
+        case cr of
+          CREvent ev -> do
+            logEvent ev
+            wen <- io Time.now
+            eId <- pure (ssNextEv ss)
+            mug <- pure (ssLastMug ss)
+
+            atomically $ showSpinner (getSpinnerNameForEvent ev)
+            (job', ss', fx) <- doJob serf $ DoWork $ Work eId mug wen ev
+            atomically $ hideSpinner
+            atomically (putResult (job', fx))
+            go ss'
+          CRSave () -> do
+            logDebug $ "Taking periodic snapshot"
+            Serf.snapshot serf ss
+            go ss
+          CRShutdown () -> do
+            -- When shutting down, we first request a snapshot, and then we
+            -- just exit this recursive processing, which will cause the serf
+            -- to exit from its RAcquire.
+            logDebug $ "Shutting down compute system..."
+            Serf.snapshot serf ss
+            pure ()
+
+
+-- Persist Thread --------------------------------------------------------------
+
+data PersistExn = BadEventId EventId EventId
+  deriving Show
+
+instance Exception PersistExn where
+  displayException (BadEventId expected got) =
+    unlines [ "Out-of-order event id send to persist thread."
+            , "\tExpected " <> show expected <> " but got " <> show got
+            ]
+
+runPersist :: ∀e. (HasPierConfig e, HasLogFunc e)
+           => EventLog
+           -> TQueue (Job, FX)
+           -> (FX -> STM ())
+           -> RAcquire e (Async ())
+runPersist log inpQ out =
+    mkRAcquire runThread cancel
+  where
+    runThread :: RIO e (Async ())
+    runThread = asyncBound $ do
+        dryRun <- view dryRunL
+        forever $ do
+            writs  <- atomically getBatchFromQueue
+            unless dryRun $ do
+                events <- validateJobsAndGetBytes (toNullable writs)
+                Log.appendEvents log events
+            atomically $ for_ writs $ \(_,fx) -> out fx
+
+    validateJobsAndGetBytes :: [(Job, FX)] -> RIO e (Vector ByteString)
+    validateJobsAndGetBytes writs = do
+        expect <- Log.nextEv log
+        fmap fromList
+            $ for (zip [expect..] writs)
+            $ \(expectedId, (j, fx)) -> do
+                unless (expectedId == jobId j) $
+                    throwIO (BadEventId expectedId (jobId j))
+                case j of
+                  RunNok _ ->
+                      error "This shouldn't happen here!"
+                  DoWork (Work eId mug wen ev) ->
+                      pure $ jamBS $ toNoun (mug, wen, ev)
+
+    getBatchFromQueue :: STM (NonNull [(Job, FX)])
+    getBatchFromQueue =
+        readTQueue inpQ >>= go . singleton
+      where
+        go acc =
+          tryReadTQueue inpQ >>= \case
+            Nothing   -> pure (reverse acc)
+            Just item -> go (item <| acc)