aboutsummaryrefslogtreecommitdiff
path: root/module/web/http
diff options
context:
space:
mode:
Diffstat (limited to 'module/web/http')
-rw-r--r--module/web/http/dav.scm144
-rw-r--r--module/web/http/make-routes.scm17
-rw-r--r--module/web/http/status-codes.scm87
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))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 09:37:18 +0200