forked from urweb/upo
-
Notifications
You must be signed in to change notification settings - Fork 0
/
auth.ur
374 lines (322 loc) · 15.9 KB
/
auth.ur
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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
(* Generic authentication backed by a database table *)
open Bootstrap
style alert_fixed
signature S = sig
con groups :: {Unit}
val whoami : transaction (option string)
val whoamiWithMasquerade : transaction (option string)
val getUser : transaction string
val getUserWithMasquerade : transaction string
val requireUser : transaction unit
val masqueradeAs : string -> transaction unit
val unmasquerade : transaction unit
val inGroup : variant (mapU unit groups) -> transaction bool
val inGroupWithMasquerade : variant (mapU unit groups) -> transaction bool
val requireGroup : variant (mapU unit groups) -> transaction unit
val getGroup : variant (mapU unit groups) -> transaction string
val getGroupWithMasquerade : variant (mapU unit groups) -> transaction string
val inGroups : dummy ::: {Unit} -> folder dummy
-> $(mapU (variant (mapU unit groups)) dummy) -> transaction bool
val requireGroups : dummy ::: {Unit} -> folder dummy
-> $(mapU (variant (mapU unit groups)) dummy) -> transaction unit
val getGroups : dummy ::: {Unit} -> folder dummy
-> $(mapU (variant (mapU unit groups)) dummy) -> transaction string
val getGroupsWithMasquerade : dummy ::: {Unit} -> folder dummy
-> $(mapU (variant (mapU unit groups)) dummy) -> transaction string
functor Masquerade(N : sig
con fs :: {Type}
con tab :: Name
val query : sql_query [] [] [tab = fs] []
val fl : folder fs
val render : $fs -> xbody
val target : $fs -> transaction page
end) : Ui.S0
end
functor Make(M : sig
con name :: Name
con key :: {Type}
con groups :: {Unit}
con others :: {Type}
constraint [name] ~ key
constraint ([name] ++ map (fn _ => ()) key) ~ groups
constraint ([name] ++ map (fn _ => ()) key ++ groups) ~ others
table users : ([name = string] ++ key ++ mapU bool groups ++ others)
val underlying : transaction (option $([name = string] ++ key))
val defaults : option $(mapU bool groups ++ others)
val allowMasquerade : option (list (variant (mapU unit groups)))
val requireSsl : bool
val accessDeniedErrorMessage : xbody
val fls : folder key
val flg : folder groups
val flo : folder others
val injs : $(map sql_injectable key)
val injo : $(map sql_injectable others)
val eqs : $(map eq key)
end) = struct
open M
cookie masquerade : string
val eqs' = @Record.eq eqs fls
val anyToSet = @fold [fn _ => bool] (fn [nm ::_] [u ::_] [r ::_] [[nm] ~ r] _ => True) False fls
con schema = [Users = [name = string] ++ key ++ mapU bool groups ++ others]
fun variantToExp (g : variant (mapU unit groups))
: sql_exp schema schema [] bool =
@@match [mapU unit groups] [sql_exp schema schema [] bool] g
(@fold [fn gs => gso :: {Unit} -> [gso ~ gs] => [[name = string] ++ key ++ others ~ gso ++ gs] => $(mapU (unit -> sql_exp [Users = [name = string] ++ key ++ mapU bool (gs ++ gso) ++ others] [Users = [name = string] ++ key ++ mapU bool (gs ++ gso) ++ others] [] bool) gs)]
(fn [nm ::_] [u ::_] [gs ::_] [[nm] ~ gs]
(acc : gso :: {Unit} -> [gso ~ gs] => [[name = string] ++ key ++ others ~ gso ++ gs] => $(mapU (unit -> sql_exp [Users = [name = string] ++ key ++ mapU bool (gs ++ gso) ++ others] [Users = [name = string] ++ key ++ mapU bool (gs ++ gso) ++ others] [] bool) gs))
[gso ::_] [gso ~ [nm] ++ gs] [[name = string] ++ key ++ others ~ gso ++ [nm] ++ gs] =>
{nm = fn () => (SQL users.{nm})}
++ acc [[nm] ++ gso])
(fn [gso ::_] [gso ~ []] [[name = string] ++ key ++ others ~ gso] => {}) flg [[]] ! !)
fun whoami' masq =
data <- underlying;
case data of
None => return None
| Some data =>
mq <- (if masq then getCookie masquerade else return None);
case mq of
Some mq =>
(case allowMasquerade of
None => error <xml>Masquerade not allowed</xml>
| Some [] => error <xml>allowMasquerade is empty.</xml>
| Some gs =>
b <- List.existsM (fn g =>
bo <- oneOrNoRowsE1 (SELECT ({variantToExp g})
FROM users
WHERE users.{name} = {[data.name]});
return (bo = Some True)) gs;
if b then
return (Some mq)
else
error accessDeniedErrorMessage)
| None =>
if anyToSet then
inDb <- oneOrNoRows1 (SELECT users.{{key}}
FROM users
WHERE users.{name} = {[data.name]}
AND {@Sql.easy_where [#Users] ! !
injs fls (data -- name)});
case inDb of
None =>
alreadyPresent <- oneRowE1 (SELECT COUNT( * ) > 0
FROM users
WHERE {@Sql.easy_where [#Users] ! !
injs fls (data -- name)});
if alreadyPresent then
dupName <- oneRowE1 (SELECT COUNT( * ) > 0
FROM users
WHERE users.{name} = {[data.name]});
if dupName then
error <xml>Duplicate user name</xml>
else
@@Sql.easy_update'' [key] [[name = _]] [_] [_] ! ! injs {name = _} fls _
users (data -- name) (data --- key);
return (Some data.name)
else
(case defaults of
None => return None
| Some defaults =>
dupName <- oneRowE1 (SELECT COUNT( * ) > 0
FROM users
WHERE users.{name} = {[data.name]});
if dupName then
error <xml>Duplicate user name</xml>
else
@@Sql.easy_insert [[name = _] ++ key ++ mapU bool groups ++ others] [_]
({name = _} ++ injs ++ injo ++ @map0 [fn _ => sql_injectable bool] (fn [u ::_] => _) flg)
(@Folder.cons [name] [_] ! (@Folder.concat ! (@Folder.mp flg)
(@Folder.concat ! flo fls)))
users (data ++ defaults);
return (Some data.name))
| Some r => return (Some data.name)
else
inDb <- oneRowE1 (SELECT COUNT( * ) > 0
FROM users
WHERE users.{name} = {[data.name]}
AND {@Sql.easy_where [#Users] ! !
injs fls (data -- name)});
if inDb then
return (Some data.name)
else
case defaults of
None => return None
| Some defaults =>
dupName <- oneRowE1 (SELECT COUNT( * ) > 0
FROM users
WHERE users.{name} = {[data.name]});
if dupName then
error <xml>Duplicate user name</xml>
else
@@Sql.easy_insert [[name = _] ++ key ++ mapU bool groups ++ others] [_]
({name = _} ++ injs ++ injo ++ @map0 [fn _ => sql_injectable bool] (fn [u ::_] => _) flg)
(@Folder.cons [name] [_] ! (@Folder.concat ! (@Folder.mp flg)
(@Folder.concat ! fls flo)))
users (data ++ defaults);
return (Some data.name)
val whoami = whoami' False
val whoamiWithMasquerade = whoami' True
val getUser =
o <- whoami;
case o of
None => error <xml>{accessDeniedErrorMessage} (not logged in)</xml>
| Some s => return s
val getUserWithMasquerade =
o <- whoamiWithMasquerade;
case o of
None => error <xml>{accessDeniedErrorMessage} (not logged in)</xml>
| Some s => return s
val requireUser =
o <- whoami;
case o of
None => error <xml>{accessDeniedErrorMessage} (not logged in)</xml>
| Some _ => return ()
fun inGroup g =
u <- whoami;
case u of
None => return False
| Some u =>
bo <- oneOrNoRowsE1 (SELECT ({variantToExp g})
FROM users
WHERE users.{name} = {[u]});
return (case bo of
None => False
| Some b => b)
fun inGroupWithMasquerade g =
u <- whoamiWithMasquerade;
case u of
None => return False
| Some u =>
bo <- oneOrNoRowsE1 (SELECT ({variantToExp g})
FROM users
WHERE users.{name} = {[u]});
return (case bo of
None => False
| Some b => b)
fun requireGroup g =
b <- inGroup g;
if b then
return ()
else
error accessDeniedErrorMessage
fun getGroup g =
u <- whoami;
case u of
None => error accessDeniedErrorMessage
| Some u =>
bo <- oneOrNoRowsE1 (SELECT ({variantToExp g})
FROM users
WHERE users.{name} = {[u]});
case bo of
Some True => return u
| _ => error accessDeniedErrorMessage
fun getGroupWithMasquerade g =
u <- whoamiWithMasquerade;
case u of
None => error accessDeniedErrorMessage
| Some u =>
bo <- oneOrNoRowsE1 (SELECT ({variantToExp g})
FROM users
WHERE users.{name} = {[u]});
case bo of
Some True => return u
| _ => error accessDeniedErrorMessage
fun inGroups [dummy] (fl : folder dummy) (gs : $(mapU _ dummy)) =
u <- whoami;
case u of
None => return False
| Some u =>
bo <- oneOrNoRowsE1 (SELECT ({@foldUR [variant (mapU unit groups)] [fn _ => sql_exp schema schema [] bool]
(fn [nm ::_] [r ::_] [[nm] ~ r] g e =>
(SQL {e} OR {variantToExp g}))
(SQL FALSE) fl gs})
FROM users
WHERE users.{name} = {[u]});
return (Option.get False bo)
fun requireGroups [dummy] (fl : folder dummy) (gs : $(mapU _ dummy)) =
b <- @inGroups fl gs;
if b then
return ()
else
error accessDeniedErrorMessage
fun getGroups [dummy] (fl : folder dummy) (gs : $(mapU _ dummy)) =
u <- whoami;
case u of
None => error accessDeniedErrorMessage
| Some u =>
bo <- oneOrNoRowsE1 (SELECT ({@foldUR [variant (mapU unit groups)] [fn _ => sql_exp schema schema [] bool]
(fn [nm ::_] [r ::_] [[nm] ~ r] g e =>
(SQL {e} OR {variantToExp g}))
(SQL FALSE) fl gs})
FROM users
WHERE users.{name} = {[u]});
case bo of
Some True => return u
| _ => error accessDeniedErrorMessage
fun getGroupsWithMasquerade [dummy] (fl : folder dummy) (gs : $(mapU _ dummy)) =
u <- whoamiWithMasquerade;
case u of
None => error accessDeniedErrorMessage
| Some u =>
bo <- oneOrNoRowsE1 (SELECT ({@foldUR [variant (mapU unit groups)] [fn _ => sql_exp schema schema [] bool]
(fn [nm ::_] [r ::_] [[nm] ~ r] g e =>
(SQL {e} OR {variantToExp g}))
(SQL FALSE) fl gs})
FROM users
WHERE users.{name} = {[u]});
case bo of
Some True => return u
| _ => error accessDeniedErrorMessage
val unmasquerade = clearCookie masquerade
fun masqueradeAs u =
case allowMasquerade of
None => error <xml>Masquerading is not enabled.</xml>
| Some [] => error <xml>allowMasquerade is empty.</xml>
| Some gs =>
b <- List.existsM inGroup gs;
if b then
setCookie masquerade {Value = u,
Expires = None,
Secure = requireSsl}
else
error accessDeniedErrorMessage
functor Masquerade(N : sig
con fs :: {Type}
con tab :: Name
val query : sql_query [] [] [tab = fs] []
val fl : folder fs
val render : $fs -> xbody
val target : $fs -> transaction page
end) = struct
open N
type a = {Rows : list $fs,
ShowAlert : source bool}
val create =
rs <- queryL1 query;
sa <- source False;
return {Rows = rs, ShowAlert = sa}
fun onload _ = return ()
fun render ctx me = <xml>
<table class="bs-table">
{List.mapX (fn r => <xml>
<tr><td><a link={target r}
onclick={fn _ => set me.ShowAlert True}>{N.render r}</a></td></tr>
</xml>) me.Rows}
</table>
<div dynClass={b <- signal me.ShowAlert;
return (if b then
CLASS "alert-fixed"
else
CLASS "d-none")}>
<h3>Masquerading!</h3>
<h4>Before resuming any further admin activities (beside more masquerades), please <b>reload</b> this page.</h4>
</div>
</xml>
fun notification _ _ = <xml></xml>
fun buttons _ _ = <xml></xml>
val ui = {Create = create,
Onload = onload,
Render = render,
Notification = notification,
Buttons = buttons}
end
end