(define-module (entry-points server) :use-module (util) :use-module (util app) :use-module (util config) :use-module (util options) :use-module (srfi srfi-1) :use-module (ice-9 match) :use-module (ice-9 control) :use-module (ice-9 rdelim) :use-module (ice-9 curried-definitions) :use-module (ice-9 ftw) :use-module (ice-9 getopt-long) :use-module (ice-9 iconv) :use-module (ice-9 regex) #| regex here due to bad macros |# :use-module (web server) :use-module (web request) :use-module (web response) :use-module (web uri) :use-module (web http) :use-module (sxml simple) :use-module (server util) :use-module (server macro) :use-module (vcomponent) :use-module (datetime) :use-module (datetime util) :use-module (output html) :use-module (output ical) :export (main) ) (define (file-extension name) (car (last-pair (string-split name #\.)))) (define (sxml->html-string sxml) (with-output-to-string (lambda () (display "\n") (sxml->xml sxml)))) (define (// . args) (string-join args file-name-separator-string )) (define (directory-table dir) `(table (thead (tr (th "") (th "Name") (th "Perm"))) (tbody ,@(map (lambda (k) (let* ((stat (lstat (// dir k)))) `(tr (td ,(case (stat:type stat) [(directory) "đ"] [(regular) "đ°"] [else "đ"])) (td (a (@ (href "/" ,dir "/" ,k)) ,k)) (td ,(number->string (stat:perms stat) 8))))) (cdr (scandir dir)))))) (define-method (make-make-routes) (make-routes ;; Manual redirect to not reserve root. (GET "/" () (return '((content-type text/html)) (sxml->html-string '(a (@ (href "/today")) "GĂĽ till idag")))) (GET "/week/:start-date.html" (start-date) (let* ((start-date (start-of-week (parse-iso-date start-date) (get-config 'week-start)))) (return '((content-type text/html)) (with-output-to-string (lambda () (html-generate calendars: (getf 'calendars) events: (getf 'event-set) start-date: start-date end-date: (date+ start-date (date day: 6)) next-start: (lambda (d) (date+ d (date day: 7))) prev-start: (lambda (d) (date- d (date day: 7))) render-calendar: render-calendar intervaltype: 'week )))))) (GET "/month/:start-date.html" (start-date) (let* ((start-date (start-of-month (parse-iso-date start-date)))) (return '((content-type text/html)) (with-output-to-string (lambda () (html-generate calendars: (getf 'calendars) events: (getf 'event-set) start-date: start-date end-date: (date- (month+ start-date) (date day: 1)) next-start: month+ prev-start: month- render-calendar: render-calendar-table pre-start: (start-of-week start-date (get-config 'week-start)) post-end: (end-of-week (end-of-month start-date) (get-config 'week-start)) intervaltype: 'month )))))) (POST "/insert" (cal data) (unless (and cal data) (return (build-response code: 400) "Both 'cal' and 'data' required\r\n")) ;; NOTE that this leaks which calendar exists, ;; but you can only query for existance. ;; also, the default output gives everything. (let ((calendar (find (lambda (c) (string=? cal (attr c 'NAME))) (getf 'calendars)))) (unless calendar (return (build-response code: 400) (format #f "No calendar with name [~a]\r\n" cal))) (let ((event ((@ (vcomponent parse xcal) sxcal->vcomponent) ;; TODO different forms? (cadr ; removes *TOP* (catch 'parser-error (lambda () (xml->sxml data)) (lambda (err port . args) (return (build-response code: 400) (format #f "XML parse error ~{~a~}\r\n" args)))))))) (unless (eq? 'VEVENT (type event)) (return (build-response code: 400) "Object not a VEVENT\r\n")) (calendar-import calendar event) (return '((content-type text/plain)) "Event inserted\r\n")))) ;; Get specific page by query string instead of by path. ;; Useful for