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
module Button = struct
type t = { content : string }
let render button index =
[%string
"<meta property='fc:frame:button:%{index#Int}' content='%{button.content}'/>"]
;;
end
type button = Button.t
module Frame = struct
type t =
{ title : string
; image_extra_data : string
; post_extra_data : string
; buttons : button list
; input : string option
}
let render frame base_url =
let buttons = List.mapi (fun i btn -> i + 1, btn) frame.buttons in
let buttons =
List.fold_left (fun acc (i, btn) -> acc ^ Button.render btn i) "" buttons
in
let image_url =
base_url ^ "/image/" ^ string_of_float (Unix.time ()) ^ "/" ^ frame.image_extra_data
in
let input_tag =
match frame.input with
| Some input ->
[%string "<meta property='fc:frame:input:text' content='%{input}' />"]
| None -> ""
in
let post_url = base_url ^ "/post/" ^ frame.post_extra_data in
[%string
{|<!DOCTYPE html>
<html>
<head>
<meta property='og:title' content='%{frame.title}'/>
<meta property='og:image' content='%{image_url}' />
<meta property='fc:frame' content='vNext' />
<meta property='fc:frame:image' content='%{image_url}'/>
<meta property='fc:frame:post_url' content='%{post_url}' />
%{input_tag}
%{buttons}
</head>
</html>|}]
;;
end
type frame = Frame.t
module Action = struct
type t =
{ button_index : int [@key "buttonIndex"]
; input_text : string option [@default None] [@key "inputText"]
; fid : int
}
[@@deriving yojson { strict = false }]
end
type action = Action.t
type post = { untrusted_data : Action.t [@key "untrustedData"] }
[@@deriving yojson { strict = false }]
module Server = struct
let start
(base_url : string)
(port : int)
(frame_handler : unit -> frame)
(post_handler : action -> string -> frame)
(image_handler : string -> string)
=
let handler _con req body =
let open Cohttp in
let path = req |> Request.uri |> Uri.path in
let path = List.tl (String.split_on_char '/' path) in
let base_path = base_url |> Uri.of_string |> Uri.path in
let base_path = List.tl (String.split_on_char '/' base_path) in
let path = List.filteri (fun i p -> (List.nth_opt base_path i) <> (Some p)) path in
match path with
| [ "frame" ] ->
Cohttp_lwt_unix.Server.respond_string
~status:`OK
~body:(Frame.render (frame_handler ()) base_url)
()
| [ "image"; _; data ] ->
let = Cohttp.Header.init_with "Content-Type" "image/svg+xml" in
let = Cohttp.Header.add headers "Cache-Control" "no-cache" in
Cohttp_lwt_unix.Server.respond_string
~status:`OK
~body:(image_handler data)
~headers
()
| [ "post"; data ] ->
let open Lwt.Syntax in
let* body = Cohttp_lwt.Body.to_string body in
let json = Yojson.Safe.from_string body in
let action =
match post_of_yojson json with
| Ok post -> post.untrusted_data
| Error e -> raise (Failure e)
in
Cohttp_lwt_unix.Server.respond_string
~status:`OK
~body:(Frame.render (post_handler action data) base_url)
()
| _ -> Cohttp_lwt_unix.Server.respond_string ~status:`OK ~body:"not found" ()
in
let open Lwt.Syntax in
let server = Cohttp_lwt_unix.Server.make ~callback:handler () in
let* ctx = Conduit_lwt_unix.init ~src:"0.0.0.0" () in
let ctx = Cohttp_lwt_unix.Client.custom_ctx ~ctx () in
Cohttp_lwt_unix.Server.create ~ctx ~mode:(`TCP (`Port port)) server
;;
end
module Utils = struct
let sanitize_text txt =
let buf = Buffer.create (String.length txt) in
let () =
String.iter
(fun c ->
match c with
| '&' -> Buffer.add_string buf "&"
| '<' -> Buffer.add_string buf "<"
| '>' -> Buffer.add_string buf ">"
| '"' -> Buffer.add_string buf """
| '\'' -> Buffer.add_string buf "'"
| c -> Buffer.add_char buf c)
txt
in
Buffer.contents buf
;;
end