;; -*- scheme -*-
#lang scheme/base
;; website entry point

(provide ramblings-dispatch)

;; reusable code is stored here
(require ;; "web-util.ss"
 "tools.ss"
 "sweb.ss"
 "facade.ss"             ;; web server helpers bundled
 "index-ramblings.ss"    ;; read and index ramblings.txt into graph
 "entry.ss"              ;; format page node -> xhtml
 "entry-format.ss"
 "parse-ramblings-fast.ss"
 (lib "match.ss")
 web-server/managers/none
 web-server/dispatch
 (planet zwizwa/lib/x/graph)

 )

;; DATA

;; Produces a dynamic object that will give a new graph whenever the
;; file changes on disk.

(define (ramblings->toc/dynamic name file)
  (cached-file-object
   (lambda (filename)
     (let* ((nl (ramblings-file->nodelist name filename))
            (toc  (nodelist->toc nl)))
       ;; (n! n 'nodelist nl) ;; save the nodelist
       toc))
   file))

;; Build graph containing all databases.  Meta info from the .db
;; file is not included in the graph struct, as it would force
;; evaluation of the node's index.
(define *db* #f)
(define *db-meta* #f)
(define *sections* '())


(define (register-ramblings-file! name file desc)
  (printf "registering ~a: ~a\n" name file)
  (n! *db* name (ramblings->toc/dynamic name file))
  (push! *sections* name)
  (cons name desc))

(define (register-db! file)
  (sweb-db register-ramblings-file! 'ramblings file))


;; All files in /txt folder for local stuff
(define (register-txt! dir)
  (define (file->name file)
    (string->symbol
     (car (regexp-split #rx"\\.txt"
                        (path->string file)))))
  (define (path->blurb path)
    (with-handlers ((exn:fail:filesystem? false))
      (with-input-from-file path
        (lambda () (read-line)))))
  (let*
      ((files  (directory-list dir))
       (names  (map file->name files))
       (paths  (for/list ((f files)) (build-path dir f)))
       (blurbs (map path->blurb paths)))
    (for/list ((n names)
               (p paths)
               (b blurbs)
               #:when b)
      (register-ramblings-file! n p b))))


  



;; Aggregate

(define (aggregate-nodelist db)
  (define (db-sections) (node-map db (lambda (k v) k)))
  (define (key x) (symbol->string (n@ x 'Index)))
  
  (let ((unsorted
         (apply append
                (for/list ((s (db-sections)))
                  (toc->list (n@ db s))))))
    (sort unsorted string<? #:key key)))

;; (define (aggregate-graph! db)
;;   (n! db 'all
;;       (cached-object (lambda ()
;;                        (let* ((nl (aggregate-nodelist db))
;;                               (n (nodelist->graph nl)))
;;                          (n! n 'nodelist '()) ;; dummy
;;                          n))
;;                      (lambda () aggregate-graph!))))


;; FIXME: file changes won't propagate up to aggregation.

;(define (aggregate-graph! db)
;  (let ((nodes (aggregate-graph db)))
;    (n! db 'all
;        (nodelist->graph nodes))))

;; Add the local db. This contains (name file) lists.
(define (reload-db)
  (set! *db* (make-node))
  (set! *db-meta*
        (append
         ;; (register-db!  (sweb-file "db/ramblings.db"))
         (register-txt! (sweb-file "txt"))))
  ;; (aggregate-graph! *db*)
  (collect-garbage)
  )

(reload-db)



;; DISPATCH

(define (padding len str)
  (build-list (- len (string-length str)) (lambda _ " ")))

;;       (width  (apply max (map string-length names))))

(define (ramblings-topics . _)
  (let* ((db (sort 
              (for/list ((d *db-meta*))
                (cons (symbol->string (car d)) (cdr d)))
              string-ci<=?
              #:key car))
         (topics (map car db))
         (descs  (map cdr db))
         (width  (apply max (map string-length topics))))
    `(html
      (pre
       ;; "ramblings "
       ,@(append*
          (for/list ((topic topics)
                     (desc  descs))
            `(,@(padding width topic)
              "["
              (a ((href ,(format "~a\n" topic))) 
                 ,(format "~a" topic))
              "] "
              ,desc
              "\n")))))))



(require scheme/pretty)
(require web-server/http/request-structs)
(require net/url-structs)

(define (section->toc sid)
  (n@ *db* sid error-404))

(define (id->node sid aid [error error-404])
  (let* ((toc (section->toc sid)))
    (with-handlers ((void (lambda _ (error))))
      (toc-ref toc aid))))

(define (try-id->node sids aid)
  (or
   (for/or ((s sids)) (id->node s aid (lambda _ #f)))
   (error-404)))

;; Possibly search.
(define (search/id->node sid aid)
  (if (eq? sid 'all)
      (try-id->node *sections* aid)
      (id->node sid aid)))

(define (with-error-404 fn)
  (with-handlers ((void error-404)) (fn)))


(define (ramblings-file req sid [str-aid "contents"])
  (with-error-response
   ;; with-error-response  ;; DEBUG
   (lambda ()
     (let-values (((aid fmt) (aid/fmt str-aid)))
       (let ((n (search/id->node sid aid))
             (q (url-query (request-uri req))))
         (printf "query: ~s\n" q)
         (cond
          ;; Delegated queries.
          ((not (null? q))
           ((n@ n 'query) q))
          
          ;; Standard data access.  Default is to render 'xhtml with
          ;; metadata and navigation.
          (fmt (case fmt
                 ((pdf)  (n@ n 'pdf))
                 ((html) (n@ n 'xhtml))
                 (else   (n@ n 'raw))))
          (else
           ;; Ordinary rendering.  Pass node tag and TOC offset as
           ;; functions so the render code does not need to depend on
           ;; zwizwa/lib/x/graph.
           (let ((node@ (lambda (key) (n@ n key (lambda () #f))))
                 (body (list (n@ n 'xhtml))))
             (render-decoration node@
                                (make-node->offset n)
                                body)))))))))

       

(define (ramblings-subdir req db)
  (redirect-to (format "~a/" db)))

(define-values
  (ramblings-dispatch ramblings-url)
  (dispatch-rules
   [("ramblings.ss" "topics")                  ramblings-topics]
   [("ramblings.ss" (symbol-arg) "")           ramblings-file]
   [("ramblings.ss" (symbol-arg) (string-arg)) ramblings-file]
   [("ramblings.ss" (symbol-arg))              ramblings-subdir]
   [else (lambda (x)
           (printf "~a\n" (req->strings x))
           (not-found))]))