Commit 21619fb2 authored by Glen Mével's avatar Glen Mével
Browse files

`dump-firefox-session` now supports Tree Tabs and Tree Style Tabs

parent ac4c5f33
This diff is collapsed.
#!/bin/env ocaml
(* guyslain nave, teaching / prog fonctionnelle / tp 8 (parseurs) *)
(**
** a small json parser
**
** reads json code on stdin and reformat it on stdout
**)
let ( %> ) f g x = g (f x)
let some x = Some x
(* json expressions: *)
type value =
| Base of base_value
| List of value list
| Record of record_field list
and base_value =
| Null
| Bool of bool
| Int of int64
| Float of float
| String of string
and record_field =
{ name : base_value;
value : value; }
class virtual stream =
object
method virtual get : char
method virtual unget : char -> unit
end
class file_stream file =
object
inherit stream
val mutable buf = []
method get =
match buf with
| c::buf' -> buf <- buf'; c
| [] -> input_char file
method unget c =
buf <- c :: buf
end
class string_stream s =
object
inherit stream
val len = String.length s
val mutable i = 0
method get =
i <- i + 1 ;
if i > len then
raise End_of_file ;
s.[i-1]
method unget c =
i <- i - 1 ;
assert (i >= 0 && c = s.[i])
end
let is_blank = function
| ' ' | '\t' | '\r' | '\n' -> true
| _ -> false
let is_ident = function
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '-' | '.' -> true
| _ -> false
let parse_json stream =
(* as stream#get, returns the first character, but ignores blanks;
* raises EOF under analogous conditions: *)
let rec get_nonblank () =
let c = stream#get in
if is_blank c then get_nonblank () else c
in
(* raises EOF only if input is empty (modulo blanks): *)
let rec parse_value () : value =
begin match get_nonblank () with
| '[' ->
parse_list ()
| '{' ->
parse_record ()
| c when is_ident c ->
let buf = Buffer.create 32 in
begin try
let c = ref c in
while is_ident !c do
Buffer.add_char buf !c;
c := stream#get
done;
stream#unget !c
with End_of_file ->
()
end;
begin match Buffer.contents buf with
| "null" -> Base Null
| "false" -> Base (Bool false)
| "true" -> Base (Bool true)
| s ->
begin try
Base (Int (Int64.of_string s))
with Failure _ ->
begin try
Base (Float (float_of_string s))
with Failure _ ->
failwith @@ "unrecognized token: " ^ s
end
end
end
| '"' ->
let buf = Buffer.create 1024 in
begin try
let c = ref '\000' in
while c := stream#get; !c <> '"' do
if !c = '\\' then
c := stream#get;
Buffer.add_char buf !c
done;
with End_of_file ->
failwith "unterminated quoted string"
end;
Base (String (Buffer.contents buf))
| _ ->
failwith "syntax error: identifier, string, list or record expected"
end
(* raises EOF only if input is empty: *)
and parse_record_field () : record_field =
begin match parse_value () with
| Base name ->
begin try
begin match get_nonblank () with
| ':' ->
let value = parse_value () in
{ name; value }
| _ ->
failwith "syntax error: ‘:’ expected after a field name"
end
with End_of_file ->
failwith "unterminated record field"
end
| _ ->
failwith "forbidden expression as a field name"
end
(* never raise EOF: *)
and parse_record_aux () : record_field list =
begin match get_nonblank () with
| '}' ->
[]
| c ->
stream#unget c;
let field = parse_record_field () in
begin match get_nonblank () with
| '}' ->
[field]
| ',' ->
field :: parse_record_aux ()
| _ ->
failwith "syntax error: ‘,’ or ‘}’ expected after a record field"
| exception End_of_file ->
failwith "unterminated record"
end
| exception End_of_file ->
failwith "unterminated record"
end
and parse_record () : value =
Record (parse_record_aux ())
(* never raise EOF: *)
and parse_list_aux () : value list =
begin match get_nonblank () with
| ']' ->
[]
| c ->
stream#unget c;
let elem = parse_value () in
begin match get_nonblank () with
| ']' ->
[elem]
| ',' ->
elem :: parse_list_aux ()
| _ ->
failwith "syntax error: ‘,’ or ‘]’ expected after a list element"
| exception End_of_file ->
failwith "unterminated list"
end
| exception End_of_file ->
failwith "unterminated list"
end
and parse_list () : value =
List (parse_list_aux ())
in
begin match parse_value () with
| json ->
begin match get_nonblank () with
| exception End_of_file ->
json
| _ ->
failwith "extra input"
end
| exception End_of_file ->
failwith "empty input"
end
let parse_json_file in_file =
parse_json (new file_stream in_file)
let parse_json_string s =
parse_json (new string_stream s)
let print_indent out_file level =
for _ = 1 to level do
output_char out_file '\t'
done
let print_quoted out_file str =
String.iter (fun c ->
if c = '"' || c = '\\' then
output_char out_file '\\';
output_char out_file c
)
str
let print_json out_file json =
let rec print level = function
| Base Null ->
output_string out_file "null"
| Base (Bool b) ->
output_string out_file (string_of_bool b)
| Base (Int i) ->
output_string out_file (Int64.to_string i)
| Base (Float f) ->
output_string out_file (string_of_float f)
| Base (String str) ->
(*Printf.fprintf out_file "%S" str*)
(*output_string out_file @@ "\"" ^ String.escaped str ^ "\""*)
output_char out_file '"';
print_quoted out_file str;
output_char out_file '"'
| List values ->
output_string out_file "[\n";
let level' = level+1 in
List.iter (fun value ->
print_indent out_file level';
print level' value;
output_string out_file ",\n"
)
values;
(*List.iter
(Printf.fprintf out_file "%a%a,\n" print_indent level' (print level'))
values;*)
Printf.fprintf out_file "%a]" print_indent level
| Record fields ->
output_string out_file "{\n";
let level' = level+1 in
List.iter (fun { name; value } ->
print_indent out_file level';
print level' (Base name);
output_char out_file ':';
print level' value;
output_string out_file ",\n";
(*Printf.fprintf out_file "%a%a:%a,\n"
print_indent level'
(print level') (Base name)
(print level') value*)
)
fields;
print_indent out_file level;
output_char out_file '}'
(*Printf.fprintf out_file "%a]" print_indent level*)
in
print 0 json
(*
* the simple json reformater
*)
(*
let () =
stdin
|> parse_json_file
|> print_json stdout
*)
(*
* a more elaborate application:
*
* dump a Firefox session backup in a much more concise and readable form (such
* backups can be found under ~/.mozilla/firefox/my.profile/sessionstore-backups/)
*)
let has_field record name' =
record
|> List.exists (fun { name; _ } -> name = String name')
let get_field record name =
record
|> List.map (fun { name; value } -> name, value)
|> List.assoc (String name)
let get_field_opt record name =
try
Some (get_field record name)
with Not_found ->
None
let as_bool = function
| Base (Bool b) -> b
| _ -> raise @@ Invalid_argument "as_bool"
let as_int = function
| Base (Int i) -> Int64.to_int i
| _ -> raise @@ Invalid_argument "as_int"
let as_string = function
| Base (String str) -> str
| _ -> raise @@ Invalid_argument "as_string"
let as_list = function
| List li -> li
| Base Null -> []
| _ -> raise @@ Invalid_argument "as_list"
let as_record = function
| Record r -> r
| Base Null -> []
| _ -> raise @@ Invalid_argument "as_record"
let opt_map ~default f = function
| Some x -> f x
| None -> default
let ( |? ) = has_field
let ( |. ) = get_field
let ( |.? ) = get_field_opt
let ( >>= ) o f = opt_map ~default:None f o
let opt_do f o = opt_map ~default:() f o
type tab = {
url : string ;
title : string ;
(*pinned : bool ;
hidden : bool ;*)
}
let () =
let tabgroup_titles = ref []
and tabgroups = Hashtbl.create 10 in
let add_to_group group_id tab =
let old =
begin try
Hashtbl.find tabgroups group_id
with Not_found ->
[]
end
in
Hashtbl.replace tabgroups group_id (tab :: old)
in
parse_json_file stdin |> as_record |. "windows" |> as_list
|> List.iter (fun window ->
window |> as_record |. "tabs" |> as_list
|> List.iter (as_record %> fun tab ->
(*let pinned = tab |.? "pinned" |> opt_map as_bool ~default:false
and hidden = tab |.? "hidden" |> opt_map as_bool ~default:false in*)
let entries = tab |. "entries" |> as_list in
let index = tab |.? "index" |> opt_map as_int ~default:(List.length entries) in
let entry = List.nth entries (index-1) |> as_record in
let url = entry |.? "url" |> opt_map as_string ~default:"[no url]"
and title = entry |.? "title" |> opt_map as_string ~default:"[no title]" in
let group_id =
tab |.? "extData" >>= (as_record %> fun extdata ->
extdata |.? "tabview-tab" >>= (as_string %> parse_json_string %> as_record %> fun tabview ->
tabview |.? "groupID" >>= (as_int %> some)
)
)
in
let tab = { url ; title (*pinned ; hidden*) } in
add_to_group group_id tab
) ;
window |> as_record |.? "extData" |> opt_do (as_record %> fun extdata ->
extdata |.? "tabview-group" |> opt_do (as_string %> parse_json_string %> as_record %>
List.iter (fun field ->
let id = Base field.name |> as_string |> int_of_string
and title = field.value |> as_record |. "title" |> as_string in
tabgroup_titles := (id, title) :: !tabgroup_titles
)
)
)
) ;
Hashtbl.iter (fun group_id tabs ->
begin match group_id with
| None -> Printf.printf "\n-- pinned or not grouped\n\n"
| Some id -> Printf.printf "\n-- group %i: %s\n\n" id (List.assoc id !tabgroup_titles)
end ;
let tabs = List.rev tabs in
List.iter (fun tab ->
Printf.printf "%s\n\t%s\n%!" tab.url tab.title
)
tabs
)
tabgroups
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment