diff options
Diffstat (limited to 'tests')
65 files changed, 4198 insertions, 571 deletions
diff --git a/tests/formats/README.md b/tests/formats/README.md new file mode 100644 index 00000000..b17bd866 --- /dev/null +++ b/tests/formats/README.md @@ -0,0 +1,9 @@ +Serialization and deserialization formats +========================================= + +`test.scm` runs every other test. + +xcal +---- + +The program handles xml trees with a default namespace fine, but diff does not. diff --git a/tests/formats/event.ics b/tests/formats/event.ics new file mode 100644 index 00000000..5b578627 --- /dev/null +++ b/tests/formats/event.ics @@ -0,0 +1,27 @@ +BEGIN:VCALENDAR
+PRODID:-//PIMUTILS.ORG//NONSGML khal / icalendar //EN
+VERSION:2.0
+BEGIN:VTIMEZONE
+TZID:Europe/Stockholm
+BEGIN:DAYLIGHT
+DTSTART;VALUE=DATE-TIME:20180325T030000
+TZNAME:CEST
+TZOFFSETFROM:+0100
+TZOFFSETTO:+0200
+END:DAYLIGHT
+BEGIN:STANDARD
+DTSTART;VALUE=DATE-TIME:20181028T020000
+TZNAME:CET
+TZOFFSETFROM:+0200
+TZOFFSETTO:+0100
+END:STANDARD
+END:VTIMEZONE
+BEGIN:VEVENT
+DTEND;TZID=Europe/Stockholm;VALUE=DATE-TIME:20180907T180000
+DTSTAMP;VALUE=DATE-TIME:20180907T154223Z
+DTSTART;TZID=Europe/Stockholm;VALUE=DATE-TIME:20180907T170000
+SEQUENCE:0
+SUMMARY:Backhäfv
+UID:ZSGUP6BTM52UV42SEWBICHSS63V8DYQX5TSZ
+END:VEVENT
+END:VCALENDAR
diff --git a/tests/formats/event.xcs b/tests/formats/event.xcs new file mode 100644 index 00000000..c3fd817f --- /dev/null +++ b/tests/formats/event.xcs @@ -0,0 +1,50 @@ +<?xml version="1.0"?> +<c:icalendar xmlns:c="urn:ietf:params:xml:ns:icalendar-2.0"> + <c:vcalendar> + <c:properties> + <c:prodid> + <c:text>-//PIMUTILS.ORG//NONSGML khal / icalendar //EN</c:text> + </c:prodid> + <c:version> + <c:text>2.0</c:text> + </c:version> + </c:properties> + <c:components> + <c:vtimezone> + <c:properties> + <c:tzid> + <c:text>Europe/Stockholm</c:text> + </c:tzid> + </c:properties> + <c:components> + <c:daylight> + <c:properties> + <c:dtstart><c:date-time>2018-03-25T03:00:00</c:date-time></c:dtstart> + <c:tzname><c:text>CEST</c:text></c:tzname> + <c:tzoffsetfrom><c:utc-offset>+0100</c:utc-offset></c:tzoffsetfrom> + <c:tzoffsetto><c:utc-offset>+0200</c:utc-offset></c:tzoffsetto> + </c:properties> + </c:daylight> + <c:standard> + <c:properties> + <c:dtstart><c:date-time>2018-10-28T02:00:00</c:date-time></c:dtstart> + <c:tzname><c:text>CET</c:text></c:tzname> + <c:tzoffsetfrom><c:utc-offset>+0200</c:utc-offset></c:tzoffsetfrom> + <c:tzoffsetto><c:utc-offset>+0100</c:utc-offset></c:tzoffsetto> + </c:properties> + </c:standard> + </c:components> + </c:vtimezone> + <c:vevent> + <c:properties> + <c:dtend><c:parameters><c:tzid><c:text>Europe/Stockholm</c:text></c:tzid></c:parameters><c:date-time>2018-09-07T18:00:00</c:date-time></c:dtend> + <c:dtstamp><c:date-time>2018-09-07T15:42:23Z</c:date-time></c:dtstamp> + <c:dtstart><c:parameters><c:tzid><c:text>Europe/Stockholm</c:text></c:tzid></c:parameters><c:date-time>2018-09-07T17:00:00</c:date-time></c:dtstart> + <c:sequence><c:integer>0</c:integer></c:sequence> + <c:summary><c:text>Backhäfv</c:text></c:summary> + <c:uid><c:text>ZSGUP6BTM52UV42SEWBICHSS63V8DYQX5TSZ</c:text></c:uid> + </c:properties> + </c:vevent> + </c:components> + </c:vcalendar> +</c:icalendar> diff --git a/tests/formats/ical.scm b/tests/formats/ical.scm new file mode 100644 index 00000000..5747e2ea --- /dev/null +++ b/tests/formats/ical.scm @@ -0,0 +1,24 @@ +(define-module (ical) + :use-module (srfi srfi-88) + :use-module ((hnh util) :select (sort*)) + :use-module (hnh util path) + :use-module ((rnrs io ports) :select (get-string-all)) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :export (sanitize-string + serialize + deserialize + component-str)) + +;; Technically not back into source, since order of children isn't +;; stable. That's also why we just check that all lines are present, +;; regardless of order. +(define (sanitize-string str) + (sort* (string-split str #\newline) + string<)) + +(define serialize ics:serialize) +(define deserialize ics:deserialize) + +(define component-str + (call-with-input-file (path-append (getenv "here") "event.ics") + get-string-all)) diff --git a/tests/formats/test.scm b/tests/formats/test.scm new file mode 100755 index 00000000..dfa04f22 --- /dev/null +++ b/tests/formats/test.scm @@ -0,0 +1,101 @@ +#!/usr/bin/env bash +# -*- mode: scheme; geiser-scheme-implementation: guile -*- + +here=$(dirname $(realpath $0)) +export here +. "$(dirname $(dirname "$here"))/env" + +exec $GUILE -s "$0" "$@" +!# + +(use-modules (srfi srfi-64) + (srfi srfi-88) + (vcomponent) + (vcomponent create) + (datetime) + (datetime timespec) + ((hnh util) :select (for print-and-return)) + (hnh test testrunner)) + + +(verbose? #t) +(test-runner-factory construct-test-runner) + +(define component + (vcomponent + 'VCALENDAR + version: "2.0" + prodid: "-//PIMUTILS.ORG//NONSGML khal / icalendar //EN" + (list + (vcomponent + 'VEVENT + summary: "Backhäfv" + dtstart: (with-parameters tzid: "Europe/Stockholm" + value: "DATE-TIME" + #2018-09-07T17:00:00) + dtend: (with-parameters tzid: "Europe/Stockholm" + value: "DATE-TIME" + #2018-09-07T18:00:00) + dtstamp: (with-parameters value: "DATE-TIME" + #2018-09-07T15:42:23Z) + uid: "ZSGUP6BTM52UV42SEWBICHSS63V8DYQX5TSZ" + sequence: 0) + (vcomponent + 'VTIMEZONE + tzid: "Europe/Stockholm" + (list (vcomponent + 'STANDARD + dtstart: (with-parameters value: "DATE-TIME" + #2018-10-28T02:00:00) + tzname: "CET" + tzoffsetfrom: (make-timespec #02:00 '+ #\z) + tzoffsetto: (make-timespec #01:00 '+ #\z)) + (vcomponent + 'DAYLIGHT + dtstart: (with-parameters value: "DATE-TIME" + #2018-03-25T03:00:00) + tzname: "CEST" + tzoffsetfrom: (make-timespec #01:00 '+ #\z) + tzoffsetto: (make-timespec #02:00 '+ #\z)))) + ))) + +(add-to-load-path (getenv "here")) + +(test-begin "Serialization Formats") + + + +(for test in '(ical xcal) + (test-group (format #f "Format: ~a" test) + (let ((interface (resolve-interface (list test)))) + (let ((component-str (module-ref interface 'component-str)) + (serialize (module-ref interface 'serialize)) + (deserialize (module-ref interface 'deserialize)) + (sanitize-string (module-ref interface 'sanitize-string))) + + (test-equal "Serialize" + (sanitize-string component-str) + (sanitize-string + (call-with-output-string + (lambda (p) (serialize component p))))) + + (test-group "Deserialize" + (let ((object (call-with-input-string component-str deserialize))) + (test-assert "Deserialize worked" (vcomponent? object)) + + (test-equal "Deserialized object serializes back into source" + (sanitize-string component-str) + (sanitize-string + (call-with-output-string + (lambda (p) (serialize object p))))))) + + + (test-assert "Serialized string can still be read back in" + (vcomponent? + (let* ((obj1 (call-with-input-string component-str deserialize)) + (str2 (call-with-output-string (lambda (p) (serialize obj1 p)))) + (obj2 (call-with-input-string str2 deserialize))) + obj2))))))) + + +(test-end) diff --git a/tests/formats/xcal.scm b/tests/formats/xcal.scm new file mode 100644 index 00000000..4c27931a --- /dev/null +++ b/tests/formats/xcal.scm @@ -0,0 +1,26 @@ +(define-module (xcal) + :use-module (srfi srfi-88) + :use-module (hnh test xmllint) + :use-module (hnh util path) + :use-module ((rnrs io ports) :select (get-string-all)) + :use-module ((vcomponent formats xcal) :prefix #{xcs:}#) + :use-module ((calp namespaces) :select (xcal)) + :export (sanitize-string + serialize + deserialize + component-str)) + +(define (sanitize-string str) + (xmllint str)) + +(define serialize + (lambda (component port) + (xcs:serialize + component port namespaces: `((,xcal . c)) + ))) + +(define deserialize xcs:deserialize) + +(define component-str + (call-with-input-file (path-append (getenv "here") "event.xcs") + get-string-all)) diff --git a/tests/litmus.scm b/tests/litmus.scm new file mode 100755 index 00000000..477c5946 --- /dev/null +++ b/tests/litmus.scm @@ -0,0 +1,47 @@ +#!/usr/bin/env bash +# -*- mode: scheme; geiser-scheme-implementation: guile -*- + +here=$(dirname $(realpath $0)) +. "$(dirname "$here")/env" + +exec $GUILE -e main -s "$0" "$@" +!# + +(use-modules (calp server webdav) + (calp server socket) + (ice-9 threads) + (ice-9 rdelim) + (srfi srfi-1) + (srfi srfi-88)) + +;;; Commentary: +;;; Runs the external WebDAV test framework litmus [1], pointing it +;;; to a new instance of our webdav server. +;;; +;;; [1]: http://webdav.org/neon/litmus/ +;;; +;;; Code: + + + +(define (start-server out) + (begin-thread + (with-error-to-file "webdav.log" + (lambda () + (run-at-any-port + webdav-handler + min-port: 8102 + msg-port: out))))) + + +(define (main args) + (define-values (in out) (car+cdr (pipe))) + (define scm (start-server out)) + (define uri-base (read-line in)) + (define suffix + (if (null? (cdr args)) + "" + (string-append "/" (cadr args)))) + (system* "litmus" (string-append uri-base suffix)) + + (cancel-thread scm)) diff --git a/tests/rfc4791/5.3.1.2/request b/tests/rfc4791/5.3.1.2/request new file mode 100644 index 00000000..8b72a380 --- /dev/null +++ b/tests/rfc4791/5.3.1.2/request @@ -0,0 +1,42 @@ +MKCALENDAR /home/lisa/calendars/events/ HTTP/1.1 +Host: cal.example.com +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:mkcalendar xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:set> + <D:prop> + <D:displayname>Lisa's Events</D:displayname> + <C:calendar-description xml:lang="en" +>Calendar restricted to events.</C:calendar-description> + <C:supported-calendar-component-set> + <C:comp name="VEVENT"/> + </C:supported-calendar-component-set> + <C:calendar-timezone><![CDATA[BEGIN:VCALENDAR +PRODID:-//Example Corp.//CalDAV Client//EN +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:US-Eastern +LAST-MODIFIED:19870101T000000Z +BEGIN:STANDARD +DTSTART:19671029T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:Eastern Standard Time (US & Canada) +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:19870405T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:Eastern Daylight Time (US & Canada) +END:DAYLIGHT +END:VTIMEZONE +END:VCALENDAR +]]></C:calendar-timezone> + </D:prop> + </D:set> +</C:mkcalendar> diff --git a/tests/rfc4791/5.3.1.2/response b/tests/rfc4791/5.3.1.2/response new file mode 100644 index 00000000..f92d755a --- /dev/null +++ b/tests/rfc4791/5.3.1.2/response @@ -0,0 +1,5 @@ +HTTP/1.1 201 Created +Cache-Control: no-cache +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Length: 0 + diff --git a/tests/rfc4791/5.3.2/request b/tests/rfc4791/5.3.2/request new file mode 100644 index 00000000..7efaceb3 --- /dev/null +++ b/tests/rfc4791/5.3.2/request @@ -0,0 +1,17 @@ +PUT /home/lisa/calendars/events/qwue23489.ics HTTP/1.1 +If-None-Match: * +Host: cal.example.com +Content-Type: text/calendar +Content-Length: 0 + +BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VEVENT +UID:20010712T182145Z-123401@example.com +DTSTAMP:20060712T182145Z +DTSTART:20060714T170000Z +DTEND:20060715T040000Z +SUMMARY:Bastille Day Party +END:VEVENT +END:VCALENDAR diff --git a/tests/rfc4791/5.3.2/response b/tests/rfc4791/5.3.2/response new file mode 100644 index 00000000..1c3c18e8 --- /dev/null +++ b/tests/rfc4791/5.3.2/response @@ -0,0 +1,5 @@ +HTTP/1.1 201 Created +Content-Length: 0 +Date: Sat, 11 Nov 2006 09:32:12 GMT +ETag: "123456789-000-111" + diff --git a/tests/rfc4791/7.10.1/request b/tests/rfc4791/7.10.1/request new file mode 100644 index 00000000..977f934b --- /dev/null +++ b/tests/rfc4791/7.10.1/request @@ -0,0 +1,11 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:free-busy-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <C:time-range start="20060104T140000Z" + end="20060105T220000Z"/> +</C:free-busy-query> diff --git a/tests/rfc4791/7.10.1/response b/tests/rfc4791/7.10.1/response new file mode 100644 index 00000000..eaf31712 --- /dev/null +++ b/tests/rfc4791/7.10.1/response @@ -0,0 +1,16 @@ +HTTP/1.1 200 OK +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: text/calendar +Content-Length: 0 + +BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Server//EN +BEGIN:VFREEBUSY +DTSTAMP:20050125T090000Z +DTSTART:20060104T140000Z +DTEND:20060105T220000Z +FREEBUSY;FBTYPE=BUSY-TENTATIVE:20060104T150000Z/PT1H +FREEBUSY:20060104T190000Z/PT1H +END:VFREEBUSY +END:VCALENDAR diff --git a/tests/rfc4791/7.8.1/request b/tests/rfc4791/7.8.1/request new file mode 100644 index 00000000..94a711a2 --- /dev/null +++ b/tests/rfc4791/7.8.1/request @@ -0,0 +1,39 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <D:getetag/> + <C:calendar-data> + <C:comp name="VCALENDAR"> + <C:prop name="VERSION"/> + <C:comp name="VEVENT"> + <C:prop name="SUMMARY"/> + <C:prop name="UID"/> + <C:prop name="DTSTART"/> + <C:prop name="DTEND"/> + <C:prop name="DURATION"/> + <C:prop name="RRULE"/> + <C:prop name="RDATE"/> + <C:prop name="EXRULE"/> + <C:prop name="EXDATE"/> + <C:prop name="RECURRENCE-ID"/> + </C:comp> + <C:comp name="VTIMEZONE"/> + </C:comp> + </C:calendar-data> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:time-range start="20060104T000000Z" + end="20060105T000000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.1/response b/tests/rfc4791/7.8.1/response new file mode 100644 index 00000000..b618b58f --- /dev/null +++ b/tests/rfc4791/7.8.1/response @@ -0,0 +1,99 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTART;TZID=US/Eastern:20060102T120000 +DURATION:PT1H +RRULE:FREQ=DAILY;COUNT=5 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTART;TZID=US/Eastern:20060104T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060104T120000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTART;TZID=US/Eastern:20060106T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060106T120000 +SUMMARY:Event #2 bis bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus>
\ No newline at end of file diff --git a/tests/rfc4791/7.8.10/request b/tests/rfc4791/7.8.10/request new file mode 100644 index 00000000..df483796 --- /dev/null +++ b/tests/rfc4791/7.8.10/request @@ -0,0 +1,22 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:prop-filter name="X-ABC-GUID"> + <C:text-match>ABC</C:text-match> + </C:prop-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query>
\ No newline at end of file diff --git a/tests/rfc4791/7.8.10/response b/tests/rfc4791/7.8.10/response new file mode 100644 index 00000000..6a13fb53 --- /dev/null +++ b/tests/rfc4791/7.8.10/response @@ -0,0 +1,11 @@ +HTTP/1.1 403 Forbidden +Date: Sat, 11 Nov 2005 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:error> + <C:supported-filter> + <C:prop-filter name="X-ABC-GUID"/> + </C:supported-filter> +</D:error> diff --git a/tests/rfc4791/7.8.2/request b/tests/rfc4791/7.8.2/request new file mode 100644 index 00000000..83e31d90 --- /dev/null +++ b/tests/rfc4791/7.8.2/request @@ -0,0 +1,24 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <C:calendar-data> + <C:limit-recurrence-set start="20060103T000000Z" + end="20060105T000000Z"/> + </C:calendar-data> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:time-range start="20060103T000000Z" + end="20060105T000000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.2/response b/tests/rfc4791/7.8.2/response new file mode 100644 index 00000000..71dced2c --- /dev/null +++ b/tests/rfc4791/7.8.2/response @@ -0,0 +1,103 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060102T120000 +DURATION:PT1H +RRULE:FREQ=DAILY;COUNT=5 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060104T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060104T120000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.3/request b/tests/rfc4791/7.8.3/request new file mode 100644 index 00000000..35f9ca07 --- /dev/null +++ b/tests/rfc4791/7.8.3/request @@ -0,0 +1,24 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <C:calendar-data> + <C:expand start="20060103T000000Z" + end="20060105T000000Z"/> + </C:calendar-data> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:time-range start="20060103T000000Z" + end="20060105T000000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.3/response b/tests/rfc4791/7.8.3/response new file mode 100644 index 00000000..68f3b1a1 --- /dev/null +++ b/tests/rfc4791/7.8.3/response @@ -0,0 +1,67 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART:20060103T170000 +DURATION:PT1H +RECURRENCE-ID:20060103T170000 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART:20060104T190000 +DURATION:PT1H +RECURRENCE-ID:20060104T170000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART:20060104T150000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus>
\ No newline at end of file diff --git a/tests/rfc4791/7.8.4/request b/tests/rfc4791/7.8.4/request new file mode 100644 index 00000000..c70acc61 --- /dev/null +++ b/tests/rfc4791/7.8.4/request @@ -0,0 +1,24 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <C:calendar-data> + <C:limit-freebusy-set start="20060102T000000Z" + end="20060103T000000Z"/> + </C:calendar-data> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VFREEBUSY"> + <C:time-range start="20060102T000000Z" + end="20060103T000000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.4/response b/tests/rfc4791/7.8.4/response new file mode 100644 index 00000000..67959c58 --- /dev/null +++ b/tests/rfc4791/7.8.4/response @@ -0,0 +1,31 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd8.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd8"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VFREEBUSY +ORGANIZER;CN="Bernard Desruisseaux":mailto:bernard@example.com +UID:76ef34-54a3d2@example.com +DTSTAMP:20050530T123421Z +DTSTART:20060101T100000Z +DTEND:20060108T100000Z +FREEBUSY;FBTYPE=BUSY-TENTATIVE:20060102T100000Z/20060102T120000Z +END:VFREEBUSY +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.5/request b/tests/rfc4791/7.8.5/request new file mode 100644 index 00000000..d3639f40 --- /dev/null +++ b/tests/rfc4791/7.8.5/request @@ -0,0 +1,23 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VTODO"> + <C:comp-filter name="VALARM"> + <C:time-range start="20060106T100000Z" + end="20060107T100000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.5/response b/tests/rfc4791/7.8.5/response new file mode 100644 index 00000000..4b5a8d8a --- /dev/null +++ b/tests/rfc4791/7.8.5/response @@ -0,0 +1,36 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd4.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd4"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235300Z +DUE;TZID=US/Eastern:20060106T120000 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:NEEDS-ACTION +SUMMARY:Task #2 +UID:E10BA47467C5C69BB74E8720@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.6/request b/tests/rfc4791/7.8.6/request new file mode 100644 index 00000000..ca6d4b37 --- /dev/null +++ b/tests/rfc4791/7.8.6/request @@ -0,0 +1,23 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:prop-filter name="UID"> + <C:text-match collation="i;octet" + >DC6C50A017428C5216A2F1CD@example.com</C:text-match> + </C:prop-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.6/response b/tests/rfc4791/7.8.6/response new file mode 100644 index 00000000..cd257a10 --- /dev/null +++ b/tests/rfc4791/7.8.6/response @@ -0,0 +1,55 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.7/request b/tests/rfc4791/7.8.7/request new file mode 100644 index 00000000..cb030130 --- /dev/null +++ b/tests/rfc4791/7.8.7/request @@ -0,0 +1,27 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:prop-filter name="ATTENDEE"> + <C:text-match collation="i;ascii-casemap" + >mailto:lisa@example.com</C:text-match> + <C:param-filter name="PARTSTAT"> + <C:text-match collation="i;ascii-casemap" + >NEEDS-ACTION</C:text-match> + </C:param-filter> + </C:prop-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.7/response b/tests/rfc4791/7.8.7/response new file mode 100644 index 00000000..cd257a10 --- /dev/null +++ b/tests/rfc4791/7.8.7/response @@ -0,0 +1,55 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.8/request b/tests/rfc4791/7.8.8/request new file mode 100644 index 00000000..1ddb3287 --- /dev/null +++ b/tests/rfc4791/7.8.8/request @@ -0,0 +1,18 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"/> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.8/response b/tests/rfc4791/7.8.8/response new file mode 100644 index 00000000..63895076 --- /dev/null +++ b/tests/rfc4791/7.8.8/response @@ -0,0 +1,151 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd1.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd1"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001102Z +DTSTART;TZID=US/Eastern:20060102T100000 +DURATION:PT1H +SUMMARY:Event #1 +Description:Go Steelers! +UID:74855313FA803DA593CD579A@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060102T120000 +DURATION:PT1H +RRULE:FREQ=DAILY;COUNT=5 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060104T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060104T120000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060106T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060106T120000 +SUMMARY:Event #2 bis bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.9/request b/tests/rfc4791/7.8.9/request new file mode 100644 index 00000000..24484ffb --- /dev/null +++ b/tests/rfc4791/7.8.9/request @@ -0,0 +1,26 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VTODO"> + <C:prop-filter name="COMPLETED"> + <C:is-not-defined/> + </C:prop-filter> + <C:prop-filter name="STATUS"> + <C:text-match + negate-condition="yes">CANCELLED</C:text-match> + </C:prop-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.9/response b/tests/rfc4791/7.8.9/response new file mode 100644 index 00000000..9e37db61 --- /dev/null +++ b/tests/rfc4791/7.8.9/response @@ -0,0 +1,62 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd4.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd4"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235335Z +DUE;VALUE=DATE:20060104 +STATUS:NEEDS-ACTION +SUMMARY:Task #1 +UID:DDDEEB7915FA61233B861457@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd5.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd5"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235300Z +DUE;VALUE=DATE:20060106 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:NEEDS-ACTION +SUMMARY:Task #2 +UID:E10BA47467C5C69BB74E8720@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.9.1/request b/tests/rfc4791/7.9.1/request new file mode 100644 index 00000000..caccc135 --- /dev/null +++ b/tests/rfc4791/7.9.1/request @@ -0,0 +1,15 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-multiget xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <D:href>/bernard/work/abcd1.ics</D:href> + <D:href>/bernard/work/mtg1.ics</D:href> +</C:calendar-multiget> diff --git a/tests/rfc4791/7.9.1/response b/tests/rfc4791/7.9.1/response new file mode 100644 index 00000000..fbc5e966 --- /dev/null +++ b/tests/rfc4791/7.9.1/response @@ -0,0 +1,53 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd1.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd1"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001102Z +DTSTART;TZID=US/Eastern:20060102T100000 +DURATION:PT1H +SUMMARY:Event #1 +Description:Go Steelers! +UID:74855313FA803DA593CD579A@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/mtg1.ics</D:href> + <D:status>HTTP/1.1 404 Not Found</D:status> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/appendix-b/request b/tests/rfc4791/appendix-b/request new file mode 100644 index 00000000..6e077508 --- /dev/null +++ b/tests/rfc4791/appendix-b/request @@ -0,0 +1,17 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"/> + </C:filter> +</C:calendar-query>
\ No newline at end of file diff --git a/tests/rfc4791/appendix-b/response b/tests/rfc4791/appendix-b/response new file mode 100644 index 00000000..5e6878ef --- /dev/null +++ b/tests/rfc4791/appendix-b/response @@ -0,0 +1,275 @@ +HTTP/1.1 207 Multi-Status +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd1.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd1"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001102Z +DTSTART;TZID=US/Eastern:20060102T100000 +DURATION:PT1H +SUMMARY:Event #1 +Description:Go Steelers! +UID:74855313FA803DA593CD579A@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060102T120000 +DURATION:PT1H +RRULE:FREQ=DAILY;COUNT=5 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060104T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060104T120000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd4.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd4"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235335Z +DUE;VALUE=DATE:20060104 +STATUS:NEEDS-ACTION +SUMMARY:Task #1 +UID:DDDEEB7915FA61233B861457@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd5.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd5"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235300Z +DUE;VALUE=DATE:20060106 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:NEEDS-ACTION +SUMMARY:Task #2 +UID:E10BA47467C5C69BB74E8720@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd6.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd6"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +COMPLETED:20051223T122322Z +DTSTAMP:20060205T235400Z +DUE;VALUE=DATE:20051225 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:COMPLETED +SUMMARY:Task #3 +UID:E10BA47467C5C69BB74E8722@example.com +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd7.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd7"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235600Z +DUE;VALUE=DATE:20060101 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:CANCELLED +SUMMARY:Task #4 +UID:E10BA47467C5C69BB74E8725@example.com +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd8.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd8"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VFREEBUSY +ORGANIZER;CN="Bernard Desruisseaux":mailto:bernard@example.com +UID:76ef34-54a3d2@example.com +DTSTAMP:20050530T123421Z +DTSTART:20060101T000000Z +DTEND:20060108T000000Z +FREEBUSY:20050531T230000Z/20050601T010000Z +FREEBUSY;FBTYPE=BUSY-TENTATIVE:20060102T100000Z/20060102T120000Z +FREEBUSY:20060103T100000Z/20060103T120000Z +FREEBUSY:20060104T100000Z/20060104T120000Z +FREEBUSY;FBTYPE=BUSY-UNAVAILABLE:20060105T100000Z/20060105T120000Z +FREEBUSY:20060106T100000Z/20060106T120000Z +END:VFREEBUSY +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 4bb34ce8..4b6d2773 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -23,11 +23,8 @@ fi (use-modules (srfi srfi-1) (srfi srfi-64) (srfi srfi-88) - (hnh util) ((hnh util io) :select (call-with-tmpfile)) - (ice-9 ftw) (ice-9 format) - (ice-9 pretty-print) (ice-9 getopt-long) (ice-9 match) (ice-9 regex) @@ -37,162 +34,12 @@ fi ((ice-9 rdelim) :select (read-string)) (system vm coverage) ((hnh module-introspection all-modules) :select (fs-find)) + + (hnh test testrunner) ) - -(define (µs x) - (* x #e1e6)) - -(define (transform-time-of-day tod) - (+ (* (µs 1) (car tod)) - (cdr tod))) - -(define verbose? (make-parameter #f)) - -(define (escaped sequence string) - (format #f "\x1b[~am~a\x1b[m" sequence string)) - -(define (green s) (escaped 32 s)) -(define (red s) (escaped 31 s)) -(define (yellow s) (escaped 33 s)) -(define (bold s) (escaped 1 s)) - -(define (make-indent depth) - (make-string (* 2 depth) #\space)) - -(define (string-replace-head s1 s2) - (string-replace s1 s2 - 0 (string-length s2))) - -(define (diff s1 s2) - (let ((filename1 (call-with-tmpfile (lambda (p f) (display s1 p) f))) - (filename2 (call-with-tmpfile (lambda (p f) (display s2 p) f)))) - (let ((pipe (open-pipe* - OPEN_READ - ;; "git" "diff" "--no-index" - "diff" - filename1 filename2))) - (begin1 (begin - (read-string pipe)) - (close-pipe pipe))))) - -(define (pp form indent prefix-1) - (let ((prefix (make-string (+ (string-length indent) - (string-length prefix-1)) - #\space))) - (string-replace-head - (with-output-to-string - (lambda () (pretty-print - form - per-line-prefix: prefix - width: (- 79 (string-length indent))))) - (string-append indent prefix-1)))) - - -(define (construct-test-runner) - (define runner (test-runner-null)) - (define depth 0) - ;; end of individual test case - (test-runner-on-test-begin! runner - (lambda (runner) - (test-runner-aux-value! runner (transform-time-of-day (gettimeofday))))) - (test-runner-on-test-end! runner - (lambda (runner) - (when (verbose?) (display (make-indent depth))) - (case (test-result-kind runner) - ((pass) (display (green "X"))) - ((fail) (display (red "E"))) - ((xpass) (display (yellow "X"))) - ((xfail) (display (yellow "E"))) - ((skip) (display (yellow "-")))) - (when (or (verbose?) (eq? 'fail (test-result-kind))) - (format #t " ~a~%" - (cond ((test-runner-test-name runner) - (negate string-null?) => identity) - ((test-result-ref runner 'expected-value) - => (lambda (p) (with-output-to-string - (lambda () - (display (bold "[SOURCE]: ")) - (truncated-print p width: 60)))))))) - (when (eq? 'fail (test-result-kind)) - (cond ((test-result-ref runner 'actual-error) - => (lambda (err) - (if (and (list? err) - (= 5 (length err))) - (let ((err (list-ref err 0)) - (proc (list-ref err 1)) - (fmt (list-ref err 2)) - (args (list-ref err 3))) - (format #t "~a~a in ~a: ~?~%" - (make-indent (1+ depth)) - err proc fmt args)) - (format #t "~aError: ~s~%" (make-indent (1+ depth)) err)))) - (else - (let ((unknown-expected (gensym)) - (unknown-actual (gensym))) - (let ((expected (test-result-ref runner 'expected-value unknown-expected)) - (actual (test-result-ref runner 'actual-value unknown-actual))) - (let ((indent (make-indent (1+ depth)))) - (if (eq? expected unknown-expected) - (format #t "~aAssertion failed~%" indent) - (begin - (display (pp expected indent "Expected: ")) - (display (pp actual indent "Received: ")) - (let ((d (diff (pp expected "" "") - (pp actual "" "")))) - (display - (string-join - (map (lambda (line) (string-append indent "|" line)) - (string-split d #\newline)) - "\n" 'suffix)))))))))) - (format #t "~aNear ~a:~a~%" - (make-indent (1+ depth)) - (test-result-ref runner 'source-file) - (test-result-ref runner 'source-line)) - (pretty-print (test-result-ref runner 'source-form) - (current-output-port) - per-line-prefix: (string-append (make-indent (1+ depth)) "> ") - )) - - (let ((start (test-runner-aux-value runner)) - (end (transform-time-of-day (gettimeofday)))) - (when (< (µs 1) (- end start)) - (format #t "~%Slow test: ~s, took ~a~%" - (test-runner-test-name runner) - (exact->inexact (/ (- end start) (µs 1))) - ))))) - - ;; on start of group - (test-runner-on-group-begin! runner - ;; count is number of #f - (lambda (runner name count) - (if (<= depth 1) - (format #t "~a ~a ~a~%" - (make-string 10 #\=) - name - (make-string 10 #\=)) - (when (verbose?) - (format #t "~a~a~%" (make-string (* depth 2) #\space) name))) - (set! depth (1+ depth)))) - (test-runner-on-group-end! runner - (lambda (runner) - (set! depth (1- depth)) - (when (<= depth 1) - (newline)))) - ;; after everything else is done - (test-runner-on-final! runner - (lambda (runner) - (format #t "Guile version ~a~%~%" (version)) - (format #t "pass: ~a~%" (test-runner-pass-count runner)) - (format #t "fail: ~a~%" (test-runner-fail-count runner)) - (format #t "xpass: ~a~%" (test-runner-xpass-count runner)) - (format #t "xfail: ~a~%" (test-runner-xfail-count runner)) - )) - - runner) - (test-runner-factory construct-test-runner) @@ -230,7 +77,8 @@ fi '((skip (value #t)) (only (value #t)) (verbose (single-char #\v)) - (coverage (value optional)))) + (coverage (value optional)) + (catch))) (define options (getopt-long (command-line) option-spec)) @@ -268,17 +116,22 @@ fi ;;; Catch/print-trace should intercept thrown exceptions, print them prettily with a stack trace, and then continue -#; -(define (catch/print-trace proc) - (catch #t proc - (case-lambda - ((err from msg args data) - (test-assert (format #f "~a in ~a: ~?" err from msg args) - #f)) - (args - (test-assert (format #f "~a (~s)" f args) - #f))))) + +(define catch/print-trace + (if (option-ref options 'catch #f) + (lambda (proc) + (catch #t proc + (case-lambda + ((err from msg args data) + (test-assert (format #f "~a in ~a: ~?" err from msg args) + #f)) + (args + (test-assert (format #f "~a (~s)" f args) + #f))))) + (lambda (proc) (proc)))) + +#; (define (catch/print-trace proc) (proc)) @@ -293,9 +146,9 @@ fi (%loop args onlies))) (if (null? args) onlies - (cond ((string-match "^--skip(=.*)?$" (car args)) + (cond ((string-match "^--skip(=(.*))?$" (car args)) => (lambda (m) - (cond ((match:substring m 1) + (cond ((match:substring m 2) => (lambda (s) (format #t "Skipping ~s~%" s) (test-skip s) @@ -303,9 +156,9 @@ fi (else (format #t "Skipping ~s~%" (cadr args)) (test-skip (cadr args)) (loop (cddr args)))))) - ((string-match "^--only(=.*)?$" (car args)) + ((string-match "^--only(=(.*))?$" (car args)) => (lambda (m) - (cond ((match:substring m 1) + (cond ((match:substring m 2) => (lambda (s) (loop (cdr args) only: s))) (else (loop (cddr args) only: (cadr args)))))) 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))) - - |