Guix — Rebar Build System — Implementation

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2023 Pierre-Henry Fröhring <contact@phfrohring.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build-system rebar)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix monads)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (srfi srfi-26)
  #:export (hexpm-uri
            hexpm-package-url
            %rebar-build-system-modules
            rebar-build
            rebar-build-system))

;; See: https://github.com/hexpm/specifications/blob/master/endpoints.md
(define %hexpm-repo-url
  (make-parameter "https://repo.hex.pm"))

(define hexpm-package-url
  (string-append (%hexpm-repo-url) "/tarballs/"))

(define* (strip-prefix name #:optional (prefix "erlang-"))
  "Return NAME without the prefix PREFIX."
  (if (string-prefix? prefix name)
      (string-drop name (string-length prefix))
      name))

(define (hexpm-uri name version)
  "Return the URI where to fetch the sources of a Hex package NAME at VERSION.
NAME is the name of the package which should look like: erlang-pkg-name-X.Y.Z
See: https://github.com/hexpm/specifications/blob/main/endpoints.md"
  ((compose
    (cute string-append "https://repo.hex.pm/tarballs/" <> "-" version ".tar")
    (cute string-replace-substring <> "-" "_"))
   (strip-prefix name)))

(define (default-rebar3)
  "Return the default Rebar3 package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((erlang-mod (resolve-interface '(gnu packages erlang))))
    (module-ref erlang-mod 'rebar3)))

(define (default-erlang)
  "Return the default Erlang package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((erlang-mod (resolve-interface '(gnu packages erlang))))
    (module-ref erlang-mod 'erlang)))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (rebar (default-rebar3))
                (erlang (default-erlang))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME from the given arguments."

  (when target
    (error (format #f "Cross compilation is not supported by the Rebar Build System
and a target has been specified: ~a" target)))

  (bag
    (name name)
    (system system)
    (build-inputs `(,@(standard-packages)
                    ("erlang" ,erlang)
                    ("rebar" ,rebar)
                    ,@inputs
                    ,@native-inputs))
    (host-inputs '())
    (outputs outputs)
    (arguments (strip-keyword-arguments
                '(#:target #:rebar #:erlang #:inputs #:native-inputs)
                arguments))
    (build rebar-build)))

(define %rebar-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build rebar-build-system)
    ,@%gnu-build-system-modules))

(define* (rebar-build name inputs
                      #:key
                      guile
                      source
                      (tests? #t)
                      (test-target "eunit")
                      (install-profile "default")
                      (phases '(@ (guix build rebar-build-system) %standard-phases))
                      (outputs '("out"))
                      (search-paths '())
                      (native-search-paths '())
                      (system (%current-system))
                      (imported-modules %rebar-build-system-modules)
                      (modules '((guix build rebar-build-system)
                                 (guix build utils))))
  "Build SOURCE with INPUTS."

  (define builder
    (with-imported-modules imported-modules
      #~(begin
          (use-modules #$@(sexp->gexp modules))
          #$(with-build-variables inputs outputs
              #~(rebar-build #:source #+source
                             #:system #$system
                             #:name #$name
                             #:tests? #$tests?
                             #:test-target #$test-target
                             #:install-profile #$install-profile
                             #:phases #$(if (pair? phases)
                                            (sexp->gexp phases)
                                            phases)
                             #:outputs %outputs
                             #:search-paths '#$(sexp->gexp
                                                (map search-path-specification->sexp
                                                     search-paths))
                             #:inputs %build-inputs)))))

  (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
                                                  system #:graft? #f)))
    ;; Note: Always pass #:graft? #f.  Without it, ALLOWED-REFERENCES &
    ;; co. would be interpreted as referring to grafted packages.
    (gexp->derivation name builder
                      #:system system
                      #:target #f
                      #:graft? #f
                      #:guile-for-build guile)))

(define rebar-build-system
  (build-system
    (name 'rebar)
    (description "The standard Rebar build system")
    (lower lower)))

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
;;; Copyright © 2020, 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2023 Pierre-Henry Fröhring <contact@phfrohring.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build rebar-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module ((guix build utils) #:hide (delete))
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (rebar-build
            %standard-phases))

(define* (unpack #:key source #:allow-other-keys)
  "Unpack SOURCE in the working directory, and change directory within the
source.  When SOURCE is a directory, copy it in a sub-directory of the current
working directory."
  (let ((gnu-unpack (assoc-ref gnu:%standard-phases 'unpack)))
    (gnu-unpack #:source source)
    ;; Packages from hex.pm typically have a contents.tar.gz containing the
    ;; actual source. If this tar file exists, extract it.
    (when (file-exists? "contents.tar.gz")
      (invoke "tar" "xvf" "contents.tar.gz"))))

(define* (set-rebar-env #:key inputs #:allow-other-keys)
  "Set environment variables."
  (setenv "REBAR_CACHE_DIR" (getcwd))
  (setenv "REBAR_GLOBAL_CONFIG_DIR" (getcwd))
  (setenv "REBAR_BASE_DIR" "_build")
  (setenv "REBAR_CHECKOUTS_DIR" "_checkouts"))

(define* (strip-prefix name #:optional (prefix "erlang-"))
  "Return NAME without the prefix PREFIX."
  (if (string-prefix? prefix name)
      (string-drop name (string-length prefix))
      name))

;; The Erlang version is constant as soon as it is computable from the current
;; execution.  It is a X.Y string where X and Y are respectively the major and
;; minor version number of the Erlang used in the build.
(define %erlang-version (make-parameter "X.Y"))

(define (erlang-version inputs)
  "Return an X.Y string where X and Y are respectively the major and
minor version number of PACKAGE. Example: /gnu/store/…-erlang-1.14.0 →
1.14"
  ((compose
    (cute string-join <> ".")
    (cute take <> 2)
    (cute string-split <> #\.)
    strip-prefix
    strip-store-file-name)
   (assoc-ref inputs "erlang")))

(define* (set-erlang-version #:key inputs #:allow-other-keys)
  "Store the version number of the Erlang input in a parameter."
  (%erlang-version (erlang-version inputs))
  (format #t "Erlang version: ~a~%" (%erlang-version)))

(define (list-directories dir)
  "List absolute paths of directories directly under the directory DIR."
  (scandir dir (lambda (filename)
                 (and (not (member filename '("." "..")))
                      (directory-exists? (string-append dir "/" filename))))))

(define* (erlang-libdir path #:optional (version (%erlang-version)))
  "Return the path where all libraries under PATH for a specified Erlang
VERSION are installed."
  (string-append path "/lib/erlang/" version))

(define* (add-dependencies #:key inputs profiles #:allow-other-keys)
  (define input-directories
    (match inputs (((_ . dir) ...) dir)))

  (define checkouts (getenv "REBAR_CHECKOUTS_DIR"))
  (mkdir-p checkouts)

  ;; For all libname in elibdir, elibdir/libname → _checkouts/libname.
  (define (install-libs elibdir checkouts)
    (for-each (lambda (libname)
                (let ((dst (string-append checkouts "/" libname)))
                  (when (not (file-exists? dst))
                    (symlink (string-append elibdir "/" libname) dst))))
              (list-directories elibdir)))

  ;; For all elibdir in inputs, (install-libs elibdir checkouts).
  (for-each (lambda (input-dir)
              (let ((elibdir (erlang-libdir input-dir)))
                (when (directory-exists? elibdir)
                  (install-libs elibdir checkouts))))
            input-directories))

(define* (build #:key install-profile #:allow-other-keys)
  (invoke "rebar3" "as" install-profile "compile"))

(define* (check #:key tests? test-target #:allow-other-keys)
  (if tests?
      (invoke "rebar3" test-target)
      (format #t "test suite not run~%")))

(define (package-name->erlang-name name+ver)
  "Convert the Guix package NAME-VER to the corresponding Elixir name-version
format.  Example: erlang-a-pkg-1.2.3 -> a_pkg"
  ((compose
    (cute string-join <> "_")
    (cute drop-right <> 1)
    (cute string-split <> #\-))
   (strip-prefix name+ver)))

(define* (install #:key name outputs install-profile #:allow-other-keys)
  "Install artifacts in the store.
Copy _build/<profile>/bin under out/.
Copy directories _build/<profile>/lib/{ebin,priv} under <out>/lib/erlang/<X.Y>/<libname>/.
"
  (let* ((out (assoc-ref outputs "out"))
         (install-dir (string-append (getenv "REBAR_BASE_DIR") "/" install-profile))
         (install-name (package-name->erlang-name name))
         (bin-dir (string-append install-dir "/bin"))
         (lib-dir (string-append install-dir "/lib/" install-name))
         (lib-dir-out (string-append (erlang-libdir out) "/" install-name)))

    (when (file-exists? bin-dir)
      (copy-recursively bin-dir out #:follow-symlinks? #t))

    (mkdir-p lib-dir-out)
    (for-each
     (lambda (dirname)
       (let ((src (string-append lib-dir "/" dirname))
             (dst (string-append lib-dir-out "/" dirname)))
         (when (file-exists? src)
           (mkdir-p dst)
           (copy-recursively src dst #:follow-symlinks? #t))))
     '("ebin" "priv"))))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (replace 'unpack unpack)
    (add-after 'unpack 'set-rebar-env set-rebar-env)
    (add-after 'set-rebar-env 'set-erlang-version set-erlang-version)
    (delete 'bootstrap)
    (delete 'configure)
    (add-before 'build 'add-dependencies add-dependencies)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)))

(define* (rebar-build #:key inputs (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given Erlang package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))