From c9719ce7937f0f0f2aa371ced1d585f67af22457 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sun, 29 Nov 2020 22:57:36 +0100
Subject: Add convert entry-point.

---
 module/calp/entry-points/convert.scm | 95 ++++++++++++++++++++++++++++++++++++
 module/calp/main.scm                 |  1 +
 2 files changed, 96 insertions(+)
 create mode 100644 module/calp/entry-points/convert.scm

(limited to 'module')

diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm
new file mode 100644
index 00000000..52ee6b2d
--- /dev/null
+++ b/module/calp/entry-points/convert.scm
@@ -0,0 +1,95 @@
+(define-module (calp entry-points convert)
+  :export (main)
+  :use-module (calp util)
+  :use-module (calp util options)
+  :use-module (ice-9 getopt-long)
+  :use-module (sxml simple)
+  )
+
+
+
+(define opt-spec
+  `((from (single-char #\f) (value (options "xcal" "ical")) 
+          (description "Input format (infered from " (i "infile") ")"))
+    (to (single-char #\t) (value (options "xcal" "ical"))
+        (description "Output format (infered from " (i "outfile") ")"))
+    (infile (value #t) (single-char #\i) (description "Input file"))
+    (outfile (value #t) (single-char #\o) (description "Output file"))
+    (help (single-char #\h) (description "Print this help."))))
+
+
+(define (filename-to-type filename)
+  (let ((extension (car (reverse (string-split filename #\.)))))
+    (cond [(string-ci=? "ics" extension)
+           "ical"]
+          [(or (string-ci=? "xcal" extension)
+               (string-ci=? "xml" extension))
+           "xcal"])))
+
+
+(define (main args)
+  (define opts (getopt-long args (getopt-opt opt-spec)))
+
+  (define infile "/dev/stdin")
+  (define outfile "/dev/stdout")
+  (define from "ical")
+  (define to "xcal")
+
+  (when (option-ref opts 'help #f)
+    (print-arg-help opt-spec)
+    (throw 'return))
+
+  (awhen (option-ref opts 'infile #f)
+         (set! infile it
+               from (filename-to-type it)))
+
+  (awhen (option-ref opts 'outfile #f)
+         (set! outfile it
+               to (filename-to-type it)))
+
+  (awhen (option-ref opts 'from #f)
+         (set! from it))
+
+  (awhen (option-ref opts 'to #f)
+         (set! to it))
+
+  ;; from ∈ { "ical" "xcal" }
+  ;;   to ∈ { "ical" "xcal" }
+
+  (let ()
+   (define parser
+     (case (string->symbol from)
+       [(ical)
+        ;; read ical
+        (@ (vcomponent ical parse) parse-calendar)]
+       [(xcal)
+        ;; read xcal
+        (compose
+         (@ (vcomponent xcal parse) sxcal->vcomponent)
+         ;; TODO strip *TOP*
+         xml->sxml)]
+       [else (error "")]
+       ))
+
+   (define writer
+     (case (string->symbol to)
+       [(ical)
+        ;; write ical
+        (lambda (component port)
+          (display ((@ (vcomponent ical output) component->ical-string)
+                    component)
+                   port))]
+       [(xcal)
+        ;; write xcal
+        (lambda (component port)
+          (sxml->xml ((@ (vcomponent xcal output) vcomponent->sxcal)
+                      component)
+                     port))]
+       [else (error "")]))
+
+
+   (call-with-output-file outfile
+     (lambda (p)
+       (writer (call-with-input-file infile parser)
+               p)))
+   (newline)))
diff --git a/module/calp/main.scm b/module/calp/main.scm
index c93ae795..1af2861a 100644
--- a/module/calp/main.scm
+++ b/module/calp/main.scm
@@ -229,6 +229,7 @@
        ((text)   (@ (calp entry-points     text) main))
        ((ical)   (@ (calp entry-points     ical) main))
        ((server) (@ (calp entry-points   server) main))
+       ((convert) (@ (calp entry-points convert) main))
        ((tidsrapport) (@ (calp entry-points   tidsrapport) main))
        ((benchmark) (@ (calp entry-points benchmark) main))
        (else => (lambda (s)
-- 
cgit v1.2.3