grumi 1.0

[Thien-Thi Nguyen]

folks,

if your guile supports module catalogs, you can use this program (plus
favorite web browser) to explore the modules named therein.  "da fare"
points are some nice hacking opportunities (that i'll take up at some
point if no one else beats me to it).

thi


______________________________________________________________
#!/bin/sh
exec ${GUILE-guile} -e '(grumi)' -s $0 "$@" # -*- scheme -*-
!#
;;; grumi --- va bene anché se non liscio come olio

;;      Copyright (C) 2004 Thien-Thi Nguyen
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA

;;; Commentary:

;; Uso: grumi [opzioni]
;;
;; Elenca tutti i moduli disponibili.
;;
;;  -G, --guile PROG    -- chiede PROG per %load-path [guile]
;;  -p, --port NUMERO   -- parla protocolo HTTP al tcp port NUMERO

;;; Code:

(define-module (grumi)
  #:use-module (scripts PROGRAM)
  #:use-module (scripts split-string-no-nulls)
  #:use-module (scripts slurp)
  #:use-module (scripts frisk)
  #:use-module (ice-9 common-list)
  #:use-module (ice-9 documentation)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (www server-utils big-dishing-loop))

(define *versione* "1.0")

(define *mc* #f)
(define *tutti* #f)

(define put set-object-property!)
(define get object-property)

(define (bei-componenti comp)
  (map (lambda (x) (list "/" x)) comp))

(define upath->componenti (split-string-no-nulls-proc "/"))

(define (mbello->corpo M mbello)
  (let* ((riga (get mbello #:riga))
         (impl (cdr (last-pair riga)))
         (inst (and (file-exists? impl)
                    (strftime "%Y-%m-%d %H:%M:%S"
                              (localtime (stat:mtime (stat impl))))))
         (comp (get mbello #:comp))
         (ecc (let ((copia (list-copy riga)))
                (set-cdr! (last-pair copia) '())
                (cdr copia)))
         (richiesti (or (get mbello #:richiesti)
                        (let ((r (if (null? ecc)
                                     (if inst
                                         (list-copy
                                          (((make-frisker) (list impl))
                                           'external))
                                         '())
                                     (case (car ecc)
                                       ((scm_init_module)
                                        (car (last-pair ecc)))
                                       (else '())))))
                          (put mbello #:richiesti r)
                          r))))
    (M #:add-content "<UL>\n<LI>"
       (if (null? ecc) "Testo" (car ecc))
       ": " impl)
    (cond ((and (null? ecc) inst)
           (M #:add-content "<BR>(")
           (M #:add-content
              "<A HREF=\"/?file"
              (bei-componenti comp)
              "\">crudo</A>")
           ;; da fare: analisi personalizzati qui
           (M #:add-content ")")))
    (and inst (M #:add-content "\n<LI>Inst: " inst))
    (cond ((not (null? richiesti))
           (M #:add-content "\n<LI>Richiesti:<UL>")
           (for-each (lambda (r)
                       (M #:add-content
                          "\n<LI>"
                          (let ((rbello (format #f "~S" r)))
                            (if (member rbello *tutti*)
                                (list "<A HREF=\""
                                      (bei-componenti r)
                                      "\">" rbello "</A>")
                                rbello))))
                     richiesti)
           (M #:add-content "\n</UL>")))
    (let* ((spazio (string-rindex mbello #\space))
           (pre (and spazio (substring mbello 0 spazio)))
           (simile (and pre (pick (lambda (m)
                                    (and (not (string=? mbello m))
                                         (> (string-length m) spazio)
                                         (string=? (substring m 0 spazio)
                                                   pre)))
                                  *tutti*))))
      (cond ((and simile (not (null? simile)))
             (M #:add-content "\n<LI>Simile:<BR>")
             (for-each (lambda (sbello)
                         (M #:add-content
                            " <A HREF=\""
                            (bei-componenti (get sbello #:comp))
                            "\">"
                            (substring sbello (1+ spazio)
                                       (1- (string-length sbello)))
                            "</A>"))
                       (reverse simile)))))
    ;; da fare: altre documentazione qui (magari "info -n")
    (M #:add-content "\n</UL>")
    (cond ((and inst (null? ecc) (file-commentary impl))
           => (lambda (c)
                (and c (not (string-null? c))
                     (M #:add-content "\n<HR><PRE>\n" c "\n</PRE>")))))))

(define (rispondere M upath)
  (M #:set-reply-status:success)
  (let* ((ancora? #t)
         (ulen (string-length upath))
         (sep (upath->componenti upath))
         (cmd (and (not (null? sep))
                   (char=? #\? (string-ref (car sep) 0))
                   (substring (car sep) 1)))
         (comp (if cmd (cdr sep) sep))
         (cbello (format #f "~A" comp))
         (mbello (and=> (member cbello *tutti*) car)))

    (define (prima titolo)
      (list "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">"
            "<HTML><HEAD><TITLE>" titolo "</TITLE></HEAD>"
            "<BODY>"))

    (define (dopo)
      (list "<HR><DIV ALIGN=\"RIGHT\">"
            "<A HREF=\"/\">(cima)</A>"
            "<A HREF=\"/?ciao\">(ciao)</A>"
            " grumi " *versione*
            "</DIV></BODY></HTML>"))

    (cond

     ((string=? "/?ciao" upath)
      (M #:add-header #:Content-Type "text/plain")
      (M #:add-content "\nciao ciao!\n  --grumi " *versione*)
      (set! ancora? #f))                ; finito

     ((and (< 6 ulen) (string=? "/?file" (substring upath 0 6)))
      (M #:add-header #:Content-Type "text/plain")
      (M #:add-content
         (if (not mbello)
             (list "(Mi spiace, non c'è codice per: " cbello ".)\n")
             (slurp (cdr (last-pair (get mbello #:riga)))))))

     ((or (string=? "/" upath)
          (string=? "" upath))
      (M #:add-header #:Content-Type "text/html")
      (M #:add-content (prima "cima"))
      (M #:add-formatted "~A moduli" (length *tutti*))
      (M #:add-content "<HR><UL>")
      (for-each (lambda (mbello)
                  (M #:add-content "\n<LI><A HREF=\"")
                  (for-each (lambda (x)
                              (M #:add-formatted "/~A" x))
                            (get mbello #:comp))
                  (M #:add-content "\">" mbello "</A>"))
                *tutti*)
      (M #:add-content "\n</UL>" (dopo)))

     (else
      (M #:add-header #:Content-Type "text/html")
      (M #:add-content
         (prima (list (if cmd (list cmd " ") "") cbello))
         "<H1>" (or cmd "") (or mbello cbello) "</H1>")
      (if (not mbello)
          (M #:add-content (list "(Mi spiace, non c'è modulo <B>"
                                 cbello
                                 "</B>.)"))
          (mbello->corpo M mbello))
      (M #:add-content (dopo))))

    (M #:rechunk-content #t)
    (M #:send-reply)
    ancora?))

(define (trovare-mc guile)
  (let ((p (open-input-pipe
            (format #f "~A -c '~S'"
                    guile
                    '(for-each (lambda (d)
                                 (let ((mc (in-vicinity d ".module-catalog")))
                                   (and (file-exists? mc)
                                        (write-line mc))))
                               %load-path)))))
    (let ciclo ((riga (read-line p)) (acc '()))
      (if (eof-object? riga)
          (begin
            (close-pipe p)
            (reverse acc))
          (ciclo (read-line p) (cons riga acc))))))

(define (grumi/qop qop)
  (let ((guile (or (qop 'guile) "guile")))
    (set! *mc* (trovare-mc guile))
    (set! *tutti* '())
    (for-each (lambda (cat)
                (let ((righe (read (open-input-file cat))))
                  (for-each (lambda (riga)
                              (let* ((modulo (car riga))
                                     (mbello (format #f "~S" modulo)))
                                (cond ((pair? modulo)
                                       (put mbello #:riga riga)
                                       (put mbello #:comp
                                            (map symbol->string modulo))
                                       (set! *tutti* (cons mbello *tutti*))))))
                            righe)))
              *mc*)
    (set! *tutti* (sort *tutti* string<?))
    (or (and=> (qop 'port string->number)
               (lambda (p)
                 (let ((cena (make-big-dishing-loop #:GET-upath rispondere)))
                   (format #t "ascoltando: ~S\n" p)
                   (cena p)
                   (write-line "ciao!"))))
        (for-each write-line *tutti*))))

(define (main args)
  (HVQC-MAIN args grumi/qop
             '(usage . commentary)
             `(version . ,*versione*)
             '(option-spec (guile (single-char #\G) (value #t))
                           (port  (single-char #\p) (value #t)))))

;;; grumi si fine qui