;;; guix-forge --- Guix software forge meta-service
;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of guix-forge.
;;;
;;; guix-forge 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.
;;;
;;; guix-forge 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 guix-forge.  If not, see
;;; <https://www.gnu.org/licenses/>.

(define-module (forge cgit)
  #:use-module (forge environment)
  #:use-module (forge fcgiwrap)
  #:use-module (forge nginx)
  #:use-module (forge socket)
  #:use-module ((gnu packages emacs) #:select (emacs-minimal))
  #:use-module ((gnu packages mail) #:select (mailcap))
  #:use-module ((gnu packages version-control)
                #:select (cgit git-minimal))
  #:use-module (gnu services)
  #:use-module ((gnu services web) #:select (nginx-server-configuration
                                             nginx-location-configuration))
  #:use-module (gnu system file-systems)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (%cgit-readme
            <cgit-configuration>
            cgit-configuration
            cgit-configuration?
            cgit-configuration-cgit
            cgit-configuration-git
            cgit-configuration-server-name
            cgit-configuration-repository-directory
            cgit-configuration-socket
            cgit-configuration-readme
            cgit-configuration-snapshots
            cgit-configuration-about-filter
            cgit-configuration-commit-filter
            cgit-configuration-email-filter
            cgit-configuration-source-filter
            cgit-configuration-mimetype-file
            cgit-configuration-repository-sort
            cgit-configuration-plain-email?
            cgit-configuration-extra-options
            cgit-service-type))

(define %cgit-readme
  (append (list "README.md" "README.markdown" "README.mdown" "README.mkd"
                "README.org" "README.rst")
          ;; man page READMEs
          (map (lambda (n)
                 (string-append "README." (number->string n)))
               (iota 9 1))
          (list "README.htm" "README.html"
                "README.txt"
                "README")))

(define-record-type* <cgit-configuration>
  cgit-configuration make-cgit-configuration
  cgit-configuration?
  this-cgit-configuration
  (cgit cgit-configuration-cgit
        (default cgit))
  (git cgit-configuration-git
       (default git-minimal))
  (server-name cgit-configuration-server-name)
  (repository-directory cgit-configuration-repository-directory
                        (default "/srv/git"))
  (socket cgit-configuration-socket
          (default (forge-unix-socket
                    (path "/var/run/fcgiwrap/cgit/socket"))))
  ;; TODO: Support org mode and gemtext READMEs too.
  (readme cgit-configuration-readme
          (default %cgit-readme))
  (snapshots cgit-configuration-snapshots
             (default (list "tar.gz"))
             (sanitize sanitize-cgit-snapshots))
  (about-filter cgit-configuration-about-filter
                (default (program-file "about-filter"
                                       (about-filter-gexp this-cgit-configuration)))
                (thunked))
  (commit-filter cgit-configuration-commit-filter
                 (default #f))
  (email-filter cgit-configuration-email-filter
                (default #f))
  (source-filter cgit-configuration-source-filter
                 (default (file-append (cgit-configuration-cgit
                                        this-cgit-configuration)
                                       "/lib/cgit/filters/syntax-highlighting.py"))
                 (thunked))
  (mimetype-file cgit-configuration-mimetype-file
                 (default (file-append mailcap "/etc/mime.types")))
  (repository-sort cgit-configuration-repository-sort
                   (default 'age)
                   (sanitize sanitize-cgit-repository-sort))
  (plain-email? cgit-configuration-noplainemail?
                (default #false))
  (extra-options cgit-configuration-extra-options
                 (default '())))

(define (sanitize-cgit-snapshots snapshots)
  (let ((valid-snapshots (list "tar" "tar.gz" "tar.bz2" "tar.lz"
                               "tar.xz" "tar.zst" "zip")))
    (for-each (lambda (snapshot)
                (unless (member snapshot valid-snapshots)
                  (leave (G_ "Snapshot ~a is not one of ~s.~%"
                             snapshot
                             valid-snapshots))))
              snapshots)
    snapshots))

(define (sanitize-cgit-repository-sort repository-sort)
  (case repository-sort
    ((name age) repository-sort)
    (else
     (leave (G_ "Invalid cgit repository-sort '~s. It should either be 'age or 'name.~%")
            repository-sort))))

(define (about-filter-gexp config)
  "Return G-expression for a cgit about-filter. Use cgit package
configured in @var{config}."
  (match-record config <cgit-configuration>
    (cgit)
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils)
                       (ice-9 match)
                       (srfi srfi-1))

          (match (command-line)
            ((_ about-file)
             (cond
              ((or (string-suffix-ci? ".markdown" about-file)
                   (string-suffix-ci? ".mdown" about-file)
                   (string-suffix-ci? ".md" about-file)
                   (string-suffix-ci? ".mkd" about-file))
               (invoke #$(file-append cgit "/lib/cgit/filters/html-converters/md2html")
                       about-file))
              ((string-suffix-ci? ".org" about-file)
               (invoke #$(file-append emacs-minimal "/bin/emacs")
                       "--script"
                       #$(local-file "org2html.el")))
              ((string-suffix-ci? ".rst" about-file)
               (invoke #$(file-append cgit "/lib/cgit/filters/html-converters/rst2html")
                       about-file))
              ((any (lambda (n)
                      (string-suffix-ci? (string-append "." (number->string n))
                                         about-file))
                    (iota 9 1))
               (invoke #$(file-append cgit "/lib/cgit/filters/html-converters/rst2html")
                       about-file))
              ((or (string-suffix-ci? ".htm" about-file)
                   (string-suffix-ci? ".html" about-file))
               (put-bytevector (current-output-port)
                               (call-with-input-file about-file
                                 get-bytevector-all)))
              (else
               (invoke #$(file-append cgit "/lib/cgit/filters/html-converters/txt2html")
                       about-file)))))))))

(define (cgitrc-gexp config)
  "Return G-expression to serialize @var{config} into cgitrc."
  (match-record config <cgit-configuration>
    (repository-directory
     readme snapshots
     about-filter commit-filter email-filter source-filter
     mimetype-file repository-sort plain-email? extra-options)
    #~(begin
        (use-modules (ice-9 match))
        
        (call-with-output-file #$output
          (lambda (port)
            (for-each (match-lambda
                        ((key #t)
                         (format port "~a=1~%" key))
                        ((key #f)
                         (format port "~a=0~%" key))
                        ((key value)
                         (format port "~a=~a~%" key value)))
                      '#$(append (map (lambda (file)
                                        (list "readme" (string-append ":" file)))
                                      readme)
                                 (if about-filter
                                     `(("about-filter" ,about-filter))
                                     (list))
                                 (if commit-filter
                                     `(("commit-filter" ,commit-filter))
                                     (list))
                                 (if email-filter
                                     `(("email-filter" ,email-filter))
                                     (list))
                                 (if source-filter
                                     `(("source-filter" ,source-filter))
                                     (list))
                                 (if mimetype-file
                                     `(("mimetype-file" ,mimetype-file))
                                     (list))
                                 ;; The order of settings in cgitrc is
                                 ;; significant.
                                 `(("snapshots" ,(string-join snapshots))
                                   ("repository-sort" ,(symbol->string repository-sort))
                                   ("noplainemail" ,(not plain-email?))
                                   ("enable-index-owner" #f)
                                   ("virtual-root" "/")
                                   ,@(map (match-lambda
                                            ((key . value)
                                             (list key value)))
                                          extra-options)
                                   ("scan-path" ,repository-directory)))))))))

(define (cgit-fcgiwrap-instance config)
  (match-record config <cgit-configuration>
    (cgit git repository-directory)
    (let ((cgitrc (computed-file "cgitrc" (cgitrc-gexp config))))
      (fcgiwrap-instance
       (name "cgit")
       (user "nginx")
       (group "nginx")
       (environment-variables (list (environment-variable
                                     (name "CGIT_CONFIG")
                                     (value cgitrc))))
       (mappings (list (file-system-mapping
                        (source repository-directory)
                        (target source))
                       (file-system-mapping
                        (source cgit)
                        (target source))
                       (file-system-mapping
                        (source cgitrc)
                        (target source))
                       (file-system-mapping
                        (source (file-append git "/libexec/git-core/git-http-backend"))
                        (target source))))))))

(define cgit-nginx-server-block
  (match-record-lambda <cgit-configuration>
      (cgit git server-name socket repository-directory)
    (nginx-server-configuration
     (server-name (list server-name))
     ;; cgit static files
     (root (file-append cgit "/share/cgit"))
     (try-files (list "$uri" "@cgit"))
     (locations
      (list
       ;; git-http-backend for the smart HTTP protocol
       (nginx-location-configuration
        (uri "~ ^/.*/(HEAD|info/refs|git-receive-pack|git-upload-pack).*$")
        (body (list "fastcgi_param SCRIPT_FILENAME "
                    (file-append git "/libexec/git-core/git-http-backend;")
                    (string-append "fastcgi_param GIT_PROJECT_ROOT "
                                   repository-directory
                                   ";")
                    "fastcgi_param GIT_HTTP_EXPORT_ALL yes;"
                    "fastcgi_param PATH_INFO $uri;"
                    "fastcgi_param QUERY_STRING $query_string;"
                    "fastcgi_param REQUEST_METHOD $request_method;"
                    "fastcgi_param CONTENT_TYPE $content_type;"
                    (string-append "fastcgi_pass "
                                   (nginx-socket->string socket)
                                   ";"))))
       ;; cgit web interface
       (nginx-location-configuration
        (uri "@cgit")
        (body (list
               #~(string-append "fastcgi_param SCRIPT_FILENAME "
                                #$(file-append cgit "/lib/cgit/cgit.cgi")
                                ";")
               "fastcgi_param PATH_INFO $uri;"
               "fastcgi_param QUERY_STRING $query_string;"
               "fastcgi_param HTTP_HOST $server_name;"
               (string-append "fastcgi_pass "
                              (nginx-socket->string socket)
                              ";")))))))))

(define cgit-service-type
  (service-type
   (name 'cgit)
   (description "Run cgit.")
   (extensions (list (service-extension fcgiwrap-service-type
                                        (compose list cgit-fcgiwrap-instance))
                     (service-extension forge-nginx-service-type
                                        (compose list cgit-nginx-server-block))))))