(* Liber(ator) - A Command Line Freenet Client *) (* by Travis Bemann and Eric Norige *) (* *) (* This program is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU General Public License as *) (* published by the Free Software Foundation; either version 2 of *) (* the License, or (at your option) any later version. *) (* *) (* This program 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 General Public License for more details. *) open Printf open Fstream open Hlfreenet open Asfreenet open Str open Config open Log open Fieldset exception Bad_action exception Bad_args of string exception Bad_conf of string * string (* item, type *) exception Missing_file of string (* file *) exception Die_msg of string (* Version reported by --version *) let version = "2.0.2" (* Regexp for splitting /etc/passwd entries *) let passwd_delimit = regexp ";" (* Return a user/home directory pair for a /etc/passwd entry *) let parse_user_home entry = match split_delim passwd_delimit entry with user :: _ :: _ :: _ :: _ :: home :: _ -> Some (Strutil.strip user, Strutil.strip home) | _ -> None (* Extract user/home directory pairs from channel *) let parse_user_homes chan = let rec list_user_homes user_homes = try match parse_user_home (input_line chan) with Some user_home -> list_user_homes (user_home :: user_homes) | None -> list_user_homes user_homes with End_of_file -> user_homes in list_user_homes [] (* Construct and return a hash table from a list pairs of some *) (* sort. *) let hash_of_pairs pairs = let hash = Hashtbl.create (List.length pairs) in List.iter (fun (key, data) -> Hashtbl.add hash key data) pairs; hash (* Construct and return a list of pairs from a hash table of some *) (* sort. *) let pairs_of_hash hash = let pairs = ref [] in Hashtbl.iter (fun key data -> pairs := (key, data) :: !pairs) hash; !pairs (* Load /etc/passwd into user/home directory hash file *) let load_passwd file = try let chan = open_in file in let user_homes = parse_user_homes chan in close_in chan; hash_of_pairs user_homes with Sys_error _ -> Hashtbl.create 0 (* User/home directory hash table *) let user_homes = load_passwd "/etc/passwd" (* Lookup a user's home directory *) let home_of_user user = Hashtbl.find user_homes user (* Strip a final / from a path if there is one. *) let strip_path path = let len = String.length path in if len > 1 then if String.get path (len - 1) = '/' then String.sub path 0 (len - 1) else path else path (* Expand a path containing references to home directories. *) let expand_path path = if String.length path > 1 then match String.get path 0 with '~' -> let index = String.index path '/' in let user = String.sub path 1 (index - 1) and home_path = String.sub path (index + 1) ((String.length path) - (index + 1)) in if user = "" then Filename.concat (strip_path (Unix.getenv "HOME")) home_path else begin try Filename.concat (home_of_user user) home_path with Not_found -> strip_path (Unix.getenv "HOME") end | _ -> path else path (* Get the contents of a directory. *) let scan_dir path = let dir = Unix.opendir path in let rec step acc = try let item = Unix.readdir dir in if item = "" then raise (Die_msg "Blank directory entry bug!") else (); step (item :: acc) with End_of_file -> List.rev acc in let items = step [] in Unix.closedir dir; items (* Expand a list of paths to include all files in directories *) (* referred to. *) let expand_paths paths log = let rec step unchecked checked = match unchecked with path :: rest -> let path = strip_path path in begin try match (Unix.stat path).Unix.st_kind with Unix.S_REG -> step rest (path :: checked) | Unix.S_DIR -> let items = List.filter (fun item -> (item <> ".") && (item <> "..")) (scan_dir path) in let paths = List.rev_map (fun item -> sprintf "%s/%s" path item) items in step (paths @ rest) checked | _ -> step rest checked with Unix.Unix_error (_, _, _) -> raise (Missing_file path) end | [] -> checked in step paths [] (* Log an unexpected exception as an error. *) let log_except log except = log#log Msg_error ("unexpected exception: " ^ (Printexc.to_string except)) (* Check for a generic FCP exception and return true if the *) (* exception is not a generic FCP exception, otherwise log an *) (* error. *) let log_fcp_errors log except = match except with Fcp.Connect_error -> log#log Msg_error "unable to connect to node"; false | Fcp.Io_error -> log#log Msg_error "IO error communicating with node"; false | Fcp.Node_format_error msg -> log#log Msg_error ("bad node FCP message: " ^ msg); false | Fcp.Format_error msg -> log#log Msg_error ("bad client FCP message: " ^ msg); false | Fcp.Node_error msg -> log#log Msg_error ("internal node error: " ^ msg); false | Fcp.Unexpected_message msg -> log#log Msg_error ("unexpected node FCP message: " ^ msg); false | _ -> true (* Messages to taunt the luser with *) let taunt_luser_msgs = ["I think you ought to stick with fproxy for the time being."; "Please read the fucking help. Thank you for your patience."; "Please slowly step away from the command line."^ " Repeat, please slowly step away from the command line."; "Please log in as root and execute the command rm -rf /*"^ " (if you actually do this, you just aren't cut out for"^ " using command line tools)"; "The only way to fix this problem is by repeatedly and"^ " rapidly turning off and on your computer."] (* The luser's an idiot or a smart aleck. *) let taunt_luser () = raise (Die_msg (List.nth taunt_luser_msgs (Random.int (List.length taunt_luser_msgs)))) type action_mark = Action_mark_none | Action_mark_request | Action_mark_request_control | Action_mark_request_map | Action_mark_insert_single | Action_mark_insert_single_ssk | Action_mark_insert_single_chk | Action_mark_insert_map_chks | Action_mark_insert_map_named_chks | Action_mark_insert_map_ssk_chks | Action_mark_insert_map_ssk_named_chks | Action_mark_insert_date_redirect | Action_mark_insert_date_redirect_ssk | Action_mark_generate_chk | Action_mark_generate_svk type action = Action_none | Action_request of string * string option (* URI, file *) | Action_request_control of string * string option (* URI, file *) | Action_request_map of string * string option (* URI, file *) | Action_insert_single of string * string (* file, URI *) | Action_insert_single_ssk of string * string option (* file, name *) | Action_insert_single_chk of string (* file *) | Action_insert_map_chks of string * string list (* map URI, files *) | Action_insert_map_named_chks of string * (string * string) list (* map URIy, (file, name) list *) | Action_insert_map_ssk_chks of string * string list (* map name, files *) | Action_insert_map_ssk_named_chks of string * (string * string) list (* map name, (file, name) list *) | Action_insert_date_redirect of string * int option * int option * string option (* URI, interval, offset, target URI *) | Action_insert_date_redirect_ssk of string * int option * int option * string option (* name, interval, offset, target name *) | Action_generate_chk of string (* file *) | Action_generate_svk (* Break an even-length list into a list of pairs of adjacent *) (* items. *) let pair_list_of_list list = let rec step list pairs_rev = match list with first :: second :: rest -> step rest ((first, second) :: pairs_rev) | _ :: [] -> raise (Invalid_argument "pair_list_of_list") | [] -> List.rev pairs_rev in step list [] (* Remove a freenet: protocol specifier from a Freenet URI. *) let strip_uri uri = if String.length uri < 9 then uri else if string_before uri 8 = "freenet:" then string_after uri 8 else uri (* Generate a filename from a URI. *) let file_of_uri uri = let uri = strip_uri uri in if String.length uri < 4 then uri else match string_before uri 4 with "KSK@" -> string_after uri 4 | "SSK@" | "CHK@" -> let pieces = split (regexp "/") uri in begin try List.find (fun part -> (Strutil.strip part) <> "") (List.rev pieces) with Not_found -> uri end | _ -> uri (* Type encapsulating outputs *) type output = Output_none | Output_channel of out_channel | Output_channel_noclose of out_channel (* Get a file output with the specified prefix and suffix *) let open_file_output file prefix suffix = let file = prefix ^ file ^ suffix in try Output_channel (open_out_bin (expand_path file)) with Sys_error _ -> raise (Die_msg (sprintf "%s: unable to open for writing" file)) (* Get an output dependent on the specified URI, the specified *) (* filename if there is one, and a number of provided items that *) (* should be from the configuration. *) let open_output uri file do_output prefix suffix use_stdout = if do_output then match file with Some file -> open_file_output file prefix suffix | None -> if use_stdout then Output_channel_noclose stdout else open_file_output (file_of_uri uri) prefix suffix else Output_none (* Get a data output dependent on the specified URI, the specified *) (* filename if there is one, and the configuration. *) let open_data_output uri file conf log = let do_output = conf#field_bool "save_data" and prefix = conf#field_string "save_data_prefix" and suffix = conf#field_string "save_data_suffix" and use_stdout = conf#field_bool "output_request_data" in open_output uri file do_output prefix suffix use_stdout (* Get a metadata output dependent on the specified URI, the *) (* specified filename if there is one, and the configuration. *) let open_metadata_output uri file conf log = let do_output = conf#field_bool "save_metadata" and prefix = conf#field_string "save_metadata_prefix" and suffix = conf#field_string "save_metadata_suffix" and use_stdout = conf#field_bool "output_request_metadata" and data_use_stdout = conf#field_bool "output_request_data" in if not data_use_stdout then open_output uri file do_output prefix suffix use_stdout else begin if use_stdout then log#log Msg_error ("both 'output_request_data' and 'output_request_metadata'"^ " are specified as true; treating"^ " 'outupt_request_metadata' as false") else (); match file with Some _ -> open_output uri file do_output prefix suffix false | None -> if use_stdout then log#log Msg_error ("as no file has been explicitly specified for metadata"^ " saving and 'output_request_metadata' has been"^ " disabled automatically, no metadata will be outputted"^ " or saved") else (); Output_none end (* Get an fstream for an output. *) let fstream_of_output = function Output_channel channel | Output_channel_noclose channel -> (new fstream_out_channel channel :> fstream_out) | Output_none -> (new fstream_out_null :> fstream_out) (* Close an output. *) let close_output = function Output_channel channel -> close_out channel | Output_none | Output_channel_noclose _ -> () (* Get the hops to live to use from the configuration. *) let get_htl conf = conf#field_int "transact_htl" (* Handle exceptions generated during requests. *) let request_except except log uri = if log_fcp_errors log except then match except with Fcp.Data_not_found -> log#log Msg_error (uri ^ ": data not found") | Fcp.Route_not_found _ -> log#log Msg_error (uri ^ ": route not found") | Fcp.Uri_error _ -> log#log Msg_error (uri ^ ": invalid URI") | Bad_control _ -> log#log Msg_error (uri ^ ": bad control structure") | Bad_map_control -> log#log Msg_error (uri ^ ": bad map control structure") | Part_not_found part -> log#log Msg_error (uri ^ ": map part '" ^ part ^ "' not found") | _ -> log_except log except else () (* Handle a request for the data and metadata of a single file. *) let request (node : node_async) uri file conf log = let data_output = open_data_output uri file conf log and metadata_output = open_metadata_output uri file conf log in log#log (Msg_info 1) (uri ^ ": initiating request"); node#request begin function Result info -> let stream = fstream_of_output metadata_output in stream#output_string (fields_print info); close_output data_output; close_output metadata_output; log#log (Msg_info 1) (uri ^ ": successful request") | Error except -> close_output data_output; close_output metadata_output; request_except except log uri; log#log (Msg_info 1) (uri ^ ": failed request") end uri (get_htl conf) (fstream_of_output data_output) (* Generate a string for a control structure. *) let string_of_control control = match control with Redirect uri -> "redirect: " ^ uri ^ "\n" | Date_redirect { dbr_target = target; dbr_offset = offset; dbr_increment = increment } -> sprintf "target URI: %s\nepoch offset (seconds):%i\nindex increment (seconds):%i\n" target offset increment | Split_file { spl_length = length; spl_blocks = blocks; spl_blocks_check = blocks_check } -> String.concat "" (((sprintf "length: %i\nblocks:\n" length) :: (List.map (fun line -> line ^ "\n") blocks)) @ ("check blocks:\n" :: (List.map (fun line -> line ^ "\n") blocks_check))) | No_control -> "no control information" (* Handle a request for the control structure and metadata of a *) (* single file. *) let request_control (node : node_async) uri file conf log = log#log (Msg_info 1) (uri ^ ": initiating control request"); node#request_control_info begin function Result ((control, info) : control_info) -> log#log (Msg_info 1) (uri ^ ": successful control request"); log#log (Msg_info 0) (string_of_control control) | Error except -> request_except except log uri; log#log (Msg_info 1) (uri ^ ": failed control request") end uri (get_htl conf) (* Generate a string for a map structure. *) let string_of_map map = String.concat "" (List.map begin fun (part, (control, info)) -> (sprintf "PART '%s':\n" part) ^ (string_of_control control) end (pairs_of_hash map.map_items)) (* Handle a request for the map structure of a single file. *) let request_map (node : node_async) uri file conf log = log#log (Msg_info 1) (uri ^ ": initiating map request"); node#request_map begin function Result map -> log#log (Msg_info 1) (uri ^ ": successful map request"); log#log (Msg_info 0) (string_of_map map) | Error except -> request_except except log uri; log#log (Msg_info 1) (uri ^ ": failed map request") end uri (get_htl conf) (* Add a field to metadata if it does not already exist. *) let add_nonexist_field metadata field data = if has_field metadata field then metadata else field_make metadata field (Field_string data) (* Get basic metadata; either that specified in a file or empty *) (* metadata. *) let basic_metadata conf (log : Log.log_type) = match conf#field_string_opt "metadata_file" with Some file -> begin try let channel = open_in file in let len = in_channel_length channel in let buf = String.create len in really_input channel buf 0 len; close_in channel; fields_parse buf with Sys_error _ -> raise (Die_msg ("cannot open or read metadata file " ^ file)) end | None -> [] (* Generate a Dublin Core date from a UNIX time. *) let dublin_core_date time = let date = Unix.gmtime time in sprintf "%04i-%02i-%02iT%02i:%02i:%02iZ" (date.Unix.tm_year + 1900) (date.Unix.tm_mon + 1) date.Unix.tm_mday date.Unix.tm_hour date.Unix.tm_min date.Unix.tm_sec (* Generate a YYYYMMDDHHMMSS date from a UNIX time. *) let yyyymmddhhmmss_date time = let date = Unix.gmtime time in sprintf "%04i%02i%02i%02i%02i%02i" (date.Unix.tm_year + 1900) (date.Unix.tm_mon + 1) date.Unix.tm_mday date.Unix.tm_hour date.Unix.tm_min date.Unix.tm_sec (* Get file-related metadata specification configuration items. *) let file_metadata_conf conf log = let suffix_mime_type = conf#field_bool "metadata_suffix_mime_type" and modify_date = conf#field_bool "metadata_modify_date" and insert_date = conf#field_bool "metadata_insert_date" and non_dublin_core_date = conf#field_bool "metadata_non_dublin_core_dates" and default_mime_type = conf#field_string "metadata_default_mime_type" in if modify_date && insert_date then begin log#log Msg_error ("both 'metadata_modify_date' and 'metadata_insert_date' are"^ " set to true, so both are being ignored"); suffix_mime_type, false, false, non_dublin_core_date, default_mime_type end else suffix_mime_type, modify_date, insert_date, non_dublin_core_date, default_mime_type (* Generate metadata for the specified file. *) let file_metadata file conf log mimetypes = let metadata = basic_metadata conf log in let suffix_mime_type, modify_date, insert_date, non_dublin_core_date, default_mime_type = file_metadata_conf conf log in try let stats = Unix.stat file in let mod_time = stats.Unix.st_mtime in let metadata = if suffix_mime_type then add_nonexist_field metadata "Format" begin try mimetypes#lookup_filename file with Not_found -> default_mime_type end else metadata in if modify_date then add_nonexist_field metadata "Date" begin if not non_dublin_core_date then dublin_core_date mod_time else yyyymmddhhmmss_date mod_time end else if insert_date then add_nonexist_field metadata "Date" begin if not non_dublin_core_date then dublin_core_date (Unix.time ()) else yyyymmddhhmmss_date (Unix.time ()) end else metadata with Unix.Unix_error (_, _, _) -> raise (Missing_file file) (* Modify a URI based on the configuration. *) let mutate_uri uri conf log = let date_redirect = conf#field_bool "date_redirect" and offset = conf#field_int "date_redirect_offset" and increment = conf#field_int "date_redirect_increment" and index = conf#field_int "date_redirect_index" in if date_redirect then generate_dbr_uri_relative uri offset increment index else uri (* Convert a name into a SSK URI based on the configuration. *) let uri_of_name name conf log = let subspace_private_key = conf#field_string "subspace_private_key" in mutate_uri (sprintf "SSK@/%s/%s" subspace_private_key name) conf log (* Generate a map name from a path. *) let name_of_path path = if path = "" then raise (Failure "name_of_path") else if String.get path 0 = '/' then String.sub path 1 ((String.length path) - 1) else path (* Handle exceptions generated during inserts. *) let insert_except except log info = if log_fcp_errors log except then match except with Fcp.Route_not_found _ -> log#log Msg_error (info ^ ": route not found") | Fcp.Key_collision uri -> log#log Msg_error (uri ^ ": key collision") | Fcp.Uri_error _ -> log#log Msg_error (info ^ ": invalid URI") | Default_not_found -> log#log Msg_error (info ^ ": default map part not found") | _ -> log_except log except else () (* Determine whether a file should be inserted as a splitfile. *) let check_splitfile channel conf log = let splitfile_block_size = conf#field_int "splitfile_block_size" in let size = in_channel_length channel in size >= splitfile_block_size (* Insert a single file into Freenet at an arbitrary URI. *) let insert_single (node : node_async) file uri conf (log : Log.log_type) mimetypes = try let uri = mutate_uri uri conf log in let info = file_metadata file conf log mimetypes in let channel = open_in_bin file in let stream = (new fstream_in_channel channel :> fstream_in) in let callback = function Result uri -> close_in channel; log#log (Msg_info 0) (uri ^ ": successful single insertion") | Error except -> close_in channel; insert_except except log uri; log#log (Msg_info 1) (uri ^ ": failed single insertion") and htl = get_htl conf in if not (check_splitfile channel conf log) then begin log#log (Msg_info 1) (uri ^ ": initiating single insertion"); node#insert_info callback uri htl info stream end else begin log#log (Msg_info 1) (uri ^ ": initiating single insertion as splitfile"); node#insert_splitfile callback uri htl info stream end with Missing_file _ | Sys_error _ -> raise (Die_msg (file ^ ": unable to open or read")) (* Insert a single file into Freenet at a name under the configured *) (* subspace private key. *) let insert_single_ssk (node : node_async) file name conf log mimetypes = let name = match name with Some name -> name | None -> name_of_path file in insert_single node file (uri_of_name name conf log) conf log mimetypes (* Insert a single file into Freenet at a CHK to be generated *) (* automatically and uniquely. *) let insert_single_chk (node : node_async) file conf log mimetypes = try let info = file_metadata file conf log mimetypes in let channel = open_in_bin file in let stream = (new fstream_in_channel channel :> fstream_in) in let callback = function Result uri -> close_in channel; log#log (Msg_info 0) (uri ^ ": successful single insertion") | Error except -> close_in channel; insert_except except log file; log#log (Msg_info 1) (file ^ ": failed single insertion") and htl = get_htl conf in if not (check_splitfile channel conf log) then begin log#log (Msg_info 1) (file ^ ": initiating single insertion"); node#insert_chk_info callback htl info stream end else begin log#log (Msg_info 1) (file ^ ": initiating single insertion as splitfile"); node#insert_splitfile_chk callback htl info stream end with Missing_file _ | Sys_error _ -> raise (Die_msg (file ^ ": unable to open or read")) (* Asychronously insert a mapfile into Freenet with a list of *) (* name-CHK pairs at a specified arbitrary URI. Call callback when *) (* done. *) let insert_map callback (node : node_async) map_uri name_control_info conf log = let map_default = conf#field_string_opt "multipart_map_default" in let map_default = match map_default with Some map_default -> if List.exists (fun (name, _) -> name = map_default) name_control_info then Some map_default else begin log#log (Msg_info 1) (map_default ^ ": not using default name"); None end | None -> None in let map = { map_items = hash_of_pairs name_control_info; map_default = map_default } in log#log (Msg_info 1) (map_uri ^ ": initiating map insertion"); node#insert begin function Result uri -> log#log (Msg_info 0) (uri ^ ": successful map insertion"); callback (Some uri) | Error except -> insert_except except log map_uri; log#log (Msg_info 1) (map_uri ^ ": failed map insertion"); callback None end map_uri (get_htl conf) map (new fstream_in_string "" :> fstream_in) (* Insert a list of files (in pairs with some other value) into *) (* arbitrary CHKs or splitfiles, and return the other value with *) (* the resulting control-info pair for each file inserted (in a *) (* list) to a specified callback. *) let insert_list callback (node : node_async) file_tags conf log mimetypes = let num_chks = List.length file_tags and htl = get_htl conf in let mutex = Mutex.create () and map = ref [] and num_done = ref 0 and cancelled = ref false in try List.iter begin fun (file, tag) -> try let info = file_metadata file conf log mimetypes in let channel = open_in_bin file in let stream = (new fstream_in_channel channel :> fstream_in) in let handle_insert control = begin match control with Redirect _ -> log#log (Msg_info 1) (file ^ ": successful insertion as CHK") | Split_file _ -> log#log (Msg_info 1) (file ^ ": successful insertion as splitfile") | _ -> assert false end; close_in channel; Mutex.lock mutex; if not !cancelled then begin map := (tag, (control, info)) :: !map; if !num_done = num_chks - 1 then begin let map = !map in Mutex.unlock mutex; log#log (Msg_info 1) "all parts successfully inserted"; callback (Some map) end else begin num_done := !num_done + 1; Mutex.unlock mutex end end else Mutex.unlock mutex and handle_error except = Mutex.lock mutex; close_in channel; insert_except except log file; log#log (Msg_info 1) (file ^ ": failed insertion"); if not !cancelled then begin cancelled := true; Mutex.unlock mutex; log#log (Msg_info 2) "insertion of parts cancelled"; callback None end else Mutex.unlock mutex in if not (check_splitfile channel conf log) then begin log#log (Msg_info 1) (file ^ ": initiating insertion as CHK"); node#insert_chk_info begin function Result uri -> handle_insert (Redirect uri) | Error except -> handle_error except end htl info stream end else begin log#log (Msg_info 1) (file ^ ": initiating insertion as splitfile"); node#insert_splitfile_blocks begin function Result blocks -> handle_insert (Split_file blocks) | Error except -> handle_error except end htl stream end with Sys_error _ -> raise (Missing_file file) end file_tags with except -> Mutex.lock mutex; cancelled := true; Mutex.unlock mutex; raise except (* Insert multiple files into Freenet with specified names in a map *) (* at the specified arbitrary URI. *) let insert_map_core node map_uri file_names conf log mimetypes = let map_uri = mutate_uri map_uri conf log in insert_list begin function Some name_control_info -> insert_map begin function Some uri -> log#log (Msg_info 1) "insertion of map with CHK parts succeeded" | None -> log#log (Msg_info 1) "insertion of map with CHK parts failed" end node map_uri name_control_info conf log | None -> log#log (Msg_info 1) "insertion of map with CHK parts failed" end node file_names conf log mimetypes (* Insert multiple files into Freenet with names generated *) (* automatically from the file paths in a map at the specified *) (* arbitrary URI. *) let insert_map_chks node map_uri files conf log mimetypes = try let files = expand_paths files log in let file_names = List.rev_map (fun file -> (file, name_of_path file)) files in insert_map_core node map_uri file_names conf log mimetypes with Missing_file path -> raise (Die_msg (path ^ ": unable to open or read or stat")) (* Expand a list of path/name pairs to include all files in *) (* directories referred to. *) let expand_path_names path_names log = let rec step unchecked checked = match unchecked with (path, name) :: rest -> begin try match (Unix.stat path).Unix.st_kind with Unix.S_REG -> step rest ((path, name) :: checked) | Unix.S_DIR -> let items = List.filter (fun item -> (item <> ".") && (item <> "..")) (scan_dir path) in let path_names = List.rev_map (fun item -> (sprintf "%s/%s" path item, sprintf "%s/%s" name item)) items in step (path_names @ rest) checked | _ -> step rest checked with Unix.Unix_error (_, _, _) -> raise (Missing_file path) end | [] -> checked in step path_names [] (* Insert multiple files into Freenet with arbitrary names in a map *) (* at the specified arbitrary URI. *) let insert_map_named_chks node map_uri file_names conf log mimetypes = try let file_names = expand_path_names file_names log in insert_map_core node map_uri file_names conf log mimetypes with Missing_file path -> raise (Die_msg (path ^ ": unable to open or read or stat")) (* Insert multiple files into Freenet with names generated *) (* automatically from the file paths in a map at the specified name *) (* under the configured subspace private key. *) let insert_map_ssk_chks node map_name files conf log mimetypes = match conf#field_string_opt "subspace_private_key" with Some subspace_private_key -> let map_uri = sprintf "SSK@%s/%s" subspace_private_key map_name in insert_map_chks node map_uri files conf log mimetypes | None -> raise (Die_msg "no subspace private key configured") (* Insert multiple files into Freenet with arbitrary names in a map *) (* at the specified name under the configured subspace private key. *) let insert_map_ssk_named_chks node map_name file_names conf log mimetypes = match conf#field_string_opt "subspace_private_key" with Some subspace_private_key -> let map_uri = sprintf "SSK@%s/%s" subspace_private_key map_name in insert_map_named_chks node map_uri file_names conf log mimetypes | None -> raise (Die_msg "no subspace private key configured") (* Length for a long random string. *) let long_random_string_len = 80 (* Generate a random limited (printing, <127, not slash) *) (* character. *) let random_limit_char () = let n = Random.int 62 in if n < 10 then char_of_int (48 + n) else if n < 36 then char_of_int (55 + n) else char_of_int (61 + n) (* Generate a long random string of limited printing characters. *) let long_random_string () = let buf = Buffer.create long_random_string_len in let rec step count = if count > 0 then begin Buffer.add_char buf (random_limit_char ()); step (count - 1) end else Buffer.contents buf in step long_random_string_len (* Regular expression to get the SSK key of a URI. *) let ssk_key_regexp = regexp "^SSK@\\([^/]+\\)/.*$" (* Get the SSK key of a URI. *) let ssk_key_of_uri uri = let uri = strip_uri uri in if String.length uri > 4 then match string_before uri 4 with "SSK@" -> if string_match ssk_key_regexp uri 0 then try matched_group 1 uri with Not_found -> raise (Die_msg "invalid SSK URI") else raise (Die_msg "invalid SSK URI") | _ -> raise (Invalid_argument "ssk_key_of_uri") else raise (Invalid_argument "ssk_key_of_uri") (* Regular expression to get the name portion of a SSK URI. *) let ssk_name_regexp = regexp "^SSK@[^/]+/\\(.*\\)$" (* Get the SSK name of a URI. *) let ssk_name_of_uri uri = let uri = strip_uri uri in if String.length uri > 4 then match string_before uri 4 with "SSK@" -> if string_match ssk_name_regexp uri 0 then try matched_group 1 uri with Not_found -> raise (Die_msg "invalid SSK URI") else raise (Die_msg "invalid SSK URI") | _ -> raise (Invalid_argument "ssk_name_of_uri") else raise (Invalid_argument "ssk_name_of_uri") (* Generate a public key URI from a private key URI. *) let generate_public_uri (node : node_async) uri conf log = let uri = strip_uri uri in if String.length uri < 4 then uri else match string_before uri 4 with "CHK@" -> raise (Die_msg "CHKs cannot be date redirect targets") | "SSK@" -> let prv_key = ssk_key_of_uri uri in log#log (Msg_info 1) "generating SSK public key from SSK private key"; let rand_uri = "SSK@" ^ prv_key ^ "/" ^ (long_random_string ()) in log#log (Msg_info 2) (rand_uri ^ ": using random generated SSK with private key"); let uri_pub = ref None and error = ref None and mutex = Mutex.create () in node#insert_info ~callback:begin function Result uri -> Mutex.lock mutex; uri_pub := Some uri; Mutex.unlock mutex | Error except -> Mutex.lock mutex; begin match except with Fcp.Key_collision uri -> uri_pub := Some uri | _ -> error := Some except end; Mutex.unlock mutex end ~uri:rand_uri ~htl:0 ~info:[] ~stream:(new fstream_in_string "" :> fstream_in); node#wait_all; begin match !error with None -> begin match !uri_pub with Some uri_pub -> log#log (Msg_info 1) "SSK public key generation is successful"; let pub_key = ssk_key_of_uri uri_pub in "SSK@" ^ pub_key ^ "/" ^ (ssk_name_of_uri uri) | None -> assert false end | Some except -> insert_except except log rand_uri; raise (Die_msg "SSK public key generation has failed") end | _ -> uri (* Insert a date redirect at the given URI with the given interval *) (* in seconds (if one is specified), offset in seconds (if one is *) (* specified, and target URI (if one is specified). *) let insert_date_redirect (node : node_async) uri interval offset target_uri conf log = let interval = match interval with Some interval -> interval | None -> conf#field_int "date_redirect_increment" and offset = match offset with Some offset -> offset | None -> conf#field_int "date_redirect_offset" and target_uri = match target_uri with Some target_uri -> target_uri | None -> generate_public_uri node uri conf log in let stream = new fstream_in_string "" and date_redirect = Date_redirect { dbr_target = target_uri; dbr_offset = offset; dbr_increment = interval } in log#log (Msg_info 1) (uri ^ ": initiating date redirect insertion"); node#insert_no_map begin function Result uri -> log#log (Msg_info 0) (uri ^ ": successful date redirect insertion") | Error except -> insert_except except log uri; log#log (Msg_info 1) (uri ^ ": failed date redirect insertion") end uri (get_htl conf) (date_redirect, []) stream (* Inset a date redirect at the given name with the given interval *) (* in seconds (if one is specified), offset in sconds (if one is *) (* specified, and target name (if one is specified), under the *) (* configured subspace private key. *) let insert_date_redirect_ssk (node : node_async) name interval offset target_name conf log = match conf#field_string_opt "subspace_private_key" with Some subspace_private_key -> let uri = sprintf "SSK@%s/%s" subspace_private_key name in let target_uri = match target_name with Some target_name -> Some (sprintf "SSK@%s/%s" subspace_private_key target_name) | None -> None in insert_date_redirect node uri interval offset target_uri conf log | None -> raise (Die_msg "no subspace private key configured") (* Generate a CHK from a file. *) let generate_chk (node : node_async) file conf log mimetypes = try let channel = open_in_bin file in let info = file_metadata file conf log mimetypes in let stream = (new fstream_in_channel channel :> fstream_in) in log#log (Msg_info 1) "initiating CHK generation"; node#generate_chk_info begin function Result uri -> close_in channel; log#log (Msg_info 0) ("generated CHK uri: " ^ uri) | Error except -> close_in channel; if log_fcp_errors log except then log_except log except else (); log#log Msg_error ("CHK generation failed - either the node or liber is"^ " buggy!") end info stream with Sys_error _ | Missing_file _ -> log#log Msg_error (file ^ ": unable to open or read") (* Generate an SVK. *) let generate_svk (node : node_async) conf log mimetypes = log#log (Msg_info 1) ("initiating SVK generation"); node#generate_svk begin function Result (private_key, public_key) -> log#log (Msg_info 0) ("generated SVK private key: " ^ private_key); log#log (Msg_info 0) ("generated SVK public key: " ^ public_key); | Error except -> if log_fcp_errors log except then log_except log except else (); log#log Msg_error ("SVK generation failed - either the node or liber is"^ " buggy!") end (* Start a single asynchronous action. *) let start_action action conf log (node : node_async) mimetypes = match action with Action_none -> () | Action_request (uri, file) -> request node uri file conf log | Action_request_control (uri, file) -> request_control node uri file conf log | Action_request_map (uri, file) -> request_map node uri file conf log | Action_insert_single (file, uri) -> insert_single node file uri conf log mimetypes | Action_insert_single_ssk (file, name) -> insert_single_ssk node file name conf log mimetypes | Action_insert_single_chk file -> insert_single_chk node file conf log mimetypes | Action_insert_map_chks (map_uri, files) -> insert_map_chks node map_uri files conf log mimetypes | Action_insert_map_named_chks (map_uri, file_names) -> insert_map_named_chks node map_uri file_names conf log mimetypes | Action_insert_map_ssk_chks (map_name, files) -> insert_map_ssk_chks node map_name files conf log mimetypes | Action_insert_map_ssk_named_chks (map_name, file_names) -> insert_map_ssk_named_chks node map_name file_names conf log mimetypes | Action_insert_date_redirect (uri, interval, offset, target_uri) -> insert_date_redirect node uri interval offset target_uri conf log | Action_insert_date_redirect_ssk (name, interval, offset, target_name) -> insert_date_redirect_ssk node name interval offset target_name conf log | Action_generate_chk file -> generate_chk node file conf log mimetypes | Action_generate_svk -> generate_svk node conf log mimetypes (* Parse an action and its arguments. *) let rec parse_action action args = match action with Action_mark_none -> if args <> [] then parse_action Action_mark_request args else Action_none | Action_mark_request -> begin match args with [uri] -> Action_request (uri, None) | [uri; file] -> Action_request (uri, Some file) | _ -> raise Bad_action end | Action_mark_request_control -> begin match args with [uri] -> Action_request_control (uri, None) | [uri; file] -> Action_request_control (uri, Some file) | _ -> raise Bad_action end | Action_mark_request_map -> begin match args with [uri] -> Action_request_map (uri, None) | [uri; file] -> Action_request_map (uri, Some file) | _ -> raise Bad_action end | Action_mark_insert_single -> begin match args with [file; uri] -> Action_insert_single (file, uri) | _ -> raise Bad_action end | Action_mark_insert_single_ssk -> begin match args with [file] -> Action_insert_single_ssk (file, None) | [file; name] -> Action_insert_single_ssk (file, Some name) | _ -> raise Bad_action end | Action_mark_insert_single_chk -> begin match args with [file] -> Action_insert_single_chk file | _ -> raise Bad_action end | Action_mark_insert_map_chks -> begin match args with uri :: files -> Action_insert_map_chks (uri, files) | _ -> raise Bad_action end | Action_mark_insert_map_named_chks -> begin match args with uri :: pairs -> begin try Action_insert_map_named_chks (uri, pair_list_of_list pairs) with Invalid_argument _ -> raise Bad_action end | _ -> raise Bad_action end | Action_mark_insert_map_ssk_chks -> begin match args with name :: files -> Action_insert_map_ssk_chks (name, files) | _ -> raise Bad_action end | Action_mark_insert_map_ssk_named_chks -> begin match args with name :: pairs -> begin try Action_insert_map_ssk_named_chks (name, pair_list_of_list pairs) with Invalid_argument _ -> raise Bad_action end | _ -> raise Bad_action end | Action_mark_insert_date_redirect -> begin match args with uri :: rest -> let interval, offset, target_uri = match rest with interval :: offset :: target_uri :: [] -> (Some interval, Some offset, Some target_uri) | interval :: offset :: [] -> (Some interval, Some offset, None) | interval :: [] -> (Some interval, None, None) | [] -> (None, None, None) | _ -> raise Bad_action in let interval = match interval with Some interval -> begin try Some (int_of_string interval) with Failure _ -> raise Bad_action end | None -> None and offset = match offset with Some offset -> begin try Some (int_of_string offset) with Failure _ -> raise Bad_action end | None -> None in Action_insert_date_redirect (uri, interval, offset, target_uri) | _ -> raise Bad_action end | Action_mark_insert_date_redirect_ssk -> begin match args with name :: rest -> let interval, offset, target_name = match rest with interval :: offset :: target_name :: [] -> (Some interval, Some offset, Some target_name) | interval :: offset :: [] -> (Some interval, Some offset, None) | interval :: [] -> (Some interval, None, None) | [] -> (None, None, None) | _ -> raise Bad_action in let interval = match interval with Some interval -> begin try Some (int_of_string interval) with Failure _ -> raise Bad_action end | None -> None and offset = match offset with Some offset -> begin try Some (int_of_string offset) with Failure _ -> raise Bad_action end | None -> None in Action_insert_date_redirect_ssk (name, interval, offset, target_name) | _ -> raise Bad_action end | Action_mark_generate_chk -> begin match args with [file] -> Action_generate_chk file | _ -> raise Bad_action end | Action_mark_generate_svk -> begin match args with [] -> Action_generate_svk | _ -> raise Bad_action end (* Process arguments and return an option configuration, action, *) (* and configuration file to use. Yes, the option configuration *) (* is generated before the configuration file one, but it is *) (* applied AFTER it, so as to override settings in it. *) let process_args () = let options = ref [] and conf_file = ref (expand_path "~/.liber") and display_version = ref false and date_method_set = ref false and go_taunt_luser = ref false and action_mark = ref Action_mark_none and action_args_rev = ref [] in let add_option name content = options := (name, content) :: !options in let add_null_option name = add_option name Config_null and add_string_option name string = add_option name (Config_string string) and add_bool_option name bool = add_option name (Config_bool bool) and add_int_option name int = add_option name (Config_int int) and add_float_option name float = add_option name (Config_float float) and add_list_option name items = add_option name (Config_list items) in let null_option name = Arg2.Unit (fun () -> add_null_option name) and string_option name = Arg2.String (fun s -> add_string_option name s) and true_option name = Arg2.Unit (fun () -> add_bool_option name true) and false_option name = Arg2.Unit (fun () -> add_bool_option name false) and int_option name = Arg2.Int (fun i -> add_int_option name i) and float_option name = Arg2.Float (fun f -> add_float_option name f) and mark_action mark = Arg2.Unit (fun () -> if !action_mark = Action_mark_none then action_mark := mark else go_taunt_luser := true) in let args = [(Arg2.Both_arg ('n', "node", "host"), [string_option "node_host"], [], "specify node host (default localhost)"); (Arg2.Both_arg ('p', "port", "port"), [int_option "node_port"], [], "specify node port (default 8481)"); (Arg2.Both_arg ('h', "htl", "hops"), [int_option "transact_htl"], [], "specify hops to live (default 15)"); (Arg2.Both_arg ('t', "max-transacts", "transactions"), [int_option "transact_max_transacts"], [], "specify maximum number of concurrent independent transactions"); (Arg2.Both_arg ('a', "max-attempts", "attempts"), [int_option "transact_max_attempts"], [], "specify maximum number of request or insert retry attempts"); (Arg2.Name_arg ("max-splitfile-threads", "threads"), [int_option "transact_max_splitfile_threads"], [], "specify maximum number of splitfile request or insert"^ " threads"); (Arg2.Name_arg ("read-block-size", "bytes"), [int_option "transact_read_block_size"], [], "specify size of blocks to be read from files in bytes"^ " (default 32K)"); (Arg2.Name_arg ("data-not-found-retry-factor", "coefficient"), [float_option "transact_dnf_retry_factor"], [], "specify the multiplier for the hops to live for a request"^ " retry in response to a DataNotFound response"); (Arg2.Both_arg ('S', "splitfile-block-size", "bytes"), [int_option "splitfile_block_size"], [], "specify attempted size of splitfile blocks to be generated;"^ " splitfiles are automatically generated if their size is"^ " larger than this (default 256K)"); (Arg2.Name_arg ("subspace-private-key", "uri"), [string_option "subspace_private_key"], [], "specify subspace private key to be used for subspace"^ " insertion (default none)"); (Arg2.Both_arg ('M', "with-metadata-file", "file"), [string_option "metadata_file"], [], "use metadata specified in a file (default off)"); (Arg2.Name "without-metadata-file", [null_option "metadata_file"], [], "do not use metadata specified in a file"); (Arg2.Both ('s', "with-suffix-mime-type"), [true_option "metadata_suffix_mime_type"], [], "use inserted file suffixes to determine MIME type for"^ " metadata (default on)"); (Arg2.Name "without-suffix-mime-type", [false_option "metadata_suffix_mime_type"], [], "do not use inserted file suffixed to determine MIME type"^ " for metadata"); (Arg2.Both ('m', "with-modify-date"), [Arg2.Unit (fun () -> if not !date_method_set then begin add_bool_option "metadata_modify_date" true; add_bool_option "metadata_insert_date" false; date_method_set := true end else go_taunt_luser := true)], [], "use inserted file modification dates to determine date"^ " for metadata; cannot be used with with-insert-date"^ " (default on)"); (Arg2.Name "without-modify-date", [false_option "metadata_modify_date"], [], "do not use inserted file modification dates to determine"^ " date for metadata"); (Arg2.Both ('i', "with-insert-date"), [Arg2.Unit (fun () -> if not !date_method_set then begin add_bool_option "metadata_modify_date" false; add_bool_option "metadata_insert_date" true; date_method_set := true end else go_taunt_luser := true)], [], "use date of file insertion to determine date for metadata;"^ " cannot be used with with-modify-date (default off)"); (Arg2.Name "without-insert-date", [false_option "metadata_insert_date"], [], "do not use date of file insertion to determine date for"^ " metadata"); (Arg2.Both_arg ('D', "map-default", "name"), [string_option "multipart_map_default"], [], "specify map part name to use for a default name"^ " (default index.html)"); (Arg2.Name "no-map-default", [null_option "multipart_map_default"], [], "do not use a default map part name"); (Arg2.Both_arg ('d', "date-redirect-item", "[index [increment [offset]]]"), [true_option "date_redirect"], [(int_option "date_redirect_index", fun _ -> ()); (int_option "date_redirect_increment", fun _ -> ()); (int_option "date_redirect_offset", fun _ -> ())], "do top level insertion as a date redirect target; index is"^ " distance from present in increments (default 1), increment"^ " is distance between item in seconds (default 86400, one"^ " day), offset is distance between epoch (00:00 UTC, 1 January"^ " 1970) and item zero in second (default 0)"); (Arg2.Name_arg ("suffix-mime-type-file", "file"), [string_option "metadata_suffix_mime_type_file"], [], "specify file containing file suffix to MIME type mappings"^ " (default ~/.liber_mimetypes)"); (Arg2.Both ('v', "verbose"), [Arg2.Unit (fun () -> add_int_option "output_verbosity" 2)], [], "specify to use normal high verbose message outputting"); (Arg2.Both ('q', "quiet"), [Arg2.Unit (fun () -> add_int_option "output_verbosity" 0)], [], "specify to use quiet message outputting; note that"^ " generated URIs will not be outputted as the only"^ " outputted messages will be errors and debugging"^ " messages, if they are enabled"); (Arg2.Both ('g', "debug"), [true_option "output_debug"], [], "specify to output debugging messages"); (Arg2.Both_arg ('V', "verbosity", "level"), [int_option "output_verbosity"], [], "specify output verbosity; 0 is equivalent to --quiet, 1 is"^ " the default verbosity, 2 is equivalent to --verbose, 3 and"^ " above is very high verbosity"); (Arg2.Name "log-stdout", [true_option "output_stdout"], [], "specify messages to be outputted with standard output"); (Arg2.Name "log-stderr", [true_option "output_stderr"], [], "specify messages to be outputted with standard error"); (Arg2.Name_arg ("log-file", "file"), [string_option "output_file"], [], "specify messages to be outputted to a file"); (Arg2.Both_arg ('f', "config-file", "file"), [Arg2.String_var conf_file], [], "specify configuration file to use (default ~/.liber)"); (Arg2.Name_arg ("request", "uri [file]"), [mark_action Action_mark_request], [], "request a single file's data and optionally metadata"); (Arg2.Name_arg ("request-control", "uri [file]"), [mark_action Action_mark_request_control], [], "request a single file's single control metadata structure;"^ " note that map part URIs are followed; note that the"^ " requested control metadata structure is handled like"^ " requested data"); (Arg2.Name_arg ("request-map", "uri [file]"), [mark_action Action_mark_request_map], [], "request a single file's map structure; note that map part"^ " URIs are not followed; note that the requested map"^ " structure is handled like requested data"); (Arg2.Name_arg ("insert", "file uri"), [mark_action Action_mark_insert_single], [], "insert a single file"); (Arg2.Name_arg ("insert-ssk", "file [name]"), [mark_action Action_mark_insert_single_ssk], [], "insert a single file in the configured subspace"); (Arg2.Name_arg ("insert-chk", "file"), [mark_action Action_mark_insert_single_chk], [], "insert a single file as a CHK and show the generated URI"); (Arg2.Name_arg ("insert-map-chks", "map-uri file ..."), [mark_action Action_mark_insert_map_chks], [], "insert multiple files as CHKs pointed to by map parts in a"^ " map at the specified URI"); (Arg2.Name_arg ("insert-map-named-chks", "map-uri (file name) ..."), [mark_action Action_mark_insert_map_named_chks], [], "insert multiple files as CHKs pointed to by explicitly named"^ " map parts in a map at the specified URI"); (Arg2.Name_arg ("insert-map-ssk-chks", "map-uri file ..."), [mark_action Action_mark_insert_map_ssk_chks], [], "insert multiple files as CHKs pointed to by map parts in a"^ " map at the specified name in the configured subspace"); (Arg2.Name_arg ("insert-map-ssk-named-chks", "map-uri (file name) ..."), [mark_action Action_mark_insert_map_ssk_named_chks], [], "insert multiple files as CHKs pointed to by explicitly named"^ " map parts in a map at the specified name in the configured"^ " subspace"); (Arg2.Name_arg ("insert-date-redirect", "uri [interval [offset [target-uri]]]"), [mark_action Action_mark_insert_date_redirect], [], "insert a date redirect with the specified interval"^ " (86400 seconds (one day) by default), offset from the epoch"^ " (zero seconds by default), and target URI is the same as the"^ " date redirect URI by default"); (Arg2.Name_arg ("insert-date-redirect-ssk", "name [interval [offset [target-name]]]"), [mark_action Action_mark_insert_date_redirect_ssk], [], "insert a date redirect with the specified interval"^ " (86400 seconds (one day) by default), offset from the epoch"^ " (zero seconds by default), and target name is the same as"^ " the date redirect name by default"); (Arg2.Name_arg ("generate-chk", "file"), [mark_action Action_mark_generate_chk], [], "generate a CHK for a given file"); (Arg2.Name "generate-svk", [mark_action Action_mark_generate_svk], [], "generate a random SVK public key/private key pair"); (Arg2.Name "version", [Arg2.Set display_version], [], "display version number")] and usage = "liber [options] key [file]" and descr = "Interact with Freenet" and notes = "by Travis Bemann and Eric Norige" and prefix_error = "liber: " in Arg2.parse args (fun arg -> action_args_rev := arg :: !action_args_rev) usage descr notes prefix_error; if !go_taunt_luser then begin Arg2.usage args usage descr notes; taunt_luser () end else let action_args = List.rev !action_args_rev and options_conf = new configure !options [] false in let action = try parse_action !action_mark action_args with Bad_action -> Arg2.usage args usage descr notes; taunt_luser () in if (action = Action_none) && (not !display_version) then Arg2.usage args usage descr notes else (); (options_conf, !conf_file, action, !display_version) (* Default configuration, without any options or configuration *) (* file; these override it, but do not wholly replace it. *) let default_conf = new configure [("node_host", Config_string "localhost"); ("node_port", Config_int 8481); ("transact_htl", Config_int 15); ("transact_max_transacts", Config_int 4); ("transact_max_attempts", Config_int 4); ("transact_max_splitfile_threads", Config_int 4); ("transact_read_block_size", Config_int (32 * 1024)); ("transact_data_not_found_retry_factor", Config_float 1.25); ("splitfile_block_size", Config_int (256 * 1024)); ("subspace_private_key", Config_null); ("metadata_file", Config_null); ("metadata_suffix_mime_type", Config_bool true); ("metadata_modify_date", Config_bool true); ("metadata_insert_date", Config_bool false); ("metadata_non_dublin_core_dates", Config_bool false); ("metadata_default_mime_type", Config_string "application/octet-stream"); ("multipart_map_default", Config_string "index.html"); ("date_redirect", Config_bool false); ("date_redirect_offset", Config_int 0); ("date_redirect_increment", Config_int 86400); ("date_redirect_index", Config_int 1); ("output_debug", Config_bool false); ("output_verbosity", Config_int 1); ("output_stdout", Config_bool true); ("output_stderr", Config_bool false); ("output_file", Config_null); ("output_stamp", Config_bool false); ("output_request_metadata", Config_bool false); ("output_request_data", Config_bool false); ("output_prefix_info", Config_string ""); ("output_prefix_info_file", Config_string ""); ("output_prefix_error", Config_string "liber: "); ("output_prefix_error_file", Config_string ""); ("output_prefix_debug", Config_string "DEBUG: "); ("output_prefix_debug_file", Config_string "DEBUG: "); ("save_metadata", Config_bool false); ("save_data", Config_bool true); ("save_metadata_prefix", Config_string ""); ("save_metadata_suffix", Config_string ".metadata"); ("save_data_prefix", Config_string ""); ("save_data_suffix", Config_string ""); ("metadata_suffix_mime_type_file", Config_string (expand_path "~/.liber_mimetypes"))] [] false (* Generate a configuration to used from the configuration items *) (* from the options provided, the specified (or default) *) (* configuration file (if it exists) and the default configuration *) (* items. *) let eval_conf options_conf conf_file = let file_conf, no_conf_file = try (new configure [] [conf_file] true, false) with Cannot_open_config | Cannot_open_any_config -> (new configure [] [] false, true) | Config_error msg -> raise (Die_msg (sprintf "%s: %s\n" conf_file (String.uncapitalize msg))) in (default_conf#merge (file_conf#merge options_conf), no_conf_file) (* Header for generated default configuration files. *) let default_conf_file_head = "# Liber(ator) configuration file\n"^ "# \n"^ "# This file was automatically generated by Liber(ator).\n"^ "# All commented lines below represent default configuration"^ " items.\n"^ "# Uncomment them when modifying them to make them apply.\n\n" (* Generate a new configuration file at the specified path. *) let generate_conf file log = try let channel = open_out file in output_string channel default_conf_file_head; output_string channel (default_conf#dump_format ~sort:String.compare ~defaults:default_conf#dump ~escape_high:false); close_out channel; log#log (Msg_info 0) (file ^ ": generated default configuration file") with Sys_error _ -> log#log Msg_error (file ^ ": unable to generate configuration file") (* Create a string representing a configuration value. *) let rec pprint_config = function Config_null -> "null" | Config_bool true -> "true" | Config_bool false -> "false" | Config_int data -> string_of_int data | Config_float data -> string_of_float data | Config_string data -> "\"" ^ data ^ "\"" | Config_list items -> sprintf "[%s]" (String.concat ", " (List.map (fun data -> pprint_config data) items)) (* Validate the actual configuration to be used and generate a new *) (* configuration that replaces non-fatal bad configuration items *) (* with the default ones. *) let check_conf conf log = (* Log a nonfatal configuration error. *) let log_conf name data = log#log Msg_error (sprintf "configuration item '%s' must be a %s; treating as %s" name data (pprint_config (default_conf#field name))) and log_not_found name = raise (Die_msg (sprintf "INTERNAL ERROR - configuration item '%s' does not exist" name)) in (* Log a nonfatal configuration error and add a configuration *) (* reversion item for such. *) let revert_default changes name data = log_conf name data; (name, default_conf#field name) :: changes in (* Handle a configuration item test and return the changes *) (* if it is fine, or otherwise add a configuration reversion back *) (* to the default value. *) let check test changes name data = try ignore (test ()); changes with Failure _ -> revert_default changes name data | Not_found -> log_not_found name in (* Check that a configuration item is a string and return the *) (* changes specified if it is, or otherwise add a configuration *) (* reversion back to the default value. *) let check_string changes name data = check (fun () -> conf#field_string name) changes name data (* Check that a configuration item is either a string or null and *) (* return the changes specified if it is, or otherwise add a *) (* configuration reversion back to the default value. *) and check_string_opt changes name data = check (fun () -> conf#field_string_opt name) changes name data (* Check that a configuration item is a boolean and return the *) (* changes specified if it is, or otherwise add a configuration *) (* reversion back to the default value. *) and check_bool changes name data = check (fun () -> conf#field_bool name) changes name data (* Check that a configuration item is an integer and return the *) (* changes specified if it is, or otherwise add a configuration *) (* reversion back to the default value. *) and check_int changes name data = check (fun () -> conf#field_int name) changes name data (* Check that a configuration item is an integer and is fits the *) (* specified check function (by returnint true) and return the *) (* changes specified if it is, or otherwise add a configuration *) (* reversion back to the default value. *) and check_int_test changes name data test = try if test (conf#field_int name) then changes else revert_default changes name data with Failure _ -> revert_default changes name data | Not_found -> log_not_found name (* Check that a configuration item is a floating point value and *) (* return the changes specified if it is, or otherwise add a *) (* configuration reversion back to the default value. *) and check_float changes name data = check (fun () -> conf#field_float name) changes name data (* Check that a configuration item is an integer and is fits the *) (* specified check function (by returnint true) and return the *) (* changes specified if it is, or otherwise add a configuration *) (* reversion back to the default value. *) and check_float_test changes name data test = try if test (conf#field_float name) then changes else revert_default changes name data with Failure _ -> revert_default changes name data | Not_found -> log_not_found name in (* Check that a configuration item is an integer and is *) (* nonnegative and return the changes specified if it is, or *) (* otherwise add a configuration reversion back to the default *) (* value. *) let check_int_nonneg changes name data = check_int_test changes name data (fun n -> n >= 0) (* Check that a configuration item is an integer and is *) (* positive and return the changes specified if it is, or *) (* otherwise add a configuration reversion back to the default *) (* value. *) and check_int_pos changes name data = check_int_test changes name data (fun n -> n > 0) (* Check that a configuration item is a floating point value and *) (* is nonnegative and return the changes specified if it is, or *) (* otherwise add a configuration reversion back to the default *) (* value. *) and check_float_nonneg changes name data = check_float_test changes name data (fun n -> n >= 0.0) (* Check that a configuration item is a floating point value and *) (* is positive and return the changes specified if it is, or *) (* otherwise add a configuration reversion back to the default *) (* value. *) and check_float_pos changes name data = check_float_test changes name data (fun n -> n > 0.0) in let changes = [] in let changes = check_string changes "node_host" "hostname" in let changes = check_int_test changes "node_port" "port" (fun n -> (n >= 1) && (n <= 65536)) in let changes = check_int_pos changes "transact_max_transacts" "non-zero number of transactions" in let changes = check_int_pos changes "transact_max_splitfile_threads" "non-zero number of threads" in let changes = check_int_pos changes "transact_read_block_size" "non-zero number of bytes" in let changes = check_int_pos changes "transact_max_attempts" "non-zero number of attempts" in let changes = check_float_test changes "transact_data_not_found_retry_factor" "factor larger or equal to one" (fun n -> n >= 1.0) in let changes = check_int_pos changes "splitfile_block_size" "non-zero number of bytes" in let changes = check_bool changes "save_data" "boolean" in let changes = check_string changes "save_data_prefix" "data file prefix" in let changes = check_string changes "save_data_suffix" "data file suffix" in let changes = check_bool changes "output_request_data" "boolean" in let changes = check_bool changes "save_metadata" "boolean" in let changes = check_string changes "save_metadata_prefix" "metadata file prefix" in let changes = check_string changes "save_metadata_suffix" "metadata file suffix" in let changes = check_bool changes "output_request_metadata" "boolean" in let changes = check_int_pos changes "transact_htl" "non-zero hops to live" in let changes = check_string_opt changes "metadata_file" "file path" in let changes = check_bool changes "metadata_suffix_mime_type" "boolean" in let changes = check_bool changes "metadata_modify_date" "boolean" in let changes = check_bool changes "metadata_insert_date" "boolean" in let changes = check_bool changes "metadata_non_dublin_core_dates" "boolean" in let changes = check_string changes "metadata_default_mime_type" "mime type" in let changes = check_bool changes "date_redirect" "boolean" in let changes = check_int_nonneg changes "date_redirect_offset" "number of seconds" in let changes = check_int_pos changes "date_redirect_increment" "non-zero number of seconds" in let changes = check_int_nonneg changes "date_redirect_index" "number of increments" in let changes = check_string_opt changes "subspace_private_key" "subspace private key" in let changes = check_int_pos changes "splitfile_block_size" "non-zero number of bytes" in let changes = check_string_opt changes "metadata_suffix_mime_type_file" "file path" in let changes = check_string_opt changes "multipart_map_default" "default name" in conf#add_fields changes (* Generate a logger object from the configuration. *) let generate_log conf = let output_stamp = try conf#field_bool "output_stamp" with Failure _ -> false and output_file = try conf#field_string_opt "output_file" with Failure _ -> None and output_stderr = try conf#field_bool "output_stderr" with Failure _ -> false and output_stdout = try conf#field_bool "output_stdout" with Failure _ -> false and output_verbosity = try conf#field_int "output_verbosity" with Failure _ -> 1 and output_debug = try conf#field_bool "output_debug" with Failure _ -> false and output_request_data = try conf#field_bool "output_request_data" with Failure _ -> false and output_request_metadata = try conf#field_bool "output_request_metadata" with Failure _ -> false and output_prefix_info = try conf#field_string "output_prefix_info" with Failure _ -> "" and output_prefix_info_file = try conf#field_string "output_prefix_info_file" with Failure _ -> "" and output_prefix_error = try conf#field_string "output_prefix_error" with Failure _ -> "liber: " and output_prefix_error_file = try conf#field_string "output_prefix_error_file" with Failure _ -> "" and output_prefix_debug = try conf#field_string "output_prefix_debug" with Failure _ -> "DEBUG: " and output_prefix_debug_file = try conf#field_string "output_prefix_debug_file" with Failure _ -> "DEBUG: " in if (output_file = None) && (not output_stderr) && (not output_stdout) then (new log_null :> log_type) else let channel, prefix_info, prefix_error, prefix_debug = match output_file with Some file -> begin try let channel = open_out_gen [Open_wronly; Open_append; Open_creat; Open_text] 0o644 (expand_path file) in (channel, output_prefix_info_file, output_prefix_error_file, output_prefix_debug_file) with Sys_error _ -> fprintf stderr "liber: %s: unable to open or write\n" file; (stderr, output_prefix_info, output_prefix_error, output_prefix_debug) end | None -> let stream = if output_stderr || output_request_data || output_request_metadata then stderr else stdout in (stream, output_prefix_info, output_prefix_error, output_prefix_debug) in if output_stamp then (new log_stamp_channel ~channel:channel ~verbosity:output_verbosity ~debug:output_debug ~prefix_info:prefix_info ~prefix_error:prefix_error ~prefix_debug:prefix_debug :> log_type) else (new log_channel ~channel:channel ~verbosity:output_verbosity ~debug:output_debug ~prefix_info:prefix_info ~prefix_error:prefix_error ~prefix_debug:prefix_debug :> log_type) (* Generate an asynchronous high level node object from the *) (* configuration. *) let generate_node conf = let addr = conf#field_string "node_host" and port = conf#field_int "node_port" and actions_max = conf#field_int "transact_max_transacts" and splitfile_threads_max = conf#field_int "transact_max_splitfile_threads" and block_len = conf#field_int "transact_read_block_size" and attempts_max = conf#field_int "transact_max_attempts" and dnf_retry_htl_mult = conf#field_float "transact_data_not_found_retry_factor" and splitfile_block_len_try = conf#field_int "splitfile_block_size" in new node_async ~addr:addr ~port:port ~actions_max:actions_max ~splitfile_threads_max:splitfile_threads_max ~block_len:block_len ~attempts_max:attempts_max ~dnf_retry_htl_mult:dnf_retry_htl_mult ~splitfile_block_len_try:splitfile_block_len_try (* Generate suffix to mimetype mapping information. *) let generate_mimetypes conf log = match conf#field_string_opt "metadata_suffix_mime_type_file" with Some file -> new Mimetype.mimetypes [file] log | None -> new Mimetype.mimetypes [] log (* Log the current version. *) let log_version log = log#log (Msg_info 0) ("Liber(ator) version " ^ version) (* Liber top level. *) let main () = Random.self_init (); let options_conf, conf_file, action, display_version = try process_args () with Die_msg msg -> fprintf stderr "liber: %s\n" msg; exit 2 | Arg2.Parse_halt -> exit 0 in let conf, no_conf_file = try eval_conf options_conf conf_file with Die_msg msg -> fprintf stderr "liber: %s\n" msg; exit 2 in let log = generate_log conf in if no_conf_file then generate_conf conf_file log else (); let conf = check_conf conf log in if display_version then log_version log else (); try begin try log#log (Msg_info 2) "created configuration"; let node = generate_node conf and mimetypes = generate_mimetypes conf log in log#log (Msg_info 2) "loaded mime type mappings"; log#log (Msg_info 2) "starting actions"; start_action action conf log node mimetypes; log#log (Msg_info 2) "waiting for all actions to complete"; node#wait_all with Bad_conf (item, data) -> raise (Die_msg (sprintf "configuration item '%s' must be a %s" item data)) end with Die_msg msg -> log#log Msg_error msg; exit 2 (* Primary entry point. *) let _ = main ()