Commit 91d54c50 authored by mud rz's avatar mud rz
Browse files

cleanup code

parent ba9a1f26
......@@ -3,10 +3,13 @@ module fsharp_bench.Content
open Giraffe
open GiraffeViewEngine
let txt = encodedText
let layout (content: XmlNode list) =
html [] [
head [] [
title [] [ encodedText "fsharp_bench" ]
title [] [ txt "Fsharp Bench" ]
meta [ _charset "UTF-8" ]
link [ _rel "stylesheet"
_type "text/css"
_href "/style.css" ]
......@@ -14,7 +17,6 @@ let layout (content: XmlNode list) =
body [] content
]
let txt = encodedText
let hyper_link children href = a [ _href href ] [ str children ]
let welcome () =
......
......@@ -4,20 +4,6 @@ open Dapper
open Npgsql
open FSharp.Control.Tasks.V2
module Excerpt =
[<CLIMutable>]
type t =
{ author: string
; excerpt: string
; source: string
; page: string option
}
[<CLIMutable>]
type res =
{ excerpts: t list
}
let url = "localhost"
let port = 5432
let database = "opi"
......
......@@ -11,77 +11,24 @@ open Microsoft.Extensions.DependencyInjection
open Giraffe
open FSharp.Control.Tasks.V2.ContextInsensitive
// ---------------------------------
// Views
// ---------------------------------
module Views =
open GiraffeViewEngine
let layout (content: XmlNode list) =
html [] [
head [] [
title [] [ encodedText "fsharp_bench" ]
link [ _rel "stylesheet"
_type "text/css"
_href "/style.css" ]
]
body [] content
]
let txt = encodedText
let hyper_link children href = a [ _href href ] [ str children ]
let welcome () =
[
h1 [] [ txt "FSharp Webapp Tutorial" ]
h2 [] [ txt "Hello" ]
ul [] (List.map (fun x -> li [] [x]) [
hyper_link "hiya" "/hello"
; hyper_link "中文" "/hello/中文"
; hyper_link "Deutsch" "/hello/Deutsch"
; hyper_link "English" "/hello/English"
])
h2 [] [ txt "Excerpts" ]
ul [] (List.map (fun x -> li [] [x]) [
hyper_link "Add Excerpt" "/excerpts/add"
; hyper_link "Excerpts" "/excerpts"
])
] |> layout
let excerpt_elt (e : Db.Excerpt.t) =
let page = match e.page with
| None -> ""
| Some p -> Printf.sprintf ", %s" p
in
blockquote [_class "excerpt"] [
p [][txt e.excerpt]
; p [][txt (Printf.sprintf "-- %s (%s%s)" e.author e.source page)]
]
let excerpts_listing_page (es : Db.Excerpt.t list) =
[
h1 [][txt "Excerpts"]
div [] (List.map excerpt_elt es)
] |> layout
// ---------------------------------
// Web app
// ---------------------------------
let indexHandler: HttpHandler =
let view = Views.welcome ()
let view = Content.welcome ()
htmlView view
let fortunesHandler: HttpHandler =
fun ctx next -> task {
let! excerpts = Db.fortunes ()
let view = Views.excerpts_listing_page excerpts
let view = Content.excerpts_listing_page excerpts
return! htmlView view ctx next
}
[<CLIMutable>]
type res = { excerpts: Excerpt.t list }
let fortunesJsonHandler: HttpHandler =
fun ctx next -> task {
let! excerpts = Db.fortunes ()
let res: Db.Excerpt.res = { excerpts= excerpts }
let res= { excerpts= excerpts }
return! json res ctx next
}
......
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>netcoreapp3.1</TargetFramework>
</PropertyGroup>
<ItemGroup>
<ProjectReference Include="../../src/fsharp-bench/fsharp-bench.fsproj" />
</ItemGroup>
<ItemGroup>
<Compile Include="Tests.fs" />
</ItemGroup>
<ItemGroup>
<None Include="paket.references" />
</ItemGroup>
<Import Project="..\..\.paket\Paket.Restore.targets" />
<?xml version="1.0" encoding="utf-8"?>
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>netcoreapp3.1</TargetFramework>
<AutoGenerateBindingRedirects>true</AutoGenerateBindingRedirects>
</PropertyGroup>
<ItemGroup>
<ProjectReference Include="../../src/fsharp-bench/fsharp-bench.fsproj" />
</ItemGroup>
<ItemGroup>
<Compile Include="Tests.fs" />
</ItemGroup>
<ItemGroup>
<None Include="paket.references" />
</ItemGroup>
<Import Project="..\..\.paket\Paket.Restore.targets" />
</Project>
\ No newline at end of file
......@@ -12,14 +12,9 @@ let default_head =
(** The basic page layout, emitted as an [`Html string] which Opium can use as a
response *)
let basic_page content =
(* let raw_html = *)
let open Html in
html default_head (body content)
(* |> Format.asprintf "%a" (Html.pp ()) *)
(*
in
`Html raw_html
*)
(* let raw_html = *)
let open Html in
html default_head (body content)
(** Short hand for link formatting *)
let hyper_link name addr = Html.(a ~a:[a_href addr] [txt name])
......@@ -43,7 +38,7 @@ let welcome_page =
let hello_page lang =
let greeting = match lang with
| "中文" -> "你好,世界!"
| "中文" -> "你好,世界!"
| "Deutsch" -> "Hallo, Welt!"
| "English" -> "Hello, World!"
| _ -> "Language not supported :(\nYou can add a language via PR to https://gitlab.com/shonfeder/ocaml_webapp"
......
......@@ -56,10 +56,7 @@ let query_db query req =
(** Collects all the SQL queries *)
module Query = struct
type ('res, 'err) query_result = ('res, [> Caqti_error.call_or_retrieve ] as 'err) result Lwt.t
(*
let add_excerpt
: Caqti_lwt.connection -> Excerpt.t -> (unit, 'err) query_result =
*)
let add_excerpt
: Excerpt.t -> Caqti_lwt.connection -> (unit, 'err) query_result =
let open Excerpt in
......@@ -71,10 +68,6 @@ module Query = struct
record_in
]
(*
let get_excerpts_by_author
: Caqti_lwt.connection -> author:string -> (Excerpt.t list, 'err) query_result =
*)
let get_excerpts_by_author
: author:string -> Caqti_lwt.connection -> (Excerpt.t list, 'err) query_result =
let open Excerpt in
......@@ -87,6 +80,7 @@ module Query = struct
record_out
]
let get_authors
: unit -> Caqti_lwt.connection -> (string list, 'err) query_result =
[%rapper get_many
......@@ -129,8 +123,8 @@ module Migration = struct
let* () = Lwt_io.printf "Running: %s\n" name in
let* pool_result = query_pool (fun c -> migration () c) pool in
match pool_result with
| Ok () -> run migrations pool
| Error err -> Lwt.return (Error err)
| Ok () -> run migrations pool
| Error err -> Lwt.return (Error err)
in
let* pool = Lwt.return (connect ()) in
run migrations pool
......
......@@ -27,10 +27,10 @@ let hello_fallback = get "/hello"
end
let get_excerpts_add = get "/excerpts/add"
begin fun _req ->
begin fun _req ->
let res = Response.of_html Content.add_excerpt_page in
Lwt.return res
end
end
let respond_or_err resp = function
| Ok v -> Response.of_html (resp v)
......@@ -67,41 +67,36 @@ let excerpts_by_author = get "/excerpts/author/:name" begin fun req ->
respond_or_err Content.excerpts_listing_page excerps
end
let get_excerpts req name =
let open Lwt.Syntax in
let* excerpts = Db.Get.excerpts_by_author name req in
let excerpts = match excerpts with
| Error e -> Error e
| Ok xs ->
let x = Excerpt.{ author= "kan"; excerpt= "My excerpt"; source= "my source"; page= Some "23" } in
let xs = x::xs in
let sorted = x::xs |> List.sort (fun a -> fun b -> String.compare a.Excerpt.excerpt b.excerpt) in
Ok (sorted) in
Lwt.return excerpts
let fortunes = get "/fortunes" begin fun req ->
let open Lwt.Syntax in
let* excerpts = Db.Get.excerpts_by_author "kan" req in
let excerpts = match excerpts with
| Error e -> Error e
| Ok xs ->
let excerpt = Excerpt.{ author= "kan"; excerpt= "My excerpt"; source= "my source"; page= Some "23" } in
let xs = excerpt::xs in
let sorted = List.sort (fun a -> fun b -> String.compare a.Excerpt.excerpt b.excerpt) xs in
Ok (sorted) in
let* excerpts = get_excerpts req "kan" in
Lwt.return (respond_or_err Content.excerpts_listing_page excerpts)
end
end
let fortunes_json = get "/fortunes-json" begin fun req ->
let open Lwt.Syntax in
let* excerpts = Db.Get.excerpts_by_author "kan" req in
let excerpts = match excerpts with
| Error e -> Error e
| Ok xs ->
let excerpt = Excerpt.{ author= "kan"; excerpt= "My excerpt"; source= "my source"; page= Some "23" } in
let xs = excerpt::xs in
let sorted = List.sort (fun a -> fun b -> String.compare a.Excerpt.excerpt b.excerpt) xs in
Ok (sorted) in
let* excerpts = get_excerpts req "kan" in
let res = match excerpts with
| Error e ->
let open Excerpt.Response.Err in
let json = to_yojson { message= e } in
Response.of_json json
| Ok xs ->
let open Excerpt.Response.Ok in
let json = to_yojson { excerpts= xs } in
Response.of_json json in
| Error e ->
let json = Excerpt.Response.Err.to_yojson { message= e } in
Response.of_json json
| Ok xs ->
let json = Excerpt.Response.Ok.to_yojson { excerpts= xs } in
Response.of_json json in
Lwt.return res
end
end
let excerpts = get "/excerpts" begin fun req ->
let open Lwt.Syntax in
......
......@@ -21,6 +21,7 @@ depends: [
"fmt" {>= "0.8.8"}
"logs" {>= "0.7.0"}
"archi-lwt" {>= "0.1.0"}
"reweb" {dev}
"utop" {dev}
"ocaml-lsp-server" {dev}
"ocamlformat" {dev}
......@@ -41,3 +42,6 @@ build: [
"@doc" {with-doc}
]
]
pin-depends: [
[ "reweb" "https://github.com/yawaramin/re-web#master" ]
]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment