sync.ml

type 'a fmt = Format.formatter -> 'a -> unit
type 'a io = 'a

(* Git types. *)

type store = unit
type hash = string
type reference = string
type host = string
type path = string list

module Reference = struct type t = reference

                          let compare = String.compare end

module Headers = Map.Make (String)
module M = Map.Make (Reference)

module type E = sig
  type t

  val make : Uri.t -> t
  val host : t -> host
  val path : t -> path
end

type master_error = ..

module type S = sig
  type error

  module Endpoint : E

  val pp_error : error fmt
  val prj_error : error -> master_error
  val fetch : store -> Endpoint.t -> (hash M.t, error) result io
  val push : store -> Endpoint.t -> hash M.t -> (hash M.t, error) result io
  val ls : store -> Endpoint.t -> (hash M.t, error) result io
end

module TEdn = struct type _ t = .. end

module type TEdn = sig
  type t
  type _ TEdn.t += TEdn : t TEdn.t
end

type 'a tedn = (module TEdn with type t = 'a)

let tedn : type edn. (module E with type t = edn) -> edn tedn =
 fun (module Edn) ->
  let module X = struct type t = Edn.t
                        type _ TEdn.t += TEdn : t TEdn.t end in
  (module X : TEdn with type t = Edn.t)

module Refl = struct
  type ('a, 'b) t = Refl : ('a, 'a) t

  let equal : type a b. a tedn -> b tedn -> (a, b) t option =
   fun a b ->
    let module A = (val a : TEdn with type t = a) in
    let module B = (val b : TEdn with type t = b) in
    match A.TEdn with B.TEdn -> Some Refl | _ -> None
end

module type INFO = sig
  type 'a t
end

module Scheme = struct
  type _ t = {scheme: string}

  let make scheme = {scheme}
  let equal a b = String.equal a.scheme b.scheme
end

module Make (KInfo : INFO) = struct
  module Key = struct
    type 'a info = 'a KInfo.t
    type 'a key = {uid: int; tedn: 'a tedn; info: 'a KInfo.t}

    let uid : type edn. edn tedn -> int =
     fun (module Edn) -> Obj.(extension_id (extension_constructor Edn.TEdn))

    let make : type edn. (module E with type t = edn) -> edn info -> edn key =
     fun (module Edn) info ->
      let tedn = tedn (module Edn) in
      let uid = uid tedn in
      {uid; tedn; info}

    let info k = k.info

    type t = V : 'edn key -> t

    let pack k = V k
    let equal (V k0) (V k1) = (compare : int -> int -> int) k0.uid k1.uid = 0
    let compare (V k0) (V k1) = (compare : int -> int -> int) k0.uid k1.uid
  end

  type 'edn key = 'edn Key.key

  module M = Map.Make (Key)

  type binding =
    | B : 'edn key * (module S with type Endpoint.t = 'edn) -> binding

  type t = binding M.t

  let empty = M.empty
  let is_empty = M.is_empty
  let mem k m = M.mem (Key.V k) m
  let add k v m = M.add (Key.V k) (B (k, v)) m
  let singleton k v = M.singleton (Key.V k) (B (k, v))
  let rem k m = M.remove (Key.V k) m

  let find : type edn.
      edn key -> t -> (module S with type Endpoint.t = edn) option =
   fun k s ->
    match M.find (Key.V k) s with
    | B (k', v) -> (
      match Refl.equal k.Key.tedn k'.Key.tedn with
      | Some Refl.Refl -> Some v
      | None -> None )
    | exception Not_found -> None

  let get k s = match find k s with Some v -> v | None -> raise Not_found
  let iter f m = M.iter (fun _ b -> f b) m
  let fold f m acc = M.fold (fun _ b acc -> f b acc) m acc
  let for_all p m = M.for_all (fun _ b -> p b) m
  let exists p m = M.exists (fun _ b -> p b) m
  let filter p m = M.filter (fun _ b -> p b) m
  let cardinal m = M.cardinal m
  let choose_exn m = snd (M.choose m)
  let choose m = try Some (snd (M.choose m)) with Not_found -> None
end

module Map = Make (Scheme)

module Gri : E with type t = Uri.t = struct
  type t = Uri.t

  let host _ = assert false
  let path _ = assert false

  let make uri =
    match Uri.scheme uri, Uri.host uri with
    | Some "git", Some _ -> uri
    | Some scheme, Some _ ->
        Fmt.invalid_arg "Invalid GRI: bad scheme (%s)" scheme
    | Some _, None -> Fmt.invalid_arg "Invalid GRI: no host"
    | None, _ -> Fmt.invalid_arg "Invalid GRI: no scheme"
end

let gri = Map.Key.(make (module Gri) Scheme.{scheme= "git"})

type http_endpoint = {uri: Uri.t; headers: string list Headers.t}

module Http : E with type t = http_endpoint = struct
  type t = http_endpoint

  let host _ = assert false
  let path _ = assert false

  let make uri =
    let headers = Headers.empty in
    match Uri.scheme uri, Uri.host uri with
    | Some "http", Some _ -> {uri; headers}
    | Some scheme, Some _ ->
        Fmt.invalid_arg "Invalid HTTP URI: bad scheme (%s)" scheme
    | Some _, None -> Fmt.invalid_arg "Invalid HTTP URI: no host"
    | None, _ -> Fmt.invalid_arg "Invalid HTTP URI: no scheme"
end

let http = Map.Key.(make (module Http) Scheme.{scheme= "http"})

module Ssh : E with type t = Uri.t = struct
  type t = Uri.t

  let host _ = assert false
  let path _ = assert false

  let make uri =
    match Uri.scheme uri, Uri.host uri with
    | Some "git+ssh", Some _ -> uri
    | Some scheme, Some _ ->
        Fmt.invalid_arg "Invalid GRI: bad scheme (%s)" scheme
    | Some _, None -> Fmt.invalid_arg "Invalid GRI: no host"
    | None, _ -> Fmt.invalid_arg "Invalid GRI: no scheme"
end

let ssh = Map.Key.(make (module Ssh) Scheme.{scheme= "git+ssh"})

module SyncTCP : S with type Endpoint.t = Gri.t = struct
  type store = unit
  type +'a io = 'a
  type error = unit
  type master_error += Tcp of error

  module Endpoint = Gri

  let pp_error ppf () = ()
  let prj_error err = Tcp err

  let fetch store edn =
    Fmt.pr "> Send TCP request.\n%!" ;
    Ok M.empty

  let push store edn m = Ok M.empty
  let ls store edn = Ok M.empty
end

module SyncHTTP : S with type Endpoint.t = Http.t = struct
  type store = unit
  type +'a io = 'a
  type error = unit
  type master_error += Http of error

  module Endpoint = Http

  let pp_error ppf () = ()
  let prj_error err = Http err

  let fetch store (edn : Http.t) =
    Fmt.pr "> Send HTTP request (headers: @[%a@]).\n%!"
      Fmt.(Dump.list (Dump.pair string (Dump.list string)))
      (Headers.bindings edn.headers) ;
    Ok M.empty

  let push store edn m = Ok M.empty
  let ls store edn = Ok M.empty
end

module SyncSSH : S with type Endpoint.t = Ssh.t = struct
  type store = unit
  type +'a io = 'a
  type error = unit
  type master_error += Ssh of error

  module Endpoint = Ssh

  let pp_error ppf () = ()
  let prj_error err = Ssh err

  let fetch store edn =
    Fmt.pr "> Send SSH request.\n%!" ;
    Ok M.empty

  let push store edn m = Ok M.empty
  let ls store edn = Ok M.empty
end

module Dispatch = struct
  let global = ref Map.empty

  let register : type edn.
      edn Map.key -> (module S with type Endpoint.t = edn) -> unit =
   fun key (module Sync) -> global := Map.(add key (module Sync) !global)

  let of_endpoint : type edn.
      edn Map.key -> (module S with type Endpoint.t = edn) =
   fun key -> Map.(get key !global)

  let endpoint uri =
    let subset =
      Map.filter
        (fun (Map.B (k, sync)) ->
          match Uri.scheme uri with
          | Some scheme' -> Scheme.equal (Map.Key.info k) (Scheme.make scheme')
          | None -> false )
        !global
    in
    match Map.cardinal subset with
    | 0 -> Fmt.invalid_arg "Cannot handle %s" (Uri.to_string uri)
    | 1 ->
        let (Map.B (k, sync)) = Map.choose_exn subset in
        Map.Key.V k
    | n ->
        Fmt.invalid_arg "Too many possibilities to handle %s"
          (Uri.to_string uri)
end

let () = Dispatch.register gri (module SyncTCP)
let () = Dispatch.register http (module SyncHTTP)
let () = Dispatch.register ssh (module SyncSSH)
let reword_error f = function Ok _ as x -> x | Error err -> Error (f err)

let headers_of_list l =
  List.fold_left (fun m (k, v) -> Headers.add k v m) Headers.empty l

let fetch ?headers uri store =
  let (Map.Key.V endpoint) = Dispatch.endpoint uri in
  match Refl.equal endpoint.Map.Key.tedn http.Map.Key.tedn with
  | Some Refl.Refl ->
      let headers : string list Headers.t =
        match headers with Some headers -> headers | None -> Headers.empty
      in
      let module Sync = (val Dispatch.of_endpoint endpoint) in
      reword_error Sync.prj_error
        (Sync.fetch store Sync.Endpoint.{(make uri) with headers})
  | None ->
      let module Sync = (val Dispatch.of_endpoint endpoint) in
      reword_error Sync.prj_error (Sync.fetch store (Sync.Endpoint.make uri))

let _ = fetch (Uri.of_string "git://github.com:mirage/decompress.git") ()
let _ = fetch (Uri.of_string "git+ssh://github.com:mirage/decompress.git") ()

let _ =
  fetch
    ~headers:(headers_of_list ["Content-Type", ["charset=utf-8"]])
    (Uri.of_string "http://github.com/mirage/decompress.git")
    ()