;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 pukkamustard <pukkamustard@posteo.net>
;;;
;;; 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/>.


;;; Commentary:
;;;
;;; This module provides an interface to the IPFS daemons HTTP API for storing
;;; and retrieving blocks. This can be used to store blocks of ERIS encoded
;;; content.
;;; 
;;; See also the IPFS API documentation:
;;; https://docs.ipfs.io/reference/http/api/#api-v0-block-put

(define-module (guix eris ipfs)
  #:use-module (eris utils base32)
  #:use-module (sodium generichash)
  #:use-module (json)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (srfi srfi-71)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)

  #:use-module ((guix build download)
                #:select ((open-connection-for-uri
                           . guix:open-connection-for-uri)))
  #:export (%ipfs-base-url

	    eris-ipfs-reducer
            eris-ipfs-ref))


;; CID encoding

;; Multicodec codes
;; (https://github.com/multiformats/multicodec/blob/master/table.csv)
(define multicodec-raw-code #x55)
(define multicodec-blake2b-256-code #xb220)

(define (blake2b-256->binary-cid hash)
  "Encode a Blake2b-256 hash as binary CID"
  (call-with-values
      (lambda () (open-bytevector-output-port))
    (lambda (port get-bytevector)
      ;; CID version
      (put-u8 port 1)
      ;; multicoded content-type
      (put-u8 port multicodec-raw-code)
      ;; set multihash to blake2b-256. This is the manually encoded varint of
      ;; 0xb220
      (put-u8 port 160) (put-u8 port 228) (put-u8 port 2)
      ;; set hash lenght
      (put-u8 port 32)
      ;; and finally the hash itself
      (put-bytevector port hash)

      ;; finalize and get the bytevector
      (get-bytevector))))

(define (binary-cid->cid bcid)
  "Encode a binary CID as Base32 encoded CID"
  ;; 'b' is the multibsae code for base32
  (string-append "b"
                 ;; the IPFS daemon uses lower-case, so to be consistent we
                 ;; also.
                 (string-downcase
                  ;; base32 encode the binary cid
                  (base32-encode bcid))))

(define blake2b-256->cid
  (compose binary-cid->cid blake2b-256->binary-cid))


;; IPFS API

(define %ipfs-base-url
  ;; URL of the IPFS gateway.
  (make-parameter "http://localhost:5001"))

(define* (call url decode
               #:optional
               (method http-post)
               #:key port body (false-if-404? #t) (headers '())
               (keep-alive #t)
               (open-connection guix:open-connection-for-uri)
               (timeout 10))
  "Invoke the endpoint at URL using METHOD.  Decode the resulting JSON body
using DECODE, a one-argument procedure that takes an input port; when DECODE
is false, return the input port.  When FALSE-IF-404? is true, return #f upon
404 responses."
  (let* ((url (if (string? url) (string->uri url)  url))
         (port (or port (open-connection url #:timeout timeout)))
         (response response-port
                   (if keep-alive
                       (method url #:streaming? #t
                               #:body body
                               #:port port
                               #:keep-alive? #t)
                       (method url #:streaming? #t
                               #:body body
                               #:port port
                               ;; IPFS daemon seems to responds with bad
                               ;; request if PUT requests are kept alive and
                               ;; do not have "Connection: close" header.
                               #:keep-alive? #f
                               #:headers `((connection close)
                                           ,@headers)))))
    (cond ((= 200 (response-code response))
           (if decode
               (let ((result (decode response-port)))
                 (close-port response-port)
                 result)
               response-port))
          ((and false-if-404?
                (= 404 (response-code response)))
           (close-port response-port)
           #f)
          (else
           (close-port response-port)
           (format #t "~a\n" response)
           (throw 'ipfs-error url response)))))

(define-syntax-rule (false-if-ipfs-error exp)
  "Return $f if EXP triggers a network related or IPFS related exception."
  (with-exception-handler
      (lambda (exn)
        (let ((kind (exception-kind exn))
              (errno (system-error-errno
                      (cons 'system-error (exception-args exn)))))
          (cond
           ((= errno ECONNREFUSED) #f)
           (else (raise-exception exp)))))
    (lambda () exp)
    #:unwind? #t))

(define %multipart-boundary
  ;; XXX: We might want to find a more reliable boundary.
  (string-append (make-string 24 #\-) "2698127afd7425a6"))

(define (bytevector->form-data bv port)
  "Write to PORT a 'multipart/form-data' representation of BV."
  (display (string-append "--" %multipart-boundary "\r\n"
                          "Content-Disposition: form-data\r\n"
                          "Content-Type: application/octet-stream\r\n\r\n")
           port)
  (put-bytevector port bv)
  (display (string-append "\r\n--" %multipart-boundary "--\r\n")
           port))

(define (ipfs-block-put bv)
  "Store a block on IPFS and return the CID of the block"
  (call (string-append (%ipfs-base-url)
                       "/api/v0/block/put"
                       "?format=raw&mhtype=blake2b-256")
        (lambda (port) (assoc-ref (json->scm port) "Key"))
        #:headers `((content-type
                     . (multipart/form-data
                        (boundary . ,%multipart-boundary))))
        #:body (call-with-bytevector-output-port
                (lambda (port) (bytevector->form-data bv port)))
        ;; IPFS daemon does not seem to accept connection re-use when putting
        ;; blocks.
        #:keep-alive #f))

(define* (ipfs-block-get cid #:key
                         (open-connection guix:open-connection-for-uri))
  "Get a block from IPFS via the HTTP API"
  (false-if-ipfs-error
   (call (string-append (%ipfs-base-url)
		        "/api/v0/block/get"
		        "?arg=" cid)
	 get-bytevector-all
         #:timeout 5
         #:open-connection open-connection)))

;; ERIS block reducer

(define eris-ipfs-reducer
  (case-lambda
    ;; initialization. Nothing to do here. In an improved implementation we
    ;; might create a single HTTP connection and reuse it for all blocks.
    (() '())

    ;; Completion. Again, nothing to do.
    ((_) 'done)

    ;; store a block
    ((_ ref-block)
     ;; ref-block is a pair consisting of the reference to the block and the
     ;; block itself.
     (ipfs-block-put (cdr ref-block)))))

(define* (eris-ipfs-ref ref #:key
                        (open-connection guix:open-connection-for-uri))
  "Dereference a block from IPFS"
  (ipfs-block-get (blake2b-256->cid ref)
                  #:open-connection open-connection))