ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-12-24 15:34:10 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into hoon-spot

Browse Source
This commit is contained in:
Liam Fitzgerald 2020-02-26 09:29:54 +10:00
commit 8c6ae6f917
131 changed files with 30103 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored
View File

@ -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

3
.ignore Normal file
View File

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

84
.stylish-haskell.yaml Normal file
View File

@ -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

49
.travis.yml
View File

@ -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

107
MAINTAINERS.md
View File

@ -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.

4
bin/brass.pill
View File

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

2
bin/ivory.pill
View File

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

4
bin/solid.pill
View File

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

1
pkg/arvo/.ignore Normal file
View File

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

10
pkg/arvo/app/permission-hook.hoon
View File

@ -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]

6
pkg/arvo/app/ping.hoon
View File

@ -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

2
pkg/arvo/gen/dbug.hoon
View File

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

2
pkg/arvo/gen/frontpage.hoon
View File

@ -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)>}."
==

4
pkg/arvo/sys/hoon.hoon
View File

@ -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

14
pkg/arvo/sys/vane/ames.hoon
View File

@ -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
::

38
pkg/arvo/sys/vane/gall.hoon
View File

@ -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

51
pkg/hs/default.nix Normal file
View File

@ -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;
}

12
pkg/hs/lmdb-static/.gitignore vendored Normal file
View File

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

24
pkg/hs/lmdb-static/LICENSE Normal file
View File

@ -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.

13
pkg/hs/lmdb-static/README.md Normal file
View File

@ -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
```

3
pkg/hs/lmdb-static/Setup.hs Normal file
View File

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

1653
pkg/hs/lmdb-static/cbits/lmdb.h Normal file
View File

File diff suppressed because it is too large Load Diff

11199
pkg/hs/lmdb-static/cbits/mdb.c Normal file
View File

File diff suppressed because it is too large Load Diff

421
pkg/hs/lmdb-static/cbits/midl.c Normal file
View File

@ -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 */
/** @} */
/** @} */

200
pkg/hs/lmdb-static/cbits/midl.h Normal file
View File

@ -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_ */

1444
pkg/hs/lmdb-static/hsrc_lib/Database/LMDB/Raw.hsc Normal file
View File

File diff suppressed because it is too large Load Diff

89
pkg/hs/lmdb-static/lmdb-static.cabal Normal file
View File

@ -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

3
pkg/hs/proto/.gitignore vendored Normal file
View File

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

21
pkg/hs/proto/LICENSE Normal file
View File

@ -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.

41
pkg/hs/proto/app/Main.hs Normal file
View File

@ -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

135
pkg/hs/proto/lib/Dashboard.hs Normal file
View File

@ -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))
]

302
pkg/hs/proto/lib/Deppy/Core.hs Normal file
View File

@ -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

114
pkg/hs/proto/lib/Nock.hs Normal file
View File

@ -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"

122
pkg/hs/proto/lib/SimpleNoun.hs Normal file
View File

@ -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

54
pkg/hs/proto/lib/Untyped/CST.hs Normal file
View File

@ -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)

230
pkg/hs/proto/lib/Untyped/Core.hs Normal file
View File

@ -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)

77
pkg/hs/proto/lib/Untyped/Hoon.hs Normal file
View File

@ -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

345
pkg/hs/proto/lib/Untyped/Parser.hs Normal file
View File

@ -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

24
pkg/hs/proto/lib/Untyped/ShittyCorePrinter.hs Normal file
View File

@ -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'] ]

91
pkg/hs/proto/package.yaml Normal file
View File

@ -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

6
pkg/hs/proto/test/Spec.hs Normal file
View File

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

26
pkg/hs/stack.yaml Normal file
View File

@ -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'

1
pkg/hs/terminal-progress-bar/LICENSE Symbolic link
View File

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

1
pkg/hs/terminal-progress-bar/README.markdown Symbolic link
View File

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

2
pkg/hs/terminal-progress-bar/Setup.hs Normal file
View File

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

51
pkg/hs/terminal-progress-bar/bench/bench.hs Normal file
View File

@ -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

1
pkg/hs/terminal-progress-bar/changelog.md Symbolic link
View File

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

2
pkg/hs/terminal-progress-bar/shell.nix Normal file
View File

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

716
pkg/hs/terminal-progress-bar/src/System/ProgressBar.hs Normal file
View File

@ -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%
@
-}

72
pkg/hs/terminal-progress-bar/terminal-progress-bar.cabal Normal file
View File

@ -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

102
pkg/hs/terminal-progress-bar/test/test.hs Normal file
View File

@ -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"

1
pkg/hs/urbit-atom/.gitignore vendored Normal file
View File

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

21
pkg/hs/urbit-atom/LICENSE Normal file
View File

@ -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.

61
pkg/hs/urbit-atom/lib/Urbit/Atom.hs Normal file
View File

@ -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

223
pkg/hs/urbit-atom/lib/Urbit/Atom/Internal.hs Normal file
View File

@ -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
--------------------------------------------------------------------------------

66
pkg/hs/urbit-atom/package.yaml Normal file
View File

@ -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

1
pkg/hs/urbit-azimuth/.gitignore vendored Normal file
View File

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

21
pkg/hs/urbit-azimuth/LICENSE Normal file
View File

@ -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.

5
pkg/hs/urbit-azimuth/Urbit/Azimuth.hs Normal file
View File

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

1
pkg/hs/urbit-azimuth/azimuth.json Normal file
View File

File diff suppressed because one or more lines are too long

55
pkg/hs/urbit-azimuth/package.yaml Normal file
View File

@ -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

3
pkg/hs/urbit-king/.gitignore vendored Normal file
View File

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

21
pkg/hs/urbit-king/LICENSE Normal file
View File

@ -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.

2
pkg/hs/urbit-king/app/Main.hs Normal file
View File

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

139
pkg/hs/urbit-king/lib/Data/RAcquire.hs Normal file
View File

@ -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

13
pkg/hs/urbit-king/lib/Urbit/Arvo.hs Normal file
View File

@ -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]

236
pkg/hs/urbit-king/lib/Urbit/Arvo/Common.hs Normal file
View File

@ -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

205
pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs Normal file
View File

@ -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"

375
pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs Normal file
View File

@ -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

135
pkg/hs/urbit-king/lib/Urbit/King/API.hs Normal file
View File

@ -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"

140
pkg/hs/urbit-king/lib/Urbit/King/App.hs Normal file
View File

@ -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

389
pkg/hs/urbit-king/lib/Urbit/King/CLI.hs Normal file
View File

@ -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."
)

53
pkg/hs/urbit-king/lib/Urbit/King/Config.hs Normal file
View File

@ -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

192
pkg/hs/urbit-king/lib/Urbit/King/EventBrowser.hs Normal file
View File

@ -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)

638
pkg/hs/urbit-king/lib/Urbit/King/Main.hs Normal file
View File

@ -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"
-}

52
pkg/hs/urbit-king/lib/Urbit/King/TryJamPill.hs Normal file
View File

@ -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"

57
pkg/hs/urbit-king/lib/Urbit/Noun.hs Normal file
View File

@ -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

860
pkg/hs/urbit-king/lib/Urbit/Noun/Conversions.hs Normal file
View File

@ -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

199
pkg/hs/urbit-king/lib/Urbit/Noun/Convert.hs Normal file
View File

@ -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

171
pkg/hs/urbit-king/lib/Urbit/Noun/Core.hs Normal file
View File

@ -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

392
pkg/hs/urbit-king/lib/Urbit/Noun/Cue.hs Normal file
View File

@ -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

368
pkg/hs/urbit-king/lib/Urbit/Noun/Jam.hs Normal file
View File

@ -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)

269
pkg/hs/urbit-king/lib/Urbit/Noun/TH.hs Normal file
View File

@ -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

283
pkg/hs/urbit-king/lib/Urbit/Noun/Tank.hs Normal file
View File

@ -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]
--
--
-}

245
pkg/hs/urbit-king/lib/Urbit/Noun/Tree.hs Normal file
View File

@ -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)

49
pkg/hs/urbit-king/lib/Urbit/Prelude.hs Normal file
View File

@ -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"

111
pkg/hs/urbit-king/lib/Urbit/Time.hs Normal file
View File

@ -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)

45
pkg/hs/urbit-king/lib/Urbit/Timer.hs Normal file
View File

@ -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 ()

305
pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs Normal file
View File

@ -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)

48
pkg/hs/urbit-king/lib/Urbit/Vere/Behn.hs Normal file
View File

@ -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)

237
pkg/hs/urbit-king/lib/Urbit/Vere/Clay.hs Normal file
View File

@ -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

307
pkg/hs/urbit-king/lib/Urbit/Vere/Dawn.hs Normal file
View File

@ -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

25
pkg/hs/urbit-king/lib/Urbit/Vere/Http.hs Normal file
View File

@ -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)

158
pkg/hs/urbit-king/lib/Urbit/Vere/Http/Client.hs Normal file
View File

@ -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)

555
pkg/hs/urbit-king/lib/Urbit/Vere/Http/Server.hs Normal file
View File

@ -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

325
pkg/hs/urbit-king/lib/Urbit/Vere/LMDB.hs Normal file
View File

@ -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

30
pkg/hs/urbit-king/lib/Urbit/Vere/LockFile.hs Normal file
View File

@ -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)

429
pkg/hs/urbit-king/lib/Urbit/Vere/Log.hs Normal file
View File

@ -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

186
pkg/hs/urbit-king/lib/Urbit/Vere/NounServ.hs Normal file
View File

@ -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

460
pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs Normal file
View File

@ -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)

Some files were not shown because too many files have changed in this diff Show More