(use-modules (gcrypt base64)
             (guix base32)
             (guix build download)
             ((guix download) #:select (%mirrors))
             (ice-9 match)
             (json)
             (sqlite3)
             (srfi srfi-1)
             (srfi srfi-9 gnu)
             (srfi srfi-19)
             (web uri))

(define-immutable-record-type <commit>
  (make-commit push-time hash)
  commit?
  (push-time commit-push-time)
  (hash commit-hash))

(define lookup-commits-query "\
SELECT c.push_time,
    c.hash
FROM commits c
ORDER BY c.push_time DESC")

(define (lookup-commits db)
  (define (record->commit rec)
    (match-let ((#(push-time hash) rec))
      (make-commit (and push-time (make-time time-utc 0 push-time))
                   hash)))
  (define (kons rec acc)
    (cons (record->commit rec) acc))
  (let* ((stmt (sqlite-prepare db lookup-commits-query))
         (commits (sqlite-fold kons '() stmt)))
    (sqlite-finalize stmt)
    commits))

(define lookup-sources-query "\
SELECT f.hash,
    fr.reference
FROM commits c
    JOIN fod_commit_links fcl USING (commit_id)
    JOIN fods f USING (fod_id)
    JOIN fod_references fr USING (fod_id)
WHERE c.hash = ?
    AND f.algorithm = 'sha256'
    AND (fr.reference LIKE '\"%'
        OR fr.reference LIKE '(\"%')
    AND NOT fr.is_error")

(define (nix-base32-sha256->subresource-integrity digest)
  "Convert the Nix-style base32-encoded SHA-256 hash DIGEST into a
Subresource Integrity metadata value."
  (define bv (nix-base32-string->bytevector digest))
  (define b64 (base64-encode bv))
  (string-append "sha256-" b64))

(define (web-reference-urls reference)
  (define uris
    (match (call-with-input-string reference read)
      ((urls ...) (map string->uri urls))
      (url (list (string->uri url)))))
  (append-map (lambda (uri)
                (map uri->string
                     (maybe-expand-mirrors uri %mirrors)))
              uris))

(define (lookup-sources db commit)
  (define (record->url-source rec)
    (match-let ((#(digest reference) rec))
      (let ((urls (web-reference-urls reference))
            (integrity (nix-base32-sha256->subresource-integrity digest)))
        `(("type" . "url")
          ("urls" . ,(list->vector urls))
          ("integrity" . ,integrity)))))
  (define (kons rec acc)
    (cons (record->url-source rec) acc))
  (let* ((stmt (sqlite-prepare db lookup-sources-query))
         (_ (sqlite-bind-arguments stmt commit))
         (sources (sqlite-fold kons '() stmt)))
    (sqlite-finalize stmt)
    sources))

(define (commit-sources-name directory commit)
  (string-append directory
                 "/"
                 (date->string (time-utc->date (commit-push-time commit))
                               "~Y-~m-~d")
                 "-"
                 (string-take (commit-hash commit) 7)
                 "-sources.json"))

(match (program-arguments)
  ((_ db-file directory)
   (mkdir directory)
   (let* ((db (sqlite-open db-file))
          (commits (lookup-commits db)))
     (for-each (lambda (commit)
                 (call-with-output-file (commit-sources-name directory commit)
                   (lambda (out)
                     (let* ((hash (commit-hash commit))
                            (sources (lookup-sources db hash)))
                       (scm->json `(("version" . "1")
                                    ("revision" . ,hash)
                                    ("sources" . ,(list->vector sources)))
                                  out)
                       (newline out)))))
               (list (car commits)))
     (sqlite-close db)
     (exit EXIT_SUCCESS)))
  (_ (display "usage: sources.scm DB-FILE\n" (current-error-port))
     (exit EXIT_FAILURE)))