Add structure for importing events.

4 files changed, 98 insertions, 34 deletions

diff --git a/module/entry-points/import.scm b/module/entry-points/import.scm
index 5558433b..3d372f8a 100644
--- a/module/entry-points/import.scm
+++ b/module/entry-points/import.scm
@@ -1,37 +1,58 @@
 (define-module (entry-points import)
   :export (main)
   :use-module (util)
+  :use-module (util app)
+  :use-module (util options)
   :use-module (ice-9 getopt-long)
+  :use-module (ice-9 rdelim)
+  :use-module (vcomponent)
+  :use-module (srfi srfi-1)
   )
 
 (define options
-  '((calendar (value #t) (single-char #\c))
-    (source (value #t) (single-char #\f))
-    ))
-
-(define (import-main calenadrs events args)
-  (define opts (getopt-long args options))
-
-  (define calendar (option-ref opts 'calendar #f))
-
-  (unless calendar
-    (format (current-error-port)
-            "Everything wroong~%"))
-
-
-  ;; TODO save sourcetype and dir for vdir calendars
-
-  #;
-  (let ((component (make-vcomponent (option-ref args 'source "/dev/stdin")))) ;
-                                        ;
-    ;; Check UID                        ;
-    ;; Add to calendar                  ;
-    ;; Allocate file, save there        ;
-                                        ;
-  )
-
-
-  )
-
-(define (main . _)
-  'noop)
+  '((calendar (value #t) (single-char #\c)
+              (description "Name of calendar to import into"))
+    (file (value #t) (single-char #\f)
+          (description "ics file to import"))
+    (help (single-char #\h)
+          (description "Print this help."))))
+
+(define (main args)
+  (define opts (getopt-long args (getopt-opt options)))
+
+  (define cal-name (option-ref opts 'calendar #f))
+  (define fname (option-ref opts 'file "/dev/stdin"))
+
+  (when (option-ref opts 'help #f)
+    (print-arg-help options)
+    (throw 'return))
+
+  (let* ((calendars (getf 'calendars))
+         (calendar
+          (and cal-name
+               (find (lambda (c) (string=? cal-name (attr c 'NAME)))
+                     (getf 'calendars)))))
+
+    (unless calendar
+      (format (current-error-port) "No calendar named ~s~%" cal-name)
+      (throw 'return))
+
+    (let ((new-events (parse-cal-path fname)))
+
+      (format #t "About to the following ~a events into ~a~%~{~a~^~%~}~%"
+              (length (children new-events))
+              (attr calendar 'NAME)
+              (map (extract 'SUMMARY) (children new-events)))
+
+      (format #t "Continue? [Y/n] ")
+
+      (let loop ((c #\space))
+        (case c
+          [(#\n #\N) (throw 'return)]
+          [(#\y #\Y) (map (lambda (e) (calendar-import calendar e))
+                          (children new-events))]
+          [else
+           (let ((line (read-line)))
+             (loop (if (string-null? line)
+                       #\Y (string-ref line 0))))]))
+      )))
diff --git a/module/vcomponent.scm b/module/vcomponent.scm
index 61168e70..e55b4f9b 100644
--- a/module/vcomponent.scm
+++ b/module/vcomponent.scm
@@ -69,3 +69,41 @@
 
 (define-method (get-event-by-uid uid)
   (hash-ref (getf 'uid-map) uid))
+
+
+
+
+(use-modules (output ical)
+             (ice-9 popen)
+             ((ice-9 rdelim) :select (read-line))
+             ((rnrs io ports) :select (call-with-port))
+             )
+
+
+(define (uuidgen)
+  (call-with-port (open-input-pipe "uuidgen")
+                  read-line))
+
+(define (filepath calendar uid)
+  (string-append (attr calendar 'X-HNH-DIRECTORY)
+                 file-name-separator-string
+                 uid ".ics"))
+
+
+(define-public (calendar-import calendar event)
+  (case (attr calendar 'X-HNH-SOURCETYPE)
+    [(file)
+     (error "Importing into direct calendar files not supported")]
+    [(vdir)
+     (aif (attr event 'UID)
+          (with-output-to-file (filepath calendar it)
+            (lambda () (print-components-with-fake-parent (list event))))
+          (let ((uuid (uuidgen)))
+            (set! (attr event 'UID) uuid)
+            ;; TODO this should caputure attributes from the calendar
+            (with-output-to-file (filepath calendar uuid)
+              (lambda ()
+                (print-components-with-fake-parent (list event))))))]
+    [else
+     (error "Source of calendar unknown, aborting.")
+     ]))
diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm
index 960fb6eb..b20fcfc8 100644
--- a/module/vcomponent/parse.scm
+++ b/module/vcomponent/parse.scm
@@ -105,17 +105,19 @@
 
 ;; Parse a vdir or ics file at the given path.
 (define-public (parse-cal-path path)
+  ;; TODO check (access? path R_OK) ?
   (define st (stat path))
   (define cal
     (case (stat:type st)
       [(regular)
        (let ((comp (call-with-input-file path parse-calendar)))
-         (set! (attr comp 'X-HNH-SOURCETYPE) "file")
+         (set! (attr comp 'X-HNH-SOURCETYPE) 'file)
          comp) ]
       [(directory)
        (report-time! "Parsing ~a" path)
        (let ((comp (parse-vdir path)))
-         (set! (attr comp 'X-HNH-SOURCETYPE) "vdir")
+         (set! (attr comp 'X-HNH-SOURCETYPE) 'vdir
+               (attr comp 'X-HNH-DIRECTORY) path)
          comp)]
       [(block-special char-special fifo socket unknown symlink)
        => (lambda (t) (error "Can't parse file of type " t))]))
diff --git a/module/vcomponent/parse/component.scm b/module/vcomponent/parse/component.scm
index 69b833dd..f7dbdf71 100644
--- a/module/vcomponent/parse/component.scm
+++ b/module/vcomponent/parse/component.scm
@@ -109,7 +109,7 @@
          (cond
           [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser]
 
-          [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID  RDATE
+          [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE
                               CREATED DTSTAMP LAST-MODIFIED
                               ;; only on VALARM
                               ACKNOWLEDGED
@@ -142,7 +142,10 @@
            (lambda (params value)
              (let ((v (car ((get-parser 'TEXT) params value))))
                (unless (and (string? v) (string=? "2.0" v))
-                 (warning "File of unsuported version. Proceed with caution"))))]
+                 #f
+                 ;; (warning "File of unsuported version. Proceed with caution")
+                 )
+               v))]
 
           [(memv key '(TRANSP))
            (enum-parser '(OPAQUE TRANSPARENT))]