Switch to `wak' suite of libraries

pkg-list.scm

@@ -0,0 +1,17 @@
+(package (irclogs (0) (20100409))
+  (depends (srfi)
+           (wak-riastreams)
+           (wak-foof-loop)
+           (wak-irregex)
+           (wak-fmt)
+           (wak-prometheus)
+           (spells)
+           (xitomatl)
+           (sbank))
+  (libraries (("scheme" "irclogs") -> "irclogs")
+             (("scheme" "irclogs.sls") -> "irclogs.sls")))
+
+
+;; Local Variables:
+;; scheme-indent-styles: (pkg-list)
+;; End:

scheme/irclogs.sls

@@ -1,6 +1,6 @@
 ;;; irclogs.sls --- An interface to IRC logs
 
-;; Copyright (C) 2009 Andreas Rottmann <a.rottmann@gmx.at>
+;; Copyright (C) 2009, 2010 Andreas Rottmann <a.rottmann@gmx.at>
 
 ;; Author: Andreas Rottmann <a.rottmann@gmx.at>
 
@@ -34,6 +34,7 @@
           (srfi :8 receive)
           (only (srfi :13)
                 string-concatenate substring/shared string-join)
+          (srfi :19 time)
           (srfi :43 vectors)
           (spells opt-args)
           (spells alist)
@@ -44,17 +45,18 @@
           (spells filesys)
           (spells string-utils)
           (spells define-values)
-          (spells foof-loop)
+          (wak foof-loop)
           (spells tracing)
-          (spells irregex)
-          (spells fmt)
-          (spells lazy-streams)
-          (prometheus)
-          (spenet path-dispatch)
-          (xitomatl ssax extras)
-          (spenet http)
-          (spenet httpd responses)
-          (spenet utils)
+          (wak irregex)
+          (wak fmt)
+          (wak riastreams)
+          (wak prometheus)
+          (ocelotl ssax-utils)
+          (only (ocelotl private utils)
+                uri-with-directory-path) ;++ move that to (ocelotl net uri)
+          (ocelotl net path-dispatch)
+          (ocelotl net http)
+          (ocelotl net httpd responses)
           (irclogs window)
           (irclogs tree)
           (irclogs cache)
@@ -529,28 +531,29 @@
       (logs 'add-value-slot! %cache (make-cache (logs 'state-dir)
                                                 (logs 'log-tree)
                                                 (logs %matcher)))
-      (modify-object! logs
-        ((dispatch self resend path request)
-         (let* ((file-path? (not (or (null? path)
-                                     (string=? (last path) ""))))
-                (trimmed-path (trim-path path)))
-           (cond ((irclogs-dispatcher trimmed-path)
-                  => (lambda (renderer)
-                       (if file-path?
-                           (make-error-response
-                            (http-status moved-perm)
-                            request
-                            (uri-with-directory-path (http-request/uri request)))
-                           (or (and=> (renderer self request)
-                                      (lambda (shtml)
-                                        (shtml-response-page self
-                                                             request
-                                                             shtml)))
-                               (not-found-response-page self request)))))
-                 (else
-                  (not-found-response-page self request))))))
+      (logs 'add-method-slot! 'dispatch do-dispatch)
       logs))
 
+  (define (do-dispatch self resend path request)
+    (let* ((file-path? (not (or (null? path)
+                                (string=? (last path) ""))))
+           (trimmed-path (trim-path path)))
+      (cond ((irclogs-dispatcher trimmed-path)
+             => (lambda (renderer)
+                  (if file-path?
+                      (make-error-response
+                       (http-status moved-perm)
+                       request
+                       (uri-with-directory-path (http-request/uri request)))
+                      (or (and=> (renderer self request)
+                                 (lambda (shtml)
+                                   (shtml-response-page self
+                                                        request
+                                                        shtml)))
+                          (not-found-response-page self request)))))
+            (else
+             (not-found-response-page self request)))))
+
   (define (render-overview self request tag channel)
     (let* ((query (http-request/uri-query-alist request))
            (base-date (or (query-date query) (todays-date 0)))

scheme/irclogs/cache.sls

@@ -1,6 +1,6 @@
 ;;; cache.sls --- Handling the cache for the log files
 
-;; Copyright (C) 2009 Andreas Rottmann <a.rottmann@gmx.at>
+;; Copyright (C) 2009, 2010 Andreas Rottmann <a.rottmann@gmx.at>
 
 ;; Author: Andreas Rottmann <a.rottmann@gmx.at>
 
@@ -34,13 +34,13 @@
           (srfi :2 and-let*)
           (srfi :8 receive)
           (srfi :19 time)
+          (wak foof-loop)
+          (wak irregex)
           (spells alist)
-          (spells foof-loop)
           (spells match)
           (only (spells record-types)
                 define-record-type*
                 define-functional-fields)
-          (spells irregex)
           (spells filesys)
           (spells pathname)
           (spells string-utils)

scheme/irclogs/page.sls

@@ -1,6 +1,6 @@
 ;;; page.sls --- 
 
-;; Copyright (C) 2009 Andreas Rottmann <a.rottmann@gmx.at>
+;; Copyright (C) 2009, 2010 Andreas Rottmann <a.rottmann@gmx.at>
 
 ;; Author: Andreas Rottmann <a.rottmann@gmx.at>
 
@@ -35,9 +35,9 @@
           (spells alist)
           (spells match)
           (spells string-utils)
-          (xitomatl ssax extras)
-          (spenet http)
-          (spenet httpd responses))
+          (ocelotl ssax-utils)
+          (ocelotl net http)
+          (ocelotl net httpd responses))
 
 (define (shtml-response-page irclogs request shtml)
   (make-http-response

scheme/irclogs/parse.sls

@@ -1,6 +1,6 @@
 ;;; parse.sls --- Parse IRC logs
 
-;; Copyright (C) 2008, 2009 Andreas Rottmann <a.rottmann@gmx.at>
+;; Copyright (C) 2008-2010 Andreas Rottmann <a.rottmann@gmx.at>
 
 ;; Author: Andreas Rottmann <a.rottmann@gmx.at>
 
@@ -36,12 +36,12 @@
           (srfi :2 and-let*)
           (srfi :8 receive)
           (srfi :19 time)
+          (srfi :45 lazy)
           (spells pathname)
           (spells misc)
           (spells match)
           (spells gc)
-          (spells lazy)
-          (spells lazy-streams)
+          (wak riastreams)
           (spells tracing)
           (xitomatl irregex)
           (irclogs utils))

scheme/irclogs/query.sls

@@ -1,6 +1,6 @@
 ;;; query.sls --- Query string handling.
 
-;; Copyright (C) 2008, 2009 Andreas Rottmann <a.rottmann@gmx.at>
+;; Copyright (C) 2008, 2009, 2010 Andreas Rottmann <a.rottmann@gmx.at>
 
 ;; Author: Andreas Rottmann <a.rottmann@gmx.at>
 
@@ -58,13 +58,13 @@
           (srfi :19 time)
           (only (spells record-types)
                 define-functional-fields)
-          (spells irregex)
+          (wak irregex)
           (spells alist)
           (spells misc)
           (spells tracing)
           (spells match)
-          (spells fmt)
-          (spells foof-loop)
+          (wak fmt)
+          (wak foof-loop)
           (irclogs parse)
           (irclogs utils))
 

scheme/irclogs/tree.sls

@@ -1,6 +1,6 @@
 ;;; tree.sls --- Handle a tree of IRC log files
 
-;; Copyright (C) 2009 Andreas Rottmann <a.rottmann@gmx.at>
+;; Copyright (C) 2009, 2010 Andreas Rottmann <a.rottmann@gmx.at>
 
 ;; Author: Andreas Rottmann <a.rottmann@gmx.at>
 
@@ -32,13 +32,13 @@
           (srfi :8 receive)
           (only (srfi :13) string-concatenate)
           (srfi :19 time)
+          (srfi :45 lazy)
           (spells alist)
           (spells misc)
-          (spells lazy)
-          (spells lazy-streams)
+          (wak riastreams)
           (spells gc)
           (spells filesys)
-          (spells irregex)
+          (wak irregex)
           (spells pathname)
           (spells gzip)
           (spells tracing)
@@ -124,16 +124,18 @@
                     (day . ,(num->str (date-day date) 2)))
                   (log-tree-struct tree)))
 
-(define log-port-guardian (make-guardian))
+(define log-port-reaper
+  (make-reaper (lambda (port)
+                 (close-port port)
+                 #t)))
 
 (define (open-log-stream tree tag channel date)
   ;; Close ports not in use anymore
-  (do ((port (log-port-guardian) (log-port-guardian)))
-      ((not port))
-    (close-port port))
+  (do ((v (log-port-reaper) (log-port-reaper)))
+      ((eqv? v #f)))
   (let ((port (open-log-file tree tag channel date)))
     (cond (port
-           (log-port-guardian port)
+           (log-port-reaper port)
            (port->irc-log-entry-stream port date))
           (else
            #f))))

scheme/irclogs/utils.sls

@@ -1,6 +1,6 @@
 ;;; utils.sls --- Utilities for the irclogs system.
 
-;; Copyright (C) 2008, 2009 Andreas Rottmann <a.rottmann@gmx.at>
+;; Copyright (C) 2008, 2009, 2010 Andreas Rottmann <a.rottmann@gmx.at>
 
 ;; Author: Andreas Rottmann <a.rottmann@gmx.at>
 
@@ -35,8 +35,6 @@
     parse-date unparse-date
     todays-date
     date-day=?
-    date-up-from
-    date-down-from
 
     in-stream
 
@@ -64,18 +62,19 @@
           (srfi :8 receive)
           (srfi :13 strings)
           (srfi :14 char-sets)
+          (srfi :19 time)
           (srfi :26 cut)
           (srfi :39 parameters)
+          (wak riastreams)
+          (wak irregex)
           (spells opt-args)
           (spells alist)
-          (spells time-lib)
           (spells misc)
-          (spells lazy-streams)
           (spells string-utils)
           (spells pathname)
-          (spells irregex)
+          (spells time-lib)
           (spells tracing)
-          (spenet uri))
+          (ocelotl net uri))
 
   (define (list-intersperse lst item)
     (if (null? lst)
@@ -156,56 +155,6 @@
           (else
            (guard (c (#t #f))
              (date-with-zone-offset (string->date s isodate-fmt) 0)))))
-
-  (define-syntax date-up-from
-    (syntax-rules ()
-      ((_ (date-var) (start-expr (to end-expr)) cont . env)
-       (cont
-        (((end) (date->time-utc end-expr)) ;Outer bindings
-         ((start tz) (let ((start start-expr))
-                       (values start (date-zone-offset start))))
-         ((step) one-day))
-        ((time-var (date->time-utc start)  ;Loop variables
-                   (add-duration time-var step)))
-        ()                                 ;Entry bindings
-        ((time>=? time-var end))           ;Termination conditions
-        (((date-var)                       ;Body bindings
-          (time-utc->date time-var tz)))
-        ()                                 ;Final bindings
-        . env))))
-
-  (define-syntax date-down-from
-    (syntax-rules ()
-      ((_ (date-var) (start-expr (to end-expr)) cont . env)
-       (cont
-        (((end) (date->time-utc end-expr)) ;Outer bindings
-         ((start tz) (let ((start start-expr))
-                       (values start (date-zone-offset start))))
-         ((step) one-day))
-        ((time-var (date->time-utc start)  ;Loop variables
-                   (subtract-duration time-var step)))
-        ()                                 ;Entry bindings
-        ((time<=? time-var end))           ;Termination conditions
-        (((date-var)                       ;Body bindings
-          (time-utc->date time-var tz)))
-        ()                                 ;Final bindings
-        . env))))
-
-  (define-syntax in-stream
-    (syntax-rules ()
-      ((_ (elt-var stream-var) (stream-expr) cont . env)
-       (cont
-        ()                                    ;Outer bindings
-        ((stream-var stream-expr              ;Loop variables
-                     (stream-cdr stream-var)))
-        ()                                    ;Entry bindings
-        ((stream-null? stream-var))           ;Termination conditions
-        (((elt-var) (stream-car stream-var))) ;Body bindings
-        ()                                    ;Final bindings
-        . env))
-      ;; Optional stream variable
-      ((_ (elt-var) (stream-expr) cont . env)
-       (in-stream (elt-var stream) (stream-expr) cont . env))))
 
   (define (println fmt . args)
     (string-substitute #t fmt args 'braces)

scheme/irclogs/window.sls

@@ -1,6 +1,6 @@
 ;;; window.sls --- "sliding window" for searching with context
 
-;; Copyright (C) 2009 Andreas Rottmann <a.rottmann@gmx.at>
+;; Copyright (C) 2009, 2010 Andreas Rottmann <a.rottmann@gmx.at>
 
 ;; Author: Andreas Rottmann <a.rottmann@gmx.at>
 
@@ -36,10 +36,10 @@
   (import (rnrs)
           (srfi :8 receive)
           (srfi :19 time)
-          (spells foof-loop)
-          (spells lazy-streams)
+          (wak foof-loop)
+          (wak riastreams)
           (spells tracing)
-          (spenet wt-tree)
+          (ocelotl wt-tree)
           (irclogs utils)
           (irclogs parse))