Skip to content

Commit 05e07ca

Browse files
CrazedProgrammerCrazedProgrammer
committed
vfs: Major improvements
- Handle read-only mounts properly (for example, fs.delete now always throws an error if the path is in a read-only mount). - Show an error when a mount point directory doesn't exist in the parent mount. - change command line interface for vfs mounts.
1 parent fbc1f9b commit 05e07ca

3 files changed

Lines changed: 124 additions & 102 deletions

File tree

‎config.lisp‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@
1212
dir: host file system directory
1313
Can be relative to the current directory.
1414
Default: rw:/:. r:/rom:/rom"
15-
:default '("rw:/:." "r:/rom:/rom"))
15+
:default '("cw:/:." "c:/rom:/rom"))
1616

1717
(add-argument! spec '("--boot" "-b")
1818
:name "boot-file"

‎vfs/ccfs.lisp‎

Lines changed: 4 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,31 +1,22 @@
11
(import lua/basic (_G))
22
(define fs (.> _G :fs))
33

4-
(defun create (dir read-only)
4+
(defun create (dir)
55
{ :list (lambda (path)
66
((.> fs :list) (format nil "{#dir}/{#path}")))
77
:exists (lambda (path)
88
((.> fs :exists) (format nil "{#dir}/{#path}")))
99
:isDir (lambda (path)
1010
((.> fs :isDir) (format nil "{#dir}/{#path}")))
1111
:isReadOnly (lambda (path)
12-
(or read-only
13-
((.> fs :isReadOnly) (format nil "{#dir}/{#path}"))))
12+
((.> fs :isReadOnly) (format nil "{#dir}/{#path}")))
1413
:getSize (lambda (path)
1514
((.> fs :getSize) (format nil "{#dir}/{#path}")))
1615
:getFreeSpace (lambda (path)
1716
((.> fs :getFreeSpace) (format nil "{#dir}/{#path}")))
1817
:makeDir (lambda (path)
19-
(if read-only
20-
(error! "permission denied.")
21-
((.> fs :makeDir) (format nil "{#dir}/{#path}"))))
18+
((.> fs :makeDir) (format nil "{#dir}/{#path}")))
2219
:delete (lambda (path)
23-
(if read-only
24-
(error! "permission denied.")
25-
((.> fs :delete) (format nil "{#dir}/{#path}"))))
26-
:move (lambda (from to)
27-
((.> fs :move) (format nil "{#dir}/{#from}") (format nil "{#dir}/{#to}")))
28-
:copy (lambda (from to)
29-
((.> fs :copy) (format nil "{#dir}/{#from}") (format nil "{#dir}/{#to}")))
20+
((.> fs :delete) (format nil "{#dir}/{#path}")))
3021
:open (lambda (path mode)
3122
((.> fs :open) (format nil "{#dir}/{#path}") mode)) })

‎vfs/init.lisp‎

Lines changed: 119 additions & 88 deletions
Original file line numberDiff line numberDiff line change
@@ -3,101 +3,16 @@
33
(import vfs/tmpfs tmpfs)
44
(import util (log!))
55

6-
(defun create-vfs (vfs-mounts)
7-
(let* [(mounts {})
8-
(wrap-fun (lambda (function)
9-
(lambda (path &rest)
10-
(with ((mount local-path) (mount-path mounts path))
11-
((.> mount function) local-path (splice rest))))))]
12-
; TODO: if the mount point is not /, check if the mount point is a directory in the existing vfs.
13-
(for-each vfs-mount vfs-mounts
14-
(let* [(mount-args (string/split vfs-mount "%:"))
15-
(attributes (string/split (car mount-args) ""))
16-
(mount-point (canonicalise (cadr mount-args)))
17-
(dir (canonicalise (caddr mount-args)))
18-
(fs-type (cond
19-
[(elem? "r" attributes) 'realfs ]
20-
[(elem? "t" attributes) 'tmpfs ]
21-
[true (error! "file system type not found.")]))
22-
(read-only (not (elem? "w" attributes)))]
23-
(case fs-type
24-
[realfs (.<! mounts mount-point (ccfs/create dir read-only))]
25-
[tmpfs (.<! mounts mount-point (tmpfs/create dir))]
26-
[else (error! "unimplemented.")])))
27-
28-
(with (vfs
29-
{ :list (wrap-fun :list)
30-
:exists (wrap-fun :exists)
31-
:isDir (wrap-fun :isDir)
32-
; TODO: make the VFS prevent writing to read-only mounts.
33-
:isReadOnly (wrap-fun :isReadOnly)
34-
:getName (lambda (path)
35-
(with (name (last (string/split (canonicalise path) "%/")))
36-
(if (= name "") "root" name)))
37-
:getDrive (lambda (path) "hdd")
38-
:getSize (wrap-fun :getSize)
39-
:getFreeSpace (wrap-fun :getFreeSpace)
40-
:makeDir (wrap-fun :makeDir)
41-
:delete (wrap-fun :delete)
42-
:combine (lambda (path child-path)
43-
(canonicalise (.. path "/" child-path)))
44-
:open (wrap-fun :open)
45-
; TODO: proper wildcard support.
46-
:find (lambda (wildcard)
47-
(if ((wrap-fun :exists) wildcard)
48-
(list wildcard)
49-
'()))
50-
:getDir (lambda (path)
51-
(with (parts (string/split (canonicalise path) "%/"))
52-
(cond [(= (car parts) "") ".."]
53-
[(= (n parts) 1) ""]
54-
[else (cadr (reverse parts))])))
55-
:complete (lambda (partial-name path include-files include-slashes)
56-
(if (not ((wrap-fun :isDir)))
57-
{}
58-
(with (names ((wrap-fun :list) path))
59-
(filter
60-
(lambda (x) (= x "nil"))
61-
(map (lambda (name)
62-
(if (= (string/sub name 1 (n partial-name)) partial-name)
63-
name "nil"))))))) })
64-
; Copy and move need to be done manually in order to support copying across mounts.
65-
(.<! vfs :copy
66-
(lambda (raw-from-path raw-to-path)
67-
(let* [(from-path (canonicalise raw-from-path))
68-
(to-path (canonicalise raw-to-path))]
69-
(if (not ((.> vfs :exists) from-path))
70-
(error! "No such file")
71-
(if ((.> vfs :exists) to-path)
72-
(error! "File exists")
73-
(letrec [(copy-path (lambda (from to)
74-
(log! (.. "copying " from " to " to))
75-
(if ((.> vfs :isDir) from)
76-
(progn
77-
((.> vfs :makeDir) to)
78-
(do [(path (struct->list ((.> vfs :list) from)))]
79-
(copy-path (.. from "/" path) (.. to "/" path))))
80-
(let* [(read-handle ((.> vfs :open) from "r"))
81-
(write-handle ((.> vfs :open) to "w"))]
82-
((.> write-handle :write) ((.> read-handle :readAll)))
83-
((.> read-handle :close))
84-
((.> write-handle :close))))))]
85-
(copy-path from-path to-path)))))))
86-
87-
(.<! vfs :move (lambda (from-path to-path)
88-
((.> vfs :copy) from-path to-path)
89-
((.> vfs :delete) from-path)))
90-
vfs)))
91-
926
(defun mount-path (mounts path)
937
(let* [(abs-path (canonicalise path))
948
(mount-name "")]
959
(for-each mount-point (keys mounts)
9610
(when (and (> (n mount-point) (n mount-name))
9711
(= (string/sub abs-path 1 (n mount-point)) mount-point))
9812
(set! mount-name mount-point)))
99-
(splice (list (.> mounts mount-name)
100-
(canonicalise (string/sub abs-path (+ 1 (n mount-name))))))))
13+
(splice (list (.> (.> mounts mount-name) :fs)
14+
(canonicalise (string/sub abs-path (+ 1 (n mount-name))))
15+
(.> (.> mounts mount-name) :readOnly)))))
10116

10217
(defun canonicalise (path)
10318
(let* [(parts (string/split path "%/"))
@@ -115,3 +30,119 @@
11530
(and (/= x "") (/= x ".")))
11631
parts) "/")))
11732

33+
(defun mount-fs (vfs mounts new-vfs-mount)
34+
(let* [(mount-args (string/split new-vfs-mount "%:"))
35+
(attributes-str (car mount-args))
36+
(attributes (string/split attributes-str ""))
37+
(mount-point (canonicalise (cadr mount-args)))
38+
(dir (canonicalise (caddr mount-args)))
39+
(fs-type (cond
40+
[(elem? "c" attributes) 'ccfs ]
41+
[(elem? "t" attributes) 'tmpfs ]
42+
[true (error! (.. "Supported file system type not found in " attributes-str))]))
43+
(read-only (not (elem? "w" attributes)))]
44+
(if (not (all (lambda (a) (elem? a (list "w" "c" "t")))
45+
attributes))
46+
(error! (.. "Unsupported mount option in " attributes-str))
47+
(if (and (/= mount-point "") (not ((.> vfs :isDir) mount-point)))
48+
(error! (.. "Cannot mount /" mount-point ": directory does not exist in the parent filesystem"))
49+
(case fs-type
50+
[ccfs (.<! mounts mount-point
51+
{ :fs (ccfs/create dir)
52+
:readOnly read-only })]
53+
[tmpfs (.<! mounts mount-point
54+
{ :fs (tmpfs/create dir)
55+
:readOnly read-only })]
56+
[else (error! "unimplemented.")])))))
57+
58+
59+
(defun create-vfs (vfs-mounts)
60+
(let* [(mounts {})
61+
(wrap-fun (lambda (function)
62+
(lambda (path &rest)
63+
(with ((mount local-path) (mount-path mounts path))
64+
((.> mount function) local-path (splice rest))))))
65+
(wrapped-funs-names (list :list :exists :isDir :isReadOnly :getSize :getFreeSpace :makeDir :delete :open))
66+
(wrapped-funs (assoc->struct (map (lambda (fun-name)
67+
(list fun-name (wrap-fun fun-name)))
68+
wrapped-funs-names)))
69+
(vfs {})]
70+
(.<! vfs :list (.> wrapped-funs :list))
71+
(.<! vfs :exists (.> wrapped-funs :exists))
72+
(.<! vfs :isDir (.> wrapped-funs :isDir))
73+
; TODO: make the VFS prevent writing to read-only mounts.
74+
(.<! vfs :isReadOnly (lambda (path)
75+
(if (caddr (list (mount-path mounts path)))
76+
true
77+
((.> wrapped-funs :isReadOnly) path))))
78+
(.<! vfs :getName (lambda (path)
79+
(with (name (last (string/split (canonicalise path) "%/")))
80+
(if (= name "") "root" name))))
81+
(.<! vfs :getDrive (lambda (path) "hdd"))
82+
(.<! vfs :getSize (.> wrapped-funs :getSize))
83+
(.<! vfs :getFreeSpace (.> wrapped-funs :getFreeSpace))
84+
(.<! vfs :makeDir (lambda (path)
85+
(if ((.> vfs :isReadOnly) path)
86+
(error! "Permission denied")
87+
((.> wrapped-funs :makeDir) path))))
88+
(.<! vfs :delete (lambda (path)
89+
(if ((.> vfs :delete) path)
90+
(error! "Permission denied")
91+
((.> wrapped-funs :delete) path))))
92+
(.<! vfs :combine (lambda (path child-path)
93+
(canonicalise (.. path "/" child-path))))
94+
(.<! vfs :open (lambda (path mode)
95+
(if (and (elem? mode (list "w" "wb" "a" "ab")) ((.> vfs :isReadOnly) path))
96+
(splice (list nil "Permission denied"))
97+
((.> wrapped-funs :open) path mode))))
98+
; TODO: proper wildcard support.
99+
(.<! vfs :find (lambda (wildcard)
100+
(if ((.> wrapped-funs :exists) wildcard)
101+
(list wildcard)
102+
'())))
103+
(.<! vfs :getDir (lambda (path)
104+
(with (parts (string/split (canonicalise path) "%/"))
105+
(cond [(= (car parts) "") ".."]
106+
[(= (n parts) 1) ""]
107+
[else (cadr (reverse parts))]))))
108+
(.<! vfs :complete (lambda (partial-name path include-files include-slashes)
109+
(if (not ((.> wrapped-funs :isDir)))
110+
{}
111+
(with (names ((.> wrapped-funs :list) path))
112+
(filter
113+
(lambda (x) (= x "nil"))
114+
(map (lambda (name)
115+
(if (= (string/sub name 1 (n partial-name)) partial-name)
116+
name "nil"))))))))
117+
; Copy and move need to be done manually in order to support copying across mounts.
118+
(.<! vfs :copy
119+
(lambda (raw-from-path raw-to-path)
120+
(let* [(from-path (canonicalise raw-from-path))
121+
(to-path (canonicalise raw-to-path))]
122+
(if (not ((.> vfs :exists) from-path))
123+
(error! "No such file")
124+
(if ((.> vfs :exists) to-path)
125+
(error! "File exists")
126+
(letrec [(copy-path (lambda (from to)
127+
(log! (.. "copying " from " to " to))
128+
(if ((.> vfs :isDir) from)
129+
(progn
130+
((.> vfs :makeDir) to)
131+
(do [(path (struct->list ((.> vfs :list) from)))]
132+
(copy-path (.. from "/" path) (.. to "/" path))))
133+
(let* [(read-handle ((.> vfs :open) from "r"))
134+
(write-handle ((.> vfs :open) to "w"))]
135+
((.> write-handle :write) ((.> read-handle :readAll)))
136+
((.> read-handle :close))
137+
((.> write-handle :close))))))]
138+
(copy-path from-path to-path)))))))
139+
140+
(.<! vfs :move (lambda (from-path to-path)
141+
((.> vfs :copy) from-path to-path)
142+
((.> vfs :delete) from-path)))
143+
144+
(for-each vfs-mount vfs-mounts
145+
(mount-fs vfs mounts vfs-mount))
146+
147+
vfs))
148+

0 commit comments

Comments
 (0)