(define-module (fruix system freebsd source)
  #:use-module (fruix packages freebsd)
  #:use-module (fruix system freebsd model)
  #:use-module (fruix system freebsd utils)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-13)
  #:export (materialize-freebsd-source
            freebsd-source-materialization-spec))

(define freebsd-source-materializer-version "2")

(define (string-downcase* value)
  (list->string (map char-downcase (string->list value))))

(define (safe-name-fragment value)
  (let* ((text (if (and (string? value) (not (string-null? value))) value "source"))
         (chars (map (lambda (ch)
                       (if (or (char-alphabetic? ch)
                               (char-numeric? ch)
                               (memv ch '(#\- #\_ #\.)))
                           ch
                           #\-))
                     (string->list text))))
    (list->string chars)))

(define (freebsd-source-manifest source effective-source identity)
  (string-append
   "materializer-version=" freebsd-source-materializer-version "\n"
   "declared-source=\n"
   (object->string (freebsd-source-spec source))
   "\neffective-source=\n"
   (object->string (freebsd-source-spec effective-source))
   "\nidentity=\n"
   (object->string identity)))

(define (ensure-git-source-cache source cache-dir)
  (let* ((url (freebsd-source-url source))
         (repo-dir (string-append cache-dir "/git/"
                                  (sha256-string (string-append "git:" url))
                                  ".git")))
    (mkdir-p (dirname repo-dir))
    (unless (file-exists? repo-dir)
      (unless (zero? (system* "git" "init" "--quiet" "--bare" repo-dir))
        (error "failed to initialize git source cache" repo-dir))
      (unless (zero? (system* "git" "-C" repo-dir "remote" "add" "origin" url))
        (error "failed to add git source remote" url)))
    (let ((current-url (safe-command-output "git" "-C" repo-dir "remote" "get-url" "origin")))
      (unless (and current-url (string=? current-url url))
        (unless (zero? (system* "git" "-C" repo-dir "remote" "set-url" "origin" url))
          (error "failed to update git source remote" url))))
    repo-dir))

(define (resolve-git-freebsd-source source cache-dir)
  (let* ((selector (or (freebsd-source-commit source)
                       (freebsd-source-ref source)
                       (error "git freebsd source requires a ref or commit" source)))
         (repo-dir (ensure-git-source-cache source cache-dir)))
    (unless (zero? (system* "git" "-C" repo-dir "fetch" "--quiet" "--depth" "1" "origin" selector))
      (error "failed to fetch git freebsd source" selector))
    (let ((resolved-commit (command-output "git" "-C" repo-dir "rev-parse" "FETCH_HEAD")))
      `((cache-path . ,repo-dir)
        (effective-source . ,(freebsd-source #:name (freebsd-source-name source)
                                             #:kind 'git
                                             #:url (freebsd-source-url source)
                                             #:ref (freebsd-source-ref source)
                                             #:commit resolved-commit
                                             #:sha256 #f))
        (identity . ((resolved-commit . ,resolved-commit)))
        (populate-tree . ,(lambda (tree-root)
                            (let ((archive-path (string-append (dirname tree-root) "/git-export.tar")))
                              (unless (zero? (system* "git" "-C" repo-dir "archive"
                                                      "--format=tar" "-o" archive-path resolved-commit))
                                (error "failed to archive git freebsd source" resolved-commit))
                              (unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root))
                                (error "failed to extract archived git freebsd source" archive-path))
                              (delete-path-if-exists archive-path))))))))

(define (normalize-expected-sha256 source)
  (let ((sha256 (freebsd-source-sha256 source)))
    (and sha256 (string-downcase* sha256))))

(define (resolve-txz-freebsd-source source cache-dir)
  (let* ((url (freebsd-source-url source))
         (expected-sha256 (or (normalize-expected-sha256 source)
                              (error "src-txz freebsd source requires sha256 for materialization" source)))
         (archive-path (string-append cache-dir "/archives/"
                                      (sha256-string (string-append "txz:" url))
                                      "-src.txz")))
    (mkdir-p (dirname archive-path))
    (when (file-exists? archive-path)
      (let ((actual (string-downcase* (file-hash archive-path))))
        (unless (string=? actual expected-sha256)
          (delete-file archive-path))))
    (unless (file-exists? archive-path)
      (unless (zero? (system* "fetch" "-q" "-o" archive-path url))
        (error "failed to download FreeBSD src.txz source" url)))
    (let ((actual-sha256 (string-downcase* (file-hash archive-path))))
      (unless (string=? actual-sha256 expected-sha256)
        (error "downloaded src.txz hash mismatch" url expected-sha256 actual-sha256))
      `((cache-path . ,archive-path)
        (effective-source . ,(freebsd-source #:name (freebsd-source-name source)
                                             #:kind 'src-txz
                                             #:url url
                                             #:path #f
                                             #:ref #f
                                             #:commit #f
                                             #:sha256 actual-sha256))
        (identity . ((archive-sha256 . ,actual-sha256)))
        (populate-tree . ,(lambda (tree-root)
                            (unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root))
                              (error "failed to extract FreeBSD src.txz source" archive-path))))))))

(define (resolve-local-freebsd-source source)
  (let* ((path (freebsd-source-path source))
         (tree-sha256 (native-build-source-tree-sha256 path)))
    `((cache-path . #f)
      (effective-source . ,(freebsd-source #:name (freebsd-source-name source)
                                           #:kind 'local-tree
                                           #:url #f
                                           #:path path
                                           #:ref #f
                                           #:commit #f
                                           #:sha256 tree-sha256))
      (identity . ((tree-sha256 . ,tree-sha256)))
      (populate-tree . ,(lambda (tree-root)
                          (copy-tree-contents path tree-root))))))

(define (detect-materialized-source-relative-root tree-root)
  (cond
   ((file-exists? (string-append tree-root "/Makefile"))
    "tree")
   ((file-exists? (string-append tree-root "/usr/src/Makefile"))
    "tree/usr/src")
   (else
    "tree")))

(define* (materialize-freebsd-source source #:key
                                    (store-dir "/frx/store")
                                    (cache-dir "/frx/var/cache/fruix/freebsd-source"))
  (validate-freebsd-source source)
  (let* ((resolution (case (freebsd-source-kind source)
                       ((local-tree)
                        (resolve-local-freebsd-source source))
                       ((git)
                        (resolve-git-freebsd-source source cache-dir))
                       ((src-txz)
                        (resolve-txz-freebsd-source source cache-dir))
                       (else
                        (error "unsupported freebsd source kind" (freebsd-source-kind source)))))
         (effective-source (assoc-ref resolution 'effective-source))
         (identity (assoc-ref resolution 'identity))
         (manifest (freebsd-source-manifest source effective-source identity))
         (display-name (string-append "freebsd-source-"
                                      (safe-name-fragment (freebsd-source-name source))))
         (output-path (make-store-path store-dir display-name manifest
                                       #:kind 'freebsd-source))
         (info-file (string-append output-path "/.freebsd-source-info.scm"))
         (cache-path (assoc-ref resolution 'cache-path))
         (populate-tree (assoc-ref resolution 'populate-tree)))
    (unless (file-exists? output-path)
      (let* ((temp-output (string-append output-path ".tmp"))
             (temp-tree-root (string-append temp-output "/tree")))
        (delete-path-if-exists temp-output)
        (mkdir-p temp-tree-root)
        (populate-tree temp-tree-root)
        (let* ((relative-root (detect-materialized-source-relative-root temp-tree-root))
               (source-root (string-append output-path "/" relative-root))
               (temp-source-root (string-append temp-output "/" relative-root))
               (tree-sha256 (native-build-source-tree-sha256 temp-source-root)))
          (write-file (string-append temp-output "/.references") "")
          (write-file (string-append temp-output "/.fruix-source") manifest)
          (write-file (string-append temp-output "/.freebsd-source-info.scm")
                      (object->string
                       `((materializer-version . ,freebsd-source-materializer-version)
                         (declared-source . ,(freebsd-source-spec source))
                         (effective-source . ,(freebsd-source-spec effective-source))
                         (identity . ,identity)
                         (source-store . ,output-path)
                         (source-root . ,source-root)
                         (source-tree-sha256 . ,tree-sha256)
                         (cache-path . ,cache-path)))))
        (rename-file temp-output output-path)))
    (call-with-input-file info-file
      (lambda (port)
        (let* ((info (read port))
               (effective (assoc-ref info 'effective-source)))
          `((source-store-path . ,output-path)
            (source-root . ,(assoc-ref info 'source-root))
            (source-info-file . ,info-file)
            (source-tree-sha256 . ,(assoc-ref info 'source-tree-sha256))
            (cache-path . ,(assoc-ref info 'cache-path))
            (effective-source . ,effective)
            (effective-commit . ,(assoc-ref effective 'commit))
            (effective-sha256 . ,(assoc-ref effective 'sha256))))))))


(define (freebsd-source-materialization-spec result)
  `((source-store-path . ,(assoc-ref result 'source-store-path))
    (source-root . ,(assoc-ref result 'source-root))
    (source-info-file . ,(assoc-ref result 'source-info-file))
    (source-tree-sha256 . ,(assoc-ref result 'source-tree-sha256))
    (cache-path . ,(assoc-ref result 'cache-path))
    (effective-source . ,(assoc-ref result 'effective-source))))