diff options
Diffstat (limited to 'module/calp')
40 files changed, 2681 insertions, 283 deletions
diff --git a/module/calp/entry-points/benchmark.scm b/module/calp/entry-points/benchmark.scm index 31ea958a..709d2bea 100644 --- a/module/calp/entry-points/benchmark.scm +++ b/module/calp/entry-points/benchmark.scm @@ -17,9 +17,9 @@ (define opt-spec `((enable-output (single-char #\o) (description - ,(_ "Output is by default supressed, since many fields contain way to much data to read. This turns it on again.") + ,(G_ "Output is by default supressed, since many fields contain way to much data to read. This turns it on again.") )) - (help (single-char #\h) (description ,(_ "Print this help."))))) + (help (single-char #\h) (description ,(G_ "Print this help."))))) (define (main args) diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm index 707414e5..0835b3d6 100644 --- a/module/calp/entry-points/convert.scm +++ b/module/calp/entry-points/convert.scm @@ -12,12 +12,12 @@ (define opt-spec `((from (single-char #\f) (value (options "xcal" "ical")) - (description ,(xml->sxml (_ "<group>Input format (otherwise infered from <i>infile</i>)</group>")))) + (description ,(xml->sxml (G_ "<group>Input format (otherwise infered from <i>infile</i>)</group>")))) (to (single-char #\t) (value (options "xcal" "ical")) - (description ,(xml->sxml (_ "<group>Output format (otherwise infered from <i>outfile</i>)</group>")))) - (infile (value #t) (single-char #\i) (description ,(_ "Input file"))) - (outfile (value #t) (single-char #\o) (description ,(_ "Output file"))) - (help (single-char #\h) (description ,(_ "Print this help."))))) + (description ,(xml->sxml (G_ "<group>Output format (otherwise infered from <i>outfile</i>)</group>")))) + (infile (value #t) (single-char #\i) (description ,(G_ "Input file"))) + (outfile (value #t) (single-char #\o) (description ,(G_ "Output file"))) + (help (single-char #\h) (description ,(G_ "Print this help."))))) (define (filename-to-type filename) @@ -71,7 +71,7 @@ ;; TODO strip *TOP* xml->sxml)] [else (scm-error 'misc-error "convert-main" - (_ "Unexpected parser type: ~a") + (G_ "Unexpected parser type: ~a") (list from) #f)] )) @@ -90,7 +90,7 @@ component) port))] [else (scm-error 'misc-error "convert-main" - (_ "Unexpected writer type: ~a") + (G_ "Unexpected writer type: ~a") (list to) #f)])) diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index 2aa7e0e2..de229533 100644 --- a/module/calp/entry-points/html.scm +++ b/module/calp/entry-points/html.scm @@ -31,21 +31,21 @@ (define opt-spec `((from (value #t) (single-char #\F) - (description ,(_ "Start date of output.")) + (description ,(G_ "Start date of output.")) ) (count (value #t) - (description ,(xml->sxml (_ "<group>How many pages should be rendered. + (description ,(xml->sxml (G_ "<group>How many pages should be rendered. If --style=<b>week</b> and --from=<b>2020-04-27</b>; then --count=<b>4</b> would render the four pages 2020-04-27, 2020-05-04, 2020-05-11, and 2020-05-25. Defaults to 12 to give a whole year when --style=<b>month</b></group>")))) (target (single-char #\t) (value #t) - (description ,(xml->sxml (_ "<group>Directory where html files should end up. Default to <b>./html</b></group>")))) + (description ,(xml->sxml (G_ "<group>Directory where html files should end up. Default to <b>./html</b></group>")))) (style (value #t) (predicate ,(lambda (v) (memv (string->symbol v) '(small wide week table)))) - (description ,(xml->sxml (_ "<group>How the body of the HTML page should be layed out. + (description ,(xml->sxml (G_ "<group>How the body of the HTML page should be layed out. <br/><b>week</b> gives a horizontally scrolling page with 7 elements, where each has events graphically laid out hour by hour. @@ -56,10 +56,10 @@ given day, in order of start time. They are however not graphically sized. is the same as week, but gives a full month.</group>")))) (standalone - (description ,(xml->sxml (_ "<group>Creates a standalone document instead of an HTML fragment + (description ,(xml->sxml (G_ "<group>Creates a standalone document instead of an HTML fragment for embedding in a larger page. Currently only applies to the <i>small</i> style</group>")))) - (help (single-char #\h) (description ,(_ "Print this help."))))) + (help (single-char #\h) (description ,(G_ "Print this help."))))) @@ -81,9 +81,9 @@ for embedding in a larger page. Currently only applies to the <i>small</i> style ((= errno EEXIST) (let ((st (lstat link))) (cond ((not (eq? 'symlink (stat:type st))) - (warning (_ "File ~s exists, but isn't a symlink") link)) + (warning (G_ "File ~s exists, but isn't a symlink") link)) ((not (string=? target (readlink link))) - (warning (_ "~s is a symlink, but points to ~s instead of expected ~s") + (warning (G_ "~s is a symlink, but points to ~s instead of expected ~s") link (readlink link) target)))) ;; else, file exists as a symlink, and points where we want, ;; which is expected. Do nothing and be happy. @@ -113,7 +113,7 @@ for embedding in a larger page. Currently only applies to the <i>small</i> style (stream-for-each (lambda (start-date) (define fname (path-append target-directory (date->string start-date "~1.xml"))) - (format (current-error-port) (_ "Writing to [~a]~%") fname) + (format (current-error-port) (G_ "Writing to [~a]~%") fname) (with-output-to-file fname (lambda () (sxml->xml (re-root-static (apply html-generate @@ -178,7 +178,7 @@ for embedding in a larger page. Currently only applies to the <i>small</i> style pre-start: (start-of-week start) post-end: (end-of-week (end-of-month start)))] [else - (scm-error 'misc-error "html-main" (_ "Unknown html style: ~a") (list style) #f)]) + (scm-error 'misc-error "html-main" (G_ "Unknown html style: ~a") (list style) #f)]) - ((@ (calp util time) report-time!) (_ "all done")) + ((@ (calp util time) report-time!) (G_ "all done")) ) diff --git a/module/calp/entry-points/ical.scm b/module/calp/entry-points/ical.scm index e164c340..3720d8db 100644 --- a/module/calp/entry-points/ical.scm +++ b/module/calp/entry-points/ical.scm @@ -12,9 +12,9 @@ (define opt-spec `((from (value #t) (single-char #\F)) (to (value #t) (single-char #\T) - (description ,(_ "Returns all elements between these two dates."))) + (description ,(G_ "Returns all elements between these two dates."))) (help (single-char #\h) - (description ,(_ "Print this help."))))) + (description ,(G_ "Print this help."))))) (define (main args) (define opts (getopt-long args (getopt-opt opt-spec))) diff --git a/module/calp/entry-points/import.scm b/module/calp/entry-points/import.scm index 00edc0d8..ecf8b939 100644 --- a/module/calp/entry-points/import.scm +++ b/module/calp/entry-points/import.scm @@ -16,11 +16,11 @@ (define options `((calendar (value #t) (single-char #\c) - (description ,(_ "Name of calendar to import into"))) + (description ,(G_ "Name of calendar to import into"))) (file (value #t) (single-char #\f) - (description ,(_ "ics file to import"))) + (description ,(G_ "ics file to import"))) (help (single-char #\h) - (description ,(_ "Print this help."))))) + (description ,(G_ "Print this help."))))) (define (main args) (define opts (getopt-long args (getopt-opt options))) @@ -39,18 +39,18 @@ (get-calendars global-event-object))))) (unless calendar - (format (current-error-port) (_ "No calendar named ~s~%") cal-name) + (format (current-error-port) (G_ "No calendar named ~s~%") cal-name) (throw 'return)) (let ((new-events (parse-cal-path fname))) - (format #t (_ "About to import the following ~a events into ~a~%") + (format #t (G_ "About to import the following ~a events into ~a~%") (length (children new-events)) (prop calendar 'NAME)) (format #t "~{~a~^~%~}~%" (map (extract 'SUMMARY) (children new-events))) - (format #t (_ "Continue? [Y/n] ")) + (format #t (G_ "Continue? [Y/n] ")) (let loop ((line (read-line))) (case (if (string-null? line) 'yes (yes-no-check line)) diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm index 903d085d..08c9d43a 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -17,22 +17,22 @@ (define options `((port (value #t) (single-char #\p) - (description ,(xml->sxml (_ "<group>Bind to TCP port, defaults to <i>8080</i>. + (description ,(xml->sxml (G_ "<group>Bind to TCP port, defaults to <i>8080</i>. <br/>Can also be set through the config variable <i>port</i>.</group>")))) (addr (value #t) - (description ,(xml->sxml (_ "<group>Address to use, defaults to <i>0.0.0.0</i> for IPv4, + (description ,(xml->sxml (G_ "<group>Address to use, defaults to <i>0.0.0.0</i> for IPv4, and <i>[::]</i> for IPv6</group>")))) ;; numbers as single-char doesn't work. - (six (description ,(_ "Use IPv6."))) - (four (description ,(_ "Use IPv4."))) - (sigusr (description ,(_ "Reload events on SIGUSR1"))) + (six (description ,(G_ "Use IPv6."))) + (four (description ,(G_ "Use IPv4."))) + (sigusr (description ,(G_ "Reload events on SIGUSR1"))) (help (single-char #\h) - (description ,(_ "Print this help."))))) + (description ,(G_ "Print this help."))))) (define-config port 8080 - description: (_ "Port to which the web server should bind.")) + description: (G_ "Port to which the web server should bind.")) (define (main args) @@ -59,12 +59,12 @@ and <i>[::]</i> for IPv6</group>")))) "::" "0.0.0.0"))) (when (option-ref opts 'sigusr #f) - (format (current-error-port) (_ "Listening for SIGUSR1~%")) + (format (current-error-port) (G_ "Listening for SIGUSR1~%")) ;; NOTE this uses the main thread, and does therefore block HTTP requests ;; while reloading. However, it appears to not cause any race conditions. (sigaction SIGUSR1 (lambda _ - (format (current-error-port) (_ "Received SIGUSR1, reloading calendars~%")) + (format (current-error-port) (G_ "Received SIGUSR1, reloading calendars~%")) ((@ (vcomponent util instance) reload))))) @@ -74,7 +74,7 @@ and <i>[::]</i> for IPv6</group>")))) ;; Port which we listen to ;; PID of this process ;; PWD of this process - (format #t (_ "Starting server on ~a:~a~%I'm ~a, runing from ~a~%") + (format #t (G_ "Starting server on ~a:~a~%I'm ~a, runing from ~a~%") addr port% (getpid) (getcwd)) diff --git a/module/calp/entry-points/terminal.scm b/module/calp/entry-points/terminal.scm index dd35b8f3..9a1b8b00 100644 --- a/module/calp/entry-points/terminal.scm +++ b/module/calp/entry-points/terminal.scm @@ -11,8 +11,8 @@ (define options `((date (value #t) (single-char #\d) - (description ,(_ "Which date to start on."))) - (help (single-char #\t) (description ,(_ "Print this help."))) + (description ,(G_ "Which date to start on."))) + (help (single-char #\t) (description ,(G_ "Print this help."))) )) (define (main args) diff --git a/module/calp/entry-points/text.scm b/module/calp/entry-points/text.scm index 775245eb..127798ce 100644 --- a/module/calp/entry-points/text.scm +++ b/module/calp/entry-points/text.scm @@ -12,11 +12,11 @@ (define options `((width (value #t) (single-char #\w) - (description ,(_ "Width of written text, defaults to 70 chars."))) + (description ,(G_ "Width of written text, defaults to 70 chars."))) (file (value #t) (single-char #\f) - (description ,(xml->sxml (_ "<group>Read from <i>file</i> instead of standard input.</group>")))) + (description ,(xml->sxml (G_ "<group>Read from <i>file</i> instead of standard input.</group>")))) (help (single-char #\h) - (description ,(_ "Prints this help."))))) + (description ,(G_ "Prints this help."))))) (define (main args) (define opts (getopt-long args (getopt-opt options))) diff --git a/module/calp/entry-points/tidsrapport.scm b/module/calp/entry-points/tidsrapport.scm index a50f0659..a258cd73 100644 --- a/module/calp/entry-points/tidsrapport.scm +++ b/module/calp/entry-points/tidsrapport.scm @@ -93,7 +93,7 @@ (as-time (datetime-difference (prop e 'DTEND) (prop e 'DTSTART))))) - (cadr group)))))) + (cdr group)))))) instances) @@ -165,19 +165,19 @@ trailer (define opt-spec `((pdf (value #t) - (description ,(_ "Input pdf file"))) + (description ,(G_ "Input pdf file"))) (output (single-char #\o) (value optional) - (description ,(_ "Output file"))) + (description ,(G_ "Output file"))) (data (value optional) - (description ,(_ "Static data to fill fields with")) + (description ,(G_ "Static data to fill fields with")) ) (template (value optional) - (description ,(xml->sxml (_ "<group>Map between real field names and human readable names.<br/> + (description ,(xml->sxml (G_ "<group>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</group>")))) (search (value #t) (description - ,(_ "Search term for dynamic filling. Supports basic globbing"))))) + ,(G_ "Search term for dynamic filling. Supports basic globbing"))))) (define (parse-search str) (cond [(string-match "\\{(.*)\\}" str) @@ -203,7 +203,7 @@ If data is given, but not trans, then data is assumed to be in a correct format< (define template (call-with-input-file (or (option-ref opts 'template #f) - (error (_ "Template required"))) + (error (G_ "Template required"))) read)) (define prepared-data @@ -231,9 +231,9 @@ If data is given, but not trans, then data is assumed to be in a correct format< (define days (let ((days (assoc-ref group 'days))) (cond ((not (list? days)) - (error (_ "Needs list, not pair"))) + (error (G_ "Needs list, not pair"))) ((null? days) - (error (_ "Need more days"))) + (error (G_ "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) @@ -249,7 +249,7 @@ If data is given, but not trans, then data is assumed to be in a correct format< ,@(build-alist work-hours days) (,sum ,(apply + work-hours)))) (or (assoc-ref template 'groups) - (error (_ "Groups required in template"))) + (error (G_ "Groups required in template"))) search))) (define report diff --git a/module/calp/entry-points/update-zoneinfo.scm b/module/calp/entry-points/update-zoneinfo.scm index b565faeb..c6be1af3 100644 --- a/module/calp/entry-points/update-zoneinfo.scm +++ b/module/calp/entry-points/update-zoneinfo.scm @@ -14,7 +14,7 @@ :use-module (calp translation)) (define opt-spec - `((help (single-char #\h) (description ,(_ "Print this help."))))) + `((help (single-char #\h) (description ,(G_ "Print this help."))))) (define (main args) (define opts (getopt-long args (getopt-opt opt-spec))) @@ -27,7 +27,7 @@ (path-append (xdg-data-home) "tzget"))) (filename (or (find file-exists? locations) (scm-error 'missing-helper "update-zoneinfo" - (_ "tzget not installed, please put it in one of ~a") + (G_ "tzget not installed, please put it in one of ~a") (list locations) (list "tzget" locations)))) diff --git a/module/calp/html/caltable.scm b/module/calp/html/caltable.scm index 2c027c35..bdbcf55f 100644 --- a/module/calp/html/caltable.scm +++ b/module/calp/html/caltable.scm @@ -58,7 +58,7 @@ ;; Cell 0, 0. The letter v. for week number (div (@ (class "column-head row-head")) - ,(_ "v.")) + ,(G_ "v.")) ;; top row, names of week days ,@(map (lambda (d) `(div (@ (class "column-head")) diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index df30b6bc..463bae38 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -54,7 +54,7 @@ rest: args) (when (and onclick href) (scm-error 'wrong-type-arg "btn" - (_ "href and onclick are mutually exclusive. href = ~s, onclick = ~s.") + (G_ "href and onclick are mutually exclusive. href = ~s, onclick = ~s.") (list href onclick) #f)) (let ((classes (string-join (cons "btn" class) " ")) diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm index 948cadb7..0a5b44ae 100644 --- a/module/calp/html/util.scm +++ b/module/calp/html/util.scm @@ -33,6 +33,6 @@ #xFF)) "#000000" "#FFFFFF"))) (lambda args - (format (current-error-port) (_ "Error calculating foreground color?~%~s~%") args) + (format (current-error-port) (G_ "Error calculating foreground color?~%~s~%") args) "#FF0000" ))) diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 287c62e1..0516b9d4 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -56,10 +56,10 @@ (configuration-error (lambda (key subr msg args data) (format (current-error-port) - (_ "Error retrieving configuration, ~?~%") msg args))) + (G_ "Error retrieving configuration, ~?~%") msg args))) (#t ; for errors when running the filter (lambda (err . args) - (warning (_ "~a on formatting description, ~s") err args) + (warning (G_ "~a on formatting description, ~s") err args) str)))) ;; TODO replace with propper mimetype parser @@ -91,14 +91,14 @@ "unknown"))))) (time ,(let ((dt (prop event 'DTSTART))) (if (datetime? dt) - (datetime->string dt (_ "~Y-~m-~d ~H:~M")) - (date->string dt (_ "~Y-~m-~d") )))) + (datetime->string dt (G_ "~Y-~m-~d ~H:~M")) + (date->string dt (G_ "~Y-~m-~d") )))) (a (@ (href ,(date->string (as-date (prop event 'DTSTART)) "/week/~Y-~m-~d.html"))) ;; Button for viewing calendar, accompanied by a calendar icon - ,(_ "View") " 📅") + ,(G_ "View") " 📅") (span ,(prop event 'SUMMARY))))) (cons - (calendar-styles calendars) + `(style ,(lambda () (calendar-styles calendars #t))) (for event in list `(details ,(summary event) @@ -166,7 +166,7 @@ (div (@ (class "fields")) ,(when (and=> (prop ev 'LOCATION) (negate string-null?)) - `(div (b ,(_ "Location: ")) + `(div (b ,(G_ "Location: ")) (div (@ (class "location") (data-property "location")) ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) (prop ev 'LOCATION))))) @@ -244,10 +244,10 @@ ,@(format-recurrence-rule ev))) ,(when (prop ev 'LAST-MODIFIED) - `(div (@ (class "last-modified")) ,(_ "Last modified") " " + `(div (@ (class "last-modified")) ,(G_ "Last modified") " " ,(datetime->string (prop ev 'LAST-MODIFIED) ;; Last modified datetime - (_ "~1 ~H:~M"))))) + (G_ "~1 ~H:~M"))))) )))) @@ -258,7 +258,7 @@ (let ((date (car day)) (events (cdr day))) `(section (@ (class "text-day")) - (header (h2 ,(let ((s (date->string date (_ "~Y-~m-~d")))) + (header (h2 ,(let ((s (date->string date (G_ "~Y-~m-~d")))) `(a (@ (href "#" ,s) (class "hidelink")) ,s)))) ,@(stream->list @@ -340,7 +340,7 @@ ;; TODO possibly unused? (define (repeat-info event) `(div (@ (class "eventtext")) - (h2 ,(_ "Recurrences")) + (h2 ,(G_ "Recurrences")) (table (@ (class "recur-components")) ,@((@@ (vcomponent recurrence internal) map-fields) (lambda (key value) @@ -412,7 +412,7 @@ (form (@ (class "edit-form")) (select (@ (class "calendar-selection")) ;; NOTE flytta "muffarna" utanför - (option ,(_ "- Choose a Calendar -")) + (option ,(G_ "- Choose a Calendar -")) ,@(let ((dflt ((@ (vcomponent) default-calendar)))) (map (lambda (calendar) (define name (prop calendar 'NAME)) @@ -422,7 +422,7 @@ ,name)) calendars))) (input (@ (type "text") - (placeholder ,(_ "Summary")) + (placeholder ,(G_ "Summary")) (name "summary") (required) (data-property "summary") ; (value ,(prop ev 'SUMMARY)) @@ -440,25 +440,25 @@ (div (@ (class "checkboxes")) (input (@ (type "checkbox") (name "wholeday") - (data-label ,(_ "Whole day?")) + (data-label ,(G_ "Whole day?")) )) (input (@ (type "checkbox") (name "has_repeats") - (data-label ,(_ "Recurring?")) + (data-label ,(G_ "Recurring?")) ))) ) - (input (@ (placeholder ,(_ "Location")) - (data-label ,(_ "Location")) + (input (@ (placeholder ,(G_ "Location")) + (data-label ,(G_ "Location")) (name "location") (type "text") (data-property "location") ; (value ,(or (prop ev 'LOCATION) "")) )) - (textarea (@ (placeholder ,(_ "Description")) - (data-label ,(_ "Description")) + (textarea (@ (placeholder ,(G_ "Description")) + (data-label ,(G_ "Description")) (data-property "description") (name "description")) ; ,(prop ev 'DESCRIPTION) @@ -467,9 +467,9 @@ (input-list (@ (name "categories") (data-property "categories") - (data-label ,(_ "Categories"))) + (data-label ,(G_ "Categories"))) (input (@ (type "text") - (placeholder ,(_ "Category"))))) + (placeholder ,(G_ "Category"))))) ;; TODO This should be a "list" where any field can be edited ;; directly. Major thing holding us back currently is that @@ -518,7 +518,7 @@ ; "20:56" )) (div (@ (class "fields")) - (div (b ,(_ "Location: ")) + (div (b ,(G_ "Location: ")) (div (@ (class "location") (data-property "location")) ; "Alsättersgatan 13" @@ -540,7 +540,7 @@ ;; "varje vecka" ;; ".") (div (@ (class "last-modified")) - ,(_ "Last Modified") " -" + ,(G_ "Last Modified") " -" ; "2021-09-29 19:56" )))))) @@ -548,21 +548,21 @@ `(template (@ (id "vevent-edit-rrule")) (div (@ (class "eventtext")) - (h2 ,(_ "Recurrences")) + (h2 ,(G_ "Recurrences")) (dl - (dt ,(_ "Frequency")) + (dt ,(G_ "Frequency")) (dd (select (@ (name "freq")) (option "-") ,@(map (lambda (x) `(option (@ (value ,x)) ,(string-titlecase (symbol->string x)))) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)))) - (dt ,(_ "Until")) + (dt ,(G_ "Until")) (dd (date-time-input (@ (name "until")))) - (dt ,(_ "Conut")) + (dt ,(G_ "Conut")) (dd (input (@ (type "number") (name "count") (min 0)))) - (dt ,(_ "Interval")) + (dt ,(G_ "Interval")) (dd (input (@ (type "number") (name "interval") ; min and max depend on FREQ ))) @@ -576,14 +576,14 @@ (dd (input-list (@ (name ,name)) (input (@ (type "number") (min ,min) (max ,max))))))) - `((bysecond ,(_ "By Second") 0 60) - (byminute ,(_ "By Minute") 0 59) - (byhour ,(_ "By Hour") 0 23) - (bymonthday ,(_ "By Month Day") -31 31) ; except 0 - (byyearday ,(_ "By Year Day") -366 366) ; except 0 - (byweekno ,(_ "By Week Number") -53 53) ; except 0 - (bymonth ,(_ "By Month") 1 12) - (bysetpos ,(_ "By Set Position") -366 366) ; except 0 + `((bysecond ,(G_ "By Second") 0 60) + (byminute ,(G_ "By Minute") 0 59) + (byhour ,(G_ "By Hour") 0 23) + (bymonthday ,(G_ "By Month Day") -31 31) ; except 0 + (byyearday ,(G_ "By Year Day") -366 366) ; except 0 + (byweekno ,(G_ "By Week Number") -53 53) ; except 0 + (bymonth ,(G_ "By Month") 1 12) + (bysetpos ,(G_ "By Set Position") -366 366) ; except 0 ))) ;; (dt "By Week Day") @@ -594,7 +594,7 @@ ;; ,(week-day-select '()) ;; )) - (dt ,(_ "Weekstart")) + (dt ,(G_ "Weekstart")) (dd ,(week-day-select '((name "wkst"))))))) ) @@ -610,29 +610,29 @@ (nav (@ (class "popup-control")) (button (@ (class "close-button") ;; Close this popup - (title ,(_ "Close")) + (title ,(G_ "Close")) (aria-label "Close")) "×") (button (@ (class "maximize-button") ;; Make this popup occupy the entire screen - (title ,(_ "Fullscreen")) + (title ,(G_ "Fullscreen")) ;; (aria-label "") ) ,(xml-entities "🗖")) (button (@ (class "remove-button") ;; Remove/Trash the event this popup represent ;; Think garbage can - (title ,(_ "Remove"))) + (title ,(G_ "Remove"))) ,(xml-entities "🗑"))) (tab-group (@ (class "window-body")) (vevent-description - (@ (data-label ,(xml-entities "📅")) (data-title ,(_ "Overview")) + (@ (data-label ,(xml-entities "📅")) (data-title ,(G_ "Overview")) (class "vevent"))) (vevent-edit (@ (data-label ,(xml-entities "🖊")) - (data-title ,(_ "Edit")) + (data-title ,(G_ "Edit")) ;; Used by JavaScript to target this tab (data-originaltitle "Edit"))) @@ -641,9 +641,9 @@ (vevent-changelog (@ (data-label ,(xml-entities "📒")) - (data-title ,(_ "Changelog")))) + (data-title ,(G_ "Changelog")))) ,@(when (debug) `((vevent-dl (@ (data-label ,(xml-entities "🐸")) - (data-title ,(_ "Debug")))))))))) + (data-title ,(G_ "Debug")))))))))) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 3d70fb1b..3c7e2546 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -78,10 +78,10 @@ ,display))) (unless next-start - (scm-error 'misc-error "html-generate" (_ "Next-start needs to be a procedure") #f #f)) + (scm-error 'misc-error "html-generate" (G_ "Next-start needs to be a procedure") #f #f)) (unless prev-start - (scm-error 'misc-error "html-generate" (_ "Prev-start needs to be a procedure") #f #f)) + (scm-error 'misc-error "html-generate" (G_ "Prev-start needs to be a procedure") #f #f)) (xhtml-doc (@ (lang sv)) @@ -92,9 +92,9 @@ (meta (@ (name viewport) (content "width=device-width, initial-scale=0.5"))) (meta (@ (name description) - (content ,(format #f (_ "Calendar for the dates between ~a and ~a") - (date->string start-date (_ "~Y-~m-~d")) - (date->string end-date (_ "~Y-~m-~d")))))) + (content ,(format #f (G_ "Calendar for the dates between ~a and ~a") + (date->string start-date (G_ "~Y-~m-~d")) + (date->string end-date (G_ "~Y-~m-~d")))))) ;; NOTE this is only for the time actually part of this calendar. ;; overflowing times from pre-start and post-end is currently ignored here. (meta (@ (name start-time) @@ -119,7 +119,7 @@ window.default_calendar='~a';" ,(include-alt-css "/static/dark.css" '(title "Dark")) ,(include-alt-css "/static/light.css" '(title "Light")) - (script (@ (src "/static/script.out.js"))) + (script (@ (src "/static/script.js"))) (script (@ (src "/static/user/user-additions.js"))) (style ,(lambda () (calendar-styles calendars #t))) @@ -154,11 +154,11 @@ window.default_calendar='~a';" ;; Page footer (footer (@ (style "grid-area: footer")) - (span ,(_ "Page generated ") - ,(date->string (current-date) (_ "~Y-~m-~d"))) - (span ,(_ "Current time ") (current-time (@ (interval 1)))) + (span ,(G_ "Page generated ") + ,(date->string (current-date) (G_ "~Y-~m-~d"))) + (span ,(G_ "Current time ") (current-time (@ (interval 1)))) (span (a (@ (href ,(repo-url))) - ,(_ "Source Code")))) + ,(G_ "Source Code")))) ;; Small calendar and navigation (nav (@ (class "calnav") (style "grid-area: nav")) @@ -169,11 +169,11 @@ window.default_calendar='~a';" start-date) "/week/~1.html") ;; Button to view week - (_ "Week")) + (G_ "Week")) ,(btn href: (date->string (day start-date 1) "/month/~1.html") ;; button to view month - (_ "Month")) + (G_ "Month")) (today-button (a (@ (class "btn") @@ -183,7 +183,7 @@ window.default_calendar='~a';" [(week) "view=week"] [else ""])))) ;; Button to go to today - ,(_ "Today")))) + ,(G_ "Today")))) (date-jump ;; Firefox's accessability complain about each date @@ -203,11 +203,11 @@ window.default_calendar='~a';" ,(btn "➔")))) (details (@ (open) (style "grid-area: cal")) - (summary ,(_ "Month overview")) + (summary ,(G_ "Month overview")) (div (@ (class "smallcall-head")) ,(string-titlecase (date->string start-date ;; Header of small calendar - (_ "~B ~Y")))) + (G_ "~B ~Y")))) ;; NOTE it might be a good idea to put the navigation buttons ;; earlier in the DOM-tree/tag order. At least Vimium's ;; @key{[[} keybind sometimes finds parts of events instead. @@ -233,16 +233,16 @@ window.default_calendar='~a';" (input (@ (type "text") (name "q") ;; Search placeholder - (placeholder ,(_ "Search")))) + (placeholder ,(G_ "Search")))) (input (@ (type "submit") (value ">")))) ,(when (or (debug) (edit-mode)) `(details (@ (class "sliders")) - (summary ,(_ "Option sliders")) + (summary ,(G_ "Option sliders")) ,@(when (edit-mode) - `((label ,(_ "Event blankspace")) + `((label ,(G_ "Event blankspace")) ,(slider-input variable: "editmode" min: 0 @@ -251,7 +251,7 @@ window.default_calendar='~a';" value: 1))) ,@(when (debug) - `((label ,(_ "Fontsize")) + `((label ,(G_ "Fontsize")) ,(slider-input unit: "pt" min: 1 @@ -262,7 +262,7 @@ window.default_calendar='~a';" ;; List of calendars (details (@ (class "calendarlist")) - (summary ,(_ "Calendar list")) + (summary ,(G_ "Calendar list")) (ul ,@(map (lambda (calendar) `(li (@ (data-calendar ,(base64encode (prop calendar 'NAME)))) @@ -288,7 +288,7 @@ window.default_calendar='~a';" ;; Events which started before our start point, ;; but "spill" into our time span. (section (@ (class "text-day")) - (header (h2 ,(_ "Earlier"))) + (header (h2 ,(G_ "Earlier"))) ;; TODO this group gets styles applied incorrectly. ;; Figure out way to merge it with the below call. ,@(stream->list diff --git a/module/calp/html/view/calendar/shared.scm b/module/calp/html/view/calendar/shared.scm index 4779d11b..413bb5f5 100644 --- a/module/calp/html/view/calendar/shared.scm +++ b/module/calp/html/view/calendar/shared.scm @@ -36,7 +36,7 @@ (unless event-length-key (scm-error 'wrong-type-arg "fix-event-widths!" - (_ "event-length-key is required") + (G_ "event-length-key is required") #f #f)) ;; @var{x} is how for left in the container we are. diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index caad8912..44898b0d 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -36,7 +36,7 @@ ;; Top left area (div (@ (class "week-indicator")) (span (@ (style "font-size: 50%")) - ,(_ "v.")) + ,(G_ "v.")) ,@(->> (week-number start-date) number->string string->list (map (lambda (c) `(span ,(string c)))))) @@ -49,7 +49,7 @@ ,@(map (lambda (day-date) `(div (@ (class "meta")) (span (@ (class "daydate")) - ,(date->string day-date (_ "~Y-~m-~d"))) + ,(date->string day-date (G_ "~Y-~m-~d"))) (span (@ (class "dayname")) ;; TODO translation here? ,(string-titlecase (date->string day-date "~a"))))) diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index 114541ed..e400c1ba 100644 --- a/module/calp/html/view/search.scm +++ b/module/calp/html/view/search.scm @@ -26,25 +26,27 @@ errors has-query? search-term search-result page paginator) (xhtml-doc (@ (lang sv)) - (head (title ,(_ "Search results")) + (head (title ,(G_ "Search results")) ,(include-css "/static/style.css")) (body - (a (@ (href ("/today"))) ,(_ "Show today")) - (h2 ,(_ "Search term")) + (a (@ (href ("/today"))) ,(G_ "Show today")) + (h2 ,(G_ "Search term")) + ;; TODO add blurb documenting available variables here, + ;; and link to full documentation page (form (pre (textarea (@ (name "q") (rows 5) (spellcheck false) (style "width:100%")) ,(when has-query? (with-output-to-string (lambda () (pretty-print search-term)))))) - (label (@ (for "onlyfuture")) ,(_ "limit to future occurences")) + (label (@ (for "onlyfuture")) ,(G_ "limit to future occurences")) (input (@ (name "onlyfuture") (id "onlyfuture") (type checkbox))) (input (@ (type submit)))) ,@(if errors - `((h2 ,(_ "Error searching")) + `((h2 ,(G_ "Error searching")) (div (@ (class "error")) (pre ,errors))) - `((h2 ,(format #f (_ "Result (page ~a)") page)) + `((h2 ,(format #f (G_ "Result (page ~a)") page)) (ul ,@(compact-event-list search-result)) (div (@ (class "paginator")) ,@(paginator->list diff --git a/module/calp/load-config.scm b/module/calp/load-config.scm new file mode 100644 index 00000000..5844c1b6 --- /dev/null +++ b/module/calp/load-config.scm @@ -0,0 +1,50 @@ +(cond-expand + (guile-3 + (define-module (calp load-config) + :declarative? #f)) + (else + (define-module (calp load-config) + ))) + +(use-modules (srfi srfi-1) + (calp translation) + (hnh util path) + ((xdg basedir) :prefix xdg-)) + +(export load-config find-config-file) + +(define (load-config config-file) + ;; Load config + ;; Sandbox and "stuff" not for security from the user. The config script is + ;; assumed to be "safe". Instead it's so we can control the environment in + ;; which it is executed. + (catch #t + (lambda () (load config-file)) + (lambda args + (format (current-error-port) + ;; Two arguments: + ;; Configuration file path, + ;; thrown error arguments + (G_ "Failed loading config file ~a~%~s~%") + config-file + args + )))) + + +(define (find-config-file altconfig) + (cond [altconfig + (if (file-exists? altconfig) + altconfig + (scm-error 'misc-error + "wrapped-main" + (G_ "Configuration file ~a missing") + (list altconfig) + #f))] + ;; altconfig could be placed in the list below. But I want to raise an error + ;; if an explicitly given config is missing. + [(find file-exists? + (list + (path-append (xdg-config-home) "calp" "config.scm") + (path-append (xdg-sysconfdir) "calp" "config.scm"))) + => identity]) + ) diff --git a/module/calp/main.scm b/module/calp/main.scm index 827dbf4e..90e7e115 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -1,10 +1,10 @@ ;; -*- geiser-scheme-implementation: guile -*- (define-module (calp main) - :use-module (hnh util) + :use-module ((hnh util) :select (awhen)) :use-module ((hnh util path) :select (path-append)) :use-module (srfi srfi-1) - :use-module (srfi srfi-88) ; keyword syntax + :use-module ((srfi srfi-88) :select ()) ; keyword syntax :use-module (hnh util options) :use-module ((calp util hooks) :select (shutdown-hook)) @@ -16,10 +16,6 @@ :use-module ((calp util exceptions) :select ()) :use-module (ice-9 getopt-long) - :use-module (ice-9 regex) - :use-module ((ice-9 popen) :select (open-input-pipe)) - :use-module ((ice-9 sandbox) :select - (make-sandbox-module all-pure-and-impure-bindings)) :use-module (statprof) :use-module (calp repl) @@ -28,18 +24,22 @@ :use-module ((xdg basedir) :prefix xdg-) :use-module (calp translation) + :use-module ((calp load-config) :select (load-config find-config-file)) :export (main) ) + + + (define options `((statprof (value display-style) - (description ,(xml->sxml (_ "<group>Run the program within Guile's built in statical + (description ,(xml->sxml (G_ "<group>Run the program within Guile's built in statical profiler. Display style is one of <b>flat</b> or <b>tree</b>.</group>")))) (repl (value address) (description - ,(xml->sxml (_ "<group>Start a Guile repl which can be connected to, defaults to the + ,(xml->sxml (G_ "<group>Start a Guile repl which can be connected to, defaults to the unix socket <i>/run/user/${UID}/calp-${PID}</i>, but it can be bound to any unix or TCP socket. ((@ (vcomponent util instance) global-event-object)) should contain all events. @@ -48,22 +48,22 @@ contain all events. (config (value #t) (description - ,(_ "Path to alterantive configuration file to load instead of the default one."))) + ,(G_ "Path to alterantive configuration file to load instead of the default one."))) (debug (single-char #\d) (description - ,(_ "Turns on debug mode for HTML output"))) + ,(G_ "Turns on debug mode for HTML output"))) (edit-mode (description - ,(_ "Makes generated HTML user editable (through JS)"))) + ,(G_ "Makes generated HTML user editable (through JS)"))) (version (single-char #\v) - (description ,(format #f (_ "Display version, which is ~a btw.") + (description ,(format #f (G_ "Display version, which is ~a btw.") (@ (calp) version)))) (help (single-char #\h) - (description ,(_ "Print this help"))) + (description ,(G_ "Print this help"))) )) @@ -73,30 +73,30 @@ contain all events. "<group><br/> <center><b>" "Calp" "</b></center> <br/><br/> -" (_ "Usage: <b>calp</b> [ <i>flags</i> ] <i>mode</i> [ <i>mode flags</i> ]") "<br/> +" (G_ "Usage: <b>calp</b> [ <i>flags</i> ] <i>mode</i> [ <i>mode flags</i> ]") "<br/> <hr/>" ;; Header for following list of modes of operation - "<center><b>" (_ "Modes") "</b></center> + "<center><b>" (G_ "Modes") "</b></center> <br/><br/>" - (_ "<p><b>html</b> reads calendar files from disk, and writes them to static HTML files.</p>") - (_ "<p><b>terminal</b> loads the calendars, and starts an interactive terminal interface.</p>") - (_ "[UNTESTED]<br/><p><b>import</b>s a calendar object into the database.</p>") - (_ "<p><b>text</b> formats and justifies what it's given on standard input, + (G_ "<p><b>html</b> reads calendar files from disk, and writes them to static HTML files.</p>") + (G_ "<p><b>terminal</b> loads the calendars, and starts an interactive terminal interface.</p>") + (G_ "[UNTESTED]<br/><p><b>import</b>s a calendar object into the database.</p>") + (G_ "<p><b>text</b> formats and justifies what it's given on standard input, and writes it to standard output. Similar to this text.</p>") - (_ "<p><b>ical</b> loads the calendar database, and immediately + (G_ "<p><b>ical</b> loads the calendar database, and immediately re-serializes it back into iCAL format. Useful for merging calendars.</p>") - (_ "<p><b>benchmark</b> <i>module</i><br/>Runs the procedure 'run-benchmark' + (G_ "<p><b>benchmark</b> <i>module</i><br/>Runs the procedure 'run-benchmark' from the module (calp benchmark <i>module</i>).</p>") - (_ "<p><b>server</b> starts an HTTP server which dynamically loads and + (G_ "<p><b>server</b> starts an HTTP server which dynamically loads and displays events. The <i>/month/{date}.html</i> & <i>/week/{date}.html</i> runs the same output code as <b>html</b>. While the <i>/calendar/{uid}.ics</i> uses the same code as <b>ical</b>.</p>") - (_ "<p><b>update-zoneinfo</b> in theory downloads and updates our local + (G_ "<p><b>update-zoneinfo</b> in theory downloads and updates our local zoneinfo database, but is currently broken.</p>") "<hr/><br/>" ;; Header for list of available flags. ;; Actual list is auto generated elsewhere. - "<center><b>" (_ "Flags") "</b></center> + "<center><b>" (G_ "Flags") "</b></center> <br/></group>"))) (define (ornull a b) @@ -109,42 +109,11 @@ zoneinfo database, but is currently broken.</p>") (define repl (option-ref opts 'repl #f)) (define altconfig (option-ref opts 'config #f)) - (define config-file - (cond [altconfig - (if (file-exists? altconfig) - altconfig - (scm-error 'misc-error - "wrapped-main" - (_ "Configuration file ~a missing") - (list altconfig) - #f))] - ;; altconfig could be placed in the list below. But I want to raise an error - ;; if an explicitly given config is missing. - [(find file-exists? - (list - (path-append (xdg-config-home) "calp" "config.scm") - (path-append (xdg-sysconfdir) "calp" "config.scm"))) - => identity])) + (define config-file (find-config-file altconfig)) (when stprof (statprof-start)) - - - ;; Load config - ;; Sandbox and "stuff" not for security from the user. The config script is - ;; assumed to be "safe". Instead it's so we can control the environment in - ;; which it is executed. - (catch #t - (lambda () (load config-file)) - (lambda args - (format (current-error-port) - ;; Two arguments: - ;; Configuration file path, - ;; thrown error arguments - (_ "Failed loading config file ~a~%~s~%") - config-file - args - ))) + (load-config config-file) (awhen (option-ref opts 'edit-mode #f) ((@ (calp html config) edit-mode) #t)) @@ -162,7 +131,7 @@ zoneinfo database, but is currently broken.</p>") (throw 'return)) (when (option-ref opts 'version #f) - (format #t (_ "Calp version ~a~%") (@ (calp) version)) + (format #t (G_ "Calp version ~a~%") (@ (calp) version)) (throw 'return)) ;; always load zoneinfo if available. @@ -194,7 +163,7 @@ zoneinfo database, but is currently broken.</p>") ((update-zoneinfo) (@ (calp entry-points update-zoneinfo) main)) (else => (lambda (s) (format (current-error-port) - (_ "Unsupported mode of operation: ~a~%") + (G_ "Unsupported mode of operation: ~a~%") s) (exit 1)))) ropt)) @@ -209,7 +178,7 @@ zoneinfo database, but is currently broken.</p>") (define (main args) - ((@ (calp util time) report-time!) (_ "Program start")) + ((@ (calp util time) report-time!) (G_ "Program start")) (with-throw-handler #t (lambda () (dynamic-wind (lambda () 'noop) diff --git a/module/calp/namespaces.scm b/module/calp/namespaces.scm new file mode 100644 index 00000000..09a642da --- /dev/null +++ b/module/calp/namespaces.scm @@ -0,0 +1,14 @@ +(define-module (calp namespaces)) + +;;; Commentary: +;;; (XML) Namespaces used by different parts of the program. +;;; Code: + +(define-public webdav (string->symbol "DAV:")) +(define-public caldav (string->symbol "urn:ietf:params:xml:ns:caldav")) +(define-public xcal (string->symbol "urn:ietf:params:xml:ns:icalendar-2.0")) + +(define-public namespaces + `((d . ,webdav) + (c . ,caldav) + (x . ,xcal))) diff --git a/module/calp/repl.scm b/module/calp/repl.scm index 7beee560..327ee206 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -4,7 +4,10 @@ (define-module (calp repl) :use-module (system repl server) + :use-module ((system repl common) :select (repl-default-option-set!)) + :use-module ((ice-9 pretty-print) :select (truncated-print)) :use-module (ice-9 regex) + :use-module (ice-9 format) :use-module ((calp util hooks) :select (shutdown-hook)) :use-module ((hnh util exceptions) :select (warning)) :use-module (calp translation) @@ -14,7 +17,7 @@ (define (repl-start address) (define lst (string->list address)) (format (current-error-port) - (_ "Starting REPL server at ~a~%") address) + (G_ "Starting REPL server at ~a~%") address) (spawn-server (case (cond [(memv (car lst) '(#\. #\/)) 'UNIX] [(string-match "(\\d{1,3}\\.){3}\\d{1,3}(:\\d+)?" address) 'IPv4] @@ -24,19 +27,24 @@ [(UNIX) (add-hook! shutdown-hook (lambda () (catch 'system-error (lambda () (delete-file address)) (lambda (err proc fmt args data) - (warning (string-append (format #f (_ "Failed to unlink ~a") address) + (warning (string-append (format #f (G_ "Failed to unlink ~a") address) (format #f ": ~?" fmt args))) err)))) (make-unix-domain-server-socket path: address)] [(IPv4) (apply (case-lambda - [() (error (_ "Empty address?"))] + [() (error (G_ "Empty address?"))] [(address) (make-tcp-server-socket host: address)] [(address port) (make-tcp-server-socket host: address port: port)]) (string-split address #\:))] ;; currently impossible - [(IPv6) (error (_ "How did you get here?"))])) + [(IPv6) (error (G_ "How did you get here?"))])) - ;; TODO setup repl environment here + (repl-default-option-set! + 'print + (lambda (repl obj) + (truncated-print obj) + (newline))) + ;; TODO setup repl environment here ) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 44fac7e8..3383f7a6 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -61,18 +61,18 @@ `(table (@ (class "directory-table")) (thead (tr (th "") - (th ,(_ "Name")) + (th ,(G_ "Name")) ;; File permissions, should be about as long as three digits - (th ,(_ "Perm")) + (th ,(G_ "Perm")) ;; File size - (th ,(_ "Size")))) + (th ,(G_ "Size")))) (tbody (tr (td "↩️") (td (@ (colspan 3)) (a (@ (href ,(-> (path-split dir) (drop-right 1) (xcons "/static") path-join))) - ,(_ "Return up")))) + ,(G_ "Return up")))) ,@(map (lambda (k) (let ((stat (lstat (path-append prefix dir k)))) `(tr (td ,(case (stat:type stat) @@ -95,7 +95,7 @@ (scm-error 'misc-error "directory-table" - (_ "Scandir argument invalid or not directory: ~s") + (G_ "Scandir argument invalid or not directory: ~s") (list dir) '()))))))) @@ -118,13 +118,12 @@ (define-config static-dir "static" - description: (_ "Where static files for the web server are located")) + description: (G_ "Where static files for the web server are located")) (define ical-namespace '(IC . "urn:ietf:params:xml:ns:icalendar-2.0")) -(define root-script "window.onload = () => document.getElementsByTagName('a')[0].click()") ;; TODO ensure encoding on all fields which take user provided data. ;; Possibly a fallback which strips everything unknown, and treats @@ -132,22 +131,28 @@ (define (make-make-routes) (make-routes - ;; Manual redirect to not reserve root. - ;; Also reason for really ugly frontend redirect. (GET "/" (html) - (return `((content-type ,(content-type html))) - (with-output-to-string - (lambda () - ((sxml->output html) - (xhtml-doc - (body (a (@ (href "/today")) ,(_ "Go to Today")) - (script ,(lambda () (display root-script)))))))))) + (return (build-response code: 307 + headers: `((Location . "/today/") + (content-type tex/plain))) + (G_ "Redirecting to today, might take some time if server was just restarted."))) (GET "/favicon.ico" () (return `((content-type image/svg+xml)) (call-with-input-file "static/calendar.svg" read-string))) + (GET "/everything.ics" (start end) + (let ((start (or start (date- (current-date) (date day: 14)))) + (end (or end (date+ (current-date) (date year: 1))))) + (let ((events (append + (fixed-events-in-range global-event-object start end) + (get-repeating-events global-event-object)))) + (format (current-error-port) "Collected ~a events~%" (length events)) + (return '((content-type text/calendar)) + (with-output-to-string + (lambda () (print-components-with-fake-parent events))))))) + ;; TODO any exception in this causes the whole page to fail ;; It would be much better if most of the page could still make it. (GET "/week/:start-date.html" (start-date html) @@ -163,8 +168,7 @@ next-start: (lambda (d) (date+ d (date day: 7))) prev-start: (lambda (d) (date- d (date day: 7))) render-calendar: (@ (calp html view calendar week) render-calendar) - intervaltype: 'week - ))))))) + intervaltype: 'week))))))) (GET "/month/:start-date.html" (start-date html) (let ((start-date (start-of-month (parse-iso-date start-date)))) @@ -189,7 +193,7 @@ (POST "/remove" (uid) (unless uid (return (build-response code: 400) - (_ "uid required"))) + (G_ "uid required"))) (aif (get-event-by-uid global-event-object uid) (begin @@ -201,10 +205,10 @@ (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") (unless ((@ (vcomponent formats vdir save-delete) save-event) it) (return (build-response code: 500) - (_ "Saving event to disk failed."))) + (G_ "Saving event to disk failed."))) (return (build-response code: 204))) (return (build-response code: 400) - (format #f (_ "No event with UID '~a'") uid)))) + (format #f (G_ "No event with UID '~a'") uid)))) ;; TODO this fails when dtstart is <date>. ;; @var{cal} should be the name of the calendar encoded in base64. @@ -212,7 +216,7 @@ (unless (and cal data) (return (build-response code: 400) - (string-append (_ "Both 'cal' and 'data' required") "\r\n"))) + (string-append (G_ "Both 'cal' and 'data' required") "\r\n"))) ;; NOTE that this leaks which calendar exists, ;; but you can only query for existance. @@ -223,7 +227,7 @@ (unless calendar (return (build-response code: 400) - (format #f "~@?\r\n" (_ "No calendar with name [~a]") + (format #f "~@?\r\n" (G_ "No calendar with name [~a]") calendar-name))) ;; Expected form of data (but in XML) is: @@ -254,12 +258,12 @@ (lambda (err port . args) (return (build-response code: 400) (format #f "~a ~{~a~}\r\n" - (_ "XML parse error") + (G_ "XML parse error") args))))))) (unless (eq? 'VEVENT (type event)) (return (build-response code: 400) - (string-append (_ "Object not a VEVENT") "\r\n"))) + (string-append (G_ "Object not a VEVENT") "\r\n"))) ;; NOTE add-event uses the given UID if one is given, ;; but generates its own if not. It might be a good idea @@ -272,6 +276,10 @@ (catch* (lambda () (add-and-save-event global-event-object calendar event)) + ((pre-unwind #t) + (lambda _ + (let ((stack (make-stack #t))) + (display-backtrace stack (current-error-port))))) (warning (lambda (err fmt args) (define str (format #f "~?" fmt args)) @@ -286,11 +294,11 @@ str))))) (return '((content-type application/xml)) - (with-output-to-string - (lambda () - (sxml->xml - `(properties - (uid (text ,(prop event 'UID))))))))))) + (lambda (port) + (sxml->xml + `(properties + (uid (text ,(prop event 'UID)))) + port)))))) ;; Get specific page by query string instead of by path. ;; Useful for <form>'s, since they always submit in this form, but also @@ -324,18 +332,18 @@ (GET "/calendar/:uid{.*}.xcs" (uid) (aif (get-event-by-uid global-event-object uid) (return '((content-type application/calendar+xml)) - ;; TODO sxml->xml takes a port, would be better - ;; to give it the return port imidiately. - (with-output-to-string - ;; TODO this is just the vevent part. - ;; A surounding vcalendar is required, as well as - ;; a doctype. - ;; Look into changing how events carry around their - ;; parent information, possibly splitting "source parent" - ;; and "program parent" into different fields. - (lambda () (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) it))))) + ;; TODO this is just the vevent part. + ;; A surounding vcalendar is required, as well as + ;; a doctype. + ;; Look into changing how events carry around their + ;; parent information, possibly splitting "source parent" + ;; and "program parent" into different fields. + (lambda (port) + (sxml->xml + ((@ (vcomponent formats xcal output) vcomponent->sxcal) it) + port))) (return (build-response code: 404) - (format #f (_ "No component with UID=~a found.") uid)))) + (format #f (G_ "No component with UID=~a found.") uid)))) (GET "/calendar/:uid{.*}.ics" (uid) (aif (get-event-by-uid global-event-object uid) @@ -344,7 +352,8 @@ (lambda () (print-components-with-fake-parent (list it))))) (return (build-response code: 404) - (format #f (_ "No component with UID=~a found.") uid)))) + (format #f (G_ "No component with UID=~a found.") uid)))) + (GET "/search/text" (q) (return (build-response @@ -404,14 +413,14 @@ (set! error (format #f "~?~%" fmt arg)))))) - (return `((content-type (content-type html))) - (with-output-to-string - (lambda () - ((sxml->output html) - (search-result-page - error - (and=> q (negate string-null?)) - search-term search-result page paginator)))))) + (return `((content-type ,(content-type html))) + (lambda (port) + ((sxml->output html) + (search-result-page + error + (and=> q (negate string-null?)) + search-term search-result page paginator) + port)))) ;; NOTE this only handles files with extensions. Limited, but since this ;; is mostly for development, and something like nginx should be used in @@ -449,7 +458,7 @@ (lambda () ((sxml->output html) (xhtml-doc - (head (title ,(_ "Calp directory listing for ") path) + (head (title ,(G_ "Calp directory listing for ") path) ,(include-css "/static/directory-listing.css")) (body ,(directory-table (static-dir) path)))))))) diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index 814aaed7..4c5a0886 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -3,28 +3,21 @@ :use-module (web server) :use-module ((calp server routes) :select (make-make-routes)) :use-module (ice-9 threads) + :use-module (srfi srfi-88) + :use-module (calp server socket) :export (start-server)) -;; NOTE The default make-default-socket is broken for IPv6. -;; A patch has been submitted to the mailing list. 2020-03-31 -(module-set! - (resolve-module '(web server http)) - 'make-default-socket - (lambda (family addr port) - (let ((sock (socket family SOCK_STREAM 0))) - (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) - (bind sock family addr port) - sock))) - +;;; TODO Do I really want this hardcoded here? (define handler (make-make-routes)) -;; (define impl (lookup-server-impl 'http)) -;; (define server (open-server impl open-params)) - (define (start-server open-params) - (run-server handler 'http open-params 1) + (run-server handler + 'http + (append open-params + `(socket: ,(apply setup-socket open-params))) + 1) ;; NOTE at first this seems to work, but it quickly deteriorates. ;; (for i in (iota 16) ;; (begin-thread diff --git a/module/calp/server/socket.scm b/module/calp/server/socket.scm new file mode 100644 index 00000000..990adfa6 --- /dev/null +++ b/module/calp/server/socket.scm @@ -0,0 +1,48 @@ +(define-module (calp server socket) + :use-module (srfi srfi-88) + :use-module (web server) + :export (setup-socket + run-at-any-port) + ) + +;; NOTE The default make-default-socket is broken for IPv6. +;; A patch has been submitted to the mailing list. 2020-03-31 +;; +;; This sets up the socket manually, and sends that to @code{http-open}. +(define* (make-default-socket/fixed family addr port) + (let ((sock (socket family SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock family addr port) + sock)) + +(define* (setup-socket key: + (host #f) + (family AF_INET) + (addr (if host (inet-pton family host) + INADDR_LOOPBACK)) + (port 8080)) + (make-default-socket/fixed family addr port)) + + +(define* (run-at-any-port handler key: + (min-port 8081) + msg-port) + (unless msg-port + (scm-error 'misc-error "run-at-any-port" + "msg-port required" + '() #f)) + (let loop ((port min-port)) + (catch 'system-error + (lambda () + (let ((socket (setup-socket port: port))) + (let ((addr (format #f "http://localhost:~a~%" port))) + (display addr msg-port) + (force-output msg-port) + (format #t "Server started at ~s~%" addr) + (run-server handler 'http + `(socket: ,socket)) + (format #t "Server closed~%")))) + (lambda (err proc fmt args data) + (if (= EADDRINUSE (car data)) + (loop (1+ port)) + (apply throw err proc fmt args data)))))) diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm new file mode 100644 index 00000000..f26b97f6 --- /dev/null +++ b/module/calp/server/webdav.scm @@ -0,0 +1,767 @@ +(define-module (calp server webdav) + :use-module ((hnh util) :select (for group -> ->> init+last catch*)) + :use-module (ice-9 match) + :use-module (ice-9 regex) + :use-module (ice-9 format) + :use-module (ice-9 control) + :use-module (web request) + :use-module (web response) + :use-module (web uri) + :use-module (web server) + :use-module ((web http) :select (declare-method! + declare-header!)) + :use-module (web http status-codes) + :use-module (datetime) + :use-module (sxml match) + :use-module (sxml namespaced) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module (calp namespaces) + :use-module (calp webdav resource) + :use-module (calp webdav resource virtual) + :use-module (calp webdav resource file) + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module (calp webdav proppatch) + :use-module (oop goops) + :export (; run-run + run-propfind + run-proppatch + run-options + run-get + run-put + run-delete + run-mkcol + run-copy + run-move + run-report + + root-resource + webdav-handler + )) + +;; (define* (my-build-response . kvs) +;; (define dt (datetime->string (current-datetime) "~a, ~d ~b ~Y ~H:~M:~S GMT")) +;; (define server (format #f "calp/~a" (@ (calp) version))) +;; (let ((as (kvlist->assq kvs))) +;; (append kvs +;; (list +;; reason-phrase: (http-status-phrase (assq-ref as code:)) +;; headers: (append (or (assq-ref kvs headers:) '()) +;; (list +;; server: server +;; date: dt +;; connection: 'keep-alive)))))) + +(define (swap p) + (xcons (car p) (cdr p))) + + +(define output-namespaces + (map (lambda (pair) (call-with-values (lambda () (car+cdr pair)) + xcons)) + namespaces)) + +;; (define (run-filter context filter-spec) +;; (sxml-match filter-spec +;; [(c:comp-filter (@ (name ,name)) . ,rest) +;; ;; TODO +;; (filter (lambda (child) (string=? name (type child))) +;; (children context))] +;; [(c:prop-filter (@ (name ,name))) +;; (prop context name) +;; ] +;; [(c:prop-filter (@ (name ,name)) . ,rest) +;; ] +;; [(c:param-filter (@ (name ,name)) . ,rest)] +;; [(c:is-not-defined)] +;; [(c:text-match (@ . ,attrs) . ,data)] +;; [(c:time-range (@ . ,attrs))])) + + + +;; Requests can content-type be both both application/xml and text/xml, server MUST accept both (RFC 4918 8.2) + +;; ;; RFC 4918 8.2 +;; (catch 'parser-error +;; (lambda () (xml->sxml body)) +;; (lambda (err input-port . msg) +;; (define err-msg +;; (with-output-to-string +;; (lambda () (for-each display msg)))) +;; (return (build-response code: 400 +;; headers: ((content-type . (text/plain)))) +;; err-msg))) + +;; ;; If a body is sent by the client when not expected, the server MUST repspond +;; ;; with 415 (RFC 4918 8.4) + +;; PROPPATCH +;; SHOULD support setting of arbitrary dead properties (RFC4918 9.2) +;; Fruux supports this +;; NOTE this means that user quotas must include dead properties + + +;; A caldav server MUST support +;; - RFC4918 (WebDAV) Class 1 +;; - RFC3744 WebDAV ACL including additional privilege defined in 6.1 +;; - HTTPS +;; - ETags from RFC2616 (http) + +;; MKCALENDAR NOT required + + + + +;; getcontentlanguage, "dead" property + +(declare-method! "PROPFIND" 'PROPFIND) +(declare-method! "PROPPATCH" 'PROPPATCH) +(declare-method! "MKCOL" 'MKCOL) +(declare-method! "COPY" 'COPY) +(declare-method! "MOVE" 'MOVE) +(declare-method! "LOCK" 'LOCK) +(declare-method! "UNLOCK" 'UNLOCK) +(declare-method! "REPORT" 'REPORT) + + + +(define (root-element sxml) + (sxml-match sxml + [(*TOP* (*PI* . ,args) ,root) root] + [(*TOP* ,root) root] + [,root root])) + +(define (root-element/namespaced sxml) + (cond ((not (list? sxml)) (scm-error 'misc-error "root-element/namespaced" + "Argument is invalid sxml: ~s" + (list sxml) #f)) + ((null? (car sxml)) (scm-error 'misc-error "root-element/namespaced" + "No root in an empty list" + '() #f)) + ((eq? '*TOP* (car sxml)) + (let ((children (cdr sxml))) + (cond ((null? children) #f) + ((pi-element? (car children)) + (cadr children)) + (else (car children))))) + (else sxml))) + + +(define root-resource (make-parameter #f)) + + + +(define (parse-dav-line str) + (map (lambda (item) + (cond ((string-match "^[0-9]+$" item) + => (lambda (m) (number->string (match:substring m)))) + ((string-match "^<(.*)>$" item) + => (lambda (m) (string->uri (match:substring m 1)))) + (else (string->symbol item)))) + (map string-trim-both (string-split str #\,)))) + +(define (validate-dav-line lst) + (every (lambda (item) + (or (and (number? item) (<= 1 item 3)) + (uri? item) + ;; Possibly check against list of valid tokens + (symbol? item))) + lst)) + +(define (write-dav-line lst port) + (display + (string-join (map (lambda (item) + (cond ((number? item) (number->string item)) + ((uri? item) (string-append "<" (uri->string item) ">")) + (else (symbol->string item)))) + lst) + ", " 'infix) + port)) + +(declare-header! "DAV" + parse-dav-line + validate-dav-line + write-dav-line) + +(declare-header! "Depth" + (lambda (str) + (if (string-ci=? str "Infinity") + 'infinity + (string->number str))) + (lambda (value) + (memv value '(0 1 infinity))) + (lambda (value port) + (display value port))) + +(declare-header! "Destination" + string->uri + uri? + (lambda (uri port) + (display (uri->string uri) port))) + +;;; TODO +;; (declare-header! "If") + +;;; TODO +;; (declare-header! "Lock-Token") + +(declare-header! "Overwrite" + (lambda (str) + ;; TODO assert isn't a thing + ;; (assert (= 1 (string-length str))) + (case (string-ref str 0) + ((#\F) #f) + ((#\T) #t) + (else (throw 'error)))) + boolean? + (lambda (b port) + (display (if b "T" "F") + port))) + +;;; TODO +;; (declare-header! "Timeout") + + + +(define (run-propfind href request body) + (define headers (request-headers request)) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + (define requested-resources + (case (or (assoc-ref headers 'depth) 'infinity) + ((0) (list (cons href resource))) + ((1) (cons (cons href resource) + (map (lambda (child) + (cons (append href (list (name child))) + child)) + (children resource)))) + ((infinity) (all-resources-under resource href)))) + + ;; Body, if it exists, MUST have be a DAV::propfind object + (define property-request + (cond ((string? body) + (xml->namespaced-sxml body)) + ((bytevector? body) + (-> body + (bytevector->string + (make-transcoder (utf-8-codec))) + xml->namespaced-sxml)) + (else `(,(xml webdav 'propfind) + (,(xml webdav 'allprop)))))) + + + (catch 'bad-request + (lambda () + (values (build-response + code: 207 + reason-phrase: (http-status-phrase 207) + headers: '((content-type . (application/xml)))) + (lambda (port) + (namespaced-sxml->xml + `(,(xml webdav 'multistatus) + ,@(for (href . resource) in requested-resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (parse-propfind (root-element/namespaced property-request) + resource))))) + namespaces: output-namespaces + port: port) + (newline port)))) + (lambda (err proc fmt args data) + (values (build-response + code: 400 + headers: '((content-type . (text/plain)))) + (lambda (port) + (apply format port fmt args))))))) + (else (values (build-response code: 404) "")))) + + + +(define (run-proppatch href request body) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + ;; Body MUST exist, and be a DAV::propertyupdate element + (catch 'bad-request + (lambda () + (values (build-response + code: 207 + reason-phrase: (http-status-phrase 207) + headers: '((content-type . (application/xml)))) + (lambda (port) + (define-values (request namespaces*) + (cond ((string? body) + (-> body + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces + (map swap namespaces)))) + ((bytevector? body) + (-> body + (bytevector->string (make-transcoder (utf-8-codec))) + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces + (map swap namespaces)))) + (else (throw 'body-required)))) + + (namespaced-sxml->xml + `(,(xml webdav 'multistatus) + (,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (parse-propertyupdate + (root-element request) + (map swap namespaces*) + resource)))) + port: port)))) + (lambda (err proc fmt args data) + (values (build-response + code: 400 + headers: '((content-type . (text/plain)))) + (lambda (port) + (apply format port fmt args))))))) + (else (values (build-response code: 404) "")))) + + +(define (run-options href request) + (values + (build-response code: 200 + headers: `((dav . (1)) + ;; (DAV . "calendar-access") + ;; TODO collecting this set dynamically would be fancy! + (allow . (GET HEAD PUT + MKCOL PROPFIND OPTIONS + DELETE + COPY + MOVE + ;; LOCK + ;; UNLOCK + ;; REPORT + )))) + "")) + +(define (run-get href request mode) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + ;; "/calendar/:user/:calendar/:filename" + ;; headers: `((content-type ,content-type)) + (values (build-response code: 200) + (case mode + ((HEAD) "") + ((GET) (content resource)) + (else (scm-error 'misc-error "run-get" + "Unknown mode: ~s" + (list mode) #f)))))) + (else (values (build-response code: 404) "")))) + +(define (run-put href request request-body) + (cond ((null? href) + (values (build-response code: 405 headers: '((content-type . (text/plain)))) + "Can't PUT on root resource")) + ((lookup-resource (root-resource) (drop-right href 1)) + => (lambda (parent) + (cond ((lookup-resource parent (list (last href))) + => (lambda (child) + (if (is-collection? child) + (values (build-response code: 405) "") + (begin + (set-content! child request-body) + (values (build-response code: 204) ""))))) + (else + (add-resource! parent (last href) + request-body) + (values (build-response code: 201) ""))))) + ;; No parent collection, fail per [WEBDAV] 9.7.1. + (else (values (build-response code: 409))))) + +(define (run-mkcol href request _) + ;; TODO href="/" + (if (assoc-ref (request-headers request) 'content-type) + (values (build-response code: 415) + "") + (let ((path name (init+last href))) + (cond ((lookup-resource (root-resource) path) + => (lambda (parent) + (catch 'resource-exists + (lambda () + (add-collection! parent name) + (values (build-response code: 201) "")) + (lambda _ (values (build-response code: 405) ""))))) + (else + (values (build-response code: 409) "")))))) + + + +;;; TODO completely rewrite error handling here +;;; TODO what happens on copy between sub-trees of different types? +;;; Like from a <calendar-resource> tree to a <file-tree>. +(define (run-copy source-href request) + (define headers (request-headers request)) + (call/ec + (lambda (return) + (let* ((depth (or (assoc-ref headers 'depth) 'infinity)) + (destination-uri (assoc-ref headers 'destination)) + (dest-href (-> headers (assoc-ref 'destination) + uri-path string->href)) + (overwrite? + (cond ((assoc 'overwrite headers) => cdr) + (else #t)))) + + ;; (assert (memv depth '(0 infinity))) + ;; (unless (string=? (listen-uri) (uri-host destination-uri)) + ;; (throw 'cross-domain-copy-not-supported)) + + (let ((dest-path dest-name (init+last dest-href))) + (let ((source-resource + (cond ((lookup-resource (root-resource) source-href) => identity) + (else (return (build-response code: 404) "")))) + (destination-parent-resource + (cond ((lookup-resource (root-resource) dest-path) => identity) + (else (return (build-response + code: 409 + reason-phrase: (http-status-phrase 409) + headers: '((content-type . (text/plain)))) + "One or more parent components of destination are missing"))))) + + (case (copy-to-location! source-resource destination-parent-resource + new-name: dest-name + include-children?: (case depth + ((0) #f) + ((infinity) #t) + (else (throw 'invalid-requeqst))) + overwrite?: overwrite?) + ((created) + (values (build-response code: 201) "")) + ((replaced) + (values (build-response code: 204) "")) + ((collision) + (values (build-response code: 412) ""))))))))) + + +(define (run-delete href request) + ;; TODO href="/" + (let ((path name (init+last href))) + (cond ((lookup-resource (root-resource) path) + => (lambda (parent) + (cond ((lookup-resource parent (list name)) + => (lambda (child) + (delete-child! parent child) + (values (build-response code: 202) + ""))) + (else + (values (build-response code: 404) ""))))) + (else + (values (build-response code: 404) ""))))) + + +(define (run-move href request) + ;; TODO href="/" + (define headers (request-headers request)) + (call/ec + (lambda (return) + (define-values (path name) (init+last href)) + (define parent (or (lookup-resource (root-resource) path) + (return (build-response code: 404) + "Source Parent not found"))) + (define child (or (lookup-resource parent (list name)) + (return (build-response code: 404) + "Source not found"))) + (define-values (dest-path dest-name) + (-> headers (assoc-ref 'destination) + uri-path string->href init+last)) + (define dest-parent (or (lookup-resource (root-resource) dest-path) + (return (build-response code: 404) + "Dest Parent not found"))) + (define overwrite? (cond ((assoc 'overwrite headers) => cdr) + (else #t))) + (define status (move-to-location! parent child + dest-parent + new-name: dest-name + overwrite?: overwrite?)) + + (case status + ((created) + (values (build-response code: 201) "")) + ((replaced) + (values (build-response code: 204) "")) + ((collision) + (values (build-response code: 412) "")))))) + + + +;; (define (run-report href request request-body)) + + + +(define log-table (make-parameter #f)) +(define (init-log-table!) (log-table '())) +(define (log-table-add! . args) + (for (key value) in (group args 2) + (log-table (acons key value (log-table))))) +(define* (log-table-get key optional: dflt) + (or (assoc-ref (log-table) key) + dflt)) + +(define (log-table-format . args) + (for-each (lambda (arg) + (cond ((string? arg) (display arg)) + ((symbol? arg) (cond ((log-table-get arg) + => display))) + ((pair? arg) (cond ((log-table-get (car arg)) + => (compose display (cdr arg))))) + (else #f))) + args)) + +(define (emit-log!) + ;; (write (log-table) (current-error-port)) + ;; (newline (current-error-port)) + (display + (with-output-to-string + (lambda () + (log-table-format (cons 'now (lambda (n) (datetime->string n "~H:~M:~S"))) + " " 'method " " + (cons 'uri uri->string) + " ") + (case (request-method (log-table-get 'request)) + ((COPY MOVE) (log-table-format + (cons 'headers (lambda (h) (and=> (assoc-ref h 'destination) uri->string))) + " ")) + (else "")) + ;; Nginx uses + ;; <ip> - - [<date>] "<request-line>" <request-status> <content-length> "<referer-url>" "<user-agent>" + (log-table-format 'response-code " " + 'response-phrase + " " + (cons 'headers (lambda (h) (assoc-ref h 'x-litmus))) + "\n") + + (cond ((log-table-get 'msg) + => (lambda (it) + (display it) + (newline)))))) + + (current-error-port)) + ) + + + + +;; For all headers: +;; `((server ,(format #f "calp/~a" (@ (calp) version))) +;; (date ,(datetime->string (current-datetime) +;; "~a, ~d ~b ~Y ~H:~M:~S GMT")) +;; (connection keep-alive)) + +;; Already fixed by server +;; (content-length ,(format #f (bytevector->length data))) + + +(define (webdav-handler request request-body) + (define href (-> request request-uri uri-path string->href)) + (init-log-table!) + (log-table-add! 'now (current-datetime) + 'method (request-method request) + 'uri (request-uri request) + 'headers (request-headers request) + 'request request) + + (catch* + (lambda () + ;; TODO also log result of execution + (call-with-values + (lambda () + (case (request-method request) + ((OPTIONS) (run-options href request)) + + ((PROPFIND) (run-propfind href request request-body)) + ((PROPPATCH) (run-proppatch href request request-body)) + + ((GET HEAD) (run-get href request (request-method request))) + + ((PUT) (run-put href request request-body)) + + ((DELETE) (run-delete href request)) + + ((MKCOL) (run-mkcol href request request-body)) + + ((COPY) (run-copy href request)) + ((MOVE) (run-move href request)) + + ;; ((REPORT)) + + (else (values (build-response code: 400) "")))) + (lambda (head body) + (log-table-add! + 'response head + 'response-code (response-code head) + 'response-phrase (response-reason-phrase head)) + (emit-log!) + (values head body)))) + + (parser-error + (lambda (err port msg . args) + (define head (build-response code: 400 + headers: '((content-type . (text/plain))))) + (define errmsg + (with-output-to-string + (lambda () + (display msg) + (for-each display args)))) + (log-table-add! 'response head + 'response-code 400 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + + (#t + (case-lambda ((err proc fmt args data) + (let ((head (build-response + code: 500 + headers: '((content-type . (text/plain))))) + (errmsg (if proc + (format #f "Error in ~a: ~?~%" proc fmt args) + (format #f "~?~%" fmt args)))) + (log-table-add! 'response head + 'response-code 500 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + (err + (let ((errmsg (format #f "General error: ~s~%" err))) + (log-table-add! 'response-code 500 + 'msg errmsg) + (emit-log!) + (values (build-response code: 500) + errmsg))))))) + + + +;;; TODO shouldn't this default to #f +(root-resource + (let () + (define root-resource (make <virtual-resource> name: "*root*")) + + (define virtual-resource (make <virtual-resource> + name: "virtual" + content: (string->bytevector "Hello, World\n" (native-transcoder)))) + + (define file-tree (make <file-resource> + root: "/home/hugo/tmp" + name: "files")) + + (mount-resource! root-resource file-tree) + (mount-resource! root-resource virtual-resource) + root-resource)) + + +(define (run-run) + (unless (root-resource) + (throw 'misc-error "run-run" + "root-resource parameter must be set before running" + (list) #f)) + (run-server webdav-handler + 'http + `(#:port 8102))) + +;; "/principals/uid/:uid" + +#; + +(define (make-make-routes) + (make-routes + + + ;; A file extension could be added, but + ;; text/calendar ⇒ .ics + ;; application/calendar+xml ⇒ .xcs + ;; application/calendar+json ⇒ UNKNOWN + (GET "/caldav/:user/:calendar/:filename" (user calendar filename) + (define requested-types + (cond ((assoc-ref r:headers 'accept) + => (lambda (accept) + (sort* accept < + (lambda (type) + (or (assoc-ref (cdr type) 'q) + 1000))))) + (else '(text/calendar)))) + (define available-types + '(text/calendar application/calendar+xml)) + + (define content-type (find (lambda (type) (memv type available-types)) requested-types)) + (define serializer + (case content-type + ((text/calendar) ical:serialize) + ((application/calendar+xml) xcal:serialize) + ((application/calendar+sexp) sxcal:serialize) + (else (return (build-response code: 415) + "Bad content type")))) + + (define event + (copy-as-orphan + (get-by-uid (get-store-by-name calendar) filename))) + + ;; TODO where is the event split into multiple VEVENT objects in the + ;; serialized form? Should be in the serializer, right? + + (define component + (vcalendar prodid: ((@ (calp) prodid)) + version: "2.0" + (list event))) + + (values `((content-type ,content-type)) + (call-with-output-string + (lambda (p) (serializer component p))))) + + (PUT "/caldav/:user/:calendar/:filename" (user calendar filename) + ;; Request Headers: + ;; If-None-Match + ;; Content-Type: text/calendar + ;; application/calendar+xml + + ;; TODO change -X-HNH to X-HNH-PRIVATE, see RFC4791 5.3.3 + + (define component + (let ((type args (car+cdr (assoc-ref r:headers 'content-type)))) + ;; Valid args: charset component optinfo + ;; Invalid args: method (see RFC4791 4.1) + ;; Component is for redundancy? + ;; optinfo is implementation dependant? + ;; Charset already handled by HTTP server + (case type + ((text/calendar) (ical:deserialize body)) + ((application/calendar+xml) (xcal:deserialize body)) + (else (return (build-response code: 415) + "Can't handle that content type"))))) + + (unless (eq? 'VCALENDAR (type component)) + ;; Top level object must be a VCALENDAR + ) + + ;; Must all children be VEVENT? + (children component) + + ;; All VEVENT component must be the the same event, so they should be merged into a single event + (define event (handle-events component)) + + ;; RFC4791 5.3.2: + ;; > The URL for each calendar object resource is entirely arbitrary and + ;; > does not need to bear a specific relationship to the calendar object + ;; > resource's iCalendar properties or other metadata. New calendar + ;; But requiring that UID and filename match makes things easier for us, at least for now + (unless (string=? filename (prop component 'UID)) + (return (build-response code: 400) + "UID and filename must match")) + + (let ((cal (get-calendar-by-name global-event-object calendar))) + ;; (add-and-save-event global-event-object cal component) + + (reparent! cal event) + (queue-write (get-store-for-calendar cal) event) + + ) + + ) + )) diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index ee3b7bc4..316421eb 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -76,7 +76,7 @@ " │ " (if (prop ev 'LOCATION) "" "\x1b[1;30m") (trim-to-width - (or (prop ev 'LOCATION) (_ "NO LOCATION")) location-width) + (or (prop ev 'LOCATION) (G_ "NO LOCATION")) location-width) STR-RESET "\n"))) events @@ -127,7 +127,7 @@ (cls) - (display (_ "== Day View ==")) + (display (G_ "== Day View ==")) (newline) (display-calendar-header! (current-page this)) @@ -148,25 +148,25 @@ (awhen (prop ev 'LOCATION) (format #t "\x1b[1m~a:\x1b[m ~a~%" - (_ "Location") + (G_ "Location") it)) ;; NOTE RFC 5545 says that DTSTART and DTEND MUST ;; have the same type. However we believe that is ;; another story. (format #t "\x1b[1m~a:\x1b[m ~a " - (_ "Start") + (G_ "Start") (let ((start (prop ev 'DTSTART))) (if (datetime? start) (datetime->string (prop ev 'DTSTART) - (_ "~Y-~m-~d ~H:~M:~S")) + (G_ "~Y-~m-~d ~H:~M:~S")) (date->string start)))) (format #t "\x1b[1m~a:\x1b[m ~a~%~%" - (_ "End") - (let ((start (prop ev 'DTSTART))) - (if (datetime? start) - (datetime->string (prop ev 'DTSTART) - (_ "~Y-~m-~d ~H:~M:~S")) - (date->string start)))) + (G_ "End") + (let ((end (prop ev 'DTEND))) + (if (datetime? end) + (datetime->string (prop ev 'DTEND) + (G_ "~Y-~m-~d ~H:~M:~S")) + (date->string end)))) (format #t "~a~%" (unlines (take-to (flow-text (or (prop ev 'DESCRIPTION) "") width: (min 70 width)) @@ -208,14 +208,14 @@ (active-element this) 0)) ((#\/) (set-cursor-pos 0 (1- height)) - (let ((search-term (get-line (_ "quick search: ")))) + (let ((search-term (get-line (G_ "quick search: ")))) `(push ,(search-view (format #f "(regexp-exec (make-regexp \"~a\" regexp/icase) (prop event 'SUMMARY))" search-term) (get-event-set this))))) ((#\() (set-cursor-pos 0 (1- height)) - (let ((search-term (get-line (_ "search: ")))) + (let ((search-term (get-line (G_ "search: ")))) `(push ,(search-view search-term (get-event-set this))))) (else (next-method)))) @@ -261,7 +261,7 @@ (cls) - (display (_ "== Search View ==\n")) + (display (G_ "== Search View ==\n")) ;; display search term (format #t "~y" (search-term this)) @@ -290,6 +290,7 @@ ">"))) (newline)) +;;; TODO what is this view? (define-method (input (this <view>) char) (case char ((#\j #\J down) (unless (= (active-element this) (1- (page-length this))) @@ -300,6 +301,9 @@ ((#\g) (set! (active-element this) 0)) ((#\G) (set! (active-element this) (1- (page-length this)))) + ;; TODO Launch edit mode! + ;; TODO should edit mode be here? + ((#\e) 'NOOP) ((#\q) '(pop))) @@ -317,7 +321,7 @@ 'DTSTART))))) ((#\h left) (set! (current-page this) = ((lambda (old) (max 0 (1- old)))))) ((#\l right) - (format #t "~% ~a~%" (_ "loading...")) + (format #t "~% ~a~%" (G_ "loading...")) (set! (current-page this) (next-page (slot-ref this 'search-result) (current-page this)))) diff --git a/module/calp/translation.scm b/module/calp/translation.scm index 67189e7a..e99062db 100644 --- a/module/calp/translation.scm +++ b/module/calp/translation.scm @@ -3,7 +3,7 @@ :use-module (ice-9 regex) :use-module (ice-9 match) :use-module (srfi srfi-88) - :export (_ translate yes-no-check)) + :export (G_ translate yes-no-check)) (bindtextdomain "calp" "/home/hugo/code/calp/localization/") @@ -18,7 +18,7 @@ (gettext string "calp"))) ;; Mark string for translation, and also make it discoverable for gettext -(define (_ . msg) +(define (G_ . msg) (translate (string-join msg))) (define* (yes-no-check string optional: (locale %global-locale)) diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm index aba2cd2c..d2bff5ac 100644 --- a/module/calp/util/config.scm +++ b/module/calp/util/config.scm @@ -19,7 +19,7 @@ args)) (define %configuration-error - (_ "Pre-property failed when setting ~s to ~s")) + (G_ "Pre-property failed when setting ~s to ~s")) (define-syntax-rule (define-once-public symbol binding) (begin (define-once symbol binding) @@ -27,7 +27,7 @@ (define-syntax (define-config stx) (syntax-case stx () - ((_ name default kw ...) + ((G_ name default kw ...) (let ((pre (cond ((memv pre: (fix-keywords #'(kw ...))) => cadr) (else #f))) (post (cond ((memv post: (fix-keywords #'(kw ...))) => cadr) (else #f)))) #`(define-once-public name diff --git a/module/calp/util/exceptions.scm b/module/calp/util/exceptions.scm index 5d6a71e8..6bfc2415 100644 --- a/module/calp/util/exceptions.scm +++ b/module/calp/util/exceptions.scm @@ -4,6 +4,6 @@ :use-module (hnh util exceptions)) (define-config warnings-are-errors #f - description: (_ "Crash on warnings.") + description: (G_ "Crash on warnings.") post: (@ (hnh util exceptions) warnings-are-errors) ) diff --git a/module/calp/webdav/property.scm b/module/calp/webdav/property.scm new file mode 100644 index 00000000..092d270a --- /dev/null +++ b/module/calp/webdav/property.scm @@ -0,0 +1,91 @@ +(define-module (calp webdav property) + :use-module (sxml namespaced) + :use-module (web http status-codes) + :use-module ((srfi srfi-1) :select (concatenate find)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (hnh util) + :use-module (calp namespaces) + :export (make-propstat + propstat? + propstat-status-code + propstat-property + propstat-error + propstat-response-description + + propstat + + merge-propstats + propstat-200? + ;; propstat->sxml + propstat->namespaced-sxml + )) + +;;; Commentary: +;;; Code: + + +;; Maps directly to [WEBDAV]'s propstat objects. This is just a simpler interface in the code. + +(define-record-type <propstat> + (make-propstat status prop error responsedescription) + propstat? + ;; An http status code indicating if this property is present + (status propstat-status-code) + ;; A list of namespaced sxml elements, such that they could all be + ;; directly inserted as the children of <DAV::prop/> + ;; @example + ;; `((,(xml ns tag) "Content")) + ;; @end example + (prop propstat-property) + + ;; See [WEBCAL] propstat XML element + (error propstat-error) + (responsedescription propstat-response-description)) + +(define* (propstat code prop key: error responsedescription) + (make-propstat code prop error responsedescription)) + +;; Query a given dead property from the given resource +;; property should be a xml-element item +;; (define (propfind-selected-property resource property) +;; (cond ((get-dead-property resource property) +;; => (lambda (it) (propstat 200 (list it)))) +;; (else (propstat 404 (list (list property)))))) +;; Takes a list of <propstat> items, finds all where status, error, and +;; responsedescription are all equal, and merges the prop tags of all those. +;; Returns a new list of <propstat> items +(define (merge-propstats propstats) + (map (lambda (group) + (define-values (code error desc) (unlist (car group))) + (make-propstat code + (concatenate + (map propstat-property (cdr group))) + error desc)) + (group-by (lambda (propstat) + (list (propstat-status-code propstat) + (propstat-error propstat ) + (propstat-response-description propstat))) + propstats))) + +(define (propstat-200? prop) + (= 200 (propstat-status-code prop))) + + +;; (define (propstat->sxml propstat) +;; `(d:propstat (d:prop ,(propstat-property propstat)) +;; (d:status ,(http-status-line (propstat-status-code propstat))) +;; ,@(awhen (propstat-error propstat) +;; `((d:error ,it))) +;; ,@(awhen (propstat-response-description propstat) +;; `((d:responsedescription ,it))))) + +(define (propstat->namespaced-sxml propstat) + `(,(xml webdav 'propstat) + (,(xml webdav 'prop) ,@(propstat-property propstat)) + (,(xml webdav 'status) ,(http-status-line (propstat-status-code propstat))) + ,@(awhen (propstat-error propstat) + `((,(xml webdav 'error) ,it))) + ,@(awhen (propstat-response-description propstat) + `((,(xml webdav 'responsedescription) ,it))))) diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm new file mode 100644 index 00000000..83725825 --- /dev/null +++ b/module/calp/webdav/propfind.scm @@ -0,0 +1,99 @@ +(define-module (calp webdav propfind) + :use-module (calp webdav property) + :use-module (calp webdav resource) + :use-module (calp namespaces) + :use-module (srfi srfi-1) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :export (propfind-selected-properties + propfind-all-live-properties + propfind-most-live-properties + propfind-all-dead-properties + + parse-propfind + )) + +;;; Commentary: +;;; Procedures for the WebDav PROPFIND method +;;; Code: + +;; Properties should be a list of xml-tag-elements +;; return a list of propstat elements +;; work for both dead and alive objects +(define (propfind-selected-properties resource properties) + (map (lambda (el) (get-property resource el)) + properties)) + + +;; (define-method (supported-properties (self <resource>)) +;; (map (lambda (v) (cons webdav v)) +;; `())) + +;; Returns a list of <propstat> objects. +(define (propfind-all-live-properties resource) + (map (lambda (p) ((cdr p) resource)) + (live-properties resource))) + +;; Returns a list of <propstat> objects. +;; The list being the live properties defined by [WEBDAV] +(define (propfind-most-live-properties resource) + (map (lambda (p) ((property-getter (cdr p)) resource)) + webdav-properties)) + +;; Returns a list of <propstat> objects. +;; All "dead" properties on resource. +(define (propfind-all-dead-properties resource) + (map (lambda (v) (propstat 200 (list v))) + (dead-properties resource))) + + + + + +(define (find-element target list) + (define target* (xml-element-hash-key target)) + (find (lambda (x) (and (list? x) + (not (null? x)) + (xml-element? (car x)) + (equal? target* (xml-element-hash-key (car x))))) + list)) + +;; Takes a propfind xml element (tree), and a webdav resource object. +;; Returns a list of <propstat> objects. +(define (parse-propfind sxml resource) + ;; (assert (list? sxml)) + ;; (assert (not (null? sxml))) + ;; (assert eq? 'd:propfid (car sxml)) + (let ((propname (find-element (xml webdav 'propname) (cdr sxml))) + (allprop (find-element (xml webdav 'allprop) (cdr sxml))) + (include (find-element (xml webdav 'include) (cdr sxml))) + (prop (find-element (xml webdav 'prop) (cdr sxml)))) + (merge-propstats + (cond ((and allprop include) + ;; Return "all" properties + those noted by <include/> + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource) + (propfind-selected-properties + resource + (map car (cdr include))))) + (allprop + ;; Return "all" properties + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + ;; Return the list of available properties + (list (propstat + 200 + ;; car to get tagname, list to construct a valid xml element + (map (compose list car) + (append + (dead-properties resource) + (live-properties resource)))))) + (prop + ;; Return the properties listed + (propfind-selected-properties + resource + (map car (cdr prop)))) + (else + (scm-error 'bad-request "parse-propfind" + "Invalid search query ~s" (list sxml) (list sxml))))))) diff --git a/module/calp/webdav/proppatch.scm b/module/calp/webdav/proppatch.scm new file mode 100644 index 00000000..db7f5f95 --- /dev/null +++ b/module/calp/webdav/proppatch.scm @@ -0,0 +1,67 @@ +(define-module (calp webdav proppatch) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp webdav property) + :use-module (calp webdav resource) + :use-module (sxml match) + :use-module (sxml namespaced) + :use-module ((hnh util) :select (for)) + :export (parse-propertyupdate) + ) + + +(define (parse-propertyupdate body namespaces resource) + (merge-propstats + (sxml-match body + [(d:propertyupdate . ,changes) + (define continuations + (concatenate + (for change in changes + (sxml-match change + [(d:remove (d:prop . ,properties)) + (map (lambda (prop) (cons prop + (remove-property + resource + (car + (sxml->namespaced-sxml prop namespaces))))) + properties)] + + ;; TODO handle xmllang correctly + [(d:set (d:prop . ,properties)) + (map (lambda (prop) (cons prop + (set-property resource + (sxml->namespaced-sxml prop namespaces)))) + properties)] + + [,else (scm-error 'bad-request "" + "Invalid propertyupdate: ~s" + (list body) + (list body))])))) + + ;; (format (current-error-port) "~s~%" continuations) + (let loop ((continuations continuations)) + (if (null? continuations) + '() + (let ((tag proc (car+cdr (car continuations)))) + (set! tag (sxml->namespaced-sxml tag namespaces)) + ;; (format (current-error-port) "tag: ~s~%" tag) + (catch #t (lambda () + ;; This is expected to throw quite often + (proc) + (cons (propstat 200 (list tag)) + (loop (cdr continuations)))) + (lambda err + (cons (propstat 409 (list tag)) + (mark-remaining-as-failed-dependency (cdr continuations))))))))] + + [,else (scm-error 'bad-request "" + "Invalid root element: ~s" + (list else) + (list else))]))) + + +(define (mark-remaining-as-failed-dependency pairs) + (map (lambda (item) + (propstat 424 (list (car item)))) + pairs)) diff --git a/module/calp/webdav/resource.scm b/module/calp/webdav/resource.scm new file mode 100644 index 00000000..47c5aded --- /dev/null +++ b/module/calp/webdav/resource.scm @@ -0,0 +1,15 @@ +(define-module (calp webdav resource) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource base) + :export (mount-resource!)) + +(define cm (module-public-interface (current-module))) +(module-use! cm (resolve-interface '(calp webdav resource base))) + +;;; TODO mount-resource! vs add-child! +;;; Would a good idea be that add-resource! adds directly, and should +;;; be considered internal, while mount-resource! also runs post-add +;;; hooks, and could thereby be exported +(define-method (mount-resource! (this <resource>) (child <resource>)) + (add-child! this child)) diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm new file mode 100644 index 00000000..500aef90 --- /dev/null +++ b/module/calp/webdav/resource/base.scm @@ -0,0 +1,598 @@ +(define-module (calp webdav resource base) + :use-module ((srfi srfi-1) :select (find remove last append-map drop-while)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (calp webdav property) + :use-module (calp namespaces) + :use-module ((hnh util) :select (unless)) + :use-module (rnrs bytevectors) + :use-module (hnh util) + :use-module (hnh util env) + :use-module (datetime) + :export (<resource> + ;; href + href->string + string->href + href-relative + ;; local-path + name + dead-properties + ;; resource-children + resource? + children + + + + get-live-property + get-dead-property + get-property + + set-dead-property + set-dead-property! + set-live-property + set-live-property! + set-property + set-property! + + remove-dead-property + remove-dead-property! + remove-live-property + remove-live-property! + remove-property + remove-property! + + + setup-new-resource! + setup-new-collection! + + + + live-properties + add-child! + add-resource! + add-collection! + is-collection? + + content + set-content! + + copy-resource + copy-to-location! + move-to-location! + cleanup-resource + delete-child! + setup-new-resource! + ;; prepare-for-add! + + creationdate + displayname + getcontentlanguage + getcontentlength + getcontenttype + getetag + getlastmodified + lockdiscovery + resourcetype + supportedlock + + webdav-properties + + ;; absolute-path + ;; find-resource + lookup-resource + all-resources-under + + ;; dereference + + make-live-property + live-property? + property-getter + property-setter-generator + property-remover-generator + + prepare-update-properties + + )) + + +(define-record-type <live-property> + (make-live-property% getter setter-generator remover-generator) + live-property? + (getter property-getter) + (setter-generator property-setter-generator) + (remover-generator property-remover-generator)) + +(define* (make-live-property getter setter-generator optional: remover-generator) + (make-live-property% getter setter-generator remover-generator)) + + + +;; Collections are also resources, this is non-collection resources +(define-class <resource> () + ;; (href init-keyword: href: getter: href init-value: #f) + ;; (local-path init-keyword: local-path: getter: local-path) + + ;; name is a part of its search path. + ;; For example: the component located at /a/b + ;; would have name="a", its parent name="b", and the root element + ;; would have an unspecified name (probably the empty string, or "*root*") + (name init-keyword: name: getter: name) + + (dead-properties + ;; Map from (namespace . tagname) pairs to namespaced xml element + init-form: (make-hash-table) + getter: dead-properties%) + + ;; Attributes on data + (displayname accessor: displayname* init-value: #f) + (contentlanguage accessor: contentlanguage init-value: #f) + + ;; Direct children, used by @code{children} if not overwritten by child + (resource-children init-value: '() + accessor: resource-children) + + ;; Table containing href -> resource mappings, saves us from recursivly searching children each time. + (resource-cache init-value: (make-hash-table 0) + getter: resource-cache)) + +(define (resource? x) + (is-a? x <resource>)) + + +(define (href->string href) + (if (null? href) + "/" (string-join href "/" 'prefix))) + +(define (string->href s) + (remove string-null? + (string-split s #\/))) + +;; parent must be the head of child, elements in child after that is "free range" +(define (href-relative parent child) + (cond ((null? parent) child) + ((null? child) (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)) + ((equal? (car parent) (car child)) + (href-relative (cdr parent) (cdr child))) + (else (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)))) + +(define-method (children (self <resource>)) + (resource-children self)) + +;;; TODO merge content and set-content! into an accessor? +(define-method (content (self <resource>)) + (throw 'misc-error "content<resource>" + "Base <resource> doesn't implement (getting) content, please override this method" + '() #f)) + +(define-method (set-content! (self <resource>) content) + (throw 'msic-error "set-content!<resource>" + "Base <resource> doesn't implement (setting) content, please override this method" + '() #f)) + +(define-method (content-length (self <resource>)) + (if (is-collection? self) + 0 + (let ((c (content self))) + (cond ((bytevector? c) (bytevector-length c)) + ((string? c) (string-length c)) + (else -1))))) + +(define-method (write (self <resource>) port) + (catch #t + (lambda () + (display ; Make output atomic + (call-with-output-string + (lambda (port) + (format port "#<~a name=~s" + (class-name (class-of self)) + (name self)) + (cond ((displayname self) + propstat-200? + (lambda (name) (format port ", displayname=~s" name)))) + (format port ">"))) + port)) + (lambda _ + (format port "#<~a>" (class-name (class-of self)))))) + + +(define (add-resource! self new-name content) + (if (lookup-resource self (list new-name)) + (throw 'resource-exists) + (let ((resource (make (class-of self) name: new-name))) + (add-child! self resource collection?: #f) + (set-content! resource content) + resource))) + +(define (add-collection! self new-name) + (if (lookup-resource self (list new-name)) + (throw 'resource-exists) + (let ((resource (make (class-of self) name: new-name))) + (add-child! self resource collection?: #t) + resource))) + +(define (initialize-copied-resource! source copy) + (for-each (lambda (tag) (set-dead-property! copy tag)) + (dead-properties source)) + (set! (displayname* copy) (displayname* source) + (contentlanguage copy) (contentlanguage source)) + ;; (format (current-error-port) "Setting content! ~s (~s)~%" copy source) + (when (content source) + (set-content! copy (content source))) + ;; resource-cache should never be copied + ) + +(define-method (copy-resource (self <resource>) include-children?) + (copy-resource self include-children? #f)) + +(define-method (copy-resource (self <resource>) include-children? new-name) + (let ((resource (make (class-of self) name: (or new-name (name self))))) + (initialize-copied-resource! self resource) + (when include-children? + (for-each (lambda (c) (add-child! resource c)) + (map (lambda (c) (copy-resource c #t)) + (children self)))) + resource)) + +;; source and target-parent should be resource instances +;; new-name a string +;; include-children? and overwrite? booleans +(define* (copy-to-location! source target-parent + key: + (new-name (name source)) + include-children? + overwrite? + ) + (let ((copy (make (class-of source) name: new-name)) + ;; Take copy if child list. If we run `cp -r / /c` then; + ;; (at least when /c already exists) our child list gets + ;; updated, leading to an infinite loop if we use + ;; `(children source)` directly below. + (children-before (children source))) + (let ((status (add-child! target-parent copy + ;; (is-collection? copy) doesn't work for + ;; all types, since it's not quite yet + ;; added (for example: <file-resoure> + ;; checks if the target resource is a + ;; directory on the file system). + collection?: (is-collection? source) + overwrite?: overwrite?))) + (case status + ((created replaced) + (initialize-copied-resource! source copy) + (when include-children? + (for-each (lambda (c) (copy-to-location! + c copy + include-children?: #t)) + children-before)) + status) + ((collision) 'collision))))) + +(define* (move-to-location! source-parent source target-parent + key: + (new-name (name source)) + overwrite?) + (let ((status (copy-to-location! source target-parent + new-name: new-name + include-children?: #t + overwrite?: overwrite?))) + (case status + ((created replaced) + (delete-child! source-parent source) + status) + ((collision) 'collision)))) + + +;; Only tagname and namespaces are checked on the <xml-element> for the {get,set}-property + + +;;; All get-*-property methods return propstat elements + +(define (lookup-live-property resource xml-el) + (assoc-ref (live-properties resource) (xml-element-hash-key xml-el))) + +;;; TODO should {get,set}{,-{dead,live}}-property really be methods? +;;; - Live properties are defined by lookup-live-property, which isn't a +;;; method, which in turn calls live-properties, which MUST be a method. +;;; - Dead properties may have a reason. For example, file resources might +;;; want to store them directly in xattrs, ignoring its built in hash-table. +;;; - The combined should always just dispatch to either one + +(define-method (get-live-property (resource <resource>) xml-el) + (cond ((lookup-live-property resource xml-el) + => (lambda (pair) ((property-getter pair) resource))) + (else (propstat 404 (list (list xml-el)))))) + +(define-method (get-dead-property (resource <resource>) xml-el) + (cond ((hash-ref (dead-properties% resource) + (xml-element-hash-key xml-el)) + => (lambda (it) (propstat 200 (list it)))) + (else (propstat 404 (list (list xml-el)))))) + +;;; Return a list xml tags (including containing list) +(define-method (dead-properties (resource <resource>)) + (hash-map->list (lambda (_ v) v) + (dead-properties% resource))) + +;; Value should be a list with an <xml-element> in it's car +(define-method (set-dead-property (resource <resource>) value) + (unless (and (list? value) + (xml-element? (car value))) + (scm-error 'misc-error "set-dead-property" + "Invalid value, expected namespaced sxml" + '() #f)) + (lambda () + (hash-set! (dead-properties% resource) + (xml-element-hash-key (car value)) + value))) + +(define-method (set-live-property (resource <resource>) value) + (unless (and (list? value) + (xml-element? (car value))) + (scm-error 'misc-error "set-live-property" + "Invalid value, expected namespaced sxml" + '() #f)) + (cond ((lookup-live-property resource (car value)) + => (lambda (prop) (apply (property-setter-generator prop) + resource (cdr value)))) + (else #f))) + +(define (set-dead-property! resource value) + ((set-dead-property resource value))) + +(define (set-live-property! resource value) + ((set-live-property resource value))) + +(define (set-property resource value) + (or (set-live-property resource value) + (set-dead-property resource value))) + +(define (set-property! resource value) + ((set-property resource value))) + +;;; The remove-* procedures still take "correct" namespaced sxml (so an +;;; xml-element object inside a list). These extra lists are a bit of a waste, +;;; But allows remove-* to have the same signature as set-* + +(define-method (remove-dead-property (resource <resource>) xml-tag) + (unless (xml-element? xml-tag) + (scm-error 'misc-error "remove-dead-property" + "Bad property element" + '() #f)) + (lambda () + (hash-remove! (dead-properties% resource) + (xml-element-hash-key xml-tag)))) + +(define-method (remove-live-property (resource <resource>) xml-tag) + (unless (xml-element? xml-tag) + (scm-error 'misc-error "remove-live-property" + "Bad property element" + '() #f)) + + (cond ((lookup-live-property resource xml-tag) + => (lambda (prop) + (cond ((property-remover-generator prop) + => (lambda (f) (f resource))) + (else (throw 'irremovable-live-property))))) + (else #f))) + +(define (remove-dead-property! resource xml-tag) + ((remove-dead-property resource xml-tag))) + +(define (remove-live-property! resource xml-tag) + ((remove-live-property resource xml-tag))) + +(define-method (remove-property (resource <resource>) xml-tag) + (or (remove-live-property resource xml-tag) + (remove-dead-property resource xml-tag))) + +(define (remove-property! resource xml-tag) + ((remove-property resource xml-tag))) + + + +;; xml-tag should be just the tag element, without a surounding list +(define-method (get-property (resource <resource>) xml-tag) + (cond ((get-dead-property resource xml-tag) + propstat-200? => identity) + (else (get-live-property resource xml-tag)))) + +;; Return an alist from xml-element tags (but not full elements with surrounding list) +;; to generic procedures returning that value. +;; SHOULD be extended by children, which append their result to this result +;; @example +;; (define-method (live-properties (self <specific-resource>) +;; (append (next-method) +;; specific-resource-properties)) +;; @end example +(define-method (live-properties (self <resource>)) + (map (lambda (pair) (cons (xml-element-hash-key (xml webdav (car pair))) (cdr pair))) + webdav-properties)) + +(define-method (setup-new-resource! (this <resource>) (parent <resource>)) + 'noop) + +(define-method (setup-new-collection! (this <resource>) (parent <resource>)) + 'noop) + +(define (add-child* this child collection?) + (setup-new-resource! child this) + (when collection? + (setup-new-collection! child this)) + (set! (resource-children this) + (cons child (resource-children this)))) + +(define* (add-child! this child + key: + overwrite? + (collection? (is-collection? child))) + (let ((existing (lookup-resource this (list (name child))))) + (cond ((and overwrite? existing) + (delete-child! this existing) + (add-child* this child collection?) + 'replaced) + (existing 'collision) + (else + (add-child* this child collection?) + 'created)))) + + +;; Free any aditional system resources held by this object. +;; For example, file resources will remove the underlying file here. +(define-method (cleanup-resource (this <resource>)) + 'noop) + +(define-method (delete-child! (this <resource>) (child <resource>)) + (set! (resource-children this) + (delq1! child (children this))) + (for-each (lambda (grandchild) + (delete-child! child grandchild)) + (children child)) + (cleanup-resource child)) + + + +;;; TODO rename to simply @code{collection?} +(define-method (is-collection? (self <resource>)) + (not (null? (resource-children self)))) + + + + +(define-method (creationdate (self <resource>)) + (propstat 501 `((,(xml webdav 'creationdate))))) + +(define-method (set-creationdate! (self <resource>) _) + (throw 'protected-resource "creationdate")) + +(define-method (displayname (self <resource>)) + (cond ((displayname* self) + => (lambda (name) + (propstat 200 `((,(xml webdav 'displayname) + ,name))))) + (else + (propstat 404 `((,(xml webdav 'displayname))))))) + +(define-method (set-displayname! (self <resource>) value) + (lambda () (set! (displayname* self) value))) + +(define-method (getcontentlanguage (self <resource>)) + (cond ((contentlanguage self) + => (lambda (lang) (propstat 200 `((,(xml webdav 'getcontentlanguage) ,lang))))) + (else (propstat 404 `((,(xml webdav 'getcontentlanguage))))))) + +(define-method (set-getcontentlanguage! (self <resource>) value) + (lambda () (set! (contentlanguage self) value))) + +(define-method (getcontentlength (self <resource>)) + (propstat 501 `((,(xml webdav 'getcontentlength))))) + +(define-method (getcontentlength (self <resource>)) + (propstat 200 + (list + (list (xml webdav 'getcontentlength) + (content-length self))))) + +(define-method (set-getcontentlength! (self <resource>) _) + (throw 'protected-resource "getcontentlength")) + +(define-method (getcontenttype (self <resource>)) + (propstat 501 `((,(xml webdav 'getcontenttype))))) + +(define-method (set-getcontenttype! (self <resource>) _) + (throw 'protected-resource "getcontenttype")) + +(define-method (getetag (self <resource>)) + ;; TODO + (propstat 501 `((,(xml webdav 'getetag))))) + +(define-method (set-getetag! (self <resource>) _) + (throw 'protected-resource "getetag")) + +(define-method (getlastmodified (self <resource>)) + (propstat 200 `((,(xml webdav 'getlastmodified) + ,(with-locale1 + LC_TIME "C" + (lambda () + (datetime->string (unix-time->datetime 0) "~a, ~d ~b ~Y ~H:~M:~S GMT"))))))) + +(define-method (set-getlastmodified! (self <resource>) _) + (throw 'protected-resource "getlastmodified")) + +(define-method (lockdiscovery (self <resource>)) + (propstat 200 `((,(xml webdav 'lockdiscovery) + ())))) + +(define-method (set-lockdiscovery! (self <resource>) _) + (throw 'protected-resource "lockdiscovery")) + +(define-method (resourcetype (self <resource>)) + (propstat 200 `((,(xml webdav 'resourcetype) + ,@(when (is-collection? self) + `((,(xml webdav 'collection)))))))) + +(define-method (set-resourcetype! (self <resource>) _) + (throw 'protected-resource "resourcetype")) + +(define-method (supportedlock (self <resource>)) + (propstat 200 `((,(xml webdav 'supportedlock) ())))) + +(define-method (set-supportedlock! (self <resource>) _) + (throw 'protected-resource "supportedlock")) + +(define webdav-properties + `((creationdate . ,(make-live-property creationdate set-creationdate!)) + (displayname . ,(make-live-property displayname set-displayname!)) + (getcontentlanguage . ,(make-live-property getcontentlanguage set-getcontentlanguage!)) + (getcontentlength . ,(make-live-property getcontentlength set-getcontentlength!)) + (getcontenttype . ,(make-live-property getcontenttype set-getcontenttype!)) + (getetag . ,(make-live-property getetag set-getetag!)) + (getlastmodified . ,(make-live-property getlastmodified set-getlastmodified!)) + (lockdiscovery . ,(make-live-property lockdiscovery set-lockdiscovery!)) + (resourcetype . ,(make-live-property resourcetype set-resourcetype!)) + (supportedlock . ,(make-live-property supportedlock set-supportedlock!)))) + + + +;;; TODO remove! This is a remnant of the old mount system +;; (define-method (dereference (self <resource>)) +;; self) + +(define (find-resource resource path) + ;; Resource should be a <resource> (or something descended from it) + ;; path should be a list of strings + (cond ((null? path) resource) + ((string-null? (car path)) + ;; resource + (find-resource resource (cdr path))) + ((find (lambda (r) (string=? (car path) (name r))) + (children resource)) + => (lambda (r) (find-resource r (cdr path)))) + (else #f))) + +;; Lookup up a given resource first in the cache, +;; Then in the tree +;; and finaly fails and returns #f +(define (lookup-resource root-resource path) + (find-resource root-resource path) + #; + (or (hash-ref (resource-cache root-resource) path) + (and=> (find-resource root-resource path) + (lambda (resource) + (hash-set! (resource-cache root-resource) path resource) + resource)))) + +(define* (all-resources-under* resource optional: (prefix '())) + (define s (append prefix (list (name resource)))) + (cons (cons s resource) + (append-map (lambda (c) (all-resources-under* c s)) + (children resource)))) + +;; Returns a flat list of this resource, and all its decendants +(define* (all-resources-under resource optional: (prefix '())) + (cons (cons prefix resource) + (append-map (lambda (c) (all-resources-under* c prefix)) + (children resource)))) diff --git a/module/calp/webdav/resource/calendar.scm b/module/calp/webdav/resource/calendar.scm new file mode 100644 index 00000000..314d66aa --- /dev/null +++ b/module/calp/webdav/resource/calendar.scm @@ -0,0 +1,27 @@ +(define-module (calp webdav resource calendar) + ;; :use-module (hnh util) + ;; :use-module (datetime) + ;; :use-module (sxml namespaced util) + ;; :use-module (calp webdav property) + ;; :use-module (ice-9 hash-table) + :use-module (calp webdav resource calendar collection) + :use-module (calp webdav resource calendar object) + :export ( + calendar-resource? +) + ) + +(define cm (module-public-interface (current-module))) +(module-use! cm (resolve-interface '(calp webdav resource calendar collection))) +(module-use! cm (resolve-interface '(calp webdav resource calendar object))) + +(define (calendar-resource? x) + (or (calendar-collection-resource? x) + (calendar-object-resource? x))) + + + + + + + diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm new file mode 100644 index 00000000..9acb6701 --- /dev/null +++ b/module/calp/webdav/resource/calendar/collection.scm @@ -0,0 +1,298 @@ +(define-module (calp webdav resource calendar collection) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :use-module ((vcomponent) :prefix vcs-) + :use-module ((vcomponent base) + :select (type prop make-vcomponent)) + + :use-module (web request) + :use-module (web uri) + + :use-module ((calp namespaces) :select (webdav caldav)) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (ice-9 hash-table) + + :use-module (hnh util) + + :use-module (calp webdav resource calendar object) + ;; propfind-most-live-properties propfind-all-dead-properties propname uri-path request-uri type + :export (<calendar-collection-resource> + caldav-properties + calendar-collection-resource?) + ) + +;;; Resoruces containing calendar components +(define-class <calendar-collection-resource> (<resource>) + (description init-value: #f + accessor: description) + (data-store getter: data-store + init-keyword: store:) + #; + (content% init-value: (make-vcomponent 'VIRTUAL) + accessor: content%)) + + +(define-method (is-collection? (_ <calendar-collection-resource>)) + #t) + + + +(define-method (children (this <calendar-collection-resource>)) + (map (lambda (ev) + (make <calendar-object-resource> + name: (prop ev 'UID) + component: ev)) + (vcs-children this))) + +(define (calendar-collection-resource? x) + (is-a? x <calendar-collection-resource>)) + + +(define-method (base-timezone <calendar-collection-resource>) + ;; (zoneinfo->vtimezone '() "Europe/Stockholm" 'ev) + (make-vcomponent 'VTIMEZONE) + ) + + + +(define-method (live-properties (self <calendar-collection-resource>)) + (append (next-method) + (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair))) + caldav-properties))) + + + + +(define-method (displayname (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml webdav 'displayname) + ,(prop (content self) 'displayname))))) + + +(define-method (resourcetype (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml webdav 'resourcetype) + (,(xml caldav 'calendar)))))) + +;;; CALDAV Properties + +(define-method (calendar-description (self <calendar-collection-resource>)) + (cond ((description self) + => (lambda (it) + (propstat 200 + (list (list (xml caldav 'calendar-description (alist->hashq-table '((xml:lang . "en")))) + it))))) + (else + (propstat 404 (list (list (xml caldav 'calendar-description))))))) + +(define-method (calendar-timezone (self <calendar-collection-resource>)) + (propstat 200 + (list + (list (xml caldav 'calendar-description) + (call-with-output-string + (lambda (port) + (ics:serialize (base-timezone self) port))))))) + +(define-method (supported-calendar-component-set (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml caldav 'supported-calendar-component-set) + (,(xml caldav 'comp + (alist->hashq-table '((name . "VEVENT"))))))))) + +(define-method (supported-calendar-data (self <calendar-collection-resource>)) + (propstat 200 + (list + (list + (xml caldav 'supported-calendar-data) + (map (lambda (content-type) + (list (xml caldav 'calendar-data + (alist->hashq-table + '((content-type . ,content-type) + (version . "2.0")))))) + '("text/calendar" + "application/calendar+xml")))))) + + + +;; (define-method (max-resource-size (self <calendar-collection-resource>)) +;; ) + +;; (define-method (min-date-time )) +;; (define-method (max-date-time )) +;; (define-method (max-instances )) +;; (define-method (max-attendees-per-instance )) + +(define-method (supported-collation-set (self <calendar-collection-resource>)) + (propstat 200 + (list `(,(xml caldav 'supported-collation-set) + ,@(map (lambda (cs) `(,(xml caldav 'supported-collation) ,cs)) + `(;; Required by CalDAV + "i;ascii-casemap" + "i;octet" + ;; Added (RFC 5051)) + "i;unicode-casemap")))))) + + + +(define caldav-properties + `((calendar-description . ,calendar-description) + (calendar-timezone . ,calendar-timezone) + (supported-calendar-component-set . ,supported-calendar-component-set) + (supported-calendar-data . ,supported-calendar-data) + (supported-collation-set . ,supported-collation-set) + ;; (max-resource-size . ,max-resource-size) + ;; (min-date-time . ,min-date-time) + ;; (max-date-time . ,max-date-time) + ;; (max-instances . ,max-instances) + ;; (max-attendees-per-instance . ,max-attendees-per-instance) + )) + +;;; Reports + +(define-method (supported-reports* (this <calendar-collection-resource>)) + (append (next-method) + (list + ;; Required for ACL, but not for CalDAV + ;; (xml webdav 'version-tree) + ;; Optional for ACL, but REQUIRED for CalDAV + (cons (xml webdav 'expand-property) expand-property) + ;; REQUIRED by CalDAV + (cons (xml caldav 'calendar-query) calendar-query) + (cons (xml caldav 'calendar-multiget) calendar-multiget) + (cons (xml caldav 'free-busy-report) free-busy-report) + ))) + + +(define-method (calendar-query (this <calendar-collection-resource>) headers body) + ;; Request body MUST be a caldav:calendar-query + ;; Request MAY include a depth header, default = 0 + ;; Respnose-body MUST be a dav:multistatus + ;; Responseb body MUST contain DAV:respons element for each iCalendar object that matched the search filter + + (let ((allprop (find-element (xml webdav 'allprop) (cdr body))) + (propname (find-element (xml webdav 'propname) (cdr body))) + (prop (find-element (xml webdav 'prop) (cdr body))) + (filter (find-element (xml caldav 'filter) (cdr body))) + (timezone (find-element (xml caldav 'timezone) (cdr body)))) + (when (< 1 (count identity (list allprop propname prop))) + (throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive")) + + (unless filter + (throw 'bad-request 400 "filter required")) + + + #; + (when timezone + (case (assoc-ref (attributes timezone) 'content-type) + ((application/calendar+xml) + (xcs:serialize default-timezone)) + ;; ((application/calendar+json)) + (else ; includes text/calendar + (ics:serialieze default-timezone) + ))) + + (let ((resources (select-components-by-comp-filter this comp-filter))) + `(,(xml webdav 'multistatus) + ,@(for (href . resource) in resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (merge-propstats + (cond (allprop + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + (list (propstat + 200 + (map (compose list car) + (append (dead-properties resource) + (live-properties resource)))))) + (prop + (map (lambda (prop) (get-property resource prop)) + prop))))))))))) + + + + +(define-method (expand-property (this <calendar-collection-resource>) request body)) + +(define-method (free-busy-report (this <calendar-collection-resource>) request body)) + +(define-method (calendar-multiget (this <calendar-collection-resource>) request body) + (define base-href (-> request request-uri uri-path href->string)) + (let ((allprop (find-element (xml webdav 'allprop) (cdr body))) + (propname (find-element (xml webdav 'propname) (cdr body))) + (prop (find-element (xml webdav 'prop) (cdr body))) + (hrefs (find-elements (xml webdav 'href) (cdr body)))) + (when (< 1 (count identity (list allprop propname prop))) + (throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive")) + (when (null? hrefs) + (throw 'bad-request 400 "At least one href is required")) + + ;; (assert (memv href hrefs)) + + (let ((resources + (for href in hrefs + (cons href + (lookup-resource + this + (href-relative base-href href)))))) + `(,(xml webdav 'multistatus) + (for (href . resource) in resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(cond (resource + (cond (allprop + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + (list (propstat + 200 + ;; car to get tagname, list to construct a valid xml element + (map (compose list car) + (append + (dead-properties resource) + (live-properties resource)))))) + (prop + (propfind-selected-properties + resource + (map car (cdr prop)))))) + (else + `(,(xml webdav 'status) + ,(http-status-line 404)))))))))) + + + + +(define-method (select-components-by-comp-filter (this <calendar-collection-resource>) comp-filter) + ) + + +;;; TODO +(define (overlaps? a b) + #t) + +(define (comp-filter scope filter) + ;; CaldDAV 9.7.1 + (or (and (null? (children filter)) + (eq? (attribute filter 'name) + (type scope))) + (and (find-element (xml caldav 'is-not-defined) + (children filter)) + (not + (find (lambda (el) (eq? (type el) (attribute filter 'name))) + (children scope)))) + (and (cond ((find-element (xml caldav 'time-range) + (children filter)) + => (lambda (range) + (overlaps? scope range))) + (else #f)) + (every (lambda (filt) (comp-filter scope filt)) (children filter))) + (every (lambda (filt) (comp-filter scope filt)) (children filter)))) diff --git a/module/calp/webdav/resource/calendar/object.scm b/module/calp/webdav/resource/calendar/object.scm new file mode 100644 index 00000000..82a8c18e --- /dev/null +++ b/module/calp/webdav/resource/calendar/object.scm @@ -0,0 +1,76 @@ +(define-module (calp webdav resource calendar object) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :use-module ((vcomponent formats xcal) :prefix #{xcs:}#) + :use-module ((vcomponent) :prefix vcs-) + :use-module ((calp namespaces) :select (webdav)) + :use-module (calp webdav property) + :use-module (sxml namespaced) + + :export (<calendar-object-resource> + calendar-object-resource? + component) + ) + +;;; content% + +(define-class <calendar-object-resource> (<resource>) + (component getter: component + init-keyword: component:)) + + + +(define-method (is-collection? (_ <calendar-object-resource>)) + #f) + + + +(define-method (children (_ <calendar-object-resource>)) + '()) + +(define (calendar-object-resource? x) + (is-a? x <calendar-object-resource>)) + +(define-method (content (self <calendar-object-resource>) content-type) + (case content-type + ((text/calendar) + (call-with-output-string (lambda (port) (ics:serialize (content% self) port)))) + ((application/calendar+xml) + (call-with-output-string (lambda (port) (xcs:serialize (content% self) port)))) + ;; ((text/html)) + ;; ((application/xhtml+xml)) + ;; ((application/calendar+json)) + (else (content self 'text/calendar)) + ) + ) + +(define-method (creationdate (self <calendar-object-resource>)) + (propstat 200 + `((,(xml webdav 'creationdate) + (-> (content self) + (prop 'CREATED) + ;; TODO timezone + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + + +(define-method (getcontentlength (self <calendar-object-resource>)) + ;; TODO which representation should be choosen to calculate length? + (propstat 501 `((,(xml webdav 'getcontentlength))))) + + + +(define-method (getcontenttyype (self <calendar-object-resource>)) + ;; TODO different representations + (propstat 200 `((,(xml webdav 'getcontentlength) + "text/calendar")))) + + +(define-method (getlastmodified (self <calendar-object-resource>)) + (propstat 200 + `((,(xml webdav 'getlastmodified) + (string->datetime (prop (content self) 'LAST-MODIFIED) + "~Y~m~dT~H~M~S"))))) diff --git a/module/calp/webdav/resource/file.scm b/module/calp/webdav/resource/file.scm new file mode 100644 index 00000000..e2fec9a5 --- /dev/null +++ b/module/calp/webdav/resource/file.scm @@ -0,0 +1,192 @@ +(define-module (calp webdav resource file) + :use-module (srfi srfi-1) + :use-module (oop goops) + :use-module (hnh util) + :use-module (hnh util env) + :use-module (hnh util path) + :use-module (datetime) + :use-module (ice-9 popen) + :use-module (ice-9 rdelim) + :use-module (ice-9 ftw) + :use-module (sxml namespaced) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp namespaces) + :use-module (rnrs io ports) + :use-module (rnrs bytevectors) + :export (<file-resource> file-resource? root ; path + )) + +;;; Resources backed by the filesystem +(define-class <file-resource> (<resource>) + ;; Directory to act as root for this file tree. + ;; Should be inherited by all children + + ;; DO NOT export the setters. These fields needs to be carefully managed to + ;; ensure that they stay consistant with the @var{name} trail. + (root getter: root setter: set-root! init-value: "/" init-keyword: root:) + (path getter: path setter: set-path! init-value: "/" init-keyword: path:)) + +(define-method (write (self <file-resource>) port) + (display + (format #f "#<<file-resource> name=~s, root=~s, path=~s>" + (name self) + (root self) + (path self)) + port)) + +(define (file-resource? x) + (is-a? x <file-resource>)) + +;; TODO this is global, so most certanly leaks info between different +;; <file-resource> trees. +(define *realized-resource* (make-hash-table)) + +(define (file-resource-for-path root path) + (or (hash-ref *realized-resource* path) + (let ((resource (make <file-resource> + ;; href: + root: root + ; local-path: path + name: (basename path) + path: path + ))) + (hash-set! *realized-resource* path resource) + resource))) + +(define (filepath self) + (path-append (root self) + (path self))) + +(define-method (children (self <file-resource>)) + ;; (format (current-error-port) "root=~s, path=~s~%" + ;; (root self) + ;; (local-path self)) + (when (is-collection? self) + (map (lambda (p) (file-resource-for-path (root self) + (path-append (path self) + p))) + (remove (lambda (p) (member p '("." ".."))) + (scandir (filepath self)))))) + +(define-method (is-collection? (self <file-resource>)) + (eq? 'directory (stat:type (stat (filepath self))))) + +(define (file-creation-date path) + (let ((pipe (open-pipe* OPEN_READ "stat" "-c" "%W" path))) + (begin1 (unix-time->datetime (read pipe)) + (close-pipe pipe)))) + +(define (mimetype path) + (let ((pipe (open-pipe* OPEN_READ "file" "--brief" "--mime-type" + path))) + (begin1 (read-line pipe) + (close-pipe pipe)))) + +(define-method (creationdate (self <file-resource>)) + (propstat 200 + `((,(xml webdav 'creationdate) + ,(with-locale1 + LC_TIME "C" + (lambda () + (-> (file-creation-date (filepath self)) + (datetime->string "~Y-~m-~dT~H:~M:~S~Z")))))))) + +(define-method (content (self <file-resource>)) + (if (is-collection? self) + #f + (call-with-input-file (filepath self) + get-bytevector-all binary: #t))) + +(define-method (set-content! (self <file-resource>) data) + (cond ((bytevector? data) + (call-with-output-file (filepath self) + (lambda (port) (put-bytevector port data)))) + ((string? data) + (call-with-output-file (filepath self) + (lambda (port) (put-string port data)))) + (else (scm-error 'misc-error "set-content!<file-resource>" + "Content must be bytevector or string: ~s" + (list data) #f)))) + + +(define-method (setup-new-resource! (self <file-resource>) + (parent <file-resource>)) + (next-method) + (set-root! self (root parent)) + (set-path! self (path-append (path parent) (name self)))) + +(define-method (setup-new-collection! (self <file-resource>) + (parent <file-resource>)) + (next-method) + (mkdir (filepath self))) + +(define-method (cleanup-resource (self <file-resource>)) + ((if (is-collection? self) + rmdir + delete-file) + (filepath self))) + +(define-method (content-length (self <file-resource>)) + (-> (filepath self) stat stat:size)) + + +(define-method (getcontenttype (self <file-resource>)) + ;; TODO 404 if collection + ;; Or just omit it? + (propstat 200 `((,(xml webdav 'getcontenttype) + ,(mimetype (filepath self)))))) + +(define-method (getlastmodified (self <file-resource>)) + (propstat 200 + `((,(xml webdav 'getlastmodified) + ,(with-locale1 + LC_TIME "C" + (lambda () + (-> (filepath self) + stat + stat:mtime + unix-time->datetime + (datetime->string "~a, ~d ~b ~Y ~H:~M:~S GMT")))))))) + +;; (define (xattr-key xml-el) +;; (format #f "caldav.~a" +;; (base64-encode +;; (format #f "~a:~a" +;; (xml-element-namespace xml-el) +;; (xml-element-tagname xml-el))))) + + +;; (define-method (set-dead-property (self <file-resource>) value) +;; (unless (and (list? value) +;; (xml-element? (car value))) +;; (scm-error 'misc-error "set-dead-property" +;; "Invalid value, expected namespaced sxml" +;; '() #f)) +;; (catch #t +;; (lambda () +;; (lambda () +;; (xattr-set! +;; (filename self) +;; (xattr-key (car value)) +;; (with-output-to-string +;; (lambda () (namespaced-sxml->xml value)))))) +;; (lambda _ (next-method)))) + + +;; (define-method (get-dead-property (self <file-resource>) +;; xml-el) +;; (catch #t +;; (lambda () +;; (propstat 200 +;; (list +;; (xattr-ref (filepath self) +;; (xattr-key el))))) +;; (lambda _ (next-method)))) + + +;; (define-method (remove-dead-property (self <file-resource>) +;; xml-el) +;; (catch #t +;; (lambda () (xattr-remove! (filepath self) xml-el)) +;; (lambda _ (next-method)))) diff --git a/module/calp/webdav/resource/virtual.scm b/module/calp/webdav/resource/virtual.scm new file mode 100644 index 00000000..1d2d5d31 --- /dev/null +++ b/module/calp/webdav/resource/virtual.scm @@ -0,0 +1,71 @@ +(define-module (calp webdav resource virtual) + :use-module (oop goops) + :use-module (datetime) + :use-module (rnrs bytevectors) + :use-module (hnh util) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp namespaces) + :export (<virtual-resource> + virtual-resource? + virtual-ns + ;; content + isvirtual + ) + ) + +(define virtual-ns (string->symbol "http://example.com/virtual")) + +(define-class <virtual-resource> (<resource>) + (content* init-value: #vu8() + init-keyword: content: + accessor: content*) + (creation-time init-form: (current-datetime) + init-keyword: creation-time: + getter: creation-time)) + +(define (virtual-resource? x) + (is-a? x <virtual-resource>)) + +(define-method (write (self <virtual-resource>) port) + (format port "#<<virtual-resource> name=~s, creation-time=~s, content=~s>" + (name self) + (creation-time self) + (content self))) + +(define-method (live-properties (self <virtual-resource>)) + (append + (next-method) + (list (cons (xml-element-hash-key (xml virtual-ns 'isvirtual)) (make-live-property isvirtual set-isvirtual!))))) + +(define-method (content (self <virtual-resource>)) + (content* self)) + +(define-method (set-content! (self <virtual-resource>) data) + (set! (content* self) data)) + +(define-method (creationdate (self <virtual-resource>)) + (propstat 200 + (list + (list (xml webdav 'creationdate) + (-> (creation-time self) + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + + +(define-method (getcontenttype (self <resource>)) + (propstat 200 + (list + (list (xml webdav 'getcontenttype) + "application/binary")))) + +(define-method (isvirtual (self <virtual-resource>)) + (propstat 200 + (list + (list (xml virtual-ns 'isvirtual) + "true")))) + + +(define-method (set-isvirtual! (self <virtual-resource>) _) + (throw 'protected-resource "isvirtual")) |