From 207d04b652925de2348010a0a2a4d2f72728a363 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 23 Oct 2020 00:14:52 +0200 Subject: Add entry-point for generating tidsrapporter. --- module/calp/entry-points/tidsrapport.scm | 234 +++++++++++++++++++++++++++++++ module/calp/main.scm | 1 + module/datetime.scm | 2 +- module/vcomponent/search.scm | 2 +- 4 files changed, 237 insertions(+), 2 deletions(-) create mode 100644 module/calp/entry-points/tidsrapport.scm diff --git a/module/calp/entry-points/tidsrapport.scm b/module/calp/entry-points/tidsrapport.scm new file mode 100644 index 00000000..1c9d78bf --- /dev/null +++ b/module/calp/entry-points/tidsrapport.scm @@ -0,0 +1,234 @@ +;;; pdftk dump_data_fields to get field names (including checkbox values) + +(define-module (calp entry-points tidsrapport) + :export (main) + :use-module (calp util) + :use-module (calp util options) + :use-module (ice-9 getopt-long) + :use-module (datetime) + ) + +(use-modules (srfi srfi-41) + (srfi srfi-41 util) + (srfi srfi-1) + (vcomponent) + (datetime) + (vcomponent instance) + (vcomponent instance methods) + (calp util) + (ice-9 regex) + (ice-9 popen) + ) + + +(define event-set + (get-event-set global-event-object)) + +(define (get-worked-hours summary-search month year) + + (define instances + (group-by (compose day as-date (extract 'DTSTART)) + (stream->list + ((@ (vcomponent search) execute-query) + (lambda (e) + (define d (as-datetime (prop e 'DTSTART))) + (define s (date year: year month: month day: 1)) + + (and (string=? summary-search (prop e 'SUMMARY)) + (datetime<=? (datetime date: s) d) + (datetime<=? d (datetime date: (date+ s (date month: 1)))))) + event-set + )))) + + (define by-day (make-vector 31 0)) + + (define (exactify n) + (if (= n (round n)) + (inexact->exact n) + n)) + + (for-each (lambda (group) + (define day (car group)) + (vector-set! by-day day + (exactify + (apply + + (map (lambda (e) + (time->decimal-hour + (as-time + (datetime-difference (prop e 'DTEND) + (prop e 'DTSTART))))) + (cadr group)))))) + instances) + + + + (vector->list by-day)) + +(define (build-alist work-hours fields) + (filter-map + (lambda (f n) + (if (= 0 n) + #f + (list (string->symbol f) + n))) + fields + work-hours)) + + + +(define (fill-from-alist template-list data-list) + (filter-map (lambda (pair) + (cond ((assoc-ref data-list (cadr pair)) + => (lambda (it) (cons (car pair) it))) + (else #f))) + template-list)) + + + +;; +;; [ 1, 31] +;; Text16 [17, 47] Text48 +;; Text49 [50, 80] Text81 +;; Text82 [83, 113] Text114 +;; +(define (format-field key value) + (format #f "~%<<~%/T (~a)~%/V (~a)~%>>" + key value)) + +(define prefix-string + "%FDF-1.2 +%âãÏÓ +1 0 obj + +<< +/FDF +<< +/Fields [") + +(define post-string + "] +>> +>> +endobj + +trailer + +<< +/Root 1 0 R +>> +%%EOF") + + +(define (generate-fdf report) + (string-append prefix-string + (string-join (map (lambda (pair) + (apply format-field pair)) + report)) + post-string) +) + +(define opt-spec + '((pdf (value #t) + (description "Input pdf fill")) + (output (single-char #\o) (value 'optional) + (description "Output file")) + + (data (value optional) + (description "Static data to fill fields with") + ) + (template (value optional) + (description "Map between real field names and human readable names." (br) + "If data is given, but not trans, then data is assumed to be in a correct format")) + (search (value #t) + (description + "Search term for dynamic filling. Supports basic globbing")))) + +(define (parse-search str) + (cond [(string-match "\\{(.*)\\}" str) + => (lambda (m) + (map (lambda (option) + (string-replace str option + (match:start m) + (match:end m))) + (string-split (match:substring m 1) #\,)))] + [else (list str)])) + +(define (main args) + (define opts (getopt-long args (getopt-opt opt-spec))) + + (define input-pdf (option-ref opts 'pdf #f)) + (define output-pdf (or (option-ref opts 'output #f) + (and input-pdf + (string-append (dirname input-pdf) + "/" (basename input-pdf ".pdf") + "-output.pdf")))) + + (define data (option-ref opts 'data #f)) + (define template + (call-with-input-file + (or (option-ref opts 'template #f) + (error "Template required")) + read)) + + (define prepared-data + + (cond ((and template data) + (fill-from-alist template + (call-with-input-file data read))) + (data (call-with-input-file data read)) + (template '()) + (else '()))) + + (define search (parse-search (option-ref opts 'search #f))) + + ;; month year + (define rem (map string->number (option-ref opts '() '()))) + ;; TODO warn when length(search) > 3 (number of rows in pdf) + + (define auto-filled + (concatenate + (map (lambda (group search-term) + (define prefix (->string (car (or (assoc-ref group 'prefix) (list (symbol)))))) + (define summary + (string-append prefix (->string (car (assoc-ref group 'summary))))) + (define sum (string-append prefix (->string (car (assoc-ref group 'sum))))) + (define days + (let ((days (assoc-ref group 'days))) + (cond ((not (list? days)) + (error "Needs list, not pair")) + ((null? days) + (error "Need more days")) + ((and (list? (car days)) (eqv? '- (caar days))) + (map (lambda (s) (string-append prefix (->string s))) + (iota (1+ (- (list-ref (car days) 2) + (list-ref (car days) 1))) + (list-ref (car days) 1)))) + ;; TODO case where cadr is a list, instead of cdr is the list? + (else + (map (lambda (s) (string-append prefix (->string s))) + days))))) + + (define work-hours (apply get-worked-hours search-term rem)) + `((,summary ,(format #f "~a ~a" (locale-month (car rem)) search-term)) + ,@(build-alist work-hours days) + (,sum ,(apply + work-hours)))) + (or (assoc-ref template 'groups) + (error "Groups required in template")) + search))) + + (define report + (append + prepared-data + auto-filled)) + + + (if input-pdf + (let ((port (open-pipe* OPEN_WRITE + "pdftk" input-pdf "fill_form" "-" + "output" output-pdf))) + (set-port-encoding! port "ISO-8859-1") + (display (generate-fdf report) port) + (newline port) + ;; (put-bytevector port (generate-fdf report)) + (close-pipe port)) + (display (generate-fdf report)))) diff --git a/module/calp/main.scm b/module/calp/main.scm index 407f7b81..33da1554 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -192,6 +192,7 @@ ((text) (@ (calp entry-points text) main)) ((ical) (@ (calp entry-points ical) main)) ((server) (@ (calp entry-points server) main)) + ((tidsrapport) (@ (calp entry-points tidsrapport) main)) ((benchmark) (@ (calp entry-points benchmark) main)) (else => (lambda (s) (format (current-error-port) diff --git a/module/datetime.scm b/module/datetime.scm index 001af59e..cb732ad3 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -16,7 +16,7 @@ :use-module (ice-9 i18n) :use-module (ice-9 format) :use-module (calp util config) - :re-export (locale-month) + :re-export (locale-month locale-month-short) ) diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm index 7d039a24..a402bd49 100644 --- a/module/vcomponent/search.scm +++ b/module/vcomponent/search.scm @@ -73,7 +73,7 @@ ;; Returns a new stream which is the result of filtering the input set with the ;; query procedure. ;; (a → bool), (stream a) → (stream a) -(define (execute-query query-proc event-set) +(define-public (execute-query query-proc event-set) (stream-timeslice-limit (stream-filter query-proc event-set) ;; .5s, tested on my laptop. .1s sometimes doesn't get to events on -- cgit v1.2.3