#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do grumi)' -s $0 "$@" # -*- scheme -*-
!#
(define-module (ttn-do grumi)
#:export (main)
#:use-module ((ttn-do zzz 0gx forms-from) #:select (forms<-file))
#:use-module ((ttn-do zzz 0gx read-string) #:select (read-string))
#:use-module ((ttn-do zzz banalities) #:select (check-hv
qop<-args))
#:use-module ((scripts frisk) #:select (make-frisker
edge-type
edge-up
mod-up-ls))
#:use-module ((ice-9 documentation) #:select (file-commentary))
#:use-module ((ice-9 popen) #:select (open-input-pipe
close-pipe))
#:use-module ((srfi srfi-1) #:select (partition! car+cdr))
#:use-module ((srfi srfi-11) #:select (let-values))
#:use-module ((srfi srfi-13) #:select (substring/shared
string-drop
string-drop-right
string-trim-both
string-suffix-length
string-prefix?))
#:use-module ((ttn-do mogrify) #:select (editing-buffer))
#:use-module ((www server-utils big-dishing-loop)
#:select (make-big-dishing-loop))
#:use-module ((www utcsec) #:select (rfc1123-date<-))
#:use-module ((ttn-do zzz xhtml-tree) #:select (~simple-strict-xhtml
~head ~title
~link ~body
~div ~p
~h1 ~hr
~pre ~a ~br
~strong ~code
~table ~tr ~td))
#:use-module ((ttn-do zzz personally) #:select (accumulator
whatever
FE fs fso fse))
#:use-module ((ttn-do zzz filesystem) #:select (expand-file-name
filename-components
filename-components-append))
#:use-module ((ice-9 and-let-star) #:select (and-let*))
#:use-module ((ttn-do zzz publishing) #:select (flatten css-tree))
#:use-module ((ttn-do zzz senz-altro) #:select (daemonize)))
(define *versione* "1.7")
(define (v1 filename meta ents data)
(define (check maybe)
(and=> (hash-get-handle data maybe) car))
(define (extract sel name)
(let* ((ent (hash-ref data name))
(type (if (string? ent)
'text
(car ent)))
(etc (if (eq? 'text type)
ent
(cdr ent))))
(case sel
((#:disk) (if (eq? 'text type)
etc
(cdr (last-pair etc))))
((#:type) type)
((#:commentary) (and (eq? 'text type)
(file-exists? etc)
(file-commentary etc)))
((#:export-list) #f)
((#:upstream-list)
(case type
((text) (false-if-exception
(let ((rip ((make-frisker) (list etc))))
(let ((mod (car (rip 'internal))))
(map (lambda (edge)
(cons (edge-type edge) (edge-up edge)))
(mod-up-ls mod))))))
((scm_init_module) (car (last-pair etc)))
(else #f))))))
(FE (map car ents) (map cdr ents)
(lambda (name rest)
(hash-set! data name rest)))
(values check identity extract))
(define --KNOWN-CATALOG-FORMATS (vector #f v1))
(define (snarf! filename)
(let* ((full (forms<-file filename))
(ht (make-hash-table 43))
(one (car full))
(meta #f))
(define (check condition)
(cond (condition)
(else
(throw 'bad-catalog filename))))
(define (return v ents)
(let-values (((check name<-key extract)
((vector-ref --KNOWN-CATALOG-FORMATS v)
filename meta ents ht)))
(values (acons 'file-format-version v meta)
check (lambda ()
(hash-fold (lambda (k ignored ls)
(cons (name<-key k) ls))
'() ht))
extract)))
(cond ((pair? one) (let-values (((ents z) (partition! (lambda (x)
(pair? (car x)))
one)))
(set! meta `((exclude . ,(or (assq-ref z '**exclude**) '()))))
(return 1 ents)))
(else
(check #f)))))
(define modcatmgr (make-object-property))
(define (open-module-catalog filename)
(let-values (((meta check all extract) (snarf! filename)))
(define (mgr sel . name)
(define (need-name!)
(and (null? name) (error "missing module name"))
(set! name (car name)))
(case sel
((#:filename) filename)
((#:meta) (copy-tree meta))
((#:list) (map (lambda (name)
(set! (modcatmgr name) mgr)
name)
(all)))
((#:check)
(need-name!)
(and=> (and (pair? name)
(check name))
(lambda (ok)
(set! (modcatmgr ok) mgr)
ok)))
((#:disk #:type #:commentary #:export-list #:upstream-list)
(need-name!)
(or (eq? mgr (modcatmgr name))
(error (fs "module ‘~A’ not in ~A" name filename)))
(extract sel name))
(else (fse "bad sel: ~S" sel)
(exit #f))))
mgr))
(define (module-type name)
((modcatmgr name) #:type name))
(define (module-manifestation name)
(let ((v ((modcatmgr name) #:disk name)))
(if (pair? v)
(car v)
v)))
(define (module-commentary name)
((modcatmgr name) #:commentary name))
(define (module-export-list name)
((modcatmgr name) #:export-list name))
(define (module-upstream-list name)
((modcatmgr name) #:upstream-list name))
(define (ingoiare . x)
(let* ((s? (null? (cdr x)))
(p (if s?
(open-input-file (car x))
(open-input-pipe (apply fs x))))
(finito (if s? close-port close-pipe)))
(editing-buffer p
(finito p)
(string-trim-both (buffer-string)))))
(define quanti (make-object-property))
(define posto (make-object-property))
(define conflitto (make-object-property))
(define-macro (forse precond . corpo)
`(or (and-let* ,precond (list ,@corpo))
'()))
(define-macro (se-vero par+nome vai . arrangiati-senza)
`(cond ((hash-get-handle tutti ,(cadr par+nome))
=> (lambda (h)
(let-values (((nome nome/bello) (car+cdr h)))
((lambda ,(car par+nome)
,vai)
nome nome/bello))))
(else
(whatever)
,@arrangiati-senza)))
(define (gustare-la-verità guile)
(let ((tutti (make-hash-table 241)))
(set! (modcatmgr tutti)
(read-string
(ingoiare "~A -c '~S ~S'"
guile
'(use-modules (srfi srfi-1) (ice-9 and-let-star))
'(write
(list->vector
(filter-map
(lambda (d)
(and-let* ((f (in-vicinity d ".module-catalog"))
((file-exists? f)))
f))
%load-path))))))
(set! (quanti tutti) 0)
(array-index-map!
(modcatmgr tutti)
(lambda (i)
(let ((mc (open-module-catalog (vector-ref (modcatmgr tutti) i)))
(n 0))
(set! (posto mc) i)
(FE (mc #:list)
(lambda (nome)
(set! n (1+ n))
(se-vero ((prima x) nome)
(let ((dom (modcatmgr prima))
(cur (or (conflitto mc) '())))
(or (memq dom cur)
(set! (conflitto mc) (cons dom cur)))
(set! (conflitto prima)
(cons mc (or (conflitto prima) '()))))
(set! (quanti tutti) (1+ (quanti tutti)))
(hash-set! tutti nome (A nome)))))
(set! (quanti mc) n)
mc)))
tutti))
(define (pulire s)
(let ((ls (list s)))
(define (sostituire prima dopo)
(let ((acc (accumulator)))
(let loop ((ini 0))
(cond ((null? ls)
(set! ls (acc)))
((string-index (car ls) prima ini)
=> (lambda (p)
(acc (substring/shared (car ls) ini p) dopo)
(loop (1+ p))))
(else
(acc (string-drop (car ls) ini))
(set! ls (cdr ls))
(loop 0))))))
(sostituire #\& "&")
(sostituire #\< "<")
(sostituire #\> ">")
ls))
(define (spazioso ls proc)
(~br (map (lambda (x)
(list " " (proc x) " "))
ls)))
(define (A x) (fs "~A" x))
(define (S x) (fs "~S" x))
(define (legame s nome . pre)
(~a 'href (list pre (filename-components-append (map A nome)))
(~code s)))
(define (legame/mc s mc)
(~a 'href (fs "/?cat~A" (if (integer? mc)
mc
(posto mc)))
(if (integer? s)
(A s)
s)))
(define (ordinato ht . sel)
(set! sel (if (null? sel)
identity
(car sel)))
(map car (sort-list! (hash-fold (lambda (k v ls)
(or (and-let* ((ok (sel k)))
(acons ok v ls))
ls))
'() ht)
(lambda (a b)
(string<? (cdr a)
(cdr b))))))
(define (corpo<-nome tutti nome)
(~hr
(let* ((mc (modcatmgr nome))
(dir (expand-file-name (dirname (mc #:filename))))
(type (module-type nome))
(manif (module-manifestation nome))
(sotto? (string-prefix? dir manif))
(inst (and (file-exists? manif) (stat:mtime (stat manif)))))
(~div
'class "C"
(~p "(" (A type) ") "
(if inst
(list (~strong "inst") " " (strftime "%F %T" (localtime inst)))
(list (~strong "sparito!") " (non trovato su disk)"))
(~br (~code
(legame/mc (if sotto?
dir
(A (list (posto mc))))
mc)
(let ((resto (if sotto?
(string-drop manif (string-length dir))
manif)))
(define (ultinfo tipo)
(list (~strong "/") (legame (string-drop resto 1)
nome "/?" tipo)))
(if inst
(case type
((text) (ultinfo "file"))
((scm_init_module) (ultinfo "readelf"))
(else resto))
resto)))))))
(forse ((dispo (module-export-list nome))
((not (or (null? dispo) (and (null? (car dispo))
(null? (cdr dispo)))))))
(~div
'class "C"
(let-values (((sint norm) (car+cdr dispo)))
(set! sint (map A sint)) (let ((insieme (sort (append sint (map A norm)) string<?)))
(~p (~strong "disponibil"
(if (= 1 (+ (length sint) (length norm)))
"e" "i"))
(~code (spazioso insieme
(lambda (x)
(if (member x sint)
(A (list x))
x)))))))))
(forse ((richiesti (or (module-upstream-list nome) '()))
((not (null? richiesti))))
(~table
'class "tight"
(~tr (~td 'class "C"
'colspan "2"
(~strong "richiest" (if (null? (cdr richiesti)) "o" "i"))))
(map (lambda (r)
(let-values (((tipo modulo) (car+cdr r)))
(~tr (~td (se-vero ((vero Avero) modulo)
(legame Avero vero)
(~strong (~code (S modulo)))))
(~td 'class "R" (~code (A tipo))))))
richiesti))
(~p))
(forse ((commenti (and=> (module-commentary nome) string-trim-both))
((and commenti (not (string-null? commenti)))))
(~table 'class "tight"
(~tr (~td (~hr)))
(~tr (~td (~pre (pulire commenti))))
(~tr (~td (~hr)))))
(forse (((not (null? (cdr nome))))
(emon (reverse nome))
(genitori (cdr emon))
(amici (ordinato tutti (lambda (k)
(let ((rev (reverse k)))
(and (not (equal? emon rev))
(equal? genitori (cdr rev))
rev)))))
((not (null? amici))))
(~div
'class "C"
(~p
(~strong "amic" (if (null? (cdr amici)) "o" "i"))
(spazioso amici (lambda (amico)
(legame (A (car amico)) (reverse amico))))))
)))
(define ((rispondere tutti) M upath)
(M #:set-reply-status:success)
(let* ((ancora? #t)
(mc/t (modcatmgr tutti))
(mc/t-count (vector-length mc/t))
(eterna? (eq? 'eterna (posto tutti)))
(sep (filename-components upath))
(cmd (and (not (null? sep))
(char=? #\? (string-ref (car sep) 0))
(string-drop (car sep) 1)))
(comp (if cmd (cdr sep) sep))
(cbello (A comp))
(nome (se-vero ((vero x) (map string->symbol comp))
vero
#f))
(mc (modcatmgr nome)))
(define (mc/t: x)
(and (< -1 x mc/t-count)
(vector-ref mc/t x)))
(define (~pagina/titolata titolo . x)
(~simple-strict-xhtml
(~head (~title titolo)
(~link 'rel "stylesheet"
'href "/?stile"
'type "text/css"))
(~body x
(~hr)
(~div 'class "R"
(~a 'href "/" "(cima)")
" "
(if eterna?
(~a 'href "/?baci" "(baci)")
(~a 'href "/?ciao" "(ciao)"))
" grumi " *versione*))))
(define (quanti-modul* q)
(fs "~A modul~A" q (if (= 1 q) "o" "i")))
(define (ficanaso . x)
(or eterna? (flatten x))
(or (zero? (port-column (current-output-port)))
(newline))
(if (and (= 1 (length x))
(string? (car x)))
(car x)
x))
(or eterna? (fso "upath: ~A~%" upath))
(M #:add-header #:Server (string-append "grumi/" *versione*))
(M #:add-header #:Connection "close")
(cond
((string=? "/?stile" upath)
(M #:add-header #:Content-Type "text/css")
(M #:add-header #:Expires (rfc1123-date<- #f (+ 600 (current-time))))
(M #:add-content
(map css-tree
(let ((filename (expand-file-name "~/.ttn-do/grumi-stile")))
(or (and (file-exists? filename)
(car (forms<-file filename)))
'(("h1" text-align "center")
("a" text-decoration "none")
("body"
max-width "25cm"
margin "auto"
border "10mm solid transparent"
border-top "none")
(".tight"
text-align "left"
border-spacing "15px 0px"
margin "auto")
(".C" text-align "center")
(".R" text-align "right")))))))
((and eterna? (string=? "/?baci" upath))
(M #:add-header #:Content-Type "text/plain")
(M #:add-formatted "~%baci baci!~% --grumi ~A" *versione*))
((and (not eterna?) (string=? "/?ciao" upath))
(M #:add-header #:Content-Type "text/plain")
(M #:add-formatted "~%ciao ciao!~% --grumi ~A" *versione*)
(set! ancora? #f))
((string-prefix? "/?file" upath)
(M #:add-header #:Content-Type "text/plain")
(M #:add-content
(if nome
(ingoiare (ficanaso (module-manifestation nome)))
(ficanaso "(Mi dispiace, non c'è codice per: " cbello ".)"))))
((string-prefix? "/?readelf" upath)
(M #:add-header #:Content-Type "text/plain")
(let ((manif (module-manifestation nome)))
(M #:add-content
(if manif
(ingoiare "readelf -a '~A' 2>&1" manif)
(ficanaso "(Mi dispiace, non c'è ELF per: " cbello ".)")))))
((string-prefix? "/?cat" upath)
(set! upath (string-drop upath 5))
(or (and-let* ((mc (and=> (string->number upath) mc/t:)))
(M #:add-header #:Content-Type "text/html")
(M #:add-content
(let ((filename (mc #:filename))
(sotto (map posto (or (conflitto mc) '()))))
(~pagina/titolata
filename
(~div
'class "C"
(~p (~strong filename)
(~br (~code (string-drop-right
(ingoiare "ls -l '~A'" filename)
(string-length filename))))
(forse (((not (null? sotto))))
(~br "oscurato da"
(map (lambda (p)
(list " " (legame/mc (A p) p)))
sotto))))
(map (lambda (pair)
(~p (~strong (A (car pair)))
(~br (~code (S (cdr pair))))))
(mc #:meta)))
(~table
'class "tight"
(~tr (~td 'class "C"
'colspan (A (if (null? sotto) 1 2))
(~hr)
(quanti-modul* (quanti mc))))
(map (lambda (nome)
(se-vero ((già Agià) nome)
(if (memq mc (or (conflitto già) '()))
(~tr (~td (~code Agià))
(~td (legame/mc "oscurato"
(modcatmgr già))))
(~tr (~td (legame Agià già))))
(~tr (~td (~code nome)))))
(sort-list!
(mc #:list)
(lambda (a b)
(string<? (A a)
(A b))))))))))
(begin
(M #:add-header #:Content-Type "text/html")
(M #:add-content
(~pagina/titolata
"Non c'è!"
(ficanaso "(Mi dispiace, non c'è catalogo «"
(~strong (~code upath))
"».)"))))))
((or (string-null? upath)
(string=? "/" upath))
(let ((indici (iota mc/t-count)))
(M #:add-header #:Content-Type "text/html")
(M #:add-content
(~pagina/titolata
"cima"
(~div
'class "C"
(~p (quanti-modul* (quanti tutti))
(fs " (~A catalog~A)"
mc/t-count (if (= 1 mc/t-count) "o" "hi"))))
(~hr)
(~table
'class "tight"
(map (lambda (i)
(let ((mc (mc/t: i)))
(~tr (~td (legame/mc
(~code (let ((filename (mc #:filename)))
(string-drop-right
filename
(string-suffix-length
filename ".module-catalog"))))
i))
(~td " ")
(map (lambda (c)
(~td (forse (((= c i)))
(~strong (A c)))))
indici)
(forse ((ls (conflitto mc)))
(~td " ")
(~td "≻" (map (lambda (x)
(fs " ~A"
(posto x)))
ls))))))
indici)
(~tr (~td (~hr))
(~td)
(map (lambda ignored
(~td (~hr)))
indici)
(forse (((or-map conflitto (vector->list
(modcatmgr tutti)))))
(~td)
(~td (~hr))))
(map (lambda (nome)
(~tr (~td (legame (A nome) nome))
(~td)
(let ((cat (posto (modcatmgr nome))))
(map (lambda (c)
(~td (forse (((= c cat)))
(legame/mc c c))))
indici))
(forse ((more (conflitto nome)))
(~td)
(~td "≺" (map (lambda (sotto)
(list
" "
(let ((i (posto sotto)))
(legame/mc i i))))
more)))))
(ordinato tutti)))))))
((string=? "/favicon.ico" upath)
(M #:set-reply-status 404 ""))
(else
(M #:add-header #:Content-Type "text/html")
(M #:add-content
(~pagina/titolata
(list (forse ((cmd))
cmd " ")
cbello)
(~h1 (forse ((cmd)) cmd)
(~code (se-vero ((x mbello) nome)
mbello
cbello)))
(if nome
(corpo<-nome tutti nome)
(ficanaso "(Mi dispiace, non c'è modulo "
(~strong (~code cbello))
".)"))))))
(M #:rechunk-content #t)
(M #:send-reply)
ancora?))
(define (andato-male s arg)
(fse (string-append "grumi: " s "~%") arg)
(exit #f))
(define (come-daemon tutti nome cena p)
(and (file-exists? nome)
(andato-male "c'è già ~A !!!" nome))
(daemonize ->bool (lambda (bye)
(sigaction SIGHUP bye)
(sigaction SIGQUIT bye)
(set! (posto tutti) 'eterna)
(cena p))
nome
p))
(define (grumi/qop qop)
(let ((tutti (gustare-la-verità (or (qop 'guile) "guile"))))
(or (and-let* ((port (qop 'port))
(p (or (string->number port)
(andato-male "invalid port: ~S" port)))
(cena (make-big-dishing-loop
#:socket-setup `((,SO_REUSEADDR . 1)
(,SO_LINGER 1 . 60))
#:method-handlers `((GET . ,(rispondere tutti)))
#:concurrency #f)))
(or (qop 'daemon (lambda (nome)
(come-daemon tutti nome cena p)))
(begin
(fso "ascoltando: ~S~%" p)
(cena p)
(fso "ciao!~%"))))
(let ((mc/t (modcatmgr tutti)))
(array-index-map!
mc/t (lambda (i)
(fso "cat[~A]: ~A~%" i
((vector-ref mc/t i) #:filename))))
(FE (ordinato tutti)
(lambda (nome)
(fso "~A: ~A~%"
(posto (modcatmgr nome))
nome)))))))
(define (main args)
(check-hv args `((package . "ttn-do")
(version . ,*versione*)
(help . commentary)))
(grumi/qop
(qop<-args
args '((guile (single-char #\G) (value #t))
(port (single-char #\p) (value #t))
(daemon (single-char #\d) (value #t))))))