(**************************************************************************)
(*  Copyright © 2009-2013 Stéphane Glondu <steph@glondu.net>              *)
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  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     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

open Printf
open Types

type source
type binary
type 'a t = Stanza.t

module Name = struct
  type 'a t = string

  let of_string x = x
  let to_string x = x
end

let filter_print keep outc p =
  let filter =
    if keep = [] then fun _ -> true
    else
      let keep = List.rev_map String.lowercase_ascii keep in
      fun x -> List.mem (String.lowercase_ascii x) keep
  in
  Stanza.pp outc (Stanza.filter filter p)

let print = filter_print []
let empty = Stanza.empty
let get = Stanza.find
let has = Stanza.mem
let add = Stanza.add

module Set = struct
  module S = Set.Make (String)

  type 'a t = S.t

  let is_empty = S.is_empty
  let empty = S.empty
  let add = S.add
  let remove = S.remove
  let mem = S.mem
  let from_list = List.fold_left (fun set elt -> add elt set) empty
  let exists = S.exists
  let iter = S.iter
  let cardinal = S.cardinal
  let elements = S.elements
  let fold = S.fold
  let filter = S.filter
  let for_all = S.for_all
end

type _ kind = Source : source kind | Binary : binary kind

let rex = Re.Pcre.regexp "^(\\S+)(?: \\((\\S+)\\))?$"

let of_stanza (type a) (kind : a kind) x : a t =
  match kind with
  | Binary ->
      let source, version =
        try
          let name = get "source" x in
          let r = Re.Pcre.exec ~rex name in
          let name = Re.Pcre.get_substring r 1 in
          let version =
            try Re.Pcre.get_substring r 2 with Not_found -> get "version" x
          in
          (name, version)
        with Not_found -> (get "package" x, get "version" x)
      in
      Stanza.add "Source-Version" version
        (Stanza.add "Source" source (Stanza.remove "Source" x))
  | Source -> x

module Map = struct
  module M = Map.Make (String)

  type ('a, 'b) t = 'b M.t

  let empty = M.empty
  let is_empty = M.is_empty
  let add = M.add
  let remove = M.remove
  let iter = M.iter
  let find = M.find
  let find_opt = M.find_opt
  let mapi = M.mapi
  let fold = M.fold
  let bindings = M.bindings
  let mem = M.mem

  let update_default default f key t =
    let previous = try find key t with Not_found -> default in
    add key (f previous) t
end

let eval_conjunction xs = List.for_all (String.starts_with ~prefix:"!") xs
let eval_disjunction xs = List.exists eval_conjunction xs

let get_and_split =
  let open Re.Pcre in
  let rex_split_pkg = regexp ",\\s*" in
  let rex_split_alt = regexp "\\s*\\|\\s*" in
  let rex_match_pkg = regexp "^([^ :]+)(?::\\S+)?(?:\\s+(.*))?$" in
  let rex_match_profile = regexp "<([^>]+)>" in
  let rex_split_spaces = regexp "\\s+" in
  fun field x ->
    try
      get field x |> split ~rex:rex_split_pkg
      |> List.map (fun x ->
          match split ~rex:rex_split_alt x with x :: _ -> x | _ -> x)
      |> List.filter_map (fun x ->
          match exec ~rex:rex_match_pkg x with
          | exception Not_found -> None
          | g ->
              Some
                (get_substring g 1, try get_substring g 2 with Not_found -> ""))
      |> List.filter_map (fun (pkg, extra) ->
          if
            Re.all rex_match_profile extra
            |> List.map (fun g ->
                Re.Group.get g 1 |> split ~rex:rex_split_spaces)
            |> fun xs ->
            if xs = [] then true
            else
              (* we evaluate the build profile restriction formula with no profiles *)
              eval_disjunction xs
          then Some pkg
          else None)
    with Not_found -> []

let build_depends ?(ignore_indep = false) x =
  (if ignore_indep then [] else get_and_split "build-depends-indep" x)
  @ get_and_split "build-depends" x
  @ get_and_split "build-depends-arch" x

let binaries x = get_and_split "binary" x
let provides x = get_and_split "provides" x

type dependency = {
  dep_name : string;
  dep_version : (comparison * string) option;
}

let split_name_and_version =
  let rex =
    Re.Pcre.regexp
      "^\\s*(\\S+)\\s*(\\(([<>=]+)\\s*([^)]+)\\))?\\s*(\\[\\s*([^\\]]+)\\s*\\])?\\s*$"
  in
  fun x ->
    try
      let r = Re.Pcre.exec ~rex x in
      let dep =
        try
          let cmp =
            match Re.Pcre.get_substring r 3 with
            | "<=" -> Le
            | "<<" -> Lt
            | ">=" -> Ge
            | ">>" -> Gt
            | "=" -> Eq
            | "<" -> Lt
            | ">" -> Gt
            | x -> ksprintf failwith "invalid comparison operator: %s" x
          in
          Some (cmp, Re.Pcre.get_substring r 4)
        with Not_found -> None
      in
      { dep_name = Re.Pcre.get_substring r 1; dep_version = dep }
    with Not_found -> ksprintf failwith "unable to parse: %s" x

let dependencies =
  let rex = Re.Pcre.regexp "(?:\\s*[,|]\\s*)+" in
  fun field x ->
    try
      let deps = get field x in
      let deps = Re.Pcre.split ~rex deps in
      List.map split_name_and_version deps
    with Not_found -> []
