forked from zapashcanon/drame
80 lines
2.0 KiB
OCaml
80 lines
2.0 KiB
OCaml
open Drame
|
|
open Tyxml
|
|
open Tyxml.Html
|
|
|
|
module App_id = struct
|
|
let qualifier = "org"
|
|
|
|
let organization = "drame"
|
|
|
|
let application = "drame"
|
|
end
|
|
|
|
module Server = Server.Make (App_id)
|
|
|
|
let template_html (_request : Request.t) ~title ~body =
|
|
let styles =
|
|
List.map
|
|
(fun s -> link ~rel:[ `Stylesheet ] ~href:(Fmt.str "/assets/css/%s" s) ())
|
|
[ "style.css" ]
|
|
in
|
|
let head = head (Html.title title) styles in
|
|
let body = Html.body [ main [ h1 [ title ]; body ] ] in
|
|
let a = [ a_lang "en" ] in
|
|
let tyxml_doc = html ~a head body in
|
|
Html_doc.of_tyxml tyxml_doc
|
|
|
|
let hello =
|
|
let body = txt "How are you doing?" in
|
|
fun ~name ->
|
|
let title = Fmt.kstr txt "Hello %s!" name in
|
|
fun request ->
|
|
let doc = template_html request ~title ~body in
|
|
let content = Content.Html doc in
|
|
Ok content
|
|
|
|
let hello_q request =
|
|
let name = Request.query request "name" in
|
|
let name = Option.value name ~default:"World" in
|
|
let msg = Fmt.kstr txt "Hello %s!" name in
|
|
let doc = template_html request ~title:msg ~body:msg in
|
|
let content = Content.Html doc in
|
|
Ok content
|
|
|
|
let config =
|
|
let title = txt "Configuration" in
|
|
let body = Fmt.kstr txt "%a" Scfg.Pp.config Server.config in
|
|
fun request ->
|
|
let doc = template_html request ~title ~body in
|
|
let content = Content.Html doc in
|
|
Ok content
|
|
|
|
let not_found =
|
|
let title = txt "404 Not Found" in
|
|
let body = txt "Ooops :S" in
|
|
fun request ->
|
|
let content = template_html request ~title ~body in
|
|
Error (Status.Not_found, content)
|
|
|
|
let style =
|
|
let s = {css|body {
|
|
color: #ebb2bf;
|
|
background-color: #0f1312;
|
|
}|css} in
|
|
let sheet = Css.parse_css s in
|
|
let content = Content.Css sheet in
|
|
fun _request -> Ok content
|
|
|
|
let handler route =
|
|
Fmt.pr "[request] %a@\n" Route.pp route;
|
|
Fmt.flush Fmt.stdout ();
|
|
match route with
|
|
| [||] -> hello ~name:"World"
|
|
| [| "assets"; "css"; "style.css" |] -> style
|
|
| [| "config" |] -> config
|
|
| [| "hello"; name |] -> hello ~name
|
|
| [| "helloq" |] -> hello_q
|
|
| _ -> not_found
|
|
|
|
let () = Server.run ~handler
|