(import (bs core))
(import (prefix (bs dict) dict.))
(import (prefix (bs re) re.))
(import (prefix (bs string) string.))
(import (srfi srfi-1))
(import (sxml simple))
(import (oop goops))
(import (ice-9 peg))
(import (only (srfi srfi-19) date->string current-date))
(import (only (ice-9 match) match match-lambda))
(import (prefix (web server) http.))
(import (prefix (web request) http.req.))
(import (prefix (web response) http.res.))
(import (prefix (web uri) http.uri.))

 ;; general functions, should be extracted to libs

(import (only (ice-9 ftw) scandir))
(define (os.listdir path)
  (scandir path))

(define (os.path.expanduser path)
  (let ([home (getenv "HOME")])
    (string.replace path "~" home)))

(define (os.getenv var)
  (getenv var))

(define (set.difference s1 s2)
  (cond [(null? s1) '()]
        [(not (member? (first s1) s2))
         (cons (first s1) (set.difference (rest s1) s2))]
        [else
         (set.difference (rest s1) s2)]))

(import (only (ice-9 rdelim) read-delimited))
(define (readlines fname)
  (call-with-input-file fname
    (lambda [p]
      (read-delimited "" p 'concat))))

(import (prefix (ice-9 popen) popen/))
(define (subprocess.call argv)
  (apply system* argv))

(import (ice-9 receive))
(import (only (ice-9 rdelim) read-string))
(define (pandoc text)
  (receive (from to pid)
      ((@@ (ice-9 popen) open-process) OPEN_BOTH
       "pandoc" "-f" "markdown" "-t" "html")
    (display text to)
    (close to)
    (let ((ret (read-string from)))
      (close from)
      ret)))

 ;; z program

(define *zdir* (os.path.expanduser "~/test-z-wiki"))

;; A node 'id' is a monotonically increasing number.

;; It can be represented as a string, in which case it is encoded in
;; base 36.

(define (id->string id)
  (fmt "~36,3'0r" id))

(define (string->id s)
  (string->number s 36))

;; It can be represented as a path, in which case it is
;; `<*zdir*>/<string>.md'

(define (path->id fname)
  "Given a path, parse out the node id."
  (-> fname
      (string.replace ".md" "")
      (string.replace *zdir* "")
      (string->id)))

(define (id->path id)
  "Given an id, return the absolute path to the file."
  (fmt "~a/~a.md" *zdir* (id->string id)))

 ;; Manipulating nodes

(define (list-nodes* dir)
  (->> dir
       (os.listdir)
       ;; remove '.' and '..'
       ((/. s (set.difference s '("." ".."))))
       (map path->id)))

(define (list-nodes)
  (list-nodes* *zdir*))

(define (latest-node ls)
  (if (eq? ls '())
      0
      (apply max ls)))

(define (next-id)
   (-> (list-nodes) latest-node inc))

(define-class <node> ()
  (id #:getter id #:init-keyword #:id)
  (title #:accessor title #:init-keyword #:title)
  (created #:getter created
           #:init-form (date->string (current-date) "~Y.~m.~d..~H.~M"))
  (tags #:accessor tags #:init-keyword #:tags)
  (content #:accessor get-content #:init-keyword #:content)
  (path #:getter path
        #:allocation #:virtual
        #:slot-set! (lambda (_) #f)
        #:slot-ref (lambda (self)
                     (id->path (id self)))))

(define-generic save!)

(define-method (save! (node <node>))
  (call-with-output-file (path node)
    (fn [file]
        (format file "title: ~a\n" (title node))
        (format file "created: ~a\n" (created node))
        (format file "tags: ~{~a ~}" (tags node))
        (display "---\n" file)
        (format file "~a" (get-content node)))))

 ;; Parsing Nodes

(define-peg-string-patterns "\
node <- meta* content !.
meta <-- key SEP value NL
key <-- 'title' / 'created' / 'tag'
value <-- (!NL !SEP  .)*
content <-- HR .*
HR < '---'
SEP < ':'
NL < '\n'
")

(define (parse-meta node-tree)
  (turn (first node-tree)
        (match-lambda
          [('meta ('key key) ('value ret))
           `(,key . ,(string.strip ret #\space))]
          [_ '()])))

(define (parse-content node-tree)
  (-> node-tree second second))

(define (load-node id)
  (let* ([node-tree (->> id id->path readlines (match-pattern node) peg:tree)]
         [meta (parse-meta node-tree)])
    (make <node>
      #:id id
      #:title (assoc-ref meta "title")
      #:created (assoc-ref meta "created")
      #:tags (->> meta
                  (filter (/. P (equal? (car P) "tag")))
                  (map cdr))
      #:content (parse-content node-tree))))

 ;; Indexing

(define *tags* (dict.empty))
(define *titles* (dict.empty))

(define (index-node id)
  (let ([node (load-node id)])
    (dict.set *titles* (title node) id)
    (turn (tags node)
      (/. tag
          (if tag
              (dict.update
               *tags*
               tag
               (/. ids
                   (if (contains? ids id)
                       ids
                       (cons id ids)))))))))

(define (reindex)
  (set! *titles* (dict.empty))
  (set! *tags* (dict.empty))
  (map index-node (list-nodes)))

 ;; Searching / filtering

(define (tagged tag)
  "returns a list of all ids with the given tag"
  (dict.get *tags* tag))

(define (get-by-title title)
  (dict.get *titles* title))

 ;; view

(define *css* "
@import url('https://fonts.googleapis.com/css2?family=Source+Code+Pro:ital,wght@0,400;0,700;1,400&family=Source+Sans+Pro:ital,wght@0,400;0,700;1,400&family=Source+Serif+Pro:wght@400;700&display=swap');
body
{ max-width: 900px; min-height: 100vh
; margin: 0 auto; padding: 0 10px
; color:#444
; font: 18px/1.5 -apple-system, 'Source Sans Pro',
  BlinkMacSystemFont, \"Segoe UI\", Roboto, \"Helvetica Neue\", Arial,
  \"Noto Sans\", sans-serif, \"Apple Color Emoji\", \"Segoe UI Emoji\",
  \"Segoe UI Symbol\", \"Noto Color Emoji\"
; display: flex; flex-direction: column
}
main,nav,aside { font-family: 'Source Sans Pro', sans-serif; }
nav { order: -1 }
h1,h2,h3 { line-height: 1.2 }
p, li { line-height: 1.4rem }
p { margin: 0 0 1.8rem 0 }
.serif { font-family: 'Source Sans Pro', serif }
pre { font-family: 'Source Sans Pro', monospace }
pre a, pre a:hover, pre a:visited { text-decoration: none }
@media (min-width: 768px) {
  body { flex-direction: row; flex: 1; justify-content: center }
  main { flex: 1 }
  nav, aside { flex: 0 0 12em }
}
/* Base16 Spacemacs Scheme: Nasser Alshammari (https://github.com/nashamri/spacemacs-theme) */
table.sourceCode, tr.sourceCode, td.sourceCode, table.sourceCode pre
{ margin: 0; padding: 0; border: 0; vertical-align: baseline; border: none; background-color: #f8f8f8; color: #444155 }
td.nums { text-align: right; padding-right: 5px; padding-left: 5px; background-color: #e8e8e8; }
td.sourceCode { padding-left: 5px; }
code.sourceCode { background-color: #f8f8f8; }
pre.sourceCode { background-color: #f8f8f8; line-height: 125% }
td.nums pre { background-color: #e8e8e8; line-height: 125% }
code.sourceCode span.kw { color: #4f97d7; font-weight: bold } /* Keyword */
code.sourceCode span.dt { color: #a31db1} /* Keyword.Type */
code.sourceCode span.dv { color: #ffa500 } /* Literal.Number.Integer */
code.sourceCode span.bn { color: #ffa500 } /* Literal.Number.Hex */
code.sourceCode span.fl { color: #ffa500 } /* Literal.Number.Float */
code.sourceCode span.ch { color: #67b11d} /* Literal.String.Char */
code.sourceCode span.st { color: #67b11d } /* Literal.String */
code.sourceCode span.co { color: #585858 } /* Comment */
code.sourceCode span.ot { color: #b03060 } /* Comment.Preproc */
code.sourceCode span.al { color: #a31db1 } /* Generic.Error */
code.sourceCode span.fu { color: #b1951d } /* Name.Function */
code.sourceCode span.re { color: #2d9574}
code.sourceCode span.er { color: #f2241f; border: 1px solid #a31db1 } /* Error */
@media (prefers-color-scheme: dark)
{
  body { color: white; background: #444 }
  a:link { color: #5bf }
  a:visited { color: #ccf }
  /* Base16 Spacemacs Scheme: Nasser Alshammari (https://github.com/nashamri/spacemacs-theme) */
  table.sourceCode, tr.sourceCode, td.sourceCode, table.sourceCode pre
  { margin: 0; padding: 0; border: 0; vertical-align: baseline; border: none; background-color: #1f2022; color: #a3a3a3 }
  td.nums { text-align: right; padding-right: 5px; padding-left: 5px; background-color: #282828; }
  td.sourceCode { padding-left: 5px; }
  code.sourceCode { background-color: #1f2022; }
  pre.sourceCode { background-color: #1f2022; line-height: 125% }
  td.nums pre { background-color: #282828; line-height: 125% }
  code.sourceCode span.kw { color: #4f97d7; font-weight: bold } /* Keyword */
  code.sourceCode span.dt { color: #a31db1} /* Keyword.Type */
  code.sourceCode span.dv { color: #ffa500 } /* Literal.Number.Integer */
  code.sourceCode span.bn { color: #ffa500 } /* Literal.Number.Hex */
  code.sourceCode span.fl { color: #ffa500 } /* Literal.Number.Float */
  code.sourceCode span.ch { color: #67b11d} /* Literal.String.Char */
  code.sourceCode span.st { color: #67b11d } /* Literal.String */
  code.sourceCode span.co { color: #585858 } /* Comment */
  code.sourceCode span.ot { color: #b03060 } /* Comment.Preproc */
  code.sourceCode span.al { color: #a31db1 } /* Generic.Error */
  code.sourceCode span.fu { color: #b1951d } /* Name.Function */
  code.sourceCode span.re { color: #2d9574}
  code.sourceCode span.er { color: #f2241f; border: 1px solid #a31db1 } /* Erro  r */
}

")

;; global navbar on the left side
(define *navbar*
  `(nav
    (h1 (a (@ (href "/") (class "serif")) "z"))
    (ul
     ,@(receive (names paths)
           (unzip2 '(("index" "/")
                     #;("new" "/id/new")
                     ("tags" "/tag")))
         (map (lambda (name path)
                `(li (a (@ (href ,path)) ,name)))
              names paths)))))

(define (template title body)
  `(html (head
          (title ,title)
          (meta (@ (name "viewport")
                   (content "width=device-width, initial-scale=1"))))
         (style ,*css*)
         (body
          ,@body)))

(define (link-tag tag)
  `(a (@ (href ,(fmt "/tag/~a" tag)))
      ,(fmt "~a" tag)))

(define (view-content node)
  `(main
    (h2 ,(title node))
    ,(->> node
          get-content
          pandoc
          ;; wrap in article tags so sxml includes all of the
          ;; content, not just the first element
          ((/. s (string.str "<article>" s "</article>")))
          xml->sxml)))

(define (view-meta node)
  `(aside
    (ul
     (li ,(created node))
     ,(turn (tags node)
            (/. tag `(li ,(link-tag tag)))))))

 ;; webserver

(define* (respond #:optional body #:key
                  (status 200)
                  (title "z")
                  (doctype "<!DOCTYPE html>\n")
                  (content-type-params '((charset . "utf-8")))
                  (content-type 'text/html)
                  (extra-headers '())
                  (sxml (and body (template title body))))
  (values (http.res.build-response
           #:code status
           #:headers `((content-type
                        . (,content-type ,@content-type-params))
                       ,@extra-headers))
          (lambda (port)
            (when sxml
              (if doctype (display doctype port))
              (sxml->xml sxml port)))))

(define (path-components req)
  (-> req
      http.req.request-uri
      http.uri.uri-path
      http.uri.split-and-decode-uri-path))

(define (routes req body)
  (match (path-components req)
    ['()
     (respond
      `((ul
         ,@(turn (list-nodes)
                 (lambda (id)
                   `(li (a (@ (href ,(fmt "/node/~a" (id->string id))))
                           ,(fmt "~a: ~a"
                                 (id->string id)
                                 (title (load-node id))))))))))]
    [("node" id)
     (let* ([node (load-node (string->id id))]
            [txt (or (get-content node) "")])
       (respond
        (list
         (view-content node)
         (view-meta node)
         *navbar*)
        #:title (fmt "z - ~a" (title node))))]
    [("tag")
     (begin
       (reindex)
       (respond
        `((ul ,@(turn (dict.keys *tags*)
                      (lambda [tag]
                        `(li ,(link-tag tag))))))))]
    [("tag" tag)
     (respond
      `((ul ,@(turn (tagged tag)
                    (lambda [id]
                      `(li (a (@ (href ,(fmt "/node/~a" (id->string id))))
                              ,(fmt "~a:  ~a"
                                    (id->string id)
                                    (title (load-node id))))))))))]
    [_ (respond '(h1 "not found")
                #:title "z - not found")]))

(define* (serve #:key (port 8080))
  (prn "z")
  (prn (fmt "port ~a" port))
  (http.run-server routes 'http `(#:port ,port #:host "0.0.0.0")))

 ;; CLI

(define (usage)
  (prn "\
usage: z [command]
where 'command' is:
    <none>         create new note
    ls             list all notes
    tags           list all tags
    tagged [tag]   list notes tagged with 'tag'
    web [port]     start the webserver"))

(define (main args)
  (match (rest args)
    ['()
     ;; TODO: create a tmp file with template, open that in editor,
     ;; write and save. then load-node and save! proper. I can't pipe,
     ;; because emacs doesn't pipe to buffer
     (let ([node (make <node>)]
           [editor (os.getenv "EDITOR")])
       (subprocess.call (list editor (path node)))
       (exit EXIT_SUCCESS))]
    [("ls")
     (turn (list-nodes)
           (lambda (id)
             (format #t "~a:  ~a\n"
                     (id->string id)
                     (title (load-node id)))))]
    [("tagged" tag)
     (begin
       (reindex)
       (turn (tagged tag)
             (lambda (id)
               (format #t "~a:  ~a\n"
                       (id->string id)
                       (title (load-node id))))))]
    [("tags")
     (begin
       (reindex)
       (turn (dict.keys *tags*)
             (lambda (tag)
               (format #t
                       "(~a)  ~a\n"
                       (count (const #t) (dict.get *tags* tag))
                       tag))))]
    [("web") (serve)]
    [("web" port) (serve #:port (string->number port))]
    [_ (usage)]))