(define-module (tekuti projects)
  #:use-module ((tekuti config) #:select (*projects-dir*))
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (tekuti git)
  #:use-module (tekuti page-helpers)
  #:export (page-projects))

(use-modules (ice-9 ftw)
             (ice-9 match))

(define remove-stat
  (match-lambda
   ((name stat)
    name)
   ((name stat children ...)
    (list name (map remove-stat children)))))

(define (list-projects)
  (remove-stat
   (file-system-tree
    *projects-dir*
    (lambda (name stat)
      (not (file-exists? (string-append name "/config")))))))

(define (project-description project)
  (let ((dfile-name
         (string-append project "/description")))
    (if (file-exists? dfile-name)
        (with-input-from-file dfile-name
          (lambda ()
            (read-line)))
        "Unknown")))

(define (gitless name)
  (let ((pos (string-contains name ".git")))
    (if pos
        (substring name 0 pos)
        name)))

(define (project->row dir project prefix)
  (let ((project-dir (string-append dir "/" project))
        (project-name (gitless project)))
    `(tr
      (td (@ (class "span3"))
          (a (@ (href "http://code.ryuslash.org/cgit.cgi/"
                      ,prefix "/" ,project-name))
             ,project-name))
      (td (@ (class "span6")) ,(project-description project-dir))
      (td (@ (class "span2")) ,(git-last-update project-dir))
      (td (@ (class "span1")) ""))))

(define (project-list->table top-dir list lvl prefix)
  (let ((head (car list))
        (body (cadr list)))
    `((,(string->symbol (string-append "h" (number->string lvl))) ,head)
      (table
       (@ (class "table table-condensed table-striped"))
       (thead
        (tr
         (th "Name")
         (th "Description")
         (th "Last update")
         (th "")))
       (tbody
        ,@(map (lambda (elt)
                 (project->row top-dir elt prefix))
               (filter (lambda (elt)
                         (and (string? elt)
                              (access? (string-append top-dir "/" elt) R_OK)))
                       body))))
      ,@(map (lambda (elt) (project-list->table
                            (string-append top-dir (car elt)) elt (1+ lvl)
                            (string-append prefix (car elt))))
             (filter
              (lambda (elt)
                (and (list? elt)
                     (access? (string-append top-dir (car elt)) X_OK)))
              body)))))

(define (page-projects request body index)
  (respond (project-list->table *projects-dir* (list-projects) 1 "")
           #:extra-headers '((pragma . (no-cache (broccoli . "tastyy"))))))