#!/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 -backlog: 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 ((not str) "\n")
        ((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))
    (unless (null? args)
      (cond ((or (string=? "-help" (car args))
                 (string=? "-h" (car args)))
             (usage)
             (exit 0))
            ((string=? "-port" (car args))
             (set! qotd-port (string->number (cadr args))))
            ((string=? "-host" (car args))
             (set! qotd-host (cadr args)))
            ((string=? "-backlog" (car args))
             (set! qotd-backlog (string->number (cadr args))))
            ((string=? "-file" (car args))
             (set! qotd-file (cadr args))))
      (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))