(**************************************************************************)
(*  ocplib-resto                                                          *)
(*  Copyright (C) 2016, OCamlPro.                                         *)
(*                                                                        *)
(*    All rights reserved.  This file is distributed under the terms      *)
(*    of the GNU Lesser General Public License version 2.1, with the      *)
(*    special exception on linking described in the file LICENSE.         *)
(*                                                                        *)
(**************************************************************************)

open Resto

let map_option f = function
  | None -> None
  | Some x -> Some (f x)

let (>>=) = Lwt.bind
let (>|=) = Lwt.(>|=)

module Answer = struct

  (** Return type for service handler *)
  type ('o, 'e) t =
    [ `Ok of 'o (* 200 *)
    | `OkStream of 'o stream (* 200 *)
    | `Created of string option (* 201 *)
    | `No_content (* 204 *)
    | `Unauthorized of 'e option (* 401 *)
    | `Forbidden of 'e option (* 403 *)
    | `Not_found of 'e option (* 404 *)
    | `Conflict of 'e option (* 409 *)
    | `Error of 'e option (* 500 *)
    ]

  and 'a stream = {
    next: unit -> 'a option Lwt.t ;
    shutdown: unit -> unit ;
  }

  let return x = Lwt.return (`Ok x)
  let return_stream x = Lwt.return (`OkStream x)

end

module Make (Encoding : ENCODING) = struct

  module Service = Resto.MakeService(Encoding)

  module Curry = struct

    type (_,_,_,_,_,_) conv =
      | Z : (unit, 'g, 'g, unit, 'f, 'f) conv
      | S : ('t, 'g, 'b * 's, 'rt, 'f, 'r) conv ->
        ('t * 'b, 'g, 's, 'a * 'rt, 'a -> 'f, 'r) conv
    let reverse
      : type a c d e f. (a, c, unit, d, e, f) conv -> a -> c
      = fun c v ->
        let rec reverse
          : type a c d e f g. (a, c, d, e, f, g) conv -> a -> d -> c
          = fun c v acc ->
            match c, v with
            | Z, _ -> acc
            | S c, (v, x) -> reverse c v (x, acc) in
        reverse c v ()
    let rec curry
      : type a b c d e f. (a, b, c, d, e, f) conv -> e -> d -> f
      = fun c f ->
        match c with
        | Z -> fun () -> f
        | S c -> (fun (v, x) -> curry c (f v) x)
    let curry c f =
      let f = curry c f in
      fun x -> f (reverse c x)

  end

  type step =
    | Static of string
    | Dynamic of Arg.descr
    | DynamicTail of Arg.descr

  type conflict =
    | CService of meth
    | CDir
    | CBuilder
    | CTail
    | CTypes of Arg.descr * Arg.descr
    | CType of Arg.descr * string list

  exception Conflict of step list * conflict

  open Resto.Internal

  type lookup_error =
    [ `Not_found (* 404 *)
    | `Method_not_allowed of meth list (* 405 *)
    | `Cannot_parse_path of string list * Arg.descr * string (* 400 *)
    ]

  type ('query, 'input, 'output, 'error) types
    = ('query, 'input, 'output, 'error) Service.Internal.types
    = {
      query : 'query Resto.Query.t ;
      input : 'input Service.input ;
      output : 'output Encoding.t ;
      error : 'error Encoding.t ;
    }

  type 'key t =
    | Empty : 'key t
    | Static : 'key static_directory -> 'key t
    | Dynamic : string option * ('key -> 'key directory Lwt.t) -> 'key t
    | DynamicTail : 'a arg * ('key * 'a list) t -> 'key t

  and 'key directory = 'key t
  and 'key static_directory = {
    services : 'key registered_service_builder MethMap.t ;
    subdirs : 'key static_subdirectories option
  }

  and _ static_subdirectories =
    | Suffixes: 'key directory StringMap.t -> 'key static_subdirectories
    | Arg: 'a Resto.Internal.arg * ('key * 'a) directory -> 'key static_subdirectories

  and registered_service =
    | Service :
        { types : ('q, 'i, 'o, 'e) types ;
          handler : ('q -> 'i -> ('o, 'e) Answer.t Lwt.t) ;
        } -> registered_service

  and 'key registered_service_builder = {
    meth : Resto.meth ;
    description : Encoding.schema Description.service ;
    builder : 'key -> registered_service Lwt.t ;
  }

  let empty = Empty

  let rec map_directory
    : type a b.
      (a -> b Lwt.t) -> b directory -> a directory
    = fun f t ->
      match t with
      | Empty -> Empty
      | Dynamic (descr, builder) ->
          let builder a = f a >>= builder >|= map_directory f in
          Dynamic (descr, builder)
      | DynamicTail (arg, dir) ->
          DynamicTail (arg, map_directory (fun (x, l) -> f x >|= fun x -> (x, l)) dir)
      | Static dir ->
          Static (map_static_directory f dir)

  and map_static_directory
    : type a b.
      (a -> b Lwt.t) -> b static_directory -> a static_directory
    = fun f t ->
      { services = MethMap.map (map_registered_service f) t.services ;
        subdirs = map_option (map_static_subdirectories f) t.subdirs ;
      }

  and map_static_subdirectories
    : type a b.
      (a -> b Lwt.t) -> b static_subdirectories -> a static_subdirectories
    = fun f t ->
      match t with
      | Suffixes map ->
          Suffixes (StringMap.map (map_directory f) map)
      | Arg (arg, dir) ->
          let dir = map_directory (fun (a, x) -> f a >|= fun a -> (a, x)) dir in
          Arg (arg, dir)

  and map_registered_service
    : type a b.
      (a -> b Lwt.t) -> b registered_service_builder -> a registered_service_builder
    = fun f rs ->
      { rs with builder = (fun p -> f p >>= fun p -> rs.builder p) }

  let map = map_directory

  let prefix
    : type p pr. (pr, p) Path.path -> p directory -> pr directory
    = fun path dir ->
      let rec prefix
        : type k pr. (pr, k) Resto.Internal.path -> k directory -> pr directory
        = fun path dir ->
          match path with
          | Root -> dir
          | Static (path, name) ->
              let subdirs = Suffixes (StringMap.singleton name dir) in
              prefix path (Static { subdirs = Some subdirs ;
                                    services = MethMap.empty })
          | Dynamic (path, arg) ->
              let subdirs = Arg (arg, dir) in
              prefix path (Static { subdirs = Some subdirs ;
                                    services = MethMap.empty })
          | DynamicTail _ ->
              invalid_arg "RestoDirectory.prefix" in
      prefix (Resto.Internal.to_path path) dir

  let conflict steps kind = raise (Conflict (steps, kind))

  let rec merge
    : type p.
      step list -> p directory -> p directory -> p directory
    = fun path t1 t2 ->
      match t1, t2 with
      | Empty, t -> t
      | t, Empty -> t
      | Static n1, Static n2 ->
          Static (merge_static_directory path n1 n2)
      | Dynamic _, _
      | _, Dynamic _ -> conflict path CBuilder
      | DynamicTail _, _
      | _, DynamicTail _ -> conflict path CTail

  and merge_static_directory
    : type p.
      step list -> p static_directory -> p static_directory -> p static_directory
    = fun path t1 t2 ->
      let subdirs =
        match t1.subdirs, t2.subdirs with
        | None, None -> None
        | None, Some dir | Some dir, None -> Some dir
        | Some d1, Some d2 ->
            match d1, d2 with
            | Suffixes m1, Suffixes m2 ->
                let merge =
                  StringMap.fold
                    (fun n t m ->
                       let st =
                         try StringMap.find n m with Not_found -> empty in
                       StringMap.add n (merge (Static n :: path) st t) m) in
                Some (Suffixes (merge m1 m2))
            | Arg (arg1, subt1), Arg (arg2, subt2) ->
                begin
                  try let Eq = Ty.eq arg1.id arg2.id in
                    let subt = merge (Dynamic arg1.descr :: path) subt1 subt2 in
                    Some (Arg (arg1, subt))
                  with Ty.Not_equal ->
                    conflict path (CTypes (arg1.descr, arg2.descr))
                end
            | Arg (arg, _), Suffixes m ->
                conflict path
                  (CType (arg.descr, List.map fst (StringMap.bindings m)))
            | Suffixes m, Arg (arg, _) ->
                conflict path
                  (CType (arg.descr, List.map fst (StringMap.bindings m))) in
      let services =
        MethMap.fold
          begin fun meth s map ->
            if MethMap.mem meth map then
              conflict path (CService meth)
            else
              MethMap.add meth s map
          end
          t1.services t2.services in
      { subdirs ; services }

  let merge x y = merge [] x y

  let rec describe_directory
    : type a. recurse:bool -> ?arg:a ->
    a directory -> Encoding.schema Description.directory Lwt.t
    = fun ~recurse ?arg dir ->
      match dir with
      | Empty -> Lwt.return Description.Empty
      | Dynamic (descr, builder) -> begin
          match arg with
          | None ->
              Lwt.return (Dynamic descr : Encoding.schema Description.directory)
          | Some arg ->
              builder arg >>= fun dir -> describe_directory ~recurse dir
        end
      | DynamicTail ( _, dir) -> describe_directory ~recurse dir
      | Static dir ->
          describe_static_directory recurse arg dir >>= fun dir ->
          Lwt.return (Static dir : Encoding.schema Description.directory)

  and describe_static_directory
    : type a.
      bool -> a option -> a static_directory ->
      Encoding.schema Description.static_directory Lwt.t
    = fun recurse arg dir ->
      let services = MethMap.map describe_service dir.services in
      begin
        if recurse then
          match dir.subdirs with
          | None -> Lwt.return_none
          | Some subdirs ->
              describe_static_subdirectories arg subdirs >>= fun dirs ->
              Lwt.return (Some dirs)
        else
          Lwt.return_none
      end >>= fun subdirs ->
      Lwt.return ({ services ; subdirs } : Encoding.schema Description.static_directory)

  and describe_static_subdirectories
    : type a.
      a option -> a static_subdirectories ->
      Encoding.schema Description.static_subdirectories Lwt.t
    = fun arg dir ->
      match dir with
      | Suffixes map ->
          StringMap.fold (fun key dir map ->
              map >>= fun map ->
              describe_directory ~recurse:true ?arg dir >>= fun dir ->
              Lwt.return (StringMap.add key dir map))
            map (Lwt.return StringMap.empty) >>= fun map ->
          Lwt.return (Suffixes map : Encoding.schema Description.static_subdirectories)
      | Arg (arg, dir) ->
          describe_directory ~recurse:true dir >>= fun dir ->
          Lwt.return (Arg (arg.descr, dir)
                      : Encoding.schema Description.static_subdirectories)

  and describe_service
    : type a.
      a registered_service_builder -> Encoding.schema Description.service
    = fun { description ; _ } -> description

  and describe_query
    : type a.
      a Resto.Internal.query -> Description.query_item list
    = fun (Fields (fields, _)) ->
      let rec loop : type a b. (a, b) query_fields -> _ = function
        | F0 -> []
        | F1 (f, fs) ->
            { Description.name = field_name f ;
              description = field_description f ;
              kind = field_kind f } :: loop fs in
      loop fields


  (****************************************************************************
   * Lookup
   ****************************************************************************)

  type resolved_directory =
      Dir: 'a static_directory * 'a -> resolved_directory

  let rec resolve
    : type a.
      string list -> a directory -> a -> string list ->
      (resolved_directory, _) result Lwt.t
    = fun prefix dir args path ->
      match path, dir with
      | _, Empty -> Lwt.return_error `Not_found
      | path, Dynamic (_, builder) ->
          builder args >>= fun dir -> resolve prefix dir args path
      | path, DynamicTail (arg, dir) -> begin
          match
            List.fold_right
              (fun e acc ->
                 match acc with
                 | Error _ as err -> err
                 | Ok (prefix, path) ->
                     match arg.destruct e with
                     | Ok s -> Ok (e :: prefix, s :: path)
                     | Error msg ->
                         Error (`Cannot_parse_path (List.rev (e :: prefix), arg.descr, msg)))

              path (Ok (prefix, []))
          with
          | Ok (prefix, path) -> resolve prefix dir (args, path) []
          | Error _ as err -> Lwt.return err
        end
      | [], Static sdir -> Lwt.return_ok (Dir (sdir, args))
      | _name :: _path, Static { subdirs = None ; _ } ->
          Lwt.return_error `Not_found
      | name :: path,
        Static { subdirs = Some (Suffixes static) ; _ } -> begin
          match StringMap.find name static with
          | exception Not_found -> Lwt.return_error `Not_found
          | dir -> resolve (name :: prefix) dir args path
        end
      | name :: path, Static { subdirs = Some (Arg (arg, dir)) ; _ } ->
          match arg.destruct name with
          | Ok x -> resolve (name :: prefix) dir (args, x) path
          | Error msg ->
              Lwt.return_error @@
              `Cannot_parse_path (List.rev (name :: prefix), arg.descr, msg)

  let lookup
    : type a.
      a directory -> a -> meth -> string list ->
      (registered_service, lookup_error) result Lwt.t
    = fun dir args meth path ->
      resolve [] dir args path >>= function
      | Error _ as err -> Lwt.return err
      | Ok (Dir (dir, args)) -> begin
          match MethMap.find meth dir.services with
          | exception Not_found -> begin
              match MethMap.bindings dir.services with
              | [] -> Lwt.return_error `Not_found
              | l -> Lwt.return_error (`Method_not_allowed (List.map fst l))
            end
          | rs -> rs.builder args >>= Lwt.return_ok
        end

  let lookup =
    (lookup
     : _ -> _ -> _ -> _ -> (_, lookup_error) result Lwt.t
     :> _ -> _ -> _ -> _ -> (_, [> lookup_error ]) result Lwt.t )

  let allowed_methods
    : type a.
      a directory -> a -> string list ->
      (Resto.meth list, lookup_error) result Lwt.t
    = fun dir args path ->
      resolve [] dir args path >>= function
      | Error err -> Lwt.return_error err
      | Ok (Dir (dir, _)) -> begin
          match MethMap.bindings dir.services with
          | [] -> Lwt.return_error `Not_found
          | l -> Lwt.return_ok (List.map fst l)
        end

  let allowed_methods =
    (allowed_methods
     : _ -> _ -> _ -> (_, lookup_error) result Lwt.t
     :> _ -> _ -> _ -> (_, [> lookup_error]) result Lwt.t)


  let rec build_dynamic_dir : type p. p directory -> p -> p directory Lwt.t =
    fun dir args ->
      match dir with
      | Dynamic (_, builder) ->
          builder args >>= fun dir -> build_dynamic_dir dir args
      | _ -> Lwt.return dir

  let rec transparent_resolve
    : type pr p.
      pr directory -> (pr, p) path -> p -> p directory option Lwt.t
    = fun dir path rargs ->
      match path with
      | Root -> Lwt.return_some dir
      | Static (path, name) -> begin
          transparent_resolve dir path rargs >>= function
          | None -> Lwt.return_none
          | Some dir ->
              build_dynamic_dir dir rargs >>= function
              | Dynamic (_,_) -> assert false (* should not happen. *)
              | Static { subdirs = Some (Suffixes s) ; _ } ->
                  Lwt.return_some (StringMap.find name s)
              | Empty -> Lwt.return_none
              | Static _ -> Lwt.return_none
              | DynamicTail _ -> Lwt.return_none
        end
      | Dynamic (ipath, iarg) -> begin
          transparent_resolve dir ipath (fst rargs) >>= function
          | None -> Lwt.return_none
          | Some dir ->
              build_dynamic_dir dir (fst rargs) >>= function
              | Dynamic (_, _) -> assert false (* should not happen. *)
              | Static { subdirs = Some (Arg (arg, dir)) ; _ } -> begin
                  match Ty.eq iarg.id arg.id with
                  | exception Ty.Not_equal ->
                      Lwt.return_none
                  | Eq ->
                      Lwt.return_some (dir : (_ * _) directory :> p directory)
                end
              | Empty -> Lwt.return_none
              | Static _ -> Lwt.return_none
              | DynamicTail _ -> Lwt.return_none
        end
      | DynamicTail (path, arg) -> begin
          transparent_resolve dir path (fst rargs) >>= function
          | None -> Lwt.return_none
          | Some dir ->
              build_dynamic_dir dir (fst rargs) >>= function
              | Dynamic (_,_) -> assert false (* should not happen. *)
              | DynamicTail (iarg, dir) -> begin
                  match Ty.eq iarg.id arg.id with
                  | exception Ty.Not_equal ->
                      Lwt.return_none
                  | Eq ->
                      Lwt.return_some (dir : (_ * _) directory :> p directory)
                end
              | Empty -> Lwt.return_none
              | Static _ -> Lwt.return_none
        end

  let transparent_lookup :
    type prefix params query input output error.
    prefix directory ->
    (_, prefix, params, query, input, output, error) Service.t ->
    params -> query -> input -> (output, error) Answer.t Lwt.t =
    fun dir service params query body ->
      let service = Service.Internal.to_service service in
      transparent_resolve dir service.path params >>= function
      | None -> Lwt.return (`Not_found None)
      | Some (Static { services ; _ }) -> begin
          try
            (MethMap.find service.meth services).builder
              params >>= fun (Service { handler ; types }) ->
            match Service.Internal.eq types service.types with
            | exception Service.Internal.Not_equal ->
                Lwt.return (`Not_found None)
            | Service.Internal.Eq ->
                (handler query body
                 : (_, _) Answer.t Lwt.t :> (output, error) Answer.t Lwt.t)
          with Not_found -> Lwt.return (`Not_found None)
        end
      | Some _ -> Lwt.return (`Not_found None)

  let transparent_lookup =
    ( transparent_lookup
      : _ -> (Resto.meth, _, _, _, _, _, _) Service.t ->
      _ -> _ -> _ -> (_, _) Answer.t Lwt.t
      :> _ -> ([< Resto.meth ], _, _, _, _, _, _) Service.t ->
      _ -> _ -> _ -> [> (_, _) Answer.t ] Lwt.t)

  let rec describe_rpath
    : type a b. Description.path_item list ->
      (a, b) path -> Description.path_item list
    = fun acc path ->
      match path with
      | Root -> acc
      | Static (rpath, name) ->
          describe_rpath (PStatic name :: acc) rpath
      | Dynamic (rpath, arg) ->
          describe_rpath (PDynamic arg.descr :: acc) rpath
      | DynamicTail (rpath, arg) ->
          describe_rpath (PDynamicTail arg.descr :: acc) rpath

  (****************************************************************************
   * Registration
   ****************************************************************************)

  let rec step_of_path
    : type p rk. (rk, p) path -> step list -> step list
    = fun path acc ->
      match path with
      | Root -> acc
      | Static (path, name) -> step_of_path path (Static name :: acc)
      | Dynamic (path, arg) -> step_of_path path (Dynamic arg.descr :: acc)
      | DynamicTail (path, arg) -> step_of_path path (DynamicTail arg.descr :: acc)
  let step_of_path p = step_of_path p []

  let conflict path kind = raise (Conflict (step_of_path path, kind))

  let rec insert
    : type k rk.
      (rk, k) path -> rk directory -> k directory * (k directory -> rk directory)
    = fun path dir ->
      match path with
      | Root -> dir, (fun x -> x)
      | Static (subpath, name) -> begin
          let subdir, rebuild = insert subpath dir in
          let dirmap, services =
            match subdir with
            | Empty ->
                StringMap.empty, MethMap.empty
            | Static { subdirs = None ; services } ->
                StringMap.empty, services
            | Static { subdirs = Some (Suffixes m) ;
                       services } ->
                m, services
            | Static { subdirs = Some (Arg (arg, _)) ; _ } ->
                conflict path (CType (arg.descr, [name]))
            | Dynamic _ -> conflict path CBuilder
            | DynamicTail _ -> conflict path CTail in
          let dir =
            try StringMap.find name dirmap with Not_found -> empty in
          let rebuild s =
            let subdirs =
              Some (Suffixes (StringMap.add name s dirmap)) in
            rebuild (Static { subdirs ; services }) in
          dir, rebuild
        end
      | Dynamic (subpath, arg) -> begin
          let subdir, rebuild = insert subpath dir in
          let dir, services =
            match subdir with
            | Empty ->
                Empty, MethMap.empty
            | Static { subdirs = None ; services } ->
                Empty, services
            | Static { subdirs = Some (Arg (arg', dir)) ;
                       services } -> begin
                try
                  let Eq = Ty.eq arg.id arg'.id in
                  (dir :> k directory), services
                with Ty.Not_equal ->
                  conflict path (CTypes (arg.descr, arg'.descr))
              end
            | Static { subdirs = Some (Suffixes m) ; _ } ->
                conflict path
                  (CType (arg.descr, List.map fst (StringMap.bindings m)))
            | Dynamic _ -> conflict path CBuilder
            | DynamicTail _ -> conflict path CTail
          in
          let rebuild s =
            let subdirs = Some (Arg (arg, s)) in
            rebuild (Static { subdirs ; services }) in
          dir, rebuild
        end
      | DynamicTail (subpath, arg) -> begin
          let subdir, rebuild = insert subpath dir in
          match subdir with
          | Empty ->
              let rebuild s = rebuild (DynamicTail (arg, s)) in
              empty, rebuild
          | Static { subdirs = None ; services } ->
              conflict path (CService (fst (MethMap.min_binding services)))
          | Static { subdirs = Some (Arg (arg, _)) ; _ } ->
              conflict path (CType (arg.descr, []))
          | Static { subdirs = Some (Suffixes m) ; _ } ->
              conflict path
                (CType (arg.descr, List.map fst (StringMap.bindings m)))
          | Dynamic _ -> conflict path CBuilder
          | DynamicTail _ -> conflict path CTail
        end

  let register
    : type p q i o e pr.
      pr directory -> (_, pr, p, q, i, o, e) Service.t ->
      (p -> q -> i -> (o, e) Answer.t Lwt.t) -> pr directory =
    fun root s handler ->
      let s = Service.Internal.to_service s in
      let register
        : type k. (pr, k) path -> (k -> q -> i -> (o, e) Answer.t Lwt.t) ->
          pr directory =
        fun path handler ->
          let dir, insert = insert path root in
          let rs =
            let description : _ Description.service = {
              meth = s.meth ;
              path = describe_rpath [] path ;
              description = s.description ;
              query = describe_query (Resto.Internal.to_query s.types.query) ;
              input = begin
                match s.types.input with
                | Service.No_input -> None
                | Service.Input input -> Some (Encoding.schema input)
              end ;
              output = Encoding.schema s.types.output ;
              error = Encoding.schema s.types.error ;
            } in
            let builder key = Lwt.return (Service {
                types = s.types ;
                handler = handler key ;
              }) in
            { meth = s.meth ; description ; builder } in
          match dir with
          | Empty ->
              insert (Static { services = MethMap.singleton s.meth rs ;
                               subdirs = None })
          | Static ({ services ; _ } as dir)
            when not (MethMap.mem s.meth services) ->
              insert (Static { dir with services = MethMap.add s.meth rs services })
          | Static _ -> conflict path (CService s.meth)
          | Dynamic _ -> conflict path CBuilder
          | DynamicTail _ -> conflict path CTail in
      register s.path handler

  let register =
    (register
     : _ -> (Resto.meth, _, _, _, _, _, _) Service.t ->
     (_ -> _ -> _ -> (_, _) Answer.t Lwt.t) -> _
     :> _ -> ([< Resto.meth ], _, _, _, _, _, _) Service.t ->
     (_ -> _ -> _ -> [< (_, _) Answer.t ] Lwt.t) -> _)

  let register_dynamic_directory
    : type pr a pr.
      ?descr:string ->
      pr directory -> (pr, a) Path.path ->
      (a -> a directory Lwt.t) -> pr directory =
    fun ?descr root path builder ->
      let path = Resto.Internal.to_path path in
      let register
        : type k. (pr, k) path -> (k -> k directory Lwt.t) -> pr directory =
        fun path builder ->
          let dir, insert = insert path root in
          match dir with
          | Empty ->
              insert (Dynamic (descr, builder))
          | Static ({ services ; subdirs = None }) ->
              conflict path (CService (fst (MethMap.choose services)))
          | Static ({ subdirs = Some _ ; _ }) -> conflict path CDir
          | Dynamic _ -> conflict path CBuilder
          | DynamicTail _ -> conflict path CTail in
      register path builder

  let register_describe_directory_service
    : type pr.
      pr directory ->
      (pr, pr, _) Service.description_service ->
      pr directory
    = fun root service ->
      let dir = ref root in
      let lookup (args, path) { Description.recurse } () =
        resolve [] root args path >>= function
        | Error `Not_found
        | Error `Cannot_parse_path _ ->
            Lwt.return (`Not_found None)
        | Ok (Dir (dir, arg)) ->
            describe_directory ~recurse ~arg (Static dir) >>= function
            | Static { services ; _ }
              when not recurse && MethMap.is_empty services ->
                Lwt.return (`Not_found None)
            | d ->
                Lwt.return (`Ok d)
      in
      dir := register root service lookup ;
      !dir

  (****************************************************************************
   * Let's currify!
   ****************************************************************************)

  open Curry

  let register0 root s f = register root s (curry Z f)
  let register1 root s f = register root s (curry (S Z) f)
  let register2 root s f = register root s (curry (S (S Z)) f)
  let register3 root s f = register root s (curry (S (S (S Z))) f)
  let register4 root s f = register root s (curry (S (S (S (S Z)))) f)
  let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f)

  let register_dynamic_directory1 ?descr root s f =
    register_dynamic_directory ?descr root s (curry (S Z) f)
  let register_dynamic_directory2 ?descr root s f =
    register_dynamic_directory ?descr root s (curry (S (S Z)) f)
  let register_dynamic_directory3 ?descr root s f =
    register_dynamic_directory ?descr root s (curry (S (S (S Z))) f)


end