*.go

*.log

configure

config.status

Makefile

Makefile.in

aclocal.m4

autom4te.cache

install-sh

missing

pre-inst-env

scripts/gitile

# Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

#

# This library is free software; you can redistribute it and/or

# modify it under the terms of the GNU Lesser General Public

# License as published by the Free Software Foundation; either

# version 3 of the License, or (at your option) any later version.

#

# This library 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

# Lesser General Public License for more details.

#

# You should have received a copy of the GNU Lesser General Public

# License along with this library; if not, write to the Free Software

# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

include guile.am

SOURCES= \

    gitile/config.scm \

    gitile/handler.scm \

    gitile/pages.scm \

    gitile/repo.scm

clean-go:

	find . -name '*.go' -delete

autoreconf -fiv

#                                               -*- Autoconf -*-

# Process this file with autoconf to produce a configure script.

AC_PREREQ([2.69])

AC_INIT([social], [0.1], [julien@lepiller.eu])

AM_INIT_AUTOMAKE([-Wall -Werror foreign])

AC_CONFIG_MACRO_DIR([m4])

# Checks for programs.

GUILE_SITE_DIR

GUILE_PROGS

# Checks for libraries.

GUILE_MODULE_AVAILABLE([have_git], [(git)])

if test "x$have_git" != "xyes"; then

  AC_MSG_ERROR([The Guile bindings of libgit2 are missing; please install them.])

fi

GUILE_MODULE_AVAILABLE([have_gnutls], [(gnutls)])

if test "x$have_gnutls" != "xyes"; then

  AC_MSG_ERROR([The Guile bindings of GnuTLS are missing; please install them.])

fi

GUILE_MODULE_AVAILABLE([have_fibers], [(fibers web server)])

if test "x$have_fibers" != "xyes"; then

  AC_MSG_ERROR([The Guile Fibers library is missing; please install it.])

fi

AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])

AC_CONFIG_FILES([scripts/gitile], [chmod +x scripts/gitile])

AC_CONFIG_FILES(Makefile)

AC_OUTPUT

	    <config>

(define-record-type <config>

  #:use-module (gitile config)

  #:use-module (sxml simple)

             (li (a (@ (href "/" ,project)) "Repository"))

             (li (a (@ (href "/" ,project "/tree/" ,ref)) "Files"))

             (li (a (@ (href "/" ,project "/commits")) "Commits"))

             (li (a (@ (href "/" ,project "/tags")) "Tags")))))

    (let ((repo (string-append (config-repositories config)

                               "/" name ".git")))

      (pk 'repo repo)

      (pk 'exists (file-exists? (string-append repo "/git-daemon-export-ok")))

      (if (file-exists? (string-append repo "/git-daemon-export-ok"))

          (repository-open repo)

          #f)))

    (($ <config> port host database repositories)

         ((project-name)

          (show (style (project-index project-name (get-repo project-name))

                       project-name "-")))

          (show (style (project-files project-name (get-repo project-name)

				      #:ref ref #:path path)

          (show (style (project-commits project-name (get-repo project-name) #f)

		       project-name "-")))

          (show (style (project-commits project-name (get-repo project-name) ref)

		       project-name ref)))

         ((project-name "commit" ref)

          (show (style not-yet-page project-name "-")))

	 (_ (not-found request)))))))

  #:use-module (git)

  #:use-module (git types)

  #:use-module (ice-9 match)

  #:use-module (rnrs bytevectors)

  #:use-module (srfi srfi-19); date/time

  #:use-module (system foreign)

            project-files

            project-index

	    project-commits))

  `((p "Not yet available, sorry :/")))

(define* (project-file-raw repo path #:key (ref "-"))

  (let* ((ref (if (equal? ref "-") #f ref))

         (path (if (list? path)

                   (string-join

                     (filter (lambda (p) (not (string-null? p))) path)

                     "/")

                   path)))

    (get-file-content repo path #:ref ref)))

(define* (project-files repository-name repo #:key (ref "-") (path '()))

  (let* ((ref (if (equal? ref "-") #f ref))

         (path (if (list? path)

                   (string-join

                     (filter (lambda (p) (not (string-null? p))) path)

                     "/")

                   path))

         (dir-path (if (string-null? path) path (string-append path "/")))

         (files (sort (get-files repo #:ref ref #:path dir-path)

                      (lambda (f1 f2)

                        (string<=? (file-name f1) (file-name f2))))))

    (pk 'path dir-path)

    (pk 'files files)

            `((p (@ (class "content")) "file content")

              (pre ,(pk (utf8->string (get-file-content repo path #:ref ref)))))

            `(,(last-commit-infobox repository-name repo ref)

              (table

                (thead

                  (tr

                    (td "name")

                    (td "last commit")

                    (td "date")))

                (tbody

                 ,@(map

                     (match-lambda

                       (($ <file> name type commit)

                        (let ((name (if (= type 2) (string-append name "/") name)))

                          `(tr (td (a (@ (href "/" ,repository-name

                                               "/tree/" ,(or ref "-")

                                               "/" ,path "/" ,name))

                                      (img (@ (src "/images/file-type-" ,type ".png")))

                                      ,name))

                               (td (a (@ (href "/" ,repository-name

                                               "/commit/" ,(oid->string

							     (commit-id commit))))

                                      ,(commit-message commit)))

                               (td ,(commit->date-string commit))))))

                     files))))))))

(define get-config-string

  (let ((proc (libgit2->procedure int "git_config_get_string" '(* * *))))

    (lambda (config name)

      (let ((out (make-double-pointer)))

        (proc out (config->pointer config) (string->pointer name))

        (pointer->string out)))))

(define (project-index repository-name repo)

  `((h1 ,repository-name)

    (p ,(get-config-string (repository-config repo)

                           "gitweb.description"))

    ,(project-files repository-name repo)))

(define (author-image author)

  "/images/unknown.png")

(define (commit->date-string commit)

  (date->string

    (time-utc->date

      (make-time time-utc 0 (commit-time commit)))))

(define (last-commit-infobox repository-name repo ref)

  (let* ((ref (if (equal? ref "-") #f ref))

         (commit (last-commit repo ref)))

    (commit-infobox repository-name commit)))

(define (commit-infobox repository-name commit)

  `(div (@ (class "commit-info"))

     (p (img (@ (src ,(author-image (commit-author commit))))))

     (div (@ (class "commit"))

       (p (@ (class "message"))

	  (a (@ (href "/" ,repository-name "/commit/"

		      ,(oid->string (commit-id commit))))

	     ,(commit-message commit)))

       (p (span (@ (class "author"))

                ,(signature-name (commit-author commit)))

          (span (@ (class "date"))

            ,(commit->date-string commit))))

     (div (@ (class "commit-id"))

          (p (@ (class "short-id"))

             ,(string-take (oid->string (commit-id commit)) 7))

          (button (@ (data-clipboard-copy ,(oid->string (commit-id commit)))

                     (class "copy"))

              (img (@ (src "/images/copy.png")))))))

(define (project-commits repository-name repo ref)

  (let* ((commits (get-commits repo ref))

	 (next (cdr commits))

	 (commits (car commits)))

    (pk 'commits commits)

    `(,(map (lambda (commit)

	      (commit-infobox repository-name commit))

	    commits)

      ,(if next

	   `(p (a (@ (href "/" ,repository-name "/commits/"

			   ,(oid->string (commit-id next))))))

	   '()))))

  #:use-module (git types)

  #:use-module (srfi srfi-9)

  #:use-module (system foreign)

            get-files

            get-file-content

	    get-commits

            last-commit

            <file>

            make-file

            file?

            file-name

            file-type))

(define tree-entry-type

  (let ((proc (libgit2->procedure int "git_tree_entry_type" '(*))))

    (lambda (entry)

      (proc (tree-entry->pointer entry)))))

        (reference-name->oid repo (search-reference repo ref-name)))))

(define-record-type <file>

  (make-file name type commit)

  file?

  (name   file-name)

  (type   file-type)

  (commit file-commit))

            (set! result

              (cons (make-file (tree-entry-name entry)

                               (tree-entry-type entry)

                               (last-commit-for-file

                                 (string-append root (tree-entry-name entry))

                                 commit))

                    result)))

          0))

      result)))

(define (last-commit repo ref)

  (let ((oid (ref->oid repo ref)))

    (commit-lookup repo oid)))

  (let* ((oid (ref->oid repo ref))

         (entry (pk 'tree-item (tree-entry-bypath tree (pk 'path path))))

         (entry-oid (tree-entry-id entry))

(define (last-commit-for-file path commit)

  (let* ((initial-tree (commit-tree commit))

         (initial-entry (false-if-exception (tree-entry-bypath initial-tree path))))

    (let loop ((commit commit))

      (let ((pcommit (false-if-exception (commit-parent commit))))

        (if pcommit

            (let* ((ptree (commit-tree pcommit))

                   (pentry (false-if-exception (tree-entry-bypath ptree path))))

              (if (or (and (not initial-entry) (not pentry))

                      (and initial-entry pentry

                           (equal? (tree-entry-id initial-entry)

                                   (tree-entry-id pentry))))

                  (loop pcommit)

                  commit))

            commit)))))

(define (get-commits repo ref)

  (let* ((oid (ref->oid repo ref))

	 (commit (commit-lookup repo oid)))

    (let loop ((result (list commit)) (commit commit))

      (let ((pcommit (false-if-exception (commit-parent commit))))

	(if (and pcommit (< (length result) 20))

	    (loop (cons pcommit result) pcommit)

	    (cons (reverse result) pcommit))))))

moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION)

godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache

GOBJECTS = $(SOURCES:%.scm=%.go)

nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)

nobase_go_DATA = $(GOBJECTS)

# Make sure source files are installed first, so that the mtime of

# installed compiled files is greater than that of installed source

# files.  See

# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>

# for details.

guile_install_go_files = install-nobase_goDATA

$(guile_install_go_files): install-nobase_modDATA

CLEANFILES = $(GOBJECTS)

EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)

GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat

SUFFIXES = .scm .go

.scm.go:

	$(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILD) compile $(GUILE_WARNINGS) -o "$@" "$<"

;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; This library is free software; you can redistribute it and/or

;;;; modify it under the terms of the GNU Lesser General Public

;;;; License as published by the Free Software Foundation; either

;;;; version 3 of the License, or (at your option) any later version.

;;;; 

;;;; This library 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

;;;; Lesser General Public License for more details.

;;;; 

;;;; You should have received a copy of the GNU Lesser General Public

;;;; License along with this library; if not, write to the Free Software

;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; 

(use-modules (guix packages)

             (guix licenses)

             (guix build-system gnu)

             (gnu packages autotools)

             (gnu packages guile)

             (gnu packages guile-xyz)

             (gnu packages pkg-config)

             (gnu packages tls))

(package

  (name "gitile")

  (version "0.1")

  (source #f)

  (build-system gnu-build-system)

  (inputs

   `(("guile-git" ,guile-git)

     ("gnutls" ,gnutls)

     ("guile-fibers" ,guile-fibers)))

  (native-inputs

   `(("autoconf" ,autoconf)

     ("automake" ,automake)

     ("libtool" ,libtool)

     ("pkg-config" ,pkg-config)

     ("guile" ,guile-3.0)))

  (home-page "https://git.lepiller.eu")

  (synopsis "")

  (description "")

  (license gpl3+))

#!/bin/sh

abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`"

abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`"

GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"

GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH"

export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH

PATH="$abs_top_builddir:$PATH"

export PATH

exec "$@"

#!@GUILE@ \

--no-auto-compile -e main -s

!#

;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

;;;;

;;;; This library is free software; you can redistribute it and/or

;;;; modify it under the terms of the GNU Lesser General Public

;;;; License as published by the Free Software Foundation; either

;;;; version 3 of the License, or (at your option) any later version.

;;;;

;;;; This library 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

;;;; Lesser General Public License for more details.

;;;;

;;;; You should have received a copy of the GNU Lesser General Public

;;;; License along with this library; if not, write to the Free Software

;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;;

(use-modules (fibers web server))

(use-modules (ice-9 match))

(use-modules (gitile config) (gitile handler))

(define* (main #:optional (args (command-line)))

  (let ((config

         (match args

      ((_) (make-config 8080 "localhost" "/var/lib/gitile/gitile-db.sql"

                        "/var/lib/gitolite/repositories"))

      ((_ "-c" file)

       (let ((content (call-with-input-file file read)))

         (match content

           (('config ('port port) ('host host) ('database database)

	             ('repositories repositories))

            (make-config port host database repositories)))))

      (_ (format #t "Usage: ~a [-c config-file]~%" (car args))))))

    (run-server (gitile-handler config)

                #:port (config-port config))))