(defpackage #:poftheday
  (:use #:cl)
  (:import-from #:rutils
                #:iter
                #:with
                #:fmt)
  (:export
   #:choose))
(in-package poftheday)

(defun choose ()
  (let ((published (find-published-systems)))
    (flet ((is-published (release)
             (loop for system-file in (ql::system-files release)
                   for system-name = (str:replace-all ".asd" "" system-file)
                   when (member system-name published :test #'string-equal)
                   do (return-from is-published t))))
      (let* ((releases (ql::provided-releases t))
             (non-published (remove-if #'is-published releases))
             (idx (random (length non-published)))
             (release (nth idx non-published)))
        (values
         (ql::project-name release)
         (ql::system-files release))))))

CL-USER> (ql-dist:install-dist "http://dist.ultralisp.org/"
                               :prompt nil)
CL-USER> (ql-dist:all-dists)
(#<QL-DIST:DIST quicklisp 2019-08-13> #<QL-DIST:DIST ultralisp 20200307123509>)

(setf *random-state*
      (make-random-state t))

(defclass file ()
  ((filename :initarg :filename
             :type string
             :documentation "A relative path to the source org-mode file."
             :reader get-filename)
   (root :initarg :root
         :documentation "Parsed org-mode document, root node."
         :reader get-root)))


(defmethod print-object ((file file) stream)
  (print-unreadable-object (file stream :type t)
    (format stream "~A" (get-filename file))))


(defun read-files ()
  (uiop:while-collecting (collect)
    (flet ((org-mode-p (name)
             (string-equal (pathname-type name)
                           "org"))
           (make-file (filename)
             (collect
                 (let ((relative-filename
                         (ppath:relpath (pathname-to-string filename)
                                        "content/")))
                   (make-instance 'file
                                  :filename relative-filename
                                  :root (cl-org-mode::read-org-file filename))))))
      (cl-fad:walk-directory "content/"
                             #'make-file
                             :test #'org-mode-p))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *google-code* "
  <!-- Global site tag (gtag.js) - Google Analytics -->
  <script async src=\"https://www.googletagmanager.com/gtag/js?id=UA-162105820-1\"></script>
  <script>
    window.dataLayer = window.dataLayer || [];
    function gtag(){dataLayer.push(arguments);}
    gtag('js', new Date());
  
    gtag('config', 'UA-162105820-1');
  </script>
  "))


(defvar *index-uri* nil
  "This is a path to the site's top level. When it is nil, consider we are on the front page.")


(defun construct-uri (uri &rest args)
  (if *index-uri*
      (concatenate 'string
                   *index-uri*
                   (apply #'rutils:fmt uri args))
      (apply #'rutils:fmt uri args)))


(defmacro app-page ((stream &key title index-uri (site-title "Lisp Project of the Day")) &body body)
  `(let ((*index-uri* ,index-uri))
     (cl-who:with-html-output (*standard-output* ,stream :prologue t :indent t)
       (:html :lang "en"
         (:head
          (:meta :charset "utf-8")
          ,@(when title
              `((:title (cl-who:esc ,title))))
          (:link :rel "alternate"
                 :href "https://40ants.com/lisp-project-of-the-day/rss.xml"
                 :type "application/rss+xml")
          (:meta :name "viewport"
                 :content "width=device-width, initial-scale=1")
          *google-code*
          (:link
           :type "text/css"
           :rel "stylesheet"
           :href  ,cl-bootstrap:*bootstrap-css-url*)
          (:script :src ,cl-bootstrap:*jquery-url*)
          (:script :src ,cl-bootstrap:*bootstrap-js-url*)
          (:link :rel "stylesheet"
                 :href "../../highlight/styles/tomorrow-night.css")
          (:script :src "../../highlight/highlight.pack.js")
          (:script "hljs.initHighlightingOnLoad();")
          (:style "

.tags .label {
    margin-right: 1em;
}
.posts tr {
    line-height: 1.7em;
}
.posts tr td.number {
    font-weight: bold;
    padding-right: 0.7em;
}
.posts tr td.tags {
    padding-left: 0.7em;
}
h1 .tags {
    font-size: 1.2rem;
    position: relative;
    left: 1.5rem;
    top: -1.5rem;
}
.tags a {
    text-decoration: none;
}
"))
         (:body 
          (cl-bootstrap:bs-container ()
            (cl-bootstrap:bs-row
              (:a :href "https://40ants.com/lisp-project-of-the-day/rss.xml"
                  :style "display: block; float: right;"
                  (:img :alt "RSS Feed"
                        :src "https://40ants.com/lisp-project-of-the-day/media/images/rss.png"))
              (:header
               (:h1 :style "text-align: center"
                    (if ,index-uri
                        (cl-who:htm
                         (:a :href (rutils:fmt "~Aindex.html" ,index-uri)
                             (cl-who:esc ,site-title)))
                        (cl-who:esc ,site-title)))
               ,@(when title
                   `((:h2 :style "text-align: center"
                          (cl-who:esc ,title)))))
              (cl-bootstrap:bs-col-md ()
                (:center
                 (:h3 "You can support this project by donating at:")
                 (:a :href "https://www.patreon.com/bePatron?u=33868637"
                     (:img :alt "Donate using Patreon"
                           :src "https://40ants.com/lisp-project-of-the-day/media/images/patreon-btn.png"
                           :width "160"))
                 (:a :href "https://liberapay.com/poftheday/donate"
                     (:img :alt "Donate using Liberapay"
                           :src "https://liberapay.com/assets/widgets/donate.svg"))
                 (:p "Or see "
                     (:a :href "https://40ants.com/lisp-project-of-the-day/patrons/index.html"
                         "the list of project sponsors")
                     "."))
                ,@body))
            (:div
             (:hr)
             (:center
              (:p (cl-who:str "Brought to you by 40Ants under&nbsp;")
                  (:a :rel "license"
                      :href "http://creativecommons.org/licenses/by-sa/4.0/"
                      (:img :alt "Creative Commons License"
                            :style "border-width:0"
                            :src "https://i.creativecommons.org/l/by-sa/4.0/88x31.png")))))))))))

(defun remove-tags (title)
  (cl-ppcre:regex-replace-all " *:.*:$" title ""))

(defun extract-tags (title)
  (declare (type simple-string title))
  (when (find #\: title :test #'char=)
    (mapcar (alexandria:curry #'str:replace-all "_" "-")
            (str:split #\:
                       (cl-ppcre:regex-replace-all ".*?:(.*):$" title "\\1")))))

(defun get-title (file)
  ;; Title can ends with tags, we need to extract them
  ;; and return as a second value.   
  (let ((full-title (cl-org-mode::node.heading
                     (cl-org-mode::node.next-node
                      (get-root file)))))
    (values (remove-tags full-title)
            (extract-tags full-title))))

(defvar *rss-mode* nil)

(defgeneric render-node (node stream)
  (:documentation "Renders org-mode node into the HTML stream"))

(defmethod render-node ((node cl-org-mode::outline-node) stream)
  (cl-who:with-html-output (stream)
    ;; First node is a title
    (with ((level (1- (length (cl-org-mode::node.heading-level-indicator node))))
           (full-title (cl-org-mode::node.heading node))
           (title (remove-tags full-title)))
      (ecase level
        (1 (unless *rss-mode*
             (cl-who:htm
              (:h1 (cl-who:esc title)
                   (:span :class "tags"
                          (loop for tag in (extract-tags full-title)
                          do (cl-who:htm
                              (:a :href (construct-uri "tags/~A.html" tag)
                                  (cl-bootstrap:bs-label ()
                                    (cl-who:esc tag))))))))))
        (2 (cl-who:htm
            (:h2 (cl-who:esc title))))
        (3 (cl-who:htm
            (:h3 (cl-who:esc title)))))))
  (call-render-for-all-children node stream))

(defun autolink (text)
  (cond
    ((str:starts-with-p "http" text)
     (format nil "<a href=\"~A\">~A</a>" text text))
    (t text)))

(defun smile->unicode (text)
  (arrows:->>
   text
   (str:replace-all ":)" "😀")
   (str:replace-all ":|" "🤨")
   (str:replace-all ":(" "🥺")))

;; This method was removed from cl-org-mode at some moment :(
(defmethod cl-org-mode::node.children ((node CL-ORG-MODE::TEXT-NODE))
  nil)

(defmethod render-node ((node cl-org-mode::properties-node) stream)
  (unless *rss-mode*
    (cl-who:with-html-output (stream)
      (:table :style "position: relative; float: right; background-color: #F1F1F1; padding: 1em; margin-left: 1em; margin-bottom: 1em; border: 1px solid #D1D1D1;"
              (mapcar
               (lambda (item)
                 (render-node item stream))
               (cl-org-mode::node.children node))))))

(defmethod render-node ((node cl-org-mode::property-node) stream)
  (cl-who:with-html-output (stream)
    (:tr
     (:td :style "padding-left: 0.5rem; padding-right: 0.5rem"
          (cl-who:esc
           (cl-org-mode::property-node.property node)))
     (:td :style "padding-left: 0.5rem; padding-right: 0.5rem; border-left: 1px solid #DDD"
          (cl-who:str
           (autolink
            (smile->unicode
             (cl-org-mode::property-node.value node))))))))

(defmethod render-node ((node cl-org-mode::src-node) stream)
  (let ((mode (str:trim (cl-org-mode::node.emacs-mode node)))
        (text (str:trim (cl-org-mode::node.text node))))

    (cond
      ((and (str:starts-with-p "html " mode)
            (str:containsp ":render-without-code" mode))
       
       (cl-who:with-html-output (stream)
         (cl-who:str text)))
      
      ((and (str:starts-with-p "html " mode)
            (str:containsp ":render" mode))
       
       (cl-who:with-html-output (stream)
         (:h4 "Code")
         (:pre
          (:code :class mode
                 (cl-who:esc text))))

       (cl-who:with-html-output (stream)
         (:h4 "Result")
         (cl-who:str text)))
      (t
       (cl-who:with-html-output (stream)
         (:pre
          (:code :class mode
                 (cl-who:esc text))))))))

(defmethod render-node ((node cl-org-mode::closing-delimiter-node) stream)
  ;; Closing delimiters for source code blocks should be ignored.
  )

(defun replace-images (text)
  (cl-ppcre:regex-replace-all
   "\\[\\[(.*?\\.(png|jpg|gif))\\]\\]"
   text
   "<img style=\"max-width: 100%\" src=\"\\1\"/>"))

(defun replace-links (text)
  (cl-ppcre:regex-replace-all
   "\\[\\[(.*?)\\]\\[(.*?)\\]\\]"
   text
   "<a href=\"\\1\">\\2</a>"))

(defun replace-raw-urls (text)
  (cl-ppcre:regex-replace-all
   "(^| )(https?://.*?)[,.!]?( |$)"
   text
   "\\1<a href=\"\\2\">\\2</a>\\3"))

(defun replace-inline-code (text)
  (cl-ppcre:regex-replace-all
   "~(.*?)~"
   text
   "<code>\\1</code>"))

(defun replace-org-mode-markup-with-html (text)
  (replace-inline-code
   (replace-raw-urls
    (replace-links
     (replace-images
      text)))))

(defun render-text (text stream)
  (let ((buffer nil)
        (reading-quote nil)
        (reading-list nil))
    (labels
        ((write-paragraph ()
           (cl-who:with-html-output (stream)
             (:p (cl-who:str
                  ;; Here we don't escape the text, because
                  ;; it is from trusted source and will contain
                  ;; links to the images
                  (replace-org-mode-markup-with-html
                   (str:join " " (nreverse buffer))))))
           (write-char #\Newline stream)
           (setf buffer nil))
         (write-quote ()
           (cl-who:with-html-output (stream)
             (:blockquote
              (:pre
               (cl-who:esc
                (str:join #\Newline (nreverse buffer))))))
           (write-char #\Newline stream)
           (setf buffer nil))
         (write-list ()
           (cl-who:with-html-output (stream)
             (:ul
              (loop for item in (reverse buffer)
                    do (cl-who:htm
                        (:li (cl-who:str (replace-org-mode-markup-with-html item)))))))
           (write-char #\Newline stream)
           (setf buffer nil))
         (process (line)
           (cond
             ((and (str:starts-with-p "- " line)
                   (not reading-quote))
              (push (subseq line 2)
                    buffer)
              (setf reading-list t))
             ((and reading-list
                   (string= line ""))
              (write-list)
              (setf reading-list nil))
             (reading-list
              (setf buffer
                    (list*
                     (format nil "~A ~A"
                             (car buffer)
                             line)
                     (cdr buffer))))
             ((string-equal line
                            "#+BEGIN_QUOTE")
              (setf reading-quote t))
             ((string-equal line
                            "#+END_QUOTE")
              (setf reading-quote nil)
              (write-quote))
             ((not (string= line ""))
              (push line buffer))
             ((and (not reading-quote)
                   (and (string= line "")
                        buffer))
              (write-paragraph)))))
      (mapc #'process
            (str:split #\Newline text)))))

(defmethod render-node ((node cl-org-mode::text-node) stream)
  (render-text (cl-org-mode::node.text node)
               stream))

(defun make-output-filename (file)
  (check-type file file)
  (ppath:join "docs"
              (format nil "~A.html" (car (ppath:splitext (get-filename file))))))

(defmethod render-node ((file file) stream)
  (render-node (get-root file)
               stream))

(defun call-render-for-all-children (node stream)
  (loop for child in (cl-org-mode::node.children node)
        do (render-node child
                        stream)))

(defmethod render-node ((file cl-org-mode::org-file) stream)
  (call-render-for-all-children file stream))

(defun render-file (file)
  (with ((filename (make-output-filename file))
         (title (get-title file)))
    (ensure-directories-exist filename)

    (alexandria:with-output-to-file (stream filename :if-exists :supersede)
      (app-page (stream :index-uri "../../"
                        :title title)
        (cl-who:with-html-output (stream)
          (render-node file stream)
          (write-string "
<script src=\"https://utteranc.es/client.js\"
        repo=\"40ants/lisp-project-of-the-day\"
        issue-term=\"title\"
        label=\"comments\"
        theme=\"github-light\"
        crossorigin=\"anonymous\"
        async>
</script>
" stream))))))
  

(defun find-published-systems ()
  (let* ((file (cl-org-mode::read-org-file "README.org"))
         (years (loop for node = file then (cl-org-mode::node.next-node node)
                      while node
                      when (and (typep node 'cl-org-mode::outline-node)
                                (str:starts-with-p "20"
                                                   (cl-org-mode::node.heading node)))
                      collect node))
         (months (loop for year in years
                       appending (cl-org-mode::node.children year)))
         (text-nodes (loop for month in months
                           appending (cl-org-mode::node.children month)))
         (texts (loop for node in text-nodes
                      collect (cl-org-mode::node.text node)))
         (lines (loop for text in texts
                      appending (str:split #\Newline text))))
    (loop for line in lines
          when (and (str:starts-with-p "-" line)
                    ;; If there are two links, then the second link is to the twitter post.
                    ;; In this case this post is published.
                    (= (str:count-substring "[[" line)
                       2))
          appending (str:split " & "
                               (cl-ppcre:regex-replace
                                ".*?\\]\\[(.*?)\\].*"
                                line
                                "\\1")))))

(defun get-file-timestamp (file)
  (let* ((all-commits (with-output-to-string (*standard-output*)
                        (legit:git-log :paths (fmt "content/~A"
                                                   (get-filename file))
                                       :reverse t
                                       :format "%at %s")))
         (lines (str:split #\Newline all-commits))
         (first-timestamp
           (parse-integer (first (str:split #\Space
                                            (first lines))))))
    (local-time:unix-to-timestamp first-timestamp)))

(defun render-rss (files)
  (alexandria:with-output-to-file (stream "docs/rss.xml"
                                          :if-exists :supersede)
    (let ((base-url "http://40ants.com/lisp-project-of-the-day/")
          (published (find-published-systems)))
      (flet ((is-not-published (file)
               (let ((title (get-title file))
                     (filename (get-filename file)))
                 (or (not
                      (member title
                              published
                              :test #'string-equal))
                     (str:containsp "draft"
                                    filename)))))
        (xml-emitter:with-rss2 (stream)
          (xml-emitter:rss-channel-header "Common Lisp Project of the Day"
                                          base-url)
          (loop for file in (rutils:take 20 (reverse
                                             (remove-if #'is-not-published
                                                        files)))
                for title = (get-title file)
                for uri = (get-uri file)
                for full-url = (format nil "~A~A" base-url uri)
                for description = (make-description file)
                for timestamp = (get-file-timestamp file)
                do (xml-emitter:rss-item title
                                         :description description
                                         :link full-url
                                         :pubdate (local-time:format-rfc1123-timestring
                                                   nil timestamp))))))))

(defun strip-doc-folder (filename)
  "Removes doc/ from beginning of the filename"
  (cond
    ((str:starts-with-p "docs/" filename)
     (subseq filename 5))
    (t filename)))

(defun get-uri (file)
  "Returns a link like 2020/03/001-some.html"
  (strip-doc-folder (make-output-filename file)))


(defun get-title-for-index (file)
  (rutils:with ((title tags (get-title file))
                (filename (get-filename file))
                (splitted (ppath:split filename))
                (only-file (cdr splitted))
                (number (first (str:split #\- only-file))))
    (values title number tags)))

(defun title-to-systems (title)
  "Title may contain several systems, separated by &.
   Like \"skippy-renderer & zpng\".
   This function returns a list of separate systems."
  (mapcar #'str:trim
          (str:split "&" title)))
  
(defun render-index-page (files filename &key
                                           (index-uri nil)
                                           (path "docs")
                                           (title "Latest posts"))
  (let ((filename (ppath:join path
                              (rutils:fmt "~A.html"
                                          filename)))
        (published (find-published-systems)))
    (ensure-directories-exist filename)
    
    (flet ((is-not-published (file)
             (let* ((title (get-title file))
                    (systems (title-to-systems title)))
               (and (not (string= title "Day Zero"))
                    (loop for system in systems
                          never (member system
                                        published
                                        :test #'string-equal))))))
      (alexandria:with-output-to-file (stream filename :if-exists :supersede)
        (app-page (stream :index-uri index-uri)
          (:section :style "margin-left: auto; margin-right: auto; margin-top: 2em; width: 50%"
            (:h3 :style "margin-left: 1.6em"
                 title)
            (:table :class "posts"
                    (loop for file in (reverse files)
                          for uri = (get-uri file)
                          do (cl-who:htm
                              (:tr
                               (multiple-value-bind (title number tags)
                                   (get-title-for-index file)
                                  
                                 (unless (string-equal number
                                                       "draft")
                                   (cl-who:with-html-output (stream)
                                     (:td :class "number"
                                          (cl-who:esc (format nil "#~A" number)))
                                      
                                     (:td (:a :href (construct-uri uri)
                                              (cl-who:esc title)))

                                     (:td :class "tags"
                                          (loop for tag in tags
                                                do (cl-who:htm
                                                    (:a :href (construct-uri "tags/~A.html" tag)
                                                        (cl-bootstrap:bs-label ()
                                                          (cl-who:esc tag)))))
                                          (when (is-not-published file)
                                            (cl-bootstrap:bs-label-danger
                                              (cl-who:esc "draft")))))))))))))))
    (values)))


(defun render-index (files)
  (render-index-page files "index"))

(defun get-all-tags (files)
  (let (results)
    (iter outer
      (:for file :in files)
      (with ((_ tags (get-title file)))
        (declare (ignorable _))
        (iter (:for tag :in tags)
          (pushnew tag results :test #'string-equal))))
    results))

(defun get-files-with-tag (files tag)
  (iter (:for file :in files)
    (with ((_ tags (get-title file)))
      (declare (ignorable _))
      (when (member tag tags :test #'string-equal)
        (:collect file)))))

(defun render-tag (all-files tag)
  (render-index-page (get-files-with-tag all-files tag)
                     tag
                     :path "docs/tags/"
                     :index-uri "../"
                     :title (rutils:fmt "Posts with tag \"~A\""
                                        tag)))

(defun render-all-tag-pages (all-files)
  (mapcar (alexandria:curry #'render-tag all-files)
          (get-all-tags all-files)))

(defun render-patrons ()
  (let ((filename (ppath:join "docs"
                              "patrons"
                              "index.html"))
        (patrons '(("Jean-Philippe Paradis (Hexstream)" "https://www.hexstreamsoft.com/"))))
    (alexandria:with-output-to-file (stream filename :if-exists :supersede)
      (app-page (stream :index-uri "../")
        (:section :style " margin-left: auto; margin-right: auto; margin-top: 2em; width: 50%"
          (:h3 :style "margin-left: 1.6em"
               "Project Patrons")
          (:p "Special thanks to these people and companies supporting the project!")
          (:ul
           (loop for (name url) in patrons
                 do (cl-who:htm
                     (:li (:a :href url
                              (cl-who:esc name)))))))))
    (values)))

(defun render-site (&key (no-tags nil))
  (let ((files (read-files)))
    (mapc #'render-file files)
    (render-index files)
    (unless no-tags
      (render-all-tag-pages files))
    (render-patrons)
    (render-rss files)
    (values)))

(defun make-description (file)
  (let ((*rss-mode* t))
    (with-output-to-string (s)
      (render-node file s))))

(defclass lowercased-src-node (cl-org-mode::src-node)
         ()
         (:default-initargs 
          :opening-delimiter "#+begin_src"
          :closing-delimiter (format nil "~%#+end_src")
          :text nil
          :include-end-node nil))

(defmethod cl-org-mode::node-dispatchers ((node cl-org-mode::org-node))
  (or cl-org-mode::*dispatchers* 
      (mapcar #'make-instance '(lowercased-src-node
                                cl-org-mode::src-node
                                cl-org-mode::properties-node
                                cl-org-mode::outline-node))))

(defun pathname-to-string (p)
  (format nil "~A" p))

(defun install-all-quicklisp ()
  (loop with dist = (ql-dist:find-dist "quicklisp")
        with releases = (ql-dist:provided-releases dist)
        for release in releases
        do (ql-dist:install release)))

(defun get-software-dir ()
  (let ((dist (ql-dist:find-dist "quicklisp")))
    (ql-dist:relative-to dist
                         (make-pathname :directory
                                        (list :relative "software")))))

(defun grep-defsystem-depends ()
  "Returns lines produced by grep"
  (str:split #\Newline
             (with-output-to-string (s)
               (uiop:run-program (format nil "find ~A -name '*.asd' -print0 | xargs -0 grep -i defsystem-depends-on"
                                         (get-software-dir))
                                 :output s))))

(defun extract-systems (line)
  (when (str:contains? "defsystem-depends-on"
                       line)
    (loop with names = (str:words
                        (cl-ppcre:regex-replace
                         ".*:defsystem-depends-on.*\\((.*?)\\).*"
                         line
                         "\\1"))
          for name in names
          collect (string-trim "\":#"
                               name))))

(defun get-asdf-extensions (&key show-paths)
  (loop with result = (make-hash-table :test #'equal)
        for line in (grep-defsystem-depends)
        for systems = (extract-systems line)
        do (loop for system in systems
                 do (push line (gethash system result nil)))
        finally  (return
                   (loop with sorted = (sort (alexandria:hash-table-alist result)
                                             #'>
                                             :key (lambda (item)
                                                    (length (cdr item))))
                         for (system . lines) in sorted
                         collect (cons system (if show-paths
                                                  lines
                                                  (length lines)))))))