Commit 1e7828cd authored by Glen Mével's avatar Glen Mével
Browse files

`dump-treetabs-session`: same as `dump-firefox-session` but processes TreeTabs...

`dump-treetabs-session`: same as `dump-firefox-session` but processes TreeTabs backup files (*.tt_session)
parent 9be31ce6
#!/bin/env ocaml
(* requires OCaml ≥ 4.06 *)
(*
* Dump, in human-readable form, a Firefox/TreeTabs session backup provided on stdin.
*
* TreeTabs session backups are Json-encoded files generated on-demand.
*
* This script demonstrates a minimal Json parser/printer.
*)
(*******************************************************************************
** Generic stuff *************************************************************)
let ( %> ) f g x = g (f x)
module Option :
sig
val some : 'a -> 'a option
val app : default:'b -> f:('a -> 'b) -> 'a option -> 'b
val def : default:'a -> 'a option -> 'a
val bind : ('a -> 'b option) -> 'a option -> 'b option
val map : ('a -> 'b) -> 'a option -> 'b option
val odo : ('a -> unit) -> 'a option -> unit
module Infix :
sig
val ( or ) : 'a option -> 'a -> 'a
val ( >>= ) : 'a option -> ('a -> 'b option) -> 'b option
val ( |>= ) : 'a option -> ('a -> 'b) -> 'b option
end
end =
struct
let some x = Some x
let app ~default ~f = function
| Some x -> f x
| None -> default
let def ~default o = app ~default ~f:(fun x -> x) o
let bind f o = app ~default:None ~f o
let map f o = app ~default:None ~f:(f %> some) o
let odo f o = app ~default:() ~f o
module Infix = struct
let ( or ) o d = def ~default:d o
let ( >>= ) o f = bind f o
let ( |>= ) o f = map f o
end
end
(*******************************************************************************
** Json expressions and how to deal with them ********************************)
(* With these notations, one can write:
* json.?{[ R ; F "field1" ; R ; F "subfield1" ; B ]}
* instead of (e.g.):
* json |> as_record |.? "field1" |>= as_record
* >>= fun r -> r |.? "subfield1" |>= as_bool
*)
module Json =
struct
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; }
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"
module Subscript =
struct
type (_, _) index =
| (* bool value *) B : (value, bool ) index
| (* int value *) Z : (value, int ) index
| (* string value *) S : (value, string ) index
| (* list value *) L : (value, value list ) index
| (* record value *) R : (value, record_field list) index
| (* index of list *) I : int -> (value list, value) index
| (* field of record *) F : string -> (record_field list, value) index
type (_, _) indices =
| [] : ('a, 'a) indices
| (::) : ('a, 'b) index * ('b, 'c) indices -> ('a, 'c) indices
end
open Subscript
let get' : type a b. (a, b) index -> a -> b =
fun index ->
begin match index with
| B -> as_bool
| Z -> as_int
| S -> as_string
| L -> as_list
| R -> as_record
| I idx -> fun x -> List.nth x idx
| F name -> fun x -> get_field x name
end
let rec get : type a b. (a, b) indices -> a -> b =
fun indices ->
begin match indices with
| [] -> fun x -> x
| index :: indices' -> get' index %> get indices'
end
let get_opt indices x =
begin try
Some (get indices x)
with Invalid_argument _ | Not_found | Failure _ ->
None
end
module Infix =
struct
let ( |? ) = has_field
let ( |. ) = get_field
let ( |.? ) = get_field_opt
let ( .!{ } ) x idx = get idx x
let ( .?{ } ) x idx = get_opt idx x
end
end (* module Json *)
(*******************************************************************************
** Json parser ***************************************************************)
module Json_parser :
sig
val parse_json_file : in_channel -> Json.value
val parse_json_string : string -> Json.value
end =
struct
open Json
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)
end (* module Json_parser *)
(*******************************************************************************
** Json printer **************************************************************)
module Json_printer :
sig
val print_json : out_channel -> ?level:int -> Json.value -> unit
end =
struct
open Json
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 ?(level=0) =
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 level
end (* module Json_printer *)
(*******************************************************************************
** Packing everything together ***********************************************)
module Json =
struct
include Json
module Parser = Json_parser
module Printer = Json_printer
end
(*******************************************************************************
** Application 1: reformat Json code *****************************************)
(*
let () =
stdin
|> Json.Parser.parse_json_file
|> Json.Printer.print_json stdout
*)
(*******************************************************************************
** Application 2: dump a Firefox/TreeTabs session backup in a readable format *)
open Option.Infix
open Json.Infix
open Json
type tab = {
url : string ;
title : string ;
}
(* NOTE: Groups are not “nodes”, because they cannot be the child of anything.
* They are the roots of the forest. *)
type node =
| Tab of tab
| Folder of string
type tree =
{
node : node ;
children : tree list ;
}
type group =
{
group_name : string ;
group_tabs : tree list ;
}
let indent_width = 4
let rec print_tree out ?(indent=0) tree =
let indent_string = Printf.sprintf "%*s" (indent_width * indent) "" in
begin match tree.node with
| Tab tab ->
Printf.fprintf out "%s- %s\n" indent_string tab.title ;
Printf.fprintf out "%s %s\n" indent_string tab.url
| Folder folder_name ->
Printf.fprintf out "%s+ %s\n" indent_string folder_name
end ;
tree.children |> List.iter (print_tree out ~indent:(indent+1))
type 'a with_index =
{
index : int ;
indexed_value : 'a ;
}
let sort_with_indexes (li : 'a with_index list) : 'a list =
li
|> List.sort (fun a b -> Stdlib.compare a.index b.index)
|> List.map (fun x -> x.indexed_value)
(* There are two phases in building the tab forest.
* (1) For each “node” (tab/folder), build the node and add it to the list of
* the children of its parent.
* (2) For each group, build the tree whose root is this group, by collecting
* the children lists recursively.
* This is so, because links between parents and children are provided from
* child to parent, and must thus be reversed to build an immutable tree.
* This works because groups are guaranteed to be roots. *)
(* Groups, folders and tabs all have an ID in the Json file. *)
type id = string
(* The global state.
* - The [children] hashtable stores, for each ID (be it that of a group,
* folder, or tab), the list of children of this ID.
* - The [groups] list stores the groups whose tree has already been built.
* *)
let childrens : (id, (id * node) with_index list) Hashtbl.t = Hashtbl.create 10
let groups : group with_index list ref = ref []
let clear () =
Hashtbl.clear childrens ;
groups := []
let add_child parent_id child =
let old_children = Hashtbl.find_opt childrens parent_id or [] in
Hashtbl.replace childrens parent_id (child :: old_children)
let add_treetabs_tab tab =
let id = tab.!{[ F "id" ; Z ]} |> string_of_int in
let parent = tab.!{[ F "parent" ; S ]} in
let index = tab.!{[ F "index" ; Z ]} in
let url = tab.!{[ F "url" ; S ]} in
let title = tab.!{[ F "title" ; S ]} in
let node = Tab { url ; title } in
add_child parent { index ; indexed_value = (id, node) }
let add_folder folder =
let id = folder.!{[ F "id" ; S ]} in
let parent = folder.!{[ F "parent" ; S ]} in
let index = folder.!{[ F "index" ; Z ]} in
let name = folder.!{[ F "name" ; S ]} in
let node = Folder name in
add_child parent { index ; indexed_value = (id, node) }
let rec build_children (id : id) : tree list =
id
|> Hashtbl.find_opt childrens
|> Option.def ~default:[]
|> sort_with_indexes
|> List.map build_tree
and build_tree (id, node : id * node) : tree =
{
node = node ;
children = build_children id ;
}
let add_group ~id ~name ~index =
let children = build_children id in
let group = { group_name = name ; group_tabs = children } in
groups := { index ; indexed_value = group } :: !groups
let add_treetabs_group group =
let id = group.!{[ F "id" ; S ]} in
let name = group.!{[ F "name" ; S ]} in
let index = group.!{[ F "index" ; Z ]} in
add_group ~id ~name ~index
(* Tree Tabs puts pinned tabs in an implicit group with ID "pin_list". *)
let add_treetabs_pinned_group () =
add_group ~id:"pin_list" ~name:"Pinned" ~index:~-1
let () =
let json = Parser.parse_json_file stdin in
json.!{[ L ]} |> List.map as_record
(* For each window… *)
|> List.iteri begin fun window_count window ->
(* Process all tabs. *)
window.!{[ F "tabs" ; L ]} |> List.iter (as_record %> add_treetabs_tab) ;
(* Process all folders. *)
window.!{[ F "folders" ; R ]}
|> List.map (fun field -> field.value |> as_record)
|> List.iter add_folder ;
(* Process all groups. *)
add_treetabs_pinned_group () ;
window.!{[ F "groups" ; R ]}
|> List.map (fun field -> field.value |> as_record)
|> List.iter add_treetabs_group ;
(* Finalize groups. *)
let groups = sort_with_indexes !groups in
(* Print the whole forest. *)
Printf.printf "\n{ WINDOW %u }\n" (window_count + 1) ;
groups |> List.iter begin fun group ->
Printf.printf "\n[%s]\n\n" group.group_name ;
List.iter (print_tree stdout ~indent:1) group.group_tabs ;
end ;
(* Clear the global state for subsequent windows. *)
clear () ;
end
Supports Markdown
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