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

;;;; 

(define-module (gitile config)

  #:use-module (srfi srfi-9)

  #:export (make-config

            config?

            config-port

            config-host

            config-database

            config-repositories))

(define-record-type config

  (make-config port host database repositories)

  config?

  (port         config-port)

  (host         config-host)

  (database     config-database)

  (repositories config-repositories))

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

;;;; 

(define-module (gitile handler)

  #:use-module (fibers web server)

  #:use-module (git)

  #:use-module (gitile pages)

  #:use-module (ice-9 match)

  #:use-module (web request)

  #:use-module (web response)

  #:use-module (web uri)

  #:export (gitile-handler))

(define (request-path-components request)

  (split-and-decode-uri-path (uri-path (request-uri request))))

(define (not-found request)

  (format #t "Not found: ~a~%" (uri->string (request-uri request)))

  (values (build-response #:code 404)

          (string-append "Resource not found: "

                         (uri->string (request-uri request)))))

(define (style page project ref)

  `(html

     (head

       (meta (@ (charset "UTF-8")))

       (meta (@ (name "viewport") (content "width=device-width, initial-scale=1")))

       (link (@ (rel "stylesheet") (href "/css/gitile.css"))))

     (body

       (header

         (nav

           (ul

             (li (@ (class "first")) (a (@ (href "/")) "Projects"))

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

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

             (li (a (@ (href "/" project "/ommits")) "Commits"))

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

       (div (@ (id "content"))

            ,@page)

       (footer (p (a (@ (href "https://lepiller.eu")) "Who am I?"))))))

(define (show page)

  (values '((content-type . (text/html)))

          (with-output-to-string (lambda _ (sxml->xml page)))))

(define (show-raw page)

  (values '((content-type . (text/plain)))

          page))

(define (gitile-handler config)

  (define (get-repo name)

    (repository-open (string-append repositories "/" name ".git")))

  (match config

    (($ config port host database repositories)

     (lambda (request body)

       (pk 'request request)

       (pk 'body (if body (utf8->string body) body))

       (match (request-path-components request)

         ((project-name) (show (project-index project-name)))

         ((project-name "tree" ref path ...)

          (show (style (project-files (get-repo project-name) #:ref ref #:path path)

                       project-name ref)))

         ((project-name "raw" ref path ...)

          (show-raw (project-file-raw (get-repo project-name) path #:ref ref)))

         ((project-name "commits")

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

         ((project-name "commits" ref)

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

         ((project-name "tags")

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

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

;;;; 

(define-module (gitile pages)

  #:use-module (gitile repo)

  #:export (not-yet-page

            project-file-raw

            project-files))

(define not-yet-page

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

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

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

(define* (project-files repo #:key (ref #f) (path ""))

  (let ((files (get-files repo #:ref ref #:path path)))

    (if (and (string-null? path) (null? files))

        `(p "Empty repository")

        (if (null? files)

            `((p "file content")

              (pre ,@(get-file-content repo path #:ref ref)))

            `((p "directory content")

              ,@(map

                  (lambda (file)

                    `(p ,file))

                  files))))))

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

;;;; 

(define-module (gitile repo)

  #:use-module (git)

  #:export (get-branches

            get-tags

            get-files))

(define (get-branches repo)

  (map (lambda (ref) (cons (reference-shorthand ref) (reference-name ref)))

       (filter reference-branch? (reference-fold cons '() repo))))

(define (get-tags repo)

  (map (lambda (ref) (cons (reference-shorthand ref) (reference-name ref)))

       (filter reference-tag? (reference-fold cons '() repo))))

(define (search-reference repo name)

  (reference-fold (lambda (ref acc)

                    (if (equal? name (reference-shorthand ref))

                        (reference-name ref)

                        acc))

                  #f

                  repo))

(define (ref->oid repo ref)

  (let ((ref-name (or ref

                      (false-if-exception (reference-name (repository-head repo))))))

    (or (false-if-exception (string->oid ref-name))

        (false-if-exception (reference-name->oid repo ref-name))

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

(define* (get-files repo #:key (path "") (ref #f))

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

         (commit (commit-lookup repo oid))

         (tree (commit-tree commit)))

    (let ((result '()))

      (tree-walk

        tree TREEWALK-PRE

        (lambda (root entry)

          (when (equal? root path)

            (set! result (cons (string-append root (tree-entry-name entry))

                               result)))

          0)))))

(define (find-tree-item tree name)

  (let ((result #f))

    (tree-walk

      tree TREEWALK-PRE

      (lambda (root entry)

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

          (when (equal? name filepath)

            (set! result entry))

          0)))

    result))

(define* (get-file-content repo path #:key (ref #f))

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

         (commit (commit-lookup repo oid))

         (tree (commit-tree commit))

         (entry (find-tree-item tree path))

         (entry-oid (entry-id entry))

         (blob (blob-lookup repo entry-oid)))

    (blob-content blob)))