;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define (add-to-load-path* directory)
  (unless (member directory %load-path)
    (add-to-load-path directory)))

(add-to-load-path* "/home/dave/Code/guile-syntax-highlight")

(use-modules (haunt asset)
             (haunt builder blog)
             (haunt builder atom)
             (haunt builder assets)
             (haunt html)
             (haunt page)
             (haunt post)
             (haunt reader)
             (haunt reader commonmark)
             (haunt site)
             (haunt utils)
             (commonmark)
             (syntax-highlight)
             (syntax-highlight scheme)
             (syntax-highlight xml)
             (syntax-highlight c)
             (sxml match)
             (sxml transform)
             (texinfo)
             (texinfo html)
             (srfi srfi-1)
             (srfi srfi-19)
             (ice-9 rdelim)
             (ice-9 regex)
             (ice-9 match)
             (web uri))

(define (date year month day)
  "Create a SRFI-19 date for the given YEAR, MONTH, DAY"
  (let ((tzoffset (tm:gmtoff (localtime (time-second (current-time))))))
    (make-date 0 0 0 0 day month year tzoffset)))

(define (stylesheet name)
  `(link (@ (rel "stylesheet")
            (href ,(string-append "/css/" name ".css")))))

(define (anchor content uri)
  `(a (@ (href ,uri)) ,content))

(define %cc-by-sa-link
  '(a (@ (href "https://creativecommons.org/licenses/by-sa/4.0/"))
      "Creative Commons Attribution Share-Alike 4.0 International"))

(define %cc-by-sa-button
  '(a (@ (class "cc-button")
         (href "https://creativecommons.org/licenses/by-sa/4.0/"))
      (img (@ (src "https://licensebuttons.net/l/by-sa/4.0/80x15.png")))))

(define %piwik-code
  '((script (@ (type "text/javascript") (src "/js/piwik.js")))
    (noscript
     (p (img (@ (src "//stats.dthompson.us/piwik.php?idsite=3")
                (style "border:0;")
                (alt "")))))))

(define (link name uri)
  `(a (@ (href ,uri)) ,name))

(define* (centered-image url #:optional alt)
  `(img (@ (class "centered-image")
           (src ,url)
           ,@(if alt
                 `((alt ,alt))
                 '()))))

(define (first-paragraph post)
  (let loop ((sxml (post-sxml post))
             (result '()))
    (match sxml
      (() (reverse result))
      ((or (('p ...) _ ...) (paragraph _ ...))
       (reverse (cons paragraph result)))
      ((head . tail)
       (loop tail (cons head result))))))

(define dthompson-theme
  (theme #:name "dthompson"
         #:layout
         (lambda (site title body)
           `((doctype "html")
             (head
              (meta (@ (charset "utf-8")))
              (title ,(string-append title " — " (site-title site)))
              ,(stylesheet "reset")
              ,(stylesheet "fonts")
              ,(stylesheet "dthompson"))
             (body
              (div (@ (class "container"))
                   (div (@ (class "nav"))
                        (ul (li ,(link "David Thompson" "/"))
                            (li (@ (class "fade-text")) " ")
                            (li ,(link "About" "/about.html"))
                            (li ,(link "Blog" "/index.html"))
                            (li ,(link "Projects" "/projects.html"))))
                   ,body
                   (footer (@ (class "text-center"))
                           (p (@ (class "copyright"))
                              "© 2016 David Thompson"
                              ,%cc-by-sa-button)
                           (p "The text and images on this site are
free culture works available under the " ,%cc-by-sa-link " license.")
                           (p "This website is built with "
                              (a (@ (href "http://haunt.dthompson.us"))
                                 "Haunt")
                              ", a static site generator written in "
                              (a (@ (href "https://gnu.org/software/guile"))
                                 "Guile Scheme")
                              "."))))))
         #:post-template
         (lambda (post)
           `((h1 (@ (class "title")),(post-ref post 'title))
             (div (@ (class "date"))
                  ,(date->string (post-date post)
                                 "~B ~d, ~Y"))
             (div (@ (class "post"))
                  ,(post-sxml post))))
         #:collection-template
         (lambda (site title posts prefix)
           (define (post-uri post)
             (string-append "/" (or prefix "")
                            (site-post-slug site post) ".html"))

           `((h1 ,title)
             ,(map (lambda (post)
                     (let ((uri (string-append "/"
                                               (site-post-slug site post)
                                               ".html")))
                       `(div (@ (class "summary"))
                             (h2 (a (@ (href ,uri))
                                    ,(post-ref post 'title)))
                             (div (@ (class "date"))
                                  ,(date->string (post-date post)
                                                 "~B ~d, ~Y"))
                             (div (@ (class "post"))
                                  ,(first-paragraph post))
                             (a (@ (href ,uri)) "read more ➔"))))
                   posts)))))

(define %collections
  `(("Recent Blog Posts" "index.html" ,posts/reverse-chronological)))

(define parse-lang
  (let ((rx (make-regexp "-*-[ ]+([a-z]*)[ ]+-*-")))
    (lambda (port)
      (let ((line (read-line port)))
        (match:substring (regexp-exec rx line) 1)))))

(define (maybe-highlight-code lang source)
  (let ((lexer (match lang
                 ('scheme lex-scheme)
                 ('xml    lex-xml)
                 ('c      lex-c)
                 (_ #f))))
    (if lexer
        (highlights->sxml (highlight lexer source))
        source)))

(define (sxml-identity . args) args)

(define (highlight-code . tree)
  (sxml-match tree
    ((code (@ (class ,class) . ,attrs) ,source)
     (let ((lang (string->symbol
                  (string-drop class (string-length "language-")))))
       `(code (@ ,@attrs)
             ,(maybe-highlight-code lang source))))
    (,other other)))

(define (highlight-scheme code)
  `(pre (code ,(highlights->sxml (highlight lex-scheme code)))))

(define (media-hackery . tree)
  (sxml-match tree
    ((img (@ (src ,src) . ,attrs) . ,body)
     (if (string-suffix? ".webm" src)
         `(video (@ (src ,src) (controls "true"),@attrs) ,@body)
         tree))))

(define %commonmark-rules
  `((code . ,highlight-code)
    (img . ,media-hackery)
    (*text* . ,(lambda (tag str) str))
    (*default* . ,sxml-identity)))

(define (post-process-commonmark sxml)
  (pre-post-order sxml %commonmark-rules))

(define commonmark-reader*
  (make-reader (make-file-extension-matcher "md")
               (lambda (file)
                 (call-with-input-file file
                   (lambda (port)
                     (values (read-metadata-headers port)
                             (post-process-commonmark
                              (commonmark->sxml port))))))))

(define (static-page title file-name body)
  (lambda (site posts)
    (make-page file-name
               (with-layout dthompson-theme site title body)
               sxml->html)))

(define* (project-page #:key name file-name description usage requirements
                       installation manual? license repo releases)
  (define body
    `((h1 ,name)
      ,description
      ,@(if usage
            `((h2 "Usage")
              ,usage)
            '())
      ,@(if manual?
         `((h2 "Documentation")
           (p ,(anchor "View the reference manual"
                       (string-append "/manuals/" repo "/index.html"))))
         '())
      (h2 "Releases")
      (ul ,(map (match-lambda
                  ((version date)
                   (let ((url (string-append "https://files.dthompson.us/"
                                             repo "/" repo "-" version
                                             ".tar.gz")))
                     `(li ,(date->string date "~Y-~m-~d")
                          " — " ,version " — "
                          ,(anchor (string-append repo "-" version ".tar.gz")
                                   url)
                          " — "
                          ,(anchor "GPG signature"
                                   (string-append url ".asc"))))))
                releases))
      (h2 "Requirements")
      (ul ,(map (lambda (requirement)
                  `(li ,requirement))
                requirements))
      (h2 "Installation")
      ,@(if installation
            (list installation)
            `((p ,name " uses the standard GNU build system.  "
                 "To build and install " ,name " from source, run:")
              (pre "./configure
make
make install")))
      (h2 "License")
      (p ,license)
      (h2 "Source Code")
      ,@(let ((url (string-append "https://git.dthompson.us/" repo ".git")))
          `((p ,name " is developed using the Git version control
system. The official repository is hosted at "
               ,(anchor url url))
            (h3 "Anonymous clone")
            (pre "git clone " ,url)))
      (h2 "Community")
      (p "Real-time discussion for " ,name " can be found on the "
         (code "#guile")
         " channel on the Freenode IRC network.")
      (h2 "Contributing")
      (p "Send patches and bug reports to "
         ,(anchor "davet@gnu.org" "mailto:davet@gnu.org")
         ".")))

  (static-page name (string-append "projects/" file-name) body))

(define about-page
  (static-page
   "About Me"
   "about.html"
   `((h2 "Hi.")
     (p "I am a professional software developer and free software
activist based in Massachusetts.")
     (p "I graudated from "
        ,(anchor "Worcester State University" "http://worcester.edu")
        " in 2012 with a BS in Computer Science.")
     (p "I am currently a web developer with a focus on operations
at "
        ,(anchor "Vista Higher Learning" "http://vistahigherlearning.com")
        ", and formerly a web developer at the "
        ,(anchor "Free Software Foundation." "https://fsf.org"))
     (p "You can follow me on "
        ,(anchor "GNU Social" "https://quitter.se/davexunit") " and "
        ,(anchor "Twitter" "https://twitter.com/davexunit") "."))))

(define projects-page
  (static-page
   "Projects"
   "projects.html"
   `((h1 "Projects")
     (p ,(anchor "Guile-SDL2" "projects/guile-sdl2.html")
        " — SDL2 bindings for Guile Scheme")
     (p ,(anchor "Haunt" "https://haunt.dthompson.us")
        " — Functional, hackable static site generator")
     (p ,(anchor "Shroud" "projects/shroud.html")
        " — GPG-based password manager")
     (p ,(anchor "Sly" "projects/sly.html")
        " — Functional reactive game engine")
     (p ,(anchor "srt2vtt" "projects/srt2vtt.html")
        " — SRT to WebVTT subtitle converter"))))

(define sly-page
  (project-page
   #:name "Sly"
   #:file-name "sly.html"
   #:description
   `((p "Sly is a fun, free software 2D/3D game engine written in "
        ,(anchor "Guile Scheme" "https://gnu.org/s/guile") ".")
     ,(centered-image "/images/sly/logo.png" "Sly fox mascot")
     (p "Sly differentiates itself from most other game engines by encouraging
and enabling the use of "
        ,(anchor "live coding"
                 "http://toplap.org/about/")
        " and "
        ,(anchor "functional reactive programming"
                 "https://en.wikipedia.org/wiki/Functional_reactive_programming")
        " techniques.  Sly provides a dynamic live coding environment
that allows games to be built interactively and iteratively without
ever stopping the running program.  A data structure called a “signal”
provides a method of modeling time-varying state that is declarative,
functional, and reactive.")
     (p ,(centered-image "/images/sly/2048.png"))
     (p ,(centered-image "/images/sly/mines.png")))
   #:requirements '("GNU Guile >= 2.0.11"
                    "guile-opengl_ >= 0.1.0"
                    "guile-sdl_ >= 0.5.0"
                    "SDL 1.2.x"
                    "FreeImage >= 3.0"
                    "GNU Scientific Library (GSL)")
   #:license "GNU GPLv3+"
   #:repo "sly"
   #:manual? #t
   #:releases
   `(("0.1" ,(date 2015 11 12)))))

(define guile-sdl2-page
  (project-page
   #:name "Guile-SDL2"
   #:file-name "guile-sdl2.html"
   #:repo "guile-sdl2"
   #:description
   `((p "Guile-SDL2 provides "
        ,(anchor "Guile Scheme" "https://gnu.org/s/guile")
        " bindings for the "
        ,(anchor "SDL2" "http://libsdl.org")
        " C shared library.  The bindings are written in pure Scheme
using Guile's foreign function interface."))
   #:usage
   `((p "Guile-SDL2 provides modules in the "
        (code "(sdl2 ...)")
        " namespace, roughly organized how the SDL2 C header files are
organized.  Low-level bindings are available in the"
        (code "(sdl2 bindings ...)")
        " namespace, bu these are not recommended for normal usage.")
     (p "Additionally, SDL2 extension library bindings are available in the
following modules:")
     (ul (li "SDL2_image: " (code "(sdl2 image)"))
         (li "SDL2_mixer: " (code "(sdl2 mixer)"))
         (li "SDL2_ttf: " (code "(sdl2 ttf)")))
     (p "Here is a short “hello, world” example program:")
     ,(highlight-scheme
       "(use-modules (sdl2)
             (sdl2 render)
             (sdl2 surface)
             (sdl2 video))

(define (draw ren)
  (let* ((surface (load-bmp \"hello.bmp\"))
         (texture (surface->texture ren surface)))
    (clear-renderer ren)
    (render-copy ren texture)
    (present-renderer ren)
    (sleep 2)))

(sdl-init)

(call-with-window (make-window)
  (lambda (window)
    (call-with-renderer (make-renderer window) draw)))

(sdl-quit)"))
   #:requirements '("GNU Guile >= 2.0.9"
                    "SDL2 >= 2.0.0"
                    "SDL2_image >= 2.0.0"
                    "SDL2_mixer >= 2.0.0"
                    "SDL2_ttf >= 2.0.0"
                    "GNU Make"
                    "GNU pkg-config")
   #:license "GNU LGPLv3+"
   #:releases
   `(("0.1.2" ,(date 2016 08 10))
     ("0.1.1" ,(date 2016 01 01))
     ("0.1.0" ,(date 2015 12 22)))))

(define shroud-page
  (project-page
   #:name "Shroud"
   #:file-name "shroud.html"
   #:repo "shroud"
   #:description
   `((p "Shroud is a simple secret manager with a command line interface.")
     (p "The password database is stored as a Scheme s-expression
and encrypted with a "
           ,(anchor "GnuPG" "https://gnupg.org")
           " key.  Secrets consist of an arbitrary number of key/value
pairs, making Shroud suitable for more than just password storage.
For copying and pasting secrets into web browsers and other graphical
applications, there is xclip integration."))
   #:requirements '("GNU Guile >= 2.0.9"
                    "GnuPG >= 1.4"
                    "GNU Make"
                    "GNU pkg-config"
                    ("optional: xclip is needed for the "
                     (code "-c")
                     " flag of "
                     (code "shroud show")
                     " to work"))
   #:usage
   `((p "First, create a " (code ".shroud")
        " file in your home directory to hold your
configuration settings.  All you really need to set here is your GPG
user ID i.e. your email address:")
     ,(highlight-scheme
       "'((user-id . \"foo@example.com\"))")
     (p "The "
        (code ".shroud")
        " file is Scheme source code, so any expression that evaluates
to an alist of valid configuration settings is usable by Shroud.")
     (p "Once Shroud is configured, try out the following commands to
get a feel for how things work:")
     (pre
       "# Add a new secret:
shroud hide bank-account username=foobar password=hackme

# Edit an existing secret:
shroud hide --edit bank-account password=hackmepls

# List all secrets:
shroud list

# Show all key/value pairs for a saved secret:
shroud show bank-account

# Show a single value in a secret:
shroud show bank-account password

# Copy a password directly to X clipboard:
shroud show -c bank-account password

# Delete a secret:
shroud remove bank-account")
     (p "Happy shrouding!"))
   #:license "GNU GPLv3+"
   #:releases
   `(("0.1.1" ,(date 2015 10 01))
     ("0.1.0" ,(date 2015 09 29)))))

(define srt2vtt-page
  (project-page
   #:name "srt2vtt"
   #:file-name "srt2vtt.html"
   #:repo "srt2vtt"
   #:description
   `((p "Convert SRT formatted subtitles to WebVTT format for use with
the HTML5 "
        (code "<track>") " tag."))
   #:requirements '("GNU Guile >= 2.0.5")
   #:usage
   `((pre
      "$ srt2vtt --help
Usage: srt2vtt [OPTIONS]
Convert SubRip formatted subtitles to WebVTT format.

  -h, --help             display this help and exit
  -v, --version          display version and exit
  -i, --input=FILE-NAME  read input from FILE-NAME
  -o, --output=FILE-NAME write output to FILE-NAME")
     (p "If " (code "--input")
        " or " (code "--output")
        " is ommitted, read from stdin or stdout, respectively."))
   #:license "GNU GPLv3+"
   #:releases
   `(("0.1" ,(date 2015 02 7)))))

(site #:title "dthompson"
      #:domain "dthompson.us"
      #:default-metadata
      '((author . "David Thompson")
        (email  . "davet@gnu.org"))
      #:readers (list commonmark-reader*)
      #:builders (list (blog #:theme dthompson-theme #:collections %collections)
                       (atom-feed)
                       (atom-feeds-by-tag)
                       about-page
                       projects-page
                       sly-page
                       guile-sdl2-page
                       shroud-page
                       srt2vtt-page
                       (static-directory "css")
                       (static-directory "fonts")
                       (static-directory "images")
                       (static-directory "videos")
                       (static-directory "src")
                       (static-directory "manuals")))