8sync-website/haunt.scm

;;; 8sync's website
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.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/>.

(use-modules (ice-9 match)
             (haunt asset)
             (haunt html)
             (haunt site)
             (haunt page)
             (haunt post)
             (haunt builder blog)
             (haunt builder atom)
             (haunt builder assets)
             (haunt reader)
             (haunt reader skribe)
             (syntax-highlight)
             (syntax-highlight scheme))


;;; Utilities
;;; ---------

(define %site-prefix (make-parameter ""))

(define (prefix-url url)
  (string-append (%site-prefix) url))



;;; Latest release info
;;; -------------------

(define latest-version "0.1.0")
(define main-download-url "ftp://ftp.gnu.org/gnu/8sync/")
(define latest-filename
  (string-append "8sync-"
                 latest-version
                 ".tar.gz"))
(define latest-release-url
  (string-append main-download-url
                 latest-filename))
(define latest-release-sig-url
  (string-append latest-release-url
                 ".sig"))



;;; Templates
;;; ---------

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

(define (base-image image alt)
  `(img (@ (src ,(prefix-url (string-append "/images/" image)))
           (alt ,alt))))

(define header-menu
  '(("docs" "/docs/")
    ("download" "/download/")
    ("community" "/community/")
    ("news" "/news/")))

(define* (base-layout site body
                      #:key title big-logo)
  `((doctype "html")
    (head
     (meta (@ (charset "utf-8")))
     (title ,(if title
                 (string-append title " -- 8sync")
                 (site-title site)))
     ;; css
     (link (@ (rel "stylesheet")
              (href ,(prefix-url "/css/main.css"))))
     (link (@ (rel "stylesheet")
              (href ,(prefix-url "/css/code.css"))))
     ;; atom feed
     (link (@ (rel "alternate")
              (title "8sync news")
              (type "application/atom+xml")
              (href ,(prefix-url "/feed.xml")))))
    (body
     (div (@ (class "main-wrapper"))
          (header (@ (id "site-header"))
                  ;; 8sync logo
                  (div (@ (class "header-logo-wrapper"))
                       (a (@ (href ,(prefix-url "/"))
                             (class "8sync-header-logo"))
                          ,(base-image ;; "8sync-logo-header.png"
                            (if big-logo
                                "8sync-logo-500px.png"
                                "8sync-logo-300px.png")
                            "8sync logo")))
                  ;; Header menu
                  (div (@ ,(if big-logo
                               '(class "navbar-menu big-navbar")
                               '(class "navbar-menu small-navbar")))
                       ,@(map
                          (lambda (item)
                            (match item
                              ((name url)
                               `(div
                                 (a (@ (href ,(prefix-url url)))
                                    ,name)))))
                          header-menu)))
          (div (@ (class "site-main-content"))
               ,body))
     ;; TODO: Link to source.
     (div (@ (class "footer"))
          (a (@ (href "https://notabug.org/cwebber/8sync-website"))
             "Site contents")
          " dual licensed under "
          (a (@ (href "https://creativecommons.org/licenses/by-sa/4.0/"))
             "Creative Commons 4.0 International")
          " and "
          (a (@ (href "http://www.gnu.org/licenses/gpl-3.0.en.html"))
             "the GNU GPL, version 3 or any later version")
          ".  Powered by "
          (a (@ (href "http://haunt.dthompson.us/"))
             "Haunt")
          "."))))

(define* (post-template post #:key post-link)
  `(div (@ (class "content-box blogpost"))
        (h1 (@ (class "title"))
            ,(if post-link
                 `(a (@ (href ,post-link))
                     ,(post-ref post 'title))
                 (post-ref post 'title)))
        (div (@ (class "post-about"))
             (span (@ (class "by-line"))
                   ,(post-ref post 'author))
             " -- " ,(date->string* (post-date post)))
        (div (@ (class "post-body"))
             ,(post-sxml post))))

(define (collection-template site title posts prefix)
  ;; In our case, we ignore the prefix argument because
  ;; the filename generated and the pathname might not be the same.
  ;; So we use (prefix-url) instead.
  (define (post-uri post)
    (prefix-url
     (string-append "/news/" (site-post-slug site post) ".html")))
  `((div (@ (class "news-header"))
         (h3 "recent news"))
    (div (@ (class "post-list"))
         ,@(map
            (lambda (post)
              (post-template post
                             #:post-link (post-uri post)))
            posts))))

(define 8sync-haunt-theme
  (theme #:name "8sync"
         #:layout
         (lambda (site title body)
           (base-layout
            site body
            #:title title
            #:big-logo #f))
         #:post-template post-template
         #:collection-template collection-template))



;;; Plain content pages
;;; -------------------

(define code-snippet
  (string-join
   '("(define (site-user-view request db-conn)"
     "  \"Display a list of all users registered on this site\""
     "  (htmlize-response"
     "   (list-users-template"
     "    #:request request"
     "    ;; Wrapping in 8sync \"suspends\" this function, running"
     "    ;; fetch-active-users asynchronously, and \"wakes up\" the function"
     "    ;; when ready, seamlessly passing back its result."
     "    #:users (8sync"
     "             (fetch-active-users db-conn)))")
   "\n"))

(define (index-content posts)
  `(div
    ;; Main intro
    (div (@ (class "content-box bigger-text"))
         (h2 (@ (class "title"))
             "What's 8sync?")
         (p "8sync (pronounced \"eight-sync\") is an asynchronous "
            "programming library for "
            (a (@ (href "http://www.gnu.org/software/guile/"))
               "GNU Guile")
            ". It makes use of "
            (a (@ (href "https://www.gnu.org/software/guile/manual/html_node/Prompts.html"))
               "delimited continuations")
            " to avoid a mess of callbacks "
            "resulting in clean, easy to read non-blocking code.")
         (div (@ (class "code"))
              ,(highlights->sxml
                (highlight lex-scheme code-snippet))))
    ;; Video
    ;; News updates and etc
    ))

(define (index-page site posts)
  (make-page
   "index.html"
   (base-layout site
                (index-content posts)
                #:big-logo #t)
   sxml->html))

(define (docs-content posts)
  `(div (@ (class "content-box"))
        (h1 (@ (class "title"))
            "Documentation")
        (p
         "We haven't done a formal export yet! :) "
         "I suppose in the meanwhile we should add an appropriately oldschool "
         (a (@ (href "http://www.textfiles.com/underconstruction/"))
            "under construction gif")
         " here...")
        (p
         "In the meanwhile, you can read a "
         (a (@ (href "http://dustycloud.org/tmp/8sync-tutorial-part1.html"))
            "work in progress tutorial")
         ".")))

(define (docs-page site posts)
  (make-page
   "docs/index.html"
   (base-layout site
                (docs-content posts)
                #:big-logo #f)
   sxml->html))

(define (download-content posts)
  `(div (@ (class "content-box"))
        (h1 (@ (class "title"))
            "Download")
        (ul
         (li "Download the latest 8sync release: "
             (a (@ (href ,latest-release-url))
                ,latest-filename)
             " (" (a (@ (href ,latest-release-sig-url))
                    "signature") ")")
         (li "See "
             (a (@ (href ,main-download-url))
                "all 8sync releases")))

        (p "For the latest code, we are "
           (a (@ (href "https://savannah.gnu.org/projects/8sync"))
              "hosted on Savannah. ")
           "Pull down our git repo:")
        (div (@ (class "code"))
             "git clone git://git.savannah.gnu.org/8sync.git")))

(define (download-page site posts)
  (make-page
   "download/index.html"
   (base-layout site
                (download-content posts)
                #:big-logo #f)
   sxml->html))

(define (community-content posts)
  `(div (@ (class "content-box"))
        (h1 (@ (class "title"))
            "Community")
        (p "Want to get involved in 8sync development? "
           "(Contributions of all kind are welcome!) "
           "Or maybe you're just a user looking for some help? "
           "We'd love to hear from you!")

        (ul
         (li (b "IRC:")
             " Chat with us on " (b "irc.freenode.net") " in "
             (a (@ (href "http://webchat.freenode.net/?channels=guile"))
                "#guile")
             " and "
             (a (@ (href "http://webchat.freenode.net/?channels=8sync"))
                "#8sync")
             ".")
         (li (b "Email:")
             " For now we're using the "
             (a (@ (href "https://lists.gnu.org/mailman/listinfo/guile-user"))
                "guile-user mailing list")
             " for most communication. "
             "You can also send patches there. "
             "Maybe in the future we'll get our own mailing lists..."))))

(define (community-page site posts)
  (make-page
   "community/index.html"
   (base-layout site
                (community-content posts)
                #:big-logo #f)
   sxml->html))



;;; Site constructor
;;; ----------------

(define* (make-site #:key
                    site-prefix
                    (build-directory "site"))
  (if site-prefix
      (%site-prefix site-prefix))
  (site #:title "8sync: Asynchronous Programming Made Awesome"
        #:domain "8sync.org"
        #:default-metadata
        '((author . "Christopher Allan Webber")
          (email . "cwebber@dustycloud.org"))
        #:readers (list (make-skribe-reader
                         #:modules '((haunt skribe utils)
                                     (skribe-utils))))
        #:build-directory build-directory
        #:builders (list (blog #:theme 8sync-haunt-theme
                               #:prefix "/news")
                         index-page
                         docs-page
                         download-page
                         community-page
                         (atom-feed #:blog-prefix (prefix-url "/news"))
                         (atom-feeds-by-tag #:blog-prefix (prefix-url "/news"))
                         (static-directory "static/images" "images")
                         (static-directory "static/css" "css")
                         ;;; Not sure we'll ever need this
                         ;; (static-directory "static/js" "js")
                         (static-directory "static/fonts" "fonts"))))

(make-site)