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

  #:use-module (gitile pages)

  #:use-module (ice-9 match)

  #:use-module (rnrs bytevectors)

  #:use-module (sxml simple)

  #: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)))

  (show (style `((p "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")))

       (link (@ (rel "icon") (href "/images/icon.png") (sizes "32x32")))

       (script (@ (src "/js/gitile.js")) "")

       (title ,project))

     (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 "/commits")) "Commits"))

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

       (div (@ (id "content"))

            ,@page)

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

(define* (show page #:key (code 200))

  (values (build-response #:code code #:headers '((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 (call-with-repo project-name callback)

    (define (repo-404 content project-name ref)

      (show (style content project-name ref)

            #:code 404))

    (define (repo-500 content)

      (show content #:code 500))

    (define (get-repo name)

      (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)))

    (let ((repo (get-repo project-name)))

      (if repo

          (catch #t

            (lambda _

              (callback repo))

            (lambda* (key . args)

              (match key

                ('not-found

                 (pk 'except key args)

                 (repo-404 (assoc-ref args 'content)

                           project-name

                           (or (assoc-ref args 'ref) "-")))

                (_

                  (pk 'uncaught-exception key args)

                  (repo-500 `((p "Internal error")))))))

          (repo-404 `((p "Repository not found: " ,project-name)) project-name

                    "-"))))

  (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)

          (call-with-repo project-name

            (lambda (repo)

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

                           project-name "-")))))

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

          (call-with-repo project-name

            (lambda (repo)

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

                           project-name ref)))))

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

          (call-with-repo project-name

            (lambda (repo)

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

         ((project-name "commits")

          (call-with-repo project-name

            (lambda (repo)

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

                    project-name "-")))))

         ((project-name "commits" ref)

          (call-with-repo project-name

            (lambda (repo)

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

                    project-name ref)))))

         ((project-name "commit" ref)

          (call-with-repo project-name

            (lambda (repo)

              (show (style (project-commit project-name repo ref)

                           project-name ref)))))

         ((project-name "tags")

          (call-with-repo project-name

            (lambda (repo)

              (show (style (project-tags project-name repo)

                    project-name "-")))))

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