retroforth/example/Tuporo.forth
crc e71709b303 begin work on 2018.6; this release *will* make some changes that break existing code in small ways
FossilOrigin-Name: 2ea7e4d5f74070041c454af65713a478ebe2a9d71bbc9e6bb6add6c256351765
2018-04-25 16:51:46 +00:00

244 lines
6.5 KiB
Forth

#!/usr/bin/env rre
# tūporo: a gopher-based block store for retro
## Overview
Traditional Forths often provided simple editors oriented around blocks.
A standard block is a single unit of text, with 16 lines of 64 symbols
per line, or 1024 characters. While far less common now, blocks are
still useful, and RETRO has had some support for them in most of its
incarnations.
With my recent interest in Gopher, I've decided that my next take on
blocks will use Gopher.
So the basic goal of this is to provide a Gopher server capable of
transfer and update of blocks, and also a means of browsing the blocks
via Gopher. As with all of my recent servers, this will run under `tui`,
`tcpserver` or `inetd`.
## Configuration
The basic configuration settings are the number of blocks (`MAX-BLOCKS`)
and the path to the block file (including the file name). This is also
where the server URL (or IP) and port are set.
~~~
:BLOCKS '/home/crc/blocks ;
:SERVER 'forthworks.com ;
#8081 'PORT const
#200 'MAX-BLOCKS const
~~~
## Block I/O
First up are a scratch variable (`FID`) to hold the file ID for use with
reads/writes, and a safe buffer to store the currently loaded block. I
will use the `buffer:` namespace for interacting with the block, so it
needs to be one cell longer than the actual data length to account for
the final ASCII NUL terminator.
~~~
'FID var
'Block d:create #1025 allot
~~~
`block:locate` moves the index in the blockfile to the actual starting
point for a particular block.
~~~
:block:locate (n-)
#1024 * @FID file:seek ;
~~~
`block:copy` copies the data for the current block into the `Block`
buffer.
~~~
:block:copy (-)
#1024 [ @FID file:read buffer:add ] times ;
~~~
The top level `block:get` word sets the current buffer to `Block`, then
loads the block file and copies the requested block into the buffer. It
returns the address of the `Block` buffer.
~~~
:block:get (n-s)
&Block buffer:set
BLOCKS file:R file:open !FID
block:locate block:copy
@FID file:close &Block ;
~~~
`block:set` writes a string into a block. The string *can* be longer
than a block, in which case it writes to subsequent blocks.
~~~
:block:set (sn-)
BLOCKS file:R+ file:open !FID
block:locate dup s:length [ fetch-next @FID file:write ] times drop
@FID file:close ;
~~~
## Browsing
To be able to browse the blocks, we first need a means of displaying a
top level index (returned when the Gopher client sends a request as an
empty selector string).
I'll use `generate-index` for this. A Gopher directory line looks like:
<type><description>\t<selector>\t<server>\t<port>
The type of interest here is:
0 plain text
I define `generate-entry` to make a line for a block. It takes a
description and selector and uses the SERVER and PORT variables to
construct the line.
~~~
:generate-entry (ss-)
SERVER PORT 'abcd 'dcba reorder '0%s\t%s\t%s\t%n s:format puts nl ;
~~~
With this it's easy to define `generate-index` using a loop to make a
usable directory index listing all blocks.
~~~
:generate-index (-)
#0 MAX-BLOCKS
[ dup n:to-string over '/%n s:format generate-entry n:inc ] times
drop ;
~~~
Displaying a block as plain text is very easy. Using `block:get` to fetch
the data, it's just two loops (one for each line, one for each charaacter)
displaying the characters and newlines as needed.
~~~
:display-block (n-)
block:get #16 [ #64 [ fetch-next putc ] times nl ] times drop ;
~~~
## ...
## Gopher Protocol
Tūporo decides what to do based on the selectors passed to it. These are
what I will recognize:
/ directory index of all blocks
/nnnn block #nnnn (as formatted text data)
/r/nnnn block #nnnn (as raw text data)
/s/nnnn/text change block #nnnn to specified raw text data
I have a `Selector` buffer for storing the selector the user passes in.
This is sized to be big enough for the incoming block data (if using /s)
with room to spare.
~~~
'Selector d:create #4096 allot
~~~
The `prefix` word returns the first two characters of the selector. This
will be enough to identify what type of request we are dealing with.
~~~
:prefix (-s)
&Selector #0 #2 s:substr ;
~~~
`raw-block` returns a raw, unformatted block as text data. This will
correspond to /r/nnnn selectors.
~~~
:raw-block (-)
&Selector #3 + s:chop block:get puts ;
~~~
`set-block` updates a block with new text. This selector takes a form:
/s/block#/text
It's probably *not* a good idea to leave this exposed on a public
server as there is no means provided of restricting writes using it.
~~~
:set-block (-)
&Selector #3 +
$/ s:split s:to-number swap n:inc s:chop swap block:set ;
~~~
And `handle-block` uses `display-block` to return a formatted text block
when browsing.
~~~
:handle-block (-)
&Selector n:inc s:chop s:to-number display-block ;
~~~
The top level `handle` word decides how to handle each selector using the
results of `prefix`. Selectors that don't match up to one of the handled
ones just return a directory listing.
~~~
:handle
prefix
'/r [ raw-block ] s:case
'/s [ set-block ] s:case
'/0 [ handle-block ] s:case
'/1 [ handle-block ] s:case
'/2 [ handle-block ] s:case
'/3 [ handle-block ] s:case
'/4 [ handle-block ] s:case
'/5 [ handle-block ] s:case
'/6 [ handle-block ] s:case
'/7 [ handle-block ] s:case
'/8 [ handle-block ] s:case
'/9 [ handle-block ] s:case
drop generate-index ;
~~~
And finally, a quick bit from Atua to read in the selector and pass it
to `handle`
~~~
:eol? (c-f)
[ ASCII:CR eq? ] [ ASCII:LF eq? ] [ ASCII:HT eq? ] tri or or ;
:gets (a-)
buffer:set
[ getc dup buffer:add eol? not ] while ;
&Selector gets handle
~~~
## Future Direction
It'd probably be a good idea to add some authentication so unknown users
can't write changes to the block store.
Other than that, it's a simple, clean system for exposing a blockfile via
Gopher.
## Legalities
Copyright (c) 2017, Charles Childers
Permission to use, copy, modify, and/or distribute this software for
any purpose with or without fee is hereby granted, provided that the
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
PERFORMANCE OF THIS SOFTWARE.