software-archive/logarion-2016
2
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Wrap webserver with custom CmdLiner term

Browse Source
This commit is contained in:
Stavros Polymenis 2017-10-25 22:09:52 +01:00
parent b1851c4426
commit 66c2d3cd2c
1 changed files with 52 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
src/logarion_webserver.ml
View File

@ -44,14 +44,17 @@ let string_response s = `String s |> respond'
let html_response h = `Html h |> respond'
let optional_html_response = function Some h -> html_response h | None -> html_response "Not found"
let () =
let serve config_filename =
let module L = Logarion in
let module Config = Confix.Config.Make (Confix.ConfixToml) in
Random.self_init();
let module Config = Confix.Config.Make (Confix.ConfixToml) in
let toml_config = Config.(config "config.toml") in
let toml_config =
let open Confix.Config in
(if config_filename = "" then Path.with_file "config.toml" else Path.of_string config_filename)
|> function Ok cfg -> Config.from_path cfg | Error str -> prerr_endline str; exit 1
in
let config =
toml_config |> Config.to_record L.Archive.Configuration.of_config
|> function Ok cfg -> cfg | Error str -> prerr_endline str; exit 1
@ -132,21 +135,49 @@ let () =
print_endline @@ "Server address: " ^ Uri.to_string web_config.Configuration.url;
print_endline @@ "Press Ctrl+C to stop.";
App.empty
|> App.port (match Uri.port web_config.Configuration.url with Some p -> p | None -> 3666)
|> middleware @@
Middleware.static
~local_path:(Fpath.to_string web_config.Configuration.static)
~uri_prefix:"/static"
|> get "/:ttl" @@ view_note "ttl" lgrn (L.note_with_alias lgrn)
|> post "/post.note" @@ post_note lgrn
|> get "/edit.note/:ttl" @@ edit_note "ttl" lgrn (L.note_with_alias lgrn)
|> get "/new.note" (fun _ -> lwt_blanknote () >|= form_of_note >>= html_response)
|> get "/topic/:topic" @@ list_notes_with_topic "topic" lgrn
|> get "/note/:ttl" @@ view_note "ttl" lgrn (L.note_with_alias lgrn)
|> get "/!/:ttl" @@ view_note "ttl" lgrn (fun t -> match L.latest_entry lgrn t with
| Some meta -> L.note_with_id lgrn meta.Logarion.Meta.uuid
| None -> None)
|> get "/feed.atom" @@ atom_response lgrn
|> get "/" @@ list_notes "p" lgrn
|> App.run_command
let app =
App.empty
|> App.port (match Uri.port web_config.Configuration.url with Some p -> p | None -> 3666)
|> middleware @@
Middleware.static
~local_path:(Fpath.to_string web_config.Configuration.static)
~uri_prefix:"/static"
|> get "/:ttl" @@ view_note "ttl" lgrn (L.note_with_alias lgrn)
|> post "/post.note" @@ post_note lgrn
|> get "/edit.note/:ttl" @@ edit_note "ttl" lgrn (L.note_with_alias lgrn)
|> get "/new.note" (fun _ -> lwt_blanknote () >|= form_of_note >>= html_response)
|> get "/topic/:topic" @@ list_notes_with_topic "topic" lgrn
|> get "/note/:ttl" @@ view_note "ttl" lgrn (L.note_with_alias lgrn)
|> get "/!/:ttl" @@ view_note "ttl" lgrn (fun t -> match L.latest_entry lgrn t with
| Some meta -> L.note_with_id lgrn meta.Logarion.Meta.uuid
| None -> None)
|> get "/feed.atom" @@ atom_response lgrn
|> get "/" @@ list_notes "p" lgrn
|> App.start
in
Lwt_main.run app
let serve_term =
let open Cmdliner in
let config = Arg.(value & opt string "" & info ["c"; "config"] ~docv:"CONFIG FILENAME" ~doc:"Configuration filename") in
Term.(const serve $ config),
Term.info
"serve"
~doc:"serve repository over web"
~man:[ `S "DESCRIPTION"; `P "Launches a webserver for current repository"]
let help_term =
let open Cmdliner in
Term.(ret (const (`Help (`Pager, None)))),
Term.info
"Logarion webserver" ~version:"0.1.0"
~doc:"Logarion repository web server"
~man:[ `S "BUGS";
`P "Submit bugs https://gitlab.com/orbifx/logarion/issues/new."; ]
let cmds = [ serve_term; help_term ]
let () =
let open Cmdliner in
match Term.eval_choice serve_term cmds with
| `Error _ -> exit 1 | _ -> exit 0