Skip to content
This repository
tag: v2988
Fetching contributors…

Cannot retrieve contributors at this time

file 353 lines (305 sloc) 13.038 kb
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 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353
(*
Copyright © 2011 MLstate

This file is part of Opa.

Opa is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

Opa is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
(** folder.ml *)

(**
Notes:
1) Now extensively rewritten to use Base, Filename and Unix.
2) Removed old FileSys functor.
*)
module List = Base.List
module String = Base.String

type folder =
    { current: string ref;
      valid: string list ref
    }

exception Folder_error of string

(* Equivalent of try with _ -> for this file
* We ban all exceptions named here and log any we don't know about.
*)
let check_exn ?raise_exn funname defval exn =
  let action () = match raise_exn with | Some exn -> raise exn | None -> defval in
  match exn with
  | Folder_error _ -> action ()
  | Failure _ -> action ()
  | Unix.Unix_error _ -> action ()
  | exn -> (Logger.warning "Folder.%s: Unknown exception %s" funname (Printexc.to_string exn); action ())

(* Some support functions *)

(* Split a path into its directory and filename.
* We need to actually stat the file to determine if it is really
* a file or a directory. This is needed so that we can determine
* if a file spec is in a valid directory or not. We need to take
* into account whether the file or dir exists or not. This routine
* is now used to stat files which we want to create.
*)
let dir_file path =
  let (dir,file) =
    try
      (match (Unix.stat path).Unix.st_kind with
Unix.S_DIR -> (path,"")
       | Unix.S_REG -> (Filename.dirname path,Filename.basename path)
       | _ -> raise (Failure "File not regular file or directory"))
    with Unix.Unix_error (Unix.ENOENT, "stat", _) ->
      (* It doesn't exist so we don't know if it's a dir or file *)
      (Filename.dirname path,Filename.basename path)
  in
  (PathTransform.string_to_mysys (File.explicit_path "" (Some (PathTransform.string_to_unix dir))),file)

(* Just get the current folder and extract up to last '/'.
May raise Not_found *)
let chup file =
  let len = String.length file in
  let pos = Str.search_backward (Str.regexp_string File.path_sep) file (len-1) in
  String.sub file 0 (pos+1)

(* canonical cwd path:
* Return the canonical name of a file relative to "from".
* Now just a call to explicit_path in the File module.
*)
let canonical from file = File.explicit_path file (Some from)

(* Rename Unix functions *)
let openfileread file = Unix.openfile file [Unix.O_RDONLY] 0o640
let openfilewrite file = Unix.openfile file [Unix.O_WRONLY;Unix.O_CREAT;Unix.O_TRUNC] 0o640
let openfileappend file = Unix.openfile file [Unix.O_WRONLY;Unix.O_APPEND;Unix.O_CREAT] 0o640
let filesize fd = (Unix.fstat fd).Unix.st_size
let lseek fd int = Unix.lseek fd int Unix.SEEK_SET

(* Creator methods *)

let empty dir = { current = ref dir; valid = ref [ dir ] }

(* Accessor methods *)

let current_folder f = !(f.current)
let get_valid_folders f = !(f.valid)

(* We store the canonical name to make later searches quicker. *)
let add_valid_folder f dir =
  let cdir = canonical (!(f.current)) dir in
  if not (List.mem cdir (!(f.valid)))
  then f.valid := cdir :: (!(f.valid))
  else raise (Folder_error "not_valid")

(* validate_folder f dir:
* Check if a folder is under one of the valid folders.
* Return the canonical name if it is, raise Folder_error "not_valid" if
* it's not.
*)
let validate_folder f dir =
  let cdir = canonical (!(f.current)) dir in
  if List.fold_left (fun ok d -> ok || String.is_prefix d cdir) false (!(f.valid))
  then (*Logger.debug "validate_folder: %s is valid\n" dir;*) cdir
  else (*Logger.debug "validate_folder: %s is NOT valid\n" dir;*) raise (Folder_error "not_valid")

(* Access permissons for folder *)
let exists_folder f dir perms =
  try Unix.access (canonical (!(f.current)) dir) perms; true
  with exn -> check_exn "exists_folder" false exn

let writable_folder f dir =
  let res = exists_folder f dir [Unix.W_OK] in
  Logger.debug "writable_folder: %s %b" dir res;
  res

(* Same as above but turn into bool *)
let valid_folder f dir =
  try ignore (validate_folder f dir); true
  with exn -> check_exn "valid_folder" false exn

(* We chdir to the validated folder so it must exist.
* We also convert any error exceptions into access_denied.
*)
let chfolder f dir =
  let cwd = Unix.getcwd () in
  try
    let cdir = validate_folder f dir in
    Unix.chdir cdir;
    f.current := cdir;
    Unix.chdir cwd
  with exn ->
    (*Logger.debug "chfolder: exn=%s\n" (Printexc.to_string exn);*)
    Unix.chdir cwd;
    check_exn ~raise_exn:(Folder_error "access_denied") "chfolder" () exn

(* Move up one folder. Need to check we're still valid. *)
let chfolderup f =
  try chfolder f (chup (current_folder f))
  with Not_found -> raise (Folder_error "not_valid")

(* May leave the current folder invalid !!! *)
let remove_valid_folder f dir =
  f.valid := List.filter (fun d -> d <> dir) (!(f.valid));
  let cfolder = current_folder f in
  try ignore (validate_folder f cfolder)
  with (Folder_error "not_valid") ->
    if List.length (!(f.valid)) = 0
    then ()
    else chfolder f (List.nth (!(f.valid)) 0)

(* Rename a folder, assume already valid *)
let rename_folder f from_name to_name =
  try
    let cfn = canonical (!(f.current)) from_name in
    let ctn = canonical (!(f.current)) to_name in
    Unix.rename cfn ctn;
    true
  with exn ->
    Logger.debug "rename_folder: exn=%s" (Printexc.to_string exn);
    false

(* Delete a folder, assume already valid *)
let file_action f name action action_name =
  try action (canonical (!(f.current)) name); true
  with exn -> Logger.debug "%s: exn=%s" action_name (Printexc.to_string exn); false

(* Delete a folder, assume already valid *)
let delete_folder f name = file_action f name Unix.unlink "delete_folder"

(* Create a directory, assume already valid *)
let create_directory f name = file_action f name (fun n -> Unix.mkdir n 0o751) "create_directory"

(* Delete a directory, assume already valid *)
let delete_directory f name = file_action f name Unix.rmdir "delete_directory"

(* Return a string array with a directory listing for the given dir (relative to f.current) *)
let list f dir =
  try
    let cwd = current_folder f in
    let _ = chfolder f dir in
    let dir = (!(f.current)) in
    let _ = f.current := cwd in
    Some (Sys.readdir dir)
  with exn -> check_exn "list" None exn

(* Support code for the ls-style directory listing *)

(* File permissions *)
let str_of_rwx rwx =
  (if (rwx land 0x04) <> 0 then "r" else "-")^
  (if (rwx land 0x02) <> 0 then "w" else "-")^
  (if (rwx land 0x01) <> 0 then "x" else "-")

let str_of_perm k p =
  (match k with
     | Unix.S_REG -> "-" (* Regular file *)
     | Unix.S_DIR -> "d" (* Directory *)
     | Unix.S_CHR -> "c" (* Character device *)
     | Unix.S_BLK -> "b" (* Block device *)
     | Unix.S_LNK -> "l" (* Symbolic link *)
     | Unix.S_FIFO -> "p" (* Named pipe *)
     | Unix.S_SOCK -> "s")^ (* Socket *)
   (str_of_rwx ((p asr 6) land 0x07))^
   (str_of_rwx ((p asr 3) land 0x07))^
   (str_of_rwx (p land 0x07))

(* Human-readable file sizes.
* Todo: use LargeFile for file sizes!!!
* Currently not used because ftp clients didn't understand it.
*)
(*let human i =
let f = float_of_int i in
if f < 1024.0 then Printf.sprintf "%d" i
else if f < (1024.0 *. 1024.0) then Printf.sprintf "%.1fk" (f /. 1024.0)
else if f < (1024.0 *. 1024.0 *. 1024.0) then Printf.sprintf "%.1fM" (f /. (1024.0*.1024.0))
else Printf.sprintf "%.1fG" (f /. (1024.0*.1024.0*.1024.0))*)

let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]

(* Convert Unix times into date string *)
let mtime t =
  let gmt = Unix.gmtime t in
    (* This is ls -l format *)
    (*Printf.sprintf "%d-%02d-%02d %02d:%02d"
(1900+gmt.Unix.tm_year) (gmt.Unix.tm_mon+1) gmt.Unix.tm_mday gmt.Unix.tm_hour gmt.Unix.tm_min*)
    (* This is what ftp clients seem to need *)
    Printf.sprintf "%s %02d %04d" (months.(gmt.Unix.tm_mon)) gmt.Unix.tm_mday (1900+gmt.Unix.tm_year)

(* Group and user names *)
let uid_name uid = try (Unix.getpwuid uid).Unix.pw_name with Not_found -> Printf.sprintf "%d" uid
let gid_name gid = try (Unix.getgrgid gid).Unix.gr_name with Not_found -> Printf.sprintf "%d" gid

(* For tabulation, compute maximum size per column *)
let get_max_slens a b =
  let alen,blen = Array.length a,Array.length b in
  let geta i = if i < alen then Array.unsafe_get a i else 0 in
  let getb i = if i < blen then Array.unsafe_get b i else "" in
    Array.init (max alen blen) (fun i -> max (geta i) (String.length (getb i)))

(* Given an array of arrays of strings, pad each column to have the same length.
* The pat parameter is an array of "l" or "r" strings indicating whether
* left or right padding for each column.
* Any other character results in no padding.
* The pat characters default to "l" if the pat array is too small.
* Note that we must not have spaces after the filename because the client
* will think it's part of the filename.
*)
let tabulate pat aa =
  let patlen = Array.length pat in
  let len = Array.fold_left (fun mx a -> max mx (Array.length a)) 0 aa in
  let maxs = Array.fold_left get_max_slens (Array.make len 0) aa in
    Array.map (fun a ->
let alen = Array.length a in
Array.init len (fun i ->
let getpat i = if i < patlen then pat.(i) else "l" in
                                     let complete_none _ _ s = s in
let complete =
                                       match getpat i with
                                       | "l" -> String.complete_left
                                       | "r" -> String.complete_right
                                       | _ -> complete_none in
complete maxs.(i) ' ' (if i < alen then a.(i) else ""))) aa

(* Return a file stat, checking validity, None if not valid *)
let stat_file folder _file =
  let cwd = Unix.getcwd () in
  try
    Unix.chdir (!(folder.current));
    let (dir,file) = dir_file _file in
    let cdir = validate_folder folder dir in
    Unix.chdir cdir;
    let s = Unix.stat (if file = "" then cdir else file) in
    Unix.chdir cwd;
    Some s
  with exn ->
    Unix.chdir cwd;
    check_exn "stat_file" None exn

(* Return a formatted ls-style file listing *)
let ls_files folder filenames =
  let ssc ss s = match (ss,s) with (ss,"") -> ss | ("",s) -> s | (ss,s) -> ss^" "^s in
  Array.map (fun a -> Array.fold_right ssc a "")
    (tabulate [|"l";"l";"r";"r";"l";"r";"n"|]
       (Array.map (fun filename ->
match stat_file folder filename with
Some stat ->
[| Printf.sprintf "%s" (str_of_perm stat.Unix.st_kind stat.Unix.st_perm);
Printf.sprintf "%d" stat.Unix.st_nlink;
Printf.sprintf "%s" (uid_name stat.Unix.st_uid);
Printf.sprintf "%s" (gid_name stat.Unix.st_gid);
Printf.sprintf "%d" ((*human*) stat.Unix.st_size);
Printf.sprintf "%s" (mtime stat.Unix.st_mtime);
Printf.sprintf "%s" filename |]
| None -> [|"";"";"";"";"";"";""|]) filenames))

(* Open a file for reading, check it's valid *)
let openfile open_file f _file =
  let cwd = Unix.getcwd () in
  try
    Unix.chdir (!(f.current));
    let (dir,file) = dir_file _file in
    let cdir = validate_folder f dir in
    Unix.chdir cdir;
    let fd = open_file file in
    Unix.chdir cwd;
    fd
  with Unix.Unix_error _ ->
    Unix.chdir cwd;
    raise (Folder_error "file_inaccessible")

(** Open file for read.
We need to stat it because Unix.open_file allows you to open a directory.
*)
let openfileread folder file =
  match stat_file folder file with
    Some stat ->
      (match stat.Unix.st_kind with
         Unix.S_REG -> Some (openfile openfileread folder file)
       | _ -> None)
  | None -> None
let openfilewrite folder file = openfile openfilewrite folder file
let openfileappend folder file = openfile openfileappend folder file

(* Read in [amnt] bytes to a string.
* If amnt=0 then read in whole file.
*)
let read fd amnt =
  let size = match amnt with 0 -> filesize fd | size -> size in
  let buff = String.create size in
  let cnt = Unix.read fd buff 0 size in
  (*Logger.debug "read: size=%d cnt=%d buff=%s" size cnt (String.sub buff 0 cnt);*)
  if cnt < size
  then String.sub buff 0 cnt
  else buff

(* Write size bytes from buff, starting from index 0 to fd *)
let write fd buff size =
  (*Logger.debug "Folder.write: writing %d bytes '%s'" size buff;*)
  Unix.write fd buff 0 size

(* Write-through to file close *)
let closefile = Unix.close

(* End of file folder.ml *)
Something went wrong with that request. Please try again.