more cleanups, xhtml sanitization thanks to MikeS, --repl

tekuti/boot.scm

@@ -37,6 +37,7 @@
 
 (define *option-grammar* '((gds)
                            (usage)
+                           (repl)
                            (version (single-char #\v))
                            (help (single-char #\h))))
 
@@ -55,10 +56,7 @@
 
 ;; krap code
 (define (parse-options args)
-  (let ((opts (getopt-long args '((gds)
+  (let ((opts (getopt-long args *option-grammar*)))
-                                  (usage)
-                                  (version (single-char #\v))
-                                  (help (single-char #\h))))))
     (if (or (option-ref opts 'usage #f)
             (option-ref opts 'help #f)
             (not (null? (option-ref (cdr opts) '() '()))))
@@ -79,4 +77,8 @@
 (define (boot args)
   (let ((options (parse-options args)))
     (ensure-git-repo)
-    (event-loop)))
+    (if (option-ref options 'repl #f)
+        (begin (make-thread event-loop)
+               (scm-style-repl))
+        (event-loop))))
+

tekuti/comment.scm

@@ -130,24 +130,30 @@
 (define (compile-sxslt-rules tags)
   (define (ok . body)
     body)
+  (define (compile-attribute-rule rule)
+    (if (symbol? rule)
+        `(,rule . ,ok)
+        `(,(car rule) . ,(lambda (tag text)
+                           (or ((cdr rule) text)
+                               (throw 'bad-attr-value text))
+                           (list tag text)))))
   `(,@(map (lambda (spec)
              `(,(car spec)
-               ((@ (,@(map (lambda (attr)
+               ((@ *preorder*
-                             (if (symbol? attr)
+                   . ,(let ((rules `((@ (,@(map compile-attribute-rule
-                                 `(,attr . ,ok)
+                                                (cdr spec))
-                                 `(,(car attr)
+                                         (*text*
-                                   . ,(lambda (tag text)
+                                          . ,(lambda (tag text) text))
-                                        (or ((cdr attr) text)
+                                         (*default*
-                                            (throw 'bad-attr-value text))
+                                          . ,(lambda (tag . body)
-                                        (list tag text)))))
+                                               (throw 'bad-attr tag))))
-                           (cdr spec)))
+                                        . ,ok))))
-                   . ,ok))
+                        (lambda tree
+                          (pre-post-order tree rules)))))
                . ,ok))
            *allowed-tags*)
     (*text* . ,(lambda (tag text)
                  text))
-    (@ . ,(lambda (tag text)
-            (throw 'bad-attr tag)))
     (*default* . ,(lambda (tag . body)
                     (throw 'bad-tag tag)))))
 
@@ -251,40 +257,33 @@
                            dadd)
                dents))))))
     
-(define (mutate-tree master add remove change message)
+(define de-newline (s///g "[\n\r]" " "))
-  (let ((tree (make-tree-deep master add remove change)))
-    (string-trim-both
-     (git* `("commit-tree" ,tree "-p" ,master) #:input message
-           #:env '("GIT_COMMMITTER=tekuti")))))
 
 (define (make-new-comment post post-data)
   (let ((content (assoc-ref post-data "comment"))
         (author (assoc-ref post-data "author"))
         (email (assoc-ref post-data "email"))
         (url (assoc-ref post-data "url"))) 
-    (let ((sha1 (create-blob 
+    (let ((sha1 (with-output-to-blob
-                 (with-output-to-string
+                 (for-each
-                   (lambda ()
+                  (lambda (pair)
-                     (for-each
+                    (format #t "~a: ~a\n" (car pair) (cdr pair)))
-                      (lambda (pair)
+                  `((timestamp . ,(time-second (current-time)))
-                        (format #t "~a: ~a\n" (car pair) (cdr pair)))
+                    (author . ,(de-newline author))
-                      `((timestamp . ,(time-second (current-time)))
+                    (author_email . ,email)
-                        (author . ,(string-join
+                    (author_url . ,url)))
-                                    ;; security foo
+                 (display "\n")
-                                    (string-split author #\newline)
+                 (display content))))
-                                    " "))
-                        (author_email . ,email)
-                        (author_url . ,url)))
-                     (display "\n")
-                     (display content))))))
       (git-update-ref
        "refs/heads/master"
        (lambda (master)
-         (mutate-tree master
+         (git-commit-tree
-                      `(((,(assq-ref post 'key) "comments") . (,sha1 ,sha1 "blob" "100644")))
+          (make-tree-deep master
-                      '()
+                          `(((,(assq-ref post 'key) "comments")
-                      '()
+                             . (,sha1 ,sha1 blob)))
-                      "new comment"))
+                          '()
+                          '())
+          master
+          "new comment"
+          #f))
        5))))
-
-

tekuti/git.scm

@@ -39,9 +39,11 @@
             git git* ensure-git-repo git-ls-tree git-ls-subdirs
             parse-metadata parse-commit commit-utc-timestamp
             commit-parents git-mktree git-rev-parse
-            create-blob git-update-ref
+            git-hash-object git-update-ref
             git-commit-tree
 
+            with-output-to-blob with-input-from-blob
+
             write-indices read-indices))
 
 (define-condition-type &git-condition &condition git-condition?
@@ -53,17 +55,6 @@
   `(,guard (c ((,git-condition? c) #f))
            ,@body))
 
-(define (shell:quote str)
-  (with-output-to-string
-    (lambda ()
-      (display #\')
-      (for-each (lambda (ch)
-		  (if (eqv? ch #\')
-                      (begin (display #\\) (display #\'))
-                      (display ch)))
-		(string->list str))
-      (display #\'))))
-      
 (define *debug* #f)
 (define (trc . args)
   (if *debug*
@@ -202,10 +193,22 @@
 (define (git-rev-parse rev)
   (string-trim-both (git "rev-parse" rev)))
 
-(define (create-blob contents)
+(define (git-hash-object contents)
   (string-trim-both
    (git* '("hash-object" "-w" "--stdin") #:input contents)))
 
+(define (with-output-to-blob* thunk)
+  (git-hash-object (with-output-to-string thunk)))
+
+(define-macro (with-output-to-blob . forms)
+  `(,with-output-to-blob* (lambda () ,@forms)))
+
+(define (with-input-from-blob* sha1 thunk)
+  (with-input-from-string (git "show" sha1) thunk))
+
+(define-macro (with-input-from-blob sha1 . forms)
+  `(,with-input-from-blob* ,sha1 (lambda () ,@forms)))
+
 (define (git-update-ref refname proc count)
   (let* ((ref (git-rev-parse refname))
          (commit (proc ref)))
@@ -227,7 +230,8 @@
          #:env (if timestamp
                    (list "GIT_COMMMITTER=tekuti"
                          (format #f "GIT_COMMITTER_DATE=~a +0100" timestamp)
-                         (format #f "GIT_AUTHOR_DATE=~a +0100" timestamp))))))
+                         (format #f "GIT_AUTHOR_DATE=~a +0100" timestamp))
+                   (list "GIT_COMMMITTER=tekuti")))))
 
 ;; fixme: map-pairs
 

tekuti/mod-lisp.scm

@@ -26,15 +26,14 @@
 
 (define-module (tekuti mod-lisp)
   #:use-module (ice-9 rdelim)
-  #:use-module ((srfi srfi-1) #:select (fold))
   #:use-module (tekuti config)
   #:use-module (tekuti util)
-  #:use-module (tekuti index) ; rev-parse
+  #:use-module (tekuti index)
   #:use-module (tekuti request)
   #:use-module (tekuti web)
   #:export (event-loop))
 
-;;; thought: ignore SIGPIPE, otherwise apache dying will kill us
+;;; FIXME: ignore SIGPIPE, otherwise apache dying will kill us
 
 (define (read-headers socket)
   (define (read-line*)

tekuti/page.scm

@@ -271,7 +271,11 @@
                (rcons* request
                        'title "comment posted"
                        'body `((p "Comment, posted, thanks.")
-                               (p "Back to the post: " (post-link post)))))))))
+                               ;; fixme: show the post directly; or a redirect?
+                               (p "Back to the post: "
+                                  ,(rellink (string-append "archives/" (url:decode slug))
+                                            post)))))))))
+     
      (else
       (page-not-found request index)))))
 

tekuti/util.scm

@@ -29,9 +29,20 @@
   #:use-module (srfi srfi-1)
   #:export (expanduser match-lines dbg unwind-protect dbg dsu-sort
             hash-push! list-has-length? list-head-match mapn
-            take-max read-hash write-hash
+            take-max read-hash write-hash shell:quote
             list-intersperse with-backtrace with-time-debugging define-memoized))
 
+(define (shell:quote str)
+  (with-output-to-string
+    (lambda ()
+      (display #\')
+      (string-for-each (lambda (ch)
+                         (if (eqv? ch #\')
+                             (begin (display #\\) (display #\'))
+                             (display ch)))
+                       str)
+      (display #\'))))
+      
 (define (expanduser path)
   (let ((parts (string-split path #\/)))
     (if (eqv? (string-ref (car parts) 0) #\~)