diff options
Diffstat (limited to 'module')
103 files changed, 7822 insertions, 619 deletions
diff --git a/module/c/lex.scm b/module/c/lex.scm index 34e52d88..977f497f 100644 --- a/module/c/lex.scm +++ b/module/c/lex.scm @@ -65,16 +65,16 @@ (define-peg-pattern char all (and (ignore "'") (or escaped-char peg-any) (ignore "'"))) +;; whitespace +(define-peg-pattern ws none + (or " " " " "\n")) + (define-peg-pattern* operator all `(or ,@(map symbol->string symbol-binary-operators) ,@(map (lambda (op) `(and ,(symbol->string op) ws)) wordy-binary-operators))) -;; whitespace -(define-peg-pattern ws none - (or " " " " "\n")) - ;; space (for when whitespace is optional) (define-peg-pattern sp none (* ws)) diff --git a/module/calp.scm b/module/calp.scm index 81268cbb..b1952547 100644 --- a/module/calp.scm +++ b/module/calp.scm @@ -1,4 +1,9 @@ -(define-module (calp)) +(define-module (calp) + :export (version prodid)) ;; Update me on new release -(define-public version "0.6.1") +(define version "0.6.1") + +(define (prodid) + (format #f "-//hugo//calp ~a//EN" + (@ (calp) version))) 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")) diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm index d9a304b2..d6c84348 100644 --- a/module/datetime/instance.scm +++ b/module/datetime/instance.scm @@ -9,7 +9,7 @@ :export (zoneinfo)) (define-config tz-list '() - description: (_ "List of default zoneinfo files to be parsed")) + description: (G_ "List of default zoneinfo files to be parsed")) ;; TODO see (vcomponent uil instance), this has a similar problem with early load ;; Takes a list of zoneinfo files relative @@ -25,7 +25,7 @@ (() (define tz-list (tz-list)) (if (null? tz-list) - (warning (_ "Default zoneinfo only available when tz-dir and tz-list are configured")) + (warning (G_ "Default zoneinfo only available when tz-dir and tz-list are configured")) (self tz-list))) ((file-list) (provide 'zoneinfo) diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm index 46f93a61..53eba014 100644 --- a/module/datetime/timespec.scm +++ b/module/datetime/timespec.scm @@ -42,7 +42,7 @@ (define (timespec-add . specs) (unless (apply eqv? (map timespec-type specs)) - (warning (_ "Adding timespecs of differing types"))) + (warning (G_ "Adding timespecs of differing types"))) (reduce (lambda (spec done) (cond diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 1c9b34ee..acfb17a8 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -186,7 +186,7 @@ day: (string->number day)) time: (timespec-time timespec) tz: (case (timespec-type timespec) - [(#\s) (warning (_ "what even is \"Standard time\"‽")) ""] + [(#\s) (warning (G_ "what even is \"Standard time\"‽")) ""] [(#\w) #f] ;; Since we might represent times before UTC existed ;; this is a bit of a lie. But it should work. @@ -274,8 +274,8 @@ ;; They were removed since they were unused, uneeded, and was ;; technical dept. (scm-error 'misc-error "parse-zic-file" - (_ "Invalid key ~s. Note that leap seconds and expries rules aren't yet implemented.") - (list type) + (G_ "Invalid key ~s. Note that leap seconds and expries rules aren't yet implemented.") + (list (car tokens)) #f)))])))))) @@ -298,16 +298,16 @@ (for-each (lambda (group) (hashq-set! rules (car group) - (sort* (cadr group) + (sort* (cdr group) (lambda (a b) (if (eq? 'minimum) #t (< a b))) rule-from))) - (group-by rule-name (car it)))) + (group-by rule-name it))) ;; put zones in map (awhen (assoc-ref groups 'zone) (for-each (lambda (zone) (hash-set! zones (zone-name zone) (zone-entries zone))) - (car it))) + it)) ;; resolve links to extra entries in the zone map (awhen (assoc-ref groups 'link) @@ -316,9 +316,9 @@ (target (link-target link)) (target-item (hash-ref zones target #f))) (if (not target-item) - (warning (_ "Unresolved link, target missing ~a -> ~a") name target) + (warning (G_ "Unresolved link, target missing ~a -> ~a") name target) (hash-set! zones name target-item)))) - (car it))) + it)) (make-zoneinfo rules zones))) @@ -355,7 +355,7 @@ (day d base-day)))) tz: (case (timespec-type (rule-at rule)) ((#\w) #f) - ((#\s) (warning (_ "what even is \"Standard time\"‽")) #f) + ((#\s) (warning (G_ "what even is \"Standard time\"‽")) #f) ((#\u #\g #\z) "UTC")))) (let ((timespec (rule-at rule))) @@ -377,7 +377,7 @@ (case to ((maximum) #f) ((minimum) (scm-error 'misc-error "rule->rrule" - (_ "Check your input") + (G_ "Check your input") #f #f)) (else ;; NOTE I possibly need to check the start of @@ -390,7 +390,7 @@ (match (rule-on rule) ((? number? d) (set (bymonthday base) (list d))) (('last d) (set (byday base) (list (cons -1 d)))) - (('< wday base-day) (scm-error 'misc-error "rule->rrule" (_ "Counting backward for RRULES unsupported") #f #f)) + (('< wday base-day) (scm-error 'misc-error "rule->rrule" (G_ "Counting backward for RRULES unsupported") #f #f)) (('> wday base-day) ;; Sun<=25 ;; Sun>=8 @@ -412,14 +412,14 @@ [(#\z) ;; NOTE No zones seem to currently use %z formatting. ;; '%z' is NOT a format string, but information about another format string. - (warning (_ "%z not yet implemented")) + (warning (G_ "%z not yet implemented")) fmt-string] [else (scm-error 'misc-error "zone-format" ;; first slot is the errornous character, ;; second is the whole string, third is the index ;; of the faulty character. - (_ "Invalid format char ~s in ~s at position ~a") + (G_ "Invalid format char ~s in ~s at position ~a") (list (string-ref fmt-string (1+ idx)) fmt-string (1+ idx)) diff --git a/module/graphviz.scm b/module/graphviz.scm new file mode 100644 index 00000000..c2e3fa04 --- /dev/null +++ b/module/graphviz.scm @@ -0,0 +1,88 @@ +;;; Copyright © 2016 Roel Janssen <roel@gnu.org> +;;; +;;; This program is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; https://github.com/roelj/graphviz-guile/blob/master/graphviz.scm + +(define-module (graphviz) + :export (;; New graphs + graph + digraph + strictgraph + strictdigraph + readstring + read + + ;; New nodes/edges + node + edge + + ;; Setting/getting attribute values + setv + getv + + ;; Finding and obtaining names + nameof + findsubg + findnode + findedge + findattr + + ;; Graph navigators + headof + tailof + graphof + rootof + + ;; Obtain handles of proto node/edge for setting attribute values + protonode + protoedge + + ;; Iterators + ok + firstsubg + nextsubg + firstsupg + nextsupg + firstedge + nextedge + firstout + nextout + firsthead + nexthead + firstin + nextin + firstnode + nextnode + firstattr + nextattr + + ;; Remove graph objects + rm + + ;; Layout + layout + render + renderresult + renderchannel + renderdata + write)) + +(define lib "graphviz/guile/libgv_guile") + +(load-extension + (format #f "~a/~a.so" + "/usr/lib" ; LIBRARY PATH + lib) + "SWIG_init") diff --git a/module/hnh/module-introspection.scm b/module/hnh/module-introspection.scm new file mode 100644 index 00000000..83e561f1 --- /dev/null +++ b/module/hnh/module-introspection.scm @@ -0,0 +1,22 @@ +(define-module (hnh module-introspection) + :use-module (srfi srfi-1) + :use-module (hnh util) + :export (unique-symbols + find-module-declaration + module-declaration? + )) + + +(define (unique-symbols tree) + (uniq + (sort* (filter symbol? (flatten tree)) + string<? symbol->string))) + +(define (module-declaration? form) + (cond ((null? form) #f) + ((not (pair? form)) #f) + (else (eq? 'define-module (car form))))) + +(define (find-module-declaration forms) + (and=> (find module-declaration? forms) + cadr)) diff --git a/module/hnh/module-introspection/all-modules.scm b/module/hnh/module-introspection/all-modules.scm new file mode 100644 index 00000000..1bf39e1e --- /dev/null +++ b/module/hnh/module-introspection/all-modules.scm @@ -0,0 +1,55 @@ +(define-module (hnh module-introspection all-modules) + :use-module (ice-9 regex) + :use-module (srfi srfi-1) + :use-module (ice-9 ftw) + :use-module (ice-9 match) + :use-module (hnh util path) + :use-module (hnh module-introspection) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :export (all-files-and-modules-under-directory + all-modules-under-directory + fs-find-base fs-find + module-file-mapping + )) + +(define (fs-find dir) + (define files '()) + (ftw dir (lambda args (set! files (cons args files)) #t)) + files) + +;; (define (fs-find proc dir) +;; (filter proc (fs-find-base dir))) + +(define (all-files-and-modules-under-directory dir) + (define re (make-regexp "\\.scm$")) + + (define files + (map car + (filter (match-lambda ((filename _ 'regular) + (and (regexp-exec re filename) + (not (file-hidden? filename)))) + (_ #f)) + (fs-find dir)))) + + (map (lambda (file) + (list file + (call-with-input-file file + (compose find-module-declaration get-forms)))) + files)) + +(define (all-modules-under-directory dir) + "Returns two values, all scm files in dir, and all top +level modules in those files" + + (define pairs (all-files-and-modules-under-directory dir)) + (values + (map car pairs) + (filter identity (map cadr pairs)))) + +;; Returns an association list from module names the modules +;; containing filename +(define (module-file-mapping dir) + (filter + car + (map (lambda (pair) (cons (cadr pair) (car pair))) + (all-files-and-modules-under-directory dir)))) diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm new file mode 100644 index 00000000..3bed2a5e --- /dev/null +++ b/module/hnh/module-introspection/module-uses.scm @@ -0,0 +1,116 @@ +(define-module (hnh module-introspection module-uses) + :use-module (ice-9 match) + :use-module (hnh util) + :use-module ((srfi srfi-1) :select (concatenate)) + :use-module ((srfi srfi-88) :select (string->keyword)) + :use-module (rnrs records syntactic) + :export (module-uses*)) + +;;; Commentary: +;;; Static analyze version of guile's built in module-uses. +;;; Will give a less accurate result, but in turn doesn't +;;; require that the target module compiles. +;;; Code: + +(define-record-type (module make-module% module?) + (fields name select hide prefix renamer version)) + +(define* (make-module name key: + (select #f) + (hide '()) + (prefix #f) + (renamer #f) + (version #f)) + (make-module% name select hide prefix renamer version)) + +(define (module->list module) + (append + (list (module-name module)) + (awhen (module-select module) `(#:select ,it)) + (awhen (module-hide module) `(#:hide ,it)) + (awhen (module-prefix module) `(#:prefix ,it)) + (awhen (module-renamer module) `(#:renamer ,it)) + (awhen (module-version module) `(#:version ,it)))) + +;; Normalizes keywords (#:key) and pseudo keywords (:key) used by define-module syntax. +(define (normalize-keyword kw-or-symb) + (cond ((symbol? kw-or-symb) + (-> (symbol->string kw-or-symb) + (string-drop 1) + string->keyword)) + ((keyword? kw-or-symb) + kw-or-symb) + (else (error "Bad keyword like" kw-or-symb)))) + +;; Takes one argument as taken by @code{use-modules}, or following #:use-module +;; in @code{define-module}. +;; returns a list on the form +;; (module-name (key value) ...) +;; where module name is something like (srfi srfi-1) +(define (parse-interface-specification interface-specification) + (match interface-specification + ;; matches `((srfi srfi-1) :select (something)) + (((parts ...) args ...) + (apply make-module + `(,parts ,@(concatenate + (map (lambda (pair) + (cons (normalize-keyword (car pair)) + (cdr pair))) + (group args 2)))))) + ;; matches `(srfi srfi-1) + ((parts ...) + (make-module parts)) + (_ (error "Bad module declaration")))) + +;; Finds all define-module forms, and returns what they +;; pull in (including autoloads) +(define (module-declaration-uses forms) + (match forms + (('define-module module-name directives ...) + (let loop ((directives directives)) + (cond ((null? directives) '()) + ((memv (car directives) '(#:use-module #{:use-module}#)) + (cons (parse-interface-specification (cadr directives)) + (loop (cddr directives)))) + ((memv (car directives) '(#:autoload #{:autoload}#)) + (cons (cadr directives) + (loop (cdddr directives)))) + (else (loop (cdr directives)))))) + ((form forms ...) + (append (module-declaration-uses form) + (module-declaration-uses forms))) + (_ '()))) + +;; find all use-modules forms, and return what they pull in +;; NOTE this will pull in all forms looking like a (use-modules ...) +;; form, even if they are quoted, or in a cond-expand +(define (module-use-module-uses forms) + (match forms + (('use-modules modules ...) + (map parse-interface-specification modules)) + ((form forms ...) + (append (module-use-module-uses form) + (module-use-module-uses forms))) + (_ '()))) + +;; find all explicit module references (e.g. +;; (@ (module) var) and (@@ (module) private-var)), +;; and return those modules +(define (module-refer-uses forms) + (match forms + (((or '@ '@@) module symb) + (list (make-module module select: (list symb)))) + ((form forms ...) + (append (module-refer-uses form) + (module-refer-uses forms))) + (_ '()))) + +;; List of all modules pulled in in any of forms +;; Returns a list where each element suitable to have +;; resolve-interface applied to it. +(define (module-uses* forms) + (map module->list + (append + (module-declaration-uses forms) + (module-use-module-uses forms) + (module-refer-uses forms)))) diff --git a/module/hnh/module-introspection/static-util.scm b/module/hnh/module-introspection/static-util.scm new file mode 100644 index 00000000..7593ce3c --- /dev/null +++ b/module/hnh/module-introspection/static-util.scm @@ -0,0 +1,9 @@ +(define-module (hnh module-introspection static-util) + :export (get-forms)) + +(define (get-forms port) + (let loop ((done '())) + (let ((form (read port))) + (if (eof-object? form) + done + (loop (cons form done)))))) diff --git a/module/hnh/test/testrunner.scm b/module/hnh/test/testrunner.scm new file mode 100644 index 00000000..384afd4b --- /dev/null +++ b/module/hnh/test/testrunner.scm @@ -0,0 +1,126 @@ +(define-module (hnh test testrunner) + :use-module (srfi srfi-64) + :use-module (hnh test util) + :use-module (ice-9 pretty-print) + :use-module (ice-9 format) + :export (verbose? construct-test-runner) + ) + +(define verbose? (make-parameter #f)) + +(define (pp form indent prefix-1) + (let ((prefix (make-string (+ (string-length indent) + (string-length prefix-1)) + #\space))) + (string-replace-head + (with-output-to-string + (lambda () (pretty-print + form + display?: #t + per-line-prefix: prefix + width: (- 79 (string-length indent))))) + (string-append indent prefix-1)))) + + +(define (construct-test-runner) + (define runner (test-runner-null)) + (define depth 0) + ;; end of individual test case + (test-runner-on-test-begin! runner + (lambda (runner) + (test-runner-aux-value! runner (transform-time-of-day (gettimeofday))))) + (test-runner-on-test-end! runner + (lambda (runner) + (when (verbose?) (display (make-indent depth))) + (case (test-result-kind runner) + ((pass) (display (green "X"))) + ((fail) (display (red "E"))) + ((xpass) (display (yellow "X"))) + ((xfail) (display (yellow "E"))) + ((skip) (display (yellow "-")))) + (when (or (verbose?) (eq? 'fail (test-result-kind))) + (format #t " ~a~%" + (cond ((test-runner-test-name runner) + (negate string-null?) => identity) + ((test-result-ref runner 'expected-value) + => (lambda (p) (with-output-to-string + (lambda () + (display (bold "[SOURCE]: ")) + (truncated-print p width: 60)))))))) + (when (eq? 'fail (test-result-kind)) + (cond ((test-result-ref runner 'actual-error) + => (lambda (err) + (if (and (list? err) + (= 5 (length err))) + (let ((err (list-ref err 0)) + (proc (list-ref err 1)) + (fmt (list-ref err 2)) + (args (list-ref err 3))) + (format #t "~a~a in ~a: ~?~%" + (make-indent (1+ depth)) + err proc fmt args)) + (format #t "~aError: ~s~%" (make-indent (1+ depth)) err)))) + (else + (let ((unknown-expected (gensym)) + (unknown-actual (gensym))) + (let ((expected (test-result-ref runner 'expected-value unknown-expected)) + (actual (test-result-ref runner 'actual-value unknown-actual))) + (let ((indent (make-indent (1+ depth)))) + (if (eq? expected unknown-expected) + (format #t "~aAssertion failed~%" indent) + (begin + (display (pp expected indent "Expected: ")) + (display (pp actual indent "Received: ")) + (let ((d (diff (pp expected "" "") + (pp actual "" "")))) + (display + (string-join + (map (lambda (line) (string-append indent "|" line)) + (string-split d #\newline)) + "\n" 'suffix)))))))))) + (format #t "~aNear ~a:~a~%" + (make-indent (1+ depth)) + (test-result-ref runner 'source-file) + (test-result-ref runner 'source-line)) + (pretty-print (test-result-ref runner 'source-form) + (current-output-port) + per-line-prefix: (string-append (make-indent (1+ depth)) "> ") + )) + + (let ((start (test-runner-aux-value runner)) + (end (transform-time-of-day (gettimeofday)))) + (when (< (µs 1) (- end start)) + (format #t "~%Slow test: ~s, took ~a~%" + (test-runner-test-name runner) + (exact->inexact (/ (- end start) (µs 1))) + ))))) + + ;; on start of group + (test-runner-on-group-begin! runner + ;; count is number of #f + (lambda (runner name count) + (if (<= depth 1) + (format #t "~a ~a ~a~%" + (make-string 10 #\=) + name + (make-string 10 #\=)) + (when (verbose?) + (format #t "~a~a~%" (make-string (* depth 2) #\space) name))) + (set! depth (1+ depth)))) + (test-runner-on-group-end! runner + (lambda (runner) + (set! depth (1- depth)) + (when (<= depth 1) + (newline)))) + ;; after everything else is done + (test-runner-on-final! runner + (lambda (runner) + (format #t "Guile version ~a~%~%" (version)) + (format #t "pass: ~a~%" (test-runner-pass-count runner)) + (format #t "fail: ~a~%" (test-runner-fail-count runner)) + (format #t "xpass: ~a~%" (test-runner-xpass-count runner)) + (format #t "xfail: ~a~%" (test-runner-xfail-count runner)) + )) + + runner) + diff --git a/module/hnh/test/util.scm b/module/hnh/test/util.scm new file mode 100644 index 00000000..3d51e162 --- /dev/null +++ b/module/hnh/test/util.scm @@ -0,0 +1,57 @@ +(define-module (hnh test util) + :use-module ((hnh util) :select (begin1)) + :use-module ((hnh util io) :select (call-with-tmpfile)) + :use-module (ice-9 pretty-print) + :use-module ((ice-9 rdelim) :select (read-string)) + :use-module ((ice-9 popen) + :select (open-pipe* + close-pipe)) + :export (µs + transform-time-of-day + green + red + yellow + bold + make-indent + string-replace-head + diff + )) + +(define (µs x) + (* x #e1e6)) + +(define (transform-time-of-day tod) + (+ (* (µs 1) (car tod)) + (cdr tod))) + +(define (escaped sequence string) + (format #f "\x1b[~am~a\x1b[m" sequence string)) + +;; Terminal output formatting. Doesn NOT compose +(define (green s) (escaped 32 s)) +(define (red s) (escaped 31 s)) +(define (yellow s) (escaped 33 s)) +(define (bold s) (escaped 1 s)) + +(define (make-indent depth) + (make-string (* 2 depth) #\space)) + +(define (string-replace-head s1 s2) + (string-replace s1 s2 + 0 (string-length s2))) + + +(define diff-cmd + ;; '("diff") + '("git" "diff" "--no-index" "--color-moved=default" "--color=always"; "--word-diff=color" + ) + ) + +(define (diff s1 s2) + (let ((filename1 (call-with-tmpfile (lambda (p f) (pretty-print s1 p display?: #t) f))) + (filename2 (call-with-tmpfile (lambda (p f) (pretty-print s2 p display?: #t) f)))) + (let ((pipe (apply open-pipe* + OPEN_READ + (append diff-cmd (list filename1 filename2))))) + (begin1 (read-string pipe) + (close-pipe pipe))))) diff --git a/module/hnh/test/xmllint.scm b/module/hnh/test/xmllint.scm new file mode 100644 index 00000000..95362607 --- /dev/null +++ b/module/hnh/test/xmllint.scm @@ -0,0 +1,27 @@ +(define-module (hnh test xmllint) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((rnrs io ports) :select (get-string-all)) + :use-module ((hnh util) :select (begin1)) + :export (xmllint) + ) + + +(define (xmllint str) + (let ((in* out (car+cdr (pipe))) + (in out* (car+cdr (pipe))) + (cmdline (string-split "xmllint --format -" #\space))) + (define pid + (spawn (car cmdline) cmdline + input: in* + output: out*)) + (close-port in*) + (close-port out*) + + (display str out) + (force-output out) + (close-port out) + + (begin1 (get-string-all in) + (close-port in)))) diff --git a/module/hnh/util.scm b/module/hnh/util.scm index d2c0dd5f..c88a029e 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -17,6 +17,7 @@ find-extreme find-min find-max filter-sorted != + init+last take-to string-take-to string-first @@ -55,6 +56,12 @@ assq-ref-all assv-ref-all + uniqx + uniq + univ + uniqv + unique + vector-last ->string @@ -64,6 +71,10 @@ :replace (set! define-syntax when unless)) +(cond-expand + (guile-3 (use-modules ((ice-9 copy-tree) :select (copy-tree)))) + (else)) + ((@ (guile) define-syntax) define-syntax (syntax-rules () ((_ (name args ...) body ...) @@ -112,6 +123,9 @@ ((for (<var> <vars> ...) in <collection> b1 body ...) (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ...) b1 body ...]) <collection>)) + ((for (<var> <vars> ... . <tail>) in <collection> b1 body ...) + (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ... . <tail>) b1 body ...]) + <collection>)) ((for <var> in <collection> b1 body ...) (map (lambda (<var>) b1 body ...) <collection>)))) @@ -137,9 +151,12 @@ +;; TODO this is called flip in Haskell land (define (swap f) (lambda args (apply f (reverse args)))) - +;; Swap would be +;; (define (swap p) +;; (xcons (car p) (cdr p))) ;; Allow set to work on multiple values at once, ;; similar to Common Lisp's @var{setf} @@ -240,6 +257,12 @@ ;; (define (!= a b) (not (= a b))) (define != (negate =)) + +(define (init+last l) + (let ((last rest (car+cdr (reverse l)))) + (values (reverse rest) last))) + + (define (take-to lst i) "Like @var{take}, but might lists shorter than length." (if (> i (length lst)) @@ -307,7 +330,8 @@ (define (kvlist->assq kvlist) (map (lambda (pair) - (cons (keyword->symbol (car pair)) (cdr pair))) + (cons (keyword->symbol (car pair)) + (cadr pair))) (group kvlist 2))) (define* (assq-limit alist optional: (number 1)) @@ -320,8 +344,7 @@ (for value in lst (let ((key (proc value))) (hash-set! h key (cons value (hash-ref h key '()))))) - ;; NOTE changing this list to cons allows the output to work with assq-merge. - (hash-map->list list h))) + (hash-map->list cons h))) ;; (split-by '(0 1 2 3 4 2 5 6) 2) ;; ⇒ ((0 1) (3 4) (5 6)) @@ -383,7 +406,7 @@ (reverse (cons (map list last) rest )))))) ;; Given an arbitary tree, do a pre-order traversal, appending all strings. -;; non-strings allso allowed, converted to strings and also appended. +;; non-strings also allowed, converted to strings and also appended. (define (string-flatten tree) (cond [(string? tree) tree] [(list? tree) (string-concatenate (map string-flatten tree))] @@ -506,6 +529,19 @@ (define (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) +(define (uniqx = lst) + (cond ((null? lst) lst) + ((null? (cdr lst)) lst) + ((and (pair? lst) + (= (car lst) (cadr lst))) + (uniqx = (cons (car lst) (cddr lst)))) + (else (cons (car lst) + (uniqx = (cdr lst)))))) + +(define (uniq lst) (uniqx eq? lst)) +(define (univ lst) (uniqx eqv? lst)) +(define (unique lst) (uniqx equal? lst)) + (define (vector-last v) @@ -517,9 +553,12 @@ (define-syntax catch* - (syntax-rules () + (syntax-rules (pre-unwind) + ((_ thunk ((pre-unwind key) handler)) + (with-throw-handler (quote key) thunk handler)) ((_ thunk (key handler)) (catch (quote key) thunk handler)) - ((_ thunk (key handler) rest ...) - (catch* (lambda () (catch (quote key) thunk handler)) + + ((_ thunk pair rest ...) + (catch* (lambda () (catch* thunk pair)) rest ...)))) diff --git a/module/hnh/util/env.scm b/module/hnh/util/env.scm index 18ec0543..32ea1cc1 100644 --- a/module/hnh/util/env.scm +++ b/module/hnh/util/env.scm @@ -1,5 +1,7 @@ (define-module (hnh util env) - :export (let-env with-working-directory)) + :export (let-env + with-working-directory + with-locale1)) (define-syntax let-env (syntax-rules () @@ -33,3 +35,12 @@ thunk (lambda () (chdir old-cwd))))) + +(define-syntax-rule (with-locale1 category locale thunk) + (let ((old #f)) + (dynamic-wind + (lambda () + (set! old (setlocale category)) + (setlocale category locale)) + thunk + (lambda () (setlocale category old))))) diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm index d638ebb4..09900f8d 100644 --- a/module/hnh/util/io.scm +++ b/module/hnh/util/io.scm @@ -4,7 +4,9 @@ :export (open-input-port open-output-port read-lines - with-atomic-output-to-file)) + with-atomic-output-to-file + call-with-tmpfile + ->port)) (define (open-input-port str) (if (string=? "-" str) @@ -62,3 +64,19 @@ ;; counted on, since anything with an unspecified return ;; value might as well return #f) #f)))) + +(define* (call-with-tmpfile proc key: (tmpl "/tmp/file-XXXXXXX")) + (let* ((filename (string-copy tmpl)) + (port (mkstemp! filename))) + (with-continuation-barrier + (lambda () + (begin1 + (proc port filename) + (close-port port)))))) + +(define (->port port-or-string) + (cond ((port? port-or-string) port-or-string) + ((string? port-or-string) (open-input-string port-or-string)) + (else (scm-error 'misc-error "->port" + "Not a port or string" + (list port-or-string) #f)))) diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index ea081e85..b0991073 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -3,15 +3,20 @@ :use-module (srfi srfi-71) :use-module (hnh util) :export (path-append + path-absolute? path-join path-split file-hidden? filename-extension - realpath)) + realpath + relative-to)) (define // file-name-separator-string) (define /? file-name-separator?) +(define path-absolute? absolute-file-name?) + +;; TODO remove intermidiate period components (define (path-append . strings) (fold (lambda (s done) (string-append @@ -87,3 +92,31 @@ (if (absolute-file-name? filename) filename (path-append (getcwd) filename))) + + +(define (relative-to base path) + ;; (typecheck base string?) + ;; (typecheck path string?) + + (when (string-null? base) + (error "Base can't be empty" )) + + (let ((base (if (absolute-file-name? base) + base + (path-append (getcwd) base)))) + + (cond ((equal? '("") base) path) + ((not (absolute-file-name? path)) + (path-append base path)) + (else + (let loop ((a (path-split base)) + (b (path-split path))) + (cond + ((null? a) (path-join b)) + ((null? b) path) + ((string=? (car a) (car b)) (loop (cdr a) (cdr b))) + (else + (path-join + (append + (make-list (length a) "..") + (drop b (length a))))))))))) diff --git a/module/hnh/util/state-monad.scm b/module/hnh/util/state-monad.scm new file mode 100644 index 00000000..91201583 --- /dev/null +++ b/module/hnh/util/state-monad.scm @@ -0,0 +1,120 @@ +;;; Commentary: +;;; A state monad similar to (and directly influenced by) the one found in in +;;; Haskell +;;; Each procedure can either explicitly take the state as a curried last +;;; argument, or use the `do' notation, which handles that implicitly. +;;; Each procedure MUST return two values, where the second value is the state +;;; value which will be chained. +;;; +;;; Code borrowed from guile-dns +;;; Code: + +(define-module (hnh util state-monad) + :use-module (ice-9 curried-definitions) + :replace (do mod) + :export (with-temp-state + <$> return get get* put put* sequence lift + eval-state exec-state)) + +(define-syntax do + (syntax-rules (<- let =) + ((_ (a ...) <- b rest ...) + (lambda state-args + (call-with-values (lambda () (apply b state-args)) + (lambda (a* . next-state) + (apply (lambda (a ...) + (apply (do rest ...) + next-state)) + a*))))) + ((_ a <- b rest ...) + (lambda state-args + (call-with-values (lambda () (apply b state-args)) + (lambda (a . next-state) + (apply (do rest ...) + next-state))))) + + ((_ a = b rest ...) + (let ((a b)) + (do rest ...))) + + ((_ a) + (lambda state (apply a state))) + ((_ a rest ...) + (lambda state + (call-with-values (lambda () (apply a state)) + (lambda (_ . next-state) + (apply (do rest ...) + next-state))))))) + + +(define (with-temp-state state* op) + (do old <- (get*) + (apply put* state*) + ret-value <- op + (apply put* old) + (return ret-value))) + + +(define (<$> f y) + (do tmp <- y + (return (f tmp)))) + +(define ((return x) . y) + (apply values x y)) + +(define ((get*) . state) + "Like @code{get}, but always returns a list" + (values state state)) + +(define ((get) fst . state) + "If state contains a single variable return that, otherwise, return a list of all variables in state" + (if (null? state) + (values fst fst) + (apply values (cons fst state) fst state))) + +(define ((put . new-state) fst . old-state) + (if (null? old-state) + (apply values fst new-state) + (apply values (cons fst old-state) new-state))) + +;; Like put, but doesn't return anything (useful) +(define ((put* . new-state) . _) + (apply values #f new-state)) + +(define (mod proc) + (do + a <- (get) + (put (proc a)))) + +;; ms must be a list of continuations +(define (sequence ms) + (if (null? ms) + (return '()) + (do + fst <- (car ms) + rest <- (sequence (cdr ms)) + (return (cons fst rest))))) + + +(define (lift proc . arguments) + (do xs <- (sequence arguments) + (return (apply proc xs)))) + + +;; Run state, returning value +(define (eval-state st init) + (call-with-values + (lambda () + (if (procedure? init) + (call-with-values init st) + (st init))) + (lambda (r . _) r))) + +;; Run state, returning state +(define (exec-state st init) + (call-with-values + (lambda () + (if (procedure? init) + (call-with-values init st) + (st init))) + (lambda (_ . v) (apply values v)))) diff --git a/module/hnh/util/uuid.scm b/module/hnh/util/uuid.scm index 68455243..8e0434e3 100644 --- a/module/hnh/util/uuid.scm +++ b/module/hnh/util/uuid.scm @@ -1,19 +1,19 @@ (define-module (hnh util uuid) :use-module (ice-9 format) - :export (uuid uuid-v4)) + :export (seed uuid uuid-v4)) -(define %seed (random-state-from-platform)) +(define seed (make-parameter (random-state-from-platform))) (define (uuid-v4) (define version 4) (define variant #b10) (format #f "~8'0x-~4'0x-~4'0x-~4'0x-~12'0x" - (random (ash 1 (* 4 8)) %seed) - (random (ash 1 (* 4 4)) %seed) + (random (ash 1 (* 4 8)) (seed)) + (random (ash 1 (* 4 4)) (seed)) (logior (ash version (* 4 3)) - (random (1- (ash 1 (* 4 3))) %seed)) + (random (1- (ash 1 (* 4 3))) (seed))) (logior (ash variant (+ 2 (* 4 3))) - (random (ash 1 (+ 2 (* 4 3))) %seed)) - (random (ash 1 (* 4 12)) %seed))) + (random (ash 1 (+ 2 (* 4 3))) (seed))) + (random (ash 1 (* 4 12)) (seed)))) (define uuid uuid-v4) diff --git a/module/scripts/README.md b/module/scripts/README.md new file mode 100644 index 00000000..37bee989 --- /dev/null +++ b/module/scripts/README.md @@ -0,0 +1,18 @@ +Guile Script Format +=================== + +### `%summary` +String containing a summary of what the module does. +Should be a single line. + +### `%include-in-guild-list` +Boolean, indicating if the script should be listed when running `guild help` or `guild list`. + +### `%help` +Longer help for module. If this variable isn't set the procedure `module-commentary` is run + +### `%synopsis` +Short help showing how to invoke the script. Should *not* include the guild command. + +### `main` +Procedure which is primary entry point. Gets remaining command line as its arguments (meaning it takes multiple arguments). diff --git a/module/scripts/module-dependants.scm b/module/scripts/module-dependants.scm new file mode 100644 index 00000000..6bda1917 --- /dev/null +++ b/module/scripts/module-dependants.scm @@ -0,0 +1,126 @@ +;;; Commentary: +;;; +;;; For a given module in the project, finds all other modules who uses that +;;; module, and break it down per symbol. +;;; +;;; Code: + +(define-module (scripts module-dependants) + :use-module (hnh util) + :use-module (hnh util path) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (ice-9 ftw) + :use-module (ice-9 curried-definitions) + :use-module (ice-9 format) + :use-module (texinfo string-utils) + :use-module (hnh module-introspection) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :export (main)) + +(define %summary "Print all modules which depend on module specified in target file.") +(define %synopsis "module-dependants TARGET-FILE") + +(define cstat (make-object-property)) + +(define (find-all-files-under directory) + (file-system-fold + ;; enter? + (lambda (path stat result) #t) + ;; leaf + (lambda (path stat result) + (set! (cstat path) stat) + (cons path result)) + ;; down + (lambda (path stat result) + (set! (cstat path) stat) + (cons path result)) + ;; up + (lambda (path state result) result) + ;; skip + (lambda (path stat result) result) + ;; error + (lambda (path stat errno result) result) + '() directory)) + +(define (regular-file? filename) + (eq? 'regular (stat:type (cstat filename)))) + +;; Does @var{filename} have the extension @var{ext}? +(define ((filename-extension? ext) filename) + (string=? ext (filename-extension filename))) + + +(define (main . args) + (define target-file (realpath (car args))) + (define target-forms + (reverse (call-with-input-file target-file get-forms))) + (define target-module + (find-module-declaration target-forms)) + ;; (define target-symbols (unique-symbols target-forms)) + ;; (write target-module) (newline) + + (define edges + (concatenate + (map (lambda (file) + (catch #t + (lambda () + (define forms (call-with-input-file file get-forms)) + (define module (and=> (-> forms find-module-declaration) resolve-module)) + (define source-symbols (unique-symbols forms)) + + (when module + (awhen (find (lambda (module) + (equal? target-module + (module-name module))) + (module-uses module)) + (let ((module-symbols (module-map (lambda (key value) key) it))) + ;; (display " ") + (map (lambda (symb) + (cons file symb)) + (lset-intersection eq? source-symbols module-symbols)) + )))) + ;; TODO many of these errors are due to the 'prefix and 'postfix + ;; read options being set for modules which expect them to be off. + (lambda (err proc fmt args data) + (format (current-error-port) + "ERROR when reading ~a: ~a in ~a: ~?~%" file err proc fmt args) + '()))) + + (delete target-file + (filter (filename-extension? "scm") + (filter regular-file? + (append-map (lambda (module-dir) + (find-all-files-under module-dir)) + %load-path))))))) + + + (define file-uses (make-hash-table)) + (define symbol-used-by (make-hash-table)) + + (for-each (lambda (edge) + (hashq-set! symbol-used-by (cdr edge) + (cons (car edge) (hashq-ref symbol-used-by (cdr edge) '()))) + (hash-set! file-uses (car edge) + (cons (cdr edge) (hash-ref file-uses (car edge) '())))) + edges) + + (for-each (lambda (pair) + (let ((symb files (car+cdr pair))) + (display (center-string (format #f " ~a (~a uses)" symb (length files)) + 80 #\= #\=)) + (newline) + (for-each (lambda (file) (format #t "• ~a~%" file)) files) + (newline))) + (sort* + (hash-map->list cons symbol-used-by) + string< (compose symbol->string car))) + + (display (center-string " Unused (except possibly internally) " 80 #\= #\=)) (newline) + (for-each (lambda (symb) (format #t "• ~a~%" symb)) + (lset-difference + eqv? + (module-map (lambda (k _) k) (resolve-interface target-module) ) + (hash-map->list (lambda (k _) k) symbol-used-by))) + + ) diff --git a/module/scripts/module-imports.scm b/module/scripts/module-imports.scm new file mode 100644 index 00000000..8f9ab1b8 --- /dev/null +++ b/module/scripts/module-imports.scm @@ -0,0 +1,80 @@ +;;; Commentary: +;;; +;;; Scripts which finds unused imports in each file. +;;; Uses Guile's module system reflection to find what is imported, +;;; but simple looks at all unique symbols in the source file for what +;;; is used, which might lead to some discrepancies. +;;; +;;; Code: + +(define-module (scripts module-imports) + :use-module ((srfi srfi-1) :select (lset-difference)) + :use-module ((rnrs lists) :select (remp filter partition)) + :use-module ((hnh module-introspection) :select (module-declaration? unique-symbols)) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :use-module ((hnh module-introspection module-uses) :select (module-uses*)) + :export (main) + ) + +(define %summary "List imports, and how many are used.") +(define %synopsis "module-imports filename") + +;;; Module use high scores +;;; $ grep -Ho '#\?:use-module' -R module | uniq -c | sort -n + +(define (main . args) + (define filename (car args)) + ;; TODO Module declaration can reside inside a cond-expand block + (define-values (module-declaration-list forms) + (partition module-declaration? + (reverse (call-with-input-file filename get-forms)))) + + ;; All symbols in source file, which are not in module declaration. + ;; Otherwise all explicitly imported symbols would be marked as + ;; used. + (define symbs (unique-symbols forms)) + ;; (format #t "~y" (find-module-declaration forms)) + ;; (format #t "~a~%" symbs) + + ;; TODO parameterize this to a command line argument + (define skip-list '((guile) + (guile-user) + (srfi srfi-1) + )) + + (define modules + ;; If we didn't find the module declaration + (if (null? module-declaration-list) + ;; Find symbols by best effort + (begin + (format #t "Using our make-shift module introspection~%") + (map (lambda (mod) (apply resolve-interface mod)) + (remp (lambda (mod) (member (car mod) skip-list)) + (module-uses* forms)))) + ;; If we did find the declaration, use the actual symbol in + (begin + (format #t "Using guile's true module introspection~%") + (remp (lambda (mod) (member (module-name mod) skip-list)) + (module-uses (resolve-module + (cadr (car module-declaration-list)))))))) + + (format #t "=== ~a ===~%" filename) + (for-each (lambda (mod) + + ;; all symbols imported from module + (define all-symbols (module-map (lambda (key value) key) mod)) + + ;; Thes subset of all imported symbols from module which are used + (define used-symbols + (filter (lambda (symb) (memv symb symbs)) + all-symbols)) + + (define used-count (length used-symbols)) + (define total-count (length (module-map list mod))) + + (format #t "~a/~a ~a~% used ~s~% unused ~s~%" + used-count total-count (module-name mod) + used-symbols + (lset-difference eq? all-symbols used-symbols))) + modules) + (newline)) diff --git a/module/scripts/peg-to-graph.scm b/module/scripts/peg-to-graph.scm new file mode 100644 index 00000000..afd7a4c3 --- /dev/null +++ b/module/scripts/peg-to-graph.scm @@ -0,0 +1,63 @@ +(define-module (scripts peg-to-graph) + :use-module ((graphviz) :prefix #{gv:}#) + :use-module ((hnh module-introspection) :select (unique-symbols)) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :use-module (srfi srfi-1) + :use-module (ice-9 match) + :use-module (hnh util options) + :use-module (ice-9 getopt-long) + :export (main)) + +(define option-spec + `((engine (value #t) + (description "Graphviz rendering engine to use. Defaults to DOT")) + (output (single-char #\o) + (value #t) + (description "Name of output pdf")))) + +(define %summary "Output peg-pattern relations as a graphviz graph.") +(define %synopsis "peg-to-graph [options] <filename>") +(define %help (format-arg-help option-spec)) + +(define peg-primitives + '(and or * + ? followed-by not-followed-by peg-any range + ignore capture peg)) + +(define (handle-peg-form! graph form) + (match form + (`(define-peg-pattern ,name ,capture ,body) + (let ((node (gv:node graph (format #f "~a" name)))) + (gv:setv node "style" + (case capture + ((all) "solid") + ((body) "dashed") + ((none) "dotted")))) + (for-each (lambda (symbol) + (gv:edge graph + (format #f "~a" name) + (format #f "~a" symbol))) + (remove (lambda (x) (memv x peg-primitives)) + (unique-symbols (list body))))))) + +(define (main . args) + (define options (getopt-long (cons "peg-to-graph" args) + (getopt-opt option-spec))) + (define engine (option-ref options 'engine "dot")) + (define output-file (option-ref options 'output "lex2.pdf")) + (define input-file (let ((filenames (option-ref options '() '()))) + (when (null? filenames) + (format #t "Usage: ~a~%" %summary) + (exit 1)) + (car filenames))) + + + (let ((graph (gv:digraph "G"))) + (for-each (lambda (form) handle-peg-form! graph form) + (filter (lambda (x) + (and (list? x) + (not (null? x)) + (eq? 'define-peg-pattern (car x)))) + (call-with-input-file input-file get-forms))) + + (gv:layout graph engine) + (gv:render graph "pdf" output-file))) diff --git a/module/scripts/use2dot-all.scm b/module/scripts/use2dot-all.scm new file mode 100644 index 00000000..18639619 --- /dev/null +++ b/module/scripts/use2dot-all.scm @@ -0,0 +1,191 @@ +(define-module (scripts use2dot-all) + :use-module ((scripts frisk) :select (make-frisker edge-type edge-up + edge-down)) + :use-module (srfi srfi-1) + :use-module (srfi srfi-88) + :use-module ((graphviz) :prefix gv.) + :use-module (hnh module-introspection all-modules) + :use-module (hnh util options) + :use-module (ice-9 getopt-long) + :export (main)) + +(define default-remove + '((srfi srfi-1) + (srfi srfi-9) + (srfi srfi-26) + (srfi srfi-41) + + (ice-9 match) + (ice-9 format))) + +(define option-spec + `((engine (value #t) + (description "Graphviz rendering engine to use. Defaults to FDP")) + (default-module + (single-char #\m) + (value #t) + (description "Set MOD as the default module, see guild help use2dot for more information. Defaults to (guile-user)")) + (output + (single-char #\o) + (value #t) + (description "Name of output PDF")) + (remove + (value #t) + (description "Modules to remove from check, usually since to many other modules depend on them.")) + (ignore-default-remove + (description "Don't ignore the modules which are ignored by default, which are:" (br) + ,@(append-map (lambda (item) (list (with-output-to-string (lambda () (display item))) '(br))) + default-remove))))) + +(define %synopsis "use2dot-all [options] <directory>") +(define %summary "Like use2dot, but for multiple modules") +(define %help (format-arg-help option-spec)) + +(define (remove-edges blacklist edges) + (remove (lambda (edge) + (or (member (edge-up edge) blacklist) + (member (edge-down edge) blacklist))) + edges)) + +(define (main . args) + (define options (getopt-long (cons "use2dot-all" args) + (getopt-opt option-spec) + stop-at-first-non-option: #t)) + (define default-module + (cond ((option-ref options 'default-module #f) + => (lambda (s) (let ((mod (with-input-from-string s read))) + (unless (list? mod) + (format (current-error-port) + "Module must be a list: ~s~%" mod) + (exit 1))))) + (else '(guile-user)))) + (define engine (option-ref options 'engine "fdp")) + (define output-file (option-ref options 'output "graph.pdf")) + (define custom-remove (cond ((option-ref options 'remove #f) + => (lambda (s) (let ((lst (with-input-from-string s read))) + (unless (and (list? lst) (every list? lst)) + (format (current-error-port) + "custom-remove must get a list of lists: ~s~%" lst) + (exit 1)) + lst))) + (else '()))) + (define to-remove (if (option-ref options 'default-remove #f) + custom-remove + (append custom-remove default-remove))) + (define target-directory + (let ((remaining (option-ref options '() '()))) + (cond ((null? remaining) + (format (current-error-port) "Target directory required~%") + (exit 1)) + (else (car remaining))))) + + ;; End of command line parsing + + (define scan (make-frisker `(default-module . ,default-module))) + + (define-values (files our-modules) + (all-modules-under-directory target-directory)) + + (define graph + (let ((graph (gv.digraph "G"))) + (gv.setv graph "color" "blue") + (gv.setv graph "compound" "true") + (gv.setv graph "overlap" "prism") + ;; (gv.setv graph "bgcolor" "blue") + graph)) + + (define count 0) + + (define colors + '("red" "green" "blue")) + + (define rem our-modules) + + ;; (for-each (lambda (key) + ;; + ;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) + ;; + ;; (define-values (use rem*) (partition (lambda (mod) (eq? key (car mod))) rem)) + ;; (set! rem rem*) + ;; + ;; ;; (gv.setv subgraph "rankdir" "TB") + ;; (gv.setv subgraph "color" (list-ref colors count)) + ;; + ;; (for-each (lambda (name) + ;; (gv.node subgraph (format #f "~a" name))) + ;; use) + ;; + ;; (set! count (1+ count)) + ;; ) + ;; '(calp vcomponent)) + + ;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) + ;; + ;; ;; (gv.setv subgraph "rankdir" "TB") + ;; (gv.setv subgraph "color" (list-ref colors count)) + ;; + ;; (for-each (lambda (name) + ;; (gv.node subgraph (format #f "~a" name))) + ;; rem) + + (define subgraph + (let ((subgraph (gv.graph graph (format #f "cluster_~a" 0)))) + ;; (gv.setv subgraph "rankdir" "TB") + (gv.setv subgraph "color" "Red") + subgraph)) + + + (define subgraphs + (let ((subgraphs (make-hash-table))) + (for-each (lambda (name) + (let ((g (hashq-ref subgraphs (car name) + (gv.graph graph (format #f "cluster_~a" (car name)))))) + (hashq-set! subgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (lambda (x) (eq? 'calp (car x))) + our-modules)))) + + (define calp-base (gv.graph graph "cluster_1")) + (define calpgraphs + (let ((calpgraphs (make-hash-table))) + (for-each (lambda (name) + (let ((g (hashq-ref calpgraphs (cadr name) + (gv.graph + ;; calp-base + graph + (format #f "cluster_~a" (cadr name)))))) + (hashq-set! calpgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (compose null? cdr) + (filter (lambda (x) (eq? 'calp (car x))) + our-modules))) + calpgraphs)) + + + (for-each (lambda (edge) + (let ((gv-edge (gv.edge graph + (format #f "~a" (edge-down edge)) + (format #f "~a" (edge-up edge)) + ))) + (when (and (eq? 'calp (car (edge-up edge))) + (not (eq? 'calp (car (edge-down edge))))) + (gv.setv gv-edge "color" "red")) + (when (and (memv (car (edge-up edge)) '(vcomponent calp)) + (not (memv (car (edge-down edge)) '(vcomponent calp )))) + (gv.setv gv-edge "color" "blue")) + )) + (remove-edges to-remove + ((scan files) 'edges))) + + (gv.layout graph engine) + (gv.render graph "pdf" output-file)) diff --git a/module/srfi/srfi-64/util.scm b/module/srfi/srfi-64/util.scm new file mode 100644 index 00000000..a371227f --- /dev/null +++ b/module/srfi/srfi-64/util.scm @@ -0,0 +1,11 @@ +(define-module (srfi srfi-64 util) + :use-module (ice-9 curried-definitions) + :use-module ((srfi srfi-1) :select (every)) + :use-module (srfi srfi-64) + :export (test-match-group)) + +;; Specifier for name of group +(define ((test-match-group name . names) runner) + (every string=? + (reverse (cons name names)) + (test-runner-group-stack runner))) diff --git a/module/sxml/namespaced.scm b/module/sxml/namespaced.scm new file mode 100644 index 00000000..e5a334da --- /dev/null +++ b/module/sxml/namespaced.scm @@ -0,0 +1,266 @@ +(define-module (sxml namespaced) + :use-module (sxml ssax) + :use-module (sxml util) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (hnh util state-monad) + :use-module ((hnh util io) :select (->port)) + :export (xml->namespaced-sxml + namespaced-sxml->xml + namespaced-sxml->sxml + namespaced-sxml->sxml/namespaces + sxml->namespaced-sxml + xml + attribute + + make-xml-element + xml-element? + xml-element-tagname + xml-element-namespace + xml-element-attributes + + make-pi-element + pi-element? + pi-tag + pi-body + )) + +;; XML processing instruction elements (and other things with identical syntax) +;; For example: <?xml version="1.0" encoding="utf-8"?> would be encoded as +;; (make-pi-element 'xml "version=\"1.0\" encoding=\"utf-8\"") +;; tag should always be a symbol +;; body should always be a string +(define-record-type <pi-element> + (make-pi-element tag body) + pi-element? + (tag pi-tag) + (body pi-body)) + + +(define-record-type <xml-element> + (make-xml-element tagname namespace attributes) + xml-element? + (tagname xml-element-tagname) + (namespace xml-element-namespace) + (attributes xml-element-attributes)) + + +(define xml + (case-lambda + ((tag) (make-xml-element tag #f '())) + ((ns tag) (make-xml-element tag ns '())) + ((ns tag attrs) (make-xml-element tag ns attrs)))) + +(define (attribute xml attr) + (assoc-ref (xml-element-attributes xml) attr)) + + +(define* (parser key: trim-whitespace?) + (ssax:make-parser + + ;; DOCTYPE + ;; (lambda (port docname systemid internal-subset? seed) + ;; (format (current-error-port) + ;; "doctype: port=~s, docname=~s, systemid=~s, internal-subset?=~s, seed=~s~%" + ;; port docname systemid internal-subset? seed) + ;; (values #f '() '() seed)) + + ;; UNDECL-ROOT + ;; (lambda (elem-gi seed) + ;; (format (current-error-port) "Undecl-root: ~s~%" elem-gi) + ;; (values #f '() '() seed)) + + ;; DECL-ROOT + ;; (lambda (elem-gi seed) + ;; (format (current-error-port) "Decl-root: ~s~%" elem-gi) + ;; seed) + + NEW-LEVEL-SEED + (lambda (elem-gi attributes namespaces expected-content seed) + (cons + (list + (match elem-gi + ((ns . tag) (make-xml-element tag ns attributes)) + (tag (make-xml-element tag #f attributes)))) + seed)) + + FINISH-ELEMENT + (lambda (elem-gi attributes namespaces parent-seed seed) + (match seed + (((self . self-children) (parent . children) . rest) + `((,parent (,self ,@(reverse self-children)) ,@children) + ,@rest)))) + + CHAR-DATA-HANDLER + (lambda (str1 str2 seed) + (define s + (if trim-whitespace? + (string-trim-both (string-append str1 str2)) + (string-append str1 str2))) + (cond ((string-null? s) seed) + (else + (match seed + (((parent . children) . rest) + `((,parent ,(string-append str1 str2) + ,@children) + ,@rest)))))) + + PI + ((*DEFAULT* . (lambda (port pi-tag seed) + (let ((body (ssax:read-pi-body-as-string port))) + (match seed + (((parent . children) . rest) + `((,parent ,(make-pi-element pi-tag body) ,@children) + ,@rest))))))) + )) + + +(define* (xml->namespaced-sxml port-or-string key: (trim-whitespace? #t)) + (match (with-ssax-error-to-port + (current-error-port) + (lambda () ((parser trim-whitespace?: trim-whitespace?) + (->port port-or-string) + '((*TOP*))))) + ((('*TOP* . items)) + `(*TOP* ,@(reverse items))))) + +(define (pi-element->sxml pi) + `(*PI* ,(pi-tag pi) ,(pi-body pi))) + + + +(define (ns-pair->attribute pair) + (let ((fqdn short (car+cdr pair))) + (list (string->symbol (format #f "xmlns:~a" short)) + (symbol->string fqdn)))) + +;; Takes an association list from full namespace names (as symbols), to their +;; short forms, and returns a list containing xmlns:x-attributes suitable for +;; splicing into scheme's "regular" sxml. +(define (ns-alist->attributes ns) + (map ns-pair->attribute ns)) + + + +(define (get-prefix ns) + (do namespaces <- (get) + (cond ((assq-ref namespaces ns) => return) + (else (do prefix = (gensym "ns") + (put (acons ns prefix namespaces)) + (return prefix)))))) + + +(define (xml-element->sxml el) + (do tag <- (cond ((xml-element-namespace el) + => (lambda (ns) + (do pre <- (get-prefix ns) + (return + (string->symbol + (format #f "~a:~a" pre (xml-element-tagname el))))))) + (else (return (xml-element-tagname el)))) + (return + (lambda (children) + (cond ((null? (xml-element-attributes el)) + `(,tag ,@children)) + (else + `(,tag (@ ,@(map (lambda (p) + (call-with-values (lambda () (car+cdr p)) list)) + (xml-element-attributes el))) + ,@children))))))) + +(define (sxml->xml-element el namespaces) + (lambda (children) + (let ((tag-symb attrs + (match el + ((tag ('@ attrs ...)) + (values tag (map (lambda (p) (apply cons p)) attrs))) + ((tag) (values tag '()))))) + (let ((parts (string-split (symbol->string tag-symb) #\:))) + (cons (case (length parts) + ((1) (xml (assoc-ref namespaces #f) + (string->symbol (car parts)) attrs)) + ((2) + (cond ((assoc-ref namespaces (string->symbol (car parts))) + => (lambda (ns) (xml ns (string->symbol (cadr parts)) attrs))) + (else (scm-error 'missing-namespace "sxml->xml-element" + "Unknown namespace prefix encountered: ~s (on tag ~s)" + (list (car parts) (cadr parts)) + #f)))) + (else (scm-error 'misc-error "sxml->xml-element" + "Invalid QName: more than one colon ~s" + (list tag-symb) #f))) + children))))) + + +(define (namespaced-sxml->sxml* tree) + (cond ((null? tree) (return tree)) + ((string? tree) (return tree)) + ((pi-element? tree) (return (pi-element->sxml tree))) + ((not (pair? tree)) (return tree)) + ((car tree) symbol? + => (lambda (symb) + (case symb + ((*TOP*) (do children <- (sequence (map namespaced-sxml->sxml* + (cdr tree))) + + (return (cons '*TOP* children)))) + (else (return tree))))) + ((xml-element? (car tree)) + (do proc <- (xml-element->sxml (car tree)) + children <- (sequence (map namespaced-sxml->sxml* (cdr tree))) + (return (proc children)))) + + ;; list of xml-element? + (else (scm-error 'misc-error "namespaced-sxml->sxml*" + "Unexpected token in tree: ~s" + (list tree) + #f)))) + + +;; Takes a tree of namespaced-sxml, and optionally an assoc list from namespace symbols, to prefered prefix. +;; Returns a sxml tree, with xmlns:<prefix>=namespace attributes +(define* (namespaced-sxml->sxml tree optional: (namespace-prefixes '())) + (let ((tree ns ((namespaced-sxml->sxml* tree) namespace-prefixes))) + ((get-root-element tree) + (lambda (root) + (add-attributes root (ns-alist->attributes ns)))))) + +(define* (namespaced-sxml->xml tree key: + (namespaces '()) + (port (current-output-port))) + ((@ (sxml simple) sxml->xml) + (namespaced-sxml->sxml tree namespaces) port)) + +;; Takes a tree of namespaced-sxml, and optionally an assoc list from namespace symbols, to prefered prefix. +;; Returns two values: a sxml tree without declared namespaces +;; and a association list from namespace symbols, to used prefixes +(define* (namespaced-sxml->sxml/namespaces tree optional: (namespace-prefixes '())) + ((namespaced-sxml->sxml* tree) namespace-prefixes)) + +;; Takes an sxml tree, and an association list from prefixes to namespaces +;; Returns a namespaced sxml tree +(define (sxml->namespaced-sxml tree namespaces) + (match tree + (('*PI* tag body) (make-pi-element tag body)) + (('*TOP* rest ...) + `(*TOP* ,@(map (lambda (r) (sxml->namespaced-sxml r namespaces)) + rest))) + ((el ('@ attrs ...) rest ...) + ((sxml->xml-element `(,el (@ ,@attrs)) namespaces) + (map (lambda (el) (sxml->namespaced-sxml el namespaces)) + rest))) + ((el rest ...) + ((sxml->xml-element `(,el) namespaces) + (map (lambda (el) (sxml->namespaced-sxml el namespaces)) + rest))) + (atom atom))) + +;;; TODO read intro-comment in SSAX file +;;; TODO Figure out how to still use (sxml match) and (sxml xpath) with these +;;; new trees (probably rewriting to a "regular" sxml tree, and keeping +;;; a strict mapping of namespaces) + diff --git a/module/sxml/namespaced/util.scm b/module/sxml/namespaced/util.scm new file mode 100644 index 00000000..6f93e362 --- /dev/null +++ b/module/sxml/namespaced/util.scm @@ -0,0 +1,45 @@ +(define-module (sxml namespaced util) + :use-module (sxml namespaced) + :use-module (srfi srfi-1) + :use-module ((ice-9 control) :select (call/ec)) + :export (xml-element-hash-key + find-element + element-matches? + on-root-element + root-element + )) + +(define (xml-element-hash-key tag) + "Returns a value suitable as a key to hash-ref (and family)" + (cons (xml-element-namespace tag) + (xml-element-tagname tag))) + +(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)) + + +(define (element-matches? target-el tree) + (and (not (null? tree)) + (equal? + (xml-element-hash-key target-el) + (xml-element-hash-key (car tree))))) + + +(define (on-root-element proc tree) + (cond ((and (eq? '*TOP* (car tree)) + (pi-element? (cadr tree))) + (cons* (car tree) (cadr tree) + (proc (caddr tree)))) + ((eq? '*TOP* (car tree)) + (cons (car tree) + (proc (cadr tree)))) + (else (proc (car tree))))) + +(define (root-element tree) + (call/ec (lambda (return) + (on-root-element return tree)))) diff --git a/module/sxml/util.scm b/module/sxml/util.scm new file mode 100644 index 00000000..532141b2 --- /dev/null +++ b/module/sxml/util.scm @@ -0,0 +1,22 @@ +(define-module (sxml util) + :use-module (ice-9 match) + :export (get-root-element add-attributes)) + +(define (get-root-element tree) + (match tree + (('*TOP* ('*PI* 'xml body) (root . children)) + (lambda (modifier) `(*TOP* (*PI* xml ,body) + ,(modifier `(,root ,@children))))) + (('*TOP* (root . children)) + (lambda (modifier) `(*TOP* ,(modifier `(,root ,@children))))) + ((root . children) + (lambda (modifier) `(*TOP* ,(modifier `(,root ,@children))))))) + +(define (add-attributes element added-attributes) + (match element + ((el ('@ . attributes) . children) + `(,el (@ ,@attributes ,@added-attributes) + ,@children)) + ((el . children) + `(,el (@ ,@added-attributes) + ,@children)))) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index b62d45c2..472c5074 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -15,7 +15,9 @@ vcomponent? children type parent - add-child! remove-child! + reparent! + abandon! + orphan! delete-property! prop* prop @@ -28,6 +30,7 @@ parameters properties + copy-as-orphan copy-vcomponent x-property? internal-field? @@ -75,40 +78,42 @@ (make-vline% key value ht)) (define-record-type <vcomponent> - (make-vcomponent% type children parent properties) + (make-vcomponent% type children properties) vcomponent? (type type) (children children set-component-children!) - (parent get-component-parent set-component-parent!) (properties get-component-properties)) ((@ (srfi srfi-9 gnu) set-record-type-printer!) <vcomponent> (lambda (c p) - (format p "#<<vcomponent> ~a, len(child)=~a, parent=~a>~%" + (format p "#<<vcomponent> ~a, len(child)=~a>" (type c) (length (children c)) - (and=> (get-component-parent c) type)))) + ))) -;; TODO should this also update the parent -(define parent - (make-procedure-with-setter - get-component-parent set-component-parent!)) + +(define parent% (make-object-property)) +(define (parent x) (parent% x)) (define* (make-vcomponent optional: (type 'VIRTUAL)) - (make-vcomponent% type '() #f (make-hash-table))) + (make-vcomponent% type '() (make-hash-table))) -(define (add-child! parent child) +;; TODO should this be renamed to `adopt!'? Adopting a child better implies +;; that the old parent should no longer be considered its parent. +(define (reparent! parent child) (set-component-children! parent (cons child (children parent))) - (set-component-parent! child parent)) + (set! (parent% child) parent)) -(define (remove-child! parent-component child) - (unless (eq? parent-component (parent child)) - (scm-error - 'wrong-type-arg "remove-child!" "Child doesn't belong to parent" - (list parent-component child) #f)) +(define (abandon! parent-component child) (set-component-children! parent-component (delq1! child (children parent-component))) - (set-component-parent! child #f)) + (when (eq? parent-component (parent% child)) + (orphan! child))) + +;; TODO should this exist? It's really weird to remove our reference to our +;; parent, without the parent removing their reference to us. +(define (orphan! child) + (set! (parent% child) #f)) ;;; TODO key=DTSTART, (date? value) => #t ;;; KRÄVER att (props vline 'VALUE) <- "DATE" @@ -194,12 +199,10 @@ ;; TODO deep-copy on parameters? (get-vline-parameters vline))) -(define (copy-vcomponent component) +(define (copy-as-orphan component) (make-vcomponent% (type component) - ;; TODO deep copy? (children component) - (parent component) ;; properties (alist->hashq-table (hash-map->list (lambda (key value) @@ -208,6 +211,13 @@ (copy-vline value)))) (get-component-properties component))))) + +(define (copy-vcomponent component) + (let ((ev (copy-as-orphan component))) + (when (parent component) + (reparent! (parent component) ev)) + ev)) + (define (extract field) (lambda (e) (prop e field))) diff --git a/module/vcomponent/config.scm b/module/vcomponent/config.scm index b2598207..3bc51557 100644 --- a/module/vcomponent/config.scm +++ b/module/vcomponent/config.scm @@ -4,13 +4,13 @@ :use-module (calp util config)) (define-config calendar-files '() - description: (_ "Which files to parse. Takes a list of paths or a single string which will be globbed.") + description: (G_ "Which files to parse. Takes a list of paths or a single string which will be globbed.") pre: (lambda (v) (cond [(list? v) v] [(string? v) ((@ (glob) glob) v)] [else #f]))) (define-config default-calendar "" - description: (_ "Default calendar to use for operations. Set to empty string to unset") + description: (G_ "Default calendar to use for operations. Set to empty string to unset") pre: (ensure string?)) diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm index 0869543d..19a6fa18 100644 --- a/module/vcomponent/control.scm +++ b/module/vcomponent/control.scm @@ -26,7 +26,7 @@ ;; TODO what is this even used for? (define-syntax with-replaced-properties (syntax-rules () - [(_ (component (key val) ...) + [(G_ (component (key val) ...) body ...) (let ((htable (make-hash-table 10))) diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm new file mode 100644 index 00000000..374da8b4 --- /dev/null +++ b/module/vcomponent/create.scm @@ -0,0 +1,121 @@ +(define-module (vcomponent create) + :use-module (vcomponent base) + :use-module ((srfi srfi-1) :select (last drop-right car+cdr)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-17) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((ice-9 hash-table) :select (alist->hashq-table)) + :use-module ((hnh util) :select (kvlist->assq ->)) + :export (with-parameters + as-list + vcomponent + vcalendar vevent + vtimezone standard daylight + )) + +;; TODO allow parameters and list values at same time + + + +;; Convert a scheme keyword to a symbol suitable for us +(define (keyword->key keyword) + (-> keyword + keyword->string + string-upcase + string->symbol)) + +(define (symbol-upcase symbol) + (-> symbol + symbol->string + string-upcase + string->symbol)) + +;; Upcase the keys in an association list. Keys must be symbols. +(define (upcase-keys alist) + (map (lambda (pair) (cons (symbol-upcase (car pair)) + (cdr pair))) + alist)) + + + +(define-immutable-record-type <almost-vline> + (make-almost-vline parameters value) + almost-vline? + (parameters almost-vline-parameters) + (value almost-vline-value)) + +(define (almost-vline->vline key almost-vline) + (make-vline key + (almost-vline-value almost-vline) + (almost-vline-parameters almost-vline))) + +(define (with-parameters . args*) + (define parameters (drop-right args* 1)) + (define value (last args*)) + (make-almost-vline + (-> parameters + kvlist->assq + upcase-keys + alist->hashq-table) + value)) + + + +(define-immutable-record-type <list-value> + (make-list-value value) + list-value? + (value list-value-value)) + +(define (as-list arg) + (make-list-value arg)) + + + +(define (vcomponent type . attrs*) + (define component (make-vcomponent type)) + (define attrs*-len (length attrs*)) + (unless (zero? attrs*-len) + (let ((attrs children + (if (and (list? (list-ref attrs* (- attrs*-len 1))) + (or (= 1 attrs*-len) + (not (keyword? (list-ref attrs* (- attrs*-len 2)))))) + (values (drop-right attrs* 1) + (last attrs*)) + (values attrs* '())))) + (for-each (lambda (pair) + (let ((key value (car+cdr pair))) + (cond + ((almost-vline? value) + (set! (prop* component key) + (almost-vline->vline key value))) + ((list-value? value) + (set! (prop* component key) + (map (lambda (value) + (make-vline key value (make-hash-table))) + (list-value-value value)))) + (else + (set! (prop component key) value))))) + (upcase-keys (kvlist->assq attrs))) + + ;; Attach children + (for-each (lambda (child) (reparent! component child)) + children))) + + component) + +(define (vcalendar . attrs) + (apply vcomponent 'VCALENDAR attrs)) + +(define (vevent . attrs) + (apply vcomponent 'VEVENT attrs)) + +(define (vtimezone . attrs) + (apply vcomponent 'VTIMEZONE attrs)) + +(define (standard . attrs) + (apply vcomponent 'STANDARD attrs)) + +(define (daylight . attrs) + (apply vcomponent 'DAYLIGHT attrs)) diff --git a/module/vcomponent/data-stores/caldav.scm b/module/vcomponent/data-stores/caldav.scm new file mode 100644 index 00000000..f9ba61c1 --- /dev/null +++ b/module/vcomponent/data-stores/caldav.scm @@ -0,0 +1,270 @@ +(define-module (vcomponent data-stores caldav) + ) + +(use-modules (srfi srfi-71) + (srfi srfi-88) + (rnrs bytevectors) + (rnrs io ports) + ((ice-9 binary-ports) :select (call-with-output-bytevector)) + (web request) + (web response) + (web client) + (web uri) + ;; (web http) ; + (sxml simple) + (oop goops) + (vcomponent data-stores common) + ((hnh util) :select (->)) + (web http dav) + ) + + + +(define-class <caldav-data-store> (<calendar-data-store>) + (host init-keyword: host: + getter: host) + (user init-keyword: user: + getter: user) + (calendar-path init-keyword: calendar-path: + accessor: calendar-path) + (password init-keyword: password: + getter: store-password)) + + +(define local-uri + (case-lambda ((this path) + (build-uri 'https + host: (host this) + path: path)) + ((this) + (build-uri 'https + host: (host this) + path: (calendar-path this))))) + + +(define* (make-caldav-store key: host user path password) + (define store + (make <caldav-data-store> + host: host + user: user + password: (string->symbol password) + calendar-path: path)) + + + (let* ((principal-path + (get-principal (local-uri store "/") + password: (store-password store))) + (calendar-home-set + (get-calendar-home-set (local-uri store principal-path) + password: (store-password store))) + (calendar-paths + (get-calendar-paths (local-uri store calendar-home-set) + password: (store-password store)))) + (set! (calendar-path store) + (car calendar-paths))) + + store) + +(define-method (write (this <caldav-data-store>) port) + (write `(make-caldav-store host: ,(host this) + user: ,(user this) + calendar-path: ,(calendar-path this) + password: ,(store-password this)) + port)) + +(define store + (make-caldav-store host: "dav.fruux.com" + user: "a3298201184" + password: "YjMyOTc0NjUwMDk6YXRhc3llanY2MGtu")) + +#; +(define-method (calendar-base (this <caldav-data-store>)) + (build-uri 'https + host: (host this) + path: (calendar-path this))) + + +;; (define-method (get-all (this <caldav-data-store>)) +;; ) + +(define-method (get-by-uid (this <caldav-data-store>) + (uid <string>)) + (let ((uids + (dav (local-uri this) + method: 'REPORT + authorization: `(Basic ,(store-password this)) + depth: 1 + body: + `(c:calendar-query + (@ (xmlns:c ,caldav)) + (d:prop (@ (xmlns:d "DAV:")) + (d:getetag) + #; (c:calendar-data) + ) + (c:filter + (c:comp-filter + (@ (name "VCALENDAR")) + (c:comp-filter + (@ (name "VEVENT")) + (c:prop-filter + (@ (name "UID")) + (c:text-match (@ (collation "i;octet")) + ,uid))))))))) + uids)) + + +(define-method (search (this <caldav-data-store>) + (filter <pair>)) + (let ((uids + (dav (local-uri this) + method: 'REPORT + authorization: `(Basic ,(store-password this)) + depth: 1 + body: + `(c:calendar-query + (@ (xmlns:c ,caldav)) + (d:prop (@ (xmlns:d "DAV:")) + (d:getetag) + (c:calendar-data + (c:comp (@ (name "VCALENDAR")) + (c:prop (@ (name "PRODID"))))) + #; (c:calendar-data) + ) + ,filter)))) + uids)) + +(define-method (search (this <caldav-data-store>) + (filter <string>) + (field <string>)) + (search store + `(c:filter + (c:comp-filter + (@ (name "VCALENDAR")) + (c:comp-filter + (@ (name "VEVENT")) + (c:prop-filter + (@ (name ,field)) + (c:text-match (@ (collation "i;octet")) + ,filter))))))) + + + +(define-method (list-calendars (this <caldav-data-store>)) + ) + + + + +(get-principal) ; => "/principals/uid/a3298201184/" + +(get-calendar-home-set "/principals/uid/a3298201184/") +;; => "/calendars/a3298201184/" + +(get-calendar-paths "/calendars/a3298201184/") +;; => ("/calendars/a3298201184/b85ba2e9-18aa-4451-91bb-b52da930e977/") + + + +(define user "a3298201184") +(define calendar "b85ba2e9-18aa-4451-91bb-b52da930e977") +(define password (string->symbol "YjMyOTc0NjUwMDk6YXRhc3llanY2MGtu")) +(define auth `(Basic ,password)) + + + + + + +(define uri + (build-uri 'https + host: "dav.fruux.com" + path: "/calendars/a3298201184/b85ba2e9-18aa-4451-91bb-b52da930e977/ff95c36c-6ae9-4aa0-b08f-c52d84bf4f26.ics")) + +(define-values (response body) + (dav uri + method: 'GET + authorization: auth)) + + + + +(define-values (response body) + (dav uri + method: 'PROPFIND + authorization: auth + body: + `(C:supported-collation-set (@ (xmlns:C ,caldav))))) + +(define-values (response body) + (dav uri + method: 'REPORT + authorization: auth + body: + `(C:calendar-query + (@ (xmlns:C ,caldav)) + (D:prop (@ (xmlns:D "DAV:")) + (D:getetac) + (C:calendar-data)) + (C:filter + (C:comp-filter (@ (name "VCALENDAR")) + (C:comp-filter (@ (name "VEVENT")) + (C:prop-filter (@ (name "UID")) + (C:text-match (@ (collation "i;utf-8")) + "Admittansen")))))))) + + + + + + +(define (add) + ;; add new event + (http-request 'PUT + path: "/path-on-server/<filename>.ics" + headers: + ((if-none-match "*") + (content-type "text/calendar")) + body: (ics:serialize event-with-wrapping-calendar) + )) + + +(define (get-by-time-range) + (http-request 'REPORT + path: "/calendar/<calendar-name>" + body: + ;; See RFC 4791 7.8.1 + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (C:calendar-query + (@ (xmlns:D "DAV:") + (xmlns:C "urn:ietf:params:xml:ns:caldav")) + (D:prop + (D:getetag) + (C:calendar-data + (C:comp + (@ (name "VCALENDAR")) + (C:prop (@ (name "VERSION"))) + (C:prop (@ name "VEVENT") + (C:prop (@ (name "SUMMARY"))) + ...)))) + (C:filter + (C:comp-filter + (@ (name "VCALENDAR")) + (C:comp-filter + (@ (name "VEVENT")) + (C:time-range + (@ (start ,(datetime->string + start + "~Y~m~dT~H~M~S~Z")) + (end ,(datetime->string + end + "~Y~m~dT~H~M~S~Z"))))))))))) + + + + + +;; (use-modules (curl)) +;; (define c (curl-easy-init)) +;; (curl-easy-setopt c 'url "https://hornquist.se") + +;; (curl-easy-perform handle) diff --git a/module/vcomponent/data-stores/common.scm b/module/vcomponent/data-stores/common.scm new file mode 100644 index 00000000..2fb4422a --- /dev/null +++ b/module/vcomponent/data-stores/common.scm @@ -0,0 +1,43 @@ +(define-module (vcomponent data-stores common) + :use-module ((srfi srfi-88) :select ()) + :use-module (oop goops) + :export (<calendar-data-store> + ;; path + get-all + get-by-uid)) + + +(define-class <calendar-data-store> () + ;; (path init-keyword: path: + ;; getter: path) + ) + + +;;; In (calp server routes) + + + + +;;; Load - Load store into memero +;;; Dump - Save store into "disk" + + +(define-method (get-all (this <calendar-data-store>)) + (scm-error 'not-implemented "get-all" + "Get-all is not implemented for ~s" + (class-of this) + #f)) + +(define-method (get-by-uid (this <calendar-data-store>) (uid <string>)) + (scm-error 'not-implemented "get-by-uid" + "Get-by-uid is not implemented for ~s" + (class-of this) + #f)) + + +(define-method (color (this <calendar-data-store>)) + "") + + +(define-method (displayname (this <calendar-data-store>)) + "") diff --git a/module/vcomponent/data-stores/file.scm b/module/vcomponent/data-stores/file.scm new file mode 100644 index 00000000..54676224 --- /dev/null +++ b/module/vcomponent/data-stores/file.scm @@ -0,0 +1,32 @@ +(define-module (vcomponent data-stores file) + :use-module (oop goops) + :use-module ((srfi srfi-88) :select ()) + :use-module ((calp) :select (prodid)) + :use-module (vcomponent data-stores common) + :use-module ((vcomponent formats ical) :select (serialize deserialize)) + ) + +(define-class <file-data-store> (<calendar-data-store>) + (path getter: path + init-keyword: path:)) + +(define (make-file-store path) + (make <file-store> path: path)) + +(define-method (get-all (this <file-data-store>)) + ;; X-WR-CALNAME ⇒ NAME + ;; X-WR-CALDESC + (call-with-input-file (path this) + deserialize)) + +(define-method (get-by-uid (this <file-data-store>) (uid <string>)) + #f + ) + +(define-method (queue-write (this <file-data-store>) vcomponent) + ) + +(define-method (flush (this <file-data-store>)) + (with-atomic-output-to-file (path this) + (lambda () (serialize (data this) (current-output-port)))) + ) diff --git a/module/vcomponent/data-stores/meta.scm b/module/vcomponent/data-stores/meta.scm new file mode 100644 index 00000000..8ec5f7fd --- /dev/null +++ b/module/vcomponent/data-stores/meta.scm @@ -0,0 +1,29 @@ +;;; Commentary: +;;; A virtual data store which uses other data stores for its storage. +;;; Used to merge stores into larger stores +;;; Code: + +(define-module (vcomponent data-stores meta) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-41) + :use-module ((srfi srfi-88) :select ()) + :export () + ) + +(define-class <meta-data-store> (<calendar-data-store>) + (stores accessor: stores + init-value: '() + init-keyword: stores:)) + + + +(define-method (get-all (this <meta-data-store>)) + (map get-all (stores this))) + +(define-method (get-by-uid (this <meta-data-store>) (uid <string>)) + (stream-car + (stream-append + (steam-map (lambda (store) (get-by-uid store uid)) + (list->stream (stores this))) + (stream #f)))) diff --git a/module/vcomponent/data-stores/sqlite.scm b/module/vcomponent/data-stores/sqlite.scm new file mode 100644 index 00000000..b5b566a8 --- /dev/null +++ b/module/vcomponent/data-stores/sqlite.scm @@ -0,0 +1,186 @@ +(define-module (vcomponent data-stores sqlite) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-71) + :use-module ((srfi srfi-88) :select ()) + :use-module (vcomponent) + :use-module ((vcomponent formats ical) :prefix #{ical:}#) + :use-module ((hnh util) :select (aif)) + ) + + +(catch 'misc-error + (lambda () + (use-modules (sqlite3)) + (provide 'data-store-sqlite)) + (lambda args 'no-op)) + +;; (define (sqlite-exec db str) +;; (display str) +;; ((@ (sqlite3) sqlite-exec) db str)) + +(define-class <sqlite-data-store> (<calendar-data-store>) + (database accessor: database) + (name init-keyword: name: getter: calendar-name) + ) + +(define (initialize-database db) + ;;; Setup Content type + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS content_type +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (let ((stmt (sqlite-prepare db " +INSERT OR IGNORE INTO content_type +( name ) VALUES ( ? )"))) + (for-each (lambda (content-type) + (sqlite-reset stmt) + (sqlite-bind-arguments stmt ) + (sqlite-step stmt)) + '("ical" + "xcal" + "jcal"))) + + ;;; Setup calendar + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar_properties +( id INTEGER PRIMARY KEY AUTOINCREMENT +, calendar INTEGER NOT NULL +, key TEXT NOT NULL +, value TEXT NOT NULL +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + ;; INSERT INTO calendar_properties (id, key, value) + ;; VALUES ( (SELECT id FROM calendar WHERE name = 'Calendar') + ;; , 'color' + ;; , '#1E90FF') + + ;;; Setup event + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event +( uid TEXT PRIMARY KEY +, content_type INTEGER NOT NULL +, content TEXT NOT NULL +, calendar INTEGER NOT NULL +, FOREIGN KEY (content_type) REFERENCES content_type(id) +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances +( id INTEGER PRIMARY KEY AUTOINCREMENT +, event TEXT NOT NULL +, start DATETIME NOT NULL +, end DATETIME +, FOREIGN KEY (event) REFERENCES event(uid) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances_valid_range +( start DATETIME NOT NULL +, end DATETIME NOT NULL +)") + ) + +(define-method (initialize (this <sqlite-data-store>) args) + (next-method) + (if (calendar-name this) + (set! (database this) (sqlite-open (path this))) + (let ((path db-name + (aif (string-rindex (path this) #\#) + (values (substring (path this) 0 it) + (substring (path this) (1+ it))) + (scm-error 'misc-error "(initialize <sqlite-data-store>)" + "Target calendar name not specified" + '() #f)))) + (set! (database this) (sqlite-open path)) + (slot-set! this 'name db-name))) + + (initialize-database (database this))) + + +(define-method (get-calendar (this <sqlite-data-store>)) + (let ((db (database this)) + (calendar (make-vcomponent 'VCALENDAR))) + (let ((stmt (sqlite-prepare db " +SELECT key, value FROM calendar_properties cp +LEFT JOIN calendar c ON cp.calendar = c.id +WHERE c.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (let ((key (vector-ref row 0)) + (value (vector-ref row 1))) + (set-property! calendar + (string->symbol key) + value)) + calendar) + calendar + stmt)) + + (let ((stmt (sqlite-prepare db " +SELECT content_type.name, content +FROM event +LEFT JOIN calendar ON event.calendar = calendar.id +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE calendar.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (case (string->symbol (vector-ref row 0)) + ((ical) + (add-child! calendar + (call-with-input-string (vector-ref row 1) + ics:deserialize)) + calendar) + (else + (scm-error 'misc-error "(get-calendar <sqlite-data-store>)" + "Only iCal data supported, got ~a" + (list (vector-ref row 0)) #f) + )) + ) + calendar + stmt)) + + calendar)) + + +#; +(define-method (get-by-uid (this <sqlite-data-store>) (uid <string>)) + (let ((stmt (sqlite-prepare db " +SELECT name, content +FROM event +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE event.uid = ?"))) + (sqlite-bind-arguments stmt uid) + (cond ((sqlite-step stmt) + => (lambda (record) + (case (string->symbol (vector-ref content 0)) + ((ics) + ;; TODO dispatch to higher instance + ) + (else + (scm-error 'value-error "get-by-uid" + "Can only deserialize ics (uid=~s)" + (list uid) #f))) + + )) + (else + ;; TODO possibly throw no-such-value + #f + )) + + ) + ) diff --git a/module/vcomponent/data-stores/vdir.scm b/module/vcomponent/data-stores/vdir.scm new file mode 100644 index 00000000..f0ed0fdc --- /dev/null +++ b/module/vcomponent/data-stores/vdir.scm @@ -0,0 +1,87 @@ +(define-module (vcomponent data-stores vdir) + :use-module (hnh util) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-71) + :use-module ((srfi srfi-88) :select ()) + :use-module (hnh util path) + :use-module ((vcomponent formats ical) :select (serialize deserialize)) + :use-module ((ice-9 ftw) :select (scandir)) + :export ()) + +(define-class <vdir-data-store> (<calendar-data-store>) + (path getter: path + init-keyword: path:) + (loaded-calendar accessor: loaded-calendar + init-value: #f) + (uid-map accessor: uid-map + init-value: #f) + ) + +(define (make-vdir-store path) + (make <vdir-data-store> path: path)) + +(define* (get-attribute path key key: dflt) + (catch 'system-error + (lambda () (call-with-input-file (path-append path key) read-line)) + (const dflt))) + + +(define-method (get-all (this <vdir-data-store>)) + (let ((files (scandir (path this) (lambda (item) (string-ci=? "ics" (filename-extension item))))) + (calendar (make-vcomponent 'VCALENDAR))) + (set! (prop calendar 'NAME) (get-attribute (path this) "displayname") + (prop calendar 'COLOR) (get-attribute (path this) "color" "#FFFFFF")) + (for-each (lambda (item) (reparent! calendar item)) + (append-map (lambda (file) + (define cal + (call-with-input-file (path-append (path this) file) + deserialize)) + (unless (eq? 'VCALENDAR (type cal)) + (scm-error 'misc-error "get-all<vdir-data-store>" + "Unexpected top level component. Expected VCALENDAR, got ~a. In file ~s" + (list (type cal) file))) + (for-each (lambda (child) + (set! (prop child '-X-HNH-FILENAME) file)) + (children cal)) + ) + files)) + (set! (loaded-calendar this) calendar) + calendar)) + + +(define-method (get-by-uid (this <vdir-data-store>) (uid <string>)) + (unless (uid-map this) + (let ((cal + (or (loaded-calendar this) + (get-all this)))) + (define ht (make-hash-table)) + (for-each (lambda (ev) (hash-set! ht (uid ev) ev)) + (children cal)) + (set! (uid-map this) ht))) + (hash-ref m uid #f)) + + +(define (wrap-for-output . vcomponents) + (let ((calendar (make-vcomponent 'VCALENDAR))) + (set! (prop calendar 'VERSION) "2.0" + (prop calendar 'PRODID) (prodid) + (prop calendar 'CALSCALE) "GREGORIAN") + (for-each (lambda (vcomponent) (reparent! calendar vcomponent)) + vcomponents) + calendar)) + +(define-method (queue-write (this <vdir-data-store>) vcomponent) + ;; TODO Multiple components + (let ((filename + (cond ((prop vcomponent '-X-HNH-FILENAME) + => identity) + (else + (format #f "~a.ics" (prop vcomponent 'UID)))))) + (with-atomic-output-to-file (path-append (path this) filename) + (lambda () (serialize (wrap-for-output vcomponent) (current-output-port)))))) + +(define-method (flush (this <vdir-data-store>)) + (sync)) + +;; (define (get-in-date-interval )) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 440ec5fd..a66ba38a 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -245,7 +245,7 @@ Event must have the DTSTART and DTEND protperty set." (prop component 'TZNAME) (zone-entry-format zone-entry) last-until (zone-entry-until zone-entry) last-offset new-timespec) - (add-child! vtimezone component)))] + (reparent! vtimezone component)))] [(zone-entry-rule zone-entry) => (lambda (rule-name) @@ -278,7 +278,7 @@ Event must have the DTSTART and DTEND protperty set." (awhen (rule->rrule rule) (set! (prop component 'RRULE) it)) - (add-child! vtimezone component))) + (reparent! vtimezone component))) ;; some of the rules might not apply to us since we only ;; started using that rule set later. It's also possible ;; that we stopped using a ruleset which continues existing. @@ -297,5 +297,5 @@ Event must have the DTSTART and DTEND protperty set." (prop component 'TZNAME) (zone-entry-format zone-entry) last-until (zone-entry-until zone-entry) last-offset (zone-entry-stdoff zone-entry)) - (add-child! vtimezone component))])) + (reparent! vtimezone component))])) vtimezone) diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index fb3d0478..1226fc44 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -17,27 +17,27 @@ ;; [FRR] ;; Part of the sentance "Repeated [every two weeks], except on ~a, ~a & ~a" ;; See everything tagged [FRR] - `(,(_ "Repeated ") + `(,(G_ "Repeated ") ,((@ (vcomponent recurrence display) format-recurrence-rule) (prop ev 'RRULE)) ,@(awhen (prop* ev 'EXDATE) (list ;; See [FRR] - (_ ", except on ") + (G_ ", except on ") (add-enumeration-punctuation (map (lambda (d) ;; TODO show year if different from current year (if (date? d) ;; [FRR] Exception date without time - (date->string d (_ "~e ~b")) + (date->string d (G_ "~e ~b")) ;; NOTE only show time when it's different than the start time? ;; or possibly only when FREQ is hourly or lower. (if (memv ((@ (vcomponent recurrence internal) freq) (prop ev 'RRULE)) '(HOURLY MINUTELY SECONDLY)) ;; [FRR] Exception date with time - (datetime->string d (_ "~e ~b ~k:~M")) + (datetime->string d (G_ "~e ~b ~k:~M")) ;; [FRR] Exception date without time - (datetime->string d (_ "~e ~b"))))) + (datetime->string d (G_ "~e ~b"))))) (map value it))))) ".")) @@ -52,7 +52,7 @@ ;; Warning message for failure to format description. ;; First argument is name of warning/error, ;; second is error arguments - (warning (_ "~a on formatting description, ~s") err args) + (warning (G_ "~a on formatting description, ~s") err args) str))) ;; Takes an event, and returns a pretty string for the time interval @@ -64,9 +64,9 @@ => (lambda (e) ;; start = end, only return one value (if (date= e (date+ s (date day: 1))) - (_ "~Y-~m-~d") - (values (_ "~Y-~m-~d") - (_ "~Y-~m-~d"))))] + (G_ "~Y-~m-~d") + (values (G_ "~Y-~m-~d") + (G_ "~Y-~m-~d"))))] ;; no end value, just return start [else (date->string s)]))] [else ; guaranteed datetime @@ -74,10 +74,10 @@ (e (prop ev 'DTEND))) (if e (let ((fmt-str (if (date= (datetime-date s) (datetime-date e)) - (_ "~H:~M") + (G_ "~H:~M") ;; Note the non-breaking space - (_ "~Y-~m-~d ~H:~M")))) + (G_ "~Y-~m-~d ~H:~M")))) (values fmt-str fmt-str)) ;; Note the non-breaking space - (_ "~Y-~m-~d ~H:~M")))])) + (G_ "~Y-~m-~d ~H:~M")))])) diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm index a8a923da..fcb2b7b6 100644 --- a/module/vcomponent/formats/common/types.scm +++ b/module/vcomponent/formats/common/types.scm @@ -13,7 +13,7 @@ (define (parse-binary props value) ;; p 30 (unless (string=? "BASE64" (hashq-ref props 'ENCODING)) - (warning (_ "Binary field not marked ENCODING=BASE64"))) + (warning (G_ "Binary field not marked ENCODING=BASE64"))) ;; For icalendar no extra whitespace is allowed in a ;; binary field (except for line wrapping). This differs @@ -25,7 +25,7 @@ (cond [(string=? "TRUE" value) #t] [(string=? "FALSE" value) #f] - [else (warning (_ "~a invalid boolean") value)])) + [else (warning (G_ "~a invalid boolean") value)])) ;; CAL-ADDRESS ⇒ uri @@ -58,7 +58,7 @@ (define (parse-integer props value) (let ((n (string->number value))) (unless (integer? n) - (warning (_ "Non integer as integer"))) + (warning (G_ "Non integer as integer"))) n)) ;; PERIOD @@ -89,7 +89,7 @@ (case (cadr rem) [(#\n #\N) (loop (cddr rem) (cons #\newline str) done)] [(#\; #\, #\\) => (lambda (c) (loop (cddr rem) (cons c str) done))] - [else => (lambda (c) (warning (_ "Non-escapable character: ~a") c) + [else => (lambda (c) (warning (G_ "Non-escapable character: ~a") c) (loop (cddr rem) str done))])] [(#\,) (loop (cdr rem) '() (cons (reverse-list->string str) done))] @@ -138,5 +138,5 @@ (define (get-parser type) (or (hashq-ref type-parsers type #f) - (scm-error 'misc-error "get-parser" (_ "No parser for type ~a") + (scm-error 'misc-error "get-parser" (G_ "No parser for type ~a") (list type) #f))) diff --git a/module/vcomponent/formats/ical.scm b/module/vcomponent/formats/ical.scm new file mode 100644 index 00000000..dddca946 --- /dev/null +++ b/module/vcomponent/formats/ical.scm @@ -0,0 +1,17 @@ +(define-module (vcomponent formats ical) + :use-module ((vcomponent formats ical output) + :select (component->ical-string)) + :use-module ((vcomponent formats ical parse) + :select (parse-calendar)) + :export (serialize + deserialize + ) + ) + + +(define (serialize component port) + (with-output-to-port port + (lambda () (component->ical-string component)))) + +(define (deserialize port) + (parse-calendar port)) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm index da891fa6..57860d2a 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -16,6 +16,7 @@ :use-module (vcomponent geo) :use-module (vcomponent formats ical types) :use-module (vcomponent recurrence) + :use-module ((calp) :select (prodid)) :use-module (calp translation) :autoload (vcomponent util instance) (global-event-object) :export (component->ical-string @@ -24,10 +25,6 @@ print-events-in-interval )) -(define (prodid) - (format #f "-//hugo//calp ~a//EN" - (@ (calp) version))) - ;; Format value depending on key type. ;; Should NOT emit the key. @@ -96,7 +93,7 @@ (get-writer 'TEXT)] [else - (warning (_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") key) (get-writer 'TEXT)])) (catch #t #; 'wrong-type-arg @@ -168,7 +165,9 @@ ;; If we have alternatives, splice them in here. (cond [(prop component '-X-HNH-ALTERNATIVES) - => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp)) + => (lambda (alts) (hash-map->list (lambda (_ comp) + (unless (eq? component comp) + (component->ical-string comp))) alts))])) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 49f8f101..f0a19ba5 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -14,6 +14,9 @@ :use-module (calp translation) :export (parse-calendar)) +;;; TODO a few translated strings here contain explicit newlines. Check if that +;;; is preserved through the translation. + (define string->symbol (let ((ht (make-hash-table 1000))) (lambda (str) @@ -124,7 +127,7 @@ (let ((vv (parser params value))) (when (list? vv) (scm-error 'parse-error "enum-parser" - (_ "List in enum field") + (G_ "List in enum field") #f #f)) (let ((v (string->symbol vv))) (unless (memv v enum) @@ -160,7 +163,7 @@ (lambda (params value) (let ((v ((get-parser 'TEXT) params value))) (unless (= 1 (length v)) - (warning (_ "List in non-list field: ~s") v)) + (warning (G_ "List in non-list field: ~s") v)) (string-join v ",")))] ;; TEXT, but allow a list @@ -198,7 +201,7 @@ [(memv key '(REQUEST-STATUS)) (scm-error 'parse-error "build-vline" - (_ "TODO Implement REQUEST-STATUS") + (G_ "TODO Implement REQUEST-STATUS") #f #f)] [(memv key '(ACTION)) @@ -233,7 +236,7 @@ (compose car (get-parser 'TEXT))] [else - (warning (_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") key) (compose car (get-parser 'TEXT))]))) ;; If we produced a list create multiple VLINES from it. @@ -286,7 +289,7 @@ ;; ~? ;; source line ;; source file - (_ "WARNING parse error around ~a + (G_ "WARNING parse error around ~a ~? line ~a ~a~%") (get-string linedata) @@ -303,7 +306,7 @@ (if (null? (cdr stack)) ;; return (car stack) - (begin (add-child! (cadr stack) (car stack)) + (begin (reparent! (cadr stack) (car stack)) (cdr stack))))] [else (let ((key value params (parse-itemline head))) @@ -341,7 +344,7 @@ ;; ~? ;; source line ;; source file - (_ "ERROR parse error around ~a + (G_ "ERROR parse error around ~a ~? line ~a ~a Defaulting to string~%") diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm index 7b6aad2e..768f5098 100644 --- a/module/vcomponent/formats/ical/types.scm +++ b/module/vcomponent/formats/ical/types.scm @@ -37,7 +37,7 @@ ;; TODO (define (write-period _ value) - (warning (_ "PERIOD writer not yet implemented")) + (warning (G_ "PERIOD writer not yet implemented")) (with-output-to-string (lambda () (write value)))) @@ -94,4 +94,4 @@ (define (get-writer type) (or (hashq-ref type-writers type #f) - (error (_ "No writer for type") type))) + (error (G_ "No writer for type") type))) diff --git a/module/vcomponent/formats/sxcal.scm b/module/vcomponent/formats/sxcal.scm new file mode 100644 index 00000000..c02dbada --- /dev/null +++ b/module/vcomponent/formats/sxcal.scm @@ -0,0 +1,16 @@ +(define-module (vcomponent formats sxcal) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :export (serialize deserialize) + ) + + +(define (serialize component port) + (write (serialize/object component) port)) + +(define (serialize/object component) + ;; TODO where is this defined? + (vcomponent->sxcal component)) + +(define (deserialize port) + (sxcal->vcomponent port)) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 46626402..8fe69fc6 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -64,9 +64,9 @@ ;; by RECURRENCE-ID. As far as I can tell this goes against ;; the standard. Section 3.8.4.4. (case (length events) - [(0) (warning (_ "No events in component~%~a") + [(0) (warning (G_ "No events in component~%~a") (prop item '-X-HNH-FILENAME))] - [(1) (add-child! calendar (car events))] + [(1) (reparent! calendar (car events))] ;; two or more [else @@ -108,7 +108,7 @@ ;; we need to filter duplicates either way. (map (extract 'RECURRENCE-ID) (cons head rest)) (cons head rest)))) - (add-child! calendar head))]) + (reparent! calendar head))]) ;; return calendar) diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index ac520463..d096405e 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -26,16 +26,16 @@ (unless calendar (scm-error 'wrong-type-arg "save-event" - (_ "Can only save events belonging to calendars, event uid = ~s") + (G_ "Can only save events belonging to calendars, event uid = ~s") (list (prop event 'UID)) #f)) (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) (scm-error 'wrong-type-arg "save-event" (string-append - (_ "Can only save events belonging to vdir calendars.") + (G_ "Can only save events belonging to vdir calendars.") " " - (_ "Calendar is of type ~s")) + (G_ "Calendar is of type ~s")) (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) @@ -55,10 +55,10 @@ (define calendar (parent event)) (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) (scm-error 'wrong-type-arg "remove-event" - (string-append (_ "Can only remove events belonging to vdir calendars.") + (string-append (G_ "Can only remove events belonging to vdir calendars.") " " - (_ "Calendar is of type ~s")) + (G_ "Calendar is of type ~s")) (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) (delete-file (prop event '-X-HNH-FILENAME)) - (remove-child! parent event)) + (abandon! parent event)) diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm new file mode 100644 index 00000000..29a1d92f --- /dev/null +++ b/module/vcomponent/formats/xcal.scm @@ -0,0 +1,27 @@ +(define-module (vcomponent formats xcal) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module ((vcomponent formats xcal output) + :select (vcomponent->sxcal ns-wrap)) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :use-module ((hnh util) :select (->)) + :export (serialize deserialize)) + + +(define* (serialize component port key: (namespaces '())) + (-> (vcomponent->sxcal component) + ns-wrap + (namespaced-sxml->xml port: port + namespaces: namespaces))) + +(define (serialize/object component) + (call-with-output-string (lambda (p) (serialize component p)))) + + +(define* (deserialize port) + (-> port + xml->namespaced-sxml + root-element ; Strip potential *TOP* + cadr ; Remove containing icalendar + sxcal->vcomponent)) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index 87ebd32b..e4a84efb 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -8,6 +8,9 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (calp translation) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :export (vcomponent->sxcal ns-wrap)) @@ -56,7 +59,7 @@ [(memv key '(GEO)) (lambda (_ v) - `(geo + `(,(xml xcal 'geo) (latitude ,(geo-latitude v)) (longitude ,(geo-longitude v))))] @@ -70,19 +73,20 @@ (get-writer 'TEXT)] [else - (warning (_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") key) (get-writer 'TEXT)])) - (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline))) + (writer ((@@ (vcomponent base) get-vline-parameters) vline) + (value vline))) (define (property->value-tag tag . values) (if (or (eq? tag 'VALUE) (internal-field? tag)) #f - `(,(downcase-symbol tag) + `(,(xml xcal (downcase-symbol tag)) ,@(map (lambda (v) ;; TODO parameter types!!!! (rfc6321 3.5.) - `(text ,(->string v))) + `(,(xml xcal 'text) ,(->string v))) values)))) ;; ((key value ...) ...) -> `(parameters , ... ) @@ -92,15 +96,14 @@ parameters)) (unless (null? outparams) - `(parameters ,@outparams))) + `(,(xml xcal 'parameters) ,@outparams))) (define (vcomponent->sxcal component) (define tagsymb (downcase-symbol (type component))) - (remove null? - `(,tagsymb + `(,(xml xcal tagsymb) ;; only have <properties> when it's non-empty. ,(let ((props (filter-map @@ -109,7 +112,7 @@ [(key vlines ...) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (reduce assq-merge '() (map parameters vlines))) ,@(for vline in vlines @@ -117,18 +120,22 @@ [(key . vline) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (parameters vline)) ,(vline->value-tag vline)))]) - (properties component)))) + ;; NOTE this sort is unnecesasary, but here so tests can work + ;; Possibly add it as a flag instead + (sort* (properties component) + string< (compose symbol->string car))))) (unless (null? props) - `(properties + `(,(xml xcal 'properties) ;; NOTE ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) ,@props))) ,(unless (null? (children component)) - `(components ,@(map vcomponent->sxcal (children component))))))) + `(,(xml xcal 'components) + ,@(map vcomponent->sxcal (children component))))))) (define (ns-wrap sxml) - `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) - ,sxml)) + `(,(xml xcal 'icalendar) + ,sxml)) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 8537956a..7ed8c637 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -3,18 +3,23 @@ :use-module (hnh util exceptions) :use-module (base64) :use-module (ice-9 match) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :use-module (sxml match) :use-module (vcomponent) :use-module (vcomponent geo) :use-module (vcomponent formats common types) :use-module (datetime) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) :use-module (calp translation) :export (sxcal->vcomponent) ) ;; symbol, ht, (list a) -> non-list -(define (handle-value type props value) +(define (handle-value type parameters value) (case type [(binary) @@ -25,17 +30,17 @@ [(boolean) (string=? "true" (car value))] ;; TODO possibly trim whitespace on text fields - [(cal-address uri text unknown) (car value)] + [(cal-address uri text unknown) (string-concatenate value)] [(date) ;; TODO this is correct, but ensure remaining types - (hashq-set! props 'VALUE "DATE") + (hashq-set! parameters 'VALUE "DATE") (parse-iso-date (car value))] [(date-time) (parse-iso-datetime (car value))] [(duration) - ((get-parser 'DURATION) props value)] + ((get-parser 'DURATION) parameters value)] [(float integer) ; (3.0) (string->number (car value))] @@ -84,7 +89,7 @@ bymonth bysetpos) (string->number value)) (else (scm-error 'key-error "handle-value" - (_ "Invalid type ~a, with value ~a") + (G_ "Invalid type ~a, with value ~a") (list type value) #f)))))) @@ -96,35 +101,39 @@ (for key in '(bysecond byminute byhour byday bymonthday byyearday byweekno bymonth bysetpos freq until count interval wkst) - (define values (assoc-ref-all value key)) - (if (null? values) - #f - (case key - ;; These fields all have zero or one value - ((freq until count interval wkst) - (list (symbol->keyword key) - (parse-value-of-that-type - key (car (map car values))))) - ;; these fields take lists - ((bysecond byminute byhour byday bymonthday - byyearday byweekno bymonth bysetpos) - (list (symbol->keyword key) - (map (lambda (v) (parse-value-of-that-type key v)) - (map car values)))) - (else (scm-error 'misc-error "handle-value" - "Invalid key ~s" - (list key) - #f)))))))))] + (cond ((find-element (xml xcal key) value) + => (lambda (v) + (case key + ;; These fields all have zero or one value + ((freq until count interval wkst) + (list (symbol->keyword key) + (parse-value-of-that-type + key (cadr v)))) + ;; these fields take lists + ((bysecond byminute byhour byday bymonthday + byyearday byweekno bymonth bysetpos) + (list (symbol->keyword key) + (map (lambda (v) (parse-value-of-that-type key v)) + (cadr v)))) + (else (scm-error 'misc-error "handle-value" + "Invalid key ~s" + (list key) + #f))))) + (else #f)))))))] [(time) (parse-iso-time (car value))] - [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))] + [(utc-offset) ((get-parser 'UTC-OFFSET) parameters (car value))] [(geo) ; ((long 1) (lat 2)) (sxml-match (cons 'geo value) [(geo (latitude ,x) (longitude ,y)) - ((@ (vcomponent geo) make-geo) x y)])])) + ((@ (vcomponent geo) make-geo) x y)])] + + [else (scm-error 'misc-error "handle-value" + "Unknown value type: ~s" + (list type) #f)])) (define (symbol-upcase symb) (-> symb @@ -134,15 +143,20 @@ (define (handle-parameters parameters) + ;; (assert (element-matches? (xml xcal 'parameters) + ;; parameters)) + (define ht (make-hash-table)) - (for param in parameters - (match param - [(ptag (ptype pvalue ...) ...) - ;; TODO parameter type (rfc6321 3.5.) - ;; TODO multi-valued parameters!!! - (hashq-set! ht (symbol-upcase ptag) - (car (concatenate pvalue)))])) + (for param in (cdr parameters) + (define ptag (xml-element-tagname (car param))) + ;; (define-values (ptype pvalue) (car+cdr cdr)) + ;; TODO multi-valued parameters!!! + (define-values (pytpe pvalue) (car+cdr (cadr param))) + ;; TODO parameter type (rfc6321 3.5.) + ;; TODO namespaces + (hashq-set! ht (symbol-upcase ptag) + (concatenate pvalue))) ht) (define* (parse-enum str enum optional: (allow-other #t)) @@ -153,11 +167,12 @@ ;; symbol non-list -> non-list -(define (handle-tag tag-name data) +(define (handle-tag xml-tag data) + (define tag-name (xml-element-tagname xml-tag)) (case tag-name [(request-status) ;; TODO - (warning (_ "Request status not yet implemented")) + (warning (G_ "Request status not yet implemented")) #f] ((transp) (parse-enum @@ -174,6 +189,49 @@ data '(AUDIO DISPLAY EMAIL NONE))) [else data])) +(define (handle-single-property! component tree) + (define xml-tag (car tree)) + (define tag (xml-element-tagname xml-tag)) + (define tag* (symbol-upcase tag)) + + (define body (cdr tree)) + + ;; TODO request-status + (define-values (parameters data) + (if (element-matches? (xml xcal 'parameters) + (car body)) + (values (handle-parameters (car body)) + (cdr body)) + (values (make-hash-table) + body))) + + (for typetag in data + (define type (xml-element-tagname (car typetag))) + ;; TODO multi valued data + (define raw-value (cdr typetag)) + (define vline + (make-vline tag* (handle-tag + xml-tag + (let ((v (handle-value type parameters raw-value))) + ;; TODO possibly more list fields + ;; (if (eq? tag 'categories) + ;; (string-split v #\,) + ;; v) + + v)) + parameters)) + (if (memv tag* '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* component tag*) + (set! (prop* component tag*) (cons vline it)) + (set! (prop* component tag*) (list vline))) + (set! (prop* component tag*) vline)))) + ;; Note ;; This doesn't verify the inter-field validity of the object, ;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME @@ -181,83 +239,29 @@ ;; TODO ;; since we are feeding user input into this it really should be fixed. (define (sxcal->vcomponent sxcal) - (define type (symbol-upcase (car sxcal))) + + ;; TODO the surrounding icalendar element needs to be removed BEFORE this procedue is called + + (define xml-tag (car sxcal)) + (define type (symbol-upcase (xml-element-tagname xml-tag))) (define component (make-vcomponent type)) - (awhen (assoc-ref sxcal 'properties) + (awhen (find-element (xml xcal 'properties) (cdr sxcal)) ;; Loop over multi valued fields, creating one vline ;; for every value. So ;; KEY;p=1:a,b ;; would be expanded into ;; KEY;p=1:a ;; KEY;p=1:b - (for property in it - (match property - ;; TODO request-status - - [(tag ('parameters parameters ...) - (type value ...) ...) - (let ((params (handle-parameters parameters)) - (tag* (symbol-upcase tag))) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let () - (define vline - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params)) - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - ))))] - - [(tag (type value ...) ...) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let ((params (make-hash-table)) - (tag* (symbol-upcase tag))) - (define vline - (make-vline tag* - (handle-tag - tag (let ((v (handle-value type params value))) - ;; TODO possibly more list fields - (if (eq? tag 'categories) - (string-split v #\,) - v))) - params)) - ;; - - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - )))]))) + (map (lambda (x) (handle-single-property! component x)) + (cdr it))) ;; children - (awhen (assoc-ref sxcal 'components) - (for child in (map sxcal->vcomponent it) - (add-child! component child))) + (awhen (find-element (xml xcal 'components) (cdr sxcal)) + ;; NOTE Order of children is insignificant, but this allows + ;; diffs to be stable (which is used by the format tests). + (for child in (map sxcal->vcomponent + (reverse (cdr it))) + (reparent! component child))) component) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index a88b6b04..82121d5e 100644 --- a/module/vcomponent/formats/xcal/types.scm +++ b/module/vcomponent/formats/xcal/types.scm @@ -3,16 +3,18 @@ :use-module (vcomponent formats ical types) :use-module (datetime) :use-module (calp translation) + :use-module ((calp namespaces) :select (xcal)) + :use-module ((sxml namespaced) :select (xml)) :export (get-writer)) (define (write-boolean _ v) - `(boolean ,(if v "true" "false"))) + `(,(xml xcal 'boolean) ,(if v "true" "false"))) (define (write-date _ v) - `(date ,(date->string v "~Y-~m-~d"))) + `(,(xml xcal 'date) ,(date->string v "~Y-~m-~d"))) (define (write-datetime p v) - `(date-time + `(,(xml xcal 'date-time) ,(datetime->string (hashq-ref p '-X-HNH-ORIGINAL v) ;; 'Z' should be included for UTC, @@ -21,17 +23,17 @@ "~Y-~m-~dT~H:~M:~S~Z"))) (define (write-time _ v) - `(time ,(time->string v "~H:~M:S"))) + `(,(xml xcal 'time) ,(time->string v "~H:~M:S"))) (define (write-recur _ v) - `(recur ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) + `(,(xml xcal 'recur) ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) ;; sepparate since this text shouldn't be escaped (define (write-text _ v) ;; TODO out type should be xsd:string. ;; Look into what that means, and escape ;; from there - `(text ,v)) + `(,(xml xcal 'text) ,v)) @@ -40,7 +42,7 @@ #| TODO PERIOD |# URI UTC-OFFSET) (hashq-set! sxml-writers simple-type (lambda (p v) - `(,(downcase-symbol simple-type) + `(,(xml xcal (downcase-symbol simple-type)) ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v))))) (hashq-set! sxml-writers 'BOOLEAN write-boolean) @@ -52,4 +54,4 @@ (define (get-writer type) (or (hashq-ref sxml-writers type #f) - (error (_ "No writer for type") type))) + (error (G_ "No writer for type") type))) diff --git a/module/vcomponent/recurrence/display/en.scm b/module/vcomponent/recurrence/display/en.scm index c711a75c..18d11dba 100644 --- a/module/vcomponent/recurrence/display/en.scm +++ b/module/vcomponent/recurrence/display/en.scm @@ -26,13 +26,13 @@ (list "every " (add-enumeration-punctuation (map (lambda (d) (list (week-day-name (cdr d)))) - (cadr group) + (cdr group) )))] [else (list (number->string-ordinal (car group)) " " (add-enumeration-punctuation (map (lambda (d) (list (week-day-name (cdr d)) "en")) - (cadr group))))]) + (cdr group))))]) ) groups)))) diff --git a/module/vcomponent/recurrence/display/sv.scm b/module/vcomponent/recurrence/display/sv.scm index 2bd70657..ee8fc3fd 100644 --- a/module/vcomponent/recurrence/display/sv.scm +++ b/module/vcomponent/recurrence/display/sv.scm @@ -31,7 +31,7 @@ (list "varje " (add-enumeration-punctuation (map (lambda (d) (list (week-day-name (cdr d)))) - (cadr group) + (cdr group) )))] [else (list (number->string-ordinal @@ -40,7 +40,7 @@ " " (add-enumeration-punctuation (map (lambda (d) (list (week-day-name (cdr d)) "en")) - (cadr group))))]) + (cdr group))))]) ) groups)))) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index 94c4cccf..9bf425ac 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -79,9 +79,18 @@ ;; to prevent creation of invalid rules. ;; This was made apparent when wkst was (incorrectly) set to MO, ;; which later crashed generate-recurrence-set. - (make-recur-rule% freq until count interval bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - wkst)) + + ;; Allow `(cons #f day)' to be written as just `day'. + (let ((byday* (if byday + (map (lambda (day) + (if (number? day) + (cons #f day) + day)) + byday) + #f))) + (make-recur-rule% freq until count interval bysecond byminute byhour + byday* bymonthday byyearday byweekno bymonth bysetpos + wkst))) ;; only print fields with actual values. (set-record-type-printer! diff --git a/module/vcomponent/util/instance.scm b/module/vcomponent/util/instance.scm index a18085eb..2310c5bc 100644 --- a/module/vcomponent/util/instance.scm +++ b/module/vcomponent/util/instance.scm @@ -1,4 +1,5 @@ (define-module (vcomponent util instance) + :use-module (srfi srfi-88) :use-module (hnh util) :use-module (calp translation) :use-module ((vcomponent util instance methods) :select (make-instance)) @@ -14,6 +15,6 @@ (define-once global-event-object (make-instance ((@ (vcomponent config) calendar-files)))) -(define (reload) - (begin (set! global-event-object (make-instance ((@ (vcomponent config) calendar-files)))) - (format (current-error-port) (_ "Reload done~%")))) +(define* (reload optional: (files ((@ (vcomponent config) calendar-files)))) + (begin (set! global-event-object (make-instance files)) + (format (current-error-port) (G_ "Reload done~%")))) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index 193a0304..fef83958 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -80,7 +80,7 @@ (define-method (initialize (this <events>) args) (next-method) - (format (current-error-port) (_ "Building <events> from~%")) + (format (current-error-port) (G_ "Building <events> from~%")) (for calendar in (slot-ref this 'calendar-files) (format (current-error-port) " - ~a~%" calendar)) @@ -96,7 +96,7 @@ type (concatenate (map children (slot-ref this 'calendars))))) (events (awhen (assoc-ref groups 'VEVENT) - (car it))) + it)) (removed remaining (partition (extract 'X-HNH-REMOVED) events))) ;; TODO figure out what to do with removed events @@ -125,7 +125,7 @@ ;;; with the same UID, which is BAD. (define-method (add-event (this <events>) calendar event) - (add-child! calendar event) + (reparent! calendar event) (unless (prop event 'UID) (set! (prop event 'UID) (uuid))) @@ -174,13 +174,17 @@ (define-method (add-and-save-event (this <events>) calendar event) + + ((@ (vcomponent validate) validate-event) event) + (cond [(get-event-by-uid this (prop event 'UID)) => (lambda (old-event) + (define old-calendar (parent old-event)) ;; remove old instance of event from runtime (remove-event this old-event) - (remove-child! (parent old-event) old-event) + (abandon! old-calendar old-event) ;; Add new event to runtime, ;; MUST be done after since the two events SHOULD share UID. @@ -196,13 +200,13 @@ ;; save-event sets -X-HNH-FILENAME from the UID. This is fine ;; since the two events are guaranteed to have the same UID. (unless ((@ (vcomponent formats vdir save-delete) save-event) event) - (throw 'misc-error (_ "Saving event to disk failed."))) - + (throw 'misc-error (G_ "Saving event to disk failed."))) - (unless (eq? calendar (parent old-event)) + #; + (unless (eq? calendar old-calendar) ;; change to a new calendar (format (current-error-port) - (_ "Unlinking old event from ~a~%") + (G_ "Unlinking old event from ~a~%") (prop old-event '-X-HNH-FILENAME)) ;; NOTE that this may fail, leading to a duplicate event being ;; created (since we save beforehand). This is just a minor problem @@ -212,7 +216,9 @@ (format (current-error-port) - (_ "Event updated ~a~%") (prop event 'UID)))] + (G_ "Event ~a updated in ~a~%") + (prop event 'UID) + (prop calendar 'NAME)))] [else (add-event this calendar event) @@ -222,7 +228,9 @@ ;; NOTE Posibly defer save to a later point. ;; That would allow better asyncronous preformance. (unless ((@ (vcomponent formats vdir save-delete) save-event) event) - (throw 'misc-error (_ "Saving event to disk failed."))) + (throw 'misc-error (G_ "Saving event to disk failed."))) (format (current-error-port) - (_ "Event inserted ~a~%") (prop event 'UID))])) + (G_ "Event ~a added to ~a~%") + (prop event 'UID) + (prop calendar 'NAME))])) diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index cf03db88..fe3a6b7d 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -1,3 +1,5 @@ +;;; TODO remove this module, it should be part of the vdir interface + (define-module (vcomponent util parse-cal-path) :use-module (hnh util) :use-module ((calp util time) :select (report-time!)) @@ -21,14 +23,14 @@ (set! (prop comp '-X-HNH-SOURCETYPE) 'file) comp) ] [(directory) - (report-time! (_ "Parsing ~a") path) + (report-time! (G_ "Parsing ~a") path) (let ((comp (parse-vdir path))) (set! (prop comp '-X-HNH-SOURCETYPE) 'vdir (prop comp '-X-HNH-DIRECTORY) path) comp)] [(block-special char-special fifo socket unknown symlink) => (lambda (t) (scm-error 'misc-error "parse-cal-path" - (_ "Can't parse file of type ~s") + (G_ "Can't parse file of type ~s") (list t) #f))])) diff --git a/module/vcomponent/validate.scm b/module/vcomponent/validate.scm new file mode 100644 index 00000000..8881c95f --- /dev/null +++ b/module/vcomponent/validate.scm @@ -0,0 +1,16 @@ +(define-module (vcomponent validate) + :use-module (vcomponent) + :use-module (datetime) + :use-module ((hnh util exceptions) + :select (warning)) + :use-module (calp translation) + :export (validate-event)) + +(define (validate-event component) + (unless (date/-time<= + (prop component 'DTSTART) + (prop component 'DTEND)) + (warning (G_ "end (~a) must be equal to or greater than start (~a)") + (prop component 'DTEND) + (prop component 'DTSTART))) + ) diff --git a/module/web/http.scm b/module/web/http.scm new file mode 100644 index 00000000..62a462d3 --- /dev/null +++ b/module/web/http.scm @@ -0,0 +1,2081 @@ +;;; HTTP messages + +;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;; Copyright (C) 2023 Hugo Hörnquist. + +;;; Commentary: +;;; +;;; This module has a number of routines to parse textual +;;; representations of HTTP data into native Scheme data structures. +;;; +;;; It tries to follow RFCs fairly strictly---the road to perdition +;;; being paved with compatibility hacks---though some allowances are +;;; made for not-too-divergent texts (like a quality of .2 which should +;;; be 0.2, etc). +;;; +;;; Code: + +(define-module (web http) + #:use-module ((srfi srfi-1) #:select (append-map! map! find)) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (ice-9 q) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 textual-ports) + #:use-module (ice-9 exceptions) + #:use-module (rnrs bytevectors) + #:use-module (web uri) + #:export (string->header + header->string + + declare-header! + declare-opaque-header! + known-header? + header-parser + header-validator + header-writer + + read-header + parse-header + valid-header? + write-header + + read-headers + write-headers + + declare-method! + parse-http-method + parse-http-version + parse-request-uri + + read-request-line + write-request-line + read-response-line + write-response-line + + &chunked-input-error-prematurely + chunked-input-ended-prematurely-error? + make-chunked-input-port + make-chunked-output-port + + http-proxy-port? + set-http-proxy-port?!)) + + +(define (put-symbol port sym) + (put-string port (symbol->string sym))) + +(define (put-non-negative-integer port i) + (put-string port (number->string i))) + +(define (string->header name) + "Parse NAME to a symbolic header name." + (string->symbol (string-downcase name))) + +(define-record-type <header-decl> + (make-header-decl name parser validator writer multiple?) + header-decl? + (name header-decl-name) + (parser header-decl-parser) + (validator header-decl-validator) + (writer header-decl-writer) + (multiple? header-decl-multiple?)) + +;; sym -> header +(define *declared-headers* (make-hash-table)) + +(define (lookup-header-decl sym) + (hashq-ref *declared-headers* sym)) + +(define* (declare-header! name + parser + validator + writer + #:key multiple?) + "Declare a parser, validator, and writer for a given header." + (unless (and (string? name) parser validator writer) + (error "bad header decl" name parser validator writer multiple?)) + (let ((decl (make-header-decl name parser validator writer multiple?))) + (hashq-set! *declared-headers* (string->header name) decl) + decl)) + +(define (header->string sym) + "Return the string form for the header named SYM." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-name decl) + (string-titlecase (symbol->string sym))))) + +(define (known-header? sym) + "Return ‘#t’ iff SYM is a known header, with associated +parsers and serialization procedures." + (and (lookup-header-decl sym) #t)) + +(define (header-parser sym) + "Return the value parser for headers named SYM. The result is a +procedure that takes one argument, a string, and returns the parsed +value. If the header isn't known to Guile, a default parser is returned +that passes through the string unchanged." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-parser decl) + (lambda (x) x)))) + +(define (header-validator sym) + "Return a predicate which returns ‘#t’ if the given value is valid +for headers named SYM. The default validator for unknown headers +is ‘string?’." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-validator decl) + string?))) + +(define (header-writer sym) + "Return a procedure that writes values for headers named SYM to a +port. The resulting procedure takes two arguments: a value and a port. +The default writer will call ‘put-string’." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-writer decl) + (lambda (val port) + (put-string port val))))) + +(define (read-header-line port) + "Read an HTTP header line and return it without its final CRLF or LF. +Raise a 'bad-header' exception if the line does not end in CRLF or LF, +or if EOF is reached." + (match (%read-line port) + (((? string? line) . #\newline) + ;; '%read-line' does not consider #\return a delimiter; so if it's + ;; there, remove it. We are more tolerant than the RFC in that we + ;; tolerate LF-only endings. + (if (string-suffix? "\r" line) + (string-drop-right line 1) + line)) + ((line . _) ;EOF or missing delimiter + (bad-header 'read-header-line line)))) + +(define (read-continuation-line port val) + (match (peek-char port) + ((or #\space #\tab) + (read-continuation-line port + (string-append val (read-header-line port)))) + (_ val))) + +(define *eof* (call-with-input-string "" read)) + +(define (read-header port) + "Read one HTTP header from PORT. Return two values: the header +name and the parsed Scheme value. May raise an exception if the header +was known but the value was invalid. + +Returns the end-of-file object for both values if the end of the message +body was reached (i.e., a blank line)." + (let ((line (read-header-line port))) + (if (or (string-null? line) + (string=? line "\r")) + (values *eof* *eof*) + (let* ((delim (or (string-index line #\:) + (bad-header '%read line))) + (sym (string->header (substring line 0 delim)))) + (values + sym + (parse-header + sym + (read-continuation-line + port + (string-trim-both line char-set:whitespace (1+ delim))))))))) + +(define (parse-header sym val) + "Parse VAL, a string, with the parser registered for the header +named SYM. Returns the parsed value." + ((header-parser sym) val)) + +(define (valid-header? sym val) + "Returns a true value iff VAL is a valid Scheme value for the +header with name SYM." + (unless (symbol? sym) + (error "header name not a symbol" sym)) + ((header-validator sym) val)) + +(define (write-header sym val port) + "Write the given header name and value to PORT, using the writer +from ‘header-writer’." + (put-string port (header->string sym)) + (put-string port ": ") + ((header-writer sym) val port) + (put-string port "\r\n")) + +(define (read-headers port) + "Read the headers of an HTTP message from PORT, returning them +as an ordered alist." + (let lp ((headers '())) + (call-with-values (lambda () (read-header port)) + (lambda (k v) + (if (eof-object? k) + (reverse! headers) + (lp (acons k v headers))))))) + +(define (write-headers headers port) + "Write the given header alist to PORT. Doesn't write the final +‘\\r\\n’, as the user might want to add another header." + (let lp ((headers headers)) + (match headers + (((k . v) . headers) + (write-header k v port) + (lp headers)) + (() + (values))))) + + + + +;;; +;;; Utilities +;;; + +(define (bad-header sym val) + (throw 'bad-header sym val)) +(define (bad-header-component sym val) + (throw 'bad-header-component sym val)) + +(define (bad-header-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header: ~a\n" (header->string sym) val)) + (_ (default-printer))) + args)) +(define (bad-header-component-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header component: ~a\n" sym val)) + (_ (default-printer))) + args)) +(set-exception-printer! 'bad-header bad-header-printer) +(set-exception-printer! 'bad-header-component bad-header-component-printer) + +(define (parse-opaque-string str) + str) +(define (validate-opaque-string val) + (string? val)) +(define (write-opaque-string val port) + (put-string port val)) + +(define separators-without-slash + (string->char-set "[^][()<>@,;:\\\"?= \t]")) +(define (validate-media-type str) + (let ((idx (string-index str #\/))) + (and idx (= idx (string-rindex str #\/)) + (not (string-index str separators-without-slash))))) +(define (parse-media-type str) + (unless (validate-media-type str) + (bad-header-component 'media-type str)) + (string->symbol str)) + +(define* (skip-whitespace str #:optional (start 0) (end (string-length str))) + (let lp ((i start)) + (if (and (< i end) (char-whitespace? (string-ref str i))) + (lp (1+ i)) + i))) + +(define* (trim-whitespace str #:optional (start 0) (end (string-length str))) + (let lp ((i end)) + (if (and (< start i) (char-whitespace? (string-ref str (1- i)))) + (lp (1- i)) + i))) + +(define* (split-and-trim str #:optional (delim #\,) + (start 0) (end (string-length str))) + (let lp ((i start)) + (if (< i end) + (let* ((idx (string-index str delim i end)) + (tok (string-trim-both str char-set:whitespace i (or idx end)))) + (cons tok (split-and-trim str delim (if idx (1+ idx) end) end))) + '()))) + +(define (list-of-strings? val) + (list-of? val string?)) + +(define (write-list-of-strings val port) + (put-list port val put-string ", ")) + +(define (split-header-names str) + (map string->header (split-and-trim str))) + +(define (list-of-header-names? val) + (list-of? val symbol?)) + +(define (write-header-list val port) + (put-list port val + (lambda (port x) + (put-string port (header->string x))) + ", ")) + +(define (collect-escaped-string from start len escapes) + (let ((to (make-string len))) + (let lp ((start start) (i 0) (escapes escapes)) + (match escapes + (() + (substring-move! from start (+ start (- len i)) to i) + to) + ((e . escapes) + (let ((next-start (+ start (- e i) 2))) + (substring-move! from start (- next-start 2) to i) + (string-set! to e (string-ref from (- next-start 1))) + (lp next-start (1+ e) escapes))))))) + +;; in incremental mode, returns two values: the string, and the index at +;; which the string ended +(define* (parse-qstring str #:optional + (start 0) (end (trim-whitespace str start)) + #:key incremental?) + (unless (and (< start end) (eqv? (string-ref str start) #\")) + (bad-header-component 'qstring str)) + (let lp ((i (1+ start)) (qi 0) (escapes '())) + (if (< i end) + (case (string-ref str i) + ((#\\) + (lp (+ i 2) (1+ qi) (cons qi escapes))) + ((#\") + (let ((out (collect-escaped-string str (1+ start) qi escapes))) + (cond + (incremental? (values out (1+ i))) + ((= (1+ i) end) out) + (else (bad-header-component 'qstring str))))) + (else + (lp (1+ i) (1+ qi) escapes))) + (bad-header-component 'qstring str)))) + +(define (put-list port items put-item delim) + (match items + (() (values)) + ((item . items) + (put-item port item) + (let lp ((items items)) + (match items + (() (values)) + ((item . items) + (put-string port delim) + (put-item port item) + (lp items))))))) + +(define (write-qstring str port) + (put-char port #\") + (if (string-index str #\") + ;; optimize me + (put-list port (string-split str #\") put-string "\\\"") + (put-string port str)) + (put-char port #\")) + +(define* (parse-quality str #:optional (start 0) (end (string-length str))) + (define (char->decimal c) + (let ((i (- (char->integer c) (char->integer #\0)))) + (unless (and (<= 0 i) (< i 10)) + (bad-header-component 'quality str)) + i)) + (cond + ((not (< start end)) + (bad-header-component 'quality str)) + ((eqv? (string-ref str start) #\1) + (unless (or (string= str "1" start end) + (string= str "1." start end) + (string= str "1.0" start end) + (string= str "1.00" start end) + (string= str "1.000" start end)) + (bad-header-component 'quality str)) + 1000) + ((eqv? (string-ref str start) #\0) + (if (or (string= str "0" start end) + (string= str "0." start end)) + 0 + (if (< 2 (- end start) 6) + (let lp ((place 1) (i (+ start 4)) (q 0)) + (if (= i (1+ start)) + (if (eqv? (string-ref str (1+ start)) #\.) + q + (bad-header-component 'quality str)) + (lp (* 10 place) (1- i) + (if (< i end) + (+ q (* place (char->decimal (string-ref str i)))) + q)))) + (bad-header-component 'quality str)))) + ;; Allow the nonstandard .2 instead of 0.2. + ((and (eqv? (string-ref str start) #\.) + (< 1 (- end start) 5)) + (let lp ((place 1) (i (+ start 3)) (q 0)) + (if (= i start) + q + (lp (* 10 place) (1- i) + (if (< i end) + (+ q (* place (char->decimal (string-ref str i)))) + q))))) + (else + (bad-header-component 'quality str)))) + +(define (valid-quality? q) + (and (non-negative-integer? q) (<= q 1000))) + +(define (write-quality q port) + (define (digit->char d) + (integer->char (+ (char->integer #\0) d))) + (put-char port (digit->char (modulo (quotient q 1000) 10))) + (put-char port #\.) + (put-char port (digit->char (modulo (quotient q 100) 10))) + (put-char port (digit->char (modulo (quotient q 10) 10))) + (put-char port (digit->char (modulo q 10)))) + +(define (list-of? val pred) + (match val + (((? pred) ...) #t) + (_ #f))) + +(define* (parse-quality-list str) + (map (lambda (part) + (cond + ((string-rindex part #\;) + => (lambda (idx) + (let ((qpart (string-trim-both part char-set:whitespace (1+ idx)))) + (unless (string-prefix? "q=" qpart) + (bad-header-component 'quality qpart)) + (cons (parse-quality qpart 2) + (string-trim-both part char-set:whitespace 0 idx))))) + (else + (cons 1000 (string-trim-both part char-set:whitespace))))) + (string-split str #\,))) + +(define (validate-quality-list l) + (match l + ((((? valid-quality?) . (? string?)) ...) #t) + (_ #f))) + +(define (write-quality-list l port) + (put-list port l + (lambda (port x) + (let ((q (car x)) + (str (cdr x))) + (put-string port str) + (when (< q 1000) + (put-string port ";q=") + (write-quality q port)))) + ",")) + +(define* (parse-non-negative-integer val #:optional (start 0) + (end (string-length val))) + (define (char->decimal c) + (let ((i (- (char->integer c) (char->integer #\0)))) + (unless (and (<= 0 i) (< i 10)) + (bad-header-component 'non-negative-integer val)) + i)) + (unless (< start end) + (bad-header-component 'non-negative-integer val)) + (let lp ((i start) (out 0)) + (if (< i end) + (lp (1+ i) + (+ (* out 10) (char->decimal (string-ref val i)))) + out))) + +(define (non-negative-integer? code) + (and (number? code) (>= code 0) (exact? code) (integer? code))) + +(define (default-val-parser k val) + val) + +(define (default-val-validator k val) + (or (not val) (string? val))) + +(define (default-val-writer k val port) + (if (or (string-index val #\;) + (string-index val #\,) + (string-index val #\")) + (write-qstring val port) + (put-string port val))) + +(define* (parse-key-value-list str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start)) + (if (not (< i end)) + '() + (let* ((i (skip-whitespace str i end)) + (eq (string-index str #\= i end)) + (comma (string-index str #\, i end)) + (delim (min (or eq end) (or comma end))) + (k (string->symbol + (substring str i (trim-whitespace str i delim))))) + (call-with-values + (lambda () + (if (and eq (or (not comma) (< eq comma))) + (let ((i (skip-whitespace str (1+ eq) end))) + (if (and (< i end) (eqv? (string-ref str i) #\")) + (parse-qstring str i end #:incremental? #t) + (values (substring str i + (trim-whitespace str i + (or comma end))) + (or comma end)))) + (values #f delim))) + (lambda (v-str next-i) + (let ((v (val-parser k v-str)) + (i (skip-whitespace str next-i end))) + (unless (or (= i end) (eqv? (string-ref str i) #\,)) + (bad-header-component 'key-value-list + (substring str start end))) + (cons (if v (cons k v) k) + (lp (1+ i)))))))))) + +(define* (key-value-list? list #:optional + (valid? default-val-validator)) + (list-of? list + (lambda (elt) + (match elt + (((? symbol? k) . v) (valid? k v)) + ((? symbol? k) (valid? k #f)) + (_ #f))))) + +(define* (write-key-value-list list port #:optional + (val-writer default-val-writer) (delim ", ")) + (put-list + port list + (lambda (port x) + (match x + ((k . #f) + (put-symbol port k)) + ((k . v) + (put-symbol port k) + (put-char port #\=) + (val-writer k v port)) + (k + (put-symbol port k)))) + delim)) + +;; param-component = token [ "=" (token | quoted-string) ] \ +;; *(";" token [ "=" (token | quoted-string) ]) +;; +(define param-delimiters (char-set #\, #\; #\=)) +(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;)) +(define* (parse-param-component str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start) (out '())) + (if (not (< i end)) + (values (reverse! out) end) + (let ((delim (string-index str param-delimiters i))) + (let ((k (string->symbol + (substring str i (trim-whitespace str i (or delim end))))) + (delimc (and delim (string-ref str delim)))) + (case delimc + ((#\=) + (call-with-values + (lambda () + (let ((i (skip-whitespace str (1+ delim) end))) + (if (and (< i end) (eqv? (string-ref str i) #\")) + (parse-qstring str i end #:incremental? #t) + (let ((delim + (or (string-index str param-value-delimiters + i end) + end))) + (values (substring str i delim) + delim))))) + (lambda (v-str next-i) + (let* ((v (val-parser k v-str)) + (x (if v (cons k v) k)) + (i (skip-whitespace str next-i end))) + (case (and (< i end) (string-ref str i)) + ((#f) + (values (reverse! (cons x out)) end)) + ((#\;) + (lp (skip-whitespace str (1+ i) end) + (cons x out))) + (else ; including #\, + (values (reverse! (cons x out)) i))))))) + ((#\;) + (let ((v (val-parser k #f))) + (lp (skip-whitespace str (1+ delim) end) + (cons (if v (cons k v) k) out)))) + + (else ;; either the end of the string or a #\, + (let ((v (val-parser k #f))) + (values (reverse! (cons (if v (cons k v) k) out)) + (or delim end)))))))))) + +(define* (parse-param-list str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start) (out '())) + (call-with-values + (lambda () (parse-param-component str val-parser i end)) + (lambda (item i) + (if (< i end) + (if (eqv? (string-ref str i) #\,) + (lp (skip-whitespace str (1+ i) end) + (cons item out)) + (bad-header-component 'param-list str)) + (reverse! (cons item out))))))) + +(define* (validate-param-list list #:optional + (valid? default-val-validator)) + (list-of? list + (lambda (elt) + (key-value-list? elt valid?)))) + +(define* (write-param-list list port #:optional + (val-writer default-val-writer)) + (put-list + port list + (lambda (port item) + (write-key-value-list item port val-writer ";")) + ",")) + +(define-syntax string-match? + (lambda (x) + (syntax-case x () + ((_ str pat) (string? (syntax->datum #'pat)) + (let ((p (syntax->datum #'pat))) + #`(let ((s str)) + (and + (= (string-length s) #,(string-length p)) + #,@(let lp ((i 0) (tests '())) + (if (< i (string-length p)) + (let ((c (string-ref p i))) + (lp (1+ i) + (case c + ((#\.) ; Whatever. + tests) + ((#\d) ; Digit. + (cons #`(char-numeric? (string-ref s #,i)) + tests)) + ((#\a) ; Alphabetic. + (cons #`(char-alphabetic? (string-ref s #,i)) + tests)) + (else ; Literal. + (cons #`(eqv? (string-ref s #,i) #,c) + tests))))) + tests))))))))) + +;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun" +;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec" + +(define (parse-month str start end) + (define (bad) + (bad-header-component 'month (substring str start end))) + (if (not (= (- end start) 3)) + (bad) + (let ((a (string-ref str (+ start 0))) + (b (string-ref str (+ start 1))) + (c (string-ref str (+ start 2)))) + (case a + ((#\J) + (case b + ((#\a) (case c ((#\n) 1) (else (bad)))) + ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad)))) + (else (bad)))) + ((#\F) + (case b + ((#\e) (case c ((#\b) 2) (else (bad)))) + (else (bad)))) + ((#\M) + (case b + ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad)))) + (else (bad)))) + ((#\A) + (case b + ((#\p) (case c ((#\r) 4) (else (bad)))) + ((#\u) (case c ((#\g) 8) (else (bad)))) + (else (bad)))) + ((#\S) + (case b + ((#\e) (case c ((#\p) 9) (else (bad)))) + (else (bad)))) + ((#\O) + (case b + ((#\c) (case c ((#\t) 10) (else (bad)))) + (else (bad)))) + ((#\N) + (case b + ((#\o) (case c ((#\v) 11) (else (bad)))) + (else (bad)))) + ((#\D) + (case b + ((#\e) (case c ((#\c) 12) (else (bad)))) + (else (bad)))) + (else (bad)))))) + +;; "GMT" | "+" 4DIGIT | "-" 4DIGIT +;; +;; RFC 2616 requires date values to use "GMT", but recommends accepting +;; the others as they are commonly generated by e.g. RFC 822 sources. +(define (parse-zone-offset str start) + (let ((s (substring str start))) + (define (bad) + (bad-header-component 'zone-offset s)) + (cond + ((string=? s "GMT") + 0) + ((string=? s "UTC") + 0) + ((string-match? s ".dddd") + (let ((sign (case (string-ref s 0) + ((#\+) +1) + ((#\-) -1) + (else (bad)))) + (hours (parse-non-negative-integer s 1 3)) + (minutes (parse-non-negative-integer s 3 5))) + (* sign 60 (+ (* 60 hours) minutes)))) ; seconds east of Greenwich + (else (bad))))) + +;; RFC 822, updated by RFC 1123 +;; +;; Sun, 06 Nov 1994 08:49:37 GMT +;; 01234567890123456789012345678 +;; 0 1 2 +(define (parse-rfc-822-date str space zone-offset) + ;; We could verify the day of the week but we don't. + (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 17 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 16 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + ;; The next two clauses match dates that have a space instead of + ;; a leading zero for hours, like " 8:49:37". + ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 18 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 17 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + (else + (bad-header 'date str) ; prevent tail call + #f))) + +;; RFC 850, updated by RFC 1036 +;; Sunday, 06-Nov-94 08:49:37 GMT +;; 0123456789012345678901 +;; 0 1 2 +(define (parse-rfc-850-date str comma space zone-offset) + ;; We could verify the day of the week but we don't. + (let ((tail (substring str (1+ comma) space))) + (unless (string-match? tail " dd-aaa-dd dd:dd:dd") + (bad-header 'date str)) + (let ((date (parse-non-negative-integer tail 1 3)) + (month (parse-month tail 4 7)) + (year (parse-non-negative-integer tail 8 10)) + (hour (parse-non-negative-integer tail 11 13)) + (minute (parse-non-negative-integer tail 14 16)) + (second (parse-non-negative-integer tail 17 19))) + (make-date 0 second minute hour date month + (let* ((now (date-year (current-date))) + (then (+ now year (- (modulo now 100))))) + (cond ((< (+ then 50) now) (+ then 100)) + ((< (+ now 50) then) (- then 100)) + (else then))) + zone-offset)))) + +;; ANSI C's asctime() format +;; Sun Nov 6 08:49:37 1994 +;; 012345678901234567890123 +;; 0 1 2 +(define (parse-asctime-date str) + (unless (string-match? str "aaa aaa .d dd:dd:dd dddd") + (bad-header 'date str)) + (let ((date (parse-non-negative-integer + str + (if (eqv? (string-ref str 8) #\space) 9 8) + 10)) + (month (parse-month str 4 7)) + (year (parse-non-negative-integer str 20 24)) + (hour (parse-non-negative-integer str 11 13)) + (minute (parse-non-negative-integer str 14 16)) + (second (parse-non-negative-integer str 17 19))) + (make-date 0 second minute hour date month year 0))) + +;; Convert all date values to GMT time zone, as per RFC 2616 appendix C. +(define (normalize-date date) + (if (zero? (date-zone-offset date)) + date + (time-utc->date (date->time-utc date) 0))) + +(define (parse-date str) + (let* ((space (string-rindex str #\space)) + (zone-offset (and space (false-if-exception + (parse-zone-offset str (1+ space)))))) + (normalize-date + (if zone-offset + (let ((comma (string-index str #\,))) + (cond ((not comma) (bad-header 'date str)) + ((= comma 3) (parse-rfc-822-date str space zone-offset)) + (else (parse-rfc-850-date str comma space zone-offset)))) + (parse-asctime-date str))))) + +(define (write-date date port) + (define (put-digits port n digits) + (define zero (char->integer #\0)) + (let lp ((tens (expt 10 (1- digits)))) + (when (> tens 0) + (put-char port + (integer->char (+ zero (modulo (truncate/ n tens) 10)))) + (lp (floor/ tens 10))))) + (let ((date (if (zero? (date-zone-offset date)) + date + (time-tai->date (date->time-tai date) 0)))) + (put-string port + (case (date-week-day date) + ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ") + ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ") + ((6) "Sat, ") (else (error "bad date" date)))) + (put-digits port (date-day date) 2) + (put-string port + (case (date-month date) + ((1) " Jan ") ((2) " Feb ") ((3) " Mar ") + ((4) " Apr ") ((5) " May ") ((6) " Jun ") + ((7) " Jul ") ((8) " Aug ") ((9) " Sep ") + ((10) " Oct ") ((11) " Nov ") ((12) " Dec ") + (else (error "bad date" date)))) + (put-digits port (date-year date) 4) + (put-char port #\space) + (put-digits port (date-hour date) 2) + (put-char port #\:) + (put-digits port (date-minute date) 2) + (put-char port #\:) + (put-digits port (date-second date) 2) + (put-string port " GMT"))) + +;; Following https://tools.ietf.org/html/rfc7232#section-2.3, an entity +;; tag should really be a qstring. However there are a number of +;; servers that emit etags as unquoted strings. Assume that if the +;; value doesn't start with a quote, it's an unquoted strong etag. +(define* (parse-entity-tag val #:optional (start 0) (end (string-length val)) + #:key sloppy-delimiters) + (define (parse-proper-etag-at start strong?) + (cond + (sloppy-delimiters + (call-with-values (lambda () + (parse-qstring val start end #:incremental? #t)) + (lambda (tag next) + (values (cons tag strong?) next)))) + (else + (values (cons (parse-qstring val start end) strong?) end)))) + (cond + ((string-prefix? "W/" val 0 2 start end) + (parse-proper-etag-at (+ start 2) #f)) + ((string-prefix? "\"" val 0 1 start end) + (parse-proper-etag-at start #t)) + (else + (let ((delim (or (and sloppy-delimiters + (string-index val sloppy-delimiters start end)) + end))) + (values (cons (substring val start delim) #t) delim))))) + +(define (entity-tag? val) + (match val + (((? string?) . _) #t) + (_ #f))) + +(define (put-entity-tag port val) + (match val + ((tag . strong?) + (unless strong? (put-string port "W/")) + (write-qstring tag port)))) + +(define* (parse-entity-tag-list val #:optional + (start 0) (end (string-length val))) + (call-with-values (lambda () + (parse-entity-tag val start end #:sloppy-delimiters #\,)) + (lambda (etag next) + (cons etag + (let ((next (skip-whitespace val next end))) + (if (< next end) + (if (eqv? (string-ref val next) #\,) + (parse-entity-tag-list + val + (skip-whitespace val (1+ next) end) + end) + (bad-header-component 'entity-tag-list val)) + '())))))) + +(define (entity-tag-list? val) + (list-of? val entity-tag?)) + +(define (put-entity-tag-list port val) + (put-list port val put-entity-tag ", ")) + +;; credentials = auth-scheme #auth-param +;; auth-scheme = token +;; auth-param = token "=" ( token | quoted-string ) +;; +;; That's what the spec says. In reality the Basic scheme doesn't have +;; k-v pairs, just one auth token, so we give that token as a string. +;; +(define* (parse-credentials str #:optional (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let* ((start (skip-whitespace str start end)) + (delim (or (string-index str char-set:whitespace start end) end))) + (when (= start end) + (bad-header-component 'authorization str)) + (let ((scheme (string->symbol + (string-downcase (substring str start (or delim end)))))) + (case scheme + ((basic) + (let* ((start (skip-whitespace str delim end))) + (unless (< start end) + (bad-header-component 'credentials str)) + (cons scheme (substring str start end)))) + (else + (cons scheme (parse-key-value-list str default-val-parser delim end))))))) + +(define (validate-credentials val) + (match val + (('basic . (? string?)) #t) + (((? symbol?) . (? key-value-list?)) #t) + (_ #f))) + +;; While according to RFC 7617 Schemes are case-insensitive: +;; +;; 'Note that both scheme and parameter names are matched +;; case-insensitive' +;; +;; some software (*) incorrectly assumes title case for scheme +;; names, so use the more titlecase. +;; +;; (*): See, e.g., +;; https://community.spotify.com/t5/Spotify-for-Developers/API-Authorization-header-doesn-t-follow-HTTP-spec/m-p/5397381#M4917 +(define (write-credentials val port) + (match val + (('basic . cred) + (put-string port "Basic ") + (put-string port cred)) + ((scheme . params) + (put-string port (string-titlecase (symbol->string scheme))) + (put-char port #\space) + (write-key-value-list params port)))) + +;; challenges = 1#challenge +;; challenge = auth-scheme 1*SP 1#auth-param +;; +;; A pain to parse, as both challenges and auth params are delimited by +;; commas, and qstrings can contain anything. We rely on auth params +;; necessarily having "=" in them. +;; +(define* (parse-challenge str #:optional + (start 0) (end (string-length str))) + (let* ((start (skip-whitespace str start end)) + (sp (string-index str #\space start end)) + (scheme (if sp + (string->symbol (string-downcase (substring str start sp))) + (bad-header-component 'challenge str)))) + (let lp ((i sp) (out (list scheme))) + (if (not (< i end)) + (values (reverse! out) end) + (let* ((i (skip-whitespace str i end)) + (eq (string-index str #\= i end)) + (comma (string-index str #\, i end)) + (delim (min (or eq end) (or comma end))) + (token-end (trim-whitespace str i delim))) + (if (string-index str #\space i token-end) + (values (reverse! out) i) + (let ((k (string->symbol (substring str i token-end)))) + (call-with-values + (lambda () + (if (and eq (or (not comma) (< eq comma))) + (let ((i (skip-whitespace str (1+ eq) end))) + (if (and (< i end) (eqv? (string-ref str i) #\")) + (parse-qstring str i end #:incremental? #t) + (values (substring + str i + (trim-whitespace str i + (or comma end))) + (or comma end)))) + (values #f delim))) + (lambda (v next-i) + (let ((i (skip-whitespace str next-i end))) + (unless (or (= i end) (eqv? (string-ref str i) #\,)) + (bad-header-component 'challenge + (substring str start end))) + (lp (1+ i) (cons (if v (cons k v) k) out)))))))))))) + +(define* (parse-challenges str #:optional (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start)) + (let ((i (skip-whitespace str i end))) + (if (< i end) + (call-with-values (lambda () (parse-challenge str i end)) + (lambda (challenge i) + (cons challenge (lp i)))) + '())))) + +(define (validate-challenges val) + (match val + ((((? symbol?) . (? key-value-list?)) ...) #t) + (_ #f))) + +(define (put-challenge port val) + (match val + ((scheme . params) + (put-symbol port scheme) + (put-char port #\space) + (write-key-value-list params port)))) + +(define (write-challenges val port) + (put-list port val put-challenge ", ")) + + + + +;;; +;;; Request-Line and Response-Line +;;; + +;; Hmm. +(define (bad-request message . args) + (throw 'bad-request message args)) +(define (bad-response message . args) + (throw 'bad-response message args)) + +(define *known-versions* '()) + +(define* (parse-http-version str #:optional (start 0) (end (string-length str))) + "Parse an HTTP version from STR, returning it as a major–minor +pair. For example, ‘HTTP/1.1’ parses as the pair of integers, +‘(1 . 1)’." + (let lp ((known *known-versions*)) + (match known + (((version-str . version-val) . known) + (if (string= str version-str start end) + version-val + (lp known))) + (() + (let ((dot-idx (string-index str #\. start end))) + (unless (and (string-prefix? "HTTP/" str 0 5 start end) + dot-idx + (= dot-idx (string-rindex str #\. start end))) + + (bad-header-component 'http-version (substring str start end))) + (cons (parse-non-negative-integer str (+ start 5) dot-idx) + (parse-non-negative-integer str (1+ dot-idx) end))))))) + +(define (write-http-version val port) + "Write the given major-minor version pair to PORT." + (put-string port "HTTP/") + (put-non-negative-integer port (car val)) + (put-char port #\.) + (put-non-negative-integer port (cdr val))) + +(for-each + (lambda (v) + (set! *known-versions* + (acons v (parse-http-version v 0 (string-length v)) + *known-versions*))) + '("HTTP/1.0" "HTTP/1.1")) + + +(define *declared-methods* '()) + +(define (declare-method! str symb) + (set! *declared-methods* (acons str symb *declared-methods*))) + +;; Request-URI = "*" | absoluteURI | abs_path | authority +;; +;; The `authority' form is only permissible for the CONNECT method, so +;; because we don't expect people to implement CONNECT, we save +;; ourselves the trouble of that case, and disallow the CONNECT method. +;; +(define* (parse-http-method str #:optional (start 0) (end (string-length str))) + "Parse an HTTP method from STR. The result is an upper-case +symbol, like ‘GET’." + (cdr + (or (find (lambda (pair) (string= str (car pair) start end)) + *declared-methods*) + (bad-request "Invalid method: ~a" (substring str start end))))) + +(declare-method! "GET" 'GET) +(declare-method! "HEAD" 'HEAD) +(declare-method! "POST" 'POST) +(declare-method! "PUT" 'PUT) +(declare-method! "DELETE" 'DELETE) +(declare-method! "OPTIONS" 'OPTIONS) +(declare-method! "TRACE" 'TRACE) +(declare-method! "CONNECT" 'CONNECT) +(declare-method! "PATCH" 'PATCH) + +(define* (parse-request-uri str #:optional (start 0) (end (string-length str))) + "Parse a URI from an HTTP request line. Note that URIs in requests do +not have to have a scheme or host name. The result is a URI-reference +object." + (cond + ((= start end) + (bad-request "Missing Request-URI")) + ((string= str "*" start end) + #f) + ((eqv? (string-ref str start) #\/) + (let* ((q (string-index str #\? start end)) + (f (string-index str #\# start end)) + (q (and q (or (not f) (< q f)) q))) + (build-uri-reference + #:path (substring str start (or q f end)) + #:query (and q (substring str (1+ q) (or f end))) + #:fragment (and f (substring str (1+ f) end))))) + (else + (or (string->uri (substring str start end)) + (bad-request "Invalid URI: ~a" (substring str start end)))))) + +(define (read-request-line port) + "Read the first line of an HTTP request from PORT, returning +three values: the method, the URI, and the version." + (let* ((line (read-header-line port)) + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (string-rindex line char-set:whitespace))) + (unless (and d0 d1 (< d0 d1)) + (bad-request "Bad Request-Line: ~s" line)) + (values (parse-http-method line 0 d0) + (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1) + (parse-http-version line (1+ d1) (string-length line))))) + +(define (write-uri uri port) + (put-string port (uri->string uri #:include-fragment? #f))) + +(define (write-request-line method uri version port) + "Write the first line of an HTTP request to PORT." + (put-symbol port method) + (put-char port #\space) + (when (http-proxy-port? port) + (let ((scheme (uri-scheme uri)) + (host (uri-host uri)) + (host-port (uri-port uri))) + (when (and scheme host) + (put-symbol port scheme) + (put-string port "://") + (cond + ((string-index host #\:) + (put-char port #\[) + (put-string port host) + (put-char port #\])) + (else + (put-string port host))) + (unless ((@@ (web uri) default-port?) scheme host-port) + (put-char port #\:) + (put-non-negative-integer port host-port))))) + (let ((path (uri-path uri)) + (query (uri-query uri))) + (if (string-null? path) + (put-string port "/") + (put-string port path)) + (when query + (put-string port "?") + (put-string port query))) + (put-char port #\space) + (write-http-version version port) + (put-string port "\r\n")) + +(define (read-response-line port) + "Read the first line of an HTTP response from PORT, returning three +values: the HTTP version, the response code, and the (possibly empty) +\"reason phrase\"." + (let* ((line (read-header-line port)) + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (and d0 (string-index line char-set:whitespace + (skip-whitespace line d0))))) + (unless (and d0 d1) + (bad-response "Bad Response-Line: ~s" line)) + (values (parse-http-version line 0 d0) + (parse-non-negative-integer line (skip-whitespace line d0 d1) + d1) + (string-trim-both line char-set:whitespace d1)))) + +(define (write-response-line version code reason-phrase port) + "Write the first line of an HTTP response to PORT." + (write-http-version version port) + (put-char port #\space) + (put-non-negative-integer port code) + (put-char port #\space) + (put-string port reason-phrase) + (put-string port "\r\n")) + + + + +;;; +;;; Helpers for declaring headers +;;; + +;; emacs: (put 'declare-header! 'scheme-indent-function 1) +;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1) +(define (declare-opaque-header! name) + "Declares a given header as \"opaque\", meaning that its value is not +treated specially, and is just returned as a plain string." + (declare-header! name + parse-opaque-string validate-opaque-string write-opaque-string)) + +;; emacs: (put 'declare-date-header! 'scheme-indent-function 1) +(define (declare-date-header! name) + (declare-header! name + parse-date date? write-date)) + +;; emacs: (put 'declare-string-list-header! 'scheme-indent-function 1) +(define (declare-string-list-header! name) + (declare-header! name + split-and-trim list-of-strings? write-list-of-strings)) + +;; emacs: (put 'declare-symbol-list-header! 'scheme-indent-function 1) +(define (declare-symbol-list-header! name) + (declare-header! name + (lambda (str) + (map string->symbol (split-and-trim str))) + (lambda (v) + (list-of? v symbol?)) + (lambda (v port) + (put-list port v put-symbol ", ")))) + +;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1) +(define (declare-header-list-header! name) + (declare-header! name + split-header-names list-of-header-names? write-header-list)) + +;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1) +(define (declare-integer-header! name) + (declare-header! name + parse-non-negative-integer non-negative-integer? + (lambda (val port) (put-non-negative-integer port val)))) + +;; emacs: (put 'declare-uri-reference-header! 'scheme-indent-function 1) +(define (declare-uri-reference-header! name) + (declare-header! name + (lambda (str) + (or (string->uri-reference str) + (bad-header-component 'uri-reference str))) + uri-reference? + write-uri)) + +;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1) +(define (declare-quality-list-header! name) + (declare-header! name + parse-quality-list validate-quality-list write-quality-list)) + +;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1) +(define* (declare-param-list-header! name #:optional + (val-parser default-val-parser) + (val-validator default-val-validator) + (val-writer default-val-writer)) + (declare-header! name + (lambda (str) (parse-param-list str val-parser)) + (lambda (val) (validate-param-list val val-validator)) + (lambda (val port) (write-param-list val port val-writer)))) + +;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1) +(define* (declare-key-value-list-header! name #:optional + (val-parser default-val-parser) + (val-validator default-val-validator) + (val-writer default-val-writer)) + (declare-header! name + (lambda (str) (parse-key-value-list str val-parser)) + (lambda (val) (key-value-list? val val-validator)) + (lambda (val port) (write-key-value-list val port val-writer)))) + +;; emacs: (put 'declare-entity-tag-list-header! 'scheme-indent-function 1) +(define (declare-entity-tag-list-header! name) + (declare-header! name + (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str))) + (lambda (val) (or (eq? val '*) (entity-tag-list? val))) + (lambda (val port) + (if (eq? val '*) + (put-string port "*") + (put-entity-tag-list port val))))) + +;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1) +(define (declare-credentials-header! name) + (declare-header! name + parse-credentials validate-credentials write-credentials)) + +;; emacs: (put 'declare-challenge-list-header! 'scheme-indent-function 1) +(define (declare-challenge-list-header! name) + (declare-header! name + parse-challenges validate-challenges write-challenges)) + + + + +;;; +;;; General headers +;;; + +;; Cache-Control = 1#(cache-directive) +;; cache-directive = cache-request-directive | cache-response-directive +;; cache-request-directive = +;; "no-cache" ; Section 14.9.1 +;; | "no-store" ; Section 14.9.2 +;; | "max-age" "=" delta-seconds ; Section 14.9.3, 14.9.4 +;; | "max-stale" [ "=" delta-seconds ] ; Section 14.9.3 +;; | "min-fresh" "=" delta-seconds ; Section 14.9.3 +;; | "no-transform" ; Section 14.9.5 +;; | "only-if-cached" ; Section 14.9.4 +;; | cache-extension ; Section 14.9.6 +;; cache-response-directive = +;; "public" ; Section 14.9.1 +;; | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1 +;; | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1 +;; | "no-store" ; Section 14.9.2 +;; | "no-transform" ; Section 14.9.5 +;; | "must-revalidate" ; Section 14.9.4 +;; | "proxy-revalidate" ; Section 14.9.4 +;; | "max-age" "=" delta-seconds ; Section 14.9.3 +;; | "s-maxage" "=" delta-seconds ; Section 14.9.3 +;; | cache-extension ; Section 14.9.6 +;; cache-extension = token [ "=" ( token | quoted-string ) ] +;; +(declare-key-value-list-header! "Cache-Control" + (lambda (k v-str) + (case k + ((max-age min-fresh s-maxage) + (parse-non-negative-integer v-str)) + ((max-stale) + (and v-str (parse-non-negative-integer v-str))) + ((private no-cache) + (and v-str (split-header-names v-str))) + (else v-str))) + (lambda (k v) + (case k + ((max-age min-fresh s-maxage) + (non-negative-integer? v)) + ((max-stale) + (or (not v) (non-negative-integer? v))) + ((private no-cache) + (or (not v) (list-of-header-names? v))) + ((no-store no-transform only-if-cache must-revalidate proxy-revalidate) + (not v)) + (else + (or (not v) (string? v))))) + (lambda (k v port) + (cond + ((string? v) (default-val-writer k v port)) + ((pair? v) + (put-char port #\") + (write-header-list v port) + (put-char port #\")) + ((integer? v) + (put-non-negative-integer port v)) + (else + (bad-header-component 'cache-control v))))) + +;; Connection = "Connection" ":" 1#(connection-token) +;; connection-token = token +;; e.g. +;; Connection: close, Foo-Header +;; +(declare-header! "Connection" + split-header-names + list-of-header-names? + (lambda (val port) + (put-list port val + (lambda (port x) + (put-string port + (if (eq? x 'close) + "close" + (header->string x)))) + ", "))) + +;; Date = "Date" ":" HTTP-date +;; e.g. +;; Date: Tue, 15 Nov 1994 08:12:31 GMT +;; +(declare-date-header! "Date") + +;; Pragma = "Pragma" ":" 1#pragma-directive +;; pragma-directive = "no-cache" | extension-pragma +;; extension-pragma = token [ "=" ( token | quoted-string ) ] +;; +(declare-key-value-list-header! "Pragma") + +;; Trailer = "Trailer" ":" 1#field-name +;; +(declare-header-list-header! "Trailer") + +;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding +;; +(declare-param-list-header! "Transfer-Encoding") + +;; Upgrade = "Upgrade" ":" 1#product +;; +(declare-string-list-header! "Upgrade") + +;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] ) +;; received-protocol = [ protocol-name "/" ] protocol-version +;; protocol-name = token +;; protocol-version = token +;; received-by = ( host [ ":" port ] ) | pseudonym +;; pseudonym = token +;; +(declare-header! "Via" + split-and-trim + list-of-strings? + write-list-of-strings + #:multiple? #t) + +;; Warning = "Warning" ":" 1#warning-value +;; +;; warning-value = warn-code SP warn-agent SP warn-text +;; [SP warn-date] +;; +;; warn-code = 3DIGIT +;; warn-agent = ( host [ ":" port ] ) | pseudonym +;; ; the name or pseudonym of the server adding +;; ; the Warning header, for use in debugging +;; warn-text = quoted-string +;; warn-date = <"> HTTP-date <"> +(declare-header! "Warning" + (lambda (str) + (let ((len (string-length str))) + (let lp ((i (skip-whitespace str 0))) + (let* ((idx1 (string-index str #\space i)) + (idx2 (string-index str #\space (1+ idx1)))) + (when (and idx1 idx2) + (let ((code (parse-non-negative-integer str i idx1)) + (agent (substring str (1+ idx1) idx2))) + (call-with-values + (lambda () (parse-qstring str (1+ idx2) #:incremental? #t)) + (lambda (text i) + (call-with-values + (lambda () + (let ((c (and (< i len) (string-ref str i)))) + (case c + ((#\space) + ;; we have a date. + (call-with-values + (lambda () (parse-qstring str (1+ i) + #:incremental? #t)) + (lambda (date i) + (values text (parse-date date) i)))) + (else + (values text #f i))))) + (lambda (text date i) + (let ((w (list code agent text date)) + (c (and (< i len) (string-ref str i)))) + (case c + ((#f) (list w)) + ((#\,) (cons w (lp (skip-whitespace str (1+ i))))) + (else (bad-header 'warning str)))))))))))))) + (lambda (val) + (list-of? val + (lambda (elt) + (match elt + ((code host text date) + (and (non-negative-integer? code) (< code 1000) + (string? host) + (string? text) + (or (not date) (date? date)))) + (_ #f))))) + (lambda (val port) + (put-list + port val + (lambda (port w) + (match w + ((code host text date) + (put-non-negative-integer port code) + (put-char port #\space) + (put-string port host) + (put-char port #\space) + (write-qstring text port) + (when date + (put-char port #\space) + (put-char port #\") + (write-date date port) + (put-char port #\"))))) + ", ")) + #:multiple? #t) + + + + +;;; +;;; Entity headers +;;; + +;; Allow = #Method +;; +(declare-symbol-list-header! "Allow") + +;; Content-Disposition = disposition-type *( ";" disposition-parm ) +;; disposition-type = "attachment" | disp-extension-token +;; disposition-parm = filename-parm | disp-extension-parm +;; filename-parm = "filename" "=" quoted-string +;; disp-extension-token = token +;; disp-extension-parm = token "=" ( token | quoted-string ) +;; +(declare-header! "Content-Disposition" + (lambda (str) + ;; Lazily reuse the param list parser. + (match (parse-param-list str default-val-parser) + ((disposition) disposition) + (_ (bad-header-component 'content-disposition str)))) + (lambda (val) + (match val + (((? symbol?) ((? symbol?) . (? string?)) ...) #t) + (_ #f))) + (lambda (val port) + (write-param-list (list val) port))) + +;; Content-Encoding = 1#content-coding +;; +(declare-symbol-list-header! "Content-Encoding") + +;; Content-Language = 1#language-tag +;; +(declare-string-list-header! "Content-Language") + +;; Content-Length = 1*DIGIT +;; +(declare-integer-header! "Content-Length") + +;; Content-Location = URI-reference +;; +(declare-uri-reference-header! "Content-Location") + +;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864> +;; +(declare-opaque-header! "Content-MD5") + +;; Content-Range = content-range-spec +;; content-range-spec = byte-content-range-spec +;; byte-content-range-spec = bytes-unit SP +;; byte-range-resp-spec "/" +;; ( instance-length | "*" ) +;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos) +;; | "*" +;; instance-length = 1*DIGIT +;; +(declare-header! "Content-Range" + (lambda (str) + (let ((dash (string-index str #\-)) + (slash (string-index str #\/))) + (unless (and (string-prefix? "bytes " str) slash) + (bad-header 'content-range str)) + (list 'bytes + (cond + (dash + (cons + (parse-non-negative-integer str 6 dash) + (parse-non-negative-integer str (1+ dash) slash))) + ((string= str "*" 6 slash) + '*) + (else + (bad-header 'content-range str))) + (if (string= str "*" (1+ slash)) + '* + (parse-non-negative-integer str (1+ slash)))))) + (lambda (val) + (match val + (((? symbol?) + (or '* ((? non-negative-integer?) . (? non-negative-integer?))) + (or '* (? non-negative-integer?))) + #t) + (_ #f))) + (lambda (val port) + (match val + ((unit range instance-length) + (put-symbol port unit) + (put-char port #\space) + (match range + ('* + (put-char port #\*)) + ((start . end) + (put-non-negative-integer port start) + (put-char port #\-) + (put-non-negative-integer port end))) + (put-char port #\/) + (match instance-length + ('* (put-char port #\*)) + (len (put-non-negative-integer port len))))))) + +;; Content-Type = media-type +;; +(declare-header! "Content-Type" + (lambda (str) + (let ((parts (string-split str #\;))) + (cons (parse-media-type (car parts)) + (map (lambda (x) + (let ((eq (string-index x #\=))) + (unless (and eq (= eq (string-rindex x #\=))) + (bad-header 'content-type str)) + (cons + (string->symbol + (string-trim x char-set:whitespace 0 eq)) + (string-trim-right x char-set:whitespace (1+ eq))))) + (cdr parts))))) + (lambda (val) + (match val + (((? symbol?) ((? symbol?) . (? string?)) ...) #t) + (_ #f))) + (lambda (val port) + (match val + ((type . args) + (put-symbol port type) + (match args + (() (values)) + (args + (put-string port ";") + (put-list + port args + (lambda (port pair) + (match pair + ((k . v) + (put-symbol port k) + (put-char port #\=) + (put-string port v)))) + ";"))))))) + +;; Expires = HTTP-date +;; +(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT")) + +(declare-header! "Expires" + (lambda (str) + (if (member str '("0" "-1")) + *date-in-the-past* + (parse-date str))) + date? + write-date) + +;; Last-Modified = HTTP-date +;; +(declare-date-header! "Last-Modified") + + + + +;;; +;;; Request headers +;;; + +;; Accept = #( media-range [ accept-params ] ) +;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) ) +;; *( ";" parameter ) +;; accept-params = ";" "q" "=" qvalue *( accept-extension ) +;; accept-extension = ";" token [ "=" ( token | quoted-string ) ] +;; +(declare-param-list-header! "Accept" + ;; -> (type/subtype (sym-prop . str-val) ...) ...) + ;; + ;; with the exception of prop `q', in which case the val will be a + ;; valid quality value + ;; + (lambda (k v) + (if (eq? k 'q) + (parse-quality v) + v)) + (lambda (k v) + (if (eq? k 'q) + (valid-quality? v) + (or (not v) (string? v)))) + (lambda (k v port) + (if (eq? k 'q) + (write-quality v port) + (default-val-writer k v port)))) + +;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] ) +;; +(declare-quality-list-header! "Accept-Charset") + +;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] ) +;; codings = ( content-coding | "*" ) +;; +(declare-quality-list-header! "Accept-Encoding") + +;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] ) +;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" ) +;; +(declare-quality-list-header! "Accept-Language") + +;; Authorization = credentials +;; credentials = auth-scheme #auth-param +;; auth-scheme = token +;; auth-param = token "=" ( token | quoted-string ) +;; +(declare-credentials-header! "Authorization") + +;; Expect = 1#expectation +;; expectation = "100-continue" | expectation-extension +;; expectation-extension = token [ "=" ( token | quoted-string ) +;; *expect-params ] +;; expect-params = ";" token [ "=" ( token | quoted-string ) ] +;; +(declare-param-list-header! "Expect") + +;; From = mailbox +;; +;; Should be an email address; we just pass on the string as-is. +;; +(declare-opaque-header! "From") + +;; Host = host [ ":" port ] +;; +(declare-header! "Host" + (lambda (str) + (let* ((rbracket (string-index str #\])) + (colon (string-index str #\: (or rbracket 0))) + (host (cond + (rbracket + (unless (eqv? (string-ref str 0) #\[) + (bad-header 'host str)) + (substring str 1 rbracket)) + (colon + (substring str 0 colon)) + (else + str))) + (port (and colon + (parse-non-negative-integer str (1+ colon))))) + (cons host port))) + (lambda (val) + (match val + (((? string?) . (or #f (? non-negative-integer?))) #t) + (_ #f))) + (lambda (val port) + (match val + ((host-name . host-port) + (cond + ((string-index host-name #\:) + (put-char port #\[) + (put-string port host-name) + (put-char port #\])) + (else + (put-string port host-name))) + (when host-port + (put-char port #\:) + (put-non-negative-integer port host-port)))))) + +;; If-Match = ( "*" | 1#entity-tag ) +;; +(declare-entity-tag-list-header! "If-Match") + +;; If-Modified-Since = HTTP-date +;; +(declare-date-header! "If-Modified-Since") + +;; If-None-Match = ( "*" | 1#entity-tag ) +;; +(declare-entity-tag-list-header! "If-None-Match") + +;; If-Range = ( entity-tag | HTTP-date ) +;; +(declare-header! "If-Range" + (lambda (str) + (if (or (string-prefix? "\"" str) + (string-prefix? "W/" str)) + (parse-entity-tag str) + (parse-date str))) + (lambda (val) + (or (date? val) (entity-tag? val))) + (lambda (val port) + (if (date? val) + (write-date val port) + (put-entity-tag port val)))) + +;; If-Unmodified-Since = HTTP-date +;; +(declare-date-header! "If-Unmodified-Since") + +;; Max-Forwards = 1*DIGIT +;; +(declare-integer-header! "Max-Forwards") + +;; Proxy-Authorization = credentials +;; +(declare-credentials-header! "Proxy-Authorization") + +;; Range = "Range" ":" ranges-specifier +;; ranges-specifier = byte-ranges-specifier +;; byte-ranges-specifier = bytes-unit "=" byte-range-set +;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec ) +;; byte-range-spec = first-byte-pos "-" [last-byte-pos] +;; first-byte-pos = 1*DIGIT +;; last-byte-pos = 1*DIGIT +;; suffix-byte-range-spec = "-" suffix-length +;; suffix-length = 1*DIGIT +;; +(declare-header! "Range" + (lambda (str) + (unless (string-prefix? "bytes=" str) + (bad-header 'range str)) + (cons + 'bytes + (map (lambda (x) + (let ((dash (string-index x #\-))) + (cond + ((not dash) + (bad-header 'range str)) + ((zero? dash) + (cons #f (parse-non-negative-integer x 1))) + ((= dash (1- (string-length x))) + (cons (parse-non-negative-integer x 0 dash) #f)) + (else + (cons (parse-non-negative-integer x 0 dash) + (parse-non-negative-integer x (1+ dash))))))) + (string-split (substring str 6) #\,)))) + (lambda (val) + (match val + (((? symbol?) + (or (#f . (? non-negative-integer?)) + ((? non-negative-integer?) . (? non-negative-integer?)) + ((? non-negative-integer?) . #f)) + ...) #t) + (_ #f))) + (lambda (val port) + (match val + ((unit . ranges) + (put-symbol port unit) + (put-char port #\=) + (put-list + port ranges + (lambda (port range) + (match range + ((start . end) + (when start (put-non-negative-integer port start)) + (put-char port #\-) + (when end (put-non-negative-integer port end))))) + ","))))) + +;; Referer = URI-reference +;; +(declare-uri-reference-header! "Referer") + +;; TE = #( t-codings ) +;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) +;; +(declare-param-list-header! "TE") + +;; User-Agent = 1*( product | comment ) +;; +(declare-opaque-header! "User-Agent") + + + + +;;; +;;; Reponse headers +;;; + +;; Accept-Ranges = acceptable-ranges +;; acceptable-ranges = 1#range-unit | "none" +;; +(declare-symbol-list-header! "Accept-Ranges") + +;; Age = age-value +;; age-value = delta-seconds +;; +(declare-integer-header! "Age") + +;; ETag = entity-tag +;; +(declare-header! "ETag" + parse-entity-tag + entity-tag? + (lambda (val port) + (put-entity-tag port val))) + +;; Location = URI-reference +;; +;; In RFC 2616, Location was specified as being an absolute URI. This +;; was changed in RFC 7231 to permit URI references generally, which +;; matches web reality. +;; +(declare-uri-reference-header! "Location") + +;; Proxy-Authenticate = 1#challenge +;; +(declare-challenge-list-header! "Proxy-Authenticate") + +;; Retry-After = ( HTTP-date | delta-seconds ) +;; +(declare-header! "Retry-After" + (lambda (str) + (if (and (not (string-null? str)) + (char-numeric? (string-ref str 0))) + (parse-non-negative-integer str) + (parse-date str))) + (lambda (val) + (or (date? val) (non-negative-integer? val))) + (lambda (val port) + (if (date? val) + (write-date val port) + (put-non-negative-integer port val)))) + +;; Server = 1*( product | comment ) +;; +(declare-opaque-header! "Server") + +;; Vary = ( "*" | 1#field-name ) +;; +(declare-header! "Vary" + (lambda (str) + (if (equal? str "*") + '* + (split-header-names str))) + (lambda (val) + (or (eq? val '*) (list-of-header-names? val))) + (lambda (val port) + (if (eq? val '*) + (put-string port "*") + (write-header-list val port)))) + +;; WWW-Authenticate = 1#challenge +;; +(declare-challenge-list-header! "WWW-Authenticate") + + +;; Chunked Responses +(define &chunked-input-ended-prematurely + (make-exception-type '&chunked-input-error-prematurely + &external-error + '())) + +(define make-chunked-input-ended-prematurely-error + (record-constructor &chunked-input-ended-prematurely)) + +(define chunked-input-ended-prematurely-error? + (record-predicate &chunked-input-ended-prematurely)) + +(define (read-chunk-header port) + "Read a chunk header from PORT and return the size in bytes of the +upcoming chunk." + (match (read-line port) + ((? eof-object?) + ;; Connection closed prematurely: there's nothing left to read. + 0) + (str + (let ((extension-start (string-index str + (lambda (c) + (or (char=? c #\;) + (char=? c #\return)))))) + (string->number (if extension-start ; unnecessary? + (substring str 0 extension-start) + str) + 16))))) + +(define* (make-chunked-input-port port #:key (keep-alive? #f)) + "Returns a new port which translates HTTP chunked transfer encoded +data from PORT into a non-encoded format. Returns eof when it has +read the final chunk from PORT. This does not necessarily mean +that there is no more data on PORT. When the returned port is +closed it will also close PORT, unless the KEEP-ALIVE? is true." + (define (close) + (unless keep-alive? + (close-port port))) + + (define chunk-size 0) ;size of the current chunk + (define remaining 0) ;number of bytes left from the current chunk + (define finished? #f) ;did we get all the chunks? + + (define (read! bv idx to-read) + (define (loop to-read num-read) + (cond ((or finished? (zero? to-read)) + num-read) + ((zero? remaining) ;get a new chunk + (let ((size (read-chunk-header port))) + (set! chunk-size size) + (set! remaining size) + (cond + ((zero? size) + (set! finished? #t) + (get-bytevector-n port 2) ; \r\n follows the last chunk + num-read) + (else + (loop to-read num-read))))) + (else ;read from the current chunk + (let* ((ask-for (min to-read remaining)) + (read (get-bytevector-n! port bv (+ idx num-read) + ask-for))) + (cond + ((eof-object? read) ;premature termination + (raise-exception + (make-chunked-input-ended-prematurely-error))) + (else + (let ((left (- remaining read))) + (set! remaining left) + (when (zero? left) + ;; We're done with this chunk; read CR and LF. + (get-u8 port) (get-u8 port)) + (loop (- to-read read) + (+ num-read read))))))))) + (loop to-read 0)) + + (make-custom-binary-input-port "chunked input port" read! #f #f close)) + +(define* (make-chunked-output-port port #:key (keep-alive? #f) + (buffering 1200)) + "Returns a new port which translates non-encoded data into a HTTP +chunked transfer encoded data and writes this to PORT. Data written to +this port is buffered until the port is flushed, at which point it is +all sent as one chunk. The port will otherwise be flushed every +BUFFERING bytes, which defaults to 1200. Take care to close the port +when done, as it will output the remaining data, and encode the final +zero chunk. When the port is closed it will also close PORT, unless +KEEP-ALIVE? is true." + (define (q-for-each f q) + (while (not (q-empty? q)) + (f (deq! q)))) + (define queue (make-q)) + (define (%put-char c) + (enq! queue c)) + (define (%put-string s) + (string-for-each (lambda (c) (enq! queue c)) + s)) + (define (flush) + ;; It is important that we do _not_ write a chunk if the queue is + ;; empty, since it will be treated as the final chunk. + (unless (q-empty? queue) + (let ((len (q-length queue))) + (put-string port (number->string len 16)) + (put-string port "\r\n") + (q-for-each (lambda (elem) (put-char port elem)) + queue) + (put-string port "\r\n")))) + (define (close) + (flush) + (put-string port "0\r\n\r\n") + (force-output port) + (unless keep-alive? + (close-port port))) + (let ((ret (make-soft-port (vector %put-char %put-string flush #f close) "w"))) + (setvbuf ret 'block buffering) + ret)) + +(define %http-proxy-port? (make-object-property)) +(define (http-proxy-port? port) (%http-proxy-port? port)) +(define (set-http-proxy-port?! port flag) + (set! (%http-proxy-port? port) flag)) diff --git a/module/web/http/dav.scm b/module/web/http/dav.scm new file mode 100644 index 00000000..9adc8b87 --- /dev/null +++ b/module/web/http/dav.scm @@ -0,0 +1,144 @@ +(define-module (web http dav) + :use-module (srfi srfi-9) + :use-module (srfi srfi-88) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module ((ice-9 binary-ports) :select (call-with-output-bytevector)) + :use-module (web request) + :use-module (web response) + :use-module (web client) + :use-module (web uri) + :use-module (sxml simple) + :use-module (sxml xpath) + :use-module ((hnh util) :select (->)) + :export (caldav + user-agent dav + propfind + get-principal + get-calendar-home-set + get-calendar-paths + get-calendar-name + ) + ) + +(define caldav "urn:ietf:params:xml:ns:caldav") +(define user-agent (make-parameter "")) +(user-agent "calp/0.1") + +(define-record-type <info> + (make-info uri-creator password) + info? + (uri-creator uri-creator) + (password info-password) + ) + +(define (with-output-to-bytevector thunk) + (call-with-output-bytevector + (lambda (port) + (with-output-to-port port thunk)))) + +;; Make a webdav HTTP request, body should be a sxml tree without the *TOP* or +;; *PI* element. +(define* (dav uri key: method authorization body (depth 1)) + (define request-body + (if body + (with-output-to-bytevector + (lambda () + (sxml->xml + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + ,body)))) + #f)) + + (define headers + `((user-agent . ,(user-agent)) + (depth . ,(cond (depth number? => number->string) + (else depth))) + ;; (accept . ((*/*))) + (authorization . ,authorization) + ,@(if body + `((content-type . (application/xml (charset . "UTF-8"))) + (content-length . ,(bytevector-length request-body))) + '()))) + + (http-request uri + method: method + body: request-body + headers: headers + keep-alive?: #t + decode-body?: #f + streaming?: #t)) + +(define* (propfind uri resource key: (depth 1) password) + (define authorization + (if password + `(Basic ,password) + #f)) + (define-values (response port) + (dav uri + method: 'PROPFIND + authorization: authorization + depth: depth + body: `(propfind (@ (xmlns "DAV:") + (xmlns:d "DAV:") + (xmlns:c ,caldav)) + (prop (,resource))))) + (unless (= 207 (response-code response)) + (scm-error 'dav-error "propfind" + "HTTP error ~a: ~a" + (list + (response-code response) + (response-reason-phrase response)) + (list response))) + (xml->sxml port + declare-namespaces?: #t + trim-whitespace?: #t + namespaces: `((d . "DAV:") + (c . ,caldav)))) + + +;; (define (get-collections) +;; (-> (propfind "/" 'resourcetype) +;; ((sxpath '(// (d:response (// d:resourcetype d:collection)) +;; d:href *text*))))) + +;; => ((d:resourcetype (d:collection))) + +(define* (get-principal uri key: password) + (-> (propfind uri 'current-user-principal + depth: 0 + password: password) + ((sxpath '(// (d:response (d:href (equal? "/"))) + // + d:prop d:current-user-principal + d:href *text*))) + car)) + +(define* (get-calendar-home-set principal-uri key: password) + (-> (propfind principal-uri + 'c:calendar-home-set + password: password) + ((sxpath `(// (d:response (d:href + (equal? ,(uri-path principal-uri)))) + // d:prop c:calendar-home-set + d:href *text* + ))) + car)) + +(define* (get-calendar-paths calendar-home-set-uri key: password) + (-> (propfind calendar-home-set-uri + 'resourcetype + depth: "infinity" + password: password) + ((sxpath '(// (d:response (// d:resourcetype c:calendar)) + d:href *text*))))) + +;; => ("Calendar") +(define* (get-calendar-name calendar-path + key: password) + (-> (propfind calendar-path 'displayname + depth: 0 + password: password) + ((sxpath '(// d:response // d:prop d:displayname *text*))) + car)) + + diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index aa3be1ed..a36efaef 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -3,15 +3,28 @@ :use-module (ice-9 regex) :use-module (ice-9 match) :use-module (ice-9 curried-definitions) + :use-module (ice-9 control) :use-module (srfi srfi-1) :use-module (srfi srfi-71) :use-module (srfi srfi-88) + :use-module ((web query) :select (parse-query)) + :use-module ((web response) :select (build-response)) + :use-module ((ice-9 iconv) :select (bytevector->string)) :export (parse-endpoint-string make-routes) ) +;; Parses an endpoint description, and returns two values: +;; - a regex string which matches the rule +;; - the list of symbols embedded int the string +;; An endpoint string looks like +;; /calendar/:uid{.*}.ics +;; Where "/calendar/" matches literally +;; followed by something matching ".*" +;; followed by something literally matching ".ics" +;; and '(uid) would be the second return (define (parse-endpoint-string str) (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?"))) (let loop ((str str) @@ -38,87 +51,130 @@ (cons (string->symbol (match:substring m 1)) tokens))))))) - -(define ((generate-case regex-table) defn) - (match defn +(define ((generate-case regexes r:method r:path) stx) + (syntax-case stx () ((method uri param-list body ...) - (let* ((_ tokens (parse-endpoint-string uri)) - (diff intersect (lset-diff+intersection eq? param-list tokens))) - `((and (eq? r:method (quote ,method)) - (regexp-exec ,(car (assoc-ref regex-table uri)) r:path)) - => (lambda (match-object) - ;; (assert - ;; (= (1- (match:count match-object)) - ;; (length intersect))) + (let* ((regex tokens (parse-endpoint-string (syntax->datum #'uri))) + (diff intersect (lset-diff+intersection eq? (syntax->datum #'param-list) + tokens)) + (argument-list (if (null? diff) + #'() #`(key: #,@(map (lambda (x) (datum->syntax stx x)) diff) + allow-other-keys: rest: rest))) + (intersect-list (map (lambda (x) (datum->syntax stx x)) intersect)) + (rx-var (list-ref (assoc regex regexes) 1))) + #`((and (eq? #,r:method (quote method)) + (regexp-exec #,rx-var #,r:path)) + => (lambda (match-object) + ;; Those parameters which were present in the template uri + ((lambda #,intersect-list + ;; Those that only are in the query string + (lambda* #,argument-list body ...)) + #,@(unless (null? intersect) + (map (lambda (i) #`(match:substring match-object #,i)) + (cdr (iota (1+ (length intersect))))))))))))) + + + +(define-syntax (make-routes stx) + (syntax-case stx () + ((_ options-and-routes ...) + (with-syntax ((r:method (datum->syntax stx 'r:method)) + (r:uri (datum->syntax stx 'r:uri)) + (r:version (datum->syntax stx 'r:version)) + (r:headers (datum->syntax stx 'r:headers)) + (r:meta (datum->syntax stx 'r:meta)) + (r:scheme (datum->syntax stx 'r:scheme)) + (r:userinfo (datum->syntax stx 'r:userinfo)) + (r:host (datum->syntax stx 'r:host)) + (r:port (datum->syntax stx 'r:port)) + (r:path (datum->syntax stx 'r:path)) + (r:query (datum->syntax stx 'r:query)) + (r:fragment (datum->syntax stx 'r:fragment)) + + (return (datum->syntax stx 'return)) + (request (datum->syntax stx 'request)) + (body (datum->syntax stx 'body)) + (state (datum->syntax stx 'state)) + ) + + (define-values (options routes) + (let loop ((options '()) (items #'(options-and-routes ...))) + (when (null? items) + (scm-error 'misc-error "make-routes" + "Needs at least one route" '() #f)) + ;; (format #t "options: ~s, items: ~s~%" options items) + (let ((kv (syntax->datum (car items)))) + (if (keyword? kv) + (loop (cons (cons kv (cadr items)) + options) + (cddr items)) + (values (reverse options) items))))) + + ;; Ensures that all regexes are only compiled once. + ;; Given (GET "/today/" (view date) body ...) + ;; returns ("/today/" #'*random-symbol* #'(make-regexp "^/today//?$" regexp/icase)) + (define routes-regexes + (map (lambda (stx-1) + (syntax-case stx-1 () + ((%fst uri %rest ...) + (let ((regex _ (parse-endpoint-string (syntax->datum #'uri)))) + (list regex (datum->syntax stx (gensym "rx-")) + #`(make-regexp #,(string-append "^" regex "/?$") regexp/icase)))))) + routes)) + + #`(let #,(map cdr routes-regexes) + (lambda* (request body optional: state) + ;; All these bindings generate compile time warnings since the expansion + ;; of the macro might not use them. This isn't really a problem. + (let ((r:method ((@ (web request) request-method) request)) + (r:uri ((@ (web request) request-uri) request)) + (r:version ((@ (web request) request-version) request)) + (r:headers ((@ (web request) request-headers) request)) + (r:meta ((@ (web request) request-meta) request))) + (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) + (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) + ;; uri-{host,port} is (probably) not set when we are a server, + ;; fetch them from the request instead + (r:host (or ((@ (web uri) uri-host) r:uri) + (and=> ((@ (web request) request-host) request) car))) + (r:port (or ((@ (web uri) uri-port) r:uri) + (and=> ((@ (web request) request-host) request) cdr))) + (r:path ((@ (web uri) uri-path) r:uri)) + (r:query ((@ (web uri) uri-query) r:uri)) + (r:fragment ((@ (web uri) uri-fragment) r:uri))) - ;; Those parameters which were present in the template uri - ((lambda ,intersect - ;; Those that only are in the query string - (lambda* (,@(unless (null? diff) `(key: ,@diff allow-other-keys:)) - rest: rest) - ,@body)) - ,@(unless (null? intersect) - (map (lambda (i) - `((@ (ice-9 regex) match:substring) match-object ,i)) - (cdr (iota (1+ (length intersect))))))))))))) + ;; TODO propper logging + (display (format #f "[~a] ~a ~a:~a~a?~a~%" + ;; TODO does this even work? Maybe it works due to datetime + ;; being included at all expansion points. + (datetime->string (current-datetime)) + r:method r:host r:port r:path (or r:query "")) + (current-error-port)) -(define-macro (make-routes . routes) - ;; Ensures that all regexes are only compiled once. - (define routes-regexes - (map (lambda (uri) - (define-values (regex _) (parse-endpoint-string uri)) - (list uri (gensym) `(make-regexp ,(string-append "^" regex "/?$") regexp/icase))) - (map cadr routes))) + (call-with-values + (lambda () + (call/ec (lambda (return) + (apply + (with-throw-handler #t + (lambda () + (cond #,@(map (generate-case routes-regexes #'r:method #'r:path) routes) + (else (lambda* _ (return (build-response code: 404) + "404 Not Fonud"))))) + #,(assoc-ref options with-throw-handler:)) + (append + (parse-query r:query) - `(let ,(map cdr routes-regexes) - (lambda* (request body optional: state) - ;; (format (current-error-port) "~a~%" request) - ;; All these bindings generate compile time warnings since the expansion - ;; of the macro might not use them. This isn't really a problem. - (let ((r:method ((@ (web request) request-method) request)) - (r:uri ((@ (web request) request-uri) request)) - (r:version ((@ (web request) request-version) request)) - (r:headers ((@ (web request) request-headers) request)) - (r:meta ((@ (web request) request-meta) request))) - (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) - (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) - ;; uri-{host,port} is (probably) not set when we are a server, - ;; fetch them from the request instead - (r:host (or ((@ (web uri) uri-host) r:uri) - (and=> ((@ (web request) request-host) request) car))) - (r:port (or ((@ (web uri) uri-port) r:uri) - (and=> ((@ (web request) request-host) request) cdr))) - (r:path ((@ (web uri) uri-path) r:uri)) - (r:query ((@ (web uri) uri-query) r:uri)) - (r:fragment ((@ (web uri) uri-fragment) r:uri))) - ;; TODO propper logging - (display (format #f "[~a] ~a ~a:~a~a?~a~%" - (datetime->string (current-datetime)) - r:method r:host r:port r:path (or r:query "")) - (current-error-port)) - (call-with-values - (lambda () - ((@ (ice-9 control) call/ec) - (lambda (return) - (apply - (cond ,@(map (generate-case routes-regexes) routes) - (else (lambda* _ (return ((@ (web response) build-response) code: 404) - "404 Not Fonud")))) - (append - ((@ (web query) parse-query) r:query) + ;; When content-type is application/x-www-form-urlencoded, + ;; decode them, and add it to the argument list + (cond ((assoc-ref r:headers 'content-type) + => (lambda (content-type) + (let ((type args (car+cdr content-type))) + (case type + ((application/x-www-form-urlencoded) + (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) + (parse-query (bytevector->string body encoding) + encoding))))))))))))) - ;; TODO what's happening here? - (let ((content-type (assoc-ref r:headers 'content-type))) - ((@ (hnh util) when) content-type - (let ((type (car content-type)) - (args (cdr content-type))) - ((@ (hnh util) when) - (eq? type 'application/x-www-form-urlencoded) - (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - ((@ (web query) parse-query) - ((@ (ice-9 iconv) bytevector->string) - body encoding) - encoding))))))))))) - (case-lambda ((headers body new-state) (values headers body new-state)) - ((headers body) (values headers body state)) - ((headers) (values headers "" state))))))))) + (case-lambda ((headers body new-state) (values headers body new-state)) + ((headers body) (values headers body state)) + ((headers) (values headers "" state)))))))))))) diff --git a/module/web/http/status-codes.scm b/module/web/http/status-codes.scm new file mode 100644 index 00000000..86be694f --- /dev/null +++ b/module/web/http/status-codes.scm @@ -0,0 +1,87 @@ +(define-module (web http status-codes) + :use-module (srfi srfi-88) + :export (http-status-codes + http-status-phrase + http-status-line)) + +;;; https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml +;;; DAV: RFC4918 + +(define http-status-codes + '((100 . "Continue") + (101 . "Switching Protocols") + (102 . "Processing") ;RFC2518 + (103 . "Early Hints") ;RFC8297 + + (200 . "OK") + (201 . "Created") + (202 . "Accepted") + (203 . "Non-Authoritative Information") + (204 . "No Content") + (205 . "Reset Content") + (206 . "Partial Content") + (207 . "Multi-Status") ;DAV + (208 . "Already Reported") ;RFC5842 + (226 . "IM Used") ;RFC3229 + + (300 . "Multiple Choices") + (301 . "Moved Permanently") + (302 . "Found") + (303 . "See Other") + (304 . "Not Modified") + (305 . "Use Proxy") + (306 . "(Unused)") + (307 . "Temporary Redirect") + (308 . "Permanent Redirect") + + (400 . "Bad Request") + (401 . "Unauthorized") + (402 . "Payment Required") + (403 . "Forbidden") + (404 . "Not Found") + (405 . "Method Not Allowed") + (406 . "Not Acceptable") + (407 . "Proxy Authentication Required") + (408 . "Request Timeout") + (409 . "Conflict") + (410 . "Gone") + (411 . "Length Required") + (412 . "Precondition Failed") ;Extended by DAV + (413 . "Request Entity Too Large") + (414 . "Request-URI Too Long") ;Extended by DAV + (415 . "Unsupported Media Type") + (416 . "Requested Range Not Satisfiable") + (417 . "Expectation Failed") + (418 . "I'm a teapot") ;RFC7168 + (421 . "Misdirection Request") + (422 . "Unprocessable Content") + (423 . "Locked") ;DAV + (424 . "Failed Dependency") ;DAV + (425 . "Too Early") ;RFC8470 + (426 . "Upgrade Required") + (428 . "Precondition Failed") ;RFC6585 + (429 . "Too Many Requests") ;RFC6585 + (431 . "Request Header Fields Too Large") ;RFC6585 + (451 . "Unavailable For Legal Reasons") ;RFC7225 + + (500 . "Internal Server Error") + (501 . "Not Implemented") + (502 . "Bad Gateway") + (503 . "Service Unavailable") + (504 . "Gateway Timeout") + (505 . "HTTP Version Not Supported") + (506 . "Variant Also Negotiates") ;RFC2295 + (507 . "Insufficient Storage") ;DAV + (508 . "Loop Detected") ;RFC5842 + (510 . "Not Extended") ;RFC2774 (OBSOLETED) + (511 . "Network Authentication Required") ;RFC6585 + )) + + +(define (http-status-phrase code) + (or (assoc-ref http-status-codes code) + "")) + +(define* (http-status-line code optional: msg) + (format #f "HTTP/1.1 ~a ~a" code + (or msg (http-status-phrase code)))) |