root/file-view.scm

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
(define-module (file-view)
  #:use-module (html-wrapper)
  #:use-module (path-utils)
  #:use-module (file-utils)
  #:use-module (utils)
  #:use-module (system-utils)
  #:use-module (sxml simple)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-13)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:export (file-view))

(define (count-lines str)
  (+ (string-fold (lambda (c acc) (if (char=? c #\newline)
                                      (+ 1 acc)
                                      acc)) 0 str)
     ;; missing new line at the end of file
     (if (or
          (string-null? str)
          (char=? (string-ref str (- (string-length str) 1)) #\newline))
         0
         1)))

(define* (file-view file-path  #:optional (title (title-links file-path)))
  ((or (file-view-for-name file-path)
       (file-view-for-type file-path)
       file-view-text) file-path title))

(define (file-view-for-name file-path)
  (let ((ext (path-extension file-path)))
    (cond ((string-ci=? ext ".org") file-view-org)
          ((string-ci=? ext ".svg") file-view-image)
          (else #f))))

(define (file-view-for-type file-path)
  (let ((output (shell-command-to-string* "file" "-b" "--mime" file-path)))
    (cond ((string-match "\\bimage\\b" output) file-view-image)
          ((string-match "\\bvideo\\b" output) file-view-video)
          (else #f))))

(define (file-view-text file-path title)
  (let* ((contents (get-file-contents file-path))
         (lines (count-lines contents)))
    `(div (@ (class "file-view text"))
          (h4 ,title)
          (div (@ (class "contents"))
               (pre (@ (class "line-numbers"))
                    ,(let ((numbers '()))
                       (do ((i lines (- i 1)))
                           ((<= i 0))
                         (set! numbers (cons (string-append
                                              (number->string i)
                                              "\n") numbers)))
                       numbers))
               (pre (@ (class "file-content")) ,contents)))))

(define (file-view-org file-path title)
  (define org-raw (shell-command-to-string*
                   "emacs"
                   file-path
                   "--batch"
                   "--eval"
                   ;; TODO figure out the emacs version
                   ;;      and use appropriate elisp

                   ;; only valid with emacs 23
                   ;; "(progn
                   ;;     (setq org-export-preserve-breaks t)
                   ;;     (princ (org-export-region-as-html
                   ;;            (point-min) (point-max) t 'string)))"

                   ;; only tested with emacs 25
                   "(progn
                       (require 'org)
                       (setq org-export-preserve-breaks t)
                       (org-html-export-as-html nil nil nil t)
                       (switch-to-buffer \"*Org HTML Export*\")
                       (princ (buffer-substring-no-properties
                                  (point-min) (point-max))))"
                   "--kill"))
  ;; There is a bug with simple sxml not parsing &hellip and &ndash
  (define org-fix1 (string-substitute org-raw "&ndash;" "-" #t))
  (define org-contents (string-substitute org-fix1 "&hellip;" "..." #t))
  (define org-sxml (if (string=? org-contents "\n")
                       '()
                       (xml->sxml (string-append "<div>"
                                                 org-contents
                                                 "</div>\n"))))

  `(div (@ (class "file-view org rendered-markup"))
        (h4 ,title)
        (div (@ (class "contents"))
             (div (@ (class "file-content")) ,org-sxml))))

(define (file-view-image file-path title)
  (define rel-path (to-relative-raw-path file-path))
  `(div (@ (class "file-view image"))
        (h4 ,title)
        (div (@ (class "contents"))
             (img (@ (src ,rel-path))))))

(define (file-view-video file-path title)
  (define rel-path (to-relative-raw-path file-path))
  `(div (@ (class "file-view video"))
        (h4 ,title)
        (div (@ (class "contents"))
             (video (@ (src ,rel-path)  (loop "loop") (autoplay "autoplay")
                       (controls "controls") (muted "muted"))
                    (string-append "Can not play video" ,rel-path)))))

(define (title-links file-path)
  (define parts (string-split file-path #\/))
  (define final (last parts))
  (define mid (cdr (reverse (cdr (reverse parts)))))
  (define links
    (cdr (fold (lambda (value acc)
                 (define path (if (<= (car acc) 0)
                                  "./"
                                  (repeat-str (car acc) "../")))
                 (define file-path (string-append path "index.html"))
                 (define link `((a (@ (href ,file-path)) ,value) "/"))
                 (define links (append (cdr acc) link))
                 (cons (- (car acc) 1) links))
               (cons (- (length mid) 1) '())
               mid)))
  (append `((a (@ (href ,(string-append
                          (repeat-str (length mid) "../")
                          "../index.html")))
               "root") "/")
          links
          `((a (@ (href ,(string-append final ".html")))
               ,final))))

(define (to-relative-raw-path file-path)
  (define slash-count (string-count file-path #\/))
  (define result #f)
  (do ((i 0 (1+ i))
       (acc file-path (string-append "../" acc)))
      ((> i slash-count))
    (set! result acc))
  result)