;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; github.scm
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net>
;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published by the
;; Free Software Foundation, version 3 of the License.
;;
;; ebuild-autogen 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
;; ebuild-autogen. If not, see <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (ebuild fetchers github)
  #:use-module (ebuild defs)
  #:use-module (ebuild fetchers raw)
  #:use-module (ebuild utils)
  #:use-module (curl)
  #:use-module (json)
  #:use-module (ice-9 pretty-print)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-43)
  #:use-module (rx irregex)
  #:use-module (dql dql))
 
(define api-base-url "https://api.github.com/repos/")

(define check-github-errors
  (lambda (responce)
    ""
    (cond ((string-contains responce "API rate limit exceeded for")
           (error (string-append "error: GitHub API rate limit exceeded, "
                                 "please setup a token.")))
          ((string-contains responce
                            (string-append "Request forbidden by administrative"
                                           " rules. Please make sure your "
                                           "request has a User-Agent header"))
           (error (string-append "error: GitHub API requires a user agent, "
                                 "should have been supplied!"))))))

(define fetch-github-pages
  (lambda* (url token verbosity #:optional (page 1))
    ""
    (let ((curl-handle (curl-easy-init)))
      (curl-easy-setopt curl-handle
                        'url
                        (string-append url
                                       "?per_page=100&page="
                                       (number->string page)))
      (curl-easy-setopt curl-handle 'useragent curl-useragent)
      (if (string<> token "")
          (curl-easy-setopt curl-handle
                            'httpheader
                            (list (string-append "Authorization: token "
                                                 token))))
      (let* ((responce (curl-easy-perform curl-handle)))
        (if (>= verbosity verbosity-debug)
            (begin  (display "json = ") (display responce) (newline)))
        (if responce
            (begin (check-github-errors responce)
                   (let ((scm-responce (json-string->scm responce)))
                     (if (< 100 (vector-length scm-responce))
                         (vector-append (fetch-github-pages url
                                                            verbosity
                                                            (+1 page)))
                         (begin (if (>= verbosity verbosity-info)
                                    (pretty-print scm-responce))
                                scm-responce))))
            (error (string-append "GitHub fetch failed with error "
                                  (curl-error-string)
                                  "\n")))))))

(define get-releases
  (lambda (user repo token version-filter verbosity)
    "" 
    ((dql (select (filter (where version-filter
                                 "tag_name"))
                  (parm-as "version" "tag_name")
                  (parm-as "date" "created_at")))
     (fetch-github-pages (string-append api-base-url
                                        user
                                        "/"
                                        repo
                                        "/releases")
                         token
                         verbosity))))

(define get-tags
  (lambda (user repo token version-filter verbosity)
    ""
    ((dql (select (filter (where version-filter
                                 "name"))
                  (parm-as "version" "name")
                  (parm "commit" "sha"))) 
     (fetch-github-pages (string-append api-base-url
                                        user
                                        "/"
                                        repo
                                        "/tags")
                         token
                         verbosity))))

(define get-rel-assets
  (lambda (user repo token name-prefix version-alter releases)
    ""
    ;; (display "for-releases:") (newline)
    ;; (pretty-print releases)
    (map (lambda (release)
           ;; (display "for-release:") (newline)
           ;; (pretty-print release)
           (let* ((version (assoc-ref release "version"))
                  (version-final (version-alter version))
                 (curl-handle (curl-easy-init))
                 (base-asset-url (string-append "https://github.com/"
                                                user
                                                "/"
                                                repo))
                 (sha "")
                 (sha7 "")
                 (json "")
                 (scm ""))
             (curl-easy-setopt curl-handle
                               'url
                               (string-append api-base-url
                                              user
                                              "/"
                                              repo
                                              "/git/refs/tags/"
                                              version))
             (curl-easy-setopt curl-handle 'useragent curl-useragent)
             (if (string<> token "")
          (curl-easy-setopt curl-handle
                            'httpheader
                            (list (string-append "Authorization: token "
                                                 token))))
             ;;(curl-easy-setopt curl-handle 'max-time 120)
             ;;(curl-easy-setopt curl-handle 'connect-timeout 30)
             (set! json (curl-easy-perform curl-handle))
             ;; (display "json=") (display json) (newline)
             (if (not json)
                 (error (string-append "GitHub release asset fetch "
                                       "failed with error "
                                       (curl-error-string)
                                       "\n")))
             (check-github-errors json)
             (set! scm (json-string->scm json))
             ;;(display "scm:") (newline) (pretty-print scm)
             (set! sha (assoc-ref (car ((dql (select (parm "object" "sha")))
                                        (list scm)))
                                  "sha"))
             ;;(display "sha=") (display sha) (newline)
             (set! sha7 (string-take sha 7))
             (assoc-set! release "version" version-final)
             (append release
                     (list (cons "sha" sha))
                     (list (cons "github-user" user))
                     (list (cons "github-repo" repo))
                     (list (cons "sha7" sha7))
                     ;;TODO append this with list of custom assets.
                     (list
                      (list "assets"
                            (list (cons "uri" (string-append base-asset-url
                                                             "/tarball/"
                                                             sha7))
                                  (cons "name" (string-append name-prefix
                                                              "-"
                                                              version-final
                                                              "-"
                                                              sha7
                                                              ".tar.gz"))
                                  (cons "type" "tar.gz"))
                            (list (cons "uri" (string-append base-asset-url
                                                             "/zipball/"
                                                             sha7))
                                  (cons "name" (string-append name-prefix
                                                              "-"
                                                              version-final
                                                              "-"
                                                              sha7
                                                              ".zip"))
                                  (cons "type" "zip")))))))
         releases)))

(define get-tag-assets
  (lambda (user repo name-prefix version-alter tags)
     ;; (display "tags = ")
     ;; (pretty-print tags)
    (map (lambda (tag)
          (let* ((sha (assoc-ref tag "sha"))
                 (sha7 (string-take sha 7))
                 (version (assoc-ref tag "version"))
                 (version-final (version-alter version))
                 (base-asset-url (string-append "https://github.com/"
                                                user
                                                "/"
                                                repo)))
            (assoc-set! tag "version" version-final)
            (append tag
                    (list (cons "github-user" user))
                    (list (cons "github-repo" repo))
                    (list (cons "sha7" sha7))
                    (list
                     (list "assets"
                           (list (cons "uri" (string-append base-asset-url
                                                            "/tarball/"
                                                            sha7))
                                 (cons "name" (string-append name-prefix
                                                             "-"
                                                             version-final
                                                             "-"
                                                             sha7
                                                             ".tar.gz"))
                                 (cons "type" "tar.gz"))
                           (list (cons "uri" (string-append base-asset-url
                                                            "/zipball/"
                                                            sha7))
                                 (cons "name" (string-append name-prefix
                                                             "-"
                                                             version-final
                                                             "-"
                                                             sha7
                                                             ".zip"))
                                 (cons "type" "zip")))))))
         tags)))

(define-public fetch-github
  (lambda* (user repo token querry verbosity #:key
                 (version-filter (lambda (version)
                                   (irregex-search
                                    '(seq bos
                                          (+ num)
                                          (* (seq "." (+ num)))
																					eos)
                                    version)))
                 (version-alter (lambda (version)
                                  (let ((my-match (irregex-search
                                                   '(seq (+ num)
                                                         (* (seq "." (+ num))))
                                                   version)))
                                    (if my-match
                                        (irregex-match-substring my-match)
                                        #f))))
                 (file-prefix repo))
    ""
    (display "Fetching ")
    (display repo)
    (display " from ")
    (display user)
    (display " at github.")
    (newline)
    (letrec* ((releases
               (case querry
                 ((releases) (get-releases user
                                           repo
                                           token
                                           version-filter
                                           verbosity))
                 ((tags) (get-tags user repo token version-filter verbosity))
                 (else (error (string-append "Error github can only "
                                             "querry tags or releases.")))))
              (assets (case querry
                        ((releases) (get-rel-assets user repo token
                                                    file-prefix version-alter
                                                    releases))
                        ((tags) (get-tag-assets user repo
                                                file-prefix version-alter
                                                releases))
                        (else '()))))
      assets)))

(define-public extract-github-release
  (lambda (release)
    (let* ((sha7 (assoc-ref release "sha7"))
           (extracted-path (string-append (assoc-ref release 'tmp-path)
                                          "/"
                                          (assoc-ref release "github-user")
                                          "-"
                                          (assoc-ref release "github-repo")
                                          "-" sha7))
           (file-path (fetch-raw-release release "tar.gz")))
      (if (access? extracted-path F_OK)
          (system* "/bin/rm" "-r" extracted-path))
      (mkpath (assoc-ref release 'tmp-path))
      (system* "/bin/tar"
               "-xf" file-path "--directory"
               (assoc-ref release 'tmp-path))
      (values extracted-path (basename file-path)))))

(define-public fetch-github-prefixed
  (lambda* (user repo token querry verbosity prefix #:key
                 (file-prefix repo)
                 (display-data #f))
    ""
    (fetch-github user repo token querry verbosity
                  #:version-filter
                  (lambda (version)
                    (irregex-search
                     `(seq ,prefix
                           (+ num)
                           (* (seq "." (+ num)))
													 eos)
                     version))
                  #:version-alter
                  (lambda (version)
                    (let ((my-match (irregex-search
                                     `(seq (look-behind ,prefix)
                                           (+ num)
                                           (* (seq "." (+ num))))
                                     version)))
                      (if my-match
                          (irregex-match-substring my-match)
                          #f)))
                  #:file-prefix file-prefix)))