(module plugin-counter mzscheme
(require "hwikiplugin.scm")
(provide register-plugin-counter
)
(def-class
(this (entry _page _context _langs _ip))
(supers)
(private
(define _tm (current-date))
)
(public
(define (ip) _ip)
(define (page) _page)
(define (context) _context)
(define (time) _tm)
(define (accepted-languages) (let ((fh (open-output-string)))
(write _langs fh)
(let ((S (get-output-string fh)))
(close-output-port fh)
S)))
)
(constructor)
)
(def-class
(this (plugin:counter))
(supers)
(private
(define _fifos (make-hash-table 'equal))
(define _sqlis (make-hash-table 'equal))
(define _inserters (make-hash-table 'equal))
(define (create-context context)
(let ((FIFO (hash-table-get _fifos (-> context context)
(lambda ()
(hash-table-put! _fifos (-> context context) (fifo))
(let ((sqli (sqli-provider)))
(if (eq? sqli #f)
(error "plugin:counter needs a database connection to work")
(begin
(hlog (format "sqli: after connect to database: ~a" (sqli-error-message sqli)))
(hash-table-put! _sqlis (-> context context) sqli)
(hash-table-put! _inserters (-> context context) (thread (lambda () (inserter context))))
(sqli-query sqli "create table access(page varchar,context varchar,ip varchar,accepted_languages varchar,time timestamp)")
(sqli-query sqli "create table pages(page varchar,context varchar,count integer,primary key (page,context))")
)))))))
#t))
(define (get-sqli context)
(create-context context)
(hash-table-get _sqlis (-> context context)))
(define (get-fifo context)
(create-context context)
(hash-table-get _fifos (-> context context)))
(define (get-inserter context)
(create-context context)
(hash-table-get _inserters (-> context context)))
(define (inserter context)
(let ((sqli (sqli-provider))
(FIFO (get-fifo context)))
(if (eq? sqli #f)
(error "plugin:counter needs a database connection to work")
(begin
(hlog (format "sqli: after connect to database: ~a" (sqli-error-message sqli)))
(letrec ((f (lambda ()
(let ((entry (fifo- FIFO)))
(display (format "begin~%"))
(sqli-begin sqli)
(display (format "insert access~%"))
(sqli-query sqli "insert into access(page,context,ip,accepted_languages,time) values($1,$2,$3,$4,$5)"
(-> entry page)
(-> entry context)
(-> entry ip)
(-> entry accepted-languages)
(-> entry time))
(let ((c (begin
(display (format "count pages~%"))
(sqli-query sqli "select count(*) from pages where page=$1 and context=$2"
(-> entry page) (-> entry context))
(string->number (car (sqli-fetchrow sqli))))))
(display (format "insert or update pages~%"))
(if (= c 0)
(sqli-query sqli "insert into pages(page,context,count) values($1,$2,$3)" (-> entry page) (-> entry context) 1)
(sqli-query sqli "update pages set count=count+1 where page=$1 and context=$2" (-> entry page) (-> entry context)))
(display (format "commit pages~%"))
(sqli-commit sqli)))
(f))))
(f))))))
(define (count page context)
(let ((row (let ((_sqli (get-sqli context)))
(display (format "select pages~%"))
(sqli-query _sqli "select count from pages where page=$1 and context=$2" page (-> context context))
(sqli-fetchrow _sqli))))
(if (eq? row #f)
0
(car row))))
)
(public
(define (counter context)
(fifo+ (get-fifo context)
(entry (-> context page-name)
(-> context context)
(-> context accepted-languages)
(-> context from-ip)))
"")
(define (display-counter context)
(counter context)
(let ((P (page context))
(part (-> context current-part)))
(let ((S (if (-> P has-contents? part)
(-> P contents part)
(_ "page hits: ~a"))))
(format S (count (-> context page-name) context)))))
)
(constructor)
)
(define COUNTER #f)
(define (register-plugin-counter)
(if (eq? COUNTER #f)
(set! COUNTER (plugin:counter)))
(register-plugin 'plugin:counter (->> COUNTER counter))
(register-plugin 'plugin:display-counter (->> COUNTER display-counter)))
)