diff options
Diffstat (limited to 'module/web/http')
-rw-r--r-- | module/web/http/dav.scm | 144 | ||||
-rw-r--r-- | module/web/http/make-routes.scm | 17 | ||||
-rw-r--r-- | module/web/http/status-codes.scm | 87 |
3 files changed, 241 insertions, 7 deletions
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 feba3f19..a36efaef 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -145,6 +145,8 @@ ;; 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)) @@ -164,13 +166,14 @@ ;; When content-type is application/x-www-form-urlencoded, ;; decode them, and add it to the argument list - (let ((content-type (assoc-ref r:headers 'content-type))) - (when content-type - (let ((type args (car+cdr content-type))) - (when (eq? type 'application/x-www-form-urlencoded) - (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - (parse-query (bytevector->string body encoding) - encoding))))))))))) + (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))))))))))))) (case-lambda ((headers body new-state) (values headers body new-state)) ((headers body) (values headers body 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)))) |