(define-module (gnunet))

(use-modules ((system foreign) #:prefix ffi:))

(use-modules ((bytestructures guile)))


(define* (dynamic-link* #:optional library-name)
  (let ((shared-object (if library-name (dynamic-link library-name) (dynamic-link))))
    (lambda (return-value function-name . arguments)
      (let ((function (dynamic-func function-name shared-object)))
        (ffi:pointer->procedure return-value function arguments)))))

;; FIXME: this MUST NOT be public, expose exceptions instead
(define-public %gnunet-ok 1)
(define-public %gnunet-system-error -1)
(define-public %gnunet-yes 1)
(define-public %gnunet-no 0)

(define (check value . message)
  "Throw a 'gnunet-error if value is not %gnunet-ok aka. 1"
  (unless (eq? value %gnunet-ok)
    (throw 'gnunet-error message)))

(define (check2 value . message)
  "If value is a %null-pointer throw a 'gnunet-error. Return the value
otherwise"
  (if (eq? value ffi:%null-pointer)
      (throw 'gnunet-error message)
      value))

;; bytestructures helper

(define (pointer->bytestructure desc pointer)
  (let ((size (bytestructure-descriptor-size desc)))
    (let ((bv (ffi:pointer->bytevector pointer size)))
      (make-bytestructure bv 0 desc))))

;;; gnunet-util bindings, gnunet_util_lib.h

(define util (dynamic-link* "/gnu/store/1m1y318wi9w926l6p29d0izlcnf8gzjp-gnunet-fgg-0.10.1-1.b005d5e/lib/libgnunetutil.so"))

;; common

(define-public %scheduler-priority-keep 0)
(define-public %scheduler-priority-idle 1)
(define-public %scheduler-priority-background 2)
(define-public %scheduler-priority-default 3)
(define-public %scheduler-priority-high 4)
(define-public %scheduler-priority-ui 5)
(define-public %scheduler-priority-urgent 6)
(define-public %scheduler-priority-shutdown 7)
;; (define-public %scheduler-priority-count 8)

;; configuration

(define-public configuration-create
  (let ((func (util '* "GNUNET_CONFIGURATION_create")))
    (lambda ()
      "Create a new configuration object"
      (func))))

(define-public configuration-destroy!
  (let ((func (util ffi:void "GNUNET_CONFIGURATION_destroy" '*)))
    (lambda (configuration)
      "Destroy configuration object"
      (func configuration))))

(define-public configuration-load!
  (let ((func (util ffi:int "GNUNET_CONFIGURATION_load" '* '*)))
    (lambda (configuration filename)
      "Load configuration. This function will first parse the defaults
and then parse the specific configuration file to overwrite the
defaults."
      (check (func configuration (ffi:string->pointer filename))
             (format #f "Impossible to load configuration at ~a" filename)))))

;; crypto, gnunet_crypto_lib.h

(define %crypto-ecdsa-public-key (bs:struct `((q-y ,(bs:vector (/ 256 8) uint8)))))

;; scheduler

(define-public %scheduler-reason-none 0)
(define-public %scheduler-reason-startup 1)
(define-public %scheduler-reason-shutdown 2)
(define-public %scheduler-reason-timeout 4)
(define-public %scheduler-reason-read-ready 8)
(define-public %scheduler-reason-write-ready 16)
(define-public %scheduler-reason-prereq-done 32)

(define-public %scheduler-event-type-none 0)
(define-public %scheduler-event-type-in 1)
(define-public %scheduler-event-type-out 2)
(define-public %scheduler-event-type-hup 4)
(define-public %scheduler-event-type-error 8)
(define-public %scheduler-event-type-priority 16)
(define-public %scheduler-event-type-nval 32)

(define-public scheduler-run
  (let ((func (util ffi:void "GNUNET_SCHEDULER_run" '* '*)))
    (lambda (thunk)
      "Initialize and run scheduler.  This procedure will return when
all tasks have completed.  On systems with signals, receiving a
SIGTERM (and other similar signals) will cause
#GNUNET_SCHEDULER_shutdown to be run after the active task is
complete.  As a result, SIGTERM causes all shutdown tasks to be
scheduled with reason #GNUNET_SCHEDULER_REASON_SHUTDOWN.  (However,
tasks added afterwards will execute normally!).  Note that any
particular signal will only shut down one scheduler; applications
should always only create a single scheduler.

THUNK is task to run first (and immediately)"
      (func (ffi:procedure->pointer ffi:void thunk '()) ffi:%null-pointer))))

(define-public scheduler-add-with-reason-and-priority
  (let ((func (util ffi:void
                    "GNUNET_SCHEDULER_add_with_reason_and_priority"
                    '*
                    '*
                    ffi:int
                    ffi:int)))
    (lambda (thunk reason priority)
      "Continue the current execution with the given function."
      (func (ffi:procedure->pointer ffi:void thunk '())
            ffi:%null-pointer
            reason
            priority))))

(define-public scheduler-add-shutdown
  (let ((func (util '* "GNUNET_SCHEDULER_shutdown" '* '*)))
    (lambda (thunk)
      "Schedule a new task to be run on shutdown, that is when a
CTRL-C signal is received, or when #GNUNET_SCHEDULER_shutdown() is
being invoked.

Return unique task identifier for the job, valid until THUNK is
started."
      (func (ffi:procedure->pointer ffi:void thunk '())))))

;; time

(define %time-absolute (bs:struct `((abs-value-us ,uint64))))

(define %time-relative (bs:struct `((rel-value-us ,uint64))))

(define-public time-absolute-get
  (let ((func (util ffi:uint64 "GNUNET_TIME_absolute_get")))
    (lambda ()
      "Return the current time in microseconds"
      (func))))

;;; gnunet-fs bindings

(define fs (dynamic-link* "/gnu/store/1m1y318wi9w926l6p29d0izlcnf8gzjp-gnunet-fgg-0.10.1-1.b005d5e/lib/libgnunetfs.so"))

;; uri

(define-public string->uri
  (let ((func (fs '* "GNUNET_FS_uri_parse" '* '*)))
    (lambda (string)
      (func (ffi:string->pointer string) ffi:%null-pointer))))

(define-public uri-destroy
  (let ((func (fs ffi:void "GNUNET_FS_uri_destroy" '*)))
    (lambda (uri)
      "Destroy uri"
      (func uri))))

(define-public uri-chk-get-file-size
  (let ((func (fs ffi:uint64 "GNUNET_FS_uri_chk_get_file_size" '*)))
    (lambda (uri)
      "Size of file URI refers to"
      (func uri))))

;; other fs stuff

(define %fs-options-end 0)
(define %fs-options-download-parallelism 1)
(define %fs-options-request-parallelism 2)

(define-public %fs-flags-none 0)
(define-public %fs-flags-persistence 1)
(define-public %fs-flags-do-probes 2)

(define-public %fs-status-publish-start 0)
(define-public %fs-status-publish-resume 1)
(define-public %fs-status-publish-suspend 2)
(define-public %fs-status-publish-progress 3)
(define-public %fs-status-publish-error 4)
(define-public %fs-status-publish-completed 5)
(define-public %fs-status-publish-stopped 6)
(define-public %fs-status-download-start 7)
(define-public %fs-status-download-resume 8)
(define-public %fs-status-download-suspend 9)
(define-public %fs-status-download-progress 10)
(define-public %fs-status-download-error 11)
(define-public %fs-status-download-completed 12)
(define-public %fs-status-download-stopped 13)
(define-public %fs-status-download-active 14)
(define-public %fs-status-download-inactive 15)
(define-public %fs-status-download-lost-parent 16)
(define-public %fs-status-search-start 17)
(define-public %fs-status-search-resume 18)
(define-public %fs-status-search-resume-result 19)
(define-public %fs-status-search-suspend 20)
(define-public %fs-status-search-result 21)
(define-public %fs-status-search-result-namespace 22)
(define-public %fs-status-search-update 23)
(define-public %fs-status-search-error 24)
(define-public %fs-status-search-pause 25)
(define-public %fs-status-search-continued 26)
(define-public %fs-status-search-result-stopped 27)
(define-public %fs-status-search-result-suspend 28)
(define-public %fs-status-search-stopped 29)
(define-public %fs-status-unindex-start 30)
(define-public %fs-status-unindex-resume 31)
(define-public %fs-status-unindex-suspend 32)
(define-public %fs-status-unindex-progress 33)
(define-public %fs-status-unindex-error 34)
(define-public %fs-status-unindex-completed 35)
(define-public %fs-status-unindex-stopped 36)
(define-public %fs-status-publish-progress-directory 37)

; progress info struct

(define %fs-progress-info-publish
  (bs:struct
   `((publish-context ,uintptr_t)
     (file-information ,uintptr_t)
     (client-context ,uintptr_t)
     (parent-context ,uintptr_t)
     (filename ,uintptr_t)
     (size ,uint64)
     (eta ,%time-relative)
     (duration ,%time-relative)
     (completed ,uint64)
     (anonymity ,uint32)
     (specifics
      ,(bs:union `((progress
                    ,(bs:struct `((data ,uintptr_t)
                                  (offset ,uint64)
                                  (data-length ,uint64)
                                  (depth ,unsigned-int))))
                   (progress-directory
                    ,(bs:struct `((completed ,uint64)
                                  (total ,uint64)
                                  (eta ,%time-relative))))
                   (resume
                    ,(bs:struct `((message ,uintptr_t)
                                  (chk-uri ,uintptr_t)
                                  (sks-uri ,uintptr_t))))
                   (completed
                    ,(bs:struct `((chk-uri ,uintptr_t)
                                  (sks-uri ,uintptr_t))))
                   (error
                    ,(bs:struct `((message ,uintptr_t))))))))))

(define %fs-progress-info-download
  (bs:struct
   `((download-context ,uintptr_t)
     (client-context ,uintptr_t)
     (parent-context ,uintptr_t)
     (search-context ,uintptr_t)
     (uri ,uintptr_t)
     (filename ,uintptr_t)
     (size ,uint64)
     (eta ,%time-relative)
     (duration ,%time-relative)
     (completed ,uint64)
     (anonymity ,uint32)
     (active? ,int)
     (specifics
      ,(bs:union `((progress
                    ,(bs:struct `((data ,uintptr_t)
                                  (offset ,uint64)
                                  (data-length ,uint64)
                                  (block-download-duration ,%time-relative)
                                  (depth ,unsigned-int)
                                  (respect-offered ,uint32)
                                  (number-of-transmissions ,uint32))))
                   (start
                    ,(bs:struct `((meta ,uintptr_t))))
                   (resume
                    ,(bs:struct `((meta ,uintptr_t)
                                  (message ,uintptr_t))))
                   (error
                    ,(bs:struct `((message ,uintptr_t))))))))))

(define %fs-progress-info-search
  (bs:struct
   `((search-context ,uintptr_t)
     (client-context ,uintptr_t)
     (parent-context ,uintptr_t)
     (query ,uintptr_t)
     (duration ,%time-relative)
     (anonymity ,uint32)
     (specifics
      ,(bs:union `((result
                    ,(bs:struct `((meta ,uintptr_t)
                                  (uri ,uintptr_t)
                                  (result ,uintptr_t)
                                  (applicability-rank ,uint32))))
                   (resume-result
                    ,(bs:struct `((meta ,uintptr_t)
                                  (uri ,uintptr_t)
                                  (result ,uintptr_t)
                                  (availability-rank ,int32)
                                  (availability-certainty ,uint32)
                                  (applicability-rank ,uint32))))
                   (update
                    ,(bs:struct `((client-context ,uintptr_t)
                                  (meta ,uintptr_t)
                                  (uri ,uintptr_t)
                                  (availability-rank ,int32)
                                  (availability-certainty ,uint32)
                                  (applicability-rank ,uint32)
                                  (current-probe-time ,%time-relative))))
                   (result-suspend
                    ,(bs:struct `((client-context ,uintptr_t)
                                  (meta ,uintptr_t)
                                  (uri ,uintptr_t))))
                   (result-stopped
                    ,(bs:struct `((client-context ,uintptr_t)
                                  (meta ,uintptr_t)
                                  (uri ,uintptr_t))))
                   (resume
                    ,(bs:struct `((message ,uintptr_t)
                                  (paused? ,int))))
                   (error
                    ,(bs:struct `((message ,uintptr_t))))
                   (result-namespace
                    ,(bs:struct `((name ,uintptr_t)
                                  (root ,uintptr_t)
                                  (meta ,uintptr_t)
                                  (pseudonym ,%crypto-ecdsa-public-key))))))))))

(define %fs-progress-info-unindex
  (bs:struct
   `((unindex-context ,uintptr_t)
     (client-context ,uintptr_t)
     (filename ,uintptr_t)
     (size ,uint64)
     (eta ,%time-relative)
     (duration ,%time-relative)
     (completed ,uint64)
     (specifics
      ,(bs:union `((progress
                    ,(bs:struct `((data ,uintptr_t)
                                  (offset ,uint64)
                                  (data-length ,uint64)
                                  (depth ,unsigned-int))))
                   (resume
                    ,(bs:struct `((message ,uintptr_t))))
                   (error
                    ,(bs:struct `((message ,uintptr_t))))))))))

(define-public %fs-progress-info
  (bs:struct
   `((value
      ,(bs:union `((publish ,%fs-progress-info-publish)
                   (download ,%fs-progress-info-download)
                   (search ,%fs-progress-info-search)
                   (unindex ,%fs-progress-info-unindex))))
     (status ,int)
     (handle ,uintptr_t))))

(define-public (fs-progress-info-status info)
  (bytestructure-ref info 'status))

(define (progress-callback-wrapper callback)
  (lambda (_ info)
    (callback (pointer->bytestructure %fs-progress-info info))))

(define (procedure->progress-callback callback)
  (ffi:procedure->pointer ffi:void (progress-callback-wrapper callback) '(* *)))

(define-public fs-start
  (let ((func (fs '*
                  "GNUNET_FS_start"
                  '* '* '* '* ffi:int ffi:int ffi:unsigned-int ffi:int ffi:unsigned-int ffi:int)))
    (lambda* (configuration
              client-name
              progress-callback
              #:key
              (flags %fs-flags-none)
              (download-parallelism 16)
              (request-parallelism (* 10 1024)))
      "Setup a connection to the file-sharing service.

Return a handle to the file-sharing service"
      (let ((handle
             (func configuration
                   (ffi:string->pointer client-name)
                   (procedure->progress-callback progress-callback)
                   ffi:%null-pointer ;; callback closure is null
                                     ;; because guile can do it
                   flags
                   %fs-options-download-parallelism
                   download-parallelism
                   %fs-options-request-parallelism
                   request-parallelism
                   %fs-options-end
                   )))
      (check2 handle "Impossible to connect to file-sharing service.")))))


(define-public fs-stop
  (let ((func (fs ffi:void "GNUNET_FS_stop" '*)))
    (lambda (handle)
      (func handle))))

(define-public %fs-download-option-none 0)
(define-public %fs-download-option-loopback-only 1)
(define-public %fs-download-option-recursive 2)
(define-public %fs-download-no-temporaries 4)
(define-public %fs-download-is-probe (ash 1 31))

(define-public fs-download-start
  (let ((func (fs '*
                  "GNUNET_FS_download_start"
                  '* '* '* '* '* ffi:uint64 ffi:uint64 ffi:uint32 ffi:unsigned-int '* '*)))
    (lambda* (handle
             uri
             anonymity
             #:key
             (meta #f)
             (filename #f)
             (tempname #f)
             (offset 0)
             (length (uri-chk-get-file-size uri))
             (options %fs-download-option-none)
             (client-context #f)
             (parent #f))
      "Download parts of a file.  Note that this will store
the blocks at the respective offset in the given file.  Also, the
download is still using the blocking of the underlying FS
encoding.  As a result, the download may *write* outside of the
given boundaries (if offset and length do not match the 32k FS
block boundaries).

The given range can be used to focus a download towards a
particular portion of the file (optimization), not to strictly
limit the download to exactly those bytes.

HANDLE is the handle the file-sharing service.  URI is the URI of the
file (determines what to download); CHK or LOC URI.  ANONYMITY defines
the level of anonymity for the download."
      (func handle
            uri
            (or meta ffi:%null-pointer)
            (or (and filename (ffi:string->pointer filename)) ffi:%null-pointer)
            (or (and tempname (ffi:string->pointer tempname)) ffi:%null-pointer)
            offset
            length
            anonymity
            options
            (or client-context ffi:%null-pointer)
            (or parent ffi:%null-pointer)))))

;; gnunet-identity bindings

(define identity (dynamic-link* "/gnu/store/1m1y318wi9w926l6p29d0izlcnf8gzjp-gnunet-fgg-0.10.1-1.b005d5e/lib/libgnunetidentity.so"))