From 58c7d29fb76aab43a5f3bf863776e1db9fbcb1f5 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 12 Apr 2020 11:29:02 +0100 Subject: [PATCH] Add SQLite3 backend --- .travis.yml | 3 +- backends/sqlite/dune | 4 + backends/sqlite/session_sqlite.ml | 135 +++++++++++++++++++++++++++++ backends/sqlite/session_sqlite.mli | 8 ++ lib_test/sqlite/dune | 10 +++ lib_test/sqlite/test.ml | 12 +++ lib_test/sqlite/test.mli | 0 session-sqlite.opam | 24 +++++ 8 files changed, 195 insertions(+), 1 deletion(-) create mode 100644 backends/sqlite/dune create mode 100644 backends/sqlite/session_sqlite.ml create mode 100644 backends/sqlite/session_sqlite.mli create mode 100644 lib_test/sqlite/dune create mode 100644 lib_test/sqlite/test.ml create mode 100644 lib_test/sqlite/test.mli create mode 100644 session-sqlite.opam diff --git a/.travis.yml b/.travis.yml index 1e33c1c..1d54c43 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,8 +4,9 @@ script: bash -ex .travis-opam.sh sudo: required env: global: - - PINS="session.dev:. session-cohttp.dev:. session-cohttp-lwt.dev:. session-cohttp-async.dev:. session-webmachine.dev:. session-redis-lwt.dev:. session-postgresql.dev:. session-postgresql-lwt.dev:. session-postgresql-async.dev:. " + - PINS="session.dev:. session-cohttp.dev:. session-cohttp-lwt.dev:. session-cohttp-async.dev:. session-webmachine.dev:. session-redis-lwt.dev:. session-postgresql.dev:. session-postgresql-lwt.dev:. session-postgresql-async.dev:. session-sqlite.dev:." matrix: + - OCAML_VERSION=4.08 PACKAGE=session-sqlite - OCAML_VERSION=4.03 PACKAGE=session-cohttp-lwt - OCAML_VERSION=4.04 PACKAGE=session-cohttp-async - OCAML_VERSION=4.05 PACKAGE=session-webmachine diff --git a/backends/sqlite/dune b/backends/sqlite/dune new file mode 100644 index 0000000..c71137a --- /dev/null +++ b/backends/sqlite/dune @@ -0,0 +1,4 @@ +(library + (name session_sqlite) + (public_name session-sqlite) + (libraries mirage-crypto-rng base64 sqlite3 session)) diff --git a/backends/sqlite/session_sqlite.ml b/backends/sqlite/session_sqlite.ml new file mode 100644 index 0000000..9032707 --- /dev/null +++ b/backends/sqlite/session_sqlite.ml @@ -0,0 +1,135 @@ +type key = string +type value = string +type period = int64 + +let default_period = Int64.of_int (60 * 60 * 24 * 7) + +let failf fmt = + fmt |> Format.kasprintf failwith + +let or_fail ~cmd x = + match x with + | Sqlite3.Rc.OK -> () + | err -> failf "Sqlite3: %s (executing %S)" (Sqlite3.Rc.to_string err) cmd + +module Db = struct + let no_callback _ = failwith "[exec] used with a query!" + + let dump_item f x = Format.pp_print_string f (Sqlite3.Data.to_string_debug x) + let comma f () = Format.pp_print_string f ", " + let dump_row = Format.pp_print_list ~pp_sep:comma dump_item + + let exec_stmt ?(cb=no_callback) stmt = + let rec loop () = + match Sqlite3.step stmt with + | Sqlite3.Rc.DONE -> () + | Sqlite3.Rc.ROW -> + let cols = Sqlite3.data_count stmt in + cb @@ List.init cols (fun i -> Sqlite3.column stmt i); + loop () + | x -> failf "Sqlite3 exec error: %s" (Sqlite3.Rc.to_string x) + in + loop () + + let bind stmt values = + Sqlite3.reset stmt |> or_fail ~cmd:"reset"; + List.iteri (fun i v -> Sqlite3.bind stmt (i + 1) v |> or_fail ~cmd:"bind") values + + let exec stmt values = + bind stmt values; + exec_stmt stmt + + let query stmt values = + bind stmt values; + let results = ref [] in + let cb row = + results := row :: !results + in + exec_stmt ~cb stmt; + List.rev !results + + let query_some stmt values = + match query stmt values with + | [] -> None + | [row] -> Some row + | _ -> failwith "Multiple results from SQL query!" +end + +type t = { + get : Sqlite3.stmt; + set : Sqlite3.stmt; + clear : Sqlite3.stmt; + expire : Sqlite3.stmt; + mutable next_expire_due : Int64.t; +} + +let gensym () = + Base64.encode_string (Cstruct.to_string (Mirage_crypto_rng.generate 30)) + +let now () = + Int64.of_float (Unix.time ()) + +let clear t key = + Db.exec t.clear Sqlite3.Data.[ TEXT key ] + +let expire_old t = + Db.exec t.expire Sqlite3.Data.[ INT (now ()) ] + +let get t key = + match Db.query_some t.get Sqlite3.Data.[ TEXT key ] with + | None -> Error Session.S.Not_found + | Some Sqlite3.Data.[ value; INT expires ] -> + let period = Int64.(sub expires (now ())) in + if Int64.compare period 0L < 0 then ( + clear t key; + Error Session.S.Not_found + ) else ( + match value with + | NULL -> Error Session.S.Not_set + | TEXT value -> Ok (value, period) + | _ -> failf "Invalid value in row!" + ) + | Some row -> failf "get: invalid row: %a" Db.dump_row row + +let _set ?expiry ?value t key = + let expiry = + match expiry with + | None -> Int64.(add (now ()) default_period) + | Some expiry -> Int64.(add (now ()) expiry) + in + let value = + match value with + | None -> Sqlite3.Data.NULL + | Some value -> Sqlite3.Data.TEXT value + in + Db.exec t.set Sqlite3.Data.[ TEXT key; value; INT expiry ] + +let set ?expiry t key value = + _set ?expiry ~value t key + +let generate ?expiry ?value t = + let now = now () in + if t.next_expire_due <= now then ( + expire_old t; + t.next_expire_due <- Int64.add now default_period + ); + let key = gensym () in + _set ?expiry ?value t key; + key + +let create db = + Sqlite3.exec db "CREATE TABLE IF NOT EXISTS ocaml_session ( \ + key TEXT NOT NULL, \ + value TEXT, \ + expires INTEGER NOT NULL, \ + PRIMARY KEY (key))" |> or_fail ~cmd:"create table"; + let get = Sqlite3.prepare db "SELECT value, expires FROM ocaml_session WHERE key = ?" in + let set = Sqlite3.prepare db "INSERT OR REPLACE INTO ocaml_session \ + (key, value, expires) \ + VALUES (?, ?, ?)" in + let expire = Sqlite3.prepare db "DELETE FROM ocaml_session WHERE expires < ?" in + let clear = Sqlite3.prepare db "DELETE FROM ocaml_session WHERE key = ?" in + let next_expire_due = now () in + { get; set; clear; expire; next_expire_due } + +let default_period _ = default_period diff --git a/backends/sqlite/session_sqlite.mli b/backends/sqlite/session_sqlite.mli new file mode 100644 index 0000000..64fe14f --- /dev/null +++ b/backends/sqlite/session_sqlite.mli @@ -0,0 +1,8 @@ +(** SQLite3 backend *) + +include Session.S.Now with + type key = string and + type value = string and + type period = Int64.t + +val create : Sqlite3.db -> t diff --git a/lib_test/sqlite/dune b/lib_test/sqlite/dune new file mode 100644 index 0000000..d3f8a8f --- /dev/null +++ b/lib_test/sqlite/dune @@ -0,0 +1,10 @@ +(executable + (name test) + (libraries session_test session-sqlite mirage-crypto-rng mirage-crypto-rng.unix)) + +(alias + (name runtest) + (package session-sqlite) + (deps test.exe) + (action + (run %{exe:test.exe}))) diff --git a/lib_test/sqlite/test.ml b/lib_test/sqlite/test.ml new file mode 100644 index 0000000..72ffbc0 --- /dev/null +++ b/lib_test/sqlite/test.ml @@ -0,0 +1,12 @@ +module Backend = struct + include Session_sqlite + + let name = "sqlite" + + let create () = + let db = Sqlite3.db_open ~memory:true ":memory:" in + create db +end + +let () = Mirage_crypto_rng_unix.initialize () +module Test = Test_session.Make(Backend) diff --git a/lib_test/sqlite/test.mli b/lib_test/sqlite/test.mli new file mode 100644 index 0000000..e69de29 diff --git a/session-sqlite.opam b/session-sqlite.opam new file mode 100644 index 0000000..464f7b0 --- /dev/null +++ b/session-sqlite.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +name: "session-sqlite" +maintainer: "Spiros Eliopoulos " +authors: "Thomas Leonard " +license: "BSD-3-clause" +homepage: "https://github.com/inhabitedtype/ocaml-session" +bug-reports: "https://github.com/inhabitedtype/ocaml-session/issues" +doc: "https://inhabitedtype.github.io/ocaml-session/" +depends: [ + "ocaml" {>= "4.07.0"} + "dune" {build & >= "1.0"} + "session" {= version} + "base64" {>= "3.1.0"} + "sqlite3" + "mirage-crypto-rng" + "ounit" {with-test & >= "1.0.2"} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/inhabitedtype/ocaml-session.git" +synopsis: "A session manager for your everyday needs - SQLite3-specific support"