diff options
Diffstat (limited to 'module')
47 files changed, 767 insertions, 453 deletions
diff --git a/module/base64.scm b/module/base64.scm index 594edf1f..c0080581 100644 --- a/module/base64.scm +++ b/module/base64.scm @@ -39,7 +39,10 @@ (+ 26 (- byte a))] [(<= zero byte nine) (+ 26 26 (- byte zero))] - [else (error "Invalid encoded value" byte (integer->char byte))])) + [else (scm-error 'decoding-error + "encoded->real" + "Invalid character in Base64 string: ~s" + (list byte) #f)])) (define ref (make-procedure-with-setter diff --git a/module/c/cpp.scm b/module/c/cpp.scm index c782e468..3f50fb87 100644 --- a/module/c/cpp.scm +++ b/module/c/cpp.scm @@ -5,7 +5,7 @@ :use-module (ice-9 match) :use-module (ice-9 regex) :use-module ((rnrs io ports) :select (call-with-port)) - :use-module (ice-9 pretty-print) ; used by one error handler + :use-module (ice-9 format) :use-module ((hnh util io) :select (read-lines)) :use-module (hnh util graph) :use-module (c lex) @@ -25,7 +25,10 @@ (aif (regexp-exec define-re header-line) (cons (match:substring it 1) (match:substring it 4)) - (error "Line dosen't match" header-line))) + (scm-error 'c-parse-error + "tokenize-define-line" + "Line dosen't match: ~s" + (list header-line) #f))) (define-public (do-funcall function arguments) @@ -99,7 +102,7 @@ (map (lambda (line) (catch #t (lambda () (parse-cpp-define line)) - (lambda (err caller fmt args . _) + (lambda (err caller fmt args data) (format #t "~a ~?~%" fmt args) #f))) lines)) diff --git a/module/c/parse.scm b/module/c/parse.scm index 3e3d8024..8030da77 100644 --- a/module/c/parse.scm +++ b/module/c/parse.scm @@ -34,7 +34,9 @@ [(LL) '(long-long)] [(L) '(long)] [(U) '(unsigned)]) - (error "Invalid integer suffix"))) + (scm-error 'c-parse-error "parse-integer-suffix" + "Invalid integer suffix ~s" + (list str) #f))) (define (parse-lexeme-tree tree) (match tree @@ -113,11 +115,11 @@ `(funcall ,(parse-lexeme-tree function) ,(parse-lexeme-tree arguments))] - [bare (throw 'parse-error - 'parse-lexeme-tree - "Naked literal in lex-tree. How did that get there?" - '() - bare)])) + [bare (scm-error 'c-parse-error + "parse-lexeme-tree" + "Naked literal in lex-tree: ~s" + (list bare) + #f)])) ;; https://en.wikipedia.org/wiki/Operators_in_C_and_C%2B%2B @@ -175,7 +177,11 @@ (parse-lexeme-tree op) (mark-other (parse-lexeme-tree right)))] - [other (error "Not an infix tree ~a" other)])) + [other (scm-error 'c-parse-error + "flatten-infix" + "Not an infix tree ~a" + (list other) + #f)])) diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm index 5f298de4..d416b004 100644 --- a/module/calp/entry-points/convert.scm +++ b/module/calp/entry-points/convert.scm @@ -69,7 +69,7 @@ (@ (vcomponent formats xcal parse) sxcal->vcomponent) ;; TODO strip *TOP* xml->sxml)] - [else (error "")] + [else (scm-error 'misc-error "convert-main" "Unexpected parser type: ~a" (list from) #f)] )) (define writer @@ -86,7 +86,7 @@ (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) component) port))] - [else (error "")])) + [else (scm-error 'misc-error "convert-main" "Unexpected writer type: ~a" (list to) #f)])) (call-with-output-file outfile diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index 2a559794..8478aa6c 100644 --- a/module/calp/entry-points/html.scm +++ b/module/calp/entry-points/html.scm @@ -1,6 +1,7 @@ (define-module (calp entry-points html) :export (main) :use-module (hnh util) + :use-module ((hnh util exceptions) :select (warning)) :use-module ((hnh util path) :select (path-append)) :use-module (calp util time) :use-module (hnh util options) @@ -63,16 +64,31 @@ for embedding in a larger page. Currently only applies to the <i>small</i> style ;; file existing but is of wrong type, (define (create-files output-directory) - - (let* ((link (path-append output-directory "static"))) - - (unless (file-exists? output-directory) - (mkdir output-directory)) - - ;; TODO nicer way to resolve static - (let ((link (path-append output-directory "static"))) - (unless (file-exists? link) - (symlink (path-append (xdg-data-home) "calp" "www" "static") link))))) + (define link (path-append output-directory "static")) + ;; NOTE the target path is newer created + (define target (path-append (xdg-data-home) "calp" "www" "static")) + + (unless (file-exists? output-directory) + (mkdir output-directory)) + + (catch 'system-error + (lambda () (symlink target link)) + (lambda (err proc fmt fmt-args data) + (define errno (car data)) + (cond ((= errno EACCES) + (warning (format #f "~?" fmt fmt-args))) + ((= errno EEXIST) + (let ((st (lstat link))) + (cond ((not (eq? 'symlink (stat:type st))) + (warning "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" + link (readlink link) target)))) + ;; else, file exists as a symlink, and points where we want, + ;; which is expected. Do nothing and be happy. + ) + ;; Rethrow + (else (scm-error err proc fmt fmt-args data)))))) (define (re-root-static tree) @@ -164,7 +180,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 - (error (_ "Unknown html style: ~a") style)]) + (scm-error 'misc-error "html-main" (_ "Unknown html style: ~a") (list style) #f)]) ((@ (calp util time) report-time!) (_ "all done")) ) diff --git a/module/calp/entry-points/import.scm b/module/calp/entry-points/import.scm index 28fb72a6..cb8b9485 100644 --- a/module/calp/entry-points/import.scm +++ b/module/calp/entry-points/import.scm @@ -4,6 +4,7 @@ :use-module (hnh util options) :use-module (ice-9 getopt-long) :use-module (ice-9 rdelim) + :use-module (ice-9 format) :use-module (srfi srfi-1) ;; TODO FIX ;; :use-module (output vdir) diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm index d42a5d3a..1888a8a7 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -6,6 +6,7 @@ :use-module (srfi srfi-1) :use-module (ice-9 getopt-long) + :use-module (ice-9 format) :use-module (calp translation) :use-module (sxml simple) diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index 0d6fbf1c..6642b1fe 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -58,7 +58,10 @@ allow-other-keys: rest: args) (when (and onclick href) - (error (_ "Only give one of onclick, href and submit."))) + (scm-error 'wrong-type-arg "btn" + (_ "href and onclick are mutually exclusive. href = ~s, onclick = ~s.") + (list href onclick) + #f)) (let ((body #f)) `(,(cond [href 'a] diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm index aa3d9233..affaf5d2 100644 --- a/module/calp/html/util.scm +++ b/module/calp/html/util.scm @@ -18,6 +18,7 @@ ;; Returns a color with good contrast to the given background color. ;; https://stackoverflow.com/questions/1855884/determine-font-color-based-on-background-color/1855903#1855903 (define-public (calculate-fg-color c) + ;; TODO what errors can actually appear here? (catch #t (lambda () (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16)) diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index ffdd37e2..5c92e1e7 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -3,6 +3,7 @@ ;; TODO should we really use path-append here? Path append is ;; system-dependant, while URL-paths aren't. :use-module ((hnh util path) :select (path-append)) + :use-module ((hnh util exceptions) :select (warning)) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module ((rnrs io ports) :select (put-bytevector)) @@ -18,15 +19,37 @@ :use-module ((vcomponent recurrence) :select (repeating?)) :use-module ((vcomponent datetime output) :select (fmt-time-span - format-description - format-summary format-recurrence-rule )) - :use-module ((calp util config) :select (get-config)) + :use-module (calp util config) :use-module ((base64) :select (base64encode)) + :use-module (ice-9 format) :use-module (calp translation) ) +(define-config summary-filter (lambda (_ a) a) + pre: (ensure procedure?)) + +(define-config description-filter (lambda (_ a) a) + pre: (ensure procedure?)) + + +(define-public (format-summary ev str) + ((get-config 'summary-filter) ev str)) + +;; NOTE this should have information about context (html/term/...) +;; And then be moved somewhere else. +(define-public (format-description ev str) + (catch* (lambda () ((get-config 'description-filter) ev str)) + (configuration-error + (lambda (key subr msg args data) + (format (current-error-port) + "Error retrieving configuration, ~?~%" msg args))) + (#t ; for errors when running the filter + (lambda (err . args) + (warning "~a on formatting description, ~s" err args) + str)))) + ;; used by search view (define-public (compact-event-list list) @@ -222,11 +245,11 @@ (stream-map (lambda (ev) (fmt-single-event - ev `((id ,(html-id ev)) + ev `((id ,(html-id ev) "-side") (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) "unknown")))) fmt-header: (lambda body - `(a (@ (href "#" ,(html-id ev) #; (date-link (as-date (prop ev 'DTSTART))) + `(a (@ (href "#" ,(html-id ev) "-block" #; (date-link (as-date (prop ev 'DTSTART))) ) (class "hidelink")) ,@body)))) @@ -259,11 +282,11 @@ ;; surrounding <a /> element which allows something to happen when an element ;; is clicked with JS turned off. Our JS disables this, and handles clicks itself. - `((a (@ (href "#" ,(html-id ev)) + `((a (@ (href "#" ,(html-id ev) "-side") (class "hidelink")) (vevent-block (@ ,@(assq-merge extra-attributes - `((id ,(html-id ev)) + `((id ,(html-id ev) "-block") (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) "unknown"))) (data-uid ,(output-uid ev)) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index c7a5c8c2..d4ad2977 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -27,6 +27,8 @@ :use-module ((vcomponent util group) :select (group-stream get-groups-between)) :use-module ((base64) :select (base64encode)) + + :use-module (ice-9 format) :use-module (calp translation) ) @@ -73,10 +75,10 @@ ,display))) (unless next-start - (error 'html-generate (_ "Next-start needs to be a procedure"))) + (scm-error 'misc-error "html-generate" (_ "Next-start needs to be a procedure") #f #f)) (unless prev-start - (error 'html-generate (_ "Prev-start needs to be a procedure"))) + (scm-error 'misc-error "html-generate" (_ "Prev-start needs to be a procedure") #f #f)) (xhtml-doc (@ (lang sv)) @@ -118,11 +120,12 @@ window.default_calendar='~a';" ,(include-alt-css "/static/light.css" '(title "Light")) (script (@ (src "/static/script.out.js"))) + (script (@ (src "/static/user/user-additions.js"))) ,(calendar-styles calendars) ,@(when (debug) - '((style ".root { background-color: pink; }")))) + '((style ":root { --background-color: pink; }")))) (body (div (@ (class "root")) diff --git a/module/calp/html/view/calendar/shared.scm b/module/calp/html/view/calendar/shared.scm index 11f1a70c..e333dc4a 100644 --- a/module/calp/html/view/calendar/shared.scm +++ b/module/calp/html/view/calendar/shared.scm @@ -1,21 +1,19 @@ (define-module (calp html view calendar shared) :use-module (hnh util) - :use-module ((hnh util exceptions) :select (assert)) :use-module (srfi srfi-1) :use-module (vcomponent) :use-module ((vcomponent datetime) :select (event-length overlapping? event-length/clamped)) - :use-module ((vcomponent datetime output) - :select (format-summary)) :use-module (hnh util tree) :use-module (datetime) :use-module (calp html config) :use-module ((calp html components) :select (btn tabset)) :use-module ((calp html vcomponent) - :select (make-block) ) + :select (make-block format-summary)) + :use-module (ice-9 format) ) @@ -33,7 +31,10 @@ ;; only find events which also overlaps the ;; smaller event. - (assert event-length-key) + (unless event-length-key + (scm-error 'wrong-type-arg "fix-event-widths!" + "event-length-key is required" + #f #f)) ;; @var{x} is how for left in the container we are. (let inner ((x 0) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 921bdb83..16337102 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -20,6 +20,7 @@ :use-module (calp translation) :use-module ((vcomponent util group) :select (group-stream get-groups-between)) + :use-module (ice-9 format) ) diff --git a/module/calp/main.scm b/module/calp/main.scm index ebff00fd..e5388ae0 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -119,8 +119,11 @@ the same code as <b>ical</b>.</p>") (cond [altconfig (if (file-exists? altconfig) altconfig - (throw 'option-error - (_ "Configuration file ~a missing") 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? @@ -159,7 +162,7 @@ the same code as <b>ical</b>.</p>") (reverse done) (loop (cons form done)))))))) (make-sandbox-module - `(((guile) use-modules) + `(((guile) use-modules resolve-interface module-ref) ,@all-pure-and-impure-bindings )) )) @@ -215,7 +218,10 @@ the same code as <b>ical</b>.</p>") (when (option-ref opts 'update-zoneinfo #f) (let* ((locations (list "/usr/libexec/calp/tzget" (path-append (xdg-data-home) "tzget"))) (filename (or (find file-exists? locations) - (error (_ "tzget not installed, please put it in one of ~a") locations))) + (scm-error 'missing-helper "wrapped-main" + (_ "tzget not installed, please put it in one of ~a") + (list locations) + (list "tzget" locations)))) (pipe (open-input-pipe filename))) ;; (define path (read-line pipe)) @@ -237,6 +243,8 @@ the same code as <b>ical</b>.</p>") '("term")))) ((case (string->symbol (car ropt)) ((html) (@ (calp entry-points html) main)) + ;; TODO chnange term to be non-interactive term + ;; and then add interactive-term (or similar) ((term) (@ (calp entry-points terminal) main)) ((import) (@ (calp entry-points import) main)) ((text) (@ (calp entry-points text) main)) diff --git a/module/calp/repl.scm b/module/calp/repl.scm index 9b2df13f..6f2c7c0a 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -22,8 +22,9 @@ [else 'UNIX]) [(UNIX) (add-hook! shutdown-hook (lambda () (catch 'system-error (lambda () (delete-file address)) - (lambda (err proc fmt . args) - (warning (_ "Failed to unlink ~a") address args) + (lambda (err proc fmt args data) + (warning (string-append (format #f (_ "Failed to unlink ~a") address) + (format #f ": ~?" fmt args))) err)))) (make-unix-domain-server-socket path: address)] [(IPv4) (apply (case-lambda diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 2f3544ee..d05451eb 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -1,14 +1,13 @@ (define-module (calp server routes) :use-module (hnh util) - :use-module ((hnh util path) :select (path-append)) - :use-module (hnh util options) + :use-module (hnh util path) :use-module (hnh util exceptions) :use-module (srfi srfi-1) :use-module ((ice-9 rdelim) :select (read-string)) :use-module ((ice-9 ftw) :select (scandir)) - :use-module (ice-9 regex) #| regex here due to bad macros |# + :use-module (ice-9 format) :use-module ((web response) :select (build-response)) :use-module ((web uri) :select (build-relative-ref)) @@ -32,6 +31,7 @@ :autoload (vcomponent util instance) (global-event-object) + :use-module (calp util config) :use-module (calp html view calendar) :use-module ((calp html view search) :select (search-result-page)) @@ -47,27 +47,50 @@ -(define (directory-table dir) - `(table - (thead - (tr (th "") (th ,(_ "Name")) - ;; File permissions, should be about as long as three digits - (th ,(_ "Perm")))) +;; @var{prefix} directory tree which should be exported +;; @var{dir} location in exported directory tree +;; Note that the exported url is currently hard-coded to +;; start with /static. +(define (directory-table prefix dir) + `(table (@ (class "directory-table")) + (thead + (tr (th "") + (th ,(_ "Name")) + ;; File permissions, should be about as long as three digits + (th ,(_ "Perm")) + ;; File size + (th ,(_ "Size")))) (tbody + (tr (td "↩️") (td (@ (colspan 3)) + (a (@ (href ,(-> (path-split dir) + (drop-right 1) + (xcons "/static") + path-join))) + "Return up"))) ,@(map (lambda (k) - (let* ((stat (lstat (path-append dir k)))) + (let* ((stat (lstat (path-append prefix dir k)))) `(tr (td ,(case (stat:type stat) [(directory) "📁"] [(regular) "📰"] + [(symlink) "🔗"] + [(block-special) "🖴"] + [(char-special) "🔌"] + ;; [(fifo)] + ;; [(socket)] [else "🙃"])) - (td (a (@ (href "/" ,dir "/" ,k)) ,k)) - (td ,(number->string (stat:perms stat) 8))))) - (cdr (or (scandir dir) - (scm-error - 'misc-error - "directory-table" - (_ "Scandir argument invalid or not directory: ~a") - (list dir) '()))))))) + (td (a (@ (href ,(path-append "/static" dir k))) + ,k)) + (td ,(number->string (stat:perms stat) 8)) + (td (@ (style "text-align:end")) + (data (@ (value ,(stat:size stat))) + ,(format #f "~:d" (stat:size stat))))))) + ;; cddr drops '.' and '..' + (cddr (or (scandir (path-append prefix dir)) + (scm-error + 'misc-error + "directory-table" + (_ "Scandir argument invalid or not directory: ~s") + (list dir) '()))))))) @@ -88,6 +111,14 @@ +(define static-dir (make-parameter "static")) + +(define-config static-dir "static" + description: "Where static files for the web server are located" + post: static-dir + ) + + ;; TODO ensure encoding on all fields which take user provided data. ;; Possibly a fallback which strips everything unknown, and treats @@ -234,70 +265,22 @@ ;; accidental overwriting. - (cond - [(get-event-by-uid global-event-object (prop event 'UID)) - => (lambda (old-event) - - ;; remove old instance of event from runtime - ((@ (vcomponent util instance methods) remove-event) - global-event-object old-event) - - ;; Add new event to runtime, - ;; MUST be done after since the two events SHOULD share UID. - (parameterize ((warnings-are-errors #t)) - (catch 'warning - (lambda () (add-event global-event-object calendar event)) - (lambda (err fmt args) - (return (build-response code: 400) - (format #f "~?~%" fmt args))))) - - (set! (prop event 'LAST-MODIFIED) - (current-datetime)) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - - ;; 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) - (return (build-response code: 500) - (_ "Saving event to disk failed."))) - - - (unless (eq? calendar (parent old-event)) - ;; change to a new calendar - (format (current-error-port) - ;; unlinks (removes) a single event, argument is a file name - (_ "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 - ;; which either a better atomic model, or a propper error - ;; recovery log would solve. - ((@ (vcomponent formats vdir save-delete) remove-event) old-event)) - - - (format (current-error-port) - (_ "Event updated ~a~%") (prop event 'UID)))] - - [else - (parameterize ((warnings-are-errors #t)) - (catch 'warning - (lambda () (add-event global-event-object calendar event)) - (lambda (err fmt args) - (return (build-response code: 400) - (format #f "~?~%" fmt args))))) - - (set! (prop event 'LAST-MODIFIED) (current-datetime)) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - (unless ((@ (vcomponent formats vdir save-delete) save-event) event) - (return (build-response code: 500) - (_ "Saving event to disk failed."))) - - (format (current-error-port) - (_ "Event inserted ~a~%") (prop event 'UID))]) + (parameterize ((warnings-are-errors #t)) + (catch* + (lambda () (add-and-save-event global-event-object + calendar event)) + (warning + (lambda (err fmt args) + (define str (format #f "~?" fmt args)) + (format (current-error-port) "400 ~a~%" str) + (return (build-response code: 400) + str))) + (#t + (lambda (err proc fmt args _) + (define str (format #f "~a in ~a: ~?~%" err proc fmt args)) + (format (current-error-port) "500 ~a~%" str) + (return (build-response code: 500) + str))))) (return '((content-type application/xml)) (with-output-to-string @@ -395,28 +378,27 @@ (define error #f) (define search-result - (catch #t - (lambda () - (catch 'max-page - ;; TODO Get-page only puts a time limiter per page, meaning that - ;; if a user requests page 1000 the server is stuck trying to - ;; find that page, which can take up to 1000 * timeslice = 500s = 8min+ - ;; A timeout here, and also an actual multithreaded server should - ;; solve this. - (lambda () (get-page paginator page)) - (lambda (err page-number) - (define location - (build-relative-ref - path: r:path ; host: r:host port: r:port - query: (encode-query-parameters - `((p . ,page-number) - (q . ,search-term))))) - (return (build-response - code: 307 - headers: `((location . ,location))))))) - (lambda (err callee fmt arg data) - (set! error - (format #f "~?~%" fmt arg))))) + ;; TODO Get-page only puts a time limiter per page, meaning that + ;; if a user requests page 1000 the server is stuck trying to + ;; find that page, which can take up to 1000 * timeslice = 500s = 8min+ + ;; A timeout here, and also an actual multithreaded server should + ;; solve this. + (catch* (lambda () (get-page paginator page)) + (max-page + (lambda (err page-number) + (define location + (build-relative-ref + path: r:path ; host: r:host port: r:port + query: (encode-query-parameters + `((p . ,page-number) + (q . ,search-term))))) + (return (build-response + code: 307 + headers: `((location . ,location)))))) + (#t + (lambda (err callee fmt arg data) + (set! error + (format #f "~?~%" fmt arg)))))) (return '((content-type application/xhtml+xml)) (with-output-to-string @@ -431,6 +413,7 @@ ;; is mostly for development, and something like nginx should be used in ;; production it isn't a huge problem. + (GET "/static/:*{.*}.:ext" (* ext) ;; Actually parsing /etc/mime.types would be better. @@ -439,16 +422,33 @@ [(js) "javascript"] [else ext])) - (return - `((content-type ,(string->symbol (string-append "text/" mime)))) - (call-with-input-file (string-append "static/" * "." ext) - read-string))) - - (GET "/static/:*{.*}" (*) - (return - '((content-type text/html)) - (sxml->html-string - (directory-table (path-append "static" *))))) + (catch 'system-error + (lambda () + (return + `((content-type ,(string->symbol (string-append "text/" mime)))) + (call-with-input-file (path-append (static-dir) (string-append * "." ext)) + read-string))) + (lambda (err proc fmt fmt-args data) + (warning (format #f "404|500: ~?" fmt fmt-args)) + (if (= ENOENT (car data)) + (return (build-response code: 404) + (format #f "~?" fmt fmt-args)) + (scm-error err proc fmt fmt-args data))))) + + ;; Note that `path' will most likely start with a slash + (GET "/static:path{.*}" (path) + (catch + 'misc-error + (lambda () (return + '((content-type text/html)) + (sxml->html-string + `(html + (head (title "Calp directory listing for " path) + ,((@ (calp html components) include-css) "/static/directory-listing.css")) + (body ,(directory-table (static-dir) path)))))) + (lambda (err proc fmt fmt-args data) + (return (build-response code: 404) + (format #f "~?" fmt fmt-args))))) ;; This is almost the same as /static/, but with the difference that ;; we produce these images during runtime diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index e982c468..d91dc584 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -32,6 +32,9 @@ #:export (main-loop)) + +;;; TODO change all hard coded escape sequences to proper markup + (define-values (height width) (get-terminal-size)) (define (open-in-editor fname) @@ -123,7 +126,8 @@ (cls) - (display (_ "== Day View ==\n")) + (display (_ "== Day View ==")) + (newline) (display-calendar-header! (current-page this)) diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm index 2637cd85..3bc55d92 100644 --- a/module/calp/util/config.scm +++ b/module/calp/util/config.scm @@ -38,10 +38,13 @@ (define (define-config% name default-value kwargs) (for (key value) in (group kwargs 2) - (set! ((or (hashq-ref config-properties key) - (error (_ "Missing config protperty slot ") key)) - name) - value)) + (aif (hashq-ref config-properties key) + (set! (it name) value) + (scm-error 'configuration-error + "define-config" + (_ "No configuration slot named ~s, when defining ~s") + (list key name) + #f))) (set-config! name (get-config name default-value))) (define-syntax define-config @@ -54,7 +57,14 @@ (define-public (set-config! name value) (hashq-set! config-values name (aif (pre name) - (or (it value) (error (_ "Pre crashed for") name)) + (or (it value) + (scm-error 'configuration-error + "set-config!" + ;; first slot is property name, second is new + ;; property value. + (_ "Pre-property failed when setting ~s to ~s") + (list name value) + #f)) value)) (awhen (post name) (it value))) @@ -65,15 +75,18 @@ (if (eq? default %uniq) (let ((v (hashq-ref config-values key %uniq))) (when (eq? v %uniq) - (error (_ "Missing config") key)) + (scm-error 'configuration-error + "get-config" + (_ "No configuration item named ~s") + (list key) #f)) v) (hashq-ref config-values key default))) (define-public ((ensure predicate) value) - (if (not (predicate value)) - #f value)) + (if (predicate value) + value #f)) @@ -107,6 +120,8 @@ (export format-procedure) +;; TODO break this up into separate `get-all-configuration-items' and +;; `format-configuration-items' procedures (define-public (get-configuration-documentation) (define groups (group-by (compose source-module car) diff --git a/module/calp/util/time.scm b/module/calp/util/time.scm index 0a624d30..f3789eeb 100644 --- a/module/calp/util/time.scm +++ b/module/calp/util/time.scm @@ -1,5 +1,6 @@ (define-module (calp util time) :use-module (ice-9 match) + :use-module (ice-9 format) :export (report-time! profile!)) diff --git a/module/crypto.scm b/module/crypto.scm index 3e468018..477014e9 100644 --- a/module/crypto.scm +++ b/module/crypto.scm @@ -1,6 +1,7 @@ (define-module (crypto) :use-module (rnrs bytevectors) :use-module (system foreign) + :use-module (ice-9 format) :export (sha256 checksum->string)) (define-once libcrypto (dynamic-link "libcrypto")) @@ -21,17 +22,15 @@ (define bv (cond ((bytevector? msg) msg) ((string? msg) (string->utf8 msg)) - (else (throw 'value-error "Invalid type")))) + (else (scm-error 'wrong-type-arg "sha256" + "Wrong type argument. Expected string or bytevector, got ~s" + (list msg) (list msg))))) (SHA256 ((@ (system foreign) bytevector->pointer) bv) (bytevector-length bv) ((@ (system foreign) bytevector->pointer) md)) md) -(define (checksum->string md) - (string-concatenate - (map (lambda (byte) - (format #f "~x~x" - (logand #xF (ash byte -4)) - (logand #xF byte))) - (bytevector->u8-list md)))) +(define* (checksum->string md #:optional port) + ((@ (ice-9 format) format) port + "~{~2'0x~}" (bytevector->u8-list md))) diff --git a/module/datetime.scm b/module/datetime.scm index 3b03bf53..478fc479 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -10,12 +10,10 @@ :use-module (srfi srfi-9 gnu) :use-module ((hnh util) - :select (vector-last define*-public set! -> swap case* set + :select (vector-last define*-public set! -> ->> swap case* set span-upto let* set->)) :use-module (srfi srfi-41) - :use-module ((srfi srfi-41 util) - :select (with-streams)) :use-module (ice-9 i18n) :use-module (ice-9 format) :use-module (ice-9 regex) @@ -67,6 +65,11 @@ (year year) (month month) (day day)) (define*-public (date key: (year 0) (month 0) (day 0)) + (unless (and (integer? year) (integer? month) (integer? day)) + (scm-error 'wrong-type-arg "date" + "Year, month, and day must all be integers. ~s, ~s, ~s" + (list year month day) + #f)) (make-date year month day)) (set-record-type-printer! @@ -74,7 +77,7 @@ (lambda (r p) (catch 'misc-error (lambda () (display (date->string r "#~Y-~m-~d") p)) - (lambda (err _ fmt args . rest) + (lambda (err proc fmt args data) (format p "#<<date> BAD year=~s month=~s day=~s>" (year r) (month r) (day r)))))) @@ -535,14 +538,15 @@ (iota (modulo (- (* 7 5) month-len month-start) 7) 1))))) +;; The amount of days in the given interval, both end pointts inclusive (define-public (days-in-interval start-date end-date) (let ((diff (date-difference (date+ end-date (date day: 1)) start-date))) - (with-streams - (fold + (day diff) - (map days-in-month - (take (+ (month diff) - (* 12 (year diff))) - (month-stream start-date))))))) + (->> (month-stream start-date) + (stream-take (+ (month diff) + (* 12 (year diff)))) + (stream-map days-in-month) + (stream-fold + (day diff))))) + ;; Day from start of the year, so 1 feb would be day 32. ;; Also known as Julian day. @@ -676,6 +680,11 @@ Returns -1 on failure" [else dt])) (cond [(null? str) + ;; TODO should this be considered an error? + ;; Should it be toggleable through a flag. + ;; It's sometimes useful to allow it, since it allows optional + ;; trailing fields, but sometimes useful to disallow it, since + ;; it gives a better check that the data is valid ;; ((@ (hnh util exceptions) warning) ;; "Premature end of string, still got fmt = ~s" ;; fmt) @@ -736,11 +745,15 @@ Returns -1 on failure" (let* ((head post (cond ((null? (cddr fmt)) (values str '())) ((eqv? #\~ (caddr fmt)) (cond ((null? (cdddr fmt)) - (error "Unexpected ~ at end of fmt")) + (scm-error 'misc-error "string->datetime" + "Unexpected ~ at end of fmt" + #f #f)) ((eqv? #\~ (cadddr fmt)) (span (lambda (c) (not (eqv? #\~ c))) str)) - (else (error "Can't have format specifier directly after month by name")))) + (else (scm-error 'misc-error "string->datetime" + "Can't have format specifier directly after month by name" + #f #f)))) (else (span (lambda (c) (not (eqv? c (caddr fmt)))) str))))) (loop post @@ -1125,7 +1138,7 @@ Returns -1 on failure" ;; overflow is number of days above ;; time x time → time x int -(define-public (time+% base change) +(define (time+% base change) ;; while (day base) > (days-in-month base) ;; month++; days -= (days-in-month base) diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm index ea29a423..099634b6 100644 --- a/module/datetime/timespec.scm +++ b/module/datetime/timespec.scm @@ -65,15 +65,6 @@ specs)) -(define (parse-time string) - (apply (lambda* (hour optional: (minute "0") (second "0")) - (time hour: (string->number hour) - minute: (string->number minute) - ;; discard sub-seconds - second: (string->number (car (string-split second #\.))))) - (string-split string #\:))) - - (define*-public (parse-time-spec string optional: (suffixes '(#\s #\w #\u #\g #\z))) (let* ((type string @@ -82,11 +73,12 @@ (values (string-ref string idx) (substring string 0 idx)))] [else (values #\w string)]))) + ;; Note that string->time allows a longer format than the input (cond [(string=? "-" string) (make-timespec (time) '+ type)] [(string-prefix? "-" string) - (make-timespec (parse-time (string-drop string 1)) + (make-timespec (string->time (string-drop string 1) "~H:~M:~S") '- type)] [else - (make-timespec (parse-time string) + (make-timespec (string->time string "~H:~M:~S") '+ type)]))) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 0362ec99..e2600d4f 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -92,14 +92,14 @@ ;; @end example (define-public (get-zone zoneinfo name) (or (hash-ref (zoneinfo-zones zoneinfo) name) - (error "No zone ~a" name))) + (scm-error 'misc-error "get-zone" "No zone ~a" (list name) #f))) ;; @example ;; (get-rule zoneinfo 'EU) ;; @end example (define-public (get-rule zoneinfo name) (or (hashq-ref (zoneinfo-rules zoneinfo) name) - (error "No rule ~a" name))) + (scm-error 'misc-error "get-rule" "No rule ~a" (list name) #f))) @@ -119,7 +119,9 @@ [(string-prefix? name "October") 10] [(string-prefix? name "November") 11] [(string-prefix? name "December") 12] - [else (error "Unknown month" name)])) + [else (scm-error 'misc-error "month-name->number" + "Unknown month ~s" (list name) + #f)])) (define (string->weekday name) @@ -131,7 +133,9 @@ [(string-prefix? name "Friday") fri] [(string-prefix? name "Saturday") sat] [(string-prefix? name "Sunday") sun] - [else (error "Unknown week day" name)])) + [else (scm-error 'misc-error "string->weekday" + "Unknown week day ~s" + (list name) #f)])) (define (parse-from str) @@ -259,8 +263,10 @@ ;; NOTE an earlier version of the code the parsers for those. ;; They were removed since they were unused, uneeded, and was ;; technical dept. - (error (_ "Invalid key ~a. Note that leap seconds and -expries rules aren't yet implemented.") type)] + (scm-error 'misc-error "parse-zic-file" + (_ "Invalid key ~s. Note that leap seconds and expries rules aren't yet implemented.") + (list type) + #f)] ))])))))) @@ -357,7 +363,9 @@ expries rules aren't yet implemented.") type)] until: (let ((to (rule-to rule))) (case to ((maximum) #f) - ((minimum) (error (_ "Check your input"))) + ((minimum) (scm-error 'misc-error "rule->rrule" + (_ "Check your input") + #f #f)) ((only) (datetime date: (date year: (rule-from rule) month: 1 day: 1))) @@ -403,4 +411,12 @@ expries rules aren't yet implemented.") type)] (warning (_ "%z not yet implemented")) fmt-string] - [else (error (_ "Invalid format char"))]))) + [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") + (list (string-index fmt-string (1+ idx)) + fmt-string + (1+ idx)) + #f)]))) diff --git a/module/glob.scm b/module/glob.scm index a436b810..82489565 100644 --- a/module/glob.scm +++ b/module/glob.scm @@ -6,8 +6,10 @@ (define (glob-err epath eerrno) - (error "Glob errored on ~s with errno = ~a" - (pointer->string epath) eerrno)) + (scm-error 'misc-error "glob-err" + "Glob errored on ~s with errno = ~a" + (list (pointer->string epath) eerrno) + #f)) ;; NOTE there really should be an (c eval) module, to resolve symbols such as ;; @var{<<}. @@ -29,7 +31,10 @@ (procedure->pointer int glob-err (list '* int)) (bytevector->pointer bv)))) (unless (zero? globret) - (error "Globret errror ~a" globret)) + (scm-error 'misc-error "glob" + "Globret errror ~a" + (list globret) + #f)) (let* ((globstr (parse-c-struct (bytevector->pointer bv) (list size_t '* size_t))) (strvec (pointer->bytevector (cadr globstr) (car globstr) 0 (string->symbol (format #f "u~a" (* 8 (sizeof '*)))))) diff --git a/module/hnh/util.scm b/module/hnh/util.scm index 8cbc8c8d..3019b35b 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -13,6 +13,7 @@ and=>> label print-and-return begin1 + catch* ) #:replace (let* set! define-syntax when unless)) @@ -247,18 +248,20 @@ ;; and the other items in some order. ;; Ord b => (list a) [, (b, b -> bool), (a -> b)] -> a, (list a) (define*-public (find-extreme items optional: (< <) (access identity)) - (if (null? items) - (error "Can't find extreme in an empty list") - (fold-values - (lambda (c min other) - (if (< (access c) (access min)) - ;; Current stream head is smaller that previous min - (values c (cons min other)) - ;; Previous min is still smallest - (values min (cons c other)))) - (cdr items) - ;; seeds: - (car items) '()))) + (when (null? items) + (scm-error 'wrong-type-arg "find-extreme" + "Can't find extreme in an empty list" + #f #f)) + (fold-values + (lambda (c min other) + (if (< (access c) (access min)) + ;; Current stream head is smaller that previous min + (values c (cons min other)) + ;; Previous min is still smallest + (values min (cons c other)))) + (cdr items) + ;; seeds: + (car items) '())) (define*-public (find-min list optional: (access identity)) (find-extreme list < access)) @@ -576,8 +579,10 @@ (for-each (lambda (pair) (setenv (car pair) (caddr pair))) env-pairs))))])) - -(define-public (uuidgen) - ((@ (rnrs io ports) call-with-port) - ((@ (ice-9 popen) open-input-pipe) "uuidgen") - (@ (ice-9 rdelim) read-line))) +(define-syntax catch* + (syntax-rules () + ((_ thunk (key handler)) + (catch (quote key) thunk handler)) + ((_ thunk (key handler) rest ...) + (catch* (lambda () (catch (quote key) thunk handler)) + rest ...)))) diff --git a/module/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm index bcfd506d..eed310bb 100644 --- a/module/hnh/util/exceptions.scm +++ b/module/hnh/util/exceptions.scm @@ -6,7 +6,7 @@ #:use-module ((system vm frame) :select (frame-bindings binding-ref)) - #:export (assert)) + ) (define-public warning-handler @@ -31,20 +31,6 @@ (raise 2) ) -(define (prettify-tree tree) - (cond [(pair? tree) (cons (prettify-tree (car tree)) - (prettify-tree (cdr tree)))] - [(and (procedure? tree) (procedure-name tree)) - => identity] - [else tree])) - - -(define-macro (assert form) - `(unless ,form - (throw 'assertion-error "Assertion failed. ~a expected, ~a got" - (quote ,form) - ((@@ (calp util exceptions) prettify-tree) (list ,form))))) - (define-public (filter-stack pred? stk) (concatenate diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm index 912f9612..03c2ae3c 100644 --- a/module/hnh/util/graph.scm +++ b/module/hnh/util/graph.scm @@ -73,8 +73,9 @@ (define-public (find-and-remove-node-without-dependencies graph) (let ((node (find-node-without-dependencies graph))) (unless node - (throw 'graph-error 'find-and-remove-node-without-dependencies - "No node without dependencies in graph" '() graph)) + (scm-error 'graph-error "find-and-remove-node-without-dependencies" + "No node without dependencies in graph" + #f (list graph))) (values node (remove-node graph node)))) ;; Assumes that the edges of the graph are dependencies. @@ -89,5 +90,5 @@ '() (let* ((node graph* (find-and-remove-node-without-dependencies graph))) (cons node (loop graph*)))))) - (lambda (err caller fmt args graph . data) - graph))) + (lambda (err caller fmt args data) + (car graph)))) diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm index 161e09a0..3a595b67 100644 --- a/module/hnh/util/io.scm +++ b/module/hnh/util/io.scm @@ -1,4 +1,5 @@ (define-module (hnh util io) + :use-module ((hnh util) :select (begin1)) :use-module ((ice-9 rdelim) :select (read-line))) (define-public (open-input-port str) @@ -13,18 +14,18 @@ (define-public (read-lines port) - (with-input-from-port port - (lambda () - (let loop ((line (read-line))) - (if (eof-object? line) - '() (cons line (loop (read-line)))))))) + (let ((line (read-line port))) + (if (eof-object? line) + '() (cons line (read-lines port))))) ;; Same functionality as the regular @var{with-output-to-file}, but ;; with the difference that either everything is written, or nothing ;; is written, and if anything is written it's all written atomicaly at ;; once (the original file will never contain an intermidiate state). ;; Does NOT handle race conditions between threads. -;; Return #f on failure, something truthy otherwise +;; +;; propagates the return value of @var{thunk} upon successfully writing +;; the file, and @code{#f} otherwise. (define-public (with-atomic-output-to-file filename thunk) ;; copy to enusre writable string (define tmpfile (string-copy (string-append @@ -36,13 +37,14 @@ (dynamic-wind (lambda () (set! port (mkstemp! tmpfile))) (lambda () - (with-output-to-port port thunk) - ;; Closing a port forces a write, due to buffering - ;; some of the errors that logically would come - ;; from write calls are first raised here. But since - ;; crashing is acceptable here, that's fine. - (close-port port) - (rename-file tmpfile filename)) + (begin1 + (with-output-to-port port thunk) + ;; Closing a port forces a write, due to buffering + ;; some of the errors that logically would come + ;; from write calls are first raised here. But since + ;; crashing is acceptable here, that's fine. + (close-port port) + (rename-file tmpfile filename))) (lambda () (when (access? tmpfile F_OK) ;; I'm a bit unclear on how to trash our write buffer. diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index 7e40259a..28a026bc 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -2,31 +2,38 @@ :use-module (srfi srfi-1) :use-module (hnh util)) +(define // file-name-separator-string) +(define /? file-name-separator?) + (define-public (path-append . strings) (fold (lambda (s done) - (string-append - done - (if (string-null? s) - (string-append s file-name-separator-string) - (if (file-name-separator? (string-last done)) - (if (file-name-separator? (string-first s)) - (string-drop s 1) s) - (if (file-name-separator? (string-first s)) - s (string-append file-name-separator-string s)))))) + (string-append + done + (cond ((string-null? s) //) + ((and (/? (string-first s)) + (/? (string-last done))) + (string-drop s 1)) + ((or (/? (string-first s)) + (/? (string-last done))) + s) + (else (string-append // s))))) ;; If first component is empty, add a leading slash to make ;; the path absolute. This isn't exactly correct if we have ;; drive letters, but on those system the user should make ;; sure that the first component of the path is non-empty. (let ((s (car strings))) (if (string-null? s) - file-name-separator-string s)) - (cdr strings))) + // s)) + (cdr strings) + )) (define-public (path-join lst) (apply path-append lst)) ;; @example ;; (path-split "usr/lib/test") ;; ⇒ ("usr" "lib" "test") +;; (path-split "usr/lib/test/") +;; ⇒ ("usr" "lib" "test") ;; (path-split "/usr/lib/test") ;; ⇒ ("" "usr" "lib" "test") ;; (path-split "//usr////lib/test") @@ -38,7 +45,7 @@ (reverse (map reverse-list->string (fold (lambda (c done) - (if (file-name-separator? c) + (if (/? c) (cons '() done) (cons (cons c (car done)) (cdr done)))) '(()) diff --git a/module/hnh/util/uuid.scm b/module/hnh/util/uuid.scm new file mode 100644 index 00000000..68455243 --- /dev/null +++ b/module/hnh/util/uuid.scm @@ -0,0 +1,19 @@ +(define-module (hnh util uuid) + :use-module (ice-9 format) + :export (uuid uuid-v4)) + +(define %seed (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) + (logior (ash version (* 4 3)) + (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))) + +(define uuid uuid-v4) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 7c062003..9a172e2d 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -3,7 +3,7 @@ #:use-module (srfi srfi-41) #:use-module ((ice-9 sandbox) :select (call-with-time-limit)) #:use-module (hnh util) ; let*, find-min - #:export (stream-car+cdr interleave-streams with-streams + #:export (stream-car+cdr interleave-streams stream-timeslice-limit)) (define (stream-car+cdr stream) @@ -132,39 +132,3 @@ (stream-timeslice-limit (stream-cdr strm) timeslice))) (lambda _ stream-null))) -;; Evaluates @var{body} in a context where most list fundamentals are -;; replaced by stream alternatives. -;; commented defifinitions are items which could be included, but for -;; one reason or another isn't. -;; TODO Possibly give access to list-primitives under a list- prefix. -;; TODO since this macro is inhygienic it requires that (srfi srfi-41) -;; is included at the point of use. -(define-macro (with-streams . body) - `(let-syntax - ((cons (identifier-syntax stream-cons)) - (null? (identifier-syntax stream-null?)) - (pair? (identifier-syntax stream-pair?)) - (car (identifier-syntax stream-car)) - (cdr (identifier-syntax stream-cdr)) - ;; stream-lambda - ;; define-stream - (append (identifier-syntax stream-append)) - (concat (identifier-syntax stream-concat)) - ;; (const stream-constant) - (drop (identifier-syntax stream-drop)) - (drop-while (identifier-syntax stream-drop-while)) - (filter (identifier-syntax stream-filter)) - (fold (identifier-syntax stream-fold)) - (for-each (identifier-syntax stream-for-each)) - (length (identifier-syntax stream-length)) - ;; stream-let - (map (identifier-syntax stream-map)) - ;; stream-match - ;; stream-range - ;; stream-ref - (reverse (identifier-syntax stream-reverse)) - ;; stream-scan - (take (identifier-syntax stream-take)) - (take-while (identifier-syntax stream-take-while)) - (zip (identifier-syntax stream-zip))) - ,@body)) diff --git a/module/srfi/srfi-64/test-error.scm b/module/srfi/srfi-64/test-error.scm new file mode 100644 index 00000000..33922c32 --- /dev/null +++ b/module/srfi/srfi-64/test-error.scm @@ -0,0 +1,85 @@ +;; Copyright © 2022 Hugo Hörnquist +;; Copyright for this file, however, majority of contents borrowed under the +;; below mentioned license agreement from srfi/srfi-64/testing.scm of Guile 2.2.7. + +;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner +;; Added "full" support for Chicken, Gauche, Guile and SISC. +;; Alex Shinn, Copyright (c) 2005. +;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. +;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014. +;; +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;;; Commentary: +;; The code is directly copied from Guile's source tree +;; (module/srfi/srfi-64/testing.scm), but @var{etype} +;; is passed to @code{catch}, causing it to actually +;; check the expected error. +;;; Code: + +(define-module (srfi srfi-64 test-error) + :use-module (srfi srfi-64) + :use-module (hnh util) + :replace (test-error)) + +(define %test-source-line2 (@@ (srfi srfi-64) %test-source-line2)) +(define %test-on-test-begin (@@ (srfi srfi-64) %test-on-test-begin)) +(define %test-on-test-end (@@ (srfi srfi-64) %test-on-test-end)) +(define %test-report-result (@@ (srfi srfi-64) %test-report-result)) + +(define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (cond ((%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (catch etype + (lambda () + (test-result-set! r 'actual-value expr) + #f) + (lambda (key . args) + ;; TODO: decide how to specify expected + ;; error types for Guile. + (test-result-set! r 'actual-error + (cons key args)) + #t))) + (%test-report-result))))))) + +(define-syntax test-error + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname etype expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-error r etype expr)))) + (((mac etype expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r etype expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r #t expr))))))) + diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 579382ae..18f31aaf 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -164,6 +164,7 @@ (define-public (copy-vcomponent component) (make-vcomponent% (type component) + ;; TODO deep copy? (children component) (parent component) ;; properties diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index 72ee8eb4..fe909ebb 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -1,7 +1,5 @@ (define-module (vcomponent datetime output) :use-module (hnh util) - :use-module (calp util config) - :use-module (hnh util exceptions) :use-module (datetime) :use-module (vcomponent base) :use-module (text util) @@ -9,12 +7,6 @@ :use-module ((vcomponent recurrence display) :select (format-recurrence-rule)) ) -(define-config summary-filter (lambda (_ a) a) - pre: (ensure procedure?)) - -(define-config description-filter (lambda (_ a) a) - pre: (ensure procedure?)) - ;; ev → sxml ;; TODO translation (define-public (format-recurrence-rule ev) diff --git a/module/vcomponent/duration.scm b/module/vcomponent/duration.scm index 786675b8..637d7db4 100644 --- a/module/vcomponent/duration.scm +++ b/module/vcomponent/duration.scm @@ -20,7 +20,9 @@ key: (sign '+) week day time) (when (and week (or day time)) - (error "Can't give week together with day or time")) + (scm-error 'misc-error "duration" + "Can't give week together with day or time" + #f #f)) (make-duration sign week day time)) @@ -64,7 +66,10 @@ (define (parse-duration str) (let ((m (match-pattern dur-pattern str))) (unless m - (throw 'parse-error "~a doesn't appar to be a duration" str)) + (scm-error 'parse-error "parse-duration" + "~s doesn't appar to be a duration" + (list str) + #f)) (unless (= (peg:end m) (string-length str)) (warning "Garbage at end of duration")) @@ -83,9 +88,12 @@ [(H) `(hour: ,n)] [(M) `(minute: ,n)] [(S) `(second: ,n)] - [else (error "Invalid key")]))] + [else (scm-error 'misc-error "parse-duration" + "Invalid key ~a" type #f)]))] [a - (error "~a not on form ((number <num>) type)" a)]) + (scm-error 'misc-error "parse-duration" + "~s not on expected form ((number <num>) type)" + (list a) #f)]) (context-flatten (lambda (x) (and (pair? (car x)) (eq? 'number (caar x)))) (cdr (member "P" tree))) diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm index 9768cf70..9e18f1eb 100644 --- a/module/vcomponent/formats/common/types.scm +++ b/module/vcomponent/formats/common/types.scm @@ -137,4 +137,5 @@ (define-public (get-parser type) (or (hashq-ref type-parsers type #f) - (error (_ "No parser for type") type))) + (scm-error 'misc-error "get-parser" (_ "No parser for type ~a") + (list type) #f))) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 8b6cffeb..7f6c89cc 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -1,5 +1,6 @@ (define-module (vcomponent formats ical parse) :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (ice-9 format) :use-module (hnh util exceptions) :use-module (hnh util) :use-module (datetime) @@ -121,7 +122,9 @@ (lambda (params value) (let ((vv (parser params value))) (when (list? vv) - (throw 'parse-error (_ "List in enum field"))) + (scm-error 'parse-error "enum-parser" + (_ "List in enum field") + #f #f)) (let ((v (string->symbol vv))) (unless (memv v enum) (warning "~a ∉ { ~{~a~^, ~} }" @@ -193,7 +196,9 @@ DRAFT FINAL CANCELED))] [(memv key '(REQUEST-STATUS)) - (throw 'parse-error (_ "TODO Implement REQUEST-STATUS"))] + (scm-error 'parse-error "build-vline" + (_ "TODO Implement REQUEST-STATUS") + #f #f)] [(memv key '(ACTION)) (enum-parser '(AUDIO DISPLAY EMAIL @@ -325,7 +330,7 @@ (set! (prop* (car stack) key) vline)))))) (loop (cdr lst) stack)]))) - (lambda (err fmt . args) + (lambda (err proc fmt fmt-args data) (let ((linedata (get-metadata head*))) (display (format #f @@ -339,7 +344,7 @@ line ~a ~a Defaulting to string~%") (get-string linedata) - fmt args + fmt fmt-args (get-line linedata) (get-file linedata)) (current-error-port)) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 4fc96e71..b21a5f2b 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -39,12 +39,16 @@ (reduce (lambda (item calendar) - (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) - (children item))) + (define-values (events other) + (partition (lambda (e) (eq? 'VEVENT (type e))) + (children item))) - ;; (assert (eq? 'VCALENDAR (type calendar))) - (assert (eq? 'VCALENDAR (type item))) + (unless (eq? 'VCALENDAR (type item)) + (scm-error 'misc-error "parse-vdir" + "Unexepected top level component. Expected VCALENDAR, got ~a. In file ~s" + (list (type item) (prop item '-X-HNH-FILENAME)) + #f)) (for child in (children item) (set! (prop child '-X-HNH-FILENAME) @@ -61,10 +65,7 @@ (case (length events) [(0) (warning (_ "No events in component~%~a") (prop item '-X-HNH-FILENAME))] - [(1) - (let ((child (car events))) - (assert (memv (type child) '(VTIMEZONE VEVENT))) - (add-child! calendar child))] + [(1) (add-child! calendar (car events))] ;; two or more [else diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index 6068e34c..01d34f9f 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -11,8 +11,8 @@ (define-module (vcomponent formats vdir save-delete) :use-module (hnh util) + :use-module (hnh util uuid) :use-module ((hnh util path) :select (path-append)) - :use-module ((hnh util exceptions) :select (assert)) :use-module (vcomponent formats ical output) :use-module (vcomponent) :use-module ((hnh util io) :select (with-atomic-output-to-file)) @@ -22,14 +22,25 @@ (define-public (save-event event) (define calendar (parent event)) - (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) - - (let* ((uid (or (prop event 'UID) (uuidgen)))) - (set! (prop event 'UID) uid - ;; TODO use existing filename if present? - (prop event '-X-HNH-FILENAME) (path-append - (prop calendar '-X-HNH-DIRECTORY) - (string-append uid ".ics"))) + (unless calendar + (scm-error 'wrong-type-arg "save-event" + (_ "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" + (_ "Can only save events belonging to vdir calendars. Calendar is of type ~s") + (list (prop calendar '-X-HNH-SOURCETYPE)) + #f)) + + (let* ((uid (or (prop event 'UID) (uuid)))) + (set! (prop event 'UID) uid) + (unless (prop event 'X-HNH-FILENAME) + (set! (prop event '-X-HNH-FILENAME) + (path-append + (prop calendar '-X-HNH-DIRECTORY) + (string-append uid ".ics")))) (with-atomic-output-to-file (prop event '-X-HNH-FILENAME) (lambda () (print-components-with-fake-parent (list event)))) uid)) @@ -37,5 +48,9 @@ (define-public (remove-event event) (define calendar (parent event)) - (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) + (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) + (scm-error 'wrong-type-arg "remove-event" + (_ "Can only remove events belonging to vdir calendars. Calendar is of type ~s") + (list (prop calendar '-X-HNH-SOURCETYPE)) + #f)) (delete-file (prop event '-X-HNH-FILENAME))) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 66bb8460..d9020858 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -82,10 +82,10 @@ bymonthday byyearday byweekno bymonth bysetpos) (string->number value)) - (else (throw - 'key-error + (else (scm-error 'key-error "handle-value" (_ "Invalid type ~a, with value ~a") - type value)))))) + (list type value) + #f)))))) ;; freq until count interval wkst @@ -109,9 +109,11 @@ byyearday byweekno bymonth bysetpos) (list (symbol->keyword key) (map (lambda (v) (parse-value-of-that-type key v)) - (map car values))) - ) - (else (throw 'error)))))))))] + (map car values)))) + (else (scm-error 'misc-error "handle-value" + "Invalid key ~s" + (list key) + #f)))))))))] [(time) (parse-iso-time (car value))] diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index b498e033..33f86e3d 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -217,7 +217,9 @@ [(BYHOUR) (to-dt (set (hour t) value))] [(BYMINUTE) (to-dt (set (minute t) value))] [(BYSECOND) (to-dt (set (second t) value))] - [else (error "Unrecognized by-extender" key)]))) + [else (scm-error 'wrong-type-arg "update" + "Unrecognized by-extender ~s" + key #f)]))) date-object extension-rule)) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index b4f09d92..ae521d77 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -5,6 +5,7 @@ #:use-module ((vcomponent base) :select (prop)) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 format) #:use-module (hnh util) ) @@ -46,11 +47,14 @@ wkst) (export! count) +;; Interval and wkst have default values, since those are assumed +;; anyways, and having them set frees us from having to check them at +;; the use site. (define*-public (make-recur-rule key: - freq until count interval bysecond byminute byhour + freq until count (interval 1) bysecond byminute byhour byday bymonthday byyearday byweekno bymonth bysetpos - wkst) + (wkst monday)) ;; TODO possibly validate fields here ;; to prevent creation of invalid rules. ;; This was made apparent when wkst was (incorrectly) set to MO, diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index 3477f6d4..d45cedf9 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -51,7 +51,9 @@ (define-macro (quick-case key . cases) (let ((else-clause (or (assoc-ref cases 'else) - '(error "Guard failed")))) + '(scm-error 'misc-error "quick-case" + "Guard failed" + #f #f)))) `(case ,key ,@(map (match-lambda ((key guard '=> body ...) @@ -72,6 +74,12 @@ `(else ,@body))) cases)))) +(define* (string->number/throw string optional: (radix 10)) + (or (string->number string radix) + (scm-error 'wrong-type-arg + "string->number/throw" + "Can't parse ~s as number in base ~a" + (list string radix) (list string radix)))) ;; RFC 5545, Section 3.3.10. Recurrence Rule, states that the UNTIL value MUST have ;; the same type as the DTSTART of the event (date or datetime). I have seen events @@ -92,8 +100,8 @@ (parse-ics-datetime val))) (day (rfc->datetime-weekday (string->symbol val))) (days (map parse-day-spec (string-split val #\,))) - (num (string->number val)) - (nums (map string->number (string-split val #\,)))) + (num (string->number/throw val)) + (nums (map string->number/throw (string-split val #\,)))) ;; It's an error to give BYHOUR and smaller for pure dates. ;; 3.3.10. p 41 @@ -123,7 +131,7 @@ (else o))))) ;; obj - (make-recur-rule interval: 1 wkst: mon) + (make-recur-rule) ;; ((key val) ...) (map (cut string-split <> #\=) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index e2e8a777..57d12f6b 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -1,5 +1,6 @@ (define-module (vcomponent util instance methods) :use-module (hnh util) + :use-module (hnh util uuid) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) @@ -19,8 +20,14 @@ get-event-by-uid fixed-events-in-range + get-calendar-by-name + get-event-set get-calendars get-fixed-events get-repeating-events + + add-and-save-event + + add-calendars )) (define-public (load-calendars calendar-files) @@ -28,12 +35,21 @@ (define-class <events> () - (calendar-files init-keyword: calendar-files:) - (calendars getter: get-calendars) + ;; Files which calendars where loaded from + (calendar-files init-keyword: calendar-files: + init-value: '()) + ;; calendar objects + (calendars getter: get-calendars + init-value: '()) + ;; events, which should all be children of the calendars (events getter: get-events) + ;; subset of events (repeating-events getter: get-repeating-events) + ;; subset of events (fixed-events getter: get-fixed-events) + ;; events again, but as stream with repeating events realised (event-set getter: get-event-set) + ;; hash-table from event UID:s, to the events uid-map ) @@ -42,6 +58,10 @@ (hash-ref (slot-ref this 'uid-map) uid)) +(define-method (get-calendar-by-name (this <events>) string) + (find (lambda (c) (string=? string (prop c 'NAME))) + (get-calendars this))) + (define-method (fixed-events-in-range (this <events>) start end) (filter-sorted (lambda (ev) ((in-date-range? start end) @@ -56,8 +76,12 @@ (for calendar in (slot-ref this 'calendar-files) (format (current-error-port) " - ~a~%" calendar)) - (slot-set! this 'calendars (load-calendars (slot-ref this 'calendar-files))) + (let ((calendars (load-calendars (slot-ref this 'calendar-files)))) + (apply add-calendars this calendars))) + +(define-method (add-calendars (this <events>) . calendars) + (slot-set! this 'calendars (append calendars (slot-ref this 'calendars))) (let* ((groups (group-by @@ -95,7 +119,7 @@ (add-child! calendar event) (unless (prop event 'UID) - (set! (prop event 'UID) (uuidgen))) + (set! (prop event 'UID) (uuid))) @@ -139,3 +163,57 @@ (hash-set! (slot-ref this 'uid-map) (prop event 'UID) #f)) + + +(define-method (add-and-save-event (this <events>) calendar event) + (cond + [(get-event-by-uid this (prop event 'UID)) + => (lambda (old-event) + + ;; remove old instance of event from runtime + (remove-event this old-event) + + ;; Add new event to runtime, + ;; MUST be done after since the two events SHOULD share UID. + ;; NOTE that this can emit warnings + (add-event this calendar event) + + (set! (prop event 'LAST-MODIFIED) + (current-datetime)) + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + + ;; 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."))) + + + (unless (eq? calendar (parent old-event)) + ;; change to a new calendar + (format (current-error-port) + (_ "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 + ;; which either a better atomic model, or a propper error + ;; recovery log would solve. + ((@ (vcomponent formats vdir save-delete) remove-event) old-event)) + + + (format (current-error-port) + (_ "Event updated ~a~%") (prop event 'UID)))] + + [else + (add-event this calendar event) + + (set! (prop event 'LAST-MODIFIED) (current-datetime)) + + ;; 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."))) + + (format (current-error-port) + (_ "Event inserted ~a~%") (prop event 'UID))])) diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index 7a5fea29..4baa647e 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -26,7 +26,10 @@ (prop comp '-X-HNH-DIRECTORY) path) comp)] [(block-special char-special fifo socket unknown symlink) - => (lambda (t) (error (_ "Can't parse file of type ") t))])) + => (lambda (t) (scm-error 'misc-error "parse-cal-path" + (_ "Can't parse file of type ~s") + (list t) + #f))])) (unless (prop cal "NAME") (set! (prop cal "NAME") diff --git a/module/vulgar.scm b/module/vulgar.scm index 5ddea738..20b93164 100644 --- a/module/vulgar.scm +++ b/module/vulgar.scm @@ -19,35 +19,39 @@ (1+ y) (1+ x))) -(define-syntax with-vulgar - (syntax-rules () - ((_ thunk) - (with-vulgar (bitwise-not (bitwise-ior ECHO ICANON)) - thunk)) - ((_ bits thunk) - (let* ((ifd (current-input-port)) - (ofd (current-output-port)) - (iattr (make-termios)) - (oattr (make-termios)) - iattr* oattr*) - (dynamic-wind - (lambda () - (tcgetattr! iattr ifd) - (tcgetattr! oattr ofd) - - ;; Store current settings to enable resetting the terminal later - (set! iattr* (copy-termios iattr) - oattr* (copy-termios oattr) - - (lflag iattr) (bitwise-and bits (lflag iattr)) - (lflag oattr) (bitwise-and bits (lflag oattr))) - - (tcsetattr! iattr ifd) - (tcsetattr! oattr ofd) - (system "tput civis")) - thunk - (lambda () - (tcsetattr! iattr* ifd) - (tcsetattr! oattr* ofd) - (system "tput cnorm") - )))))) +(define (with-vulgar . args) + (apply + (case-lambda + ((thunk) + (with-vulgar (bitwise-not (bitwise-ior ECHO ICANON)) + thunk)) + ((bits thunk) + (let* ((ifd (current-input-port)) + (ofd (current-output-port)) + (iattr (make-termios)) + (oattr (make-termios)) + iattr* oattr*) + (dynamic-wind + (lambda () + (tcgetattr! iattr ifd) + (tcgetattr! oattr ofd) + + ;; Store current settings to enable resetting the terminal later + (set! iattr* (copy-termios iattr) + oattr* (copy-termios oattr) + + (lflag iattr) (bitwise-and bits (lflag iattr)) + (lflag oattr) (bitwise-and bits (lflag oattr))) + + (tcsetattr! iattr ifd) + (tcsetattr! oattr ofd) + (format #t "\x1b[?1049h") + (system "tput civis")) + thunk + (lambda () + (tcsetattr! iattr* ifd) + (tcsetattr! oattr* ofd) + (format #t "\x1b[?1049l") + (system "tput cnorm") + ))))) + args)) diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index 7254fcb5..11f7dfb4 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -2,9 +2,9 @@ :export (make-routes) :use-module (hnh util) :use-module (ice-9 regex) + :use-module (ice-9 curried-definitions) :use-module (srfi srfi-1) - :use-module (web response) - :use-module (web uri)) + ) @@ -34,13 +34,13 @@ (cons (string->symbol (match:substring m 1)) tokens))))))) -(define (generate-case defn) + +(define ((generate-case regex-table) defn) (let* (((method uri param-list . body) defn) - (regex tokens (parse-endpoint-string uri)) + (_ tokens (parse-endpoint-string uri)) (diff intersect (lset-diff+intersection eq? param-list tokens))) `((and (eq? r:method (quote ,method)) - (regexp-exec (make-regexp ,(string-append "^" regex "/?$") regexp/icase) - r:path)) + (regexp-exec ,(car (assoc-ref regex-table uri)) r:path)) => (lambda (match-object) ;; (assert ;; (= (1- (match:count match-object)) @@ -54,60 +54,65 @@ ,@body)) ,@(unless (null? intersect) (map (lambda (i) - `(match:substring match-object ,i)) + `((@ (ice-9 regex) match:substring) match-object ,i)) (cdr (iota (1+ (length intersect))))))))))) (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))) - `(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)) - (r:port ((@ (web request) request-port) request))) - (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) - (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) - ;; TODO can sometimes be a pair of host and port - ;; '("localhost" . 8080). It shouldn't... - (r:host (or ((@ (web uri) uri-host) r:uri) - ((@ (web request) request-host) - request))) - (r:port (or ((@ (web uri) uri-port) r:uri) - ((@ (web request) request-port) - request))) - (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~%" - (datetime->string (current-datetime)) - r:method r:host 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) - (else (lambda* _ (return (build-response #:code 404) - "404 Not Fonud")))) - (append - ((@ (web query) 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) - (let ((content-type (assoc-ref r:headers 'content-type))) - (when content-type - (let ((type (car content-type)) - (args (cdr content-type))) - (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)))))))) + (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))))))))) |