#! /usr/bin/gforth
\ Copyright (C) 2005 Jason Woofenden
\
\ This file is part of filb.
\
\ filb is free software; you can redistribute it and/or modify it
\ under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2, or (at your option)
\ any later version.
\
\ filb is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\ General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with filb; see the file COPYING. If not, write to the
\ Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
\ MA 02111-1307, USA.
\ OVERVIEW
\
\ This program reads in the IRC protocol from a file and outputs an html
\ document. It uses template.html to arrange the output.
\
\ It could be run like so:
\
\ gforth filb.gf
\
\ If I've coded it correctly, it should not crash or spin or spit out any
\ malicious html, but if input doesn't follow the spec it may look very wrong.
\
\ Each nickname is given a span tag with it's own class so that the CSS
\ stylesheet can contain different colors for different nicks.
\
\ Long nicknames are silently cut short.
include code/gforthcgi/gforthcgi.fs
\ SETTINGS
" channel #c4th
: okheaders 200ok text/html ;
: 404headers 404fnf text/html ;
\ we can find the path to this folder by removing filb.fs from the end of SCRIPT_NAME
\ we can find the garbage after it by removing the path to this folder from REQUEST_URI
: script-name-len s" SCRIPT_NAME" env dup 0=; drop nip 2 - ; ( -- u )
: getarg s" REQUEST_URI" env dup 0=; drop script-name-len 2dup <= if drop drop drop 0 exit then tuck - >r + r> ; ( -- addr u | 0 ) return the string passed on the URL
\ not using get variables anymore... just the whole string as one arg... get-parse \ Parse the GET variables for the variables defined above
\ CHARS
\ FIXME: switch to 'a or whatever (is it 'a' maybe?)
32 constant #sp
char _ constant #_
char & constant #&
char # constant ##
char ; constant #;
char ! constant #!
char : constant #:
char * constant #*
\ STRINGS
\ strings have the following format in memory: one cell for the count followed by
\ the data. The pointer returned by the name points to the data _not_ the count.
: string-allot 0 , here swap aligned allot constant ;
: count 4 - @ ;
: ctype dup count type ;
: string-empty 0 swap 4 - ! ; ( string -- )
: string-append-c dup count 2dup 1 + swap 4 - ! + c! ; ( char string -- )
: string-cmp >r 4 - dup @ 4 + r> 4 - over compare not ; ( string string -- t/f )
\ VARIABLES/CONSTANTS
16 constant max-nick \ the irc spec I was looking at said that nicks are limited to 9 chars I'm not sure freenode enforces this.
max-nick string-allot nick
10 constant max-command
max-command string-allot command
" privmsg PRIVMSG
" class-chars abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_
" html-chars abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_`~!@#$% ^*(){}[]?/+=|\-:;"',.
" nbsp
variable last-key
: nbspaces dup 0 = if exit then for nbsp ctype next ; ( x -- print x non-breaking spaces )
\ UTILS
: char-in-string? dup count for 2dup c@ = if 2drop unloop 1 exit then 1 + next 2drop 0 ; ( char string -- t/f )
: html-entity #& emit ## emit .. #; emit ; ( char -- )
: html-emit dup html-chars char-in-string? if emit exit then html-entity ; ( char -- print char encoded for html )
: html-ctype dup count dup 0 = if 2drop exit then for dup c@ html-emit 1 + next drop ; ( string -- print string encoded for html )
\ PARSING
variable fd \ file descriptor for open log file
variable read-buf
: last-char last-key @ ;
: at-eof? last-char -1 = ; ( -- t/f ) have we hit end-of-file already?
: -get-char at-eof? if -1 exit then read-buf 1 fd @ read-file drop 0 = if -1 exit then read-buf c@ ;
: get-char -get-char dup 13 = if drop tail-recurse exit then dup last-key ! ;
: at-eol? ( -- t/f have we hit end-of-line already? )
last-char 10 = at-eof? or ;
: eat-c get-char drop ; ( -- )
: eat-host get-char #sp = at-eol? or if exit then tail-recurse ; ( -- )
: eat-channel get-char #sp = at-eol? or if exit then tail-recurse ; ( -- )
: eat-line eat-c at-eol? if exit then tail-recurse ; ( -- )
\ : eol? dup 13 = if eat-c drop -1 exit then -1 = ; ( char -- t/f ) return if it's a newline, and remove the following character if it's a 13
: eol? dup 10 = if drop -1 exit then -1 = ;
\ PARSE NICK
: nick-char? dup #! = if drop 0 exit then eol? not ;
: ?pn-add-c dup nick-char? if nick string-append-c 0 exit then drop 1 ;
: clear-nick nick string-empty ;
: parse-nick clear-nick max-nick for get-char ?pn-add-c if unloop exit then next ;
\ PARSE COMMAND
: clear-command command string-empty ; ( -- )
: ?pc-add-c get-char #sp = at-eol? or if 1 exit then last-char command string-append-c 0 ;
: parse-command clear-command max-command for ?pc-add-c if unloop exit then next ; ( -- )
: is-privmsg? command privmsg string-cmp ;
: eat-action eat-c eat-c eat-c eat-c eat-c eat-c eat-c ;
\ PARSE CHANNEL
: check-channel parse-command command channel string-cmp ;
: to-lower dup #AA < if; dup #ZZ > if; #AA - #a + ; ( X -- x ) return lowercase version of x.
: nick-class-char to-lower dup class-chars char-in-string? if emit exit then drop #_ emit ;
: %nchar dup count for dup c@ nick-class-char 1 + next drop ; ( string -- )
: %hchar -enc-html ; ( string -- )
: nick-pad max-nick nick count - nbspaces ;
" s-normal-nick %h:
" s-action-nick *%h
: normal-nick nick dup s-normal-nick %type ;
: action-nick nick dup s-action-nick %type ;
: dump-to get-char over = at-eof? or if drop exit then last-char html-emit tail-recurse ; ( char -- ) dump characters until char or EOF is reached
: print-action action-nick eat-action 1 dump-to eat-c ;
: print-normal normal-nick last-char emit 10 dump-to ;
: -print-message nick-pad get-char 1 = if print-action exit then print-normal ;
: parse-message ." " -print-message ."
" cr ;
: parse-message-line check-channel 0if eat-line exit then eat-c parse-message ;
: parse-data-line parse-nick eat-host parse-command is-privmsg? if parse-message-line exit then eat-line ;
: parse-line get-char #: = if parse-data-line exit then ;
: parse-lines 5000 for parse-line at-eof? if unloop exit then next ;
: test-getc .s cr 13000 for eat-c next .s cr get-char .s cr ;
" 404msg Couldn't find a log file for this date (file '%a' not found)
: parse-file 2dup r/o open-file if drop dup au-allot 404msg %save 404headers exit then okheaders emit>mem fd ! 2drop parse-lines fd @ close-file drop e>m-save ; ( addr u -- data )
: parse-file" #" parse parse-file ; ( "filename" -- )
\ DATES
1072915200 constant epoch \ april 1st 2004
: d/ um/mod nip ; ( dou ble x -- double/x ) divide a double by a single
: now utime 1000000 d/ epoch - ; ( -- seconds-since-my-epoch )
: today now 86400 / ; ( -- days-since-my-epoch )
: 1. #0 + emit ;
: 02. 10 /mod 1. 1. ;
: 04. 10 /mod 10 /mod 10 /mod 1. 1. 1. 1. ;
: dash '- emit ;
: year4. 2004 + 04. ;
: year2. 4 + 02. ;
: month. 1+ 02. ;
: day. 1+ 02. ;
create year-t 31 , 29 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ,
: year-t-offset a year-t - 4 / ; ( -- x ) return the number of words into the year-t where A points
: -scan-year 12 for +@ 2dup < if drop year-t-offset true unloop exit then - next false ; ( days -- day month true | remaining-days false )
: feb-size 4 mod 0if 29 exit then 28 ; ( year -- days-in-feb )
: year-size feb-size 337 + ; ( year -- #-of-days ) return the number of days in that year
: year-t-fix feb-size year-t 4+ ! ; ( year# -- ) fix february in year-t for given year
: scan-year year-t-fix year-t w>a -scan-year ; ( days year -- day month true | remaining-days false )
: -days->dmy >>r scan-year if r> exit then r> 1+ tail-recurse ; ( days year -- day month year )
: days->dmy 0 -days->dmy ; ( days -- day month year )
: yyyy-mm-dd days->dmy year4. dash month. dash day. ; ( days-since-my-epoch -- ) print a date in the format YYYY-MM-DD
: yy-mm-dd days->dmy year2. dash month. dash day. ; ( days-since-my-epoch -- ) print a date in the format YYYY-MM-DD
: yyyy days->dmy year4. 2drop ;
: mm days->dmy drop month. drop ;
: dd days->dmy 2drop day. ;
: %-char apush yy-mm-dd apop ;
" filename c4th/%-.txt
: parse-day filename %au parse-file ; ( day# -- data ) (FIXME: change to e>m-au) open log for day# and return html version
: date-test 0 900 for dup yyyy-mm-dd cr 1+ next ;
variable v-date-len
: date-len v-date-len @ ;
variable v-year
variable v-display-xt
arg: link-prev
arg: date
arg: link-next
arg: chat
arg: year
arg: month
arg: day
: day->date emit>mem yyyy-mm-dd e>m-save ; ( day# -- data ) convert date to string
: day->yyyy emit>mem yyyy e>m-save ; ( day# -- data ) convert date to string
: day->mm emit>mem mm e>m-save ; ( day# -- data ) convert date to string
: day->dd emit>mem dd e>m-save ; ( day# -- data ) convert date to string
: -day-display-date-parts dup day->yyyy year ! dup day->mm month ! day->dd day ! ; ( day# -- )
: -day-display-dates dup 1- day->date link-prev ! dup day->date date ! 1+ day->date link-next ! ; ( day# -- )
: -day-display dup -day-display-dates dup -day-display-date-parts parse-day chat ! ;
: day-display -day-display s" filb.fs.day.html" run-template bye ; ( day# -- doesn't return
: month-display okheaders s" filb.fs.month.html" run-template bye ;
: year-display okheaders s" filb.fs.year.html" run-template bye ;
: redirect-to-today today day->date dup count redirect ; ( -- doesn't return. send HTTP redirect to current date
: next-digit b+@ dup '0 < over '9 > or if redirect-to-today then '0 - ; ( "0"-"9" -- 0-9 ) doesn't return if not in range
: -year->i 0 4 for 10 * next-digit + next dup 2004 < if redirect-to-today then 2004 - dup v-year ! ; ( -- year# ) eat 4 bytes from A and return as years past 2004
: 2digit->i next-digit 10 * next-digit + ; ( -- i )
: -month->i 2digit->i 1- dup 12 < if; redirect-to-today ; ( -- month# ) eat 4 bytes from A and return month number
: -day->i 2digit->i 1- ; ( -- year# ) eat 4 bytes from A and return as years past 2004
: parse-dash b+@ '- = if; redirect-to-today ; ( -- ) eat a dash or freak out
: -years 0; 1- >>r year-size + r> tail-recurse ; ( 0 year# -- first-day# )
: years 0 swap -years ; ( year# -- first-day# ) return the day number for the first day in given year
: months apush v-year @ year-t-fix year-t w>a 0 swap for +@ + next apop ; ( month# -- day# ) within year v-year
: ---date->day parse-dash -day->i + ; ( -- day# ) suppose I could check if there's too many days for the month...
: --date->day parse-dash -month->i months + date-len 7 = if exit then ---date->day ; ( -- day# )
: -date->day -year->i years date-len 4 = if exit then --date->day ; ( -- day# )
: date-size->type,xt dup 4 = if ['] year-display exit then dup 7 = if ['] month-display exit then dup 10 = if ['] day-display exit then redirect-to-today ; ( date-len -- date-len display-xt )
: dd-set-type date-size->type,xt v-display-xt ! v-date-len ! ; ( u -- ) set variables for parsing date u bytes long
: date->day dd-set-type b>a -date->day ; ( addr u -- day# ) doesn't return if date is invalid
: -display 0; date->day v-display-xt @ execute ;
: display getarg -display redirect-to-today ;
display \ doesn't return