Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 354 lines (305 sloc) 13.038 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (** folder.ml *)
19
20 (**
21 Notes:
22 1) Now extensively rewritten to use Base, Filename and Unix.
23 2) Removed old FileSys functor.
24 *)
25 module List = Base.List
26 module String = Base.String
27
28 type folder =
29 { current: string ref;
30 valid: string list ref
31 }
32
33 exception Folder_error of string
34
35 (* Equivalent of try with _ -> for this file
36 * We ban all exceptions named here and log any we don't know about.
37 *)
38 let check_exn ?raise_exn funname defval exn =
39 let action () = match raise_exn with | Some exn -> raise exn | None -> defval in
40 match exn with
41 | Folder_error _ -> action ()
42 | Failure _ -> action ()
43 | Unix.Unix_error _ -> action ()
44 | exn -> (Logger.warning "Folder.%s: Unknown exception %s" funname (Printexc.to_string exn); action ())
45
46 (* Some support functions *)
47
48 (* Split a path into its directory and filename.
49 * We need to actually stat the file to determine if it is really
50 * a file or a directory. This is needed so that we can determine
51 * if a file spec is in a valid directory or not. We need to take
52 * into account whether the file or dir exists or not. This routine
53 * is now used to stat files which we want to create.
54 *)
55 let dir_file path =
56 let (dir,file) =
57 try
58 (match (Unix.stat path).Unix.st_kind with
59 Unix.S_DIR -> (path,"")
60 | Unix.S_REG -> (Filename.dirname path,Filename.basename path)
61 | _ -> raise (Failure "File not regular file or directory"))
62 with Unix.Unix_error (Unix.ENOENT, "stat", _) ->
63 (* It doesn't exist so we don't know if it's a dir or file *)
64 (Filename.dirname path,Filename.basename path)
65 in
66 (PathTransform.string_to_mysys (File.explicit_path "" (Some (PathTransform.string_to_unix dir))),file)
67
68 (* Just get the current folder and extract up to last '/'.
69 May raise Not_found *)
70 let chup file =
71 let len = String.length file in
72 let pos = Str.search_backward (Str.regexp_string File.path_sep) file (len-1) in
73 String.sub file 0 (pos+1)
74
75 (* canonical cwd path:
76 * Return the canonical name of a file relative to "from".
77 * Now just a call to explicit_path in the File module.
78 *)
79 let canonical from file = File.explicit_path file (Some from)
80
81 (* Rename Unix functions *)
82 let openfileread file = Unix.openfile file [Unix.O_RDONLY] 0o640
83 let openfilewrite file = Unix.openfile file [Unix.O_WRONLY;Unix.O_CREAT;Unix.O_TRUNC] 0o640
84 let openfileappend file = Unix.openfile file [Unix.O_WRONLY;Unix.O_APPEND;Unix.O_CREAT] 0o640
85 let filesize fd = (Unix.fstat fd).Unix.st_size
86 let lseek fd int = Unix.lseek fd int Unix.SEEK_SET
87
88 (* Creator methods *)
89
90 let empty dir = { current = ref dir; valid = ref [ dir ] }
91
92 (* Accessor methods *)
93
94 let current_folder f = !(f.current)
95 let get_valid_folders f = !(f.valid)
96
97 (* We store the canonical name to make later searches quicker. *)
98 let add_valid_folder f dir =
99 let cdir = canonical (!(f.current)) dir in
100 if not (List.mem cdir (!(f.valid)))
101 then f.valid := cdir :: (!(f.valid))
102 else raise (Folder_error "not_valid")
103
104 (* validate_folder f dir:
105 * Check if a folder is under one of the valid folders.
106 * Return the canonical name if it is, raise Folder_error "not_valid" if
107 * it's not.
108 *)
109 let validate_folder f dir =
110 let cdir = canonical (!(f.current)) dir in
111 if List.fold_left (fun ok d -> ok || String.is_prefix d cdir) false (!(f.valid))
112 then (*Logger.debug "validate_folder: %s is valid\n" dir;*) cdir
113 else (*Logger.debug "validate_folder: %s is NOT valid\n" dir;*) raise (Folder_error "not_valid")
114
115 (* Access permissons for folder *)
116 let exists_folder f dir perms =
117 try Unix.access (canonical (!(f.current)) dir) perms; true
118 with exn -> check_exn "exists_folder" false exn
119
120 let writable_folder f dir =
121 let res = exists_folder f dir [Unix.W_OK] in
122 Logger.debug "writable_folder: %s %b" dir res;
123 res
124
125 (* Same as above but turn into bool *)
126 let valid_folder f dir =
127 try ignore (validate_folder f dir); true
128 with exn -> check_exn "valid_folder" false exn
129
130 (* We chdir to the validated folder so it must exist.
131 * We also convert any error exceptions into access_denied.
132 *)
133 let chfolder f dir =
134 let cwd = Unix.getcwd () in
135 try
136 let cdir = validate_folder f dir in
137 Unix.chdir cdir;
138 f.current := cdir;
139 Unix.chdir cwd
140 with exn ->
141 (*Logger.debug "chfolder: exn=%s\n" (Printexc.to_string exn);*)
142 Unix.chdir cwd;
143 check_exn ~raise_exn:(Folder_error "access_denied") "chfolder" () exn
144
145 (* Move up one folder. Need to check we're still valid. *)
146 let chfolderup f =
147 try chfolder f (chup (current_folder f))
148 with Not_found -> raise (Folder_error "not_valid")
149
150 (* May leave the current folder invalid !!! *)
151 let remove_valid_folder f dir =
152 f.valid := List.filter (fun d -> d <> dir) (!(f.valid));
153 let cfolder = current_folder f in
154 try ignore (validate_folder f cfolder)
155 with (Folder_error "not_valid") ->
156 if List.length (!(f.valid)) = 0
157 then ()
158 else chfolder f (List.nth (!(f.valid)) 0)
159
160 (* Rename a folder, assume already valid *)
161 let rename_folder f from_name to_name =
162 try
163 let cfn = canonical (!(f.current)) from_name in
164 let ctn = canonical (!(f.current)) to_name in
165 Unix.rename cfn ctn;
166 true
167 with exn ->
168 Logger.debug "rename_folder: exn=%s" (Printexc.to_string exn);
169 false
170
171 (* Delete a folder, assume already valid *)
172 let file_action f name action action_name =
173 try action (canonical (!(f.current)) name); true
174 with exn -> Logger.debug "%s: exn=%s" action_name (Printexc.to_string exn); false
175
176 (* Delete a folder, assume already valid *)
177 let delete_folder f name = file_action f name Unix.unlink "delete_folder"
178
179 (* Create a directory, assume already valid *)
180 let create_directory f name = file_action f name (fun n -> Unix.mkdir n 0o751) "create_directory"
181
182 (* Delete a directory, assume already valid *)
183 let delete_directory f name = file_action f name Unix.rmdir "delete_directory"
184
185 (* Return a string array with a directory listing for the given dir (relative to f.current) *)
186 let list f dir =
187 try
188 let cwd = current_folder f in
189 let _ = chfolder f dir in
190 let dir = (!(f.current)) in
191 let _ = f.current := cwd in
192 Some (Sys.readdir dir)
193 with exn -> check_exn "list" None exn
194
195 (* Support code for the ls-style directory listing *)
196
197 (* File permissions *)
198 let str_of_rwx rwx =
199 (if (rwx land 0x04) <> 0 then "r" else "-")^
200 (if (rwx land 0x02) <> 0 then "w" else "-")^
201 (if (rwx land 0x01) <> 0 then "x" else "-")
202
203 let str_of_perm k p =
204 (match k with
205 | Unix.S_REG -> "-" (* Regular file *)
206 | Unix.S_DIR -> "d" (* Directory *)
207 | Unix.S_CHR -> "c" (* Character device *)
208 | Unix.S_BLK -> "b" (* Block device *)
209 | Unix.S_LNK -> "l" (* Symbolic link *)
210 | Unix.S_FIFO -> "p" (* Named pipe *)
211 | Unix.S_SOCK -> "s")^ (* Socket *)
212 (str_of_rwx ((p asr 6) land 0x07))^
213 (str_of_rwx ((p asr 3) land 0x07))^
214 (str_of_rwx (p land 0x07))
215
216 (* Human-readable file sizes.
217 * Todo: use LargeFile for file sizes!!!
218 * Currently not used because ftp clients didn't understand it.
219 *)
220 (*let human i =
221 let f = float_of_int i in
222 if f < 1024.0 then Printf.sprintf "%d" i
223 else if f < (1024.0 *. 1024.0) then Printf.sprintf "%.1fk" (f /. 1024.0)
224 else if f < (1024.0 *. 1024.0 *. 1024.0) then Printf.sprintf "%.1fM" (f /. (1024.0*.1024.0))
225 else Printf.sprintf "%.1fG" (f /. (1024.0*.1024.0*.1024.0))*)
226
227 let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]
228
229 (* Convert Unix times into date string *)
230 let mtime t =
231 let gmt = Unix.gmtime t in
232 (* This is ls -l format *)
233 (*Printf.sprintf "%d-%02d-%02d %02d:%02d"
234 (1900+gmt.Unix.tm_year) (gmt.Unix.tm_mon+1) gmt.Unix.tm_mday gmt.Unix.tm_hour gmt.Unix.tm_min*)
235 (* This is what ftp clients seem to need *)
236 Printf.sprintf "%s %02d %04d" (months.(gmt.Unix.tm_mon)) gmt.Unix.tm_mday (1900+gmt.Unix.tm_year)
237
238 (* Group and user names *)
239 let uid_name uid = try (Unix.getpwuid uid).Unix.pw_name with Not_found -> Printf.sprintf "%d" uid
240 let gid_name gid = try (Unix.getgrgid gid).Unix.gr_name with Not_found -> Printf.sprintf "%d" gid
241
242 (* For tabulation, compute maximum size per column *)
243 let get_max_slens a b =
244 let alen,blen = Array.length a,Array.length b in
245 let geta i = if i < alen then Array.unsafe_get a i else 0 in
246 let getb i = if i < blen then Array.unsafe_get b i else "" in
247 Array.init (max alen blen) (fun i -> max (geta i) (String.length (getb i)))
248
249 (* Given an array of arrays of strings, pad each column to have the same length.
250 * The pat parameter is an array of "l" or "r" strings indicating whether
251 * left or right padding for each column.
252 * Any other character results in no padding.
253 * The pat characters default to "l" if the pat array is too small.
254 * Note that we must not have spaces after the filename because the client
255 * will think it's part of the filename.
256 *)
257 let tabulate pat aa =
258 let patlen = Array.length pat in
259 let len = Array.fold_left (fun mx a -> max mx (Array.length a)) 0 aa in
260 let maxs = Array.fold_left get_max_slens (Array.make len 0) aa in
261 Array.map (fun a ->
262 let alen = Array.length a in
263 Array.init len (fun i ->
264 let getpat i = if i < patlen then pat.(i) else "l" in
265 let complete_none _ _ s = s in
266 let complete =
267 match getpat i with
268 | "l" -> String.complete_left
269 | "r" -> String.complete_right
270 | _ -> complete_none in
271 complete maxs.(i) ' ' (if i < alen then a.(i) else ""))) aa
272
273 (* Return a file stat, checking validity, None if not valid *)
274 let stat_file folder _file =
275 let cwd = Unix.getcwd () in
276 try
277 Unix.chdir (!(folder.current));
278 let (dir,file) = dir_file _file in
279 let cdir = validate_folder folder dir in
280 Unix.chdir cdir;
281 let s = Unix.stat (if file = "" then cdir else file) in
282 Unix.chdir cwd;
283 Some s
284 with exn ->
285 Unix.chdir cwd;
286 check_exn "stat_file" None exn
287
288 (* Return a formatted ls-style file listing *)
289 let ls_files folder filenames =
290 let ssc ss s = match (ss,s) with (ss,"") -> ss | ("",s) -> s | (ss,s) -> ss^" "^s in
291 Array.map (fun a -> Array.fold_right ssc a "")
292 (tabulate [|"l";"l";"r";"r";"l";"r";"n"|]
293 (Array.map (fun filename ->
294 match stat_file folder filename with
295 Some stat ->
296 [| Printf.sprintf "%s" (str_of_perm stat.Unix.st_kind stat.Unix.st_perm);
297 Printf.sprintf "%d" stat.Unix.st_nlink;
298 Printf.sprintf "%s" (uid_name stat.Unix.st_uid);
299 Printf.sprintf "%s" (gid_name stat.Unix.st_gid);
300 Printf.sprintf "%d" ((*human*) stat.Unix.st_size);
301 Printf.sprintf "%s" (mtime stat.Unix.st_mtime);
302 Printf.sprintf "%s" filename |]
303 | None -> [|"";"";"";"";"";"";""|]) filenames))
304
305 (* Open a file for reading, check it's valid *)
306 let openfile open_file f _file =
307 let cwd = Unix.getcwd () in
308 try
309 Unix.chdir (!(f.current));
310 let (dir,file) = dir_file _file in
311 let cdir = validate_folder f dir in
312 Unix.chdir cdir;
313 let fd = open_file file in
314 Unix.chdir cwd;
315 fd
316 with Unix.Unix_error _ ->
317 Unix.chdir cwd;
318 raise (Folder_error "file_inaccessible")
319
320 (** Open file for read.
321 We need to stat it because Unix.open_file allows you to open a directory.
322 *)
323 let openfileread folder file =
324 match stat_file folder file with
325 Some stat ->
326 (match stat.Unix.st_kind with
327 Unix.S_REG -> Some (openfile openfileread folder file)
328 | _ -> None)
329 | None -> None
330 let openfilewrite folder file = openfile openfilewrite folder file
331 let openfileappend folder file = openfile openfileappend folder file
332
333 (* Read in [amnt] bytes to a string.
334 * If amnt=0 then read in whole file.
335 *)
336 let read fd amnt =
337 let size = match amnt with 0 -> filesize fd | size -> size in
338 let buff = String.create size in
339 let cnt = Unix.read fd buff 0 size in
340 (*Logger.debug "read: size=%d cnt=%d buff=%s" size cnt (String.sub buff 0 cnt);*)
341 if cnt < size
342 then String.sub buff 0 cnt
343 else buff
344
345 (* Write size bytes from buff, starting from index 0 to fd *)
346 let write fd buff size =
347 (*Logger.debug "Folder.write: writing %d bytes '%s'" size buff;*)
348 Unix.write fd buff 0 size
349
350 (* Write-through to file close *)
351 let closefile = Unix.close
352
353 (* End of file folder.ml *)
Something went wrong with that request. Please try again.