(module fam "fam-base.ss"

  (provide fam-available?
           make-fam)

  (require "fam-utils.ss"
           (lib "etc.ss")
           (lib "file.ss"))
  (require (lib "foreign.ss")) (unsafe!)

  (define (%try proc . args)
    (with-handlers ((exn:fail? (lambda (x) #f)))
      (apply proc args)))

  (define %get-ffi-obj
    (lambda args
      (or (apply %try get-ffi-obj args)
          (lambda x -1))))

  (define libfam (or (%try ffi-lib "libfam")
                     (%try ffi-lib "libgamin")))

  (define (fam-available?) (if libfam #t #f))

  (define _FAMCodes
    (_enum '(fam-event-null = 0
             fam-event-modified = 1
             fam-event-deleted = 2
             fam-event-exec-start = 3
             fam-event-exec-stop = 4
             fam-event-created = 5
             fam-event-moved = 6
             fam-event-acknowledge = 7
             fam-event-found = 8
             fam-event-eol = 9)))

  (define *max-path-len* 4096)
  (define _Buffer
    (make-cstruct-type (build-list *max-path-len* (lambda (i) _byte))))

  (define-cstruct _FAMConnection ((fd _int) (extra _pointer)))
  (define-cstruct _FAMRequest ((reqnum _int)))
  (define-cstruct _FAMEvent ((fc _FAMConnection-pointer)
                             (fr _FAMRequest)
                             (hostname _pointer)
                             (filename _Buffer)
                             (userData _pointer)
                             (code _FAMCodes)))

  (defclass <fam-connection> () conn files event
    :autoaccessors #t :autoinitargs #t)

  (define (fam-open)
    (define %open-fam
      (%get-ffi-obj "FAMOpen" libfam
                    (_fun (conn : (_ptr o _FAMConnection)) ->  (d : _int)
                          -> (values (= 0 d) conn))))
    (let-values (((result conn) (%open-fam)))
      (and result (ptr-ref conn _FAMConnection 0))))

  (define (make-fam)
    (let ((conn (and (fam-available?) (fam-open))))
      (and conn
           (make <fam-connection> :conn conn
                                  :files '()
                                  :event (malloc (ctype-sizeof _FAMEvent))))))

  (defmethod (fam-release (fc <fam-connection>))
    (define %close-fam
      (%get-ffi-obj "FAMClose" libfam (_fun _FAMConnection-pointer -> _int)))
    (= 0 (%close-fam (fam-connection-conn fc))))

  (define %monitor-directory
    (%get-ffi-obj "FAMMonitorDirectory" libfam
                  (_fun _FAMConnection-pointer
                        _file
                        _FAMRequest-pointer
                        _string -> _int)))

  (define %monitor-file
    (%get-ffi-obj "FAMMonitorFile" libfam
                  (_fun _FAMConnection-pointer
                        _file
                        _FAMRequest-pointer
                        _string -> _int)))

  (defmethod (fam-monitor-path (fc <fam-connection>) pathname)
    (let ((pathname (path->string (path->complete-path pathname))))
      (if (assoc pathname (fam-connection-files fc))
          #t
          (let* ((is-file? (is-file-path? pathname)))
            (let ((conn (fam-connection-conn fc))
                  (req (make-FAMRequest 0))
                  (ffun (if is-file? %monitor-file %monitor-directory)))
              (and (= 0 (ffun conn pathname req pathname))
                   (begin
                     (set-fam-connection-files!
                      fc
                      (cons (cons pathname req) (fam-connection-files fc)))
                     #t)))))))

  (defmethod (fam-monitored-paths (fc <fam-connection>))
    (map car (fam-connection-files fc)))

  (define (%path->req fc path)
    (cond ((assoc path (fam-connection-files fc)) => cdr)
          (else #f)))

  (define (%req->%path fc req)
    (let loop ((paths (fam-connection-files fc)))
      (cond ((null? paths) "")
            ((= (FAMRequest-reqnum (cdar paths))
                (FAMRequest-reqnum req))
             (caar paths))
            (else (loop (cdr paths))))))

  (define-syntax %c+r-ffun
    (syntax-rules ()
      ((%a2fun ffi-name exp-name)
       (defmethod (exp-name (fc <fam-connection>) file)
         (define ffun
           (%get-ffi-obj ffi-name libfam
                         (_fun _FAMConnection-pointer _FAMRequest-pointer
                               -> _int)))
         (let ((conn (fam-connection-conn fc))
               (req (%path->req fc file)))
           (and ffun req (= 0 (ffun conn req))))))))


  (%c+r-ffun "FAMSuspendMonitor" fam-suspend-path-monitoring)
  (%c+r-ffun "FAMResumeMonitor" fam-resume-path-monitoring)
  (%c+r-ffun "FAMCancelMonitor" fam-cancel-path-monitoring)

  (define %pending
    (%get-ffi-obj "FAMPending" libfam (_fun _FAMConnection-pointer -> _int)))

  (defmethod (fam-any-event? (fc <fam-connection>))
    (let ((cn (fam-connection-conn fc)))
      (> (%pending cn) 0)))

  (define %next-event
    (%get-ffi-obj "FAMNextEvent" libfam
                  (_fun _FAMConnection-pointer (ev : _pointer)
                        -> (d : _int) -> (values (= d 1)
                                                 (ptr-ref ev _FAMEvent 0)))))

  (define (%bs->path bs)
    (let ((match (regexp-match #rx#"(?>([^\0]+)\0)" bs)))
      (if match (path->string (bytes->path (cadr match))) "")))

  (defmethod (fam-next-event (fc <fam-connection>) &optional (wait #f))
    (and (or wait (fam-any-event? fc))
         (let-values (((result event) (%next-event (fam-connection-conn fc)
                                                   (fam-connection-event fc))))
           (and result
                (let* ((mpath (%req->%path fc (FAMEvent-fr event)))
                       (fby (make-sized-byte-string (FAMEvent-filename event)
                                                    *max-path-len*))
                       (file (path->string
                              (path->complete-path (%bs->path fby) mpath)))
                       (time (last-modification-time file)))
                  (make <fam-event> :monitored-path mpath
                                    :path file
                                    :type (FAMEvent-code event)
                                    :timestamp time))))))

  (defmethod (fam-pending-events (fc <fam-connection>))
    (let loop ((next (fam-next-event fc)) (events '()))
      (if (not next)
          (reverse events)
          (loop (fam-next-event fc) (cons next events)))))
)