;; An implementation of the client side of the Nix daemon protocol.
;;
;; Currently implements protocol 1.21, from around Nix 2.4.
(define-library (zilch nix daemon)
  (import (scheme base) (scheme write) (zilch lib hash) srfi-151
          (zilch nix binproto) socket
          (chicken format))

  (export
          <daemon-link> make-daemon-link daemon-link?
          daemon-link-in-port daemon-link-out-port

          daemon-write-u64 daemon-read-u64
          daemon-write-bytevector daemon-read-bytevector
          daemon-write-string daemon-read-string

          *logger*
          daemon-wop-handshake daemon-wop-add-text-to-store
          daemon-wop-add-to-store-nar daemon-wop-build-paths
          daemon-wop-query-derivation-output-map)

  (begin

   (define-record-type <daemon-link>
       (make-daemon-link in-port out-port)
       daemon-link?
       (in-port daemon-link-in-port)
       (out-port daemon-link-out-port))

   ;; Equivalent to port-{read,write}-{u64,bytevector,string} but on the <daemon-link> instead.
   (define (daemon-write-u64 link val) (port-write-u64 val (daemon-link-out-port link)))
   (define (daemon-write-bytevector link val) (port-write-bytevector val (daemon-link-out-port link)))
   (define (daemon-write-string link val) (port-write-string val (daemon-link-out-port link)))

   (define (daemon-read-u64 link) (port-read-u64 (daemon-link-in-port link)))
   (define (daemon-read-bytevector link) (port-read-bytevector (daemon-link-in-port link)))
   (define (daemon-read-string link) (port-read-string (daemon-link-in-port link)))
   (define (daemon-flush link) (flush-output-port (daemon-link-out-port link)))

   (define build-activity #f)
   ;; Defines a parameter that contains a procedure that is called with two
   ;; parameters: The log event type (next, write, last, error, activity-start,
   ;; activity-stop, activity-result) and its data.
   ;;
   ;; Defaults to a simple logger to the current output port.
   (define *logger*
     (make-parameter
       (lambda (event data)
           (cond
               ((eqv? event 'next) (write-string data))
               ((eqv? event 'write) (write-string data))
               ((eqv? event 'error) (error data))
               ((and (eqv? event 'activity-start) (eq? (list-ref data 3) 104)) (set! build-activity (list-ref data 1)))
               ((and (eqv? event 'activity-start) (eq? (list-ref data 3) 105)) (printf "[..building ~S]\n" (vector-ref (list-ref data 5) 0)))
               ((and (eqv? event 'activity-result) (eqv? (list-ref data 2) 101)) (write-string (vector-ref (cadr (cddr data)) 0)) (newline))
               ((and (eqv? event 'activity-result) (eqv? (list-ref data 1) build-activity) (eqv? (list-ref data 2) 105))
                (let* ((ndata (list-ref data 3)) (done-builds (vector-ref ndata 0)) (total-builds (vector-ref ndata 1)) (running-builds (vector-ref ndata 2)))
                  (printf "[~S/~S builds, ~S running]\n" done-builds total-builds running-builds)))))))

   ;; Reads a list of log events until STDERR_LAST is called.
   ;; This is the client-side equivalent of startWorking / stopWorking on the
   ;; server.
   (define (daemon-read-log-events link)
       (define val (daemon-read-u64 link))
       (case val
         ((#x6f6c6d67) ((*logger*) 'next (daemon-read-string link)) (daemon-read-log-events link)) ; STDERR_NEXT
         ((#x64617461) (daemon-write-u64 link (daemon-read-u64 link)) (daemon-read-log-events link)) ; STDERR_READ
         ((#x64617416) ((*logger*) 'write (daemon-read-string link))  (daemon-read-log-events link)) ; STDERR_WRITE
         ((#x616c7473) ((*logger*) 'last '()) (list)) ; STDERR_LAST
         ((#x63787470) ((*logger*) 'error (daemon-read-string link))) ; STDERR_ERROR
         ((#x53545254) ((*logger*) 'activity-start (daemon-read-activity-start link)) (daemon-read-log-events link)) ; STDERR_START_ACTIVITY
         ((#x53544f50) ((*logger*) 'activity-stop (daemon-read-u64 link)) (daemon-read-log-events link))
         ((#x52534c54) ((*logger*) 'activity-result (daemon-read-activity-result link)) (daemon-read-log-events link))
         (else => (error (string-append "read-log-events: unknown event #x" (number->string val 16))))))

   ;; Read a list of activity fields from the provided <daemon-link>.
   (define (daemon-read-activity-fields link)
       (letrec ((read-field (lambda (v i n)
                             (vector-set! v i (case (daemon-read-u64 link)
                                                 ((0) (daemon-read-u64 link))
                                                 ((1) (daemon-read-string link))
                                                 (else => (error "read-activity-fields: unknown field type"))))
                             (unless (<= n 1) (read-field v (+ i 1) (- n 1))))))
        (let*
          ((count (daemon-read-u64 link))
           (fields (make-vector count)))
          (if (> count 0) (read-field fields 0 count))
          fields)))

   ;; Read an activity-start object from the provided <daemon-link>.
   (define (daemon-read-activity-start link)
       (define act (daemon-read-u64 link))
       (define lvl (daemon-read-u64 link))
       (define typ (daemon-read-u64 link))
       (define s (daemon-read-string link))
       (define fields (daemon-read-activity-fields link))
       (define parent (daemon-read-u64 link))
       `(activity-start ,act ,lvl ,typ ,s ,fields ,parent))

   ;; Read an activity-result object from the provided <daemon-link>.
   (define (daemon-read-activity-result link)
       (define act (daemon-read-u64 link))
       (define typ (daemon-read-u64 link))
       (define fields (daemon-read-activity-fields link))
       `(activity-result ,act ,typ ,fields))

   ;; Read an Error object from the provided <daemon-link>.
   (define (daemon-read-error link)
       (letrec ((read-trace (lambda (v i n) (let*
                                             ((pos (daemon-read-u64 link))
                                              (hint (daemon-read-string link)))
                                             (vector-set! v i `(,pos ,hint))
                                             (unless (<= n 1) (read-trace v (+ i 1) (- n 1)))))))
           (let*
               ((type (daemon-read-string link))
                (level (daemon-read-u64 link))
                (name (daemon-read-string link))
                (msg (daemon-read-string link))
                (have-pos (daemon-read-u64 link))
                (trace-count (daemon-read-u64 link))
                (traces (make-vector trace-count)))
              (if (> trace-count 0) (read-trace traces 0 trace-count))
              `(error ,type ,level ,msg ,traces))))

   ;; Send a Nix worker protocol handshake.
   (define (daemon-wop-handshake link)
       (daemon-write-u64 link #x6e697863)
       (daemon-flush link)
       (define worker-magic (daemon-read-u64 link))
       (define protocol-version (daemon-read-u64 link))
       (define protocol-major (bitwise-and (arithmetic-shift protocol-version -8) #xFF))
       (define protocol-minor (bitwise-and protocol-version #xFF))
       (unless (= worker-magic #x6478696f) (error "handshake: received wrong WORKER_MAGIC_2" worker-magic))
       (unless (= protocol-major 1) (error "handshake: invalid major version protocol" protocol-major))
       (daemon-write-u64 link #x115)
       (daemon-write-u64 link 0) ; cpu affinity
       (daemon-write-u64 link 0)
       (daemon-flush link)
       (daemon-read-log-events link)

       ; Send wopSetOptions too, to adjust verbosity.
       (daemon-write-u64 link 19)
       (daemon-write-u64 link 0) ; keepFailed
       (daemon-write-u64 link 0) ; keepGoing
       (daemon-write-u64 link 0) ; tryFallback
       (daemon-write-u64 link 3) ; verbosity (lvlInfo)
       (daemon-write-u64 link 63) ; maxBuildJobs
       (daemon-write-u64 link 0) ; maxSilentTime
       (daemon-write-u64 link 0) ; obsolete, useBuildHook
       (daemon-write-u64 link 0) ; verboseBuild (unused?)
       (daemon-write-u64 link 0) ; obsolete, logType
       (daemon-write-u64 link 0) ; obsolete, printBuildTrace
       (daemon-write-u64 link 0) ; buildCores
       (daemon-write-u64 link 0) ; useSubstitutes
       (daemon-write-u64 link 0) ; settings overrides
       (daemon-flush link)
       (daemon-read-log-events link))


   ;; Request to the daemon that the paths in PATHS have to be built.
   ;; Each path may either be an output path, or `<drv>!<output name>`.
   (define (daemon-wop-build-paths link paths)
       (letrec ((send-paths (lambda (i)
                                (daemon-write-string link (vector-ref paths i))
                                (unless (>= (+ 1 i) (vector-length paths)) (send-paths (+ 1 i))))))
            (daemon-write-u64 link 9)
            (daemon-write-u64 link (vector-length paths))
            (send-paths 0)
            (daemon-write-u64 link 0)
            (daemon-flush link)
            (daemon-read-log-events link)
            (daemon-read-u64 link)))

   ;; Write a simple text file to the store. REFS is expected to be sorted.
   ;; Returns the store path at which the file has been created.
   (define (daemon-wop-add-text-to-store link suffix s refs)
       (daemon-write-u64 link 8)
       (daemon-write-string link suffix)
       (daemon-write-string link s)
       (daemon-write-u64 link (length refs))
       (for-each (lambda (l) (daemon-write-string link l)) refs)
       (daemon-flush link)
       (daemon-read-log-events link)
       (daemon-read-string link))

   ;; Write a NAR (as bytevector) to the store. REFS is expected to be sorted.
   (define (daemon-wop-add-to-store-nar link path deriver refs val ca)
     (daemon-write-u64 link 39)
     (daemon-write-string link path)
     (if (eq? #f deriver) (daemon-write-string link "") (daemon-write-string link deriver))
     (daemon-write-string link (string-append "sha256:" (hex (sha256 val))))
     (daemon-write-u64 link (length refs))
     (for-each (lambda (l) (daemon-write-string link l)) refs)
     (daemon-write-u64 link 0)
     (daemon-write-u64 link (bytevector-length val))
     (daemon-write-u64 link 1)
     (daemon-write-u64 link 0)
     (daemon-write-string link ca)
     (daemon-write-u64 link 0)
     (daemon-write-u64 link 0)
     (daemon-write-bytevector link val)
     (daemon-flush link)
     (daemon-read-log-events link))

   (define (daemon-wop-query-derivation-output-map link store-path)
     (daemon-write-u64 link 41)
     (daemon-write-string link store-path)
     (daemon-flush link)
     (daemon-read-log-events link)
     (define count (daemon-read-u64 link))
     (do ((out '()) (i 0 (+ i 1)))
         ((>= i count) out)
         (let* ((name (daemon-read-string link))
                (path (daemon-read-string link)))
               (set! out (cons (cons name (if (string=? path "") #f path)) out)))))))