ocamlTW/database.ml at develop · anthonyhtyao/ocamlTW · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
open Lwt

(* madaque with Lwt *)

module Lwt_thread = struct
  include Lwt
  include Lwt_chan
end
module Lwt_PGOCaml = PGOCaml_generic.Make(Lwt_thread)
module Lwt_Query = Query.Make_with_Db(Lwt_thread)(Lwt_PGOCaml)


(* connected to database *)

let alive_dbs = ref []

let get_db() : unit Lwt_PGOCaml.t Lwt.t =
  Lwt_PGOCaml.connect ~database:"ocamltw" ~user:"postgres" () >>=
  (fun dbh -> alive_dbs := dbh::!alive_dbs; Lwt.return dbh)

let close_dbs() =
  let _ = List.map Lwt_PGOCaml.close !alive_dbs in
  alive_dbs := []

(* Tables (we don't create them here) *)

let theme = <:table< theme (
  id bigint NOT NULL,
  title text NOT NULL,
  label text NOT NULL
  )>>

let category = <:table< category (
  id bigint NOT NULL,
  theme bigint NOT NULL,
  title text,
  label text,
  article bigint,
  previous bigint,
  next bigint
  )>>

(* TODO : change created and lastmodified's type to timestamptz*)
let article = <:table< article (
  id bigint NOT NULL,
  created timestamp NOT NULL,
  lastmodified timestamp NOT NULL,
  category bigint NOT NULL,
  title text NOT NULL,
  abstract text,
  content text NOT NULL,
  slg text NOT NULL,
  previous bigint,
  next bigint,
  ord bigint NOT NULL
  )>>

let table = <:table< users (
  login text NOT NULL,
  password text NOT NULL
)>>


(* Interact with the database *)

let detail_of_theme_id id =
  get_db () >>= (fun dbh ->
    Lwt_Query.view_one dbh
    <:view< { title = tem_.title ; label = tem_.label} |
              tem_ in $theme$; tem_.id = $int64:id$; >>)

let detail_of_theme_title title =
  get_db () >>= (fun dbh ->
    Lwt_Query.view_one dbh
    <:view< { id = tem_.id ; label = tem_.label} |
              tem_ in $theme$; tem_.title = $string:title$; >>)

let detail_of_category id =
  get_db () >>= (fun dbh ->
    Lwt_Query.view_one dbh
    <:view< { theme = cat_.theme ;
              title = cat_.title ;
              label = cat_.label ;
              article = cat_.article } |
              cat_ in $category$;
              cat_.id = $int64:id$; >>)

let chapters_of_theme theme_id =
  get_db () >>= (fun dbh ->
    Lwt_Query.view dbh
    <:view< { id = cat_.id ;
              title = cat_.title ;
              label = cat_.label ;
              article = cat_.article } |
              cat_ in $category$ ;
              cat_.theme = $int64:theme_id$; >>)

let find_light_article_slg slg =
  get_db () >>= (fun dbh ->
    Lwt_Query.view_one dbh
    <:view< { id = art_.id ;
              created = art_.created;
              lastmodified = art_.lastmodified;
              title = art_.title ;
              category = art_.category } |
              art_ in $article$ ;
              art_.slg = $string:slg$ ; >>)

let find_light_article_id id =
  get_db () >>= (fun dbh ->
    Lwt_Query.view_one dbh
    <:view< { title = art_.title ;
              abstract = art_.abstract;
              slg = art_.slg } |
              art_ in $article$ ;
              art_.id = $int64:id$ ; >>)

let find_article_slg slg =
  get_db () >>= (fun dbh ->
    Lwt_Query.view_one dbh
    <:view< { id = art_.id ;
              created = art_.created;
              lastmodified = art_.lastmodified;
              title = art_.title ;
              content = art_.content ;
              category = art_.category;
              previous = art_.previous;
              next = art_.next } |
              art_ in $article$ ;
              art_.slg = $string:slg$ ; >>)

let find_article_id id =
  get_db () >>= (fun dbh ->
    Lwt_Query.view_one dbh
    <:view< { title = art_.title ;
              created = art_.created;
              lastmodified = art_.lastmodified;
              abstract = art_.abstract;
              content = art_.content ;
              previous = art_.previous ;
              next = art_.next ;
              slg = art_.slg } |
              art_ in $article$ ;
              art_.id = $int64:id$ ; >>)

let articles_of_theme theme_id =
  get_db () >>= (fun dbh ->
    Lwt_Query.view dbh
    <:view< { id = art_.id } order by art_.ord |
              art_ in $article$ ;
              cat_ in $category$ ;
              cat_.theme = $int64:theme_id$ ;
              cat_.id = art_.category ;>>)

let articles_of_chapter chapter_id ar_id =
  get_db () >>= (fun dbh ->
    Lwt_Query.view dbh
    <:view< { id = art_.id } order by art_.ord |
              art_ in $article$ ;
              art_.category = $int64:chapter_id$ ;
              art_.id <> $int64:ar_id$ ;>>)