unikernel/duniverse/mirage/lib/functoria/opam.ml

@@ -0,0 +1,257 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 Gabriel Radanne <drupyog@zoho.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Action.Syntax
+
+let find_git () =
+  let is_git p = Action.is_dir Fpath.(p / ".git") in
+  let app_opt p d = match p with None -> d | Some p -> Fpath.(d // p) in
+  let rec find p path =
+    if Fpath.is_root p then Action.ok None
+    else
+      let* has_git = is_git p in
+      if has_git then Action.ok (Some path)
+      else find (Fpath.parent p) (Some (app_opt path (Fpath.base p)))
+  in
+  let* cwd = Action.pwd () in
+  (* this is invoked from within the mirage subdirectory *)
+  let* cwd = find (Fpath.parent cwd) None in
+  match cwd with
+  | None -> Action.ok None
+  | Some subdir ->
+      let git_branch =
+        Bos.Cmd.(v "git" % "rev-parse" % "--abbrev-ref" % "HEAD")
+      in
+      let* branch = Action.(run_cmd_out ~err:`Null git_branch) in
+      let git_remote = Bos.Cmd.(v "git" % "remote" % "get-url" % "origin") in
+      let+ git_url = Action.(run_cmd_out ~err:`Null git_remote) in
+      Some (subdir, branch, git_url)
+
+module Endpoint = struct
+  type t = {
+    scheme : [ `SSH of string | `Git | `HTTP | `HTTPS | `Scheme of string ];
+    port : int option;
+    path : string;
+    hostname : string;
+  }
+
+  let of_string str =
+    let open Rresult in
+    let parse_ssh str =
+      let len = String.length str in
+      Emile.of_string_raw ~off:0 ~len str
+      |> R.reword_error (R.msgf "%a" Emile.pp_error)
+      >>= fun (consumed, m) ->
+      match
+        Astring.String.cut ~sep:":" (String.sub str consumed (len - consumed))
+      with
+      | Some ("", path) ->
+          let path = "/" ^ path in
+          let local =
+            List.map
+              (function `Atom x -> x | `String x -> Fmt.str "%S" x)
+              m.Emile.local
+          in
+          let user = String.concat "." local in
+          let hostname =
+            match fst m.Emile.domain with
+            | `Domain vs -> String.concat "." vs
+            | `Literal v -> v
+            | `Addr (Emile.IPv4 v) -> Ipaddr.V4.to_string v
+            | `Addr (Emile.IPv6 v) -> Ipaddr.V6.to_string v
+            | `Addr (Emile.Ext (k, v)) -> Fmt.str "%s:%s" k v
+          in
+          R.ok { scheme = `SSH user; path; port = None; hostname }
+      | _ -> R.error_msg "Invalid SSH pattern"
+    in
+    let parse_uri str =
+      let uri = Uri.of_string str in
+      let path = Uri.path uri in
+      match (Uri.scheme uri, Uri.host uri, Uri.port uri) with
+      | Some "git", Some hostname, port ->
+          R.ok { scheme = `Git; path; port; hostname }
+      | Some "http", Some hostname, port ->
+          R.ok { scheme = `HTTP; path; port; hostname }
+      | Some "https", Some hostname, port ->
+          R.ok { scheme = `HTTPS; path; port; hostname }
+      | Some scheme, Some hostname, port ->
+          R.ok { scheme = `Scheme scheme; path; port; hostname }
+      | _ -> R.error_msgf "Invalid uri: %a" Uri.pp uri
+    in
+    match (parse_ssh str, parse_uri str) with
+    | Ok v, _ -> Ok v
+    | _, Ok v -> Ok v
+    | Error _, Error _ -> R.error_msgf "Invalid endpoint: %s" str
+end
+
+let guess_src () =
+  let git_info =
+    match Action.run @@ find_git () with
+    | Error _ | Ok None -> None
+    | Ok (Some (subdir, branch, git_url)) -> Some (subdir, branch, git_url)
+  in
+  match git_info with
+  | None -> (None, None)
+  | Some (subdir, branch, origin) ->
+      (* TODO is there a library for git urls anywhere? *)
+      let public =
+        match Endpoint.of_string origin with
+        | Ok
+            { Endpoint.scheme = `Scheme scheme; port = None; path; hostname; _ }
+          ->
+            Fmt.str "%s://%s%s" scheme hostname path
+        | Ok
+            {
+              Endpoint.scheme = `Scheme scheme;
+              port = Some port;
+              path;
+              hostname;
+              _;
+            } ->
+            Fmt.str "%s://%s:%d%s" scheme hostname port path
+        | Ok { Endpoint.port = None; path; hostname; _ } ->
+            Fmt.str "git+https://%s%s" hostname path
+        | Ok { Endpoint.port = Some port; path; hostname; _ } ->
+            Fmt.str "git+https://%s:%d%s" hostname port path
+        | _ -> "git+https://invalid/endpoint"
+      in
+      (subdir, Some (Fmt.str "%s#%s" public branch))
+
+type t = {
+  name : string;
+  depends : Package.t list;
+  configure : string option;
+  pre_build : (Fpath.t option -> string) option;
+  lock_location : (Fpath.t option -> string -> string) option;
+  build : (Fpath.t option -> string) option;
+  install : Install.t;
+  extra_repo : (string * string) list;
+  pins : (string * string) list;
+  src : string option;
+  subdir : Fpath.t option;
+  opam_name : string;
+}
+
+let v ?configure ?pre_build ?lock_location ?build ?(install = Install.empty)
+    ?(extra_repo = []) ?(depends = []) ?(pins = []) ?subdir ~src ~opam_name name
+    =
+  let subdir, src =
+    match src with
+    | `Auto ->
+        let subdir', src = guess_src () in
+        ((match subdir with None -> subdir' | Some _ as s -> s), src)
+    | `None -> (subdir, None)
+    | `Some d -> (subdir, Some d)
+  in
+  {
+    name;
+    depends;
+    configure;
+    pre_build;
+    lock_location;
+    build;
+    install;
+    extra_repo;
+    pins;
+    src;
+    subdir;
+    opam_name;
+  }
+
+let pp_packages ppf packages =
+  Fmt.pf ppf "\n  %a\n"
+    Fmt.(list ~sep:(any "\n  ") (Package.pp ~surround:"\""))
+    packages
+
+let pp_pins ppf = function
+  | [] -> ()
+  | pins ->
+      let pp_pin ppf (package, url) = Fmt.pf ppf "[\"%s\" %S]" package url in
+      Fmt.pf ppf "@.pin-depends: [ @[<hv>%a@]@ ]@."
+        Fmt.(list ~sep:(any "@ ") pp_pin)
+        pins
+
+let pp_src ppf = function
+  | None -> ()
+  | Some src -> Fmt.pf ppf {|@.url { src: %S }|} src
+
+let pp_switch_package ppf s = Fmt.pf ppf "%S" s
+
+let pp ppf t =
+  let pp_cmd = function
+    | None -> ""
+    | Some cmd ->
+        Fmt.str {|"sh" "-exc" "%a%s"|}
+          Fmt.(option ~none:(any "") (any "cd " ++ Fpath.pp ++ any " && "))
+          t.subdir cmd
+  in
+  let pp_with_sub ppf = function
+    | None -> ()
+    | Some f -> Fmt.string ppf (f t.subdir)
+  in
+  let pp_repo =
+    Fmt.(
+      list ~sep:(any "\n")
+        (brackets (pair ~sep:(any " ") (quote string) (quote string))))
+  in
+  let switch_packages =
+    List.filter_map
+      (fun p ->
+        match Package.scope p with
+        | `Switch -> Some (Package.name p)
+        | `Monorepo -> None)
+      t.depends
+  in
+  Fmt.pf ppf
+    {|opam-version: "2.0"
+maintainer: "dummy"
+authors: "dummy"
+homepage: "dummy"
+bug-reports: "dummy"
+dev-repo: "git://dummy"
+synopsis: "Unikernel %s - switch dependencies"
+description: """
+It assumes that local dependencies are already
+fetched.
+"""
+
+build: [%a]
+
+install: [%a]
+
+depends: [%a]
+
+x-mirage-opam-lock-location: %S
+
+x-mirage-configure: [%s]
+
+x-mirage-pre-build: [%a]
+
+x-mirage-extra-repo: [%a]
+
+x-opam-monorepo-opam-provided: [%a]
+%a%a|}
+    t.name pp_with_sub t.build
+    (Install.pp_opam ?subdir:t.subdir ())
+    t.install pp_packages t.depends
+    (Option.fold ~none:""
+       ~some:(fun l -> l t.subdir t.opam_name)
+       t.lock_location)
+    (pp_cmd t.configure) pp_with_sub t.pre_build pp_repo t.extra_repo
+    (Fmt.list ~sep:(Fmt.any " ") pp_switch_package)
+    switch_packages pp_src t.src pp_pins t.pins