3 files changed, 106 insertions, 0 deletions

@@ -0,0 +1 @@
+qotd
@@ -0,0 +1,11 @@
+PREFIX ?= /usr/local
+
+qotd: qotd.scm
+        csc $< -o $@
+
+.PHONY: install uninstall
+install: qotd
+        install -D $< $(PREFIX)/bin/$<
+
+uninstall:
+        rm -f $(PREFIX)/bin/$<
@@ -0,0 +1,94 @@
+#!/bin/sh
+#| -*- scheme -*-
+exec csi -s $0 "$@"
+Copyright (C) 2022 C Duckworth <acdw@acdw.net>
+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))