#lang scheme
(require
 (planet murphy/packed-io:1:0)
 "../main.ss"
 "handle.ss")

(define (file-handle->input-port handle [name (string->some-system-path
                                               (stat-name (send handle read-stat))
                                               'unix)])
  (let ([offset (send handle offset)])
    (if offset
        (make-input-port
         name
         (λ (buffer)
           (let ([data (send handle read (bytes-length buffer))])
             (if (not (eof-object? data))
                 (begin
                   (bytes-copy! buffer 0 data)
                   (bytes-length data))
                 eof)))
         #f
         (λ ()
           (send handle clunk))
         #f #f #f
         void
         (add1 offset))
        (raise-type-error 'file-handle->input-port "open file handle" handle))))

(define (file-handle->output-port handle [name (string->some-system-path
                                                (stat-name (send handle read-stat))
                                                'unix)])
  (let ([offset (send handle offset)])
    (if offset
        (make-output-port
         name
         always-evt
         (λ (data start end dont-block? enable-breaks?)
           (send handle write (subbytes data start end)))
         (λ ()
           (send handle clunk))
         #f #f #f #f
         void
         (add1 offset))
        (raise-type-error 'file-handle->output-port "open file handle" handle))))

(define (explode-path path)
  (let next ([names null] [path (simplify-path path #f)])
    (case path
      [(relative #f)
       names]
      [else
       (let-values ([(base name must-be-dir?) (split-path path)])
         (next
          (cons (case name
                  [(same) "."]
                  [(up) ".."]
                  [else (some-system-path->string name)])
                names)
          base))])))

(define (9p-open-input-file anchor path)
  (let ([file
         (foldl
          (λ (name anchor)
            (send anchor walk name))
          anchor (explode-path path))])
    (send file open (open-mode r))
    (file-handle->input-port file)))

(define (9p-open-output-file anchor path
                             #:exists [exists-flag 'error]
                             #:permissions [perm (file-mode (type file)
                                                            (user r w) (group r) (others r))])
  (let*-values ([(steps names)
                 (split-at-right (explode-path path) 1)]
                [(name)
                 (car names)]
                [(parent)
                 (foldl
                  (λ (name anchor)
                    (send anchor walk name))
                  anchor steps)]
                [(file i/o-unit)
                 (cond
                   [(with-handlers ([exn:fail:filesystem:9p? (λ (exn) #f)])
                      (send parent walk name))
                    => (λ (file)
                         (case exists-flag
                           [(error)
                            (raise
                             (make-exn:fail:filesystem:exists
                              (format "~a: file ~e already exists below ~e"
                                      '9p-open-output-file path anchor)
                              (current-continuation-marks)))]
                           [(replace)
                            (send file remove)
                            (send parent create name perm (open-mode w))]
                           [(truncate must-truncate)
                            (values file
                                    (send file open (open-mode w trunc)))]
                           [(truncate/replace)
                            (or (with-handlers ([exn:fail:filesystem:9p? (λ (exn) #f)])
                                  (values file
                                          (send file open (open-mode w trunc))))
                                (begin
                                  (send file remove)
                                  (send parent create name perm (open-mode w))))]
                           [(update can-update)
                            (values file
                                    (send file open (open-mode w)))]
                           [(append)
                            (values file
                                    (begin0
                                      (send file open (open-mode w))
                                      (send file offset (stat-length (send file read-stat)))))]))]
                   [else
                    (case exists-flag
                      [(update must-truncate)
                       (raise
                        (make-exn:fail:filesystem
                         (format "~a: file ~e does not exist below ~e"
                                 '9p-open-output-file path anchor)
                         (current-continuation-marks)))]
                      [else
                       (send parent create name perm (open-mode w))])])])
    (file-handle->output-port file)))

(define (call-with-9p-input-file anchor path proc)
  (proc (9p-open-input-file anchor path)))

(define (call-with-9p-input-file* anchor path proc)
  (let ([port (9p-open-input-file anchor path)])
    (dynamic-wind
     void
     (λ ()
       (proc port))
     (λ ()
       (close-input-port port)))))

(define (with-input-from-9p-file anchor path thunk)
  (call-with-9p-input-file*
   anchor path
   (λ (port)
     (parameterize ([current-input-port port])
       (thunk)))))

(define (call-with-9p-output-file anchor path proc
                                  #:exists [exists-flag 'error]
                                  #:permissions [perm (file-mode (type file)
                                                                 (user r w) (group r) (others w))])
  (proc (9p-open-output-file anchor path #:exists exists-flag #:permissions perm)))

(define (call-with-9p-output-file* anchor path proc
                                   #:exists [exists-flag 'error]
                                   #:permissions [perm (file-mode (type file)
                                                                  (user r w) (group r) (others w))])
  (let ([port (9p-open-output-file anchor path #:exists exists-flag #:permissions perm)])
    (dynamic-wind
     void
     (λ ()
       (proc port))
     (λ ()
       (close-output-port port)))))

(define (with-output-to-9p-file anchor path thunk
                                #:exists [exists-flag 'error]
                                #:permissions [perm (file-mode (type file)
                                                               (user r w) (group r) (others w))])
  (call-with-9p-output-file*
   anchor path
   (λ (port)
     (parameterize ([current-output-port port])
       (thunk)))
   #:exists exists-flag #:permissions perm))

(provide/contract
 [file-handle->input-port (->* ((is-a?/c file-handle<%>)) (any/c) input-port?)]
 [file-handle->output-port (->* ((is-a?/c file-handle<%>)) (any/c) output-port?)]
 [9p-open-input-file (-> (is-a?/c directory-handle<%>)
                         (and/c path-string? relative-path?)
                         input-port?)]
 [call-with-9p-input-file (-> (is-a?/c directory-handle<%>)
                              (and/c path-string? relative-path?)
                              (-> input-port? any)
                              any)]
 [call-with-9p-input-file* (-> (is-a?/c directory-handle<%>)
                               (and/c path-string? relative-path?)
                               (-> input-port? any)
                               any)]
 [with-input-from-9p-file (-> (is-a?/c directory-handle<%>)
                              (and/c path-string? relative-path?)
                              (-> any)
                              any)]
 [9p-open-output-file (->* ((is-a?/c directory-handle<%>)
                            (and/c path-string? relative-path?))
                           (#:exists
                            (symbols 'error 'append 'update 'replace 'truncate 'truncate/replace)
                            #:permissions
                            (packing-contract uint/p))
                           output-port?)]
 [call-with-9p-output-file (->* ((is-a?/c directory-handle<%>)
                                 (and/c path-string? relative-path?)
                                 (-> output-port? any))
                                (#:exists
                                 (symbols 'error 'append 'update 'replace 'truncate 'truncate/replace)
                                 #:permissions
                                 (packing-contract uint/p))
                                any)]
 [call-with-9p-output-file* (->* ((is-a?/c directory-handle<%>)
                                  (and/c path-string? relative-path?)
                                  (-> output-port? any))
                                 (#:exists
                                  (symbols 'error 'append 'update 'replace 'truncate 'truncate/replace)
                                  #:permissions
                                  (packing-contract uint/p))
                                 any)]
 [with-output-to-9p-file (->* ((is-a?/c directory-handle<%>)
                               (and/c path-string? relative-path?)
                               (-> any))
                              (#:exists
                               (symbols 'error 'append 'update 'replace 'truncate 'truncate/replace)
                               #:permissions
                               (packing-contract uint/p))
                              any)])