(* Copyright 2005-2008 Berke DURAK, INRIA Rocquencourt, Jaap BOENDER.

This file is part of Dose2.

Dose2 is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Dose2 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 Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>. *)

(* version ::=
   | epoch':'.upstream_version.'-'.debian_revision
   | upstream_version_no_colon.'-'.debian_revision
   | upstream_version_no_colon_no_dash
   | epoch':'.upstream_version_no_dash
 * epoch ::= [0-9]+
 * upstream_version ::= [a-zA-Z0-9.+-:]+
 * upstream_version_no_colon ::= [a-zA-Z0-9.+-]+
 * upstream_version_no_dash ::= [a-zA-Z0-9.+:]+
 * upstream_version_no_colon_no_dash ::= [a-zA-Z0-9.+]+
 * debian_revision ::= [a-zA-Z0-9+.]+
 *)

open Big_int
open Scanf
open Util
open Napkin

let comma_rex = Pcre.regexp ",";;
let bar_rex = Pcre.regexp "\\|";;

let buffer = ref "";;
let buffer_pos = ref 0;;
let bufsize = 8192;;
let sub_buffer = String.create bufsize;;

let extract_epoch x =
  try
    let ci = String.index x ':' in
    if ci < String.length x - 1 then
      let epoch = String.sub x 0 ci
      and rest = String.sub x (ci + 1) (String.length x - ci - 1)
      in
      (epoch,rest)
    else
      ("",x)
  with
  | Not_found -> ("",x)
;;

let extract_revision x =
  try
    let di = String.rindex x '-' in
    if di < String.length x - 1 then
      let upstream = String.sub x 0 di
      and revision = String.sub x (di + 1) (String.length x - di - 1)
      in
      (upstream,revision)
    else
      (x,"")
  with
  | Not_found -> (x,"")
;;

let extract_chunks x =
  let (epoch,rest) = extract_epoch x in
  let (upstream,revision) = extract_revision rest in
  (epoch,upstream,revision)
;;

let ( ** ) x y = if x = 0 then y else x;;
let ( *** ) x y = if x = 0 then y () else x;;
let ( ~~~ ) f x = not (f x)

let order = function
  | `C '~' -> (0,'~')
  | `C('0'..'9' as c) -> (1,c)
  | `E -> (2,'\000')
  | `C('a'..'z'|'A'..'Z' as c) -> (3,c)
  | `C(c) -> (4,c)
;;

let compare_couples (x1,x2) (y1,y2) = (compare x1 y1) ** (compare x2 y2);;

let compare_special x y =
  let m = String.length x
  and n = String.length y
  in
  let rec loop i =
    let cx = if i >= m then `E else `C(x.[i])
    and cy = if i >= n then `E else `C(y.[i])
    in
    (compare_couples (order cx) (order cy)) ***
    (fun () ->
      if i > m or i > n then
        0
      else
        loop (i + 1))
  in
  loop 0
;;

(* -1 : x < y *)
(** According to APT's behaviour, 5.002 and 5.2 are equivalent version numbers.  This means that
  * the Debian ordering is not a proper order on strings but a preorder.  This means that it is
  * not possible to use version string-indexed hashtables, as we may get duplicate entries.
  *)

let compare_numeric_decimal x y =
  let m = String.length x
  and n = String.length y
  in
  let rec loop1 i j =
    if i < m && x.[i] = '0' then
      loop1 (i + 1) j
    else
      if j < n && y.[j] = '0' then
        loop1 i (j + 1)
      else
        if i = m && j = n then
          0
        else
          loop2 i j
  and loop2 i j =
    if i = m then
      if j = n then
        0
      else
        (* x is finished, but y is not *)
        -1
    else
      if j = n then
        (* x is not finished, but y is *)
        1
      else
        if m - i < n - j then -1
        else if m - i > n - j then 1
        else
          if x.[i] < y.[j] then -1
          else if x.[i] > y.[j] then 1
          else
              loop2 (i + 1) (j + 1)
  in
  loop1 0 0
;;
(* ***)

let rec compare_chunks x y =
  if x = y then 0
  else
    let x1,x2 = longest_matching_prefix (~~~ is_digit) x
    and y1,y2 = longest_matching_prefix (~~~ is_digit) y
    in
    let c = compare_special x1 y1 in
    if c <> 0 then
      c
    else
      let (x21,x22) = longest_matching_prefix is_digit x2
      and (y21,y22) = longest_matching_prefix is_digit y2
      in
      let c = compare_numeric_decimal x21 y21 in
      if c <> 0 then
        c
      else
        compare_chunks x22 y22
;;

let compare_versions x1 x2 =
  let (e1,u1,r1) = extract_chunks x1
  and (e2,u2,r2) = extract_chunks x2
  in
  (compare_numeric_decimal e1 e2) ***
    (fun () -> (compare_chunks u1 u2) ***
      (fun () -> compare_chunks r1 r2))
;;

let detect_pre_dependency_cycle (ps: default_package list): bool = 
let pd_ht = Hashtbl.create (List.length ps) in
let rec detect_cycle pd_ht u =
begin
	try
		let (d, m) = Hashtbl.find pd_ht u in
		match m with
		| `Grey -> (Printf.eprintf "WARNING: pre_dependency cycle at package %s!\n%!" u; true)
		| `White -> (Hashtbl.replace pd_ht u (d, `Grey);
			let r = List.fold_left (fun x alt ->
				(List.fold_left (fun y vs  ->
					match vs with
					| Unit_version (v, _) -> (detect_cycle pd_ht v) || y
					| Glob_pattern _ -> raise (Failure "Debian does not support glob patterns")
				) false alt) || x
			) false d in
			Hashtbl.replace pd_ht u (d, `Black);
			r)
		| `Black -> false
	with Not_found -> false (* ignore virtual packages *)
end in
let cycle = ref false in
begin
	List.iter (fun p ->
		Hashtbl.add pd_ht p.pk_unit (p.pk_pre_depends, `White)
	) ps;
	Hashtbl.iter (fun u _ ->
		if (detect_cycle pd_ht u) then cycle := true
	) pd_ht;
	!cycle
end;;

(**
Read a character from a .deb file (buffer if necessary)
@param channel Channel to read from
@param input_char Function that reads a character from the input channel
@return the character read
*)
let read_deb_char (input: unit -> string): char =
begin
	if (!buffer = "") || (!buffer_pos >= String.length !buffer) then
	begin
		buffer := input ();
		buffer_pos := 0;
	end;
	let result = !buffer.[!buffer_pos] in
		incr buffer_pos;
		result
end;;

let next_deb_char (input: unit -> string): char =
begin
	if (!buffer = "") || (!buffer_pos >= String.length !buffer) then
	begin
		buffer := input (); 
		buffer_pos := 0;
	end;
	!buffer.[!buffer_pos]
end;;

(**
Parse a debian name and version specification
Example: kde (>= 3.5)
@param spec The specification
@return a deb_dependency containing the specification
*)
let parse_deb_name_version (s: string): (string, string, string) versioned =
begin
	let spec = remove_spaces s in
	try
		sscanf (remove_spaces spec) "%[^(] (%[^)])" (fun t v ->
		let target = (remove_spaces t) in
		Unit_version (target, try
			sscanf v "= %s" (fun vn -> Sel_EQ vn)
		with Scan_failure _ ->
		try
			sscanf v "<< %s" (fun vn -> Sel_LT vn)
		with Scan_failure _ ->
		try
			sscanf v "<= %s" (fun vn -> Sel_LEQ vn)
		with Scan_failure _ ->
		try
			sscanf v ">= %s" (fun vn -> Sel_GEQ vn)
		with Scan_failure _ ->
		try
			sscanf v ">> %s" (fun vn -> Sel_GT vn)
		with Scan_failure _ ->
		try
			sscanf v "> %s" (fun vn -> Sel_GT vn)
		with Scan_failure _ ->
		try
			sscanf v "< %s" (fun vn -> Sel_LT vn)
		with Scan_failure _ -> Sel_ANY)
	)
	with End_of_file -> Unit_version (spec, Sel_ANY)
end;;


let parse_deb_list (fields: (string, string) Hashtbl.t) (name: string): (string, string, string) versioned list =
begin
	try
		let line = Hashtbl.find fields name in
		List.map parse_deb_name_version (List.map remove_spaces (Pcre.split ~rex:comma_rex line))
	with Not_found -> []
end;;

(**
Parse a .deb dependency line (Depends: ...)
@param line The dependency line
@return a deb_dep_expression containing the line
*)
let parse_deb_disjunction (fields: (string, string) Hashtbl.t) (name: string): (string, string, string) versioned list list =
begin
	try
		let line = Hashtbl.find fields name in
		let disjunctions = Pcre.split ~rex:comma_rex line in
		List.map (fun disj ->
			List.map parse_deb_name_version (List.map remove_spaces (Pcre.split ~rex:bar_rex disj))
		) disjunctions
	with
		Not_found -> []
end;;

let parse_deb_boolean (fields: (string, string) Hashtbl.t) (name: string): bool =
begin
	try
		(Hashtbl.find fields name) = "yes"
	with Not_found -> false
end;;

let parse_deb_int64 (fields: (string, string) Hashtbl.t) (name: string): int64 =
begin
	try
		Int64.of_string (Hashtbl.find fields name)
	with Not_found -> 0L
end;;

(**
Read a field from a .deb file
@param channel Channel to read from
@param input_char Function to read a character from that channel
*)
let read_deb_field (input: unit -> string): string * string =
let my_char = ref ' '
and my_line = ref ""
and is_multiline = ref true
and my_name = ref ""
and my_contents = ref "" in
begin
	while !is_multiline
	do
		my_char := read_deb_char input;
		while !my_char <> '\n'
		do
			my_line := !my_line ^ (String.make 1 !my_char);
			my_char := read_deb_char input;
		done;
		let next = next_deb_char input in
		is_multiline := (next = ' ' || next = '\t');
		if (!is_multiline) then my_line := !my_line ^ "\n"
	done;		
	if !my_line = "" then raise End_of_file;
	let colon_index = String.index  !my_line ':' in
	my_name := String.lowercase (String.sub !my_line 0 colon_index);
	my_contents := remove_leading_spaces (String.sub !my_line (colon_index + 1) ((String.length !my_line) - colon_index - 1));
	(!my_name, !my_contents)
end;;

let read_deb_fields (input: unit -> string): (string, string) Hashtbl.t =
let fields = Hashtbl.create 10 in
begin
	try
		while true
		do
			let (n, v) = read_deb_field input in
				Hashtbl.add fields n v
		done;
		fields
	with End_of_file -> fields
end;;

let strict_package_re = Pcre.regexp "^[a-z0-9][a-z0-9.+-]+$"
let package_re = Pcre.regexp "^[A-Za-z0-9][A-Za-z0-9._+-]+$"
let strict_architecture_re = Pcre.regexp "^[a-z0-9]+-?[a-z0-9]+$"
let architecture_re = Pcre.regexp "^[A-Za-z0-9][A-Za-z0-9._+-]+$"

let napkin_of_fields (fields: (string, string) Hashtbl.t): default_package =
begin
	(* Package (unit and version *)
	let (pk_unit, pk_version) =
	try
		let u = Hashtbl.find fields "package" in
		try
			let v = Hashtbl.find fields "version" in
			(u, v)
			with Not_found -> raise (Failure (Printf.sprintf "Package %S ignored because it has no version." u))
		with Not_found -> raise (Failure "Warning: package ignored because it has no name") in
	(* Source *)
	let pk_source =
	try
		let sp = Hashtbl.find fields "source" in
		try
			Scanf.sscanf sp "%[^ \t] (%[^)])" (fun n v -> (n, v)) 
		with 
		| End_of_file -> (sp, pk_version)
		| Scan_failure _ -> 
		    try
		      Scanf.sscanf sp "%[^ \t] %[^)]" (fun n v -> (n, v)) 
		    with
		    | End_of_file -> (sp, pk_version)
	with Not_found -> (pk_unit, pk_version) in
	(* Architecture *)
	let pk_architecture = 
	try	
		Hashtbl.find fields "architecture"
 	with Not_found -> (Printf.eprintf "Warning: package %s doesn't have an architecture, using 'any'\n%!" pk_unit; "any") in
	(* Give warnings in case packages and/or architectures are strange *)
	if not (Pcre.pmatch ~rex:strict_package_re pk_unit) then
	begin
		Printf.eprintf "Warning: Bad package name: %s\n%!" pk_unit;
		if not (Pcre.pmatch ~rex:package_re pk_unit) then
			failwith (Format.sprintf "Error: Really bad package name: %s\n%!" pk_unit)
	end;
	if not (Pcre.pmatch ~rex:strict_architecture_re pk_architecture) then
	begin
		Printf.eprintf "Warning: Bad architecture name: %s\n%!" pk_architecture;
		if not (Pcre.pmatch ~rex:architecture_re pk_architecture) then
			failwith (Format.sprintf "Error: Really bad architecture name: %s\n%!" pk_architecture)
	end;
	{ pk_extra = ();
		pk_unit = pk_unit;
		pk_version = pk_version;
		pk_architecture = pk_architecture;
		pk_source = pk_source;
		pk_essential = parse_deb_boolean fields "essential";
		pk_build_essential = parse_deb_boolean fields "build-essential";
		pk_size = parse_deb_int64 fields "size";
		pk_installed_size = parse_deb_int64 fields "installed-size";
		pk_provides = parse_deb_list fields "provides";
		pk_conflicts = parse_deb_list fields "conflicts";
		pk_breaks = parse_deb_list fields "breaks";
		pk_replaces = parse_deb_list fields "replaces";
		pk_depends = parse_deb_disjunction fields "depends";
		pk_pre_depends = parse_deb_disjunction fields "pre-depends";
		pk_suggests = parse_deb_disjunction fields "suggests";
		pk_recommends = parse_deb_disjunction fields "recommends";
		pk_enhances = parse_deb_disjunction fields "enhances"
	}
end;;

(** Read MD5 sums from a .deb file
@param channel Channel to input from
@param input_char Function to read a character from that channel
@param size The size of the MD5 file in the .deb file
@return a list of tuples (name and MD5 sum)
*)
let read_deb_md5sums (channel: 'a) (input_char: 'a -> char) (size: big_int): (string * string) list =
let files = ref []
and my_char = ref (input_char channel) 
and my_line = ref "" 
and chars_read = ref unit_big_int in
begin
	try
		while (le_big_int !chars_read size)
		do
			while (!my_char <> '\n')
			do
				my_line := !my_line ^ (String.make 1 !my_char);
				my_char := input_char channel;
				chars_read := succ_big_int !chars_read;
			done;
			sscanf !my_line "%s %s" (fun s f ->
				files := (f, s)::!files);
			my_line := "";
			my_char := input_char channel;
			chars_read := succ_big_int !chars_read
		done;
		(* read up to 512 extra characters *)
		let rest = 512 - (int_of_big_int (mod_big_int size (big_int_of_int 512))) in
			if rest <> 0 then for i = 2 to rest do ignore (input_char channel) done;
		!files
	with
		End_of_file -> !files
end;;

let bz2_input c () =
	let r = Bz2.read c sub_buffer 0 bufsize in
		if r = 0 then raise End_of_file else (String.sub sub_buffer 0 r);;

let gzip_input c () =
	let r = Gzip.input c sub_buffer 0 bufsize in
		if r = 0 then raise End_of_file else (String.sub sub_buffer 0 r);;

let normal_input c () =
	let r = Pervasives.input c sub_buffer 0 bufsize in
		if r = 0 then raise End_of_file else (String.sub sub_buffer 0 r);;

(**
Read a .deb file
@param filename File name
@return package metadata
*)
let read_deb_file (filename: string): package_with_files =
let ar_channel = Pirate.open_ar_file filename in
begin
	ignore (Pirate.ar_seek_to_file ar_channel "control.tar.gz");
	let gz_channel = Gzip.open_in_chan ar_channel in
	let sums_size = Pirate.tar_seek_to_file gz_channel Gzip.input Gzip.input_char "./md5sums" in
	let sums = read_deb_md5sums gz_channel Gzip.input_char sums_size in
	ignore (Pirate.tar_seek_to_file gz_channel Gzip.input Gzip.input_char "./control");
	{ (napkin_of_fields (read_deb_fields (gzip_input gz_channel))) with pk_extra = sums }
end;;

(**
Read a pool (cache) file
@param filename File name
@return a list package metadata
*)
let read_pool_file (filename: string) (progress: Progress.indicator): default_package list =
let ch = ref (open_in filename) in
let close_channel = ref (fun () -> ()) in
let input_buf = ref (fun () -> "") in
let packages = ref [] in
(*let icl = ref (in_channel_length !ch) in*)
begin
	let first_package = try
		let c = Bz2.open_in !ch in
		input_buf := (bz2_input c);
		close_channel := (fun () -> Bz2.close_in c);
		napkin_of_fields (read_deb_fields !input_buf)
	with Bz2.Data_error | Bz2.Unexpected_EOF ->
	try
		close_in !ch;
		ch := open_in filename;
		(*icl := in_channel_length !ch;*)
		let c = Gzip.open_in_chan !ch in
		input_buf := (gzip_input c);
		close_channel := (fun () -> Gzip.close_in c);
		napkin_of_fields (read_deb_fields !input_buf)
	with Gzip.Error _ ->
		close_in !ch;
		ch := open_in filename;
		(*icl := in_channel_length !ch;*)
		input_buf := (normal_input !ch);
		close_channel := (fun () -> ());
		napkin_of_fields (read_deb_fields !input_buf) in
	packages := [first_package];
	try
		while true
		do
			(*progress#display (pos_in !ch, !icl);*)
			let fields = read_deb_fields !input_buf in
			if Hashtbl.length fields = 0 then raise End_of_file;
			packages := (napkin_of_fields fields)::!packages
		done;
		!packages
	with End_of_file ->
	begin
		!close_channel ();
		close_in !ch;
		!packages
	end
end;;
