;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015 Ludovic Courtès ;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021, 2022 Efraim Flashner ;;; Copyright © 2018, 2019, 2020 Tobias Geerinckx-Rice ;;; Copyright © 2018 Mathieu Othacehe ;;; Copyright © 2020 Guillaume Le Vaillant ;;; Copyright © 2020 Vincent Legoll ;;; Copyright © 2020 Marius Bakke ;;; Copyright © 2021 Björn Höfling ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix 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. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even th
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services cgit)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages version-control)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services web)
  #:use-module (gnu services)
  #:use-module (gnu system shadow)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (repository-cgit-configuration
            cgit-configuration
            %cgit-configuration-nginx
            cgit-configuration-nginx-config
            opaque-cgit-configuration
            serialize-cgit-configuration
            cgit-service-type))

;;; Commentary:
;;;
;;; This module provides a service definition for the Cgit a web frontend for
;;; Git repositories written in C.
;;;
;;; Note: fields of <cgit-configuration> and <repository-cgit-configuration>
;;; should be specified in the specific order.
;;;
;;; Code:

(define %cgit-configuration-nginx
  (nginx-server-configuration
   (root cgit)
   (locations
    (list
     (nginx-location-configuration
      (uri "@cgit")
      (body '("fastcgi_param SCRIPT_FILENAME $document_root/lib/cgit/cgit.cgi;"
              "fastcgi_param PATH_INFO $uri;"
              "fastcgi_param QUERY_STRING $args;"
              "fastcgi_param HTTP_HOST $server_name;"
              "fastcgi_pass 127.0.0.1:9000;")))))
   (try-files (list "$uri" "@cgit"))
   (listen '("80"))
   (ssl-certificate #f)
   (ssl-certificate-key #f)))


;;;
;;; Serialize <cgit-configuration>
;;;

(define (uglify-field-name field-name)
  (string-delete #\? (symbol->string field-name)))

(define (serialize-field field-name val)
  #~(format #f "~a=~a\n" #$(uglify-field-name field-name) #$val))

(define (serialize-string field-name val)
  (if (and (string? val) (string=? val ""))
      ""
      (serialize-field field-name val)))

(define (serialize-list field-name val)
  (if (null? val) "" (serialize-field field-name (string-join val))))

(define robots-list? list?)

(define (serialize-robots-list field-name val)
  (if (null? val) "" (serialize-field field-name (string-join val ", "))))

(define (integer? val)
  (exact-integer? val))

(define (serialize-integer field-name val)
  (serialize-field field-name (number->string val)))

(define (serialize-boolean field-name val)
  (serialize-integer field-name (if val 1 0)))

(define (serialize-repository-cgit-configuration x)
  (serialize-configuration x repository-cgit-configuration-fields))

(define (repository-cgit-configuration-list? val)
  (list? val))

(define (serialize-repository-cgit-configuration-list field-name val)
  #~(string-append
     #$@(map serialize-repository-cgit-configuration val)))

(define (file-object? val)
  (or (file-like? val) (string? val)))
(define (serialize-file-object field-name val)
  (serialize-string field-name val))

(define (project-list? val)
  (or (list? val)
      (file-object? val)))


;;;
;;; Serialize <nginx-server-configuration>
;;;

(define (nginx-server-configuration-list? val)
  (and (list? val) (and-map nginx-server-configuration? val)))

(define (serialize-nginx-server-configuration-list field-name val)
  "")


;;;
;;; Serialize <repository-cgit-configuration>
;;;

(define (serialize-repo-field field-name val)
  #~(format #f "repo.~a=~a\n" #$(uglify-field-name field-name) #$val))

(define (serialize-repo-list field-name val)
  (if (null? val) "" (serialize-repo-field field-name (string-join val))))

(define repo-boolean? boolean?)

(define (serialize-repo-integer field-name val)
  (serialize-repo-field field-name (number->string val)))

(define (serialize-repo-boolean field-name val)
  (serialize-repo-integer field-name (if val 1 0)))
(define-maybe repo-boolean)

(define repo-list? list?)

(define repo-string? string?)

(define (serialize-repo-string field-name val)
  (if (string=? val "") "" (serialize-repo-field field-name val)))

(define repo-file-object? file-object?)
(define serialize-repo-file-object serialize-repo-string)

(define module-link-path? list?)

(define (serialize-module-link-path field-name val)
  (if (null? val) ""
      (match val
        ((path text)
         (format #f "repo.module-link.~a=~a\n" path text)))))

(define (serialize-project-list _ val)
  (if (null? val) ""
      (serialize-field
       'project-list
       (if (file-object? val)
           val
           (plain-file "project-list" (string-join val "\n"))))))

(define (serialize-extra-options extra-options)
  (string-join extra-options "\n" 'suffix))

(define repository-directory? string?)

(define (serialize-repository-directory _ val)
  (if (string=? val "") "" (format #f "scan-path=~a\n" val)))

(define mimetype-alist? list?)

(define (serialize-mimetype-alist field-name val)
  (format #f "# Mimetypes\n~a"
          (string-join
           (map (match-lambda
                  ((extension mimetype)
                   (format #f "mimetype.~a=~a"
                           (symbol->string extension) mimetype)))
                val) "\n")))

(define-configuration repository-cgit-configuration
  (snapshots
   (repo-list '())
   "A mask of snapshot formats for this repo that cgit generates links for,
restricted by the global @code{snapshots} setting.")
  (source-filter
   (repo-file-object "")
   "Override the default @code{source-filter}.")
  (url
   (repo-string "")
   "The relative URL used to access the repository.")
  (about-filter
   (repo-file-object "")
   "Override the default @code{about-filter}.")
  (branch-sort
   (repo-string "")
   "Flag which, when set to @samp{age}, enables date ordering in the branch
ref list, and when set to @samp{name} enables ordering by branch name.")
  (clone-url
   (repo-list '())
   "A list of URLs which can be used to clone repo.")
  (commit-filter
   (repo-file-object "")
   "Override the default @code{commit-filter}.")
  (commit-sort
   (repo-string "")
   "Flag which, when set to @samp{date}, enables strict date ordering in the
commit log, and when set to @samp{topo} enables strict topological ordering.")
  (defbranch
   (repo-string "")
   "The name of the default branch for this repository.  If no such branch
exists in the repository, the first branch name (when sorted) is used as
default instead.  By default branch pointed to by HEAD, or \"master\" if there
is no suitable HEAD.")
  (desc
   (repo-string "")
   "The value to show as repository description.")
  (homepage
   (repo-string "")
   "The value to show as repository homepage.")
  (email-filter
   (repo-file-object "")
   "Override the default @code{email-filter}.")
  (enable-commit-graph?
   maybe-repo-boolean
   "A flag which can be used to disable the global setting
@code{enable-commit-graph?}.")
  (enable-log-filecount?
   maybe-repo-boolean
   "A flag which can be used to disable the global setting
@code{enable-log-filecount?}.")
  (enable-log-linecount?
   maybe-repo-boolean
   "A flag which can be used to disable the global setting
@code{enable-log-linecount?}.")
  (enable-remote-branches?
   maybe-repo-boolean
   "Flag which, when set to @code{#t}, will make cgit display remote
branches in the summary and refs views.")
  (enable-subject-links?
   maybe-repo-boolean
   "A flag which can be used to override the global setting
@code{enable-subject-links?}.")
  (enable-html-serving?
   maybe-repo-boolean
   "A flag which can be used to override the global setting
@code{enable-html-serving?}.")
  (hide?
   (repo-boolean #f)
   "Flag which, when set to @code{#t}, hides the repository from the
repository index.")
  (ignore?
   (repo-boolean #f)
   "Flag which, when set to @samp{#t}, ignores the repository.")
  (logo
   (repo-file-object "")
   "URL which specifies the source of an image which will be used as a
logo on this repo’s pages.&q