summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--Makefile11
-rwxr-xr-xqotd.scm94
3 files changed, 106 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..0d1e9c8 --- /dev/null +++ b/.gitignore
@@ -0,0 +1 @@
qotd
diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..bb1524a --- /dev/null +++ b/Makefile
@@ -0,0 +1,11 @@
1PREFIX ?= /usr/local
2
3qotd: qotd.scm
4 csc $< -o $@
5
6.PHONY: install uninstall
7install: qotd
8 install -D $< $(PREFIX)/bin/$<
9
10uninstall:
11 rm -f $(PREFIX)/bin/$<
diff --git a/qotd.scm b/qotd.scm new file mode 100755 index 0000000..33f8abb --- /dev/null +++ b/qotd.scm
@@ -0,0 +1,94 @@
1#!/bin/sh
2#| -*- scheme -*-
3exec csi -s $0 "$@"
4Copyright (C) 2022 C Duckworth <acdw@acdw.net>
5An implementation of the QOTD protocol (RFC 865)
6|#
7
8(import (chicken condition)
9 (chicken file)
10 (chicken io)
11 (chicken port)
12 (chicken process)
13 (chicken process-context)
14 (chicken tcp))
15
16(define qotd-version 0.1)
17
18(define qotd-port 17)
19(define qotd-backlog 100)
20(define qotd-host "localhost")
21(define qotd-file "/tmp/qotd")
22
23(define (usage)
24 (with-output-to-port (current-error-port)
25 (lambda ()
26 (display "Usage: qotd [-host HOST] [-port PORT] [-backlog LINES] [-file FILE]\n")
27 (display "Default -host: localhost\n")
28 (display "Default -port: 17\n")
29 (display "Default -backlong: 100\n")
30 (display "Default -file: /tmp/qotd\n"))))
31
32(define (handle quote listener)
33 (define-values (i o) (tcp-accept listener))
34 (write-string (quote) #f o)
35 (close-input-port i)
36 (close-output-port o))
37
38(define (read-output command-line) ; unused
39 (call-with-input-pipe command-line
40 (lambda (port)
41 (read-string #f port))))
42
43(define (file-read* filename)
44 (if (and (file-exists? filename)
45 (file-readable? filename))
46 (with-input-from-file filename read-string)
47 #f))
48
49(define (ensure-final-newline str)
50 (cond ((char=? (string-ref str (- (string-length str) 1)) #\newline) str)
51 (else (string-append str "\n"))))
52
53(define (main arguments)
54 (with-output-to-port (current-error-port)
55 (lambda ()
56 (display "Welcome to QOTD v.")
57 (display qotd-version)
58 (newline)))
59
60 (let argloop ((args arguments))
61 (cond ((null? args) #f)
62 (else (cond
63 ((or (member "-help" args)
64 (member "-h" args))
65 (usage)
66 (exit 0))
67 ((member "-port" args) => (lambda (a) (set! qotd-port (cadr a))))
68 ((member "-host" args) => (lambda (a) (set! qotd-host (cadr a))))
69 ((member "-backlog" args) => (lambda (a) (set! qotd-backlog (cadr a))))
70 ((member "-file" args) => (lambda (a) (set! qotd-file (cadr a)))))
71 (argloop (cdr args)))))
72
73 (with-output-to-port (current-error-port)
74 (lambda ()
75 (display "QOTD Port: ")
76 (display qotd-port)
77 (newline)
78 (display "QOTD Backlog: ")
79 (display qotd-backlog)
80 (newline)
81 (display "QOTD Server: ")
82 (display qotd-host)
83 (newline)
84 (display "QOTD File: ")
85 (display qotd-file)
86 (newline)))
87
88 (let loop ((listener (tcp-listen qotd-port qotd-backlog qotd-host)))
89 (handle (lambda () (let ((qotd (ensure-final-newline (file-read* qotd-file))))
90 (if qotd qotd "Oop\n")))
91 listener)
92 (loop listener)))
93
94(main (command-line-arguments))