diff --git a/bin/main.ml b/bin/main.ml index f75ba17..3ee4bd5 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -41,7 +41,7 @@ module Sync = struct Metadata.Bundle.create_daily ~commit ~tag Metadata.Target.defaults in let bundle_key = - match daily_bundle.tag with + match Metadata.Bundle.tag daily_bundle with | Some tag -> tag | None -> Metadata.Bundle.get_date_string_from daily_bundle in @@ -110,39 +110,17 @@ module Sync = struct let cmd = Cmd.v info term end -let find_latest_stable bundles = - bundles - |> List.filter_map (fun (b : Metadata.Bundle.t) -> - match b.tag with - | None -> None - | Some tag -> - (match Scanf.sscanf_opt tag "%d.%d.%d" (fun x y z -> x, y, z) with - | None -> None - | Some tup -> Some (tup, b))) - |> List.sort (fun ((maj, min, patch), _) ((maj', min', patch'), _) -> - (* reverse sort, biggest first *) - match Int.compare maj' maj with - | 0 -> - (match Int.compare min' min with - | 0 -> Int.compare patch' patch - | otherwise -> otherwise) - | otherwise -> otherwise) - |> function - | [] -> None - | (_, bundle) :: _ -> Some bundle -;; - module Http = struct let serve dev (module Config : Config.Configuration) port = let title = "Dune Nightly" in let base_url = Config.Server.url in let bundles = Metadata.import_from_json Config.Path.metadata in let latest_release = - match find_latest_stable bundles with + match Metadata.Bundle.newest_tagged bundles with | None -> "" | Some bundle -> (* guaranteed to exist at this point *) - Option.get bundle.tag + bundle |> Metadata.Bundle.tag |> Option.get in let routes = let main_page = Web.generate_main_page ~title ~base_url ~latest_release bundles in diff --git a/bin/server.ml b/bin/server.ml index 9f23df7..0b8f23f 100644 --- a/bin/server.ml +++ b/bin/server.ml @@ -1,3 +1,7 @@ +type release = + | Latest + | Specific of string + let cache_middleware ~dev next_handler request = let open Lwt.Infix in if (not dev) && Dream.target request |> String.starts_with ~prefix:"/static" @@ -16,9 +20,16 @@ let reload_script_middleware ~dev inner_handler request = let matching_bundle ~base_url bundles ~target ~tag request = let module Bundle = Sandworm.Metadata.Bundle in let bundle = - List.find_opt - (fun candidate -> Bundle.matches_criteria ~tag ~target candidate) - bundles + match tag with + | Some Latest -> Bundle.newest_tagged bundles + | Some (Specific version) -> + List.find_opt + (fun candidate -> Bundle.matches_criteria ~tag:(Some version) ~target candidate) + bundles + | None as tag -> + List.find_opt + (fun candidate -> Bundle.matches_criteria ~tag ~target candidate) + bundles in match bundle with | None -> Dream.respond ~status:`Not_Found "No such release" @@ -26,21 +37,29 @@ let matching_bundle ~base_url bundles ~target ~tag request = Dream.redirect request (Bundle.to_download_url ~base_url ~target bundle) ;; -let latest_route_from_targets ~base_url bundles request = +let with_valid_target request f = let module Target = Sandworm.Metadata.Target in let target = Dream.param request "target" in match Target.of_string target with | None -> Dream.respond ~status:`Not_Found "Invalid target" - | Some target -> matching_bundle bundles ~base_url ~target ~tag:None request + | Some target -> f target +;; + +let latest_route_from_targets ~base_url bundles request = + with_valid_target request + @@ fun target -> matching_bundle bundles ~base_url ~target ~tag:None request ;; let stable_release ~base_url bundles request = - let module Target = Sandworm.Metadata.Target in - let release = Dream.param request "release" in - let target = Dream.param request "target" in - match Target.of_string target with - | None -> Dream.respond ~status:`Not_Found "Invalid target" - | Some target -> matching_bundle bundles ~base_url ~target ~tag:(Some release) request + let tag = Some (Specific (Dream.param request "release")) in + with_valid_target request + @@ fun target -> matching_bundle bundles ~base_url ~target ~tag request +;; + +let latest_stable_release ~base_url bundles request = + let tag = Some Latest in + with_valid_target request + @@ fun target -> matching_bundle bundles ~base_url ~target ~tag request ;; let error_template _error _debug_info suggested_response = @@ -77,6 +96,7 @@ let serve ~dev ~base_url routes port bundles = ; Dream.get "/install" (fun request -> Dream.redirect request "/static/install") ; Dream.get "/static/**" @@ Dream.static "static" ; Dream.get "/latest/:target" (latest_route_from_targets ~base_url bundles) + ; Dream.get "/stable/latest/:target" (latest_stable_release ~base_url bundles) ; Dream.get "/stable/:release/:target" (stable_release ~base_url bundles) ]) ;; diff --git a/lib/main.mlx b/lib/main.mlx index fab14ea..ff99247 100644 --- a/lib/main.mlx +++ b/lib/main.mlx @@ -51,10 +51,16 @@ let getting_started ~install_url ~latest_release:version () =

- "Copy & Install (stable)" + "Copy & Install (current stable)"

+

+ + "Copy & Install (latest stable)" +

+ +

"Getting Started"

"You can create and run your first hello-world program using Dune like this"

@@ -260,7 +266,8 @@ let manual_installation ~base_url ~builds () =

    (let bundle: Metadata.Bundle.t = builds |> List.hd in - bundle.targets + bundle + |> Metadata.Bundle.targets |> List.map (installation_target ~base_url ~bundle) |> JSX.list)
@@ -305,7 +312,7 @@ let release_information ~base_url ~bundle ~target () = "Archive" (JSX.string os) (JSX.string arch) - (String.sub bundle.commit 0 6 |> JSX.string) + (String.sub (Metadata.Bundle.commit bundle) 0 6 |> JSX.string)
@@ -331,7 +338,7 @@ let build_history ~base_url ~builds () = |> List.map (fun (bundle: Bundle.t) -> let date = Bundle.get_date_string_from ~prefix:"nightly-" bundle in let summary = Format.sprintf "dune %s" date in - let files = bundle.targets |> List.map (fun (target: Target.t) -> ()) in + let files = bundle |> Metadata.Bundle.targets |> List.map (fun (target: Target.t) -> ()) in (
diff --git a/lib/metadata.ml b/lib/metadata.ml index dbc0b87..c8087fe 100644 --- a/lib/metadata.ml +++ b/lib/metadata.ml @@ -25,7 +25,7 @@ module Target = struct ;; let to_description = function - | Aarch64_apple_darwin -> "macOS 11 or later for Apple Sillicon processors" + | Aarch64_apple_darwin -> "macOS 11 or later for Apple silicon processors" | X86_64_apple_darwin -> "macOS 11 or later for Intel processors" | X86_64_unknown_linux_musl -> "Linux for Intel 64-bit processors" ;; @@ -73,6 +73,10 @@ module Bundle = struct { date; targets; commit; tag; has_certificate = true } ;; + let targets { targets; _ } = targets + let commit { commit; _ } = commit + let tag { tag; _ } = tag + let create_daily targets = let date = Unix.time () |> Ptime.of_float_s |> Option.get |> Ptime.to_date in create ~date targets @@ -90,6 +94,65 @@ module Bundle = struct | Some t -> List.mem target t.targets ;; + module Version = struct + module Compare = struct + module Syntax = struct + let ( let+ ) comparison_result continue = + match comparison_result with + | 0 -> continue () + | non_equal -> non_equal + ;; + end + end + + let parse tag = Scanf.sscanf_opt tag "%d.%d.%d" (fun x y z -> x, y, z) + + let compare (maj, min, patch) (maj', min', patch') = + let open Compare.Syntax in + let+ () = Int.compare maj maj' in + let+ () = Int.compare min min' in + Int.compare patch patch' + ;; + end + + module Option = struct + include Option + + module Syntax = struct + let ( let+ ) v f = map f v + let ( let* ) = bind + end + end + + let bundle_with_tag bundle = + let open Option.Syntax in + let* tag = bundle.tag in + let+ tag = Version.parse tag in + tag, bundle + ;; + + let max_bundle_by_version previous candidate = + match previous with + | None -> Some candidate + | Some previous -> + let previous_version, _ = previous in + let candidate_version, _ = candidate in + if Version.compare previous_version candidate_version < 0 + then Some candidate + else Some previous + ;; + + let newest_tagged bundles = + bundles + |> List.fold_left + (fun acc bundle -> + match bundle_with_tag bundle with + | None -> acc + | Some bundle_with_tag -> max_bundle_by_version acc bundle_with_tag) + None + |> Option.map snd + ;; + let get_date_string_from ?prefix t = let y, m, d = t.date in let date = Format.sprintf "%d-%02d-%02d" y m d in diff --git a/lib/metadata.mli b/lib/metadata.mli new file mode 100644 index 0000000..c431f41 --- /dev/null +++ b/lib/metadata.mli @@ -0,0 +1,40 @@ +module Target : sig + type t + + val to_human_readable_string : t -> string + val to_description : t -> string + val to_triple : t -> string * string * string + val of_string : string -> t option + val defaults : t list +end + +module Bundle : sig + type t + + val targets : t -> Target.t list + val commit : t -> string + val tag : t -> string option + val to_download_file : Target.t -> string + val to_download_url : base_url:string -> target:Target.t -> t -> string + val to_certificate_url : base_url:string -> target:Target.t -> t -> string + val get_date_string_from : ?prefix:string -> t -> string + + (* creates a bundle with the current date *) + val create_daily : Target.t list -> commit:string -> tag:string option -> t + + (* returns [true] if the bundle matches the query *) + val matches_criteria : tag:string option -> target:Target.t -> t -> bool + + (* returns the bundle with the highest version number *) + val newest_tagged : t list -> t option +end + +(* [import_from_json filename] reads the file and parses it into a list of [Bundle.t] *) +val import_from_json : string -> Bundle.t list + +(* [export_to_json filename bundles] takes bundles and writes them to the specified + file name. *) +val export_to_json : string -> Bundle.t list -> unit + +(* Inserts a new bundle into the list unless there is already an equivalent one. *) +val insert_unique : Bundle.t -> Bundle.t list -> Bundle.t list