blob: 498846a5f191fed2bd740c73547a66b91a04da72 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
(defpackage :mux-translator
(:use :cl :hurd-common :mach
:hurd :hurd-translator
:hurd-tree-translator
:split-sequence))
(in-package :mux-translator)
(defconstant +file-list+ (first ext:*args*))
(defconstant +class-command+ (second ext:*args*))
(defclass mux-translator (tree-translator)
((timestamp :initform nil
:initarg :timestamp
:accessor timestamp)))
(defclass mux-entry (entry)
((port :initarg :port
:initform nil
:accessor port)))
(define-callback read-file mux-translator
(node user start amount stream)
(when (has-access-p node user :read)
(let ((data (io-read (port node)
:amount amount
:offset start)))
(when data
(write-sequence data stream))
t)))
(define-callback write-file mux-translator
(node user offset stream amount)
(unless (has-access-p node user :write)
(return-from write-file nil))
(when (is-dir-p (stat node))
(return-from write-file :is-a-directory))
(let ((arr (make-array amount :element-type '(unsigned-byte 8))))
(read-sequence arr stream)
(let ((ret (io-write (port node)
arr
:offset offset)))
(cond
((numberp ret)
(setf (stat node) (io-stat (port node)))
t)
(t ret)))))
(define-callback file-change-size mux-translator
(node user new-size)
(when (is-dir-p (stat node))
(return-from file-change-size :is-a-directory))
(unless (has-access-p node user :write)
(return-from file-change-size :operation-denied))
(let ((err (file-set-size (port node) new-size)))
(when (eq err t)
(setf (stat node) (io-stat (port node))))
err))
(define-callback create-directory mux-translator
(node user name mode)
(declare (ignore node user name mode))
nil)
(define-callback remove-directory-entry mux-translator
(node user name)
(declare (ignore node user name))
nil)
(define-callback create-hard-link mux-translator
(dir user file name)
(declare (ignore dir user file name))
nil)
(define-callback file-rename mux-translator
(user old-dir old-name new-dir new-name)
(declare (ignore user old-dir old-name new-dir new-name))
nil)
(define-callback allow-link-p mux-translator
(node user)
(declare (ignore node user))
nil)
(define-callback create-symlink mux-translator
(node user target)
(declare (ignore node user target))
nil)
(define-callback refresh-node mux-translator
(node user)
(declare (ignore node user))
(let ((new-timestamp (get-timestamp)))
(when (time-value-newer-p new-timestamp (timestamp translator))
(let ((root (root *translator*)))
(clear-dir root)
(mirror-file-list root)
(setf (timestamp *translator*) new-timestamp)
t))))
(defun read-file-lines (file)
"Return a list of lines in file 'file'."
(with-open-file (stream file)
(loop for line = (read-line stream nil)
while line
collect line)))
(defun classify-node (file)
(let ((cmd (concatenate-string +class-command+ " " file)))
(with-stream (stream
(ext:make-pipe-input-stream cmd))
(split-sequence #\/ (read-line stream nil)))))
(defun file-basename (file)
(first (last
(split-sequence #\/ file))))
(defun mirror-file (node dir-list full-name name port)
(let ((last-p (null dir-list)))
(cond
(last-p
(let ((file-stat (io-stat port)))
(let ((entry (make-instance 'mux-entry
:stat file-stat
:parent node
:port port)))
(tg:finalize entry (lambda () (port-deallocate port)))
(add-entry node entry name))))
(t
(let ((dir-name (first dir-list))
(rest-dir-name (rest dir-list)))
(let ((found (get-entry node dir-name)))
(cond
((and found
(not (is-dir-p (stat found))))
(warn "~s could not be classified" full-name)
(port-deallocate port)
(return-from mirror-file nil))
((not found)
(setf found (make-instance 'dir-entry
:parent node
:stat (make-stat (stat node))))
(add-entry node found dir-name)))
(mirror-file found rest-dir-name full-name name port)))))))
(defun mirror-file-list (node)
(loop for file in (read-file-lines +file-list+)
do (let ((port (file-name-lookup file
:flags '(:read :write :exec))))
(when (port-valid-p port)
(mirror-file node
(classify-node file)
file
(file-basename file)
port)))))
(define-callback fill-root-node mux-translator
((node dir-entry))
(mirror-file-list node))
(defun get-timestamp ()
(with-port-deallocate (port (file-name-lookup +file-list+ :flags '(:read :notrans)))
(stat-get (io-stat port) 'st-mtime)))
(defun main ()
(let ((translator (make-instance 'mux-translator
:name "mux-translator"
:timestamp (get-timestamp))))
(run-translator translator)))
(main)
|
