Changeset 30676 in project


Ignore:
Timestamp:
04/09/14 23:11:24 (6 years ago)
Author:
Alaric Snell-Pym
Message:

9: factored out virtual filesystem from demo server.

Location:
release/4/9p/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/9p/trunk/9p-demo-server.scm

    r27516 r30676  
    1 (use 9p-server 9p-lolevel tcp)
    2 
    3 (define (dump-message Ttype message)
    4   (printf "~S: ~S\n" Ttype message))
    5 
    6 (define (dump-message-fid Ttype message fid-value)
    7   (printf "~S: ~S ~S\n" Ttype message fid-value))
    8 
    9 (define-record file
    10   type
    11   id
    12   name
    13   perms
    14   uname
    15   gname
    16   muname
    17   size-if-known ; if #f, get-contents will be called and the result measured
    18   atime
    19   mtime
    20   get-contents ; Closure that returns a u8vector, blob or string, given the file object and the Open State
    21   parent-id ; Parent directory ID
    22   children ; List of child file objects
    23   handle-open! ; returns a new Open State
    24   handle-clunk! ; passed an Open State
    25   )
    26 
    27 (define-record-printer (file f out)
    28   (fprintf out "#<file ~s: ~s>"
    29            (file-id f)
    30            (file-name f)))
    31 
    32 (define (file-qid file)
    33   (make-qid (file-type file) 1 (file-id file)))
    34 
    35 (define (file-stat file)
    36   (list (file-qid file)
    37         (bitwise-ior (file-perms file) (arithmetic-shift (file-type file) 24))
    38         (file-atime file)
    39         (file-mtime file)
    40         (file-size file)
    41         (file-name file)
    42         (file-uname file)
    43         (file-gname file)
    44         (file-muname file)))
    45 
    46 (define (file-contents file user-state)
    47   (let ((c ((file-get-contents file) file user-state)))
    48     (cond
    49      ((u8vector? c) c)
    50      ((string? c) (blob->u8vector/shared (string->blob c)))
    51      ((blob? c) (blob->u8vector/shared c))
    52      (else (error "Invalid file contents" c)))))
    53 
    54 (define (file-size file)
    55   (if (zero? (bitwise-and (file-type file) qtdir))
    56    (if (file-size-if-known file)
    57        (file-size-if-known file)
    58        (u8vector-length (file-contents file #f)))
    59    0)) ; Directories must report zero size
    60 
    61 (define-record filesystem
    62   files
    63   file-id-counter)
    64 
    65 (define-record directory-reader
    66   last-offset
    67   remaining-entries)
    68 
    69 (define (new-filesystem root-perms root-uname root-gname root-atime root-mtime)
    70   (let ((fs (make-filesystem (make-hash-table) 1)))
    71     (hash-table-set! (filesystem-files fs) 0
    72                      (make-file
    73                       qtdir
    74                       0
    75                       "/"
    76                       root-perms
    77                       root-uname
    78                       root-gname
    79                       root-uname
    80                       #f
    81                       root-atime
    82                       root-mtime
    83                       #f ; Directories never have their contents asked for
    84                       #f
    85                       '()
    86                       (lambda (file) (make-directory-reader 0 (map file-stat (file-children file))))
    87                       (lambda (file state) (void))))
    88     fs))
    89 
    90 (define (insert-file! filesystem type name perms uname gname muname size-if-known atime mtime get-contents parent-id handle-open! handle-clunk!)
    91   (let* ((id (filesystem-file-id-counter filesystem))
    92          (f (make-file type id name perms uname gname muname size-if-known atime mtime get-contents parent-id '() handle-open! handle-clunk!))
    93          (parent-dir (if parent-id
    94                          (hash-table-ref (filesystem-files filesystem) parent-id)
    95                          #f)))
    96     (filesystem-file-id-counter-set! filesystem (+ id 1))
    97     (hash-table-set! (filesystem-files filesystem) id f)
    98     (when parent-dir
    99           (let* ((old-children (file-children parent-dir))
    100                  (new-children (cons f old-children)))
    101             (file-children-set! parent-dir new-children)))
    102     f))
    103 
    104 ;; FIXME: Add remove-file!, insert-directory!, remove-directory!, etc.
    105 
    106 (define (filesystem-file filesystem id)
    107   (hash-table-ref (filesystem-files filesystem) id))
    108 
    109 (define (filesystem-root filesystem)
    110   (filesystem-file filesystem 0))
    111 
    112 (define (filesystem-walk filesystem parent-dir name)
    113   (call-with-current-continuation
    114    (lambda (return)
    115      (let ((dirlist (file-children parent-dir)))
    116        (if (list? dirlist)
    117            (for-each (lambda (file)
    118                        (when (string=? (file-name file) name)
    119                              (return file)))
    120                      dirlist)
    121            #f) ;; #f not a directory
    122        #f)))) ;; #f not found
     1(use 9p-server-vfs 9p-lolevel tcp srfi-18 posix)
    1232
    1243;; A static filesystem (for now)
     
    1265(define filesystem (new-filesystem
    1276                    (+ perm/irusr perm/ixusr perm/irgrp perm/ixgrp perm/iroth perm/ixoth)
    128                     "root"
    129                     "root"
    130                     0
    131                     0))
     7                    "0"
     8                    "0"
     9                    (current-seconds)
     10                    (current-seconds) #t))
    13211
    133 (insert-file! filesystem
    134               qtfile
    135               "hello"
    136               (+ perm/irusr perm/irgrp perm/iroth)
    137               "root"
    138               "root"
    139               "root"
    140               #f
    141               0
    142               0
    143               (lambda (file state) (if state state "")) ; The open state IS the contents
    144               0
    145               (lambda (file) "Hello, world!\n")
    146               (lambda (file state) (void)))
     12(insert-static-file! filesystem
     13                     "hello"
     14                     (+ perm/irusr perm/irgrp perm/iroth)
     15                     "0"
     16                     "0"
     17                     "0"
     18                     (current-seconds) (current-seconds)
     19                     "Hello, World!\n"
     20                     0)
    14721
    148 (insert-file! filesystem
    149               qtfile
    150               "test"
    151               (+ perm/irusr perm/irgrp perm/iroth)
    152               "root"
    153               "root"
    154               "root"
    155               #f
    156               0
    157               0
    158               (lambda (file state) (if state state "")) ; The state IS the contents
    159               0
    160               (lambda (file) "Hello, again!\n")
    161               (lambda (file state) (void)))
     22(define subdir
     23  (insert-directory! filesystem
     24                     "dynamic-content"
     25                     (+ perm/irusr perm/irgrp perm/iroth
     26                        perm/ixusr perm/ixgrp perm/ixoth)
     27                     "0"
     28                     "0"
     29                     "0"
     30                     (current-seconds) (current-seconds)
     31                     0))
    16232
    163 ;; 9P2000
    164 
    165 (define-record file-open
    166   file
    167   contents
    168   user-state)
    169 
    170 (define-record-printer (file-open fo out)
    171   (fprintf out "#<file-open ~s/~s>"
    172            (file-open-file fo)
    173            (file-open-user-state fo)))
    174 
    175 (define +block-size+ 16384)
    176 
    177 (define (handle-version message)
    178   (dump-message 'Tversion message)
    179   (min +block-size+ (car message)))
    180 
    181 (define (handle-auth message bind-fid! reply! error!)
    182   (dump-message 'Tauth message)
    183   (error! "You don't need to authenticate with me.")
    184   (void))
    185 
    186 (define (handle-flush message reply! error!)
    187   (dump-message 'Tflush message)
    188   (reply! '())
    189   (void))
    190 
    191 (define (handle-attach message auth-fid-value bind-fid! reply! error!)
    192   (dump-message-fid 'Tattach message auth-fid-value)
    193   (let ((root (filesystem-root filesystem)))
    194    (bind-fid! (make-file-open root #f #f))
    195    (reply! (list (file-qid root)))))
    196 
    197 (define (handle-walk message parent-fid-value bind-fid! reply! error!)
    198   (dump-message-fid 'Twalk message parent-fid-value)
    199   (let loop ((names (caddr message))
    200              (parent (file-open-file parent-fid-value))
    201              (qids '()))
    202     (cond
    203      ((null? names)
    204       (bind-fid! (make-file-open parent #f #f))
    205       (reply! (list (reverse qids))))
    206      (else
    207       (let* ((name (car names))
    208              (child (filesystem-walk filesystem parent name)))
    209         (if child
    210             (loop (cdr names)
    211                   child
    212                   (cons (file-qid child) qids))
    213             (begin ;; Nonexistant child, stop here
    214               (if (null? qids)
    215                   (error! "Unknown filename")
    216                   (reply! (list (reverse qids)))))))))))
    217 
    218 (define (handle-open message fid-value reply! error!)
    219   (dump-message-fid 'Topen message fid-value)
    220   (let* ((file (file-open-file fid-value))
    221          (user-state ((file-handle-open! file) file)))
    222     (file-open-user-state-set! fid-value user-state)
    223     (if (eq? (file-type file) qtdir)
    224      (file-open-contents-set! fid-value #f)
    225      (file-open-contents-set! fid-value (file-contents file user-state)))
    226     (reply! (list (file-qid file) +block-size+))))
    227 
    228 (define (handle-create message fid-value reply! error!)
    229   (dump-message-fid 'Tcreate message fid-value)
    230   (error! "Not yet implemented"))
    231 
    232 (define (handle-file-read message fid-value reply! error!)
    233   (let* ((file (file-open-file fid-value))
    234          (contents (file-open-contents fid-value))
    235          (offset (second message))
    236          (count (min (- (u8vector-length contents) offset)
    237                      (third message))))
    238     (reply! (list
    239              (subu8vector contents offset (+ offset count))))))
    240 
    241 (define (handle-dir-read message fid-value reply! error!)
    242   (let* ((file (file-open-file fid-value))
    243          (reader (file-open-user-state fid-value))
    244          (previous-offset (directory-reader-last-offset
    245                            reader))
    246          (offset (second message))
    247          (remaining-entries
    248           (if (zero? offset)
    249               (map file-stat (file-children file))
    250               (directory-reader-remaining-entries
    251                reader)))
    252          (count (third message)))
    253     (if ;; Enforce rules about directory reads - they must be sequential
    254      (not (or
    255            (= previous-offset offset)
    256            (= offset 0)))
    257      (error! "Directory reads must be from the previous offset or back to 0")
    258      (begin
    259        ;; Return as many whole stat entries as can be packed into a read
    260        ;; without leaving any partials
    261        ;; Each stat entry is prefixed with its length in bytes, so we can
    262        ;; skip thruogh the chain easily.
    263        (receive (response new-remaining-entries)
    264                 (full-directory-listing->data
    265                  remaining-entries count)
    266                 (directory-reader-last-offset-set!
    267                  reader (+ offset (u8vector-length response)))
    268                 (directory-reader-remaining-entries-set!
    269                  reader new-remaining-entries)
    270                 (reply! (list response)))))))
    271 
    272 (define (handle-read message fid-value reply! error!)
    273   (dump-message-fid 'Tread message fid-value)
    274   (let ((file (file-open-file fid-value)))
    275     (if (eq? (file-type file)
    276              qtdir)
    277         (handle-dir-read message fid-value reply! error!)
    278         (handle-file-read message fid-value reply! error!))))
    279 
    280 (define (handle-write message fid-value reply! error!)
    281   (dump-message-fid 'Twrite message fid-value)
    282   (error! "Not yet implemented"))
    283 
    284 (define (handle-clunk fid-value reply! error!)
    285   (dump-message-fid 'Tclunk '() fid-value)
    286   (let ((file (file-open-file fid-value))
    287         (user-state (file-open-user-state fid-value)))
    288     ((file-handle-clunk! file) file user-state))
    289   (reply! '()))
    290 
    291 (define (handle-remove fid-value reply! error!)
    292   (dump-message-fid 'Tremove '() fid-value)
    293   (error! "Not yet implemented"))
    294 
    295 (define (handle-stat message fid-value reply! error!)
    296   (dump-message-fid 'Tstat message fid-value)
    297   (reply! (file-stat (file-open-file fid-value))))
    298 
    299 (define (handle-wstat message fid-value reply! error!)
    300   (dump-message-fid 'Twstat message fid-value)
    301   (error! "Not yet implemented"))
    302 
    303 (define (handle-disconnect)
    304   (printf "Disconnected\n"))
     33(insert-simple-file! filesystem
     34                     "test"
     35                     (+ perm/irusr perm/irgrp perm/iroth)
     36                     "0"
     37                     "0"
     38                     "0"
     39                     (current-seconds) (current-seconds)
     40                     (lambda ()
     41                       (string-append (seconds->string) "\n"))
     42                     subdir)
    30543
    30644(parameterize ((tcp-read-timeout #f)
     
    30947   (let accept-loop ()
    31048     (receive (in out) (tcp-accept listener)
    311               (printf "New connection!\n")
    31249              (thread-start! (make-thread
    31350                              (lambda ()
    314                                 (serve in out
    315                                        `((version . ,handle-version)
    316                                          (auth . ,handle-auth)
    317                                          (flush . ,handle-flush)
    318                                          (attach . ,handle-attach)
    319                                          (walk . ,handle-walk)
    320                                          (open . ,handle-open)
    321                                          (create . ,handle-create)
    322                                          (read . ,handle-read)
    323                                          (write . ,handle-write)
    324                                          (clunk . ,handle-clunk)
    325                                          (remove . ,handle-remove)
    326                                          (stat . ,handle-stat)
    327                                          (wstat . ,handle-wstat)
    328                                          (disconnect . ,handle-disconnect)))
     51                                (vfs-serve in out filesystem)
    32952                                (close-input-port in)
    33053                                (close-output-port out)))))
  • release/4/9p/trunk/9p.setup

    r26745 r30676  
    88(compile -s -O2 9p-server.import.scm)
    99
     10(compile -s -O2 9p-server-vfs.scm -j 9p-server-vfs)
     11(compile -s -O2 9p-server-vfs.import.scm)
     12
    1013(install-extension
    1114  '9p
    1215  '("9p-lolevel.so" "9p-lolevel.import.so"
    1316    "9p-client.so" "9p-client.import.so"
    14     "9p-server.so" "9p-server.import.so")
     17    "9p-server.so" "9p-server.import.so"
     18    "9p-server-vfs.so" "9p-server-vfs.import.so")
    1519  `((version 0.8)
    1620    (documentation "9p.html")))
  • release/4/9p/trunk/test/run.scm

    r27514 r30676  
    176176
    177177(test-group "Client and Server"
    178   (...)
     178  ; FIXME:
    179179
    180  
    181 
    182 
     180  ; Write a test suite that runs a client and a server
     181  ; and tests one against the other.
     182  (void)
    183183)
Note: See TracChangeset for help on using the changeset viewer.