;;; Disarchive
;;; Copyright © 2020, 2021 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Disarchive.
;;;
;;; Disarchive 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.
;;;
;;; Disarchive 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 Disarchive.  If not, see <http://www.gnu.org/licenses/>.

(define-module (disarchive assemblers)
  #:use-module (disarchive digests)
  #:use-module (disarchive logging)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:export (<assembler>
            make-assembler
            assembler?
            assembler-x?
            assembler-x-name
            assembler-x-digest
            assembler-x-inputs
            assembler-serialize-x
            assembler-serialized-x?
            assembler-deserialize-x
            assembler-assemble-x

            &assembly-error
            make-assembly-error
            assembly-error?
            assembly-error

            blueprint-name
            blueprint-digest
            blueprint-inputs
            serialize-blueprint
            deserialize-blueprint
            assemble))

;;; Commentary:
;;;
;;; This module provides a generalized interface for blueprints.  A
;;; blueprint is an object that describes how to produce an output
;;; that matches its digest.  Blueprints can also be serialized and
;;; deserialized.
;;;
;;; Code:

(define-record-type <assembler>
  (make-assembler x? x-name x-digest x-inputs
                  serialize-x serialized-x? deserialize-x
                  assemble-x)
  assembler?
  (x? assembler-x?)
  (x-name assembler-x-name)
  (x-digest assembler-x-digest)
  (x-inputs assembler-x-inputs)
  (serialize-x assembler-serialize-x)
  (serialized-x? assembler-serialized-x?)
  (deserialize-x assembler-deserialize-x)
  (assemble-x assembler-assemble-x))

(define-exception-type &assembly-error &error
  make-assembly-error
  assembly-error?)

(define-syntax-rule (assembly-error msg)
  (raise-exception (make-exception (make-assembly-error)
                                   (make-exception-with-message msg))))

(define (name->assembler name)
  (let ((module `(disarchive assemblers ,name)))
    (module-ref (resolve-interface module)
                (symbol-append name '-assembler))))

(define %assemblers
  (delay (map name->assembler
              '(gzip-member
                xz-file
                tarball
                directory-ref))))

(define (blueprint-name blueprint)
  "Get the name of BLUEPRINT."
  (any (match-lambda
         (($ <assembler> x? x-name _ _ _ _ _ _)
          (and (x? blueprint) (x-name blueprint))))
       (force %assemblers)))

(define (blueprint-digest blueprint)
  "Get the digest of BLUEPRINT."
  (any (match-lambda
         (($ <assembler> x? _ x-digest _ _ _ _ _)
          (and (x? blueprint) (x-digest blueprint))))
       (force %assemblers)))

(define (blueprint-inputs blueprint)
  "Get the inputs of BLUEPRINT."
  (any (match-lambda
         (($ <assembler> x? _ _ x-inputs _ _ _ _)
          (and (x? blueprint) (x-inputs blueprint))))
       (force %assemblers)))

(define (serialize-blueprint blueprint)
  "Serialize BLUEPRINT."
  (any (match-lambda
         (($ <assembler> x? _ _ _ serialize-x _ _ _)
          (and (x? blueprint) (serialize-x blueprint))))
       (force %assemblers)))

(define (deserialize-blueprint sexp)
  "Deserialize SEXP into a blueprint."
  (any (match-lambda
         (($ <assembler> _ _ _ _ _ serialized-x? deserialize-x _)
          (and (serialized-x? sexp) (deserialize-x sexp))))
       (force %assemblers)))

(define* (assemble blueprint workspace #:key (verify? #t))
  (any (match-lambda
         (($ <assembler> x? x-name _ _ _ _ _ assemble-x)
          (and (x? blueprint)
               (let* ((name (x-name blueprint))
                      (digest (blueprint-digest blueprint))
                      (out (digest->filename digest workspace)))
                 (unless (and (file-exists? out) (file-digest? out digest))
                   (for-each (cut assemble <> workspace)
                             (blueprint-inputs blueprint))
                   (assemble-x blueprint workspace)
                   (when verify?
                     (start-message "Checking ~a digest... " name)
                     (if (file-digest? out digest)
                         (message "ok")
                         (begin
                           (message "fail")
                           (assembly-error "Output is incorrect")))))))))
       (force %assemblers)))
