#!/bin/sh #| -*- scheme -*- exec csi -s $0 "$@" Copyright (C) 2022 C Duckworth An implementation of the QOTD protocol (RFC 865) |# (import (chicken condition) (chicken file) (chicken io) (chicken port) (chicken process) (chicken process-context) (chicken tcp)) (define qotd-version 0.1) (define qotd-port 17) (define qotd-backlog 100) (define qotd-host "localhost") (define qotd-file "/tmp/qotd") (define (usage) (with-output-to-port (current-error-port) (lambda () (display "Usage: qotd [-host HOST] [-port PORT] [-backlog LINES] [-file FILE]\n") (display "Default -host: localhost\n") (display "Default -port: 17\n") (display "Default -backlong: 100\n") (display "Default -file: /tmp/qotd\n")))) (define (handle quote listener) (define-values (i o) (tcp-accept listener)) (write-string (quote) #f o) (close-input-port i) (close-output-port o)) (define (read-output command-line) ; unused (call-with-input-pipe command-line (lambda (port) (read-string #f port)))) (define (file-read* filename) (if (and (file-exists? filename) (file-readable? filename)) (with-input-from-file filename read-string) #f)) (define (ensure-final-newline str) (cond ((char=? (string-ref str (- (string-length str) 1)) #\newline) str) (else (string-append str "\n")))) (define (main arguments) (with-output-to-port (current-error-port) (lambda () (display "Welcome to QOTD v.") (display qotd-version) (newline))) (let argloop ((args arguments)) (cond ((null? args) #f) (else (cond ((or (member "-help" args) (member "-h" args)) (usage) (exit 0)) ((member "-port" args) => (lambda (a) (set! qotd-port (cadr a)))) ((member "-host" args) => (lambda (a) (set! qotd-host (cadr a)))) ((member "-backlog" args) => (lambda (a) (set! qotd-backlog (cadr a)))) ((member "-file" args) => (lambda (a) (set! qotd-file (cadr a))))) (argloop (cdr args))))) (with-output-to-port (current-error-port) (lambda () (display "QOTD Port: ") (display qotd-port) (newline) (display "QOTD Backlog: ") (display qotd-backlog) (newline) (display "QOTD Server: ") (display qotd-host) (newline) (display "QOTD File: ") (display qotd-file) (newline))) (let loop ((listener (tcp-listen qotd-port qotd-backlog qotd-host))) (handle (lambda () (let ((qotd (ensure-final-newline (file-read* qotd-file)))) (if qotd qotd "Oop\n"))) listener) (loop listener))) (main (command-line-arguments))