From d18ae43731c74a77be1fd5d09b35499b46b398e8 Mon Sep 17 00:00:00 2001
From: Nathan Anderson <n8r@tuta.io>
Date: Thu, 31 Oct 2024 12:10:38 -0600
Subject: [PATCH] Working basic htmx page and endpoint, WIP static file serving
and dune test running
---
.direnv/bin/nix-direnv-reload | 19 +++++
.envrc | 1 +
.gitignore | 2 +
.ocamlformat | 2 +
bin/dune | 26 ++++++
bin/main.ml | 51 ++++++++++++
dune-project | 26 ++++++
flake.lock | 116 +++++++++++++++++++++++++++
flake.nix | 52 ++++++++++++
lib/db.ml | 9 +++
lib/dune | 15 ++++
lib/srv.ml | 145 ++++++++++++++++++++++++++++++++++
scripts/dune | 15 ++++
scripts/validate_html.ml | 19 +++++
stack_picker.opam | 31 ++++++++
static/index.html | 0
static/temp/index.html | 0
static/temp/shop/store.html | 0
static/temp/shop/test.txt | 0
test/dune | 3 +
test/test_stack_picker.ml | 1 +
21 files changed, 533 insertions(+)
create mode 100755 .direnv/bin/nix-direnv-reload
create mode 100644 .envrc
create mode 100644 .gitignore
create mode 100644 .ocamlformat
create mode 100644 bin/dune
create mode 100644 bin/main.ml
create mode 100644 dune-project
create mode 100644 flake.lock
create mode 100644 flake.nix
create mode 100644 lib/db.ml
create mode 100644 lib/dune
create mode 100644 lib/srv.ml
create mode 100644 scripts/dune
create mode 100755 scripts/validate_html.ml
create mode 100644 stack_picker.opam
create mode 100644 static/index.html
create mode 100644 static/temp/index.html
create mode 100644 static/temp/shop/store.html
create mode 100644 static/temp/shop/test.txt
create mode 100644 test/dune
create mode 100644 test/test_stack_picker.ml
diff --git a/.direnv/bin/nix-direnv-reload b/.direnv/bin/nix-direnv-reload
new file mode 100755
index 0000000..b7fcd74
--- /dev/null
+++ b/.direnv/bin/nix-direnv-reload
@@ -0,0 +1,19 @@
+#!/usr/bin/env bash
+set -e
+if [[ ! -d "/home/nate/Games/.source/stack_picker" ]]; then
+ echo "Cannot find source directory; Did you move it?"
+ echo "(Looking for "/home/nate/Games/.source/stack_picker")"
+ echo 'Cannot force reload with this script - use "direnv reload" manually and then try again'
+ exit 1
+fi
+
+# rebuild the cache forcefully
+_nix_direnv_force_reload=1 direnv exec "/home/nate/Games/.source/stack_picker" true
+
+# Update the mtime for .envrc.
+# This will cause direnv to reload again - but without re-building.
+touch "/home/nate/Games/.source/stack_picker/.envrc"
+
+# Also update the timestamp of whatever profile_rc we have.
+# This makes sure that we know we are up to date.
+touch -r "/home/nate/Games/.source/stack_picker/.envrc" "/home/nate/Games/.source/stack_picker/.direnv"/*.rc
diff --git a/.envrc b/.envrc
new file mode 100644
index 0000000..3550a30
--- /dev/null
+++ b/.envrc
@@ -0,0 +1 @@
+use flake
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..72e11c5
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+.direnv/**
+_build/**
diff --git a/.ocamlformat b/.ocamlformat
new file mode 100644
index 0000000..8adea03
--- /dev/null
+++ b/.ocamlformat
@@ -0,0 +1,2 @@
+version=0.26.2
+profile=default
diff --git a/bin/dune b/bin/dune
new file mode 100644
index 0000000..77e8f32
--- /dev/null
+++ b/bin/dune
@@ -0,0 +1,26 @@
+(executable
+ (public_name stack_picker)
+ (name main)
+ (libraries
+ stack_picker
+ eio_main
+ caqti-eio.unix
+ cohttp-eio
+ tyxml
+ fmt
+ unix
+ logs.fmt
+ logs.threaded)
+ (preprocess
+ (pps tyxml-ppx)))
+(rule
+ (alias deploy)
+ (deps static)
+ (action
+ (chdir %{workspace_root}
+ (run ./scripts/validate_html.ml ))))
+(rule
+ (alias static)
+ (action
+ (chdir %{workspace_root}
+ (copy static/* ./ ))))
diff --git a/bin/main.ml b/bin/main.ml
new file mode 100644
index 0000000..157b1b7
--- /dev/null
+++ b/bin/main.ml
@@ -0,0 +1,51 @@
+open Tyxml
+open Stack_picker.Srv
+
+(* let () = Eio_main.run @@ fun env -> *)
+(* let url = "sqlite3://stack.db" |> Uri.of_string in *)
+(* Caqti_eio_unix.with_connection ~stdenv:(env :> Caqti_eio.stdenv) url (Stack_picker.Db.test env#stdout) *)
+(* |> Caqti_eio.or_fail *)
+let () = Logs.set_reporter (Logs_fmt.reporter ())
+and () = Logs.Src.set_level Cohttp_eio.src (Some Debug)
+
+let () =
+ let port = ref 8080 in
+ Arg.parse
+ [ ("-p", Arg.Set_int port, " Listening port number(8080 by default)") ]
+ ignore "An HTTP/1.1 server";
+ Eio_main.run @@ fun env ->
+ Eio.Switch.run @@ fun sw ->
+ run ~env ~sw ~port:!port
+ [
+ get "/ping" (fun _req ->
+ let num = 1 in
+ let resp =
+ Printf.sprintf "Hello this is the num: %d" num
+ |> Eio.Flow.string_source
+ in
+ Stack_picker.Srv.respond ~body:resp ());
+ get "/" (fun _ ->
+ let%html html_doc =
+ {|
+ <html>
+ <script src="https://unpkg.com/htmx.org@2.0.3"></script>
+ <title>Ocaml</title>
+ <body>
+ <p>Hello from ocaml!</p>
+ <button _hx-get="/shop" _hx-swap="outerHTML">Shop</button>
+ </body>
+ </html>|}
+ in
+ Stack_picker.Srv.respondHtmlDoc ~body:html_doc ());
+ get "/shop" (fun _ ->
+ let%html doc =
+ {|
+ <ol>
+ <li>Bat</li>
+ <li>Cat</li>
+ <li>Doggie</li>
+ </ol>
+ |}
+ in
+ respondHtml ~body:doc ());
+ ]
diff --git a/dune-project b/dune-project
new file mode 100644
index 0000000..d66add6
--- /dev/null
+++ b/dune-project
@@ -0,0 +1,26 @@
+(lang dune 3.15)
+
+(name stack_picker)
+
+(generate_opam_files true)
+
+(source
+ (github username/reponame))
+
+(authors "Author Name")
+
+(maintainers "Maintainer Name")
+
+(license LICENSE)
+
+(documentation https://url/to/documentation)
+
+(package
+ (name stack_picker)
+ (synopsis "A short synopsis")
+ (description "A longer description")
+ (depends ocaml dune)
+ (tags
+ (topics "to describe" your project)))
+
+; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project
diff --git a/flake.lock b/flake.lock
new file mode 100644
index 0000000..ced8fdf
--- /dev/null
+++ b/flake.lock
@@ -0,0 +1,116 @@
+{
+ "nodes": {
+ "flake-utils": {
+ "inputs": {
+ "systems": "systems"
+ },
+ "locked": {
+ "lastModified": 1726560853,
+ "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "flake-utils_2": {
+ "inputs": {
+ "systems": "systems_2"
+ },
+ "locked": {
+ "lastModified": 1726560853,
+ "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "nixpkgs": {
+ "locked": {
+ "lastModified": 1727634051,
+ "narHash": "sha256-S5kVU7U82LfpEukbn/ihcyNt2+EvG7Z5unsKW9H/yFA=",
+ "owner": "nixos",
+ "repo": "nixpkgs",
+ "rev": "06cf0e1da4208d3766d898b7fdab6513366d45b9",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nixos",
+ "ref": "nixos-unstable",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "ocaml-overlay": {
+ "inputs": {
+ "flake-utils": "flake-utils_2",
+ "nixpkgs": [
+ "nixpkgs"
+ ]
+ },
+ "locked": {
+ "lastModified": 1729147101,
+ "narHash": "sha256-Th67Tza+DSGeKPTHy451EBJ+WZzaCKnAYHacdVLxO4s=",
+ "owner": "nix-ocaml",
+ "repo": "nix-overlays",
+ "rev": "f4430b8e902af054b432c546d9423a254b9bf46f",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-ocaml",
+ "repo": "nix-overlays",
+ "type": "github"
+ }
+ },
+ "root": {
+ "inputs": {
+ "flake-utils": "flake-utils",
+ "nixpkgs": "nixpkgs",
+ "ocaml-overlay": "ocaml-overlay"
+ }
+ },
+ "systems": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
+ },
+ "systems_2": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
+ }
+ },
+ "root": "root",
+ "version": 7
+}
diff --git a/flake.nix b/flake.nix
new file mode 100644
index 0000000..4ea985b
--- /dev/null
+++ b/flake.nix
@@ -0,0 +1,52 @@
+{
+ description = "A very basic flake";
+
+ inputs = {
+ nixpkgs.url = "github:nixos/nixpkgs/nixos-unstable";
+ flake-utils.url = "github:numtide/flake-utils";
+ # Add support for ocaml package overlay
+ ocaml-overlay.url = "github:nix-ocaml/nix-overlays";
+ ocaml-overlay.inputs.nixpkgs.follows = "nixpkgs";
+ };
+
+ outputs = { self, flake-utils, nixpkgs, ocaml-overlay }:
+ flake-utils.lib.eachDefaultSystem (system: let
+ pkgs = import nixpkgs {
+ inherit system;
+ overlays = [
+ ocaml-overlay.overlays.default
+ ];
+ };
+ # set ocaml packages' version
+ ocamlPackages = pkgs.ocaml-ng.ocamlPackages_5_2;
+ in {
+ devShell =
+ #let
+ #
+ #in
+ pkgs.mkShell {
+ buildInputs = with pkgs; [
+ ocaml
+ ocamlPackages.ocaml-lsp
+ ocamlPackages.findlib
+ ocamlPackages.ocamlformat
+ ocamlPackages.ocamlformat-rpc-lib
+ ocamlPackages.utop
+ dune_3
+ # Project deps
+ ocamlPackages.eio_main
+ ocamlPackages.caqti-eio
+ ocamlPackages.caqti-driver-sqlite3
+ ocamlPackages.ocaml_sqlite3
+ ocamlPackages.dream
+ ocamlPackages.cohttp-eio
+ ocamlPackages.tyxml
+ ocamlPackages.tyxml-ppx
+ ocamlPackages.ppx_deriving
+ ocamlPackages.ppx_deriving_yojson
+ ocamlPackages.ppx_assert
+ ocamlPackages.ppx_inline_test
+ ];
+ };
+ });
+}
diff --git a/lib/db.ml b/lib/db.ml
new file mode 100644
index 0000000..83b323c
--- /dev/null
+++ b/lib/db.ml
@@ -0,0 +1,9 @@
+open Base
+
+let%test_unit "rev" =
+ [%test_eq: int list] (List.rev [ 3; 2; 1 ]) [ 1; 2; 3 ]
+
+let test stdout db =
+ let _ = stdout in
+ let _ = db in
+ Ok ()
diff --git a/lib/dune b/lib/dune
new file mode 100644
index 0000000..fe57b15
--- /dev/null
+++ b/lib/dune
@@ -0,0 +1,15 @@
+(library
+ (name stack_picker)
+ (inline_tests)
+ (libraries
+ eio_main
+ caqti-eio.unix
+ caqti-driver-sqlite3
+ cohttp-eio
+ tyxml
+ fmt
+ unix
+ logs.fmt
+ logs.threaded)
+ (preprocess
+ (pps ppx_assert ppx_inline_test tyxml-ppx)))
diff --git a/lib/srv.ml b/lib/srv.ml
new file mode 100644
index 0000000..f987d94
--- /dev/null
+++ b/lib/srv.ml
@@ -0,0 +1,145 @@
+open Tyxml
+
+type endpoint_key = {
+ path : string;
+ callback : Http.Request.t -> Http.Response.t;
+}
+
+type opt_route_response = {
+ headers : Http.Header.t option;
+ status : Http.Status.t option;
+ body : Cohttp_eio.Body.t option;
+}
+
+type route_response = {
+ headers : Http.Header.t;
+ status : Http.Status.t;
+ body : Cohttp_eio.Body.t;
+}
+
+type route_callback = Http.Request.t -> route_response
+
+module Endpath : sig
+ type t
+
+ val compare : t -> t -> int
+ val of_tuple : Http.Method.t * string -> t
+end = struct
+ type t = Http.Method.t * string
+
+ let compare (meth_a, path_a) (meth_b, path_b) =
+ let meth_compare = Http.Method.compare meth_a meth_b in
+ if meth_compare <> 0 then meth_compare
+ else String.(compare (lowercase_ascii path_a) (lowercase_ascii path_b))
+
+ let of_tuple (method_, path) : t = (method_, path)
+end
+
+module EndpointMap = Map.Make (Endpath)
+
+(* let endpoints: route_callback EndpointMap.t ref = ref EndpointMap.empty *)
+
+let default_headers =
+ let headers_strings = [ ("Content-Type", "text/html; charset=UTF-8") ] in
+ ref (Http.Header.of_list headers_strings)
+
+let default_body = ref ("" |> Eio.Flow.string_source)
+let log_warning ex = Logs.warn (fun f -> f "%a" Eio.Exn.pp ex)
+
+let get (path : string) (callback : route_callback) =
+ let key = Endpath.of_tuple (`GET, path) in
+ (key, callback)
+
+let post (path : string) (callback : route_callback) =
+ let key = Endpath.of_tuple (`POST, path) in
+ (key, callback)
+(* endpoints := !endpoints |> EndpointMap.add key callback *)
+
+let rec find_html_files (static_path : string) =
+ let files = Sys.readdir static_path in
+ Array.fold_left
+ (fun acc file ->
+ let path = Filename.concat static_path file in
+ if Sys.is_directory path then acc @ find_html_files path
+ else if Filename.check_suffix path ".html" then path :: acc
+ else acc)
+ [] files
+
+let respond ?body ?headers ?status () =
+ {
+ body = Option.value body ~default:!default_body;
+ headers = Option.value headers ~default:!default_headers;
+ status = Option.value status ~default:`OK;
+ }
+
+let respondStr ?body ?headers ?status () =
+ let eio_body =
+ match body with Some b -> Eio.Flow.string_source b | None -> !default_body
+ in
+ {
+ body = eio_body;
+ headers = Option.value headers ~default:!default_headers;
+ status = Option.value status ~default:`OK;
+ }
+
+let respondHtmlDoc ?body ?headers ?status () =
+ let eio_body =
+ match body with
+ | Some b ->
+ let content = Format.asprintf "%a" (Html.pp ()) b in
+ Eio.Flow.string_source content
+ | None -> !default_body
+ in
+ {
+ body = eio_body;
+ headers = Option.value headers ~default:!default_headers;
+ status = Option.value status ~default:`OK;
+ }
+
+let respondHtml ?body ?headers ?status () =
+ let eio_body =
+ match body with
+ | Some b ->
+ let content = Format.asprintf "%a" (Html.pp_elt ()) b in
+ Eio.Flow.string_source content
+ | None -> !default_body
+ in
+ {
+ body = eio_body;
+ headers = Option.value headers ~default:!default_headers;
+ status = Option.value status ~default:`OK;
+ }
+
+(** TODO not implemented, needs yojson ? *)
+let respondJson body ?headers ?status () =
+ {
+ body;
+ headers = Option.value headers ~default:!default_headers;
+ status = Option.value status ~default:`OK;
+ }
+
+let run ~env ~sw ~port endpoint_list =
+ let endpoints : route_callback EndpointMap.t =
+ EndpointMap.of_list endpoint_list
+ in
+ let socket =
+ Eio.Net.listen env#net ~sw ~backlog:128 ~reuse_addr:true
+ (`Tcp (Eio.Net.Ipaddr.V4.loopback, port))
+ in
+ let handler _socket request _body =
+ (* let req = Http.Request.resource request in *)
+ let path = Http.Request.resource request in
+ let end_key = Endpath.of_tuple (request.meth, path) in
+ let opt_path = EndpointMap.find_opt end_key endpoints in
+ match opt_path with
+ | Some route ->
+ (* NOTE needs an Exn.protect here? try / finally *)
+ let response = route request in
+ Cohttp_eio.Server.respond () ~headers:response.headers
+ ~status:response.status ~body:response.body
+ | None ->
+ let not_found_body = "Route not defined\n" |> Eio.Flow.string_source in
+ Cohttp_eio.Server.respond () ~status:`Not_found ~body:not_found_body
+ in
+ let server = Cohttp_eio.Server.make ~callback:handler () in
+ Cohttp_eio.Server.run socket server ~on_error:log_warning
diff --git a/scripts/dune b/scripts/dune
new file mode 100644
index 0000000..496441c
--- /dev/null
+++ b/scripts/dune
@@ -0,0 +1,15 @@
+(library
+ (name stack_picker_scripts)
+ (inline_tests)
+ (libraries
+ eio_main
+ caqti-eio.unix
+ caqti-driver-sqlite3
+ cohttp-eio
+ tyxml
+ fmt
+ unix
+ logs.fmt
+ logs.threaded)
+ (preprocess
+ (pps ppx_assert ppx_inline_test tyxml-ppx)))
diff --git a/scripts/validate_html.ml b/scripts/validate_html.ml
new file mode 100755
index 0000000..7f8d5d6
--- /dev/null
+++ b/scripts/validate_html.ml
@@ -0,0 +1,19 @@
+#!/usr/bin/env ocaml
+
+let rec find_html_files (static_path : string) =
+ let files = Sys.readdir static_path in
+ Array.fold_left
+ (fun acc file ->
+ let path = Filename.concat static_path file in
+ if Sys.is_directory path then acc @ find_html_files path
+ else if Filename.check_suffix path ".html" then path :: acc
+ else acc)
+ [] files
+
+let () =
+ let files = find_html_files "static" in
+ let _file_names = List.fold_left (fun name acc ->
+ acc ^ "\n - " ^ name
+ ) "" files in
+ (* Printf.printf "Found files:\n%s" file_names; *)
+ exit 0
diff --git a/stack_picker.opam b/stack_picker.opam
new file mode 100644
index 0000000..d500377
--- /dev/null
+++ b/stack_picker.opam
@@ -0,0 +1,31 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "A short synopsis"
+description: "A longer description"
+maintainer: ["Maintainer Name"]
+authors: ["Author Name"]
+license: "LICENSE"
+tags: ["topics" "to describe" "your" "project"]
+homepage: "https://github.com/username/reponame"
+doc: "https://url/to/documentation"
+bug-reports: "https://github.com/username/reponame/issues"
+depends: [
+ "ocaml"
+ "dune" {>= "3.15"}
+ "odoc" {with-doc}
+]
+build: [
+ ["dune" "subst"] {dev}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
+dev-repo: "git+https://github.com/username/reponame.git"
diff --git a/static/index.html b/static/index.html
new file mode 100644
index 0000000..e69de29
diff --git a/static/temp/index.html b/static/temp/index.html
new file mode 100644
index 0000000..e69de29
diff --git a/static/temp/shop/store.html b/static/temp/shop/store.html
new file mode 100644
index 0000000..e69de29
diff --git a/static/temp/shop/test.txt b/static/temp/shop/test.txt
new file mode 100644
index 0000000..e69de29
diff --git a/test/dune b/test/dune
new file mode 100644
index 0000000..cabe2ef
--- /dev/null
+++ b/test/dune
@@ -0,0 +1,3 @@
+(test
+ (name test_stack_picker)
+ (libraries eio_main sqlite3 dream))
diff --git a/test/test_stack_picker.ml b/test/test_stack_picker.ml
new file mode 100644
index 0000000..8b13789
--- /dev/null
+++ b/test/test_stack_picker.ml
@@ -0,0 +1 @@
+