;;; phricken 3e8 driver

;; Copyright(c) 2009 Jim Ursetto.  All rights reserved.
;; License: BSD.

(require-library phricken)
(import (prefix (only phricken host root port handlers sgm-rules
                      logger-port logger) phricken:)
        (except phricken host root port handlers sgm-rules
                logger-port logger))
(use matchable srfi-1)

;;; utilities

(define (logger . args)
  (apply (phricken:logger) args))

;;; handlers

(define (handle-root req)
  (send-entries
   `((i "Welcome to the 3e8.org gopher server!")
     (i "This thing was archaic ten years ago, but now it's retro-cool.")
     (i "--------------------------------------------------------------")
     (i)
     (1 "Quelle heure est-il?" "/time")
     (1 "Phlog" "/blog/2009/01/08")
     (1 "Chatski" "/chatski")
     (1 "Wiki" "/wiki/Jim/sister/cat/cradle")
     (1 "Public directory" "/pub")
     (0 "SRE documentation" "/sre.txt")
     (I "So long, farewell..." "/auf-wiedersehen.jpg")
     (h "3e8.org hypertext service" "http://3e8.org")
     (0 "Password file" "../../../../../../../etc/passwd")
     (i)
     (i "Powered by the phricken gopher server on Chicken " ,(chicken-version))
     ))
  (send-lastline))

(define handle-chat
  (let* ((mutex (make-mutex))
         (chat-interval 1000)   ; ms
         (last-chat (- chat-interval)))
    (lambda (req)

      ;; Handle 'say' function.
      ;; Firefox sends search request twice.  All we can really do
      ;; is to ignore two requests in quick succession from the same IP
      ;; with the same search term -- or easier, just limit all messages to
      ;; 1 per second.  The latter is what we do here.
      (let ((this-chat (current-milliseconds))
            (extra (request-extra req)))
        (when (pair? extra)
          (mutex-lock! mutex #f #f)
          (cond ((< (- this-chat last-chat) chat-interval)
                 (mutex-unlock! mutex))
                (else
                 (set! last-chat this-chat)
                 (mutex-unlock! mutex)
                 (let ((utterance (car extra))
                       (time (utc-seconds->string (current-seconds)))
                       (out (chat-output-port)))
                   (set! (file-position out 0) seek/end)
                   (fprintf out "~S\n" `(,(current-seconds) ,utterance))
                   (flush-output out))))))

      (send-entries
       `((i "Chat log")
         (i "--------")
         (i)
         ,@(map (lambda (entry)
                 `(i ,(utc-seconds->string (car entry))
                     " | "
                     ,(cadr entry)))
                (read-file (chatfile)))
         (i)
         (7 "Dis-moi" ,(request-selector req))
         (1 "Refresh" ,(request-selector req))
         (1 "Go home" ""))))))

(define (handle-time req)
  (let ((sel (request-selector req)))
    (send-entries
     `((i "At the tone, the time will be:")
       (i ,(seconds->string (current-seconds)) " "
          ,(local-timezone-abbreviation))
       (i)
       (1 "What time is it now?" ,sel)
       (1 "Go home" "")))))

(define (blog y m d)
  (define posts '("Woke up"
                  "Got out of bed"
                  "Dragged a comb across my head"))
  (define (w2 x) (if (< x 10) (sprintf "0~a" x) (sprintf "~a" x)))
  (send-entries
   `((i "Blog entry for " ,y "-" ,(w2 m) "-" ,(w2 d))
     (i "-------------------------")
     (i)
     (i ,(list-ref posts (random (length posts))))
     (i)
     (1 "Next entry"
        ,(conc "/blog/"
               (w2 (+ (random 20) 2000)) "/"
               (w2 (+ (random 12) 1)) "/"
               (w2 (+ (random 28) 1))))
     (1 "Go home" ""))))

(define (handle-blog req)
  (match-let (((y m d) (request-matches req)))
    (apply blog (map string->number (list y m d)))))

(define handle-wiki
  (lambda (req)
    (match-let (((root article) (request-matches req)))
      (let ((objects (string-split article "/")))
        (send-entries
         `((i "3e8-opedia: " ,article)
           (i)
           (i "+----------------------------------------------------------+")
           (i "| Note: this entry is currently experiencing an edit war   |")
           (i "| and may be undergoing swift, uncontrollable convulsions. |")
           (i "+----------------------------------------------------------+")
           (i)
           ,@(if (null? objects)
                 '((i "Huh?  There's nothing to possess."))
                 `((i ,(string-intersperse objects "'s ") " is "
                      ,(list-ref '("not " "") (random 2)) "cool.")
                   (i)
                   (1 "Up" ,(string-append
                             root
                             (string-substitute "/[^/]+$" "" article)))))
           (1 "Go home" "")))))))


;;; config

(define config-data
  (if (pair? (command-line-arguments))
      (read-file (car (command-line-arguments)))
      '()))
(define (config item)
  (cond ((alist-ref item config-data) => car)
        (else #f)))
(define (config? item)      ; test if config item is provided
  (alist-ref item config-data))

(define host (or (config 'host) "amaranth"))
(define port (or (config 'port) 7070))
(define root (or (config 'root) "/Users/jim/scheme/gopher/root"))
(define logfile (or (config 'logfile)
                    (string-append root "/phricken.log")))
(define chatfile
  (make-parameter (or (config 'chatfile)
                      (string-append root "/chatski.log"))))
(define logger-port (open-output-file logfile #:append))
(define chat-output-port
  (make-parameter (open-output-file (chatfile) #:append)))

(define handlers
  `(,(match-selector "" handle-root)
    ,(match-selector "/chatski" handle-chat)
    ,(match-selector "/time" handle-time)
    ,(match-resource "/wiki" handle-wiki)
    ,(match-selector '(: "/blog/"
                        (submatch (= 4 numeric)) "/"
                        (submatch (= 2 numeric)) "/"
                        (submatch (= 2 numeric)))
                     handle-blog)
    ,(match-url handle-url)
    ,@(map (lambda (x) (apply bind-fs x))
           (or (config 'bind-fs) '()))

    ))

;;; debugging

;; Dangerous, for REPL debugging only.  Parameters are wiped when
;; you source the phricken module, and do not propagate when you
;; update them.
(define (reinit)
  (set! phricken:host (make-parameter host))
  (set! phricken:port (make-parameter port))
  (set! phricken:root (make-parameter root))
  (set! phricken:logger-port (make-parameter logger-port))
  (set! phricken:handlers (make-parameter handlers)))

;;; main

(parameterize ((phricken:host host)
               (phricken:port port)
               (phricken:logger-port logger-port)
               (phricken:handlers handlers))
  (start-server! (if (config? 'background)
                     (config 'background)
                     #t)))