chaton-poster

#!/usr/bin/env gosh

(add-load-path "@@server-data-dir@@")

(define-module chaton.poster
  (use www.cgi)
  (use srfi-13)
  (use file.util)
  (use util.list)
  (use text.html-lite)
  (use text.tree)
  (use gauche.logger)
  (use chaton)
  (export poster-main))
(select-module chaton.poster)

(define *limit* 2048)
(define +sequence-old+ (build-path +docdir+ "var/seq"))
(define +logfile+ (build-path +logdir+ "post.log"))

(define (poster-main args)
  (log-open +logfile+)
  (cgi-main (^[params]
              (let ([nick (cgi-get-parameter "nick" params :default #f)]
                    [text (cgi-get-parameter "text" params :default #f)]
                    [addr (cgi-get-metavariable "REMOTE_ADDR")])
                (make-directory* +datadir+) ;ensure
                (if (ip-blacklisted? addr)
                  (log-format "Post rejected from IP ~a: ~a: ~a"
                              addr nick text)
                  (chaton-with-exclusive-locking
                   (^[]
                     (call-with-output-file +current-file+
                       (cut update <>
                            (string-trim-both nick) (string-trim-both text))
                       :if-exists :append)
                     (update-rss))))
                (emit-reply)))
            :on-error
            (and +show-stack-trace+
                 (^e
                  `(,(cgi-header)
                    ,(html:pre
                      (html-escape-string
                       (call-with-output-string
                         (cut with-error-to-port <> (cut report-error e)))))))))
  0)

(define (emit-reply)                    ;dummy
  (write-tree `(,(cgi-header) ,(html:html (html:head) (html:body)))))

(define (update out nick text)
  (unless (or (string-null? nick) (string-null? text))
    (append-entry out nick text)
    (increment-sequence)
    (record-last-post-timestamp)))

(define (append-entry out nick text)
  (port-seek out 0 SEEK_END)
  (write (make-entry nick text) out)
  (newline out))

(define (make-entry nick text)
  ;; Exclude control characters invalid for XML1.0
  ;; http://www.w3.org/TR/2008/REC-xml-20081126/#charsets
  (define (filter-string s)
    ($ string-delete #[\u0000-\u0008\u000b\u000c\u000e-\u001f]
       $ string-incomplete->complete s #\?))
  (let ([text (filter-string text)]
        [nick (filter-string nick)])
    (receive (sec usec) (sys-gettimeofday)
      `(,nick (,sec ,usec)
              ,(if (> (string-length text) *limit*)
                 (string-take text *limit*)
                 text)
              ,(cgi-get-metavariable "REMOTE_ADDR")))))

(define (increment-sequence)
  ;; NB: for the backward compatibility, we store the sequence number under
  ;; $DOCDIR (old location) as well as $(DATADIR).  Don't forget to drop
  ;; the old stuff after some time.
  (let1 cnt (x->integer (or (file->string +sequence-file+ :if-does-not-exist #f)
                            (file->string +sequence-old+ :if-does-not-exist #f)))
    (make-directory* (sys-dirname +sequence-file+))
    (with-output-to-file +sequence-file+ (cut write (+ cnt 1)) :atomic #t)
    (make-directory* (sys-dirname +sequence-old+))
    (with-output-to-file +sequence-old+ (cut write (+ cnt 1)) :atomic #t)))

(define (record-last-post-timestamp)
  ;; NB: Theoretically the value written may differ from the entry's timestamp,
  ;; but we don't need precision here.
  (with-output-to-file +last-post-file+ (cut write (sys-time)) :atomic #t))

(define (update-rss)
  (with-output-to-file +index.rdf+
    (^[]
      (write-tree
       `("<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\n"
         "<rss version=\"2.0\" xmlns:content=\"http://purl.org/rss/1.0/modules/content/\">\n"
         "<channel>\n"
         "<title>" ,(html-escape-string "@@room-name@@") "</title>\n"
         "<link>" ,(html-escape-string "@@httpd-url@@@@url-path@@") "</link>\n"
         "<description>" ,(html-escape-string "@@room-description@@") "</description>\n"
         ,(chaton-render-from-file +current-file+ 0 #f
                                   :renderer chaton-render-rss-1
                                   :newest-first #t)
         "</channel>\n"
         "</rss>\n")))
    :atomic #t))

;; IP blocking - if datadir contains blacklist.txt, read it.
;; The file lists one IP or IP range per line; IP range being xx.xx.xx.xx/bb
;; # to the end of line is a comment.
(define (ip-blacklisted? remote-addr)
  (and-let* ([ (string? remote-addr) ]
             [v (parse-ipaddr remote-addr)]
             [addr (car v)]
             [blacklist (load-ip-blacklist)])
    (any (^p (<= (car p) addr (cdr p))) blacklist)))

;; Returns list of integer IP ranges (<start> . <end>), both inclusive
(define (load-ip-blacklist)
  (if-let1 lines (file->string-list (build-path +datadir+ "blacklist.txt")
                                    :if-does-not-exist #f)
    (filter-map parse-ipaddr lines)
    '()))

(define (parse-ipaddr addr-str)
  (rxmatch-case addr-str
    [#/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})(?:\/(\d{1,2}))?/
     (_ b3 b2 b1 b0 mask)
     (let ([bs (map string->number (list b3 b2 b1 b0))]
           [mm (if mask (string->number mask) 32)])
       (if (or (any (cut <= 256 <>) bs)
               (< 32 mm))
         (begin (log-format "bad ip addr in blacklist: ~s. ignoring." addr-str)
                #f)
         (let* ([v (fold (^[b s] (+ (* s 256) b)) 0 bs)]
                [m (logand (lognot (- (ash 1 (- 32 mm)) 1)) #xffffffff)])
           (cons (logand v m)
                 (logior v (logand (lognot m) #xffffffff))))))]
    [#/^#/ () #f]
    [#/^\s*$/ () #f]
    [else (log-format "bad ip addr in blacklist: ~s. ignoring." addr-str) #f]))

;;;===================================================================
(select-module user)

(import chaton.poster)
(define main poster-main)

;; Local variables:
;; mode: scheme
;; end: