diff options
Diffstat (limited to 'tests/test')
27 files changed, 2515 insertions, 401 deletions
diff --git a/tests/test/add-and-save.scm b/tests/test/add-and-save.scm deleted file mode 100644 index 1ab6f660..00000000 --- a/tests/test/add-and-save.scm +++ /dev/null @@ -1,120 +0,0 @@ -(define-module (test add-and-save) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module (hnh util) - :use-module (datetime) - ;; :use-module ((vcomponent) :select (prop)) - :use-module ((vcomponent base) :select (prop type children make-vcomponent)) - :use-module ((srfi srfi-1) :select (find)) - :use-module ((vcomponent formats vdir save-delete) :select (save-event)) - :use-module ((vcomponent formats xcal parse) :select (sxcal->vcomponent)) - :use-module ((vcomponent util instance methods) - :select (add-calendars - add-and-save-event - remove-event - ))) - -;; TODO is this how I want to format direct components? - -(define timezone - '(vtimezone - (properties (tzid (text "Europe/Stockholm"))) - (components - (standard - (properties - (tzoffsetto (utc-offset "+0100")) - (dtstart (date-time "1996-10-27T01:00:00")) - (tzname (text "CET")) - (tzoffsetfrom (utc-offset "+0200")) - (rrule (recur (freq "YEARLY") - (interval "1") - ((byday "-1SU")) - ((bymonth 10)))))) - (daylight - (properties - (tzoffsetto (utc-offset "+0200")) - (dtstart (date-time "1981-03-29T01:00:00")) - (tzname (text "CEST")) - (tzoffsetfrom (utc-offset "+0000")) - (rrule (recur (freq "YEARLY") - (interval "1") - ((byday "-1SU")) - ((bymonth 3)))))))) ) - -(define ev - (sxcal->vcomponent - '(vevent - (properties - (uid (text "3da506ad-8d27-4810-94b3-6ab341baa1f2")) - (summary (text "Test Event #1")) - (dtstart - (parameters (tzid (text "Europe/Stockholm"))) - (date-time "2021-12-21T10:30:00")) - (dtstamp (date-time "2021-12-21T14:10:56Z")) - (dtend (parameters (tzid (text "Europe/Stockholm"))) - (date-time "2021-12-21T11:45:00")))))) - -(define rep-ev - (sxcal->vcomponent - '(vevent - (properties - (uid (text "4ebd6632-d192-4bf4-a33a-7a8388185914")) - (summary (text "Repeating Test Event #1")) - (rrule (recur (freq "DAILY"))) - (dtstart - (parameters (tzid (text "Europe/Stockholm"))) - (date-time "2021-12-21T10:30:00")) - (dtstamp (date-time "2021-12-21T14:10:56Z")) - (dtend (parameters (tzid (text "Europe/Stockholm"))) - (date-time "2021-12-21T11:45:00")))))) - -(define directory (tmpnam)) - -(define event-object ((@ (oop goops) make) - (@@ (vcomponent util instance methods) <events>))) - -(mkdir directory) -(format #t "Using ~a~%" directory) - -(define calendar (make-vcomponent 'VCALENDAR)) - -(set! (prop calendar '-X-HNH-SOURCETYPE) 'vdir - (prop calendar '-X-HNH-DIRECTORY) directory) - -(add-calendars event-object calendar) - -;; Try adding and saving a new regular event -(add-and-save-event event-object calendar ev) - -;; Try changing and saving an existing regular event -(set! (prop ev 'SUMMARY) "Changed summary") -(add-and-save-event event-object calendar ev) - -;; Try adding and saving a new repeating event -(add-and-save-event event-object calendar rep-ev) - -;; Try changing and saving an existing repeating event -;; TODO setting start time to later than end time leads to nonsense -;; errors when trying to generate the recurrence set. -(set! (prop rep-ev 'DTSTART) (datetime+ (prop rep-ev 'DTSTART) - (datetime time: (time hour: 1)))) -(add-and-save-event event-object calendar rep-ev) - -;; Try adding and saving a new event with multiple instances -;; Try changing and saving an existing event with multiple instances - -;; (add-and-save-event event-object calendar event) - - -(test-equal "Correct amount of children in calendar" - 2 (length (children calendar))) - - -(define get-events (@@ (vcomponent util instance methods) get-events)) -(test-equal "Event object contains correct number of events (single calendar)" - 2 (length (get-events event-object))) - -(remove-event event-object (car (get-events event-object))) - -(test-equal "Correct number of events after removing first element" - 1 (length (get-events event-object))) diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm index 4e5aa07d..a6f5e946 100644 --- a/tests/test/annoying-events.scm +++ b/tests/test/annoying-events.scm @@ -9,35 +9,29 @@ stream-filter stream-take-while)) :use-module ((vcomponent base) - :select (extract prop make-vcomponent)) + :select (extract prop)) :use-module ((vcomponent datetime) :select (event-overlaps?)) :use-module ((datetime) :select (date date+ date<)) - :use-module ((hnh util) :select (set!))) + :use-module ((hnh util) :select (set!)) + :use-module (vcomponent create) + :use-module (vcomponent base)) -;; TODO remove this -(define* (event key: summary dtstart dtend) - (define ev (make-vcomponent 'VEVENT)) - (set! (prop ev 'SUMMARY) summary - (prop ev 'DTSTART) dtstart - (prop ev 'DTEND) dtend) - ev) -(define start - #2021-11-01) +(define start #2021-11-01) (define end (date+ start (date day: 8))) (define ev-set (stream - (event ; should be part of the result + (vevent ; should be part of the result summary: "A" dtstart: #2021-10-01 dtend: #2021-12-01) - (event ; should NOT be part of the result + (vevent ; should NOT be part of the result summary: "B" dtstart: #2021-10-10 dtend: #2021-10-11) - (event ; should also be part of the result + (vevent ; should also be part of the result summary: "C" dtstart: #2021-11-02 dtend: #2021-11-03))) diff --git a/tests/test/create.scm b/tests/test/create.scm new file mode 100644 index 00000000..7cc00419 --- /dev/null +++ b/tests/test/create.scm @@ -0,0 +1,66 @@ +(define-module (test create) + :use-module ((srfi srfi-1) :select (every)) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((vcomponent create) + :select (vcomponent + with-parameters + as-list)) + :use-module ((vcomponent) + :select (children properties type prop prop* param vline?))) + +;; vevent, vcalendar, vtimezone, standard, and daylight all trivial +;; and therefore not tested + +(test-group "Empty component" + (let ((ev (vcomponent 'TEST))) + (test-equal 'TEST (type ev)) + (test-equal '() (children ev)) + (test-equal '() (properties ev)))) + +(test-group "Component with properties, but no children" + (let ((ev (vcomponent 'TEST + prop: "value"))) + (test-equal '(PROP) (map car (properties ev))) + (test-equal "value" (prop ev 'PROP)))) + +(test-group "Component with children, but no properties" + (let* ((child (vcomponent 'CHILD)) + (ev (vcomponent 'TEST + (list child)))) + (test-equal '() (properties ev)) + (test-equal 1 (length (children ev))) + ; (test-eq child (car (children ev))) + )) + +(test-group "Component with both children and properties" + (let* ((child (vcomponent 'CHILD)) + (ev (vcomponent 'TEST + prop: "VALUE" + (list child)))) + (test-equal '(PROP) (map car (properties ev))) + (test-equal "VALUE" (prop ev 'PROP)) + (test-equal 1 (length (children ev))) + ; (test-eq child (car (children ev))) + )) + +(test-group "Component with no children, where last elements value is a list" + (let ((ev (vcomponent 'TEST prop: (list 1 2 3)))) + (test-equal '() (children ev)) + (test-equal '(PROP) (map car (properties ev))) + (test-equal '(1 2 3) (prop ev 'PROP)))) + +(test-group "With parameters" + (let ((ev (vcomponent 'TEST + prop: (with-parameters param: 1 2)))) + (test-equal 2 (prop ev 'PROP)) + (test-equal '(1) (param (prop* ev 'PROP) 'PARAM)))) + +(test-group "As list" + (let ((ev (vcomponent 'TEST + prop: (as-list (list 1 2 3))))) + (test-equal '(1 2 3) (prop ev 'PROP)) + (test-equal 3 (length (prop* ev 'PROP))) + (test-assert (every vline? (prop* ev 'PROP))))) + +;; (test-group "Parameters and lists" ) diff --git a/tests/test/data-stores/file.scm b/tests/test/data-stores/file.scm new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/tests/test/data-stores/file.scm diff --git a/tests/test/data-stores/sqlite.scm b/tests/test/data-stores/sqlite.scm new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/tests/test/data-stores/sqlite.scm diff --git a/tests/test/data-stores/vdir.scm b/tests/test/data-stores/vdir.scm new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/tests/test/data-stores/vdir.scm diff --git a/tests/test/datetime.scm b/tests/test/datetime.scm index 2a5ac141..f73a0ad2 100644 --- a/tests/test/datetime.scm +++ b/tests/test/datetime.scm @@ -70,45 +70,44 @@ (test-error "Invalid second" 'wrong-type-arg (time second: #f)))) (test-group "Datetime" - (let ((get-time% (@@ (datetime) get-time%))) + (let () (test-group "Empty datetime" (let ((dt (datetime))) - ;; TODO figure out propper export of get-time% - (test-assert "Datetime date is date" (date? (get-date dt))) - (test-assert "Datetime date is zero" (date-zero? (get-date dt))) - (test-assert "Datetime time is time" (time? (get-time% dt))) - (test-assert "Datetime time is zero" (time-zero? (get-time% dt))) - (test-eqv "Defalut timezone is #f" #f (get-timezone dt)))) + (test-assert "Datetime date is date" (date? (datetime-date dt))) + (test-assert "Datetime date is zero" (date-zero? (datetime-date dt))) + (test-assert "Datetime time is time" (time? (datetime-time dt))) + (test-assert "Datetime time is zero" (time-zero? (datetime-time dt))) + (test-eqv "Defalut timezone is #f" #f (tz dt)))) (test-group "Datetime with keys" (let ((dt (datetime date: (date day: 10) time: (time minute: 20)))) (test-equal "Given date is stored" - 10 (day (get-date dt))) + 10 (day (datetime-date dt))) (test-equal "Given time is stored" - 20 (minute (get-time% dt)))) + 20 (minute (datetime-time dt)))) (test-error "Date must be a date" 'wrong-type-arg (datetime date: 1)) (test-error "Date must be a date" 'wrong-type-arg (datetime date: (time))) - (test-assert "Date: #f gives still constructs a date" (date? (get-date (datetime date: #f)))) + (test-assert "Date: #f gives still constructs a date" (date? (datetime-date (datetime date: #f)))) (test-error "Time must be a time" 'wrong-type-arg (datetime time: 1)) (test-error "Time must be a time" 'wrong-type-arg (datetime time: (date))) - (test-assert "Time: #f gives still constructs a time" (time? (get-time% (datetime time: #f)))) + (test-assert "Time: #f gives still constructs a time" (time? (datetime-time (datetime time: #f)))) (let ((dt (datetime hour: 20 day: 30))) - (test-equal "Time objects can be implicitly created" 20 (hour (get-time% dt))) - (test-equal "Date objects can be implicitly created" 30 (day (get-date dt)))) + (test-equal "Time objects can be implicitly created" 20 (hour (datetime-time dt))) + (test-equal "Date objects can be implicitly created" 30 (day (datetime-date dt)))) (let ((dt (datetime day: 30 time: (time hour: 20)))) (test-equal "\"Upper\" and \"lower\" keys can be mixed" - 20 (hour (get-time% dt))) + 20 (hour (datetime-time dt))) (test-equal "\"Upper\" and \"lower\" keys can be mixed" - 30 (day (get-date dt)))) + 30 (day (datetime-date dt)))) (let ((dt (datetime hour: 30 time: (time hour: 20)))) (test-equal "time: has priority over hour: (and the like)" - 20 (hour (get-time% dt))))) + 20 (hour (datetime-time dt))))) (let ((dt (datetime day: 30 date: (date day: 20)))) (test-equal "date: has priority over day: (and the like)" - 20 (day (get-date dt))))))) + 20 (day (datetime-date dt))))))) ;; Before the general parser, since it's a dependency string->datetime. (test-group "Parse Month" @@ -384,7 +383,7 @@ (test-assert "Current datetime returns a datetime" (datetime? (current-datetime))) (test-equal "Current datetime returns with tz: UTC" - "UTC" (get-timezone (current-datetime))) + "UTC" (tz (current-datetime))) (test-assert "Current-date returns a date" (date? (current-date))) @@ -707,6 +706,11 @@ date-range (not (datetime< (datetime day: 1) (datetime day: 2) (datetime day: 1))))))) ;; TODO +date<= +time<= +datetime<= + +;; TODO date/-time< date/-time<? date/-time<= date/-time<=? date/-time> date/-time>? date/-time>= date/-time>=? diff --git a/tests/test/hnh-util-env.scm b/tests/test/hnh-util-env.scm new file mode 100644 index 00000000..f38a3a3b --- /dev/null +++ b/tests/test/hnh-util-env.scm @@ -0,0 +1,49 @@ +(define-module (test hnh-util-env) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((guile) :select (setenv getenv)) + :use-module ((hnh util env) :select (let-env))) + + +(test-group "let-env" + (setenv "CALP_TEST_ENV" "1") + + (test-equal + "Ensure we have set value beforehand" + "1" + (getenv "CALP_TEST_ENV")) + + (let-env + ((CALP_TEST_ENV "2")) + (test-equal + "Test our local override" + "2" + (getenv "CALP_TEST_ENV"))) + + (test-equal + "Test that we have returned" + "1" + (getenv "CALP_TEST_ENV")) + + (catch 'test-error + (lambda () + (let-env + ((CALP_TEST_ENV "2")) + (test-equal + "Test our local override again" + "2" + (getenv "CALP_TEST_ENV")) + (throw 'test-error))) + list) + + (test-equal + "Test restoration after non-local exit" + "1" + (getenv "CALP_TEST_ENV"))) + +(test-group "with-working-directory" + 'TODO) + +(test-group "with-locale" + 'TODO) diff --git a/tests/test/hnh-util-lens.scm b/tests/test/hnh-util-lens.scm new file mode 100644 index 00000000..0508553a --- /dev/null +++ b/tests/test/hnh-util-lens.scm @@ -0,0 +1,59 @@ +(define-module (test hnh-util-lens) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (hnh util lens)) + + +(define first (ref 0)) + +(test-equal '((1)) (first '(((1))))) +(test-equal '((2)) (set '(((1))) (compose-lenses first first) 2)) +(test-equal '(((2))) (set '(((1))) (compose-lenses first first first) 2)) + + +;; (list-change (iota 10) 5 'Hello) +;; => (0 1 2 3 4 Hello 6 7 8 9) + +(test-equal '(1 (10) 3) (set '(1 (2) 3) (compose-lenses (ref 1) (ref 0)) 10)) +(test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10)) + +;; (set (list (iota 10)) first first 11) + +(define cadr* (compose-lenses cdr* car*)) + +(test-group "Primitive lenses get and set" + (define lst '(1 2 3 4 5)) + (test-equal 1 (car* lst)) + (test-equal '(2 3 4 5) (cdr* lst)) + + (test-equal '(10 2 3 4 5) + (car* lst 10))) + +(test-group "Primitive lens composition" + (define lst '(1 2 3 4 5)) + (test-equal 2 (cadr* lst)) + (test-equal '(1 10 3 4 5) (cadr* lst 10))) + +(test-group "Modify" + (define lst '(1 2 3 4 5)) + (test-equal '(10 2 3 4 5) (modify lst car* * 10)) + (test-equal '(1 20 3 4 5) (modify lst cadr* * 10)) + ) + +(test-group "Modify*" + (define lst '(1 2 3 4 5)) + (test-equal '(1 2 4 4 5) (modify* lst cdr* cdr* car* 1+))) + +;; modify +;; modify* +;; set +;; get + +;; identity-lens +;; compose-lenses +;; lens-compose + +;; ref car* cdr* + +;; each diff --git a/tests/test/hnh-util-path.scm b/tests/test/hnh-util-path.scm new file mode 100644 index 00000000..de4bf8e3 --- /dev/null +++ b/tests/test/hnh-util-path.scm @@ -0,0 +1,124 @@ +(define-module (test hnh-util-path) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((hnh util env) :select (with-working-directory)) + :use-module (hnh util path)) + +(test-equal + "no slashes" + "home/user" + (path-append "home" "user")) + +(test-equal + "no slashes, absolute" + "/home/user" + (path-append "" "home" "user")) + +(test-equal + "slashes in one component, absolute" + "/home/user" + (path-append "" "/home/" "user")) + +(test-equal + "slashes in one component, absolute due to first" + "/home/user" + (path-append "/home/" "user")) + +(test-equal + "Slashes in both" + "home/user" + (path-append "home/" "/user")) + +(test-equal "root" "/" (path-append "")) + +(test-equal + '("usr" "lib" "test") + (path-split "usr/lib/test")) + +(test-equal + '("usr" "lib" "test") + (path-split "usr/lib/test/")) + +(test-equal + '("" "usr" "lib" "test") + (path-split "/usr/lib/test")) + +(test-equal + '("" "usr" "lib" "test") + (path-split "//usr////lib/test")) + +(test-assert (file-hidden? ".just-filename")) +(test-assert (file-hidden? "/path/to/.hidden")) +(test-assert (not (file-hidden? "/visible/.in/hidden"))) +(test-assert (not (file-hidden? ""))) + +;; TODO test realpath with .. and similar + +(test-equal "Realpath for path fragment" + "/home/hugo" + (with-working-directory + "/home" + (lambda () (realpath "hugo")))) + +(test-equal "Realpath for already absolute path" + "/home/hugo" + (with-working-directory + "/tmp" + (lambda () (realpath "/home/hugo")))) + +(test-equal "Realpath for already absolute path" + "/home/hugo" + (with-working-directory + "/tmp" + (lambda () (realpath "/home/hugo")))) + + +(test-group "Relative to" + + (test-group "With relative child" + (test-equal "/some/path" (relative-to "/some" "path"))) + + ;; Relative parent just adds (getcwd) to start of parent, + ;; but this is "hard" to test. + ;; (test-group "With relative parent") + + (test-group "With absolute child" + (test-error 'misc-error (relative-to "" "/some/path")) + (test-equal "some/path" (relative-to "/" "/some/path")) + (test-group "Without trailing slashes" + (test-equal "path" (relative-to "/some" "/some/path")) + (test-equal "../path" (relative-to "/some" "/other/path"))) + (test-group "With trailing slashes" + (test-equal "path" (relative-to "/some" "/some/path/")) + (test-equal "../path" (relative-to "/some" "/other/path/")))) + + (test-equal "/a/b" (relative-to "/a/b/c" "/a/b")) + + ) + + +(test-equal "Extension of simple file" + "txt" (filename-extension "file.txt")) + +(test-equal "Extension of file with directory" + "txt" (filename-extension "/direcotry/file.txt")) + +(test-equal "Extension of file with multiple" + "gz" (filename-extension "filename.tar.gz")) + +(test-equal "Filename extension when none is present" + "" (filename-extension "filename")) + +(test-equal "Filename extension when none is present, but directory has" + "" (filename-extension "config.d/filename")) + +(test-equal "Filename extension of directory" + "d" (filename-extension "config.d/")) + + +(test-equal "Extension of hidden file" + "sh" (filename-extension ".bashrc.sh")) + +(test-equal "Extension of hidden file without extension" + "bashrc" (filename-extension ".bashrc")) diff --git a/tests/test/hnh-util-state-monad.scm b/tests/test/hnh-util-state-monad.scm new file mode 100644 index 00000000..353c47e9 --- /dev/null +++ b/tests/test/hnh-util-state-monad.scm @@ -0,0 +1,120 @@ +(define-module (test hnh-util-state-monad) + :use-module (srfi srfi-64) + :use-module (hnh util state-monad)) + + +(call-with-values (lambda () ((return 1) 2)) + (lambda (value state) + (test-equal "Return returns the value unmodified" 1 value) + (test-equal "Return also returns the state as a second value" 2 state))) + +(test-equal "Get returns the current state as primary value, while kepping the state" + '(state state) + (call-with-values (lambda () ((get) 'state)) list)) + +;; Return value of put untested, since it's undefined +(test-equal "Put replaces the old state with a new one, and return old one" + '(old-state new-state) + (call-with-values (lambda () ((put 'new-state) 'old-state)) + list)) + +(test-equal "A simple do is effectively a `values' call" + '(value initial-state) + (call-with-values (lambda () ((do (return 'value)) 'initial-state)) + list)) + +(test-equal "Let statement in do" + '(10 state) + (call-with-values (lambda () ((do x = 10 + (return x)) + 'state)) + list)) + +;; TODO let statement with multiple binds +;; (do let (a b) = (values 10 20) ...) + +(test-equal "Set and get through do, along with <- in do." + '(5 1) + (call-with-values (lambda () ((do old <- (get) + (put (1+ old)) + (return 5)) + 0)) + list)) + + + +(test-equal "<$> Updates stuff before being removed from the monad context" + '(11 10) + (call-with-values (lambda () + ((do x <- (<$> 1+ (get)) + (return x)) + 10)) + list)) + +(test-equal "Sequence should update the state accordingly" + 3 + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + (lambda (_ st) st))) + +(test-equal "Sequence should also act as map on the primary value" + '((0 1 2) 3) + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + list)) + +(test-equal "Get returns a single value when only a single value is in the state" + '(1 1) (call-with-values (lambda () ((get) 1)) + list)) + +(test-equal "Get returns a list of values when multiple items are in the state" + '((1 2 3) 1 2 3) + (call-with-values (lambda () ((get) 1 2 3)) + list)) + +(test-equal "Get with multiple values" + '((1 2) 1 2) + (call-with-values (lambda () ((get) 1 2)) + list)) + +(test-equal "Get with multiple values in do" + '((1 2) 1 2) + (call-with-values (lambda () + ((do (a b) <- (get) + (return (list a b))) + 1 2)) + list)) + +((do (put 0) + (with-temp-state + (list 10) + (do a <- (get) + (return (test-equal "Temporary state is set" + 10 a)) + (put 20))) + a <- (get) + (return (test-equal "Pre-temp state is restored" 0 a))) + 'init) + + +;; TODO test for do where the number of implicit arguments changes + +(test-equal "Something" 30 + ((do (with-temp-state + '(10 20) + ;; todo (lift +) + (do (a b) <- (get) + (return (+ a b))))) + 0 1)) + + diff --git a/tests/test/hnh-util.scm b/tests/test/hnh-util.scm new file mode 100644 index 00000000..4e50ac1b --- /dev/null +++ b/tests/test/hnh-util.scm @@ -0,0 +1,428 @@ +;;; Commentary: +;; Checks some prodecuders from (hnh util) +;;; Code: + +(define-module (test hnh-util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (srfi srfi-1) + :use-module (hnh util) + :use-module (hnh util env) + ) + +(define (unreachable) + (throw 'unreachable)) + + +;;; Changed core bindings + +(test-group "set!" + (let ((x 10)) + (set! x 20) + (test-eqv "Regular set! still works" 20 x)) + + (test-group "Multiple set! at once works" + (let ((x 10) (y 20)) + (set! x 20 + y 30) + (test-eqv x 20) + (test-eqv y 30))) + + (test-group "Set! is ordered" + (let ((x 10)) + (set! x 20 + x (* x 2)) + (test-eqv x 40))) + + ;; TODO + ;; (test-group "set! =" + ;; ) + + ) + +;;; Nonscensical to test +;; (test-group "define-syntax" +;; ) + +(test-group "when" + (test-equal "when" + 1 (when #t 1)) + + (test-equal "'() when #f" + '() (when #f 1))) + +(test-group "unless" + (test-equal "unless" + 1 (unless #f 1)) + + (test-equal "'() unless #t" + '() (unless #t 1))) + + + +;;; New bindings + +(test-group "aif" + (aif (+ 1 2) + (test-eqv 3 it) + (unreachable)) + + (aif #f + (unreachable) + (test-assert #t))) + +(test-group "awhen" + (test-equal "awhen it" + '(3 4 5) + (awhen (memv 2 '(1 2 3 4 5)) + (cdr it))) + + (test-equal "awhen not" + '() + (awhen (memv 0 '(1 2 3 4 5)) + (cdr it)))) + +(test-group "for" + (test-equal "for simple" + (iota 10) + (for x in (iota 10) + x)) + + (test-equal "for matching" + (iota 12) + (for (x c) in (zip (iota 12) (string->list "Hello, World")) + x)) + + (test-equal "for with improper list elements" + `(3 7) + (for (a . b) in '((1 . 2) (3 . 4)) + (+ a b))) + + (test-equal "for with longer improper list elements" + '(1 2 4) + (for (a b . c) in '((1 -1 . 1) (2 -2 . 2) (4 -4 . 4)) + (* c (+ 1 a b))))) + +(test-group "begin1" + (let ((value #f)) + (test-equal + "begin1 return value" + "Hello" + (begin1 "Hello" (set! value "World"))) + (test-equal "begin1 side effects" "World" value)) + + (let ((x 1)) + (test-eqv "begin1 set! after return" + 1 (begin1 x (set! x 10))) + (test-eqv "Updates value" + 10 x))) + +(test-group "print-and-return" + (let ((p (open-output-string))) + (let ((v (with-error-to-port p + (lambda () (print-and-return (+ 1 2)))))) + (test-equal "Printed value" + "3 [(+ 1 2)]\n" (get-output-string p)) + (test-eqv "Returned value" + 3 v)))) + +(test-group "swap" + (test-equal + '(3 2 1) + ((swap list) 1 2 3))) + +(test-group "set/r!" + (test-equal + "set/r! = single" + #f + (let ((x #t)) (set/r! x = not))) + + (test-error + 'syntax-error + (test-read-eval-string "(set/r! x err not)"))) + +(test-group "label" + (test-equal "procedure label" + 120 + ((label factorial (lambda (n) + (if (zero? n) + 1 (* n (factorial (1- n)))))) + 5))) + +(test-group "sort*" + ;; we can't test if sort*! destroys the list, since its only /allowed/ to do it, + ;; not required. + (test-equal "sort*!" + '("a" "Hello" "Assparagus") + (sort*! '("Hello" "a" "Assparagus") + < string-length))) + + +(test-group "find-extreme" + (test-error 'wrong-type-arg (find-extreme '())) + + (test-group "find-min" + (call-with-values + (lambda () (find-min (iota 10))) + (lambda (extreme rest) + (test-equal "Found correct minimum" 0 extreme) + (test-equal + "Removed \"something\" from the set" + 9 + (length rest))))) + + (test-group "find-max" + (call-with-values + (lambda () + (find-max + '("Hello" "Test" "Something long") + string-length)) + (lambda (extreme rest) + (test-equal + "Found the longest string" + "Something long" + extreme) + (test-equal "Removed the string" 2 (length rest)) + (test-assert + "Other members left 1" + (member "Hello" rest)) + (test-assert + "Other members left 2" + (member "Test" rest)))))) + +(test-group "filter-sorted" + (test-equal + "Filter sorted" + '(3 4 5) + (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10)))) + + +(test-group "!=" + (test-assert "not equal" + (!= 1 2))) + +(test-group "init+last" + 'TODO) + +(test-group "take-to" + (test-equal "Take to" + '() (take-to '() 5))) + +(test-group "string-take-to" + (test-equal "Hello" + (string-take-to "Hello, World!" 5))) + +(test-group "string-first" + (test-eqv #\H (string-first "Hello, World!"))) + +(test-group "string-last" + (test-eqv #\! (string-last "Hello, World!"))) + +(test-group "as-symb" + (test-eq "From string" 'hello (as-symb "hello")) + (test-eq "From symbol" 'hello (as-symb 'hello)) + (test-eq "NOTE that others pass right through" + '() (as-symb '()))) + + +(test-group "enumerate" + (test-equal "Enumerate" + '((0 #\H) (1 #\e) (2 #\l) (3 #\l) (4 #\o) (5 #\,) (6 #\space) (7 #\W) (8 #\o) (9 #\r) (10 #\l) (11 #\d) (12 #\!)) + (enumerate (string->list "Hello, World!")))) + + +(test-group "unval" + (test-equal "unval first" + 1 + ((unval (lambda () (values 1 2 3))))) + + (test-equal "unval other" + 2 + ((unval car+cdr 1) + (cons 1 2)))) + + +(test-group "flatten" + (test-equal "flatten already flat" + (iota 10) + (flatten (iota 10))) + + (test-equal "flatten really deep" + '(1) + (flatten '(((((((((((((((1))))))))))))))))) + + (test-equal "flatten mixed" + '(1 2 3 4 5) + (flatten '((((((1(((((2((((3))))))4))))))))5)))) + +(test-group "let-lazy" + 'TODO) + +(test-group "map/dotted" + (test-equal "map/dotted without dot" + '(1 2 3 4) + (map/dotted 1+ '(0 1 2 3))) + + (test-equal "map/dotted with dot" + '(1 2 3 . 4) + (map/dotted 1+ '(0 1 2 . 3))) + + (test-equal "map/dotted direct value" + 1 (map/dotted 1+ 0))) + +(test-group "assq-merge" + (test-equal "assq merge" + '((k 2 1) (v 2)) + (assq-merge '((k 1) (v 2)) '((k 2))))) + + +(test-group "kvlist->assq" + (test-equal "kvlist->assq" + '((a . 1) (b . 2)) + (kvlist->assq '(a: 1 b: 2))) + + (test-equal "kvlist->assq repeated key" + '((a . 1) (b . 2) (a . 3)) + (kvlist->assq '(a: 1 b: 2 a: 3)))) + +(test-group "assq-limit" + 'TODO) + + +(test-group "group-by" + ;; Extra roundabout tests since groups-by doesn't guarantee order of the keys + (test-group "Two simple groups" + (let ((groups (group-by even? (iota 10)))) + (test-assert (lset= eq? '(#f #t) (map car groups))) + (test-assert (lset= = '(0 2 4 6 8) (assq-ref groups #t))) + (test-assert (lset= = '(1 3 5 7 9) (assq-ref groups #f))))) + + (test-group "Identity groups" + (let ((groups (group-by identity (iota 5)))) + (test-assert "Correct keys" + (lset= = (iota 5) (map car groups))) + (test-group "Correct amount in each group" + (for-each (lambda (g) (test-equal 1 (length (cdr g)))) groups)))) + + (test-equal "Null case" + '() + (group-by (lambda _ (unreachable)) '()))) + +(test-group "split-by" + 'TODO) + + +(test-group "span-upto" + (test-group "Case 1" + (call-with-values + (lambda () + (span-upto + 2 + char-numeric? + (string->list "123456"))) + (lambda (head tail) + (test-equal '(#\1 #\2) head) + (test-equal '(#\3 #\4 #\5 #\6) tail)))) + + (test-group "Case 2" + (call-with-values + (lambda () + (span-upto + 2 + char-numeric? + (string->list "H123456"))) + (lambda (head tail) + (test-equal '() head) + (test-equal '(#\H #\1 #\2 #\3 #\4 #\5 #\6) tail))))) + +(test-group "cross-product" + (test-equal "Basic case" + '((1 4) + (1 5) + (1 6) + (2 4) + (2 5) + (2 6) + (3 4) + (3 5) + (3 6)) + (cross-product + '(1 2 3) + '(4 5 6))) + + (test-equal "Single input list" + '((1) (2) (3)) + (cross-product '(1 2 3))) + + (test-equal "More than two" + '((1 3 5) (1 3 6) + (1 4 5) (1 4 6) + (2 3 5) (2 3 6) + (2 4 5) (2 4 6)) + (cross-product + '(1 2) + '(3 4) + '(5 6)))) + +(test-group "string-flatten" + 'TODO) + +(test-group "intersperse" + 'TODO) + +(test-group "insert-ordered" + 'TODO) + +(test-group "-> (arrows)" + (test-equal "->" 9 (-> 1 (+ 2) (* 3))) + (test-equal "-> order dependant" -1 (-> 1 (- 2))) + (test-equal "->> order dependant" 1 (->> 1 (- 2)))) + +(test-group "set" + 'TODO) + +(test-group "set->" + 'TODO) + +(test-group "and=>" + 'TODO) + +(test-group "downcase-symbol" + 'TODO) + + +(test-group "group" + ;; TODO test failure when grouping isn't possible? + (test-equal "Group" + '((0 1) (2 3) (4 5) (6 7) (8 9)) + (group (iota 10) 2))) + +(test-group "iterate" + (test-equal 0 (iterate 1- zero? 10))) + +(test-group "valued-map" + 'TODO) + +(test-group "assoc-ref-all" + (test-equal "assoc-ref-all" + '(1 3) (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) + (test-equal "assq-ref-all" + '(1 3) (assq-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) + (test-equal "assv-ref-all" + '(1 3) (assv-ref-all '((a . 1) (b . 2) (a . 3)) 'a))) + +(test-group "unique" + 'TODO) + +(test-group "vector-last" + (test-equal "vector-last" + 1 (vector-last #(0 2 3 1)))) + +(test-group "->string" + (test-equal "5" (->string 5)) + (test-equal "5" (->string "5"))) + +(test-group "catch*" + 'TODO) + diff --git a/tests/test/object.scm b/tests/test/object.scm new file mode 100644 index 00000000..701c45c0 --- /dev/null +++ b/tests/test/object.scm @@ -0,0 +1,80 @@ +(define-module (test object) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (hnh util object) + :use-module ((hnh util) :select (->))) + +(define-type (f) x) + +(test-group "Created procedures" + (test-assert "Constructor" (procedure? f)) + (test-assert "Predicate" (procedure? f?)) + (test-assert "Field access" (procedure? x))) + +;; (f) +;; (f x: 10) +;; (f? (f)) + +(test-equal "Accessors are getters" + 10 (x (f x: 10))) +(test-assert "Accessors update, returning a object of the original type" + (f? (x (f x: 10) 20))) +(test-equal "A get after an update returns the new value" + 20 (-> (f x: 10) + (x 20) + x)) + + +(define-type (g) x) + +(test-assert "Second type can be created" + (g x: 10)) + +(test-assert "Second type isn't first type" + (not (f? (g x: 10)))) + +(test-assert "First type isn't second type" + (not (g? (f x: 10)))) + +;; Tests that the old x gets shadowed +;; (test-equal 10 (x (f x: 10))) +;; (test-equal 10 (x (g x: 10))) + +;; field-level arguments +;; - init: +(define-type (f2) (f2-x default: 0 type: integer?)) +(test-equal 0 (f2-x (f2))) + +;; - type: + +(test-error "Giving an invalid type to the constructor throws an error" + 'wrong-type-arg (f2 f2-x: 'hello)) +(test-error "Giving an invalid type to a setter throws an error" + 'wrong-type-arg (f2-x (f2) 'hello)) +(test-equal "The error includes the name of the field, the expected type, and the given value" + '(f2-x integer? hello) + (catch 'wrong-type-arg (lambda () (f2-x (f2) 'hello)) + (lambda (err proc fmt args data) args))) + +(test-equal "Typed setter updates the value" + (f2 f2-x: 10) (f2-x (f2) 10)) + +;; type-level arguments +;; - constructor: +(define-type (f3 constructor: (lambda (make check) + (lambda* (#:key f3-x f3-y) + (check f3-x f3-y) + (make f3-x f3-y)))) + (f3-x type: integer?) + (f3-y type: string?)) + +(test-assert "Custom constructors create objcets" + (f3? (f3 f3-x: 10 f3-y: "Hello"))) + +(test-error "Bad arguments to custom constructor" + 'wrong-type-arg (f3 f3-x: 'hello f3-y: 'world)) + +;; - printer: +(define-type (f4 printer: (lambda (r p) (display "something" p)))) +(test-equal "something" (with-output-to-string (lambda () (write (f4))))) diff --git a/tests/test/param.scm b/tests/test/param.scm index 34f7b826..431a8f46 100644 --- a/tests/test/param.scm +++ b/tests/test/param.scm @@ -8,10 +8,10 @@ :use-module (srfi srfi-64 test-error) :use-module (srfi srfi-88) :use-module ((vcomponent base) - :select (param prop* parameters prop)) + :select (param prop* parameters prop vline?)) :use-module ((vcomponent formats ical parse) :select (parse-calendar)) - :use-module ((vcomponent) :select (make-vcomponent)) + :use-module ((vcomponent) :select (vcomponent properties set-properties)) :use-module ((hnh util) :select (sort* set!)) :use-module ((ice-9 ports) :select (call-with-input-string)) :use-module ((vcomponent formats xcal output) @@ -23,11 +23,12 @@ ;; TODO possibly change parsing (define v - (call-with-input-string - "BEGIN:DUMMY + (car + (call-with-input-string + "BEGIN:DUMMY X-KEY;A=1;B=2:Some text END:DUMMY" - parse-calendar)) + parse-calendar))) (test-equal '("1") (param (prop* v 'X-KEY) 'A)) @@ -35,17 +36,20 @@ END:DUMMY" (test-equal #f (param (prop* v 'X-KEY) 'C)) -(test-equal - '(A B) - (sort* (map car (parameters (prop* v 'X-KEY))) - string<? - symbol->string)) + +(test-group "Properties" + (let ((p (properties v))) + (test-assert (list? p)) + (test-eqv 1 (length p)) + (test-eq 'X-KEY (caar p)) + (test-assert (vline? (cadar p))))) + ;; TODO possibly move this. ;; Checks that a warning is properly raised for ;; unkonwn keys (without an X-prefix) -(test-error +(test-error "Ensure parse-calendar warns on unknown keys" 'warning (call-with-input-string "BEGIN:DUMMY @@ -54,10 +58,9 @@ END:DUMMY" parse-calendar)) ;; Similar thing happens for sxcal, but during serialization instead -(let ((component (make-vcomponent 'DUMMY))) - (set! (prop component 'KEY) "Anything") +(let ((component (set-properties (vcomponent type: 'DUMMY) + (cons 'KEY "Anything")))) + (test-error 'warning (vcomponent->sxcal component))) - - diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm index a291cc17..c2d71e61 100644 --- a/tests/test/recurrence-advanced.scm +++ b/tests/test/recurrence-advanced.scm @@ -14,8 +14,8 @@ (define-module (test recurrence-advanced) :use-module (srfi srfi-64) :use-module (srfi srfi-88) - :use-module ((vcomponent recurrence parse) - :select (parse-recurrence-rule)) + :use-module ((vcomponent recurrence) + :select (make-recur-rule)) :use-module ((vcomponent recurrence generate) :select (generate-recurrence-set)) :use-module ((vcomponent recurrence display) @@ -23,12 +23,16 @@ :use-module ((vcomponent recurrence internal) :select (count until)) :use-module ((vcomponent base) - :select (make-vcomponent prop prop* extract make-vline)) + :select (prop prop* extract)) + :use-module (vcomponent create) :use-module ((datetime) :select (parse-ics-datetime datetime + datetime-date time date + jan feb mar apr may jun jul aug sep oct nov dec + mon tue wed thu fri sat sun datetime->string)) :use-module ((hnh util) :select (-> set!)) :use-module ((srfi srfi-41) :select (stream->list)) @@ -63,36 +67,16 @@ ;; TODO possibly test with other languages (format-recurrence-rule (prop comp 'RRULE) 'sv))) -;; TODO remove this makeshift parser (and all others), and replace them with a -;; properly specified syntax for easily creating objects. -(define (vevent . rest) - (define v (make-vcomponent 'VEVENT)) - (let loop ((rem rest)) - (unless - (null? rem) - (let ((symb (-> (car rem) - keyword->string - string-upcase - string->symbol))) - ;; TODO extend to allow dates (without time) - (case symb - ((EXDATE RDATE) (set! (prop* v symb) - (map (lambda (dt) (make-vline symb dt (make-hash-table))) - (map parse-ics-datetime (cadr rem))))) - ((DTSTART) (set! (prop v symb) (parse-ics-datetime (cadr rem)))) - ((RRULE) (set! (prop v symb) (parse-recurrence-rule (cadr rem)))) - (else (set! (prop v symb) (cadr rem))))) - (loop (cddr rem)))) - v) - (map run-test (list (vevent summary: "Daily for 10 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;COUNT=10" + (make-recur-rule + freq: 'DAILY + count: 10) x-summary: "dagligen, totalt 10 gånger" x-set: @@ -110,9 +94,11 @@ summary: "Daily until December 24, 1997" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;UNTIL=19971224T000000Z" + (make-recur-rule + freq: 'DAILY + until: #1997-12-24T00:00:00Z) x-summary: "dagligen, till och med den 24 december, 1997 kl. 0:00" x-set: @@ -233,9 +219,11 @@ summary: "Every other day - forever" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;INTERVAL=2" + (make-recur-rule + freq: 'DAILY + interval: 2) x-summary: "varannan dag" x-set: @@ -263,9 +251,12 @@ summary: "Every 10 days, 5 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;INTERVAL=10;COUNT=5" + (make-recur-rule + freq: 'DAILY + interval: 10 + count: 5) x-summary: "var tionde dag, totalt 5 gånger" x-set: @@ -278,9 +269,13 @@ summary: "Every day in January, for 3 years (alt 1)" dtstart: - "19980101T090000" + #1998-01-01T09:00:00 rrule: - "FREQ=YEARLY;UNTIL=20000131T140000Z;BYMONTH=1;BYDAY=SU,MO,TU,WE,TH,FR,SA" + (make-recur-rule + freq: 'YEARLY + until: #2000-01-31T14:00:00Z + bymonth: (list jan) + byday: (list sun mon tue wed thu fri sat)) x-summary: "varje lördag, fredag, torsdag, onsdag, tisdag, måndag & söndag i januari, årligen, till och med den 31 januari, 2000 kl. 14:00" x-set: @@ -381,9 +376,12 @@ summary: "Every day in January, for 3 years (alt 2)" dtstart: - "19980101T090000" + #1998-01-01T09:00:00 rrule: - "FREQ=DAILY;UNTIL=20000131T140000Z;BYMONTH=1" + (make-recur-rule + freq: 'DAILY + until: #2000-01-31T14:00:00Z + bymonth: 1) x-summary: "dagligen, till och med den 31 januari, 2000 kl. 14:00" x-set: @@ -484,9 +482,11 @@ summary: "Weekly for 10 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;COUNT=10" + (make-recur-rule + freq: 'WEEKLY + count: 10) x-summary: "varje vecka, totalt 10 gånger" x-set: @@ -504,9 +504,11 @@ summary: "Weekly until December 24, 1997" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;UNTIL=19971224T000000Z" + (make-recur-rule + freq: 'WEEKLY + until: #1997-12-24T00:00:00Z) x-summary: "varje vecka, till och med den 24 december, 1997 kl. 0:00" x-set: @@ -531,9 +533,12 @@ summary: "Every other week - forever" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;WKST=SU" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + wkst: sun) x-summary: "varannan vecka" x-set: @@ -561,9 +566,13 @@ summary: "Weekly on Tuesday and Thursday for five weeks (alt 1)" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;UNTIL=19971007T000000Z;WKST=SU;BYDAY=TU,TH" + (make-recur-rule + freq: 'WEEKLY + until: #1997-10-07T00:00:00Z + wkst: sun + byday: (list tue thu)) x-summary: "varje tisdag & torsdag, till och med den 07 oktober, 1997 kl. 0:00" x-set: @@ -581,9 +590,13 @@ summary: "Weekly on Tuesday and Thursday for five weeks (alt 2)" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;COUNT=10;WKST=SU;BYDAY=TU,TH" + (make-recur-rule + freq: 'WEEKLY + count: 10 + wkst: sun + byday: (list tue thu)) x-summary: "varje tisdag & torsdag, totalt 10 gånger" x-set: @@ -601,9 +614,14 @@ summary: "Every other week on Monday, Wednesday, and Friday until December 24, 1997, starting on Monday, September 1, 1997:" dtstart: - "19970901T090000" + #1997-09-01T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;UNTIL=19971224T000000Z;WKST=SU;BYDAY=MO,WE,FR" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + until: #1997-12-24T00:00:00Z + wkst: sun + byday: (list mon wed fri)) x-summary: "varannan måndag, onsdag & fredag, till och med den 24 december, 1997 kl. 0:00" x-set: @@ -636,9 +654,14 @@ summary: "Every other week on Tuesday and Thursday, for 8 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;COUNT=8;WKST=SU;BYDAY=TU,TH" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + count: 8 + wkst: sun + byday: (list tue thu)) x-summary: "varannan tisdag & torsdag, totalt 8 gånger" x-set: @@ -654,9 +677,12 @@ summary: "Monthly on the first Friday for 10 occurrences" dtstart: - "19970905T090000" + #1997-09-05T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=10;BYDAY=1FR" + (make-recur-rule + freq: 'MONTHLY + count: 10 + byday: (list (cons 1 fri))) x-summary: "första fredagen varje månad, totalt 10 gånger" x-set: @@ -674,9 +700,12 @@ summary: "Monthly on the first Friday until December 24, 1997" dtstart: - "19970905T090000" + #1997-09-05T09:00:00 rrule: - "FREQ=MONTHLY;UNTIL=19971224T000000Z;BYDAY=1FR" + (make-recur-rule + freq: 'MONTHLY + until: #1997-12-24T00:00:00Z + byday: (list (cons 1 fri))) x-summary: "första fredagen varje månad, till och med den 24 december, 1997 kl. 0:00" x-set: @@ -688,9 +717,14 @@ summary: "Every other month on the first and last Sunday of the month for 10 occurrences" dtstart: - "19970907T090000" + #1997-09-07T09:00:00 rrule: - "FREQ=MONTHLY;INTERVAL=2;COUNT=10;BYDAY=1SU,-1SU" + (make-recur-rule + freq: 'MONTHLY + interval: 2 + count: 10 + byday: (list (cons 1 sun) + (cons -1 sun))) x-summary: "första söndagen samt sista söndagen varannan månad, totalt 10 gånger" x-set: @@ -708,9 +742,12 @@ summary: "Monthly on the second-to-last Monday of the month for 6 months" dtstart: - "19970922T090000" + #1997-09-22T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=6;BYDAY=-2MO" + (make-recur-rule + freq: 'MONTHLY + count: 6 + byday: (list (cons -2 mon))) x-summary: "näst sista måndagen varje månad, totalt 6 gånger" x-set: @@ -724,9 +761,11 @@ summary: "Monthly on the third-to-the-last day of the month, forever" dtstart: - "19970928T090000" + #1997-09-28T09:00:00 rrule: - "FREQ=MONTHLY;BYMONTHDAY=-3" + (make-recur-rule + freq: 'MONTHLY + bymonthday: (list -3)) x-summary: "den tredje sista varje månad" x-set: @@ -754,9 +793,12 @@ summary: "Monthly on the 2nd and 15th of the month for 10 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=10;BYMONTHDAY=2,15" + (make-recur-rule + freq: 'MONTHLY + count: 10 + bymonthday: (list 2 15)) x-summary: "den andre & femtonde varje månad, totalt 10 gånger" x-set: @@ -774,9 +816,12 @@ summary: "Monthly on the first and last day of the month for 10 occurrences" dtstart: - "19970930T090000" + #1997-09-30T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=10;BYMONTHDAY=1,-1" + (make-recur-rule + freq: 'MONTHLY + count: 10 + bymonthday: (list 1 -1)) x-summary: "den förste & sista varje månad, totalt 10 gånger" x-set: @@ -794,9 +839,13 @@ summary: "Every 18 months on the 10th thru 15th of the month for 10 occurrences" dtstart: - "19970910T090000" + #1997-09-10T09:00:00 rrule: - "FREQ=MONTHLY;INTERVAL=18;COUNT=10;BYMONTHDAY=10,11,12,13,14,15" + (make-recur-rule + freq: 'MONTHLY + interval: 18 + count: 10 + bymonthday: (list 10 11 12 13 14 15)) x-summary: "den tionde, elfte, tolfte, trettonde, fjortonde & femtonde var artonde månad, totalt 10 gånger" x-set: @@ -814,9 +863,12 @@ summary: "Every Tuesday, every other month" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MONTHLY;INTERVAL=2;BYDAY=TU" + (make-recur-rule + freq: 'MONTHLY + interval: 2 + byday: (list tue)) x-summary: "varje tisdag varannan månad" x-set: @@ -844,9 +896,12 @@ summary: "Yearly in June and July for 10 occurrences:\n: Since none of the BYDAY, BYMONTHDAY, or BYYEARDAY\nonents are specified, the day is gotten from \"DTSTART\"" dtstart: - "19970610T090000" + #1997-06-10T09:00:00 rrule: - "FREQ=YEARLY;COUNT=10;BYMONTH=6,7" + (make-recur-rule + freq: 'YEARLY + count: 10 + bymonth: (list 6 7)) x-summary: "juni & juli, årligen, totalt 10 gånger" x-set: @@ -864,9 +919,13 @@ summary: "Every other year on January, February, and March for 10 occurrences" dtstart: - "19970310T090000" + #1997-03-10T09:00:00 rrule: - "FREQ=YEARLY;INTERVAL=2;COUNT=10;BYMONTH=1,2,3" + (make-recur-rule + freq: 'YEARLY + interval: 2 + count: 10 + bymonth: (list jan feb mar)) x-summary: "januari, februari & mars vartannat år, totalt 10 gånger" x-set: @@ -884,9 +943,13 @@ summary: "Every third year on the 1st, 100th, and 200th day for 10 occurrences" dtstart: - "19970101T090000" + #1997-01-01T09:00:00 rrule: - "FREQ=YEARLY;INTERVAL=3;COUNT=10;BYYEARDAY=1,100,200" + (make-recur-rule + freq: 'YEARLY + interval: 3 + count: 10 + byyearday: (list 1 100 200)) x-summary: "dag 1, 100 & 200 vart tredje år, totalt 10 gånger" x-set: @@ -904,9 +967,11 @@ summary: "Every 20th Monday of the year, forever" dtstart: - "19970519T090000" + #1997-05-19T09:00:00 rrule: - "FREQ=YEARLY;BYDAY=20MO" + (make-recur-rule + freq: 'YEARLY + byday: (list (cons 20 mon))) x-summary: "tjugonde måndagen, årligen" x-set: @@ -934,9 +999,12 @@ summary: "Monday of week number 20 (where the default start of the week is Monday), forever" dtstart: - "19970512T090000" + #1997-05-12T09:00:00 rrule: - "FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO" + (make-recur-rule + freq: 'YEARLY + byweekno: (list 20) + byday: (list mon)) x-summary: "varje måndag v.20, årligen" x-set: @@ -964,9 +1032,12 @@ summary: "Every Thursday in March, forever" dtstart: - "19970313T090000" + #1997-03-13T09:00:00 rrule: - "FREQ=YEARLY;BYMONTH=3;BYDAY=TH" + (make-recur-rule + freq: 'YEARLY + bymonth: (list mar) + byday: (list thu)) x-summary: "varje torsdag i mars, årligen" x-set: @@ -994,9 +1065,12 @@ summary: "Every Thursday, but only during June, July, and August, forever" dtstart: - "19970605T090000" + #1997-06-05T09:00:00 rrule: - "FREQ=YEARLY;BYDAY=TH;BYMONTH=6,7,8" + (make-recur-rule + freq: 'YEARLY + byday: (list thu) + bymonth: (list 6 7 8)) x-summary: "varje torsdag i juni, juli & augusti, årligen" x-set: @@ -1024,11 +1098,15 @@ summary: "Every Friday the 13th, forever" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 exdate: - (list "19970902T090000") + (as-list + (list #1997-09-02T09:00:00)) rrule: - "FREQ=MONTHLY;BYDAY=FR;BYMONTHDAY=13" + (make-recur-rule + freq: 'MONTHLY + byday: (list fri) + bymonthday: (list 13)) x-summary: "varje fredag den trettonde varje månad" x-set: @@ -1056,9 +1134,12 @@ summary: "The first Saturday that follows the first Sunday of the month, forever" dtstart: - "19970913T090000" + #1997-09-13T09:00:00 rrule: - "FREQ=MONTHLY;BYDAY=SA;BYMONTHDAY=7,8,9,10,11,12,13" + (make-recur-rule + freq: 'MONTHLY + byday: (list sat) + bymonthday: (list 7 8 9 10 11 12 13)) x-summary: "varje lördag den sjunde, åttonde, nionde, tionde, elfte, tolfte & trettonde varje månad" x-set: @@ -1086,9 +1167,14 @@ summary: "Every 4 years, the first Tuesday after a Monday in November,\nver (U.S. Presidential Election day)" dtstart: - "19961105T090000" + #1996-11-05T09:00:00 rrule: - "FREQ=YEARLY;INTERVAL=4;BYMONTH=11;BYDAY=TU;BYMONTHDAY=2,3,4,5,6,7,8" + (make-recur-rule + freq: 'YEARLY + interval: 4 + bymonth: (list nov) + byday: (list tue) + bymonthday: (list 2 3 4 5 6 7 8)) x-summary: "varje tisdag den andre, tredje, fjärde, femte, sjätte, sjunde eller åttonde i november vart fjärde år" x-set: @@ -1116,9 +1202,13 @@ summary: "The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months" dtstart: - "19970904T090000" + #1997-09-04T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=3;BYDAY=TU,WE,TH;BYSETPOS=3" + (make-recur-rule + freq: 'MONTHLY + count: 3 + byday: (list tue wed thu) + bysetpos: (list 3)) x-summary: "NOT YET IMPLEMENTED" x-set: @@ -1129,9 +1219,12 @@ summary: "The second-to-last weekday of the month" dtstart: - "19970929T090000" + #1997-09-29T09:00:00 rrule: - "FREQ=MONTHLY;BYDAY=MO,TU,WE,TH,FR;BYSETPOS=-2" + (make-recur-rule + freq: 'MONTHLY + byday: (list mon tue wed thu fri) + bysetpos: (list -2)) x-summary: "NOT YET IMPLEMENTED" x-set: @@ -1144,9 +1237,12 @@ summary: "Every 3 hours from 9:00 AM to 5:00 PM on a specific day" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=HOURLY;INTERVAL=3;UNTIL=19970902T170000Z" + (make-recur-rule + freq: 'HOURLY + interval: 3 + until: #1997-09-02T17:00:00Z) x-summary: "var tredje timme, till och med den 02 september, 1997 kl. 17:00" x-set: @@ -1157,9 +1253,12 @@ summary: "Every 15 minutes for 6 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MINUTELY;INTERVAL=15;COUNT=6" + (make-recur-rule + freq: 'MINUTELY + interval: 15 + count: 6) x-summary: "varje kvart, totalt 6 gånger" x-set: @@ -1173,9 +1272,12 @@ summary: "Every hour and a half for 4 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MINUTELY;INTERVAL=90;COUNT=4" + (make-recur-rule + freq: 'MINUTELY + interval: 90 + count: 4) x-summary: "var sjätte kvart, totalt 4 gånger" x-set: @@ -1187,9 +1289,12 @@ summary: "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 1)" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;BYHOUR=9,10,11,12,13,14,15,16;BYMINUTE=0,20,40" + (make-recur-rule + freq: 'DAILY + byhour: (list 9 10 11 12 13 14 15 16) + byminute: (list 0 20 40)) x-summary: "dagligen kl. 09:00, 09:20, 09:40, 10:00, 10:20, 10:40, 11:00, 11:20, 11:40, 12:00, 12:20, 12:40, 13:00, 13:20, 13:40, 14:00, 14:20, 14:40, 15:00, 15:20, 15:40, 16:00, 16:20 & 16:40" x-set: @@ -1217,9 +1322,12 @@ summary: "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 2)" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MINUTELY;INTERVAL=20;BYHOUR=9,10,11,12,13,14,15,16" + (make-recur-rule + freq: 'MINUTELY + interval: 20 + byhour: (list 9 10 11 12 13 14 15 16)) x-summary: "var tjugonde minut kl. 9, 10, 11, 12, 13, 14, 15 & 16" x-set: @@ -1247,9 +1355,14 @@ summary: "An example where the days generated makes a difference because of WKST" dtstart: - "19970805T090000" + #1997-08-05T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=MO" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + count: 4 + byday: (list tue sun) + wkst: mon) x-summary: "varannan tisdag & söndag, totalt 4 gånger" x-set: @@ -1261,9 +1374,14 @@ summary: "changing only WKST from MO to SU, yields different results.." dtstart: - "19970805T090000" + #1997-08-05T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=SU" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + count: 4 + byday: (list tue sun) + wkst: sun) x-summary: "varannan tisdag & söndag, totalt 4 gånger" x-set: @@ -1275,9 +1393,12 @@ summary: "An example where an invalid date (i.e., February 30) is ignored" dtstart: - "20070115T090000" + #2007-01-15T09:00:00 rrule: - "FREQ=MONTHLY;BYMONTHDAY=15,30;COUNT=5" + (make-recur-rule + freq: 'MONTHLY + bymonthday: (list 15 30) + count: 5) x-summary: "den femtonde & tretionde varje månad, totalt 5 gånger" x-set: @@ -1290,11 +1411,15 @@ summary: "Every Friday & Wednesday the 13th, forever" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 exdate: - (list "19970902T090000") + (as-list + (list #1997-09-02T09:00:00)) rrule: - "FREQ=MONTHLY;BYDAY=FR,WE;BYMONTHDAY=13" + (make-recur-rule + freq: 'MONTHLY + byday: (list fri wed) + bymonthday: (list 13)) x-summary: "varje onsdag & fredag den trettonde varje månad" x-set: @@ -1322,9 +1447,12 @@ summary: "Monday & Wednesday of week number 20 (where the default start of the week is Monday), forever" dtstart: - "19970512T090000" + #1997-05-12T09:00:00 rrule: - "FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO,WE" + (make-recur-rule + freq: 'YEARLY + byweekno: (list 20) + byday: (list mon wed)) x-summary: "varje onsdag & måndag v.20, årligen" x-set: @@ -1350,8 +1478,8 @@ #2006-05-17T09:00:00)) (vevent summary: "Each second, for ever" - dtstart: "20201010T100000" - rrule: "FREQ=SECONDLY" + dtstart: #2020-10-10T10:00:00 + rrule: (make-recur-rule freq: 'SECONDLY) x-summary: "varje sekund" x-set: (list #2020-10-10T10:00:00 #2020-10-10T10:00:01 @@ -1377,9 +1505,9 @@ ;; instances may be present. (vevent summary: "Exdates are applied AFTER rrule's" - dtstart: "20220610T100000" - rrule: "FREQ=DAILY;COUNT=5" - exdate: (list "20220612T100000") + dtstart: #2022-06-10T10:00:00 + rrule: (make-recur-rule freq: 'DAILY count: 5) + exdate: (as-list (list #2022-06-12T10:00:00)) x-summary: "dagligen, totalt 5 gånger" x-set: (list #2022-06-10T10:00:00 #2022-06-11T10:00:00 @@ -1389,9 +1517,9 @@ )) (vevent summary: "RDATE:s add to the recurrence rule" - dtstart: "20220610T100000" - rrule: "FREQ=DAILY;COUNT=5" - rdate: (list "20220620T100000") + dtstart: #2022-06-10T10:00:00 + rrule: (make-recur-rule freq: 'DAILY count: 5) + rdate: (as-list (list #2022-06-20T10:00:00)) x-summary: "dagligen, totalt 5 gånger" x-set: (list #2022-06-10T10:00:00 #2022-06-11T10:00:00 @@ -1403,10 +1531,10 @@ ) (vevent summary: "RDATE:s add to the recurrence rule" - dtstart: "20220610T100000" - rrule: "FREQ=DAILY;COUNT=5" - exdate: (list "20220620T100000") - rdate: (list "20220620T100000") + dtstart: #2022-06-10T10:00:00 + rrule: (make-recur-rule freq: 'DAILY count: 5) + exdate: (as-list (list #2022-06-20T10:00:00)) + rdate: (as-list (list #2022-06-20T10:00:00)) x-summary: "dagligen, totalt 5 gånger" x-set: (list #2022-06-10T10:00:00 #2022-06-11T10:00:00 diff --git a/tests/test/recurrence-simple.scm b/tests/test/recurrence-simple.scm index bf154fea..33900ceb 100644 --- a/tests/test/recurrence-simple.scm +++ b/tests/test/recurrence-simple.scm @@ -12,6 +12,9 @@ :select (stream-take stream-map stream->list stream-car)) :use-module ((datetime) :select (day-stream mon)) :use-module ((vcomponent base) :select (extract prop)) + :use-module ((sxml namespaced) :select (sxml->namespaced-sxml)) + :use-module ((calp namespaces) :select (xcal)) + :use-module ((hnh util) :select (->)) :use-module ((hnh util exceptions) :select (warnings-are-errors warning-handler)) :use-module ((vcomponent formats ical parse) @@ -261,9 +264,8 @@ END:VCALENDAR" '((freq "WEEKLY") (interval "1") (wkst "MO")))) (define ev - (sxcal->vcomponent - '(vevent - (properties + (-> '(vevent + (properties (summary (text "reptest")) (dtend (date-time "2021-01-13T02:00:00")) (dtstart (date-time "2021-01-13T01:00:00")) @@ -273,7 +275,9 @@ END:VCALENDAR" (wkst "MO"))) (dtstamp (date-time "2021-01-13T01:42:20Z")) (sequence (integer "0"))) - (components)))) + (components)) + (sxml->namespaced-sxml `((#f . ,xcal))) + sxcal->vcomponent)) (test-assert "Check that recurrence rule commint from xcal also works" diff --git a/tests/test/state-monad.scm b/tests/test/state-monad.scm new file mode 100644 index 00000000..a4e28b78 --- /dev/null +++ b/tests/test/state-monad.scm @@ -0,0 +1,121 @@ +;;; Borrowed from guile-dns + +(define-module (test state-monad) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (hnh util state-monad) + ) + +(call-with-values (lambda () ((return 1) 2)) + (lambda (value state) + (test-equal "Return returns the value unmodified" 1 value) + (test-equal "Return also returns the state as a second value" 2 state))) + +(test-equal "Get returns the current state as primary value, while kepping the state" + '(state state) + (call-with-values (lambda () ((get) 'state)) list)) + +;; Return value of put untested, since it's undefined +(test-equal "Put replaces the old state with a new one, and return old one" + '(old-state new-state) + (call-with-values (lambda () ((put 'new-state) 'old-state)) + list)) + +(test-equal "A simple do is effectively a `values' call" + '(value initial-state) + (call-with-values (lambda () ((do (return 'value)) 'initial-state)) + list)) + +(test-equal "Let statement in do" + '(10 state) + (call-with-values (lambda () ((do x = 10 + (return x)) + 'state)) + list)) + +;; TODO let statement with multiple binds +;; (do let (a b) = (values 10 20) ...) + +(test-equal "Set and get through do, along with <- in do." + '(5 1) + (call-with-values (lambda () ((do old <- (get) + (put (1+ old)) + (return 5)) + 0)) + list)) + + + +(test-equal "<$> Updates stuff before being removed from the monad context" + '(11 10) + (call-with-values (lambda () + ((do x <- (<$> 1+ (get)) + (return x)) + 10)) + list)) + +(test-equal "Sequence should update the state accordingly" + 3 + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + (lambda (_ st) st))) + +(test-equal "Sequence should also act as map on the primary value" + '((0 1 2) 3) + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + list)) + +(test-equal "Get returns a single value when only a single value is in the state" + '(1 1) (call-with-values (lambda () ((get) 1)) + list)) + +(test-equal "Get returns a list of values when multiple items are in the state" + '((1 2 3) 1 2 3) + (call-with-values (lambda () ((get) 1 2 3)) + list)) + +(test-equal "Get with multiple values" + '((1 2) 1 2) + (call-with-values (lambda () ((get) 1 2)) + list)) + +(test-equal "Get with multiple values in do" + '((1 2) 1 2) + (call-with-values (lambda () + ((do (a b) <- (get) + (return (list a b))) + 1 2)) + list)) + +((do (put 0) + (with-temp-state + (list 10) + (do a <- (get) + (return (test-equal "Temporary state is set" + 10 a)) + (put 20))) + a <- (get) + (return (test-equal "Pre-temp state is restored" 0 a))) + 'init) + + +;; TODO test for do where the number of implicit arguments changes + +(test-equal "Something" 30 + ((do (with-temp-state + '(10 20) + ;; todo (lift +) + (do (a b) <- (get) + (return (+ a b))))) + 0 1)) diff --git a/tests/test/sxml-namespaced.scm b/tests/test/sxml-namespaced.scm new file mode 100644 index 00000000..55d52798 --- /dev/null +++ b/tests/test/sxml-namespaced.scm @@ -0,0 +1,170 @@ +(define-module (test sxml-namespaced) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (ice-9 match) + :use-module (sxml namespaced) + :use-module (hnh util state-monad) + ) + +;;; TODO tests with attributes + +(define (ns x) + (string->symbol (format #f "http://example.com/~a" x))) + +(define (namespaced-symbol ns symb) + (string->symbol (format #f "~a:~a" ns symb))) + + + +(test-group "XML constructor utility procedure" + (test-equal "3 args" + (make-xml-element 'tagname 'namespace 'attributes) + (xml 'namespace 'tagname 'attributes)) + + (test-equal "2 args" + (make-xml-element 'tagname 'namespace '()) + (xml 'namespace 'tagname)) + + (test-equal "1 args" + (make-xml-element 'tagname #f '()) + (xml 'tagname))) + + + +(test-group "xml->namespaced-sxml" + + (test-equal + `(*TOP* (,(xml 'tag))) + (xml->namespaced-sxml "<tag/>")) + + (test-equal + `(*TOP* (,(xml 'ns1 'tag))) + (xml->namespaced-sxml "<tag xmlns='ns1'/>")) + + (test-equal + `(*TOP* (,(xml 'ns2 'tag))) + (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'/>")) + + (test-equal + `(*TOP* (,(xml 'ns2 'tag) + (,(xml 'ns1 'tag)))) + (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'><tag/></x:tag>")) + + (test-equal "PI are passed directly" + `(*TOP* ,(make-pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"") + (,(xml 'tag))) + (xml->namespaced-sxml "<?xml encoding=\"utf-8\" version=\"1.0\"?><tag/>")) + + (test-equal "Document with whitespace in it" + `(*TOP* ,(make-pi-element 'xml "") + (,(xml 'root) + " " + (,(xml 'a)) + )) + (xml->namespaced-sxml "<?xml?><root> <a/></root>" + trim-whitespace?: #f)) + + ;; TODO is this expected? xml->sxml discards it. + (test-equal "Whitespace before root is kept" + `(*TOP* ,(make-pi-element 'xml "") + (,(xml 'root))) + (xml->namespaced-sxml "<?xml?> <root/>"))) + + + +;;; NOTE that sxml->namespaced-sxml currently ignores any existing xmlns +;;; attributes, since xml->sxml doesn't have those. +(test-group "sxml->namespaced-sxml" + (test-equal "Simplest" + `(,(xml 'a)) (sxml->namespaced-sxml '(a) '())) + (test-equal "With *TOP*" + `(*TOP* (,(xml 'a))) (sxml->namespaced-sxml '(*TOP* (a)) '())) + (test-equal "Simplest with namespace" + `(,(xml (ns 1) 'a)) + (sxml->namespaced-sxml '(x:a) + `((x . ,(ns 1))))) + (test-equal "With pi" + `(*TOP* ,(make-pi-element 'xml "test") + (,(xml 'a))) + (sxml->namespaced-sxml + `(*TOP* + (*PI* xml "test") + (a)) + '())) + (test-error "With unknown namespace" + 'missing-namespace + (sxml->namespaced-sxml '(x:a) '()))) + + + +(test-group "namespaced-sxml->*" + + ;; /namespaces is the most "primitive" one + (test-group "/namespaces" + (test-group "Without namespaces" + (call-with-values + (lambda () + (namespaced-sxml->sxml/namespaces + `(*TOP* + (,(xml 'a))))) + (lambda (tree namespaces) + (test-equal `(*TOP* (a)) tree) + (test-equal '() namespaces)))) + + (test-group "With namespaces" + (call-with-values + (lambda () + (namespaced-sxml->sxml/namespaces + `(*TOP* + (,(xml (ns 1) 'a) + (,(xml (ns 2) 'a)) + (,(xml 'a)))))) + (lambda (tree nss) + (test-eqv 2 (length nss)) + (test-equal + `(*TOP* + (,(namespaced-symbol (assoc-ref nss (ns 1)) 'a) + (,(namespaced-symbol (assoc-ref nss (ns 2)) 'a)) + (a))) + tree)))) + + (test-group "*PI*" + (call-with-values + (lambda () + (namespaced-sxml->sxml/namespaces + `(*TOP* + ,(make-pi-element 'xml "test") + (,(xml 'a))))) + (lambda (tree namespaces) + (test-equal '() namespaces) + (test-equal `(*TOP* (*PI* xml "test") + (a)) + tree))))) + + (test-group "namespaced-sxml->sxml" + (test-equal "Without namespaces" + '(*TOP* (a (@))) + (namespaced-sxml->sxml `(*TOP* (,(xml 'a))))) + + (test-group "With namespaces" + (match (namespaced-sxml->sxml `(*TOP* (,(xml (ns 1) 'a)))) + ;; (ns 1) hard coded to work with match + (`(*TOP* (,el (@ (,key "http://example.com/1")))) + (let ((el-pair (string-split (symbol->string el) #\:)) + (key-pair (string-split (symbol->string key) #\:))) + (test-equal "a" (cadr el-pair)) + (test-equal "xmlns" (car key-pair)) + (test-equal (car el-pair) (cadr key-pair)))) + (any + (test-assert (format #f "Match failed: ~s" any) #f)))))) + +;; (namespaced-sxml->xml) +;; Literal strings + + +(test-error "Namespaces x is missing, note error" + 'parser-error + (xml->namespaced-sxml "<x:a xmlns:y=\"http://example.com/1\"><x:b/></x:a>" + ; `((x . ,(ns 1))) + )) diff --git a/tests/test/vcomponent-control.scm b/tests/test/vcomponent-control.scm index f408c8b4..6ab38996 100644 --- a/tests/test/vcomponent-control.scm +++ b/tests/test/vcomponent-control.scm @@ -5,32 +5,32 @@ (define-module (test vcomponent-control) :use-module (srfi srfi-64) :use-module (srfi srfi-88) + :use-module ((vcomponent create)) :use-module ((vcomponent util control) :select (with-replaced-properties)) :use-module ((vcomponent formats ical parse) :select (parse-calendar)) :use-module ((vcomponent base) :select (prop))) -(define ev - (call-with-input-string - "BEGIN:DUMMY\nX-KEY:value\nEND:DUMMY" - parse-calendar)) +(define ev (vcomponent 'DUMMY x-key: "value")) -;; Test that temoraries are set and restored -(test-equal "value" (prop ev 'X-KEY)) +(test-group "With replaced properties" + ;; Test that temoraries are set and restored + (test-equal "value" (prop ev 'X-KEY)) -(with-replaced-properties - (ev (X-KEY "other")) - (test-equal "other" (prop ev 'X-KEY))) + (with-replaced-properties + (ev (X-KEY "other")) + (test-equal "other" (prop ev 'X-KEY))) -(test-equal "value" (prop ev 'X-KEY)) + (test-equal "value" (prop ev 'X-KEY))) ;; Test that they are restored on non-local exit -(catch #t - (lambda () - (with-replaced-properties - (ev (X-KEY "other")) - (throw 'any))) - (lambda _ (test-equal "value" (prop ev 'X-KEY)))) +(test-group "With replaced properties when throwing" + (catch #t + (lambda () + (with-replaced-properties + (ev (X-KEY "other")) + (throw 'any))) + (lambda _ (test-equal "value" (prop ev 'X-KEY))))) diff --git a/tests/test/vcomponent-datetime.scm b/tests/test/vcomponent-datetime.scm index 073a70ae..49d1711f 100644 --- a/tests/test/vcomponent-datetime.scm +++ b/tests/test/vcomponent-datetime.scm @@ -8,15 +8,12 @@ :use-module (srfi srfi-88) :use-module ((datetime) :select (date time datetime)) :use-module ((vcomponent datetime) :select (event-length/clamped)) - :use-module ((vcomponent formats ical parse) :select (parse-calendar))) + :use-module ((vcomponent create) :select (vevent))) (define ev - (call-with-input-string - "BEGIN:VEVENT -DTSTART:20200329T170000 -DTEND:20200401T100000 -END:VEVENT" - parse-calendar)) + (vevent + dtstart: #2020-03-29T17:00:00 + dtend: #2020-04-01T10:00:00)) ;; |-----------------| test interval @@ -31,12 +28,9 @@ END:VEVENT" ev)) (define utc-ev - (call-with-input-string - "BEGIN:VEVENT -DTSTART:20200329T150000Z -DTEND:20200401T080000Z -END:VEVENT" - parse-calendar)) + (vevent + dtstart: #2020-03-29T15:00:00Z + dtend: #2020-04-01T08:00:00Z)) (test-equal "Correct clamping UTC" diff --git a/tests/test/vcomponent.scm b/tests/test/vcomponent.scm index 68715462..bdaefa95 100644 --- a/tests/test/vcomponent.scm +++ b/tests/test/vcomponent.scm @@ -1,30 +1,103 @@ ;;; Commentary: -;; Test that vcomponent parsing works at all. +;; Test base functionallity of vcomponent structures. ;;; Code: (define-module (test vcomponent) + :use-module (srfi srfi-17) :use-module (srfi srfi-64) :use-module (srfi srfi-88) - :use-module ((vcomponent base) - :select (prop make-vcomponent add-child! remove-child! - children)) - :use-module ((vcomponent formats ical parse) - :select (parse-calendar))) + :use-module (hnh util table) + :use-module (datetime) + :use-module (vcomponent base)) + + + (define ev - (call-with-input-string - "BEGIN:DUMMY\nX-KEY:value\nEND:DUMMY" - parse-calendar)) + (prop (vcomponent type: 'DUMMY) + 'X-KEY "value")) -(test-assert (eq? #f (prop ev 'MISSING))) +(test-eqv "Non-existant properties return #f" + #f (prop ev 'MISSING)) -(test-assert (prop ev 'X-KEY)) +(test-assert "Existing property is non-false" + (prop ev 'X-KEY)) -(test-equal "value" (prop ev 'X-KEY)) +(test-equal "Getting value of existing property" + "value" (prop ev 'X-KEY)) -(define calendar (make-vcomponent 'VCALENDAR)) +(define calendar (add-child (vcomponent type: 'VCALENDAR) + ev)) -(add-child! calendar ev) (test-equal 1 (length (children calendar))) -(remove-child! calendar ev) -(test-equal 0 (length (children calendar))) + +;;; TODO remove child +;; (abandon! calendar ev) +;; (test-equal 0 (length (children calendar))) + + + +(define vline* + (vline + key: 'DTSTART + vline-value: #2020-01-02 + vline-parameters: (alist->table + '((VALUE . "DATE"))) + vline-source: "DTSTART;VALUE=DATE:2020-01-02")) + +(test-group "vline" + (test-assert "Type check works as expected" + (vline? vline*))) + +(define vcomponent* + (vcomponent type: 'VEVENT)) + +(test-assert "Type check works as expected" + (vcomponent? vcomponent*)) + +(define child + (vcomponent type: 'CHILD)) + + +(test-eqv + "An added component extends length" + 1 (length (children (add-child vcomponent* child)))) + +(test-eqv + "But the source isn't modified" + 0 (length (children vcomponent*))) + +(test-equal "Setting property" + (list (list 'KEY (vline key: 'KEY vline-value: "Value"))) + (properties + (prop vcomponent* 'KEY "Value"))) + +(let ((vl (vline key: 'KEY vline-value: "Value"))) + (test-equal "Setting property vline" + (list (list 'KEY vl)) + (properties + (prop* vcomponent* 'KEY vl)))) + +(test-equal "Set properties test" + '(K1 K2) + (map car + (properties + (apply set-properties + vcomponent* + `((K1 . "V1") + (K2 . "V2")))))) + +;; remove-property + +;; extract extract* + + +;; remove-parameter +;; value +;; param + +;; parameters +;; properties + +;; x-property? +;; internal-field? diff --git a/tests/test/webdav-file.scm b/tests/test/webdav-file.scm new file mode 100644 index 00000000..4096016b --- /dev/null +++ b/tests/test/webdav-file.scm @@ -0,0 +1,53 @@ +(define-module (test webdav-file) + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (hnh util) + :use-module (hnh util path) + :use-module (ice-9 ftw) + :use-module (ice-9 rdelim) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module (calp webdav resource file) + ) + +;;; Commentary: +;;; Tests the specifics of the file backed webdav resource objects. +;;; Code: + + +;;; TODO general helper procedure for this +(define test-root (mkdtemp (string-copy "/tmp/calp-test-XXXXXX"))) + +(define root-resource (make <file-resource> + root: test-root)) + + +(test-group "File resource collection" + (add-collection! root-resource "subdir") + (test-eqv "Collection correctly added" + 'directory (-> (path-append test-root "subdir") + stat stat:type) )) + + + +;;; TODO this fails, sice <file-resource> doesn't override add-resource! +;;; <file-resources>'s add resource must at least update root path path of the +;;; child resource, and possibly also touch the file (so ctime gets set). +(test-group "File resource with content" + (let ((fname "file.txt") + (s "Hello, World!\n")) + (add-resource! root-resource fname s) + (let ((p (path-append test-root fname))) + (test-eqv "File correctly added" + 'regular (-> p stat stat:type)) + (test-equal "Expected content was written" + s + (with-input-from-file p + (lambda () (read-delimited ""))) + )))) + + + +(test-group "Copy file" + 'TODO) diff --git a/tests/test/webdav-server.scm b/tests/test/webdav-server.scm new file mode 100644 index 00000000..67747de7 --- /dev/null +++ b/tests/test/webdav-server.scm @@ -0,0 +1,351 @@ +(define-module (test webdav-server) + ;; :use-module (srfi srfi-1) + ;; :use-module (ice-9 threads) + + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp server webdav) + :use-module (calp webdav resource) + :use-module ((calp webdav property) :select (propstat)) + :use-module (calp webdav resource virtual) + :use-module (calp namespaces) + :use-module (oop goops) + :use-module (web request) + :use-module (web response) + :use-module (web uri) + :use-module (sxml simple) + :use-module (sxml xpath) + :use-module (sxml namespaced) + :use-module (hnh util) + ) + +;;; Commentary: +;;; Tests that handlers for all HTTP Methods works correctly. +;;; Note that these tests don't have as goal to check that resources and +;;; properties work correctly. See (test webdav) and (test webdav-tree) for that. +;;; +;;; The namespaces http://ns.example.com/properties is intentionally given +;;; different prefixes everywhere, to ensure that namespaces are handled correctly. +;;; Code: + +(define prop-ns (string->symbol "http://ns.example.com/properties")) + +(root-resource (make <virtual-resource> name: "*root*")) +(add-resource! (root-resource) "a" "Contents of A") +(add-resource! (root-resource) "b" "Contents of B") + +;;; Connect output of one procedure to input of another +;;; Both producer and consumer should take exactly one port as argument +(define (connect producer consumer) + ;; (let ((in out (car+cdr (pipe)))) + ;; (let ((thread (begin-thread (consumer in)))) + ;; (producer out) + ;; (join-thread thread))) + + (call-with-input-string + (call-with-output-string producer) + consumer)) + +(define (xml->sxml* port) + (xml->sxml port namespaces: `((d . ,(symbol->string webdav)) + (y . ,(symbol->string prop-ns))))) + + + +(test-group "run-propfind" + (test-group "Working, depth 0" + (let* ((request (build-request + (string->uri "http://localhost/") + method: 'PROPFIND + headers: '((depth . 0)) + validate-headers?: #f)) + (head body (run-propfind '() request #f))) + (test-equal 207 (response-code head)) + (test-equal '(application/xml) + (response-content-type head)) + (test-assert (procedure? body)) + (let ((body* (connect body xml->sxml*))) + ;; Arbitrarily chosen resource + (test-equal "Resource gets returned as expected" + '((d:resourcetype (d:collection))) + ((sxpath '(// d:response + (d:propstat (// d:status (equal? "HTTP/1.1 200 OK"))) + // d:resourcetype)) + body*))))) + + (test-group "Depth: infinity" + (let* ((request (build-request + (string->uri "http://localhost/") + method: 'PROPFIND + headers: '((depth . infinity)) + validate-headers?: #f)) + (head body (run-propfind '() request #f))) + (test-equal 207 (response-code head)) + (test-equal '(application/xml) (response-content-type head)) + (test-assert (procedure? body)) + (let ((body* (connect body xml->sxml*))) + (test-equal + '("/" "/a" "/b") + (sort* ((sxpath '(// d:href *text*)) body*) + string<))))) + + (test-group "With body" + (let ((request (build-request (string->uri "http://localhost/") + method: 'PROPFIND + headers: '((depth . 0)) + validate-headers?: #f)) + (request-body "<?xml version=\"1.0\" encoding=\"utf-8\"?> +<propfind xmlns=\"DAV:\"> + <prop><resourcetype/></prop> +</propfind>")) + (let ((head body (run-propfind '() request request-body))) + (test-equal 207 (response-code head)) + (test-equal '(application/xml) (response-content-type head)) + (test-assert (procedure? body)) + (let ((body* (connect body xml->sxml*))) + (test-equal "We only get what we ask for" + '((d:prop (d:resourcetype (d:collection)))) + ((sxpath '(// d:response + (d:propstat (// d:status (equal? "HTTP/1.1 200 OK"))) + // d:prop)) + body*))))))) + + + +(test-group "run-proppatch" + (let ((request (build-request (string->uri "http://localhost/a") + method: 'PROPPATCH)) + (request-body (format #f "<?xml version=\"1.0\" encoding=\"utf-8\"?> +<propertyupdate xmlns=\"DAV:\" xmlns:x=\"~a\"> + <set> + <prop> + <displayname>New Displayname</displayname> + <x:test><x:content/></x:test> + </prop> + </set> + <!-- TODO test remove? --> +</propertyupdate>" prop-ns))) + (let ((response body (run-proppatch '("a") request request-body))) + (test-equal 207 (response-code response)) + (test-equal '(application/xml) (response-content-type response)) + (test-assert (procedure? body)) + ;; Commit the changes + (call-with-output-string body) + )) + + (let ((response body (run-propfind + '("a") + (build-request (string->uri "http://localhost/a") + method: 'PROPFIND + headers: '((depth . 0)) + validate-headers?: #f) + (format #f "<?xml version=\"1.0\" encoding=\"utf-8\"?> +<propfind xmlns=\"DAV:\" xmlns:z=\"~a\"> + <prop> + <displayname/> + <z:test/> + </prop> +</propfind>" prop-ns)))) + (test-equal 207 (response-code response)) + (test-equal '(application/xml) (response-content-type response)) + (test-assert (procedure? body)) + + ;; (format (current-error-port) "Here~%") + ;; ;; The crash is after here + ;; (body (current-error-port)) + + (let* ((body* (connect body xml->sxml*)) + (properties ((sxpath '(// d:response + (d:propstat (// d:status (equal? "HTTP/1.1 200 OK"))))) + body*))) + ;; ((@ (ice-9 format) format) (current-error-port) "Properties: ~y~%" properties) + (test-equal "Native active property is properly updated" + '("New Displayname") + ((sxpath '(// d:displayname *text*)) properties)) + (test-equal "Custom property is correctly stored and preserved" + '((y:test (y:content))) + ((sxpath '(// y:test)) properties)))) + + ;; TODO test proppatch atomicity + ) + + + +(test-group "run-options" + (let ((head body (run-options #f #f))) + (test-equal "options head" + (build-response + code: 200 + headers: `((dav . (1)) + (allow . (GET HEAD PUT MKCOL PROPFIND OPTIONS DELETE COPY MOVE)))) + head) + (test-equal "options body" + "" body))) + + + +(test-group "run-get" + (let ((head body (run-get '("a") + (build-request + (string->uri "http://localhost/a") + method: 'GET) + 'GET))) + (test-equal "Contents of A" body))) + + + +(test-group "run-put" + (test-group "Update existing resource" + (run-put '("a") + (build-request (string->uri "http://localhost/a") + method: 'PUT + port: (open-output-string)) + "New Contents of A") + + (let ((head body (run-get '("a") + (build-request + (string->uri "http://localhost/a") + method: 'GET) + 'GET))) + (test-equal "Put updates subsequent gets" + "New Contents of A" body))) + + (test-group "Create new resource" + (run-put '("c") + (build-request (string->uri "http://localhost/c") + method: 'PUT + port: (open-output-string)) + "Created Resource C") + (let ((head body (run-get '("c") + (build-request + (string->uri "http://localhost/c") + method: 'GET) + 'GET))) + (test-equal "Put creates new resources" + "Created Resource C" body)))) + + + +;;; Run DELETE +(test-group "run-delete" + 'TODO) + + + + +(test-group "run-mkcol" + (run-mkcol '("a" "b") + (build-request (string->uri "http://localhost/a/b") + method: 'MKCOL) + "") + (let* ((request (build-request + (string->uri "http://localhost/") + method: 'PROPFIND + headers: '((depth . infinity)) + validate-headers?: #f)) + (head body (run-propfind '() request #f))) + (test-equal 207 (response-code head)) + (test-equal '(application/xml) (response-content-type head)) + (test-assert (procedure? body)) + (let ((body* (connect body xml->sxml*))) + (test-equal "Check that all created resources now exists" + '("/" "/a" "/a/b" "/b" "/c") + (sort* ((sxpath '(// d:href *text*)) body*) + string<))))) + + +;;; TODO test MKCOL indempotence + + + +;;; Run COPY +(test-group "run-copy" + (parameterize ((root-resource (make <virtual-resource> name: "*root*"))) + (add-resource! (root-resource) "a" "Content of A") + (let ((a (lookup-resource (root-resource) '("a")))) + (set-property! a `(,(xml prop-ns 'test) "prop-value")) + ;; Extra child added to ensure deep copy works + (add-resource! a "d" "Content of d")) + + (test-group "cp /a /c" + (let ((response _ + (run-copy '("a") + (build-request + (string->uri "http://example.com/a") + headers: `((destination + . ,(string->uri "http://example.com/c"))))))) + ;; Created + (test-eqv "Resource was reported created" + 201 (response-code response))) + + (let ((c (lookup-resource (root-resource) '("c")))) + (test-assert "New resource present in tree" c) + (test-equal "Content was correctly copied" + "Content of A" (content c)) + (test-equal "Property was correctly copied" + (propstat 200 + (list `(,(xml prop-ns 'test) + "prop-value"))) + (get-property c (xml prop-ns 'test))))) + + (test-group "cp --no-clobber /c /a" + (let ((response _ + (run-copy '("c") + (build-request + (string->uri "http://example.com/c") + headers: `((destination + . ,(string->uri "http://example.com/a")) + (overwrite . #f)))))) + ;; collision + (test-eqv "Resource collision was reported" + 412 (response-code response)))) + + ;; Copy recursive collection, and onto child of self. + (test-group "cp -r / /c" + (let ((response _ + (run-copy '() + (build-request + (string->uri "http://example.com/") + headers: `((destination . ,(string->uri "http://example.com/c"))))))) + (test-eqv "Check that reported replaced" + 204 (response-code response)) + (test-equal "Check that recursive resources where created" + '("/" "/a" "/a/d" "/c" + ;; New resources. Note that /c/c doesn't create an infinite loop + "/c/a" "/c/a/d" "/c/c") + (map car + (sort* (map (lambda (p) (cons (href->string (car p)) (cdr p))) + (all-resources-under (root-resource) '())) + string< car))) + + ;; TODO we should also check that /c is a copy of the root resource, + ;; instead of the old /c resource. + ;; Do this by setting some properties + )))) + + + +;;; Run MOVE +(test-group "run-move" + (parameterize ((root-resource (make <virtual-resource> name: "*root*"))) + (add-resource! (root-resource) "a" "Content of A") + (let ((a (lookup-resource (root-resource) '("a")))) + (set-property! a `(,(xml prop-ns 'test) "prop-value"))) + + (test-group "mv /a /c" + (let ((response _ + (run-move '("a") + (build-request + (string->uri "http://example.com/a") + headers: `((destination + . ,(string->uri "http://example.com/c"))))))) + ;; Created + (test-eqv "Resource was reported created" + 201 (response-code response)) + ;; TODO check that old resource is gone + )))) + + + +;;; Run REPORT diff --git a/tests/test/webdav-tree.scm b/tests/test/webdav-tree.scm new file mode 100644 index 00000000..5c2a6a9b --- /dev/null +++ b/tests/test/webdav-tree.scm @@ -0,0 +1,89 @@ +(define-module (test webdav-tree) + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp webdav resource) + :use-module (calp webdav resource virtual) + :use-module (calp webdav resource file) + :use-module (oop goops) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module ((hnh util) :select (sort*)) + :use-module (hnh util path) + ) + +(define* (pretty-print-tree tree + optional: (formatter (lambda (el) (write el) (newline))) + key: (depth 0)) + (cond ((null? tree) 'noop) + ((pair? tree) + (display (make-string (* depth 2) #\space)) (formatter (car tree)) + (for-each (lambda (el) (pretty-print-tree el formatter depth: (+ depth 1))) + (cdr tree))) + (else (formatter tree)))) + +(define-method (resource-tree (self <resource>)) + (cons self + (map resource-tree (children self)))) + + + +(define dir (mkdtemp (string-copy "/tmp/webdav-tree-XXXXXX"))) +(with-output-to-file (path-append dir "greeting") + (lambda () (display "Hello, World!\n"))) + +(define root-resource (make <virtual-resource> + name: "*root*")) + +(define virtual-resource (make <virtual-resource> + name: "virtual" + content: (string->bytevector "I'm Virtual!" (native-transcoder)))) + +(define file-tree (make <file-resource> + root: dir + name: "files")) + +(mount-resource! root-resource file-tree) +(mount-resource! root-resource virtual-resource) + +(test-equal "All resources in tree, along with href items" + (list (cons '() root-resource) + (cons '("files") file-tree) + (cons '("files" "greeting") (car (children file-tree))) + (cons '("virtual") virtual-resource)) + (sort* (all-resources-under root-resource) string< (compose string-concatenate car))) + + + +;; (pretty-print-tree (resource-tree root-resource)) + + + +;; (test-equal '("") (href root-resource) ) ; / +;; ;; (test-equal '("" "virtual") (href virtual-resource)) ; /virtual & /virtual/ +;; (test-equal '("virtual") (href virtual-resource)) ; /virtual & /virtual/ +;; ;; (test-equal '("" "files") (href file-tree)) ; /files & /files/ +;; (test-equal '("files") (href file-tree)) ; /files & /files/ + +(test-eqv "Correct amount of children are mounted" + 2 (length (children root-resource))) + +(test-eq "Lookup root" + root-resource (lookup-resource root-resource '())) + +(test-eq "Lookup of mount works (virtual)" + virtual-resource (lookup-resource root-resource '("virtual"))) +(test-eq "Lookup of mount works (files)" + file-tree (lookup-resource root-resource '("files"))) + +;; (test-equal "File resource works as expected" +;; "/home/hugo/tmp" +;; (path file-tree)) + +(let ((resource (lookup-resource root-resource (string->href "/files/greeting")))) + (test-assert (resource? resource)) + (test-assert (file-resource? resource)) + ;; (test-equal "/files/greeting" (href->string (href resource))) + (test-equal "Hello, World!\n" (bytevector->string (content resource) (native-transcoder))) + ) + diff --git a/tests/test/webdav-util.scm b/tests/test/webdav-util.scm new file mode 100644 index 00000000..5c89cf6c --- /dev/null +++ b/tests/test/webdav-util.scm @@ -0,0 +1,29 @@ +(define-module (test webdav-util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp webdav resource base)) + +(test-group "string->href" + (test-equal "Root path becomes null" + '() (string->href "/")) + (test-equal "Trailing slashes are ignored" + '("a" "b") (string->href "/a/b/"))) + +(test-group "href->string" + (test-equal "Null case becomes root path" + "/" (href->string '())) + (test-equal "Trailing slashes are not added" + "/a/b" (href->string '("a" "b")))) + +(test-group "href-relative" + (test-equal '("a" "b") (href-relative '() '("a" "b"))) + (test-equal '("b") (href-relative '("a") '("a" "b"))) + (test-equal '() (href-relative '("a" "b") '("a" "b"))) + + (test-error 'misc-error + (href-relative '("c") '("a" "b"))) + + (test-error 'misc-error + (href-relative '("c") '()))) diff --git a/tests/test/webdav.scm b/tests/test/webdav.scm new file mode 100644 index 00000000..0962a89e --- /dev/null +++ b/tests/test/webdav.scm @@ -0,0 +1,353 @@ +(define-module (test webdav) + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (srfi srfi-1) + :use-module (sxml namespaced) + :use-module (oop goops) + :use-module (calp namespaces) + :use-module ((hnh util) :select (sort*)) + :use-module (datetime) + + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module (calp webdav resource) + :use-module (calp webdav resource virtual) + ) + +;;; NOTE these tests don't check that XML namespaces work correctly, but only as +;;; far as not checking that the correct namespace is choosen. They should fail if +;;; namespacing gets completely broken. + +;;; TODO tests for a missing resource? + +(define (swap p) (xcons (car p) (cdr p))) + +(define dt #2010-11-12T13:14:15) + +(define resource (make <virtual-resource> + ;; local-path: '("") + name: "*root" + content: #vu8(1 2 3 4) + creation-time: dt)) + +(define (sort-propstats propstats) + (map + (lambda (propstat) + (make-propstat (propstat-status-code propstat) + (sort* (propstat-property propstat) + string< (compose symbol->string xml-element-tagname car)) + (propstat-error propstat) + (propstat-response-description propstat))) + (sort* propstats < propstat-status-code)) + ) + +;; (test-equal "/" (href->string (href resource))) +(test-equal "Basic propstat" + (propstat 200 (list (list (xml webdav 'getcontentlength) 4))) + (getcontentlength resource)) + + +(define (sort-symbols symbs) + (sort* symbs string<=? symbol->string)) + + + +;;; NOTE propstat's return order isn't stable, making this test possibly fail +(let ((ps (list (propstat 200 (list `(,(xml webdav 'displayname) "Displayname"))) + (propstat 200 (list `(,(xml webdav 'getcontenttype) "text/plain")))))) + (test-equal "Propstat merger" + (list (propstat 200 + (list (list (xml webdav 'getcontenttype) "text/plain") + (list (xml webdav 'displayname) "Displayname")))) + (merge-propstats ps))) + + + +(test-group "All live properties" + (let ((props (live-properties resource))) + (test-assert (list? props)) + (for-each (lambda (pair) + ;; (test-assert (xml-element? (car pair))) + (test-assert (live-property? (cdr pair))) + (test-assert (procedure? (property-getter (cdr pair)))) + (test-assert (procedure? (property-setter-generator (cdr pair))))) + props))) + +(test-group "\"All\" live properties" + (let ((most (propfind-most-live-properties resource))) + (test-equal "Correct amount of keys" 10 (length most)) + (for-each (lambda (propstat) + (test-assert "Propstat is propstat" (propstat? propstat)) + (test-equal (format #f "Propstat well formed: ~a" (propstat-property propstat)) + 1 (length (propstat-property propstat))) + (test-assert "Propstat child is xml" + (xml-element? (caar (propstat-property propstat))))) + most) + + (test-equal "Correct keys" + '(creationdate displayname getcontentlanguage getcontentlength + getcontenttype getetag getlastmodified + lockdiscovery resourcetype supportedlock) + (sort-symbols (map (compose xml-element-tagname caar propstat-property) most))))) + + + +(define ns1 (string->symbol "http://example.com/namespace")) + +(set-dead-property! resource `(,(xml ns1 'test) "Content")) + +(test-equal "Get dead property" + (propstat 200 (list (list (xml ns1 'test) "Content"))) + (get-dead-property resource (xml ns1 'test))) + +(test-equal "Get live property" + (propstat 404 (list (list (xml ns1 'test)))) + (get-live-property resource (xml ns1 'test))) + +(test-group "Dead properties" + (test-equal "Existing property" + (propstat 200 (list (list (xml ns1 'test) "Content"))) + (get-property resource (xml ns1 'test))) + + (test-equal "Missing property" + (propstat 404 (list (list (xml ns1 'test2)))) + (get-property resource (xml ns1 'test2))) + + (test-equal "All dead properties" + (list (propstat 200 (list (list (xml ns1 'test) "Content")))) + (propfind-all-dead-properties resource))) + +(test-group "Live Properties" + + ;; TODO these tests were written when displayname always returned 200, but have since changed to test for 404. + ;; Change to another property which return 200 + (test-equal "Existing live property (through get-live-property)" + (propstat 404 `((,(xml webdav 'displayname)))) + (get-live-property resource (xml webdav 'displayname))) + + (test-equal "Existing live property (thrtough get-property)" + (propstat 404 `((,(xml webdav 'displayname)))) + (get-property resource (xml webdav 'displayname))) + ) + +(test-equal "propfind-selected-properties" + (list (propstat 404 `((,(xml webdav 'displayname))))) + (propfind-selected-properties resource (list (xml webdav 'displayname)))) + +(test-group "parse-propfind" + (test-group "propname" + (let ((props (parse-propfind `(,(xml webdav 'propfind) + (,(xml webdav 'propname))) + resource))) + + + (test-group "Propfind should NEVER fail for an existing resource" + (test-equal 1 (length props)) + (test-equal 200 (propstat-status-code (car props)))) + + (test-assert "Propstat objects are returned" (propstat? (car props))) + (for-each (lambda (el) + (test-assert "Base is list" (list? el)) + (test-eqv "List only contains head el" 1 (length el)) + #; + (test-assert (format #f "Head is an xml tag: ~a" el) + (xml-element? (car el)))) + (propstat-property (car props))) + + #; + (test-equal "Correct property keys" + (sort-symbols (cons* 'test 'is-virtual webdav-keys)) + (sort-symbols (map (compose xml-element-tagname car) + (propstat-property (car props))))) + + (test-group "No property should contain any data" + (for-each (lambda (el) + (test-eqv (format #f "Propname property: ~s" el) + 1 (length el))) + (propstat-property (car props)))))) + + + (test-group "direct property list" + (let ((props (parse-propfind `((xml webdav 'propfind) + (,(xml webdav 'prop) + (,(xml webdav 'displayname)))) + resource))) + (test-equal "Simple lookup" + (list (propstat 404 (list (list (xml webdav 'displayname) + )))) + props))) + + ;; TODO test that calendar properties are reported by propname + ;; TODO test that non-native caldav propreties aren't reported by allprop + + (test-group "allprop" + (let ((props (parse-propfind `(,(xml webdav 'propfind) + (,(xml webdav 'allprop))) + resource))) + + + (test-equal "Propfind result" + (list + (propstat 200 + (list (list (xml webdav 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + (list (xml webdav 'getcontentlength) + 4) + (list (xml webdav 'getcontenttype) + "application/binary") + (list (xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + (list (xml webdav 'lockdiscovery) '()) + (list (xml webdav 'resourcetype) + ; (list (xml webdav 'collection)) + ) + (list (xml webdav 'supportedlock) '()) + (list (xml ns1 'test) "Content") + )) + (propstat 404 (list (list (xml webdav 'displayname)) + (list (xml webdav 'getcontentlanguage)))) + (propstat 501 + (list (list (xml webdav 'getetag)) + ))) + (sort-propstats props)))) + + + (test-group "allprop with include" + (let ((props (parse-propfind `((xml webdav 'propfind) + (,(xml webdav 'allprop)) + (,(xml webdav 'include))) + resource))) + + + (test-equal "Include NOTHING" + (list + (propstat 200 + (list (list (xml webdav 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + (list (xml webdav 'getcontentlength) + 4) + (list (xml webdav 'getcontenttype) + "application/binary") + (list (xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + (list (xml webdav 'lockdiscovery) '()) + (list (xml webdav 'resourcetype) + ; (list (xml webdav 'collection)) + ) + (list (xml webdav 'supportedlock) '()) + (list (xml ns1 'test) "Content") + )) + (propstat 404 (list (list (xml webdav 'displayname)) + (list (xml webdav 'getcontentlanguage)))) + (propstat 501 + (list (list (xml webdav 'getetag)) + ))) + (sort-propstats props))) + + + (let ((props (parse-propfind `(,(xml webdav 'propfind) + (,(xml webdav 'allprop)) + (,(xml webdav 'include) + (,(xml virtual-ns 'isvirtual)))) + resource))) + + (test-equal "Include isvirtual" + (list + (propstat 200 + (list (list (xml webdav 'creationdate) (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + (list (xml webdav 'getcontentlength) 4) + (list (xml webdav 'getcontenttype) "application/binary") + (list (xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") + (list (xml virtual-ns 'isvirtual) "true") + (list (xml webdav 'lockdiscovery) '()) + (list (xml webdav 'resourcetype)) + (list (xml webdav 'supportedlock) '()) + (list (xml ns1 'test) "Content") + )) + (propstat 404 (list (list (xml webdav 'displayname)) + (list (xml webdav 'getcontentlanguage)))) + (propstat 501 + (list (list (xml webdav 'getetag)) + ))) + (sort-propstats props))))) + + + + +;;; Setting properties + +;;; We already use set-dead-property! above, but for testing get we need set, +;;; and for testing set we need get, and get is more independent, so we start there. + + + +(test-group "Propstat -> namespaced sxml" + (test-equal "Simple" + `(,(xml webdav 'propstat) + (,(xml webdav 'prop) (,(xml webdav 'displayname) "test")) + (,(xml webdav 'status) "HTTP/1.1 200 OK")) + (propstat->namespaced-sxml (propstat 200 `((,(xml webdav 'displayname) "test")) ))) + + ;; TODO populated error field + + (test-equal "With response description" + `(,(xml webdav 'propstat) + (,(xml webdav 'prop) (,(xml webdav 'displayname) "test")) + (,(xml webdav 'status) "HTTP/1.1 403 Forbidden") + (,(xml webdav 'responsedescription) "Try logging in")) + (propstat->namespaced-sxml (propstat 403 `((,(xml webdav 'displayname) "test")) + responsedescription: "Try logging in")))) + + + + +;;; TODO what am I doing here? + +(test-equal + (list (propstat 200 + `((,(xml webdav 'getcontentlength) 4) + (,(xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") + (,(xml webdav 'resourcetype)))) + (propstat 404 + `((,(xml webdav 'checked-in)) + (,(xml webdav 'checked-out)) + (,(xml (string->symbol "http://apache.org/dav/props/") 'executable))))) + (let ((request (xml->namespaced-sxml + "<?xml version=\"1.0\" encoding=\"utf-8\"?> +<propfind xmlns=\"DAV:\"> + <prop> + <getcontentlength/> + <getlastmodified/> + <executable xmlns=\"http://apache.org/dav/props/\"/> + <resourcetype/> + <checked-in/> + <checked-out/> + </prop> +</propfind>"))) + + (sort-propstats (parse-propfind (caddr request) resource)))) + + + +(test-group "lookup-resource" + (let* ((root (make <virtual-resource> name: "*root*")) + (a (add-collection! root "a")) + (b (add-collection! a "b")) + (c (add-resource! b "c" "~~Nothing~~"))) + (test-eq "Lookup root" + root (lookup-resource root '())) + (test-eq "Lookup direct child" + a (lookup-resource root '("a"))) + (test-eq "Lookup deep child" + c (lookup-resource root '("a" "b" "c"))) + (test-assert "Lookup missing" + (not (lookup-resource root '("a" "d" "c")))))) + + + + +(test-group "mkcol" + (let ((root (make <virtual-resource> name: "*root*"))) + (add-collection! root "child") + (test-eqv "Child got added" 1 (length (children root))))) diff --git a/tests/test/xcal.scm b/tests/test/xcal.scm deleted file mode 100644 index 48d43c59..00000000 --- a/tests/test/xcal.scm +++ /dev/null @@ -1,58 +0,0 @@ -;;; Commentary: -;; Basic tests of xcal convertion. -;; Currently only checks that events survive a round trip. -;;; Code: - -(define-module (test xcal) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((vcomponent formats xcal parse) - :select (sxcal->vcomponent)) - :use-module ((vcomponent formats xcal output) - :select (vcomponent->sxcal)) - :use-module ((vcomponent formats ical parse) - :select (parse-calendar)) - :use-module ((hnh util) :select (->)) - :use-module ((vcomponent base) - :select (parameters prop* children))) - -;;; Some different types, same parameters - -(define ev - (call-with-input-string - "BEGIN:VCALENDAR -VERSION:2.0 -PRODID:-//calparse-test -BEGIN:VEVENT -SUMMARY:Test event -DTSTART;TZID=Europe/Stockholm:20200625T133000 -DTEND:20200625T143000Z -DTSTAMP:20200609T131418Z -UID:1 -SEQUENCE:0 -CREATED:20200609T081725Z -DESCRIPTION:Short description -LAST-MODIFIED:20200609T081725Z -STATUS;X-TEST-PARAM=10:CONFIRMED -TRANSP:OPAQUE -END:VEVENT -END:VCALENDAR" - parse-calendar)) - -(define twice-converted - (-> ev vcomponent->sxcal sxcal->vcomponent)) - -;;; NOTE both these tests may fail since neither properties nor parameters are ordered sorted. - -(test-equal - "c->x & c->x->c->x" - (vcomponent->sxcal ev) - (vcomponent->sxcal twice-converted)) - -(test-equal - "xcal parameters" - '((X-TEST-PARAM "10")) - (parameters - (prop* (car (children twice-converted)) 'STATUS))) - - |